|
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: »tascrashttt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦40b1eb8cd⟧
└─⟦this⟧ »tascrashttt «
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, cdsr_ant;
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),
cdsr,cdsrid(1:1000);
long min_time,old_time,t_dif;
boolean ch,stk,eb,stop,outfile,next_or_prev,print_menu_name,print_tas_name,
to_from, print_søg_name;
boolean array maske(1:30,1:30), noprint(0:1000);
long array s_name,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);
zone sdmpz(128,1,stderror);
boolean procedure new_line(zout,no); zone zout; integer no;
begin
boolean r_val;
integer c;
r_val:=false;
no:=no+1;
if outfile then
outchar(zout,10)
else begin
if no>22 then begin
no:=0;
write(out,<:<10>more ? :>); setposition(out,0,0);
readchar(in,c); setposition(in,0,0);
r_val:=(if c=10 then false else true);
end
else outchar(zout,10)
end;
new_line:=r_val;
end;
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,e,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
e print søgdump data
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 = 'e' then begin
if outfile then print_søg_dump(zo) else print_søg_dump(out);
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;
integer procedure pmd_command;
begin
integer c,i;
long array cmd(1:1);
repeat
setposition(in,0,0);
write(out,<:MD (h,q,r,l,c,a,s,t,p,b,bt) -> :>); setposition(out,0,0);
readstring(in,cmd,1);
c:=1;
while cmd(1) <> long ( case c of (
<:h:>, <* help *>
<::>, <* nl *>
<:q:>, <* 1: quit *>
<:r:>, <* 2: print dump registers *>
<:l:>, <* 3: print link beskrivelse *>
<:c:>, <* 4: print coroutine beskrivelse *>
<:a:>, <* 5: print area table *>
<:s:>, <* 6: print spool areal *>
<:t:>, <* 7: print terminal beskrivelse *>
<:p:>, <* 8: print fra dump *>
<:b:>, <* 9: print terminal buffer *>
<:bt:>, <*10: print terminal text buffer *>
string cmd(1) <* 13 *>
))
do c:=c+1;
if c = 13 then begin
write(out,<:unknown command<10>:>);
c:=1;
end
else
if c = 1 then begin
write(out,<:
r print dump registers
l print link descriptor(s)
c print coroutine descriptor(s)
a print area table (or part of)
s print segments in a spool area
t print terminal descriptor(s)
p print from core dump
b print terminal buffer
bt print terminal text buffer
h help
:>)
end
until c>2;
setposition(in,0,0);
pmd_command:=c-2;
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 file name: :>); 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;
cdsr_ant:=pool_table(3,2); <* antal cdescr *>
init_cdsr(cdsr,cdsrid,cdsr_ant);
end;
end_pd:=false;
repeat
case pmd_command of begin
<* 1 *> end_pd:=true; <* quit *>
<* 2 *> begin <* print dump registers *>
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;
<* 3 *> begin <* print link beskrivelse *>
print_link_descr(zout);
end;
<* 4 *> begin <* print coroutine beskrivelse *>
print_cdescr(zout);
end;
<* 5 *> begin <* print area tabel *>
print_area_table(zout);
end;
<* 6 *> begin <* print spool area *>
print_spool_area(zout);
end;
<* 7 *> begin <* print terminal beskrivelse *>
print_tdescr(zout);
end;
<* 8 *> begin <* print fra dump *>
print_from_dump(zout);
end;
<* 9 *> begin <* print terminal buffer *>
print_term_buffer(zout,0);
end;
<*10 *> begin <* print terminal text buffer *>
print_term_buffer(zout,1);
end;
end;
until end_pd;
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 init_cdsr(cdsr, cdsrid, ant); value ant;
integer array cdsr,cdsrid; integer ant;
begin
integer c_pool,nxt,s,i;
integer array field ia;
ia:=0;
c_pool:=pool_table(3,1);
nxt:=c_pool+8;
s:=pool_table(3,3);
for i:=1 step 1 until ant do begin
cdsr(i):=nxt; nxt:=nxt+s;
cdsrid(i):=0;
end;
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 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;
end;
for i:=1 step 1 until ant do begin
if cdsr(i)<>0 then begin
if menu_dump_pos(mdmpz,cdsr(i),60) then
cdsrid(mdmpz.ia(5)):=cdsr(i);
end;
end;
end;
procedure print_link_descr(zout); zone zout;
begin
integer i, addr;
integer array field ia;
ia:=0;
write(out,<:type link addr or coroutine id<10>:>,
<:link : :>); setposition(out,0,0);
read(in,i);
if i < first_proc then begin
addr:=cdsrid(i)+332;
write(zout,<:link for coroutine id:>,<< d>,i,
<: (addr = :>,cdsrid(i),<:)<10>:>);
end else addr:=i;
if menu_dump_pos(mdmpz,addr,48) then
write(zout,<:link :>,<< dddddd>,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;
procedure w_localid(zout,lid); value lid;
integer lid; zone zout;
begin
integer c1,c2,c3;
write(zout,<: <60>:>);
c1:=lid shift (-16);
c2:=(lid shift (-8) ) extract 8;
c3:=lid extract 8;
if c1<32 then write(zout,<:<60>:>,<<d>,c1,<:>:>)
else write(zout,false add c1,1);
if c2<32 then write(zout,<:<60>:>,<<d>,c2,<:>:>)
else write(zout,false add c2,1);
if c3<32 then write(zout,<:<60>:>,<<d>,c3,<:>:>)
else write(zout,false add c3,1);
write(zout,<:>:>);
end;
procedure print_cdescr(zout); zone zout;
begin
<* coroutine beskrivelse
+0 ic
+2 prio
+4 test mask
+6 state
+8 ident
+10 active/timer queue
+12 -
+14 semaphore queue
+16 -
+18 mailbox queue
+20 -
+33 localid
*>
integer i, addr,fi,la,lin_no;
integer array field ia;
lin_no:=0; ia:=0;
write(out,<:type index or addr for cdescr<10>:>,
<:cdescr (0 is all): :>); setposition(out,0,0);
read(in,i);
if i <> 0 then begin
if i < first_proc then addr:=cdsrid(i) else addr:=i;
ia:=0;
if menu_dump_pos(mdmpz,addr,400) then
write(zout,<:<10>:>,<<dddddd>,addr,<< ddddddd>,
<:+0: ic :>,mdmpz.ia(1),
<:<10> +2: prio :>,mdmpz.ia(2),
<:<10> +4: t-mask :>,mdmpz.ia(3),
<:<10> +6: type :>,mdmpz.ia(4) extract 3,
<:<10> +8: ident :>,mdmpz.ia(5),
<:<10> +10:run_que :>,mdmpz.ia(6),mdmpz.ia(7),
<:<10> +14:sem_que :>,mdmpz.ia(8),mdmpz.ia(9),
<:<10> +16:mbx_que :>,mdmpz.ia(10),mdmpz.ia(11),
<:<10> +33:lid :>); w_localid(zout,mdmpz.ia(33));
write(zout,
<:<10> +366:tdescr :>,mdmpz.ia(184),
<:<10> +368:taddr :>,mdmpz.ia(185),
<:<10>:>);
end
else
begin <* list alle *>
write(zout,<:
cdescr id ic ret st ti activ tdescr localid<10>:>);
for i:=1 step 1 until cdsr_ant do begin
if cdsr(i)<>0 then begin
if menu_dump_pos(mdmpz,cdsr(i),400) 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,<: ---:>);
write(zout,<< dddddd>,mdmpz.ia(184));
w_localid(zout,mdmpz.ia(33));
if new_line(zout,lin_no) then goto SL;
end
else
goto SL;
end; <* end cdsr(i) <> 0 *>
end; <* for i:= *>
SL:
end <* list alle *>
end;
procedure print_area_table(zout); zone zout;
begin
boolean array field ee;
integer fi,la,i,lin;
write(out,<:area table base :>, << dd>, area_table_base,
<: : top :>, area_table_top, <:<10>:>);
write(out,<:first: :>); setposition(out,0,0);
read(in,fi);
write(out,<:last : :>); setposition(out,0,0);
read(in,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;
procedure print_spool_area(zout); zone zout;
begin
boolean array field ee;
integer fi,lin,i;
write(out,<:seg no: :>); 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;
procedure print_tdescr(zout); zone zout;
begin
<* terminal beskrivelse
+0 next
+2 head_session
+4 cur_th
+6 user_id
+14 cpw
+16 cpw
+18 uid
+20 tpda
+22 name+nte
+32 type
+34 ttda
+36 termspec
+52 gemt term table type
+54 s
+56 sender
+58 th stopped
+60 cth
*>
integer array field tdes;
real array field uid, tname;
integer nxt,s,t_pool,i,j,t_ant,addr,lin_no;
integer array field ia;
lin_no:=0; ia:=0;
t_pool:=pool_table(5,1);
write(out,<:type index for cdescr or addr for tdescr<10>:>,
<:tdescr (0 is all): :>); setposition(out,0,0);
read(in,addr);
if addr <> 0 then begin
i:=addr;
if i < first_proc then begin
if menu_dump_pos(mdmpz,cdsrid(i),400) then
addr:=mdmpz.ia(184)
else
goto NOTA;
write(zout,<:tdescr for coroutine id:>,<< d>,i,
<: (addr = :>,addr,<:)<10>:>);
end;
if menu_dump_pos(mdmpz,addr,tdescr_size) then begin
tdes:=0;
uid:=tdes+6; tname:=tdes+22;
write(zout,<< dddddd>,addr,
<:+2: next :>,mdmpz.tdes(2),
<:<10> +4: head :>,mdmpz.tdes(3),
<:<10> +6: user id :>,mdmpz.uid,
<:<10> +18: uid :>,mdmpz.tdes(10),
<:<10> +20: tpda :>,mdmpz.tdes(11),
<:<10> +22 name :>,mdmpz.tname,
<:<10> +32: type :>,mdmpz.tdes(17),
<:<10> +34: ttda :>,mdmpz.tdes(18),
<:<10>:>);
end
else
begin
NOTA:
write(out,<:not a legal tdescr addr<10>:>);
end;
end
else
begin <* list alle *>
if menu_dump_pos(mdmpz,cl_var,350) then begin
used_tdescr:=mdmpz.ia(89);
end;
if menu_dump_pos(mdmpz,tdescr_pool,tdescr_size) then begin
i:=used_tdescr;
write(zout,<:
tdescr tname tpda user next head uid type ttda<10>:>);
while i<>0 do begin
tdes:=(i-tdescr_pool);
uid:=tdes+6; tname:=tdes+22;
write(zout,<<dddddd>,i,<:,:>);
j:=write(zout,<: :>,mdmpz.tname);
write(zout,false add 32,(14-j),<< dddddd>,mdmpz.tdes(11));
j:=write(zout,<: :>,mdmpz.uid);
write(zout,false add 32,(14-j),
<< dddddd>,mdmpz.tdes(2),mdmpz.tdes(3),
<< dddd>, mdmpz.tdes(10),
<< dddd>,mdmpz.tdes(17),
<< ddddddd>,mdmpz.tdes(18));
if new_line(zout,lin_no) then goto SL;
i:=mdmpz.ia(1+(i-tdescr_pool)/2);
end;
SL:
end
end
end;
procedure print_from_dump(zout); zone zout;
begin
integer i,fi,ant;
integer array field ia;
write(out,<:first addr: :>); setposition(out,0,0);
read(in,fi);
write(out,<:number of hw: :>); 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;
procedure print_term_buffer(zout,p_ctrl); value p_ctrl;
integer p_ctrl; zone zout;
begin
integer i, addr,fi,la, taddr, tg, c1, c2, c3, chs, sh;
integer array field ia;
ia:=0;
write(out,<:type index or addr for cdescr<10>:>,
<:cdescr for owner: :>); setposition(out,0,0);
read(in,i);
if i < first_proc then addr:=cdsrid(i) else addr:=i;
ia:=0; tg:=0;
if menu_dump_pos(mdmpz,addr,400) then
taddr:=mdmpz.ia(185);
if menu_dump_pos(mdmpz,taddr,800) then begin
if p_ctrl = 1 then begin
c1:=mdmpz.ia(1);
c2:=c1 shift (-16);
i:=1; sh:=-16;
while c2>31 or c2=10 do begin
outchar(zout,c2);
sh:=sh+8;
if sh>0 then begin
sh:=-16;
i:=i+1;
c1:=mdmpz.ia(i);
end;
c2:=c1 shift sh extract 8;
end;
end
else begin
write(out,<:chars: :>); setposition(out,0,0);
read(in,chs);
for i:=1 step 1 until chs do begin
c1:=mdmpz.ia(i) shift (-16);
c2:=(mdmpz.ia(i) shift (-8) ) extract 8;
c3:=mdmpz.ia(i) extract 8;
tg:=tg+(if c1<32 then write(zout,<:<60>:>,<<d>,c1,<:>:>)
else write(zout,false add c1,1));
tg:=tg+(if c2<32 then write(zout,<:<60>:>,<<d>,c2,<:>:>)
else write(zout,false add c2,1));
tg:=tg+(if c3<32 then write(zout,<:<60>:>,<<d>,c3,<:>:>)
else write(zout,false add c3,1));
if tg > 60 then begin
outchar(zout,10);
tg:=0;
end;
end;
outchar(zout,10);
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;
procedure print_søg_dump(zout); zone zout;
begin
integer hw,i,lin_no;
long array field tname;
integer field lid, tpda, look, j, eno;
lid:=2; tpda:=4; tname:=4; look:=14;
lin_no:=0;
if print_søg_name then begin
write(out,<:tas søg terminal dump fil navn : :>); setposition(out,0,0);
readstring(in,s_name,1);
open(sdmpz,4,s_name,0);
print_søg_name:=false;
end;
setposition(sdmpz,0,0);
inrec6(sdmpz,2);
eno:=sdmpz.lid/12;
for i:=1 step 1 until eno do begin
inrec6(sdmpz,14);
if sdmpz.tpda >0 then begin
write(zout,<< ddd>,i,<:. :>);
w_localid(zout,sdmpz.lid);
j:=write(zout,<: :>,sdmpz.tname);
write(zout,false add 32,14-j,<< ddddddd>,sdmpz.tpda);
if sdmpz.tpda <> sdmpz.look then
write(zout,<: ************ :>,<< ddddddd>,sdmpz.look);
if new_line(zout,lin_no) then goto SL;
end;
end;
SL:
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(zout,<: :>);
for i:=2,4,6,8 do
skriv_tegn(zout,z.i);
i:=10;
write(zout,<:, :>,<<d>,z.i,<:<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;
print_søg_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);
if first_rec >= 0 then 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<0 then goto try_next;
if first_rec=0 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◀