|
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: 33024 (0x8100)
Types: TextFile
Names: »crashtxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦40b1eb8cd⟧
└─⟦this⟧ »crashtxt «
begin
<* %W% (RC International) %G% *>
integer field i,t,s,c,f,j,ver1,ver2;
integer type,l,time,coru,fourth,old,e,file,block,rest,segno,top_seg,low_seg,
lno,maxno,p,q,last_rec,first_rec,x,y,masker,fra,til,
next_first,
tas_top_dump,menu_top_dump,first_menu_dump,first_tas_dump,
d_date,d_time,w0,w1,w2,w3,d_ic,
vers_d,vers_t,first_code,first_proc,last_proc,
noprint_max, area_table_base, area_table_top,
tdescr_pool, tdescr_size, used_tdescr, cl_var,
buffer_index, pool_index;
long field st,tim;
integer array tail(1:10),m_val(1:30,1:30),maxtrue(1:30),
buffer_table(1:10,1:4), pool_table(1:10,1:6);
long min_time,old_time,t_dif;
boolean ch,stk,eb,stop,outfile,next_or_prev,print_menu_name,print_tas_name,
to_from;
boolean array maske(1:30,1:30), noprint(0:1000);
long array p_name,foname,finame(1:3);
real r,v,start_up;
real array txt(1:300), buffer_name, pool_name(0:10);
zone zo,z(128,1,stderror);
zone mdmpz(5000,1,stderror);
zone tdmpz(1024,1,stderror);
procedure read_command;
begin
boolean end_init,end_felt,end_maske;
integer c,i,j,mno,fno,p;
end_init:=false;
next_or_prev:=false;
to_from:=true;
repeat
write(out,<:(?,l,c,m,n,p,k,f,t,o,s,d,a,b,q,+,-,<nl>) -> :>);
setposition(out,0,0);
skip_sp(c);
if c >= '0' and c<='9' then begin
repeatchar(in); c:=10;
to_from:=false;
end
else begin
if c <> '?' then begin
i:=c; while i<>10 do readchar(in,i); <* skip resten af linien *>
end;
end;
if c = 'l' then begin <* list masker *>
if masker=0 then
write(out,<:ingen masker <10>:>)
else begin
write(out,<: :>,
<: type, coru, fourth, p1, p2, p3, p4<10>:>);
for i:=1 step 1 until masker do begin
write(out,<:<10>maske :>,<< dd>,i,<: : :>);
for j:=1 step 1 until 7 do
if maske(i,j) then
write(out,<< ddddd>,m_val(i,j),<:, :>)
else
write(out,<: , :>);
end;
outchar(out,10);
end;
end
else
if c = 'c' then begin <* clear maske *>
for i:=1 step 1 until 30 do
for j:=1 step 1 until 30 do maske(i,j):=false;
for i:=1 step 1 until 30 do maxtrue(i):=0;
masker:=0;
end
else
if c = 'm' then begin <* sæt maske *>
mno:=0;
write(out,<: :>,
<: type, coru, fourth, p1, p2, p3, p4<10>:>);
end_maske:=false;
repeat <* et gennemløb for hver maske *>
fno:=0;
mno:=mno+1;
write(out,<:maske :>,<< d>,mno,<: - :>); setposition(out,0,0);
end_felt:=false;
repeat <* et gennemløb for hvert felt *>
skip_sp(c);
if c<>10 then repeatchar(in);
if c = 10 then begin
if mno-1>masker then masker:=mno-1;
if fno=0 then
end_maske:=end_felt:=true
else
end_felt:=true;
end
else
if c = '*' then begin <* tom felt *>
fno:=fno+1;
maske(mno,fno):=false;
readchar(in,c);
end
else
if c<'0' or c>'9' then begin
write(out,<:*** forkert felt<10>:>);
mno:=mno-1;
readchar(in,c);
end
else
begin
read(in,p); repeatchar(in);
fno:=fno+1;
maske(mno,fno):=true;
m_val(mno,fno):=p;
if p > maxtrue(mno) then maxtrue(mno):=fno;
end;
until end_felt;
until end_maske;
end
else
if c = 'k' then begin
for i:=0 step 1 until noprint_max do noprint(i):=false;
end
else
if c = 'n' then begin
write(out,<:noprint liste : :>); setposition(out,0,0);
repeat
skip_sp(c);
if c <> 10 then begin
repeatchar(in);
read(in,i); repeatchar(in);
if i<=noprint_max then begin
if i>0 then begin
j:=i;
noprint(i):=true;
end
else begin
i:=-i;
for j:=j+1 while j<=i do noprint(j):=true;
end;
end
else begin
write(out,<:<10>number out of range<10>:>);
setposition(out,0,0);
end;
end;
until c=10;
end
else
if c = 'p' then begin
for i:=0 step 1 until noprint_max do begin
if noprint(i) then begin
write(out,<< d>,i);
j:=i;
for j:=j+1 while noprint(j) do;
if j > i+1 then begin
i:=j-1;
write(out,<<-d>,-i);
end;
end
end;
write(out,<:<10>:>);
end
else
if c = 'f' then begin
write(out,<:Fra (:>,<< d>,fra,<:) : :>); setposition(out,0,0);
skip_sp(c);
if c <> 10 then begin
repeatchar(in);
read(in,fra);
end;
end
else
if c = 't' then begin
write(out,<:Til (:>,<< d>,til,<:) : :>); setposition(out,0,0);
skip_sp(c);
if c <> 10 then begin
repeatchar(in);
read(in,til);
end;
end
else
if c = 'o' then begin
write(out,<:Output file : :>); setposition(out,0,0);
readchar(in,c);
if c = 10 then begin
outfile:=false;
outchar(zo,25);
close(zo,true);
end
else
begin
repeatchar(in);
readstring(in,foname,1);
open(zo,4,foname,0);
outfile:=true;
end;
end
else
if c = '+' then begin
next_first:=last_rec;
next_or_prev:=true;
end_init:=true;
end
else
if c = '-' then begin
next_first:=first_rec-18;
next_or_prev:=true;
end_init:=true;
end
else
if c = '?' then begin
skip_sp(c);
if c = 10 then
write(out,<:
l list masker
c clear masker
m sæt masker
n sæt noprint
p list noprint
k slet noprint
f sæt Fra
t sæt Til
o sæt navn på outputfil
s list startup version firstproc
d print fra menu dump
a print fra tas dump
q quit
+ list næste 20 test records
- list forrige 20 test records
nl list udvalgte test records
:>)
else
if c = 'l' then
write(out,<:lister søgemasker<10>:>)
else
write(out,<:ikke beskerver endnu<10>:>);
i:=c; while i<>10 do readchar(in,i); <* skip resten af linien *>
end
else
if c = 's' then begin
if outfile then
write(zo,<:<10>start - up :>,
<< dd dd dd>,systime(4,start_up,start_up),start_up,
<:<10>version :>,vers_d,vers_t,
<:<10>first code = :>,<< ddddddd>,first_code,
<:<10>first proc = :>,<< ddddddd>,first_proc,
<:<10>last proc = :>,<< ddddddd>,last_proc,<:<10>:>)
else
write(out,<:<10>start - up :>,
<< dd dd dd>,systime(4,start_up,start_up),start_up,
<:<10>version :>,vers_d,vers_t,
<:<10>first code = :>,<< ddddddd>,first_code,
<:<10>first proc = :>,<< ddddddd>,first_proc,
<:<10>last proc = :>,<< ddddddd>,last_proc,<:<10>:>);
end
else
if c = 'd' then begin
if outfile then print_menu_dump(zo) else print_menu_dump(out);
end
else
if c = 'a' then begin
print_tas_dump;
end
else
if c = 'b' then begin
write(out,<:buffer tabel:<10>:>,
string buffer_name(0),
<: first last S left<10>:>);
for i:=1 step 1 until buffer_index do
write(out,string buffer_name(i),
<< dddddd>, buffer_table(i,1), buffer_table(i,2),
buffer_table(i,4),
buffer_table(i,3),<:<10>:>);
write(out,<:<10>pool table:<10>:>,
string pool_name(0),
<: pool N S first last left<10>:>);
for i:=1 step 1 until pool_index do
write(out,string pool_name(i),
<< dddddd>, pool_table(i,1), << ddd>, pool_table(i,2),
pool_table(i,3), << dddddd>,pool_table(i,4),
pool_table(i,5), pool_table(i,6),<:<10>:>);
end
else
if c = 10 then
end_init:=true
else
if c = 'q' then
goto FIN;
until end_init;
end;
procedure skip_sp(c); integer c;
begin
repeat
readchar(in,c);
until c<>32;
end;
procedure print_menu_dump(zout); zone zout;
begin
boolean end_pd;
integer c,i,addr,la,fi,lin,nxt,ant;
boolean array field ee;
integer array field ia;
ia:=0;
if print_menu_name then begin
write(out,<:menu dump fil navn : :>); setposition(out,0,0);
readstring(in,p_name,1);
open(mdmpz,4,p_name,0);
monitor(42,mdmpz,i,tail);
menu_top_dump:=tail(1);
inrec6(mdmpz,18);
first_menu_dump:=mdmpz.ia(1); d_date:=mdmpz.ia(2); d_time:=mdmpz.ia(3);
w0:=mdmpz.ia(4); w1:=mdmpz.ia(5);
w2:=mdmpz.ia(6); w3:=mdmpz.ia(7); d_ic:=mdmpz.ia(9);
print_menu_name:=false;
end;
end_pd:=false;
repeat
write(out,<:MENU (d,l,c,a,s,t,p,?<nl>) -> :>); setposition(out,0,0);
skip_sp(c);
if c <> '?' then begin
i:=c; while i<>10 do readchar(in,i); <* skip resten af linien *>
end;
if c = 'd' then begin
write(zout,<:<10>first_proc :>,<< -dddddd>,first_menu_dump,
<:<10>version :>,d_date,d_time,
<:<10>w0 :>,w0,
<:<10>w1 :>,w1,
<:<10>w2 :>,w2,
<:<10>w3 :>,w3,
<:<10>ic :>,d_ic,<:<10>:>);
end
else
if c = 'l' then begin
integer array cdsr(1:pool_table(3,2));
integer nxt, s, c_pool, i;
c_pool:=pool_table(3,1);
nxt:=c_pool+8;
s:=pool_table(3,3);
for i:=1 step 1 until pool_table(3,2) do begin
cdsr(i):=nxt; nxt:=nxt+s;
end;
write(out,<:link : :>); setposition(out,0,0);
read(in,addr);
if addr<>0 and addr < first_proc then addr:=cdsr(addr)+332;
if menu_dump_pos(mdmpz,addr,48) then
write(zout,<:link :>,<< dddd>,addr,
<: (:>,addr - first_menu_dump,<:):>,
<:<10>operation :>,mdmpz.ia(1),mdmpz.ia(2),mdmpz.ia(3),
<:<10>reserve :>,mdmpz.ia(4),mdmpz.ia(5),mdmpz.ia(6),
<:<10>free seg :>,mdmpz.ia(7),mdmpz.ia(8),mdmpz.ia(9),
<:<10>cur_op :>,mdmpz.ia(10),
<:<10>ident :>,mdmpz.ia(11),
<:<10>first_used :>,mdmpz.ia(12) shift (-12),mdmpz.ia(12) extract 12,
<:<10>first_free :>,mdmpz.ia(13) shift (-12),mdmpz.ia(13) extract 12,
<:<10>segments :>,mdmpz.ia(14),<:<10>:>);
end
else
if c = 'c' then begin
integer c_ant;
c_ant:=pool_table(3,2); <* antal cdescr *>
begin
integer array cdsr(1:c_ant);
integer nxt, s, c_pool, i;
c_pool:=pool_table(3,1);
nxt:=c_pool+8;
s:=pool_table(3,3);
for i:=1 step 1 until c_ant do begin
cdsr(i):=nxt; nxt:=nxt+s;
end;
write(out,<:cdescr : :>); setposition(out,0,0);
read(in,addr);
if addr <> 0 then begin
if addr < first_proc then addr:=cdsr(addr);
print_cdescr(zout,addr)
end
else
begin <* list alle *>
if menu_dump_pos(mdmpz,c_pool,8) then begin
nxt:=mdmpz.ia(4);
while nxt<>0 do begin
for i:=1 step 1 until c_ant do if cdsr(i)=nxt then cdsr(i):=0;
if menu_dump_pos(mdmpz,nxt,8) then
nxt:=mdmpz.ia(1)
else
nxt:=0;
end;
write(zout,<:
cdescr id ic ret st ti nx.ac nx.sm nx.mb<10>:>);
for i:=1 step 1 until c_ant do begin
if cdsr(i)<>0 then begin
if menu_dump_pos(mdmpz,cdsr(i),60) then begin
write(zout,<< dddddd>,cdsr(i),<:,:>,
<< dd>,i,<:::>,
<< ddd>,mdmpz.ia(5),
<< dddddd>,mdmpz.ia(1)-first_proc,
mdmpz.ia(17)-first_proc,
<< dd>, mdmpz.ia(4) extract 3, mdmpz.ia(12));
if mdmpz.ia(6)<>mdmpz.ia(7) then
write(zout,<< dddddd>,mdmpz.ia(6))
else
write(zout,<: :>);
if mdmpz.ia(8)<>mdmpz.ia(9) then
write(zout,<< dddddd>,mdmpz.ia(8))
else
write(zout,<: :>);
if mdmpz.ia(10)<>mdmpz.ia(11) then
write(zout,<< dddddd>,mdmpz.ia(10))
else
write(zout,<: :>);
outchar(zout,10);
end
else
goto SL;
end; <* end cdsr(i) <> 0 *>
end; <* for i:= *>
SL:
end <* read dump ok *>
else write(zout,<:dump area too small<10>:>);
end <* list alle *>
end <* array block *>
end
else
if c = 'a' then begin
write(out,<:area table : base :>, << dd>, area_table_base,
<: : top :>, area_table_top, <:<10>:>);
write(out,<:første, sidste : :>); setposition(out,0,0);
read(in,fi,la);
fi:=(fi//10)*10; lin:=0; ee:=0;
if la>area_table_top then la:=area_table_top;
if menu_dump_pos(mdmpz,area_table_base,area_table_top) then begin
for i:=fi step 1 until la do begin
if lin mod 10 = 0 then begin
write(zout,<:<10>:>,<<ddd>,i,<:: :>); lin:=0;
end;
write(zout,<< dddd>,mdmpz.ee(i+1) extract 12);
lin:=lin+1;
end;
write(zout,<:<10>:>);
end;
end
else
if c = 's' then
begin
write(out,<:første : :>); setposition(out,0,0);
read(in,fi);
lin:=0; ee:=0;
if menu_dump_pos(mdmpz,area_table_base,area_table_top) then begin
for i:=fi, mdmpz.ee(i+1) extract 12 while i<>fi do begin
if lin mod 10 = 0 then begin
write(zout,<:<10>:>); lin:=0;
end;
write(zout,<< dddd>,i);
if i=4095 then goto slt;
lin:=lin+1;
end;
slt:
write(zout,<:<10>:>);
end;
end
else
if c = 't' then begin
integer array field tdes;
real array field uid, tname;
integer t_ant;
integer array tdsr(1:500);
integer nxt, s, t_pool, i;
t_pool:=pool_table(5,1);
t_ant:=pool_table(5,2);
nxt:=t_pool+8;
s:=pool_table(5,3);
for i:=1 step 1 until t_ant do begin
tdsr(i):=nxt; nxt:=nxt+s;
end;
write(out,<:tdescr : :>); setposition(out,0,0);
read(in,addr);
if addr <> 0 then begin
if addr<first_proc then addr:=tdsr(addr);
if menu_dump_pos(mdmpz,addr,tdescr_size) then begin
tdes:=0;
uid:=tdes+6; tname:=tdes+22;
write(zout,<< dddddd>,addr,<:: :>,<< dddddd>,
mdmpz.tdes(2),mdmpz.tdes(3),
<: :>,mdmpz.uid,<< d>,mdmpz.tdes(10),
<< ddddd>, mdmpz.tdes(11),
<< d>,mdmpz.tdes(17),
<< ddddddd>,mdmpz.tdes(18),
<: :>,mdmpz.tname,<:<10>:>);
end;
end
else
begin <* list alle *>
if menu_dump_pos(mdmpz,cl_var,350) then begin
used_tdescr:=mdmpz.ia(89);
end;
write(zout,<:used tdescr :>,<< dd>,used_tdescr,tdescr_pool,
tdescr_size,<:<10>:>);
if menu_dump_pos(mdmpz,tdescr_pool,tdescr_size) then begin
i:=used_tdescr;
while i<>0 do begin
tdes:=(i-tdescr_pool);
uid:=tdes+6; tname:=tdes+22;
write(zout,<< ddd>,i,<: : :>,<< dddddd>,mdmpz.tdes(2),mdmpz.tdes(3),
<: :>,mdmpz.uid,<< d>,mdmpz.tdes(10),
<< ddddd>, mdmpz.tdes(11),
<< d>,mdmpz.tdes(17),
<< ddddddd>,mdmpz.tdes(18),
<: :>,mdmpz.tname,<:<10>:>);
i:=mdmpz.ia(1+(i-tdescr_pool)/2);
end
end;
end
end
else
if c = 'p' then begin
write(out,<:first : :>); setposition(out,0,0);
read(in,fi);
write(out,<:number : :>); setposition(out,0,0);
read(in,ant);
ia:=0;
if menu_dump_pos(mdmpz,fi,ant*2) then begin
for i:=1 step 1 until ant do begin
write(zout,<< -ddddddd>,mdmpz.ia(i));
if i mod 8 = 0 then outchar(zout,10);
end;
write(zout,<:<10>:>);
end;
end
else
if c = '?' then begin
skip_sp(c);
if c = 10 then
write(out,<:
d dump registers
l link
c cdescr
a area table
s spool area
t terminals
p print
? help
:>)
else
write(out,<:ikke beskrevet endnu<10>:>);
i:=c; while i<>10 do readchar(in,i); <* skip resten af linien *>
end
else
if c = 10 then
end_pd:=true;
until end_pd;
end;
procedure print_cdescr(z,addr);
value addr; integer addr;
zone z;
begin
integer array field ia;
ia:=0;
if menu_dump_pos(mdmpz,addr,60) then
write(z,<:cdescr :>,<< -dddddd>,addr,
<:<10>ic :>,mdmpz.ia(1),
<:<10>prio :>,mdmpz.ia(2),
<:<10>t-mask :>,mdmpz.ia(3),
<:<10>type :>,mdmpz.ia(4) extract 3,
<:<10>ident :>,mdmpz.ia(5),
<:<10>run_lst :>,mdmpz.ia(6),mdmpz.ia(7),
<:<10>sem_lst :>,mdmpz.ia(8),mdmpz.ia(9),
<:<10>mbx_lst :>,mdmpz.ia(10),mdmpz.ia(11),
<:<10>:>);
end;
boolean procedure menu_dump_pos(z,p,l);
value p,l; zone z; integer p,l;
begin
integer segno,r,addr;
addr:=p - first_menu_dump;
if addr < 0 then begin
write(out,<<d>,addr,<: not a core addr<10>:>);
menu_dump_pos:=false;
end
else
begin
menu_dump_pos:=true;
segno:=(addr // 1024) * 2;
r:=addr mod 1024;
<*
write(out,<:seg,rest :>,<< dddd>,segno,r,<:<10>:>); setposition(out,0,0);
*>
if segno >= menu_top_dump then begin
write(out,<:adresse uden for dump<10>:>);
menu_dump_pos:=false;
end
else
begin
setposition(z,0,segno);
inrec6(z,r);
inrec6(z,l);
end;
end;
end;
procedure print_tas_dump;
begin
boolean end_pd;
integer c,i,addr,la,fi,lin;
boolean array field ee;
integer array field ia;
ia:=0;
if print_tas_name then begin
write(out,<:tas dump fil navn : :>); setposition(out,0,0);
readstring(in,p_name,1);
open(tdmpz,4,p_name,0);
monitor(42,tdmpz,i,tail);
tas_top_dump:=tail(1);
print_tas_name:=false;
end;
end_pd:=false;
repeat
write(out,<:TAS (t,<nl>) -> :>); setposition(out,0,0);
skip_sp(c);
i:=c; while i<>10 do readchar(in,i); <* skip resten af linien *>
if c = 't' then begin
end
else
if c = 10 then
end_pd:=true;
until end_pd;
end;
boolean procedure tas_dump_pos(z,p,l);
value p,l; zone z; integer p,l;
begin
integer segno,r,addr;
addr:=p - first_tas_dump;
if addr < 0 then begin
write(out,<<d>,addr,<: not a core addr<10>:>);
tas_dump_pos:=false;
end
else
begin
tas_dump_pos:=true;
segno:=(addr // 1024) * 2;
r:=addr mod 1024;
write(out,<:seg,rest :>,<< dddd>,segno,r,<:<10>:>); setposition(out,0,0);
if segno >= tas_top_dump then begin
write(out,<:adresse uden for dump<10>:>);
tas_dump_pos:=false;
end
else
begin
setposition(z,0,segno);
inrec6(z,r);
inrec6(z,l);
end;
end;
end;
procedure skip(no); value no; integer no;
begin
integer i;
setposition(z,0,0);
rest:=inrec6(z,4);
segno:=0;
lno:=0;
for i:=1 step 1 until no do next(false,false);
end;
procedure skriv_tegn(zz,t); value t; integer t; zone zz;
begin
integer ch;
for i:=-16,-8,0 do begin
ch:=(t shift i) extract 8;
if ch<32 or ch>127 then
write(zz,<:(:>,<<d>,ch,<:):>)
else
outchar(zz,ch);
end;
end;
procedure skriv(zout); zone zout;
begin
integer field i;
integer ch;
write(zout,<<dddd>,lno,<:. :>);
if type<281 then write(zout,string txt(type))
else write(zout,<: :>);
write(zout,<<dddd>,type,<: - :>);
t_dif := time - old_time;
old_time := time;
write(zout,<< ddddd>,t_dif);
write(zout,<< ddd>,coru extract 12,<:/:>);
i:=coru shift (-12);
if i < 7 then
write(zout, case i+1 of
( <:C,:>, <:D,:>, <:T,:>, <:M,:>, <:W,:>, <:P,:>, <:R,:> ) )
else write(zout,<<d>,i);
write(zout, << dddddd>,fourth,<:::>);
if type = 101 or type = 275 or type = 278 or type = 279 then begin
for i:=2 step 2 until l do begin
skriv_tegn(zout,z.i);
end;
end
else
if type = 277 or type = 274 then begin
write(zout,<:******:>);
i:=2; skriv_tegn(zout,z.i);
i:=4; write(zout,<< -ddddddd>,z.i);
end
else
if type = 27 or type = 29 then begin
i:=2; write(zout,<< -ddddddd>,z.i);
i:=4; write(zout,<< -ddddddd>,z.i);
i:=6; write(zout,<<dddd>,z.i shift (-12),<:,:>,z.i extract 12);
for i:=8 step 2 until l do begin
write(zout,<< -ddddddd>,z.i);
if i mod 8=0 and i<l then write(zout,<:<10>:>,false add 32,42);
end;
end
else
if type = 41 then begin
for i:=2 step 2 until l do begin
write(zout,<< -ddddddd>,z.i);
if (i+8) mod 16=0 and i<l then write(zout,<:<10> :>);
end;
end
else
if type = 121 or type = 122 then begin
i:=2; write(zout,<<dddd>,z.i shift (-12),<:,:>,z.i extract 12);
for i:=4 step 2 until l do begin
write(zout,<< -ddddddd>,z.i);
if i mod 8=0 and i<l then write(zout,<:<10>:>,false add 32,42);
end;
end
else
if type = 124 then begin
write(zout,<: :>);
for i:=2,4,6,8 do
skriv_tegn(zout,z.i);
write(zout,<:<10>:>,false add 32,42);
for i:=12 step 2 until l do begin
write(zout,<< -ddddddd>,z.i);
if i = 18 then write(zout,<:<10>:>,false add 32,42);
end;
end
else
if type = 130 then begin
write(out,<: :>);
for i:=2,4,6,8 do
skriv_tegn(zout,z.i);
write(zout,<:<10>:>,false add 32,42);
for i:=12 step 2 until l do begin
write(zout,<< -ddddddd>,z.i);
end;
end
else begin
for i:=2 step 2 until l do begin
write(zout,<< -ddddddd>,z.i);
if i mod 8=0 and i<l then write(zout,<:<10>:>,false add 32,42);
end;
end;
outchar(zout,10);
end;
procedure next(prt,b);
value prt,b; boolean prt,b;
begin
integer array field ia;
rep:
<* write(out,<:<10>** rest = :>,<< d>,rest,<:<10>:>); *>
if rest = 0 then begin
if segno = 0 then
segno:=low_seg
else begin
segno:=segno+1;
if segno=top_seg then segno:=1;
if segno=low_seg then begin
l:=0; time:=0; coru:=0; fourth:=0;
type:=1023;
goto exit_next;
end;
end;
<* write(out,<:<10>** seg = :>,<< d>,segno,<:<10>:>); *>
setposition(z,0,segno);
rest:=inrec6(z,4);
if z.tim = 0 then begin
rest:=inrec6(z,rest);
goto rep;
end;
end;
if rest<8 then i:=rest else i:=8;
rest:=inrec6(z,i);
type := z.t extract 12;
if type = 0 then
begin
if rest=0 then goto rep;
rest:=inrec6(z,rest);
goto rep
end;
l:=z.t shift (-12);
time:=z.s;
coru:=z.c;
fourth:=z.f;
if l>rest then begin
write(out,<:<10>trouble :>,l,rest,<:<10>:>);
inrec6(z,rest);
goto rep;
end;
rest:=inrec6(z,l);
if type=1 then begin
if prt then begin
r:=z.st/10000;
write(out,<:<10>start - up :>,
<< dd dd dd>,systime(4,r,r),r,
<:<10>version :>,z.ver1,z.ver2);
start_up := r; vers_d := z.ver1; vers_t := z.ver2;
i:=2; write(out,<:<10>first code = :>,<< ddddddd>,z.i);
first_code := z.i;
i:=12; write(out,<:<10>first proc = :>,<< ddddddd>,z.i);
first_proc := z.i;
i:=14; write(out,<:<10>last proc = :>,<< ddddddd>,z.i);
last_proc := z.i;
write(out,false add 10,2);
end;
goto rep
end
else
if type=40 then begin
if b then begin
ia:=0;
pool_index:=pool_index+1;
pool_table(pool_index,1):=z.ia(3); <* pool addr *>
pool_table(pool_index,2):=z.ia(1); <* number of elements *>
pool_table(pool_index,3):=z.ia(2); <* bufsize *>
pool_table(pool_index,4):=z.ia(3)+8;<* first *>
pool_table(pool_index,5):=z.ia(3)+6+z.ia(1)*z.ia(2); <* last *>
pool_table(pool_index,6):=z.ia(4); <* left *>
end;
<*
goto rep
*>
end
else
if type=41 then begin
if b then begin
ia:=0;
cl_var:=fourth;
area_table_base:=z.ia(79); area_table_top:=z.ia(80);
tdescr_pool:=z.ia(88);
tdescr_size:=z.ia(84) - tdescr_pool;
end;
<*
goto rep
*>
end
else
if type=44 then begin
if b then begin
ia:=0;
buffer_index:=buffer_index+1;
buffer_table(buffer_index,1):=z.ia(2); <* first *>
buffer_table(buffer_index,2):=z.ia(3); <* last *>
buffer_table(buffer_index,3):=z.ia(4); <* left *>
buffer_table(buffer_index,4):=z.ia(3)-z.ia(2)+2; <* size *>
end;
<*
goto rep
*>
end;
exit_next:
lno:=lno+1;
end next;
t:=2; s:=4; c:=6; f:=8;
st:=6; ver1:=8; ver2:=10; old:=0;
tim:=4;
old_time := 0; t_dif:=0;
outfile:=false;
print_menu_name:=true;
print_tas_name:=true;
stop:=false;
for x:=1 step 1 until 30 do
for y:=1 step 1 until 30 do maske(x,y):=false;
for x:=1 step 1 until 30 do maxtrue(x):=0;
masker:=0;
noprintmax:=1000;
for i:=0 step 1 until 1000 do noprint(i):=false;
buffer_index:=0;
pool_index:=0;
<*navne array*>
for i:=1 step 1 until 280 do txt(i):=real( case i of (
<* 1 *> <:start-up:>,<:start-co:>,<:start :>,<:wait :>,<:pass :>,
<* 6 *> <:inspect :>,<:csendmes:>,<:cwaitans:>,<:exit cwa:>,<:cregret :>,
<* 11 *> <:signal :>,<:wait sem:>,<:exit ws :>,<:send let:>,<:inspectm:>,
<* 16 *> <:wait let:>,<:exit wl :>,<:send mes:>,<:wait buf:>,<:exit wb :>,
<* 21 *> <:rel buf :>,<:exit :>,<:answer :>,<:answer a:>,<:message :>,
<* 26 *> <:timer sc:>,<:mes arri:>,<:att answ:>,<:tem mess:>,<:rem ans :>,
<* 31 *> <:creat co:>,<:remov co:>,<:g open :>,<:g lock :>,<:exit gl :>,
<* 36 *> <:wait sle:>,<:exit wsl:>,<:get buf :>,<:answer t:>,<:crt pool:>,
<* 41 *> <:cl var :>,<: :>,<: :>,<: :>,<: :>,
<* 46 *> <: :>,<: :>,<: :>,<: :>,<:crt link:>,
<* 51 *> <:rem link:>,<:adj link:>,<:putop-e :>,<:check op:>,<:releasop:>,
<* 56 *> <:get spoo:>,<:get free:>,<:adjust :>,<:rel_cte :>,<:seg io :>,
<* 61 *> <:look nam:>,<:in mcl n:>,<:rem mcln:>,<:get mseg:>,<: :>,
<* 66 *> <:next :>,<:c spoola:>,<:r spoola:>,<:seg ispo:>,<:ext spoo:>,
<* 71 *> <:cut area:>,<:move :>,<:w-error :>,<: :>,<:new term:>,
<* 76 *> <:searchth:>,<:in sess :>,<:out sess:>,<:unlink s:>,<:get tdat:>,
<* 81 *> <:link th :>,<:ulink th:>,<:link ph :>,<:ulink ph:>,<: :>,
<* 86 *> <: :>,<: :>,<: :>,<:rel op e:>,<:put op e:>,
<* 91 *> <:get f-cb:>,<:dis term:>,<:con term:>,<: :>,<:put op :>,
<* 96 *> <: :>,<: :>,<: :>,<:get abs :>,<: :>,
<* 101*> <:userid :>,<:push :>,<:pop :>,<:crt mcl :>,<:var addr:>,
<* 106*> <:alloc va:>,<:del var :>,<:set var :>,<:wait :>,<:wait op :>,
<* 111*> <:wait ter:>,<:tasc mes:>,<:s-att :>,<:rem ph :>,<:rem th l:>,
<* 116*> <:crt user:>,<:crt ph :>,<:mcl exit:>,<:term th :>,<:direct :>,
<* 121*> <:input op:>,<:output o:>,<:sim in :>,<:ctrl op :>,<:cont mcl:>,
<* 126*> <:answer i:>,<:f8000 in:>,<:send f8 :>,<:f8 read :>,<:term s-w:>,
<* 131*> <:signon :>,<:to_from :>,<: :>,<: :>,<: :>,
<* 136*> <: :>,<: :>,<: :>,<: :>,<:init_td :>,
<* 141*> <:c_read :>,<:c_write :>,<:get t ad:>,<:comp txt:>,<:move txt:>,
<* 146*> <:outtext :>,<:c_outtxt:>,<:write :>,<:erase :>,<:cursor :>,
<* 151*> <:in_text :>,<:rd_char :>,<:rd pass :>,<:strip nl:>,<:strip sp:>,
<* 156*> <: :>,<: :>,<: :>,<: :>,<:run mcl :>,
<* 161*> <:end_th :>,<:ex err 1:>,<:ex err 2:>,<:ex err 3:>,<: :>,
<* 166*> <: :>,<: :>,<: :>,<: :>,<:next op :>,
<* 171*> <:status :>,<: :>,<: :>,<: :>,<: :>,
<* 176*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 181*> <:lette.th:>,<:sear.th :>,<:op_mes :>,<:crt ph :>,<: :>,
<* 186*> <: :>,<:start rm:>,<: :>,<: :>,<: :>,
<* 191*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 196*> <: :>,<: :>,<: :>,<: :>,<:i sysm :>,
<* 201*> <:in strg :>,<:in point:>,<:gen sysm:>,<:w sysm :>,<:find ses:>,
<* 206*> <:search p:>,<:new pass:>,<:new ses :>,<:rem ses :>,<:brk ses :>,
<* 211*> <:kill out:>,<:send att:>,<:get char:>,<: :>,<: :>,
<* 216*> <: :>,<: :>,<: :>,<:start sm:>,<:goto ac :>,
<* 221*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 226*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 231*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 236*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 241*> <: :>,<: :>,<: :>,<: :>,<: :>,
<* 246*> <: :>,<: :>,<: :>,<: :>,<:s rem m :>,
<* 251*> <:wait :>,<:term.ph :>,<:wait_op :>,<:cr-l-m :>,<:rm-l-m :>,
<* 256*> <:lo-l-m :>,<:de-b-u :>,<:search-l:>,<:sent att:>,<:send inp:>,
<* 261*> <:copy :>,<:set nul :>,<:sense-r :>,<:input :>,<:output-s:>,
<* 266*> <:start-i :>,<:adj pool:>,<:adj th-l:>,<:send-ctl:>,<:c-mcl :>,
<* 271*> <:term-dat:>,<:getid :>,<:res-term:>,<:sim in :>,<:i-date :>,
<* 276*> <:answer :>,<:output :>,<:o-date :>,<:s_date :>,<:next_mes:>
));
buffer_name(0):=real <: :>;
buffer_name(1):=real <:signon :>;
buffer_name(2):=real <:term type :>;
buffer_name(3):=real <:mcl table :>;
buffer_name(4):=real <:segment table :>;
buffer_name(5):=real <:area table :>;
buffer_name(6):=real <:core table :>;
buffer_name(7):=real <:core buffer :>;
pool_name(0):=real <: :>;
pool_name(1):=real <:systext :>;
pool_name(2):=real <:event descr :>;
pool_name(3):=real <:cdescr :>;
pool_name(4):=real <:terminal :>;
pool_name(5):=real <:terminal beskr :>;
write(out,<:fil navn : :>);
setposition(out,0,0);
readstring(in,finame,1);
open(z,4,finame,0);
monitor(42,z,i,tail);
top_seg:=tail(1);
min_time:= (extend (-1)) shift (-1);
setposition(z,0,1);
for i:=1 step 1 until top_seg-1 do begin
inrec6(z,512);
if min_time > z.tim and z.tim<>0 then begin
low_seg:=i;
min_time:=z.tim;
end;
end;
<* tæl antal test records *>
setposition(z,0,0);
rest:=inrec6(z,4);
maxno:=0;
segno:=0;
count:
next(false,true);
maxno:=maxno+1;
if type<>1023 then goto count;
setposition(z,0,0);
rest:=inrec6(z,4);
segno:=0;
next(true,false);
write(out,<:<10>Antal test records = :>,<< ddd>,maxno,<:<10>:>);
setposition(out,0,0);
fra:=maxno-18; til:=maxno;
repeat
read_command;
if -,next_or_prev then begin
if to_from then begin
write(out,<:Fra, Til :>); setposition(out,0,0);
end;
readchar(in,i);
if i = 10 then begin
first_rec:=fra; last_rec:=til;
end
else
begin
repeatchar(in);
read(in,first_rec);
read(in,last_rec);
end;
end
else begin
first_rec:=next_first;
last_rec:=next_first+18;
end;
if last_rec > maxno then last_rec:=maxno;
if first_rec<1 then first_rec:=1;
skip(first_rec-1);
for q:=first_rec step 1 until last_rec do begin
next(false,false);
if noprint_max >= type then begin
if noprint(type) then begin
goto next_rec;
end;
end;
if masker = 0 then begin
if outfile then skriv(zo) else skriv(out);
end
else
for x:=1 step 1 until masker do begin
if maske(x,1) then begin
if m_val(x,1) <> type then goto skrv;
end;
if maske(x,2) then begin
if m_val(x,2) <> coru extract 12 then goto skrv;
end;
if maske(x,3) then begin
if m_val(x,3) <> fourth then goto skrv;
end;
i:=0;
y:=l/2;
if 3+y < maxtrue(x) then goto skrv;
for p:=4 step 1 until 3+y do begin
i:=i+2;
if maske(x,p) then begin
if (m_val(x,p) <> z.i) then goto skrv;
end;
end;
if outfile then skriv(zo) else skriv(out);
goto next_rec;
skrv:
end;
next_rec:
if type = 1023 then goto try_next;
end;
try_next:
until false;
FIN:
end;
▶EOF◀