|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 26880 (0x6900)
Types: TextFile
Names: »mainstat3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »mainstat3tx «
begin
message: mainstat, 1984.10.08;
comment:
mainstat (jr, eli, fgs).
mainstat is a diagnostic tool for printing statistical informa-
tion and testoutput from the fpa , ida or ifp main processses (rc8000)
or the scc processes (rc4000).
mainstat may as well print directly from the core as from a file
containing a core picture. when printing directly from core the
generation of testoutput is disabled for a moment.
mainstat is called in the following way:
<outfile> = mainstat <proc spec> <function>
<proc spec> ::= core8000.<name(fpa/ida/ifp mainproc)>
core4000.<name(scc mainproc)>
dump8000.<dump file>.<proc desc addr(fpa/ida/ifp mainproc)>
dump4000.<dump file>.<proc desc addr(scc proc)>
<function> ::= <empty>
test.yes
test.no
the <proc spec> field is used to define the type of the computer
(rc8000/rc4000) and where the statistical informations shall
be printed from (core or a core dump). the <function> field is used
to specify whether the test records shall be printed, - the default
value is 'test.no'.
mainstat may terminate with the error messages:
***mainstat, error in call
the call does not follow the syntax
***mainstat, no testbuffer
the process specified has no testbuffer
***mainstat, mainprocess unknown
the fpa- or scc-process specified does not exist
***mainstat, mainprocess not found
the fpa- or scc-process specification didnt lead to a main
process
\f
;
procedure error (errortype);
value errortype; integer errortype;
begin
write(out, <:<10>***:>, progname, <:, :>,
case errortype of (
<*1*> <:error in call:>,
<*2*> <:no testbuffer:>,
<*3*> <:mainprocess unknown:>,
<*4*> <:mainprocess not found:>),
<:<10>:>);
if errortype = 1 then
write (out,
"nl", 2,
<: call :
(<outfile>=)
mainstat <procspec> <function>
<procspec> = core8000.<name fpa, ida or ifp main proc>
core4000.<name scc main proc>
dump8000.<area>.<addr fpa, ida or ifp main proc>
dump4000.<area>.<addr scc main proc>
<function> = <empty>
test.yes
test.no (default)
:>, "nl", 1);
errorbits := 3;
goto stop;
end procedure error;
procedure fparecout(kind, buf, addr);
value kind;
integer array buf; integer kind, addr;
begin
comment: prints the testrecord stored in <buf> starting at index <addr>.
at return, <addr> points to the first index after the record;
own boolean notfirst;
own long oldtime;
integer type, length, last, i, j;
long time; real day,hms; long field t;
procedure inittexts (kind, texts);
value kind; integer kind;
real array texts;
begin
comment: initializes textinformation corresponding to testrecord-type;
integer i;
for i:= 0 step 1 until 95 do texts(i):= real <::>;
oldtime:=0;
comment: individual texts may be inserted here;
\f
if -,flag4000 then
for i:=1 step 1 until 95 do
texts (i) :=
if kind = 80 <*fpa main*> then
real (case i of (
<* 1 *> <:main: message buffer received:>,
<* 2 *> <:main: master clear received:>,
<* 3 *> <:main: call receiver(start):>,
<* 4 *> <:main: call transmitter(transmit):>,
<* 5 *> <:main: call transmitter(master clear):>,
<* 6 *> <:main: call receiver(master clear):>,
<* 7 *> <:main: stop testput:>,
<* 8 *> <:main: start receive:>,
<* 9 *> <:main: check receive result:>,
<* 10 *> <::>,
<* 11 *> <::>,
<* 12 *> <:main: start transmit:>,
<* 13 *> <:main: check transmit result:>,
<* 14 *> <::>,
<* 15 *> <::>,
<* 16 *> <:enter subprocess:>,
<* 17 *> <:return from subprocess:>,
<* 18 *> <::>,
<* 19 *> <::>,
<* 20 *> <::>,
<* 21 *> <::>,
<* 22 *> <::>,
<* 23 *> <::>,
<* 24 *> <:rec: start io (io function):>,
<* 25 *> <:rec: start wait:>,
<* 26 *> <:rec: start io (channel program):>,
<* 27 *> <:rec: after receive (channel program):>,
<* 28 *> <:rec: interrupt:>,
<* 29 *> <:rec: error:>,
<* 30 *> <:rec: after receive (header):>,
<* 31 *> <:rec: return to mainproc:>,
<* 32 *> <:trm: execute message received:>,
<* 33 *> <:trm: start transmit receive:>,
<* 34 *> <:trm: start wait:>,
<* 35 *> <:trm: after transmit (channel program):>,
<* 36 *> <:trm: interrupt:>,
<* 37 *> <:trm: after transmit (various):>,
<* 38 *> <:trm: after transmit (header):>,
<* 39 *> <:trm: return to mainproc:>,
<* 40 *> <::>,
<* 41 *> <::>,
<* 42 *> <::>,
<* 43 *> <::>,
<* 44 *> <::>,
<* 45 *> <::>,
<* 46 *> <::>,
<* 47 *> <::>,
<* 48 *> <::>,
<* 49 *> <::>,
<* 50 *> <::>,
\f
<* 51 *> <::>,
<* 52 *> <::>,
<* 53 *> <::>,
<* 54 *> <::>,
<* 55 *> <::>,
<* 56 *> <::>,
<* 57 *> <::>,
<* 58 *> <::>,
<* 59 *> <::>,
<* 60 *> <::>,
<* 61 *> <::>,
<* 62 *> <::>,
<* 63 *> <::>,
<* 64 *> <::>,
<* 65 *> <::>,
<* 66 *> <::>,
<* 67 *> <::>,
<* 68 *> <::>,
<* 69 *> <::>,
<* 70 *> <::>,
<* 71 *> <::>,
<* 72 *> <:host: entry0 (message):>,
<* 73 *> <:host: lookup process (input area:>,
<* 74 *> <:host: entry1 (message):>,
<* 75 *> <:host: entry1 (output buffer):>,
<* 76 *> <:host: entry2 (host proc desc):>,
<* 77 *> <::>,
<* 78 *> <::>,
<* 79 *> <::>,
<* 80 *> <:host: entry3 (message):>,
<* 81 *> <::>,
<* 82 *> <::>,
<* 83 *> <::>,
<* 84 *> <:host: entry4 (rec area in main):>,
<* 85 *> <:host: entry4, create (proc desc):>,
<* 86 *> <:host: entry4, create (trm area in main):>,
<* 87 *> <:host: entry4, error:>,
<* 88 *> <:host: entry4, remove (sub proc desc):>,
<* 89 *> <:host: entry4 (message):>,
<* 90 *> <:host: linkup local (message):>,
<* 91 *> <::>,
<* 92 *> <::>,
<* 93 *> <::>,
<* 94 *> <:host: remove subprocess:>,
<* 95 *> <::>
))
else
\f
real (case i of (
<* 1 *> <::>,
<* 2 *> <::>,
<* 3 *> <::>,
<* 4 *> <::>,
<* 5 *> <::>,
<* 6 *> <::>,
<* 7 *> <::>,
<* 8 *> <::>,
<* 9 *> <::>,
<* 10 *> <::>,
<* 11 *> <::>,
<* 12 *> <::>,
<* 13 *> <::>,
<* 14 *> <::>,
<* 15 *> <::>,
<* 16 *> <::>,
<* 17 *> <::>,
<* 18 *> <::>,
<* 19 *> <::>,
<* 20 *> <::>,
<* 21 *> <::>,
<* 22 *> <::>,
<* 23 *> <::>,
<* 24 *> <::>,
<* 25 *> <::>,
<* 26 *> <::>,
<* 27 *> <::>,
<* 28 *> <::>,
<* 29 *> <::>,
<* 30 *> <::>,
<* 31 *> <::>,
<* 32 *> <::>,
<* 33 *> <::>,
<* 34 *> <::>,
<* 35 *> <::>,
<* 36 *> <::>,
<* 37 *> <::>,
<* 38 *> <::>,
<* 39 *> <::>,
<* 40 *> <::>,
<* 40 *> <::>,
<* 41 *> <::>,
<* 42 *> <::>,
<* 43 *> <::>,
<* 44 *> <::>,
<* 45 *> <::>,
<* 46 *> <::>,
<* 47 *> <::>,
<* 48 *> <::>,
<* 49 *> <::>,
<* 50 *> <::>,
\f
<* 51 *> <::>,
<* 52 *> <::>,
<* 53 *> <::>,
<* 54 *> <::>,
<* 55 *> <::>,
<* 56 *> <::>,
<* 57 *> <::>,
<* 58 *> <::>,
<* 59 *> <::>,
<* 60 *> <::>,
<* 61 *> <::>,
<* 62 *> <::>,
<* 63 *> <::>,
<* 64 *> <::>,
<* 65 *> <::>,
<* 66 *> <::>,
<* 67 *> <::>,
<* 68 *> <::>,
<* 69 *> <::>,
<* 70 *> <::>,
<* 71 *> <::>,
<* 72 *> <::>,
<* 73 *> <::>,
<* 74 *> <::>,
<* 75 *> <::>,
<* 76 *> <::>,
<* 77 *> <::>,
<* 78 *> <::>,
<* 79 *> <::>,
<* 80 *> <::>,
<* 81 *> <::>,
<* 82 *> <::>,
<* 83 *> <::>,
<* 84 *> <::>,
<* 85 *> <::>,
<* 86 *> <::>,
<* 87 *> <::>,
<* 88 *> <::>,
<* 89 *> <::>,
<* 90 *> <::>,
<* 91 *> <::>,
<* 92 *> <::>,
<* 93 *> <::>,
<* 94 *> <::>,
<* 95 *> <::>
));
end inittexts;
\f
if -,notfirst then
begin
inittexts (kind, texts);
notfirst:= true;
end;
type:= buf(addr) shift (-12);
length:= (buf(addr) extract 12) shift (-1);
if type<>0 then
begin comment: not dummy record;
t:= 2*addr+4;
if oldtime=0 then oldtime:=buf.t;
time:= buf.t mod 10000;
day := systime(2,buf.t/10000,hms);
write(out, <:<10>type: :>, <<dd>, type, <:, time::>,
<< dd dd dd>, day, hms, <<__zdd.d>, time/10,
<<__+dddd.d>, (buf.t-oldtime)/10,
<:, :>, string texts(type),
<:<10>:>);
oldtime:=buf.t;
last:= addr+length-1;
for i:= addr+3 step 1 until last do
outword(buf(i));
end type<>0;
addr:= addr+length;
end fparecout;
procedure outword(word);
value word; integer word;
begin
integer i;
comment: prints <word> as 24-, 12-, 8- and 3-bit integers;
write(out, false add 32, 5,
<<_-ddddddd>, word, false add 32, 4,
<<__dddd>, word shift (-12), word extract 12,
false add 32, 4,
<<__ddd>, word shift (-16), word shift (-8) extract 8,
word extract 8,<: :>);
for i:=-7 step 1 until 0 do
write( out, <<d>,word shift(3*i) extract 3);
write(out,<:<10>:>);
end outword;
\f
procedure write_stat_rec ( z, proc_descr_addr, ia );
value proc_descr_addr ;
integer proc_descr_addr ;
zone z ;
integer array ia ;
begin
write (z, <<dddd>,
<:<10>statistics of receiver, proc descr addr : :>, proc_descr_addr,
<:<10> blocklength errors : :>, ia (0) extract 12 ,
<:<10> parity errors : :>, ia (1) shift (-12),
<:<10> time out (transmit) : :>, ia (1) extract 12 ,
<:<10> time out (monitor ) : :>, ia (2) shift (-12),
<:<10> abnormal termination : :>, ia (2) extract 12 ,
<:<10> master clear received : :>, ia (3) shift (-12),
<:<10> accept master clear received : :>, ia (3) extract 12 ,
<:<10> block number errors : :>, ia (4) shift (-12),
<:<10>:>);
end write_stat_rec;
procedure write_stat_tr ( z, proc_descr_addr, ia );
value proc_descr_addr ;
integer proc_descr_addr ;
zone z ;
integer array ia ;
begin
write (z, <<dddd>,
<:<10>statistics of transmitter, proc descr addr: :>, proc_descr_addr ,
<:<10> blocklength errors : :>, ia (0) extract 12 ,
<:<10> parity errors : :>, ia (1) shift (-12),
<:<10> time out (transmit) : :>, ia (1) extract 12 ,
<:<10> time out (monitor ) : :>, ia (2) shift (-12),
<:<10> abnormal termination : :>, ia (2) extract 12 ,
<:<10> parity errors (rec ) : :>, ia (3) shift (-12),
<:<10> blocklength errors (rec) : :>, ia (3) extract 12 ,
<:<10> waitprogram terminated : :>, ia (4) shift (-12),
<:<10>:> , <<d ddd ddd>,
<:<10> execution times (in millisecs) : :>,
<:<10> 00 - 05 : :>, ia ( 7),
<:<10> 06 - 10 : :>, ia ( 8),
<:<10> 11 - 20 : :>, ia ( 9),
<:<10> 21 - 40 : :>, ia (10),
<:<10> 41 - 80 : :>, ia (11),
<:<10> 81 - : :>, ia (12),
<:<10><10>:>);
end write_stat_tr;
\f
procedure write_stat_main (z, proc_descr_addr, ia);
value proc_descr_addr ;
zone z ;
integer proc_descr_addr ;
integer array ia ;
begin
long total;
total := (extend ia (1)) shift 24 add ia (2);
write (z, <<d ddd ddd ddd ddd>,
<:<10>statistics of main process, process descr address : :>, proc_descr_addr,
<:<10> no of times controller not able to receive : :>, ia (0),
<:<10> total number of operations to controller : :>, total,
<:<10> number of chained operations to controller : :>, ia (3),
<:<10>:>);
end write_stat_main;
\f
comment: start of program;
integer i, j, l, call, mpd, rpd, tpd, dl, inx, oldinx, mainkind;
boolean testpr, flag4000, coredump;
integer array descr(1:3), oldtestmask(1:5), mess(1:12);
real array dumparea(1:2), mainname(1:2), texts (0:95);
long array progname, outfile , chain_name (1:2);
zone z(1, 1, stderror), dz(256, 1, stderror);
integer
procedure stack_current_output (file_name);
long array file_name ;
begin
integer result ;
result := 2; <*1<1 <=> 1 segment, preferably disc*>
fp_proc (29, 0, out, chain_name); <*stack c o*>
fp_proc (28, result, out, file__name); <*connect *>
if result <> 0 then
fp_proc (30, 0, out, chain_name); <*unstack *>
stack_current_output := result;
end stack_current_output;
procedure unstack_current_output ;
begin
fp_proc (34, 0, out, 25); <*close up*>
fp_proc (79, 0, out, 0); <*terminate*>
fp_proc (30, 0, out, chain_name); <*unstack *>
end unstack_current_output;
procedure enable;
begin
integer i;
getshare (z, mess, 1);
mess (4) := 12 shift 12;
for i := 1 step 1 until 5 do mess ( i+4 ) := oldtestmask (i);
setshare (z, mess, 1);
monitor (16, z, 1, mess); <*send message*>
monitor (18, z, 1, mess); <*wait answer*>
end enable;
\f
comment: check and interprete parameters in call;
begin
integer paramno, sepleng, result;
real array param(1:2);
trapmode := 1 shift 10; <*no end alarm written*>
system (4, 0, out_file);
sepleng :=
system (4, 1, progname);
if sepleng shift (-12) <> 6 <*=*> then
begin <*noleft side, progname is param after programname*>
for i := 1, 2 do
begin
prog_name (i) := out_file (i);
out__file (i) := long <::> ;
param_no := 1 ;
end;
end <*no left side*> else
param_no := 2;
if out_file (1) <> long <::> then
begin <*stack current out and connect*>
result := stack_current_output (out_file);
if result <> 0 then
begin
write (out, "nl", 1, <:***:>, progname, "sp", 1, <:connect :>, outfile,
"sp", 1, case result of (
<:no resources:>,
<:malfunction:>,
<:not user, not exist:>,
<:convention error:>,
<:not allowed:>,
<:name format error:> ));
out_file (1) := long <::>;
end;
end <*stack current out and connect*>;
if system(4, increase (param_no), param) <> 4 shift 12 + 10 then error(1);
call:=0;
if param(1)=real <:core8:> add 48 then call:=1;
if param(1)=real <:core4:> add 48 then call:=2;
if param(1)=real <:dump8:> add 48 then call:=3;
if param(1)=real <:dump4:> add 48 then call:=4;
if call=0 then error(1);
\f
testpr:=false;
flag4000:=if call=1 or call=3 then false else true;
coredump:=if call<3 then false else true;
if system(4, increase (param_no), param) <> 8 shift 12 + 10 then error(1);
if coredump then
begin
real array ra(1:2);
if system(4, increase (param_no), ra) <> 8 shift 12 + 4 then error(1);
mpd:=ra(1);
dumparea(1):=param(1); dumparea(2):=param(2);
end;
begin
real array ra(1:2);
i := system(4, increase (paramno), ra);
if i<>0 then
begin
if i<>4 shift 12 + 10 or ra(1)<>real <:test:> then error(1);
if system(4, paramno, ra) <> 8 shift 12 + 10 then error(1);
if ra(1)=real <:yes:> then testpr:=true
else if ra(1)=real <:no:> then testpr:=false else error(1);
end;
end;
if coredump then
begin
integer array ia (1:10);
integer field kind;
real field name;
i:=1;
rpd := tpd := 0;
open(dz,4,string dumparea(increase(i)),0);
ia (1) := 0;
if monitor (42, dz, 1, ia) <> 0
or mpd//512 >= ia (1) <*size*> then error (4);
setposition(dz, 0, mpd//512);
inrec6(dz, mpd mod 512);
inrec6(dz, 10);
kind := 2;
main_kind := dz.kind;
if main_kind <> 80 <*fpa main*> and
main_kind <> 20 <*ida main*> and
main_kind <> 26 <*ifp main*> then
error (4);
\f
name:=6 ; mainname(1):=dz.name;
name:=10; mainname(2):=dz.name;
if -,flag4000 then
begin
integer field ifi;
integer array ia(0:1);
setposition(dz, 0, 1200//512);
<*some monitor addresses area save in address 1200 ff.*>
<*for coredump purposes *>
<*1200 : name table start *>
<*1202 : first device in name table *>
<*1204 : first area in name table *>
inrec6 (dz, 1200 mod 512);
inrec6(dz, 8);
ifi:=4; ia(0):=dz.ifi;
ifi:=6; ia(1):=dz.ifi;
setposition(dz, 0, ia(0)//512);
inrec6(dz, ia(0) mod 512);
ifi:=2;
for i:=0 step 2 until ia(1)-ia(0)-2 do
begin
inrec6(dz, 2);
if dz.ifi=mpd then
begin
inrec6(dz, 2); rpd:=dz.ifi;
inrec6(dz, 2); tpd:=dz.ifi;
i := ia (1) - ia (0);
end;
end;
if rpd = 0 <*mpd not found in name table*> then error (4);
end <*not flag4000*>;
end <*coredump*> else
\f
begin <*core*>
integer array ia(0:1);
i:=1;
open(z,0,string param(increase(i)),0);
mpd:=monitor(4,z,0,ia);
close(z,true);
if mpd > 0 then
system (5, mpd, ia) else ia (0) := 0;
<*mpd > 0 => ia (0) := kind, mpd = 0 => ia (0) := 0;*>
main_kind := ia (0);
if main_kind <> 80 <*fpa main*> and
main_kind <> 20 <*ida main*> and
main_kind <> 26 <*ifp main*> then
error (4);
mainname(1):=param(1); mainname(2):=param(2);
if -,flag4000 then
begin
system(5,74,ia);
begin
integer array devnametable(0:(ia(1)-ia(0))/2);
system(5,ia(0),devnametable);
for i:=0 step 1 until (ia(1)-ia(0))/2 do
if devnametable(i)=mpd then
begin
rpd:=devnametable(i+1);
tpd:=devnametable(i+2);
end;
end;
end;
end;
end;
\f
comment: print statistics;
i:=1;
write(out,<:<10><10>:>, case call of (
if mainkind = 80 then <:core8000, fpa:> else
if mainkind = 20 then <:core8000, ida:> else
<:core8000, ifp:>,
<:core4000, scc:>,
if mainkind = 80 then <:dump8000, fpa:> else
if mainkind = 20 then <:dump8000, ida:> else
<:dump8000, ifp:>,
<:dump4000, scc:>),
<: testprint:>,
<:<10>name of main process : :>, string mainname (increase (i)),
<:, process description address: :>, mpd, <:<10><10>:>);
case call of
begin
begin <*core rc8000*>
integer array core(0:12);
if main_kind = 80 <*fpa main*> then
begin
system(5,rpd+54,core);
write_stat_rec (out, rpd, core);
system(5,tpd+54,core);
write_stat_tr (out, tpd, core);
end else
begin <*ida/ifp*>
system (5, mpd + 80, core);
write_stat_main (out, mpd, core);
end;
end;
<*core rc4000*>
write (out, <:<10><10>***:>,prog_name, <:, statistics scc mainproc:>,
<: not implemented<10><10>:>);
begin <*dump rc8000*>
integer array field iaf;
iaf := 2;
if main_kind = 80 <*fpa main*> then
begin
setposition (dz, 0, (rpd+54) // 512);
inrec6 (dz, (rpd+54) mod 512);
inrec6 (dz, 10 );
write_stat_rec (out, rpd, dz.iaf);
setposition (dz, 0, (tpd+54) // 512);
inrec6 (dz, (tpd+54) mod 512);
inrec6 (dz, 26 );
write_stat_tr (out, tpd, dz.iaf);
end else
begin <*ida/ifp*>
setposition (dz, 0, (mpd + 80) // 512);
inrec6 (dz, (mpd + 80) mod 512);
inrec6 (dz, 8);
write_stat_main (out, mpd, dz.iaf);
end;
end <*dump rc8000*>;
<*dump rc4000*>
write (out, <:<10><10>***:>, prog_name, <:, statistics scc mainproc:>,
<: not implemented<10><10>:>);
end;
\f
comment: get buffer pointers, from the dumparea or from core;
if coredump then
begin
integer field tbuffirst, tbuftop, tbufcur, ifi;
tbufcur:=24;
tbuftop:=26;
tbuffirst:=if flag4000 then 38 else 28;
setposition(dz, 0, mpd//512);
inrec6(dz, mpd mod 512);
inrec6(dz, 40);
descr(1):=dz.tbufcur;
descr(2):=dz.tbuftop;
descr(3):=dz.tbuffirst;
i:=1;
if flag4000 then
begin
for ifi:=28 step 2 until 34 do
begin
oldtestmask(i):=dz.ifi;
i:=i+1;
end;
end
else
begin
for ifi:=32 step 2 until 38 do
begin
oldtestmask(i):=dz.ifi;
i:=i+1;
end;
end;
end
else
begin
comment: get pointers from core;
i:=1;
open(z, 0, string mainname(increase(i)), 0);
\f
comment: get old testmask and disable generation of
testoutput while the testbuffer and -pointers
are inspected;
if flag4000 then
system(5, mpd+26, oldtestmask)
else
system(5, mpd+30, oldtestmask);
if mainkind<> 80 then
begin <*ida/ifp*>
for i := 3 step 1 until 5 do
old_testmask (i) := 0;
end;
end <*get pointers from core*>;
write (out,
"nl", 2, <:testmask : :>,
"nl", 1);
for i := 1 step 1 until (if main_kind = 20 then 2 else 4) do
begin
write (out, "sp", 19);
l := old_testmask (i);
for j := -23 step 1 until 0 do
write (out, if l shift j extract 1 = 1 then "1" else ".", 1);
write (out, "nl", 1);
end;
write (out, "nl", 1);
if -,testpr then
goto stop;
if -, coredump then
begin <*core*>
getshare(z, mess, 1);
mess(4):= 12 shift 12;
for i := 5 step 1 until 9 do
mess (i) := 0; <*clear testmask*>
setshare(z, mess, 1);
monitor(16, z, 1, mess);
monitor(18, z, 1, mess);
trap (enable2); <*in case of alarm the test mask must be reset*>
\f
system(5, mpd+22, descr);
if flag4000 then
begin
integer array ia(1:1);
system(5, mpd+36, ia);
descr(3):=ia(1);
end;
goto skip_enable2;
enable2:
<*traproutine to enable generation of testoutput*>
enable;
goto stop;
skip_enable2:
trap (enable1); <*in case of alarm the test mask must be reset*>
end <*core*>;
\f
comment: get and print testbuffer;
if descr(2)-descr(3) <= 0 then error(2);
<*testoutput bliver ikke enabled igen, men testbufferen eksisterer*>
<*jo heller ikke *>
write(out, <:<10><10><10>:>, <:testbuffer:<10> :>,
<:bufferpointers:<10> :>,
<:first: :>, descr(3), <:, last: :>, descr(2), <:, next: :>, descr(1),
<:<10><10>:>);
dl:=(descr(2)-descr(3)) shift (-1);
goto skip_enable1;
enable1:
<*traproutine to reset test mask*>
enable;
goto stop;
skip_enable1:
begin
integer array core(0:dl-1);
if -,coredump then
trap (enable3);
comment: read from bs-area into array 'core';
if coredump then
begin
integer field ifi;
ifi:=2;
setposition(dz, 0, descr(3)//512);
inrec6(dz, descr(3) mod 512);
for i:=0 step 1 until dl-1 do
begin
inrec6(dz, 2);
core(i):=dz.ifi;
end;
close (dz, true);
end
else
begin <*-,coredump*>
system(5, descr(3), core);
\f
comment: now testoutput may be enabled again;
trap (0); <*reset traplabel*>
enable;
goto skip_enable3;
enable3:
<*traproutine to reset test mask*>
enable;
goto stop;
skip_enable3:
end;
comment: find first usable entry;
oldinx:= (descr(1)-descr(3)) shift (-1);
for inx:= oldinx step 1 until dl-1 do
begin
integer type;
i:= j:= inx;
l:= 0; type:=0;
for j:= j, j+l while (j<dl and l<>0 and l<512 and type<96) do
begin
type:=core(j) shift (-12);
l:= core(j) extract 12 shift (-1);
end;
if j=dl then inx:= dl;
end;
if inx<>dl then inx:=i;
comment: print out all testrecords;
for i:= inx while i<dl, 0, inx while i<>oldinx do
begin
inx:= i;
fparecout (main_kind, core, inx);
end;
end;
stop:
if out_file (1) <> long <::> then
unstack_current_output;
end;
▶EOF◀