|
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: 39168 (0x9900)
Types: TextFile
Names: »mains4txold «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »mains4txold «
begin
<* fgs 1988.09.23 mainstat page ...1 ...*>
comment:
mainstat (jr, eli, fgs)
mainstat is a diagnostic tool for printing statistical informa-
tion and testoutput from the ioc/ida, lan/ifp, fpa main processses
(rc8000) or the scc processes (rc4000).
mainstat may print as well 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 (<param>)
0
<param> ::= main.<mainname>/
addr.<mainaddr>/
devno.<devno> /
dump.<dumpfile>/
test.<yesno> /
rc4000.<yesno>
<mainname> ::= name of main process
<mainaddr> ::= address of main process
<devno> ::= device number of main process
<dumpfile> ::= name of system dump file
<yesno> ::= yes / no default : no
The main process specification is obligatory, either by name, by
address or by device number.
If a <dumpfile> is specified, the statistical information is taken
from the supposed monitor dump area in the file, else it is taken
from the monitor memory.
If test.yes is specified, test records are rinted, else not
(test.no is default).
If rc4000.yes is specified, the main process is supposed to be an
scc main process (default is rc4000.no).
\f
<* fgs 1988.09.23 mainstat page ...2 ...*>
mainstat may terminate with the error messages:
***mainstat, call
the call does not have any parameters
***mainstat, syntax
the call does not follow the syntax
***mainstat, parameter unknown
the call contains an unknown parameter
***mainstat, error in call
the call does not follow the syntax
***mainstat, main parameter missing
the call does not specify a main process
***mainstat, no testbuffer
the process specified has no testbuffer
***mainstat, mainprocess unknown
the main process specified does not exist
***mainstat, mainprocess not found
the main process specification didnt lead to a main
process
;
\f
<* fgs 1988.09.23 mainstat page ...3 ...*>
procedure error (errortype);
value errortype; integer errortype;
begin
write(out, <:<10>***:>, progname, <:, :>,
case errortype of (
<*1*> <:call:>,
<*2*> <:syntax:>,
<*3*> <:parameter unknown:>,
<*4*> <:main parameter missing:>,
<*5*> <:no testbuffer:>,
<*6*> <:main process unknown:>,
<*7*> <:main process not found:>,
<*8*> <:address illegal:>,
<*9*> <:devno illegal:>),
<:<10>:>);
if errortype = 1 then
write (out,
"nl", 2,
<:call :
*
(outfile) = mainstat (<param>)
0
<param> ::= main.<mainname>/
addr.<mainaddr>/
devno.<devno> /
dump.<dumpfile>/
test.<yesno> /
rc4000.<yesno>
<mainname> ::= name of main process
<mainaddr> ::= address of main process
<devno> ::= device number of main process
<dumpfile> ::= name of system dump file
<yesno> ::= yes / no default : no
:>, "nl", 1);
errorbits := 3;
goto stop;
end procedure error;
\f
<* fgs 1988.09.23 mainstat page ...4 ...*>
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;
\f
<* fgs 1988.09.23 mainstat page ...5 ...*>
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;
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 *> <::>,
\f
<* fgs 1988.09.23 mainstat page ...6 ...*>
<* 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
<* fgs 1988.09.23 mainstat page ...7 ...*>
<* 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
<* fgs 1988.09.23 mainstat page ...8 ...*>
if kind = 20 <*ioc/ida main*> then
real (case i of (
<* 1 *> <:area - message received:>,
<* 2 *> <:area - message at setup entry:>,
<* 3 *> <:area - message to controller:>,
<* 4 *> <::>,
<* 5 *> <::>,
<* 6 *> <:disk - message received:>,
<* 7 *> <:disk - message at setup entry:>,
<* 8 *> <:disk - message to controller:>,
<* 9 *> <::>,
<* 10 *> <::>,
<* 11 *> <:tape - message received:>,
<* 12 *> <:tape - message at setup entry:>,
<* 13 *> <:tape - message to controller:>,
<* 14 *> <::>,
<* 15 *> <::>,
<* 16 *> <:main - message at setup entry:>,
<* 17 *> <:main - message to controller:>,
<* 18 *> <::>,
<* 19 *> <::>,
<* 20 *> <::>,
<* 21 *> <::>,
<* 22 *> <::>,
<* 23 *> <::>,
<* 24 *> <:adp - message received:>,
<* 25 *> <::>,
<* 26 *> <::>,
<* 27 *> <::>,
<* 28 *> <::>,
<* 29 *> <::>,
<* 30 *> <::>,
<* 31 *> <::>,
<* 32 *> <::>,
<* 33 *> <::>,
<* 34 *> <::>,
<* 35 *> <::>,
<* 36 *> <::>,
<* 37 *> <::>,
<* 38 *> <::>,
<* 39 *> <::>,
<* 40 *> <::>,
<* 41 *> <::>,
\f
<* fgs 1988.09.23 mainstat page ...9 ...*>
<* 42 *> <::>,
<* 43 *> <::>,
<* 44 *> <::>,
<* 45 *> <:controller acknowledge:>,
<* 46 *> <:comm. area - rc8000 to controller:>,
<* 47 *> <:comm. area - controller to rc8000:>,
<* 48 *> <::>,
<* 49 *> <::>,
<* 50 *> <::>,
<* 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 *> <::>,
\f
<* fgs 1988.09.23 mainstat page ...10...*>
<* 80 *> <::>,
<* 81 *> <::>,
<* 82 *> <::>,
<* 83 *> <::>,
<* 84 *> <::>,
<* 85 *> <::>,
<* 86 *> <::>,
<* 87 *> <::>,
<* 88 *> <::>,
<* 89 *> <::>,
<* 90 *> <::>,
<* 91 *> <::>,
<* 92 *> <::>,
<* 93 *> <::>,
<* 94 *> <::>,
<* 95 *> <::>
))
else
\f
<* fgs 1988.09.23 mainstat page ...11...*>
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 *> <::>,
<* 41 *> <::>,
<* 42 *> <::>,
\f
<* fgs 1988.09.23 mainstat page ...12...*>
<* 43 *> <::>,
<* 44 *> <::>,
<* 45 *> <::>,
<* 46 *> <::>,
<* 47 *> <::>,
<* 48 *> <::>,
<* 49 *> <::>,
<* 50 *> <::>,
<* 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 *> <::>,
\f
<* fgs 1988.09.23 mainstat page ...13...*>
<* 81 *> <::>,
<* 82 *> <::>,
<* 83 *> <::>,
<* 84 *> <::>,
<* 85 *> <::>,
<* 86 *> <::>,
<* 87 *> <::>,
<* 88 *> <::>,
<* 89 *> <::>,
<* 90 *> <::>,
<* 91 *> <::>,
<* 92 *> <::>,
<* 93 *> <::>,
<* 94 *> <::>,
<* 95 *> <::>
));
end inittexts;
\f
<* fgs 1988.09.23 mainstat page ...14...*>
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
<* fgs 1988.09.23 mainstat page ...15...*>
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
<* fgs 1988.09.23 mainstat page ...16...*>
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 ready 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
<* fgs 1988.09.23 mainstat page ...17...*>
comment: start of program;
integer i, j, l, call, pda, mpd, rpd, tpd, dl, inx, oldinx,
devno, mainkind, monrelease, off;
boolean testpr, flag4000, coredump, testoutput;
integer array descr (1:3), oldtestmask (1:5), mess, dummyia (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, dz1 (256, 1, stderror);
integer
procedure stack_current_output (file_name);
long array file_name ;
begin
integer result ;
result := 1 shift 2; <*1<2 <=> 1 segment, temporary*>
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
<* fgs 1988.09.23 mainstat page ...18...*>
comment: check and interprete parameters in call;
begin
integer first_param, 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*>;
\f
<* fgs 1988.09.23 mainstat page ...19...*>
monrelease := mpd := 0;
devno := -1;
coredump := flag4000 := testpr := testoutput := false;
movestring (mainname, 1, <::>);
movestring (dumparea, 1, <::>);
firstparam := paramno;
for sepleng := system (4, increase (paramno), param)
while sepleng = 4 shift 12 + 10 do
begin <*next parameter set*>
call := 0;
for i := 1 step 1 until 7 do
if param (1) = real ( case i of (
<:main:>,
<:addr:>,
<:devno:>,
<:dump:>,
<:test:>,
<:rc4000:>,
<:testo:> add 'u' )) then
begin
call := i;
i := 7;
end;
if call > 0 then
begin <*known parameter read*>
sepleng := system (4, increase (paramno), param);
if (call = 2
or call = 3) and sepleng <> 8 shift 12 + 4
or (call = 1
or call > 3) and sepleng <> 8 shift 12 + 10 then
error (2); <*syntax*>
end;
case (call + 1) of
begin
error (3); <*unknown parameter*>
begin <*main*>
tofrom (mainname, param, 8);
mpd := 0;
devno := -1;
end <*main*>;
begin <*addr*>
if param (1) <= 0 then
error (8);
mpd := param (1);
movestring (mainname, 1, <::>);
devno := -1;
end <*addr*>;
begin <*devno*>
if param (1) < 0 then
error (9);
devno := param (1);
movestring (mainname, 1, <::>);
mpd := 0;
end <*devno*>;
\f
<* fgs 1988.09.23 mainstat page ...20...*>
begin <*dump*>
coredump := true;
tofrom (dumparea, param, 8); <*dump*>
end <*dump*>;
begin <*test*>
if param (1) <> real <:yes:> and
param (1) <> real <:no:> then
error (2)
else
testpr := param (1) = real <:yes:>;
end <*test*>;
begin <*rc4000*>
if param (1) <> real <:yes:> and
param (1) <> real <:no:> then
error (2)
else
flag4000 := param (1) = real <:yes:>;
end <*test*>;
testoutput := true; <*testout*>
end <*case*>;
end while;
<**********************>
if testoutput then
write (out,
"nl", 1, <:after a while : :>,
"nl", 1, <:call = :>, call,
"nl", 1, <:main = :>, mainname,
"nl", 1, <:addr = :>, mpd,
"nl", 2, <:devno = :>, devno,
"nl", 1, <:area = :>, dumparea,
"nl", 1, <:dump = :>, if coredump then <:true:> else <:false:>,
"nl", 1, <:test = :>, if testpr then <:true:> else <:false:>,
"nl", 1, <:4000 = :>, if flag4000 then <:true:> else <:false:>,
"nl", 1, <:pno. = :>, paramno,
"nl", 1, <:f.st = :>, firstparam);
if paramno = firstparam + 1 then
error (1); <*no parameters*>
if mainname (1) = real <::> and
mpd = 0 and
devno = -1 then
error (4); <*no main name*>
call :=
if not coredump then
(if not flag4000 then 1 else 2)
else
(if not flag4000 then 3 else 4);
<**********************>
if testoutput then
write (out,
"nl", 1, <:call = :>, call);
\f
<* fgs 1988.09.23 mainstat page ...21...*>
if coredump then
begin
integer array ia (1:10);
integer field kind, ifi, iff;
rpd := tpd := 0;
open (dz , 4, dumparea, 0);
open (dz1, 4, dumparea, 0);
ia (1) := 0;
if monitor (42, dz, 1, ia) <> 0
or mpd//512 >= ia (1) <*size*> then error (7);
if mpd > 0 then
begin <*main addr specified*>
setposition (dz, 0, mpd//512);
inrec6 (dz, mpd mod 512);
inrec6 (dz, 2);
kind := 2;
main_kind := dz.kind;
if main_kind <> 80 <*fpa main*> and
main_kind <> 20 <*ioc main*> and
main_kind <> 24 <*ssp main*> and
main_kind <> 26 <*lan main*> then
error (7);
<*addr wins over name*>
ifi := 2;
for iff := 2 step 2 until 8 do
begin <*name, word by word*>
inrec6 (dz, 2);
mainname.iff := dz.ifi;
end;
<***************>
if testoutput then
write (out,
"nl", 1, <:address wins over name, name = :>, mainname);
end <*main addr specified*>;
\f
<* fgs 1988.09.23 mainstat page ...22...*>
if -,flag4000 then
begin <*rc8000 coredump*>
integer field ifi, iff;
integer array ia (0:1);
real array name_found (1:2);
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, 64);
ifi:= 4; ia(0) := dz.ifi;
ifi:= 6; ia(1) := dz.ifi;
ifi := 26; monrelease := dz.ifi;
setposition (dz, 0, ia(0)//512);
inrec6 (dz, ia(0) mod 512);
ifi:=2;
if devno = -1 then
begin <*find by name*>
for i := 0 step 2 until ia(1)-ia(0)-2 do
begin
inrec6 (dz, 2);
pda := dz.ifi;
setposition (dz1, 0, pda // 512);
inrec6 (dz1, pda mod 512);
inrec6 (dz1, 2);
mainkind := dz1.ifi;
for iff := 2 step 2 until 8 do
begin <*next word of name*>
inrec6 (dz1, 2);
name_found.iff := dz1.ifi;
end;
<**************>
if testoutput then
write (out,
"nl", 1, <:name found = :>, namefound);
\f
<* fgs 1988.09.23 mainstat page ...23...*>
if name_found (1) = main_name (1) and
name_found (2) = main_name (2) then
begin <*main name found*>
mpd := pda ;
devno := i // 2;
if main_kind <> 80 <*fpa main*> and
main_kind <> 20 <*ioc main*> and
main_kind <> 24 <*ssp main*> and
main_kind <> 26 <*lan main*> then
error (7);
inrec6 (dz, 2); rpd := dz.ifi;
inrec6 (dz, 2); tpd := dz.ifi;
i := ia (1) - ia (0);
end;
end for i;
end else
begin <*find by devno*>
setposition (dz, 0, (ia (0) + 2 * devno) // 512);
inrec6 (dz, (ia (0) + 2 * devno) mod 512);
inrec6 (dz, 2);
pda := dz.ifi;
setposition (dz1, 0, pda // 512);
inrec6 (dz1, pda mod 512);
inrec6 (dz1, 2);
mainkind := dz1.ifi;
for iff := 2 step 2 until 8 do
begin <*next word of name*>
inrec6 (dz1, 2);
name_found.iff := dz1.ifi;
end;
tofrom (mainname, namefound, 8);
if main_kind <> 80 <*fpa main*> and
main_kind <> 20 <*ioc main*> and
main_kind <> 24 <*ssp main*> and
main_kind <> 26 <*lan main*> then
error (7);
mpd := pda;
inrec6 (dz, 2); rpd := dz.ifi;
inrec6 (dz, 2); tpd := dz.ifi;
end <*find by devno*>;
if mpd = 0 then
error (7); <*main not found*>
end <*not flag4000*>;
end <*coredump*> else
\f
<* fgs 1988.09.23 mainstat page ...24...*>
begin <*core*>
integer array ia (0:1);
integer array field iaf;
iaf := -2;
<*get monitor release*>
system (5) move core :(64, dummyia);
monrelease := dummyia (1);
if mpd = 0 and
devno = -1 then
begin <*find by name*>
open (z, 0, mainname ,0);
mpd:=monitor(4,z,0,ia.iaf);
close(z,true);
end <*find by name*> else
if devno >= 0 then
begin <*find by devno*>
system(5,74,ia.iaf);
begin
integer array devnametable(0:(ia(1)-ia(0))/2);
system(5,ia(0),devnametable.iaf);
mpd := devnametable (devno);
end;
end;
if mpd > 0 then
system (5, mpd, ia.iaf) 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 <*ioc main*> and
main_kind <> 24 <*sspcmain*> and
main_kind <> 26 <*lan main*> then
error (7);
if mpd > 0 then
system (5) move core :(mpd + 2, mainname);
if -,flag4000 then
begin
system(5,74,ia.iaf);
begin
integer array devnametable(0:(ia(1)-ia(0))/2);
system(5,ia(0),devnametable.iaf);
for i:=0 step 1 until (ia(1)-ia(0))/2 do
if devnametable(i)=mpd then
begin
devno := i;
rpd := devnametable(i+1);
tpd := devnametable(i+2);
end;
end;
end;
end;
end;
\f
<* fgs 1988.09.23 mainstat page ...25...*>
comment: print statistics;
write(out,
"nl", 2,
if not flag4000 and monrelease>= 80 shift 12 + 0 then
<:rc9000-10:>
else
if not flag4000 then
<:rc8000:>
else
<:rc4000:>);
if not coredump then
write (out,
<:, memory:>)
else
write (out,
<:, dump.:>, dumparea);
if monrelease > 0 then
write (out,
<:, monitor release : :>, <<d>,
monrelease shift (-12), <:.:>, monrelease extract 12);
write (out,
if flag4000 then
<:, scc:>
else
if main_kind = 80 then
<:, fpa:>
else
if main_kind = 20 and monrelease < 80 shift 12 + 0 then
<:, ida:>
else
if main_kind = 20 then
<:, ioc:>
else
if main_kind = 24 and monrelease < 80 shift 12 + 0 then
<:, ssp:>
else
if main_kind = 24 then
<:, ssp:>
else
if main_kind = 26 and monrelease < 80 shift 12 + 0 then
<:, ifp:>
else
if main_kind = 26 then
<:, lan:>
else
<::>,
<: : :>, <<d>,
"nl", 2, <:name of main process : :>, mainname,
"nl", 1, <:process description address : :>, mpd,
"nl", 1, <:device number : :>, devno,
"nl", 1);
\f
<* fgs 1988.09.23 mainstat page ...26...*>
off := if monrelease < 15 shift 12 + 0 then 80 else 122;
<**********************>
if testoutput then
write (out,
"nl", 1, <:monitor release = :>, monrelease shift (-12), <:.:>,
<<d>, monrelease extract 12 ,
"nl", 1, <:offset = :>, off);
case call of
begin
begin <*core rc8000*>
integer array core(0:12);
integer array field iaf;
iaf := -2;
if main_kind = 80 <*fpa main*> then
begin
system(5,rpd+54,core.iaf);
write_stat_rec (out, rpd, core);
system(5,tpd+54,core.iaf);
write_stat_tr (out, tpd, core);
end else
begin <*ioc/lan/ssp*>
system (5, mpd + off, core.iaf);
write_stat_main (out, mpd, core);
end;
end;
\f
<* fgs 1988.09.23 mainstat page ...27...*>
<*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 + off) // 512);
inrec6 (dz, (mpd + off) 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
<* fgs 1988.09.23 mainstat page ...28...*>
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
\f
<* fgs 1988.09.23 mainstat page ...29...*>
else
begin
comment: get pointers from core;
i:=1;
open(z, 0, string mainname(increase(i)), 0);
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", 2);
for i := 1 step 1 until (if main_kind < 80 then 2 else 4) do
begin
write (out, "sp", 8);
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;
\f
<* fgs 1988.09.23 mainstat page ...30...*>
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*>
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
<* fgs 1988.09.23 mainstat page ...31...*>
comment: get and print testbuffer;
if descr(2)-descr(3) <= 0 then error (5);
<*testoutput bliver ikke enabled igen, men testbufferen eksisterer*>
<*jo heller ikke *>
write(out, "nl", 3,
<:testbuffer:<10> :>,
<:bufferpointers:<10> :>,
<:first: :>, descr(3), <:, last: :>, descr(2), <:, next: :>, descr(1),
"nl", 3);
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);
integer array field iaf;
iaf := -2;
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
\f
<* fgs 1988.09.23 mainstat page ...32...*>
else
begin <*-,coredump*>
system(5, descr(3), core.iaf);
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;
\f
<* fgs 1988.09.23 mainstat page ...33...*>
stop:
if out_file (1) <> long <::> then
unstack_current_output;
end;
▶EOF◀