|
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: 8448 (0x2100)
Types: TextFile
Names: »fpatestout«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »fpatestout«
(elit=algol
elit)
begin
comment: print fpa testoutput from core.
eli, 28.05.1976, 16.44,
jenh, 01.01.1977, 00.00,
jr, 09.02.1977, 14.00;
procedure fparecout(buf, addr);
integer array buf; integer 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;
real array texts(0:95);
integer type, length, last, i, j;
long time; real day,hms; long field t;
procedure inittexts(texts);
real array texts;
begin
comment: initializes textinformation corresponding to testrecord-type;
integer i;
for i:= 0 step 1 until 95 do texts(i):= real <::>;
comment: individual texts may be inserted here;
for i:= 1 step 1 until 39 do
texts(i):= real (case i of(
<* 1 *> <:mainproc: send message:>,
<* 2 *> <:mainproc: master clear received:>,
<* 3 *> <:mainproc: call receiver:>,
<* 4 *> <:mainproc: call transmitter:>,
<* 5 *> <:mainproc: call transmitter (master clear):>,
<* 6 *> <:mainproc: call receiver (master clear):>,
<* 7 *> <::>,
<* 8 *> <:mainproc: start receive:>,
<* 9 *> <:mainproc: check receive result:>,
<* 10 *> <::>,
<* 11 *> <::>,
<* 12 *> <:mainproc: start transmit:>,
<* 13 *> <:mainproc: check transmit result:>,
<* 14 *> <::>,
<* 15 *> <::>,
<* 16 *> <:enter subproc:>,
<* 17 *> <:return from subproc:>,
<* 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:>
));
end inittexts;
if -,notfirst then
begin
inittexts(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;
time:= buf.t mod 10000;
day := systime(2,buf.t/10000,hms);
write(out, <:<10>type: :>, <<_dd>, type, <: :>,
<: time: :>,
<< dd dd dd>, day, hms, <:.:>, <<dddd>, time,<:<10>:>);
if texts(type)<>real <::> then
write(out, <:text: :>, string texts(type), <:<10>:>);
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- and 8-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;
comment: start of program;
real mainname, recname, trmname, name;
integer i, j, l, pd, dl, inx, oldinx, setmask;
boolean flag4000, coredump;
integer array descr(1:3), oldtestmask(1:4), mess(1:12), workarr(1:1);
real array console(1:2);
zone z(1,1,stderror), zcons(50,1,stderror);
zone dz(256,1,stderror);
coredump:= false;
flag4000:=false;
open(dz, 4, <:dump8000:>, 0);
comment: get name of console;
system(7,i,console);
j:= 1;
open(zcons, 0, string console(increase(j)), 0);
write(zcons, <:<10>select process:
1: main, transmitter, receiver
2: main3500, trm3500, rec3500
3: main3600, trm3600, rec3600
4: print from 'post mortem' dump: dump8000<10>:>);
setposition(zcons, 0, 0);
read(zcons, i);
if i=4 then
begin comment: post mortem dump;
setposition(zcons, 0, 0);
write(zcons, <:proc. descr. address of mainproc: :>);
setposition(zcons, 0, 0);
read(zcons, pd);
coredump:= true;
mainname:= real <:post mortem:>;
end;
close(zcons, true);
if coredump then
begin
comment: get buffer pointers;
integer field tbuffirst, tbuftop, tbufcur, ifi;
tbuffirst:= 27;
tbuftop:= 25;
tbufcur:= 23;
setposition(dz, 0, pd//512);
inrec6(dz, pd mod 512);
inrec6(dz, 40);
descr(1):= dz.tbufcur;
descr(2):= dz.tbuftop;
descr(3):= dz.tbuffirst;
i:= 1;
for ifi:= 31 step 2 until 37 do
begin
oldtestmask(i):= dz.ifi;
i:= i+1;
end;
end else
begin
mainname:= real (case i of (<:main:>, <:main3500:>, <:main3600:>));
trmname:= real (case i of (<:transmitter:>, <:trm3500:>, <:trm3600:>));
recname:= real (case i of (<:receiver:>, <:rec3500:>, <:rec3600:>));
setmask:= 12 shift 12;
if -,flag4000 then
begin
comment: print statistics information;
integer array core(1:30);
for name:= recname, trmname do
begin
write(out, <:<10><10><10>:>, string name, <:___statistics<10>:>);
open(z, 0, string name, 0);
pd:= monitor(4,z,0,descr);
if pd=0 then
begin
write(out, <:<10>:>, string name, <:___:>);
system(9, 0, <:<10>no proc:>);
end;
system(5, pd+22, core);
for i:= 1 step 1 until 27 do
outword(core(i));
close(z, true);
end;
end block for statistics;
comment: print testbuffer;
open(z, 0, string mainname, 0);
pd:= monitor(4, z, 0, descr);
if pd=0 then
begin
write(out, <:<10>:>, string mainname, <:___:>);
system(9, 0, <:<10>no proc:>);
end;
comment: get old testmask and disable generation of
testoutput while the testbuffer and -pointers
are inspected;
if flag4000 then
system(5, pd+26, oldtestmask)
else
system(5, pd+30, oldtestmask);
getshare(z, mess, 1);
mess(4):= setmask;
mess(5):= mess(6):= mess(7):= mess(8):= 0;
setshare(z, mess, 1);
j:= monitor(16, z, 1, mess);
monitor(18, z, 1, mess);
system(5, pd+22, descr);
if flag4000 then
begin
system(5, pd+36, workarr);
descr(3):=workarr(1);
end;
if descr(1)=0 then system(9, 0, <:<10>no buffer:>);
end;
write(out, <:<10><10><10>:>, string mainname,
<:___testbuffer<10><10>:>,
<:bufferpointers: :>,
<<_ddddddd>, descr(1), descr(2), descr(3),
<:<10><10>:>,
<:testmask: :>,
<:<10>:>);
for i:= 1 step 1 until 4 do
begin
write(out, false add 32, 19);
l:= oldtestmask(i);
for j:= -23 step 1 until 0 do
write(out, if l shift j extract 1=1 then <:1:> else <:.:>);
write(out, <:<10>:>);
end;
write(out, <:<10>:>);
dl:= (descr(2) - descr(3)) shift (-1);
begin
integer array core(0:dl-1);
if coredump then
begin comment: read from bs-area into array 'core';
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;
end else
begin
system(5, descr(3), core);
comment: now testoutput may be enabled again;
getshare(z, mess, 1);
mess(4):= setmask;
for i:= 1, 2, 3, 4 do mess(i+4):= oldtestmask(i);
setshare(z, mess, 1);
j:= monitor(16, z, 1, mess);
monitor(18, z, 1, mess);
end;
comment: find first usable entry;
oldinx:= (descr(1)-descr(3)) shift (-1);
for inx:= oldinx step 1 until dl-1 do
begin
i:= j:= inx;
l:= 0;
for j:= j, j+l while (j<dl and l<>0) do
l:= core(j) extract 12 shift (-1);
if j=dl then inx:= dl;
end;
inx:= if inx=dl then 0 else i;
for i:= inx while i<dl, 0, inx while i<>oldinx do
begin
inx:= i;
fparecout(core, inx);
end;
end
end
▶EOF◀