|
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: 37632 (0x9300)
Types: TextFile
Names: »tdescribe«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦162d2eb5b⟧ »talgprog«
└─⟦this⟧
(mode list.yes
head cpu
describe=set 25
describe=algol connect.no blocks.yes
scope user describe
head cpu
mode list.no)
1980-11-05
begin
integer i,j,k,nt,ntstart,ntper,ntarea,ntint,ntend,pda,na,
dev,fdevice,ldevice,fint,lint,farea,larea,
fbuf,lbuf,bufsize,bufadr,lowerl,upperl,
int,octal,halfword,byte,bit,text,s_int,all,l_base,u_base,
kind_a,name_a,pda_a,res_a,user_a,first_slice_a,seg_a,
doc_a,wa_a,ra_a,main_a,n_mess_a,p_mess_a,i_addr_a,
userhw,userhw1,proc_kind,proc_size,upl,lwl,externalsize,
internals,internalsize,areas,areasize,
userwords,fdrum,fdisc,topchain,drumchain,
discchain,proc_base,id_mask,ppda,dev_no;
boolean halfw,found,nl,sp,rpda,spda,reserver,user,
parent,any,table;
integer array desc(1:1),chain1,chain2(1:2);
boolean array opt,opt1(1:10);
long array field n,name,lo;
array field r,raf;
integer field kind,lowerb,upperb;
array inp,cid(1:3);
procedure writetime(l);
value l;
long l;
begin
real r,r1;
r:=l/10000;
write(out,<< dd dd dd>,systime(4,r,r1),r1);
end;
procedure writelong(l);
value l; long l;
begin
write(out,<< dddddddddddddd>,l/10000);
end;
procedure getlimit(ll,ul,max);
value max; integer ll,ul,max;
begin
integer i;
ll:=1; ul:=max;
if readifpnext(fpnr,i) and i>=ll and i<=max then
begin
ul:=i;
if readifpnext(fpnr,i) and i>=ul and i<=max then
begin
ll:=ul;
ul:=i
end;
end;
if false then write(out,nl,1,"*",1,<:limits :>,ll,ul);
end getlimit;
boolean procedure test_user(desc,id_mask);
value id_mask; integer id_mask;
integer array desc;
testuser:=integerand(desc(proc_base+user_a+id_mask shift (-13) extract 12)
shift (-((id_mask shift (-12) extract 12+1)
mod 2)*12) extract 12,
id_mask extract 12)<>0;
integer procedure find_ext_size(nt);
value nt; integer nt;
begin
integer pda,pda1;
pda:=wordload(nt);
pda1:=0;
for nt:=nt+2 while nt<ntarea and pda>pda1 do pda1:=wordload(nt);
find_ext_size:=pda1-pda;
end find_ext_size;
\f
procedure get_descr_or_name(name,addr,descr);
value descr ;
boolean descr ;
integer addr ;
array name ;
begin
integer array iarr(1:1),table(1:1);
integer i,j,no_of_procs;
boolean found;
real array field raf;
found:= false;
raf:= 0;
no_of_procs:=(ntend-ntstart)//2;
redefarray(table,ntstart,no_of_procs*2);
for i:= 1,i+1 while i <= no_of_procs and -,found do
begin
redefarray(iarr,2+table(i),12);
found:= if -,descr
then addr = table(i)
else name(1) = iarr.raf(1) and
name(2) = iarr.raf(2);
if found then
begin
if descr then addr:= table(i)
else
begin
name(1):= iarr.raf(1);
name(2):= iarr.raf(2);
end;
end;
end;
if -,found then write(out,nl,1,"*",2,name.lo,<: not found: (getdesc) :>);
end get_descr_or_name;
\f
procedure check_procfunc(name);
array name ;
begin
if name(1) = real<:procf:> add 117 and
name(2) = real<:nc:>
then
begin
name(1):= name(1) shift (-24);
name(2):= real<:cfunc:>;
end;
end;
\f
procedure type_names(mask,rel_a);
integer mask,rel_a ;
begin
integer i,j,k;
integer array table,iarr(1:1);
real array field raf;
integer array field id;
raf:= 6; id:= 16;
redefarray(table,ntint,internals*2);
for i:= 1,i+1 while i <= internals do
begin
redefarray(iarr,table(i)-4,internalsize);
for k:= 0 step 1 until 11 do
if mask shift (-k) extract 1 = 1 and
iarr.id(1) shift (-k) extract 1 = 1 and
(if rel_a=-1 then mask=iarr.id(1) else
iarr.id(1) shift (-12) = rel_a) then
begin <* id-mask of internal is contained in 'mask' *>
if iarr.raf(1) = real<:pro:> shift (-24) <* i. e. procfunc *> then
begin
write(out,sp,2,<:procfunc:>);
end else
begin
j:= 1;
write(out,sp,2,string iarr.raf(increase(j)));
end;
if rel_a=-1 then k:=12;
end;
end;
end type_names;
\f
integer procedure identification_mask(name);
array name ;
begin
integer i,j;
integer array table,iarr(1:1);
boolean found;
real array field raf;
raf:= 6; found:= false;
check_procfunc(name);
redefarray(table,ntint,internals*2);
for i:= 1,i+1 while i <= internals do
begin
redefarray(iarr,table(i)-4,internalsize);
if name(1) = iarr.raf(1) and
name(2) = iarr.raf(2) then
begin
found:= true;
identification_mask:= iarr(9);
end;
end;
if -,found then write(out,nl,1,"*",2,name.lo,<: not found(idmask):>);
end identification_mask;
\f
procedure type_table(lowerl,upperl);
value lowerl,upperl; integer lowerl,upperl;
begin
integer base,i,j,k;
integer array table(1:1);
long field timef;
redefarray(table,66,54);
timef:=110-66+2;
write(out,nl,1,<:core.:>,<<ddddd>,66);
for i:=lowerl step 1 until upperl do
begin
if i<>22 then
write(out,nl,1,<<ddd>,64+2*i,<:::>,case i of (
<:current process : :>,
<:next process : :>,
<:prev process : :>,
<:name table start : :>,
<:first device nt : :>,
<:first area nt : :>,
<:first int nt : :>,
<:name table end : :>,
<:next buffer : :>,
<:previous buffer : :>,
<:first buffer pool : :>,
<:last buffer pool : :>,
<:buffer size : :>,
<:first drum chain : :>,
<:first disc chain : :>,
<:top chain : :>,
<:chain table main cat: :>,
<:not used : :>,
<:max time slice : :>,
<:time slice : :>,
<:not used : :>,
<::>,
<:time : :>,
<:clock value sensed : :>,
<:not used : :>,
<:storage halfwords : :>,
<:global,aux permkey : :>));
if i<>22 and i<>23 then
writeformatted(table(i),if i>=27 then halfword else int) else
if i<>22 then writetime(table.timef);
end for;
end type_table;
procedure type_external(pda,desc,lowerl,upperl);
value pda,lowerl,upperl;
integer pda,lowerl,upperl;
integer array desc;
if desc(proc_base+kind_a)=0 or desc(proc_base+kind_a)=4 or
desc(proc_base+kind_a)=64 then
begin
long array field raf;
raf:=6+userhw;
write(out,nl,1,"*",2,
desc.raf,<: not external kind :>,desc(procbase+kinda));
end else
if lowerl>=1 and upperl>=lowerl and upperl<400 then
begin
integer i,j,wr,k,nt;
real array field raf;
array name(1:2);
raf:= 6+userhw; j:= i:= 1;
nt:=ntstart-2;
repeat nt:=nt+2 until wordload(nt)=pda and nt<ntend;
externalsize:=find_ext_size(nt);
k:=externalsize//2;
if upperl>k then upperl:=k;
write(out,nl,1,<:core.:>,<<ddddd>,pda-4,nl,1);
k:=if upperl>13 then 13 else upperl;
for wr:=lowerl step 1 until k do
begin
case wr of
begin
write(out,<<dddddddd>,<:lower interval : :>,sp,2,
desc(procbase+l_base),nl,1);
write(out,<<dddddddd>,<:upper interval : :>,sp,2,
desc(procbase+u_base),nl,1);
write(out,<<dddddddd>,<:kind : :>,sp,2,
desc(procbase+kind_a),nl,1);
write(out,<:name : :>,sp,2,
string desc.raf(increase(i)),nl,1);;;;
begin
write(out,<<dddddddd>,<:main : :>,sp,2,
desc(procbase+main_a));
get_descr_or_name(name,desc(proc_base+main_a),false);
write(out,sp,3,name.lo,nl,1);
end;
begin
write(out,<<dddddddd>,<:reserver : :>,sp,2);
write_formatted(desc(procbase+res_a),bit);
type_names(desc(procbase+res_a),-1);
end reserver;
begin <*users*>
write(out,nl,1,
<:users : :>,sp,2);
for j:=0 step 1 until userhw1 do
begin
if j extract 1 = 0 then
begin
if j>0 then write(out,nl,1,sp,24);
write_formatted(desc(procbase+user_a+(j shift (-1))),bit);
end;
type_names(desc(procbase+user_a+j//2) shift (-((j+1) mod 2)*12) extract 12,j);
end;
end;
write(out,nl,1,<<-ddddddddd>,<:next message : :>,sp,2,
desc(procbase+n_mess_a),nl,1);
write(out,<<-ddddddddd>,<:previous message : :>,sp,2,
desc(procbase+p_mess_a),nl,1);
write(out,<<-ddddddddd>,<:interrupt address : :>,sp,2,
desc(procbase+i_addr_a),nl,1);
end case;
end for wr;
for wr:=if lowerl>13 then lowerl else 14 step 1 until upperl do
begin
write_formatted(desc(procbase+wr-3),all-text);
write(out,nl,1);
end;
outendcur(0);
end type_external else
write(out,nl,1,"*",2,<:external lower, upper:>,lowerl,upperl);
\f
procedure type_area_process(pda,desc,lowerl,upperl);
value pda,lowerl,upperl;
integer pda,lowerl,upperl;
integer array desc;
if -,(desc(proc_base+kind_a)=4 or desc(proc_base+kind_a)=64) then
write(out,nl,1,"*",2,cid.lo,<: not area or pseudo :>) else
begin
integer i,j,k,wr;
array name(1:2);
real array field raf;
if upperl>areasize//2 then upperl:=areasize//2;
if desc(proc_base+kind_a)=64 then
begin
if upperl>9 then upperl:=9;
end;
raf:= 6+userhw; i:= j:= 1;
write(out,nl,1,<:core.:>,<<-dddddd>,pda,nl,1);
for wr:=lowerl step 1 until upperl do
begin
case wr of
begin
write(out,<<-ddddddddd>,<:lower interval : :>,sp,2,
desc(proc_base+l_base),nl,1);
write(out,<<-ddddddddd>,<:upper interval : :>,sp,2,
desc(proc_base+u_base),nl,1);
write(out,<<-ddddddddd>,<:kind : :>,sp,2,
desc(proc_base+kind_a),nl,1);
write(out,<<-ddddddddd>,<:name : :>,sp,2,
string desc.raf(increase(i)),nl,1);;;;
begin
write(out,<<-ddddddddd>,<:proc descr addr : :>,sp,2,
desc(proc_base+pda_a));
if abs desc(proc_base+pda_a)>0 then
begin
get_descr_or_name(name,abs (desc(proc_base+pda_a)//2*2),false);
j:=1;
write(out,sp,3,string name(increase(j)));
end;
write(out,nl,1);
end pda;
begin
write(out,<<-ddddddddd>,<:reserver : :>,sp,2);
write_formatted(desc(proc_base+res_a),bit);
type_names(desc(proc_base+res_a),-1);
end;
begin
write(out,nl,1,
<:users : :>,sp,2);
for j:=0 step 1 until userhw1 do
begin
if j extract 1=0 then
begin
if j>0 then write(out,nl,1,sp,23);
write_formatted(desc(proc_base+user_a+(j shift (-1))),bit);
end;
type_names(desc(proc_base+user_a+j//2) shift (-((j+1) mod 2)*12) extract 12,j);
end;
write(out,nl,1);
end user;
write(out,<<-ddddddddd>,<:first slice : :>,sp,2,
desc(proc_base+first_slice_a),nl,1);
write(out,<<-ddddddddd>,<:no of segments : :>,sp,2,
desc(proc_base+seg_a),nl,1);
begin <*doc*>
write(out,<:document : :>,sp,2);
j:= 1; raf:= 24+userhw;
write(out,string desc.raf(increase(j)),nl,1);
end doc;;;;
write(out,<<-ddddddddd>,<:write counter : :>,sp,2,
desc(proc_base+wa_a),nl,1);
write(out,<<-ddddddddd>,<:read counter : :>,sp,2,
desc(proc_base+ra_a),nl,1);
end case;
end loop;
outendcur(0);
end type_area_process;
\f
procedure type_chain(pda,desc,lowerl,upperl);
value pda,lowerl,upperl;
integer pda,lowerl,upperl;
integer array desc;
begin <* prints chainhead *>
integer i,j,k,wr;
real array field raf1,raf2;
j:= i:= k:= 1;
raf1:= 8; raf2:= 18;
write(out,nl,1,<:core.:>,<<-dddddd>,pda-36,nl,1);
if upperl>19 then upperl:=19;
for wr:=lowerl step 1 until upperl do
begin
case wr of
begin
write(out,<<-ddddddddd>,<:rel. addr. of claims in i. p. : :>,sp,2,
desc(1),nl,1);
write(out,<<-ddddddddd>,<:first slice in auxcat : :>,sp,2,
desc(2) shift (-12) extract 12,nl,1);
write(out,<<-ddddddddd>,<:bs kind : :>,sp,2,
if desc(2) shift (-3) extract 1 = 1 then<:disc:> else
<:drum:>,nl,1);
write(out,<<-ddddddddd>,<:permkey : :>,sp,2,
desc(2) extract 3,nl,1);
write(out,<:name of auxcat : :>,sp,2,
string desc.raf1(increase(j)),nl,1);;;;
write(out,<<-ddddddddd>,<:size of auxcat : :>,sp,2,
desc(9),nl,1);
write(out,<:document name : :>,sp,2,
string desc.raf2(increase(k)),nl,1);;;;
write(out,<:slice length : :>,sp,2,
desc(15),nl,1);
write(out,<:last slice of document : :>,sp,2,
<<-ddddddddd>,desc(16) shift (-12) extract 12,nl,1,
<:first slice of chaintable area : :>,sp,2,
desc(16) extract 12,nl,1);
begin
write(out,<:state of document : :>,sp,2);
for i:=0 step 1 until 6 do
if desc(17) shift (-(12+i)) extract 1=1 then
write(out,case i+1 of (<:idle:>,<:after prepare:>,<:during insert:>,
<:ready:>,<:during delete:>,<:during aux:>));
end state; <*work*>;
write(out,nl,1,<:start of chaintable at address : :>,sp,2,
<<-ddddddddd>,pda,<: slicelink :>,<<ddddd>,
desc(19) shift (-12) extract 12,desc(19) extract 12,nl,1);
end case;
end for wr;
outendcur(0);
end type_chain;
\f
procedure type_buf(bufadr,desc,lowerl,upperl);
value bufadr,lowerl,upperl;
integer bufadr,lowerl,upperl;
integer array desc;
begin
integer i,j,k,wr;
real array name(1:2);
j:= 1;
write(out,nl,1,<:core.:>,<<-dddddd>,bufadr,nl,1);
k:=if upperl>=5 then 5 else upperl;
for wr:=lowerl step 1 until k do
begin
case wr of
begin
write(out,<<-dddddd>,<:message flag : :>,desc(1),nl,1);
write(out,<<-dddddd>,<:next buffer : :>,desc(2),nl,1);
write(out,<<-dddddd>,<:prev buffer : :>,desc(3),nl,1);
begin
write(out,<<-dddddd>,<:receiver/result : :>,desc(4));
if abs(desc(4)) > 7 <* receiver addr *> then
begin
get_descr_or_name(name,abs(desc(4)//2*2),false);
j:= 1;
write(out,sp,3,string name(increase(j)));
end;
outchar(out,10);
end receiver;
begin <*sender*>
write(out,<:sender : :>,<<-dddddd>,desc(5));
if abs(desc(5)) > 0 then
begin
get_descr_or_name(name,abs(desc(5)),false);
j:= 1;
write(out,sp,3,string name(increase(j)));
end;
outchar(out,10);
end sender;
end case;
end for wr;
k:=if lowerl<=6 then 6 else lowerl;
for i:= k step 1 until upperl do
begin
write_formatted(desc(i),all);
outcharcur(10);
end;
outendcur(0);
end type_buf;
\f
procedure type_int_struct(pda,desc,opt);
value pda; integer pda;
integer array desc;
boolean array opt;
begin
integer lwl,upl,i,j;
typeinternal(pda,desc,1,7,true);
for j:=1 step 1 until 4 do
begin
lwl:=if opt(j) then (case j of (29,37,43,64)) else 1;
upl:=if opt(j) then (case j of (35,42,50,internalsize//2)) else 0;
if opt(j) then type_internal(pda,desc,lwl,upl,false);
opt(j):=false;
end j;
end type_int_struct;
\f
procedure type_internal(pda,desc,lowerl,upperl,first);
value pda,lowerl,upperl,first;
integer pda,lowerl,upperl;
boolean first;
integer array desc;
if desc(3)<>0 then write(out,nl,1,"*",cid.lo,<: not internal:>) else
if lowerl>=1 and lowerl<=upperl and upperl<=200 then
begin
integer i,j,first_bs_claims,last_bs_claims,words;
array name(1:2);
long field lf;
long array field namef;
found:= true;
first_bs_claims:=if halfw then 60 else 56;
last_bs_claims:=first_bs_claims+(if halfw then 3 else 7);
j:= 1;
if first then write(out,nl,1,<:start of internal process : :>,
<:core:>,<:.:>,<<ddddd>,pda,nl,1);
words:=internalsize//2;
if upperl>words then upperl:=words;
words:=if lowerl<64 then (case lowerl of(
1,1,3,4,4,4,4,8,9,10,10,12,12,14,14,16,17,18,19,20,
21,21,23,23,25,25,27,28,29,30,
30,32,32,34,34,36,37,37,39,39,
41,41,43,44,45,46,47,48,48,48,
51,51,53,53,55,56,57,57,57,57,
57,62,62)) else
lowerl-lowerl mod 8;
i:=if lowerl<64 then (
case lowerl of (1,1,2,3,3,3,3,4,5,6,6,7,7,8,8,9,10,
11,12,13,14,14,15,15,16,16,17,18,19,20,20,21,21,22,
22,23,24,24,25,25,26,26,27,28,29,30,31,32,32,33,33,
34,34,35,36,37,37,37,37,37,38,38)) else
39+(lowerl-64)//8;
while words<=upperl do
begin
words:=words+1;
if i<39 then write(out,case i of
(<:interval lim : :>,
<:kind : :>,
<:name : :>,
<:scount,state : :>,
<:ident : :>,
<:event q head : :>,
<:proc q elem : :>,
<:first,top : :>,
<:buf,area : :>,
<:int,func : :>,
<:prio : :>,
<:mode(pk,pr) : :>,
<:interrupt m : :>,
<:excep,escape : :>,
<:init cpa,base: :>,
<:init wr lim : :>,
<:init interr l: :>,
<:parent descr : :>,
<:quantum : :>,
<:run time : :>,
<:start run : :>,
<:start wait : :>,
<:wait addr : :>,
<:cat base : :>,
<:max base : :>,
<:std base : :>,
<:w0 : :>,
<:w1 : :>,
<:w2 : :>,
<:w3 : :>,
<:status : :>,
<:ic,cause,sb : :>,
<:curr cpa,base: :>,
<:curr wr lim : :>,
<:curr interr l: :>,
<:save area : :>,
<:g20-g24 : :>,
<:b18,b19 : :>)) else
write(out,<:bs claims:>,<<dd>,i-39,<: : :>);
if i>38 then
begin
first_bs_claims:=first_bs_claims +(if halfw then 4 else 8);
last_bs_claims:= last_bs_claims +(if halfw then 4 else 8);
words:=words+7;
end;
case i of
begin
begin <* interval limits *>
write_formatted(desc(1),int);
write_formatted(desc(2),int);
words:=words+1;
end;
<* kind *>
write_formatted(desc(3),int);
<* name *>
begin
namef:=6;
write(out,sp,2,desc.namef);
words:=words+3;
end;
<* stop count,state *>
write_formatted(desc(8),halfword + bit);
<* identification *>
write_for_matted(desc(9),bit);
begin <* next,last event *>
write_formatted(desc(10),int);
write_formatted(desc(11),int);
words:=words+1;
end;
begin <* next,last process *>
write_formatted(desc(12),int);
write_formatted(desc(13),int);
words:=words+1;
end;
begin <* first,top address *>
write_formatted(desc(14),int);
write_formatted(desc(15),int);
words:=words+1;
end;
<* buf,area *>
write_formatted(desc(16),halfword);
<* internal claim,function mask *>
write_formatted(desc(17),halfword+bit);
<* priority *>
write_formatted(desc(18),int);
<* mode (pk,pr) *>
write_formatted(desc(19),halfword);
<* interrupt mask *>
write_formatted(desc(20),bit);
begin <* exception,escape address *>
write_formatted(desc(21),int);
write_formatted(desc(22),int);
words:=words+1;
end;
begin <* initial cpa,base *>
write_formatted(desc(23),int);
write_formatted(desc(24),int);
words:=words+1;
end;
begin <* initial write limits *>
write_formatted(desc(25),int);
write_formatted(desc(26),int);
words:=words+1;
end;
<* interrupt levels *>
write_formatted(desc(27),halfword);
<* parent description *>
begin
write_formatted(desc(28),int);
get_descr_or_name(name,desc(28),false);
namef:=0;
write(out,sp,3,name.namef);
end;
<* quantum *>
write_formatted(desc(29),int);
begin <* run time *>
<*write_formatted(desc(30),int);
write_formatted(desc(31),int);*>
lf:=62;
writelong(desc.lf);
words:=words+1;
end;
begin <* start run *>
<*write_formatted(desc(32),int);
write_formatted(desc(33),int);*>
lf:=66;
writetime(desc.lf);
words:=words+1;
end;
begin <* start wait *>
<*write_formatted(desc(34),int);
write_formatted(desc(35),int);*>
lf:=70;
writetime(desc.lf);
words:=words+1;
end;
<* wait address *>
write_formatted(desc(36),int);
begin <* catalog base *>
write_formatted(desc(37),int);
write_formatted(desc(38),int);
words:=words+1;
end;
begin <* max base *>
write_formatted(desc(39),int);
write_formatted(desc(40),int);
words:=words+1;
end;
begin <* std base *>
write_formatted(desc(41),int);
write_formatted(desc(42),int);
words:=words+1;
end;
<* w0 *>
write_formatted(desc(43),all-text);
<* w1 *>
write_formatted(desc(44),all-text);
<* w2 *>
write_formatted(desc(45),all-text);
<* w3 *>
write_formatted(desc(46),all-text);
<* status *>
write_formatted(desc(47),bit);
begin <* ic,cause,sb *>
write_formatted(desc(48),int);
write_formatted(desc(49),int);
write_formatted(desc(50),int);
words:=words+2;
end;
begin <* current cpa,base *>
write_formatted(desc(51),int);
write_formatted(desc(52),int);
words:=words+1;
end;
begin <* current write limits *>
write_formatted(desc(53),int);
write_formatted(desc(54),int);
words:=words+1;
end;
<* current interrupt levels *>
write_formatted(desc(55),halfword);
<* save area *>
write_formatted(desc(56),int);
<* g20-g24 *>
begin
for j:= 57 step 1 until 61 do
write_formatted(desc(j),int);
words:=words+4;
end;
begin <* b18,b19 *>
write_formatted(desc(62),int);
write_formatted(desc(63),int);
words:=words+1;
end;
<* bs claims 0 *>
for j:= first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 1 *>
for j:= first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 2 *>
for j:= first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 3 *>
for j:=first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 4 *>
for j:=first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 5 *>
for j:=first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 6 *>
for j:=first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 7 *>
for j:=first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
<* bs claims 8 *>
for j:=first_bs_claims step 1 until last_bs_claims do
write_formatted(desc(j),if halfw then halfword else s_int);
end case;
write(out,nl,1);
i:=i+1;
end while;
outendcur(0);
end type_internal else
if lowerl<>1 and upperl<>0 then
write(out,nl,1,"*",2,<:internal lower,upper:>,lowerl,upperl);
\f
procedure write_formatted(word,mask);
value word,mask ;
integer word,mask ;
begin <* writes the contents of 'word' according format specification
given in 'mask' *>
integer i,j,char;
for i:= 0 step 1 until 6 do
begin
if mask shift (-i) extract 1 = 1 then
begin
case i+1 of
begin
write(out,<<-ddddddd>,word,"!",1); <* integer *>
begin <* octal *>
for j:= 21 step -3 until 0 do
write(out,<<d>,word shift(-j) extract 3);
write(out,"!",1);
end;
write(out,<<dddd>,word shift (-12) extract 12,sp,1,word extract 12,
"!",1); <* halfword *>
write(out,<<ddd>,word shift (-16) extract 8,sp,1,word shift (-8) extract 8,
sp,1,word extract 8,"!",1); <* byte *>
begin <* bit *>
for j:= 0 step 1 until 23 do
write(out,if word shift j < 0 then <:1:> else <:.:>);
write(out,"!",1);
end;
begin <* text *>
for j:= 16 step -8 until 0 do
begin
char:= word shift (-j) extract 8;
if char > 32 and char < 127
then outchar(out,char)
else outchar(out,32);
end;
write(out,"!",1);
end;
write(out,<<ddddd>,word,"!",1); <* short integer *>
end case;
end;
end for-loop;
end write_formatted;
\f
integer procedure format(param);
array param;
format:= if param(1) = real<:integ:> add 101 and
param(2) = real<:r:> then 1 else
if param(1) = real<:octal:> then 2 else
if param(1) = real<:halfw:> add 111 and
param(2) = real<:rd:> then 3 else
if param(1) = real<:byte:> then 4 else
if param(1) = real<:bit:> then 5 else
if param(1) = real<:text:> then 6 else
if param(1) = real<:all:> then 7 else 8;
<*main program *>
lo:=r:=0;
lowerb:=2; upperb:=4; kind:=6;
name:=6;
ntstart:=wordload(72);
ntper:=wordload(74);
ntarea:=wordload(76);
ntint:=wordload(78);
ntend:=wordload(80);
fbuf:=wordload(86);
lbuf:=wordload(88);
bufsize:=wordload(90);
fdrum:=wordload(92);
fdisc:=wordload(94);
topchain:=wordload(96);
drumchain:=fdrum-36;
discchain:=fdisc-36;
int:= 1;
octal:= 1 shift 1;
halfword:=1 shift 2;
byte:= 1 shift 3;
bit := 1 shift 4;
text:= 1 shift 5;
s_int:= 1 shift 6;
all:= 127;
l_base:= -2;
u_base:= -1;
kind_a:= 0;
name_a:= 1;
pda_a:= 5;
res_a:= 6;
user_a:= -3;
first_slice_a:= 8;
seg_a:= 9;
doc_a := 5;
wa_a:= 14;
ra_a:= 15;
main_a:= 5;
n_mess_a:= 8;
p_mess_a:= 9;
i_addr_a:= 10;
sp:= false add 32;
nl:= false add 10;
comment include number of discs and drums;
redefarray(chain1,drumchain,4);
redefarray(chain2,discchain,4);
halfw:=chain1(2) extract 3 +1 = (chain2(1) - chain1(1))//2;
internals:=(ntend-ntint)//2;
internalsize:=wordload(ntint+2)-wordload(ntint);
areas:=(ntint-ntarea)//2;
areasize:=wordload(ntarea+2)-wordload(ntarea);
userwords:=(internals+23)//24;
userhw:=userwords*2;
userhw1:=userhw-1;
proc_base:=3+userwords;
user_a:=-proc_base+1;
connectlso;
readinfp(inp,1);
table:=inp(1)=real <:table:>;
if readifp(<:table:>,lowerl,1) then
begin
table:=true;
fpnr:=fpnr-1;
end;
if table then
begin
getlimit(lowerl,upperl,27);
type_table(lowerl,upperl);
end;
if readsfp(<:buf:>,cid,<::>) then
begin
<*buffer*>
if cid(1)=real <:all:> or cid(1)=real <:used:> then
begin
getlimit(lowerl,upperl,13);
for bufadr:=fbuf step bufsize until lbuf do
begin
redefarray(desc,bufadr-2,26);
if cid(1)=real <:all:> or desc(4)<>0 then
typebuf(bufadr,desc,lowerl,upperl);
end;
end all or used
else
begin
pda:=description(cid);
if pda=0 then write(out,nl,1,"*",2,cid.lo,<: not found:(buf):>)
else
begin
inp(1):=real <::>;
rpda:=readsfpnext(fpnr,inp) and inp(1) shift (-40) extract 8='r';
if -,rpda then fpnr:=fpnr-1;
spda:=inp(1)shift(-40) extract 8 = 's';
if spda then fpnr:=fpnr+1;
if readsfpnext(fpnr,inp) then
begin
rpda:=rpda or inp(1) shift (-40) extract 8='r';
spda:=spda or inp(1) shift (-40) extract 8='s';
end else fpnr:=fpnr-1;
end;
if -,rpda and -,spda then spda:=rpda:=true;
getlimit(lowerl,upperl,13);
for bufadr:=fbuf step bufsize until lbuf do
begin
redefarray(desc,bufadr-2,26);
if (spda and desc(5)=pda) or (rpda and desc(4)=pda) then
typebuf(bufadr,desc,lowerl,upperl);
end buf.<name>;
end buf;
end for buf;
if readsfp(<:area:>,cid,<::>) then
begin
<*area*>
if cid(1)=real <:all:> or cid(1)=real <:used:> then
begin
getlimit(lowerl,upperl,areasize//2-userwords);
for nt:=ntarea step 2 until ntint-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda+2-2*procbase,areasize);
if cid(1)=real <:all:> or desc(proc_base+pda_a)<>0 then
type_area_process(pda,desc,lowerl,upperl);
end;
end all or used
else
begin
pda:=if cid(1)=real <:procf:> add 'u' and
cid(2)=real <:nc:> then wordload(ntint) else
description(cid);
if pda=0 then write(out,nl,1,"*",2,cid.lo,<: not found(area):>)
else
begin
inp(1):=real <::>;
reserver:=readsfpnext(fpnr,inp) and inp(1)shift (-40) extract 8='r';
if -,reserver then fpnr:=fpnr-1;
user:=inp(1)shift(-40) extract 8='u';
if user then fpnr:=fpnr+1;
if readsfpnext(fpnr,inp) then
begin
reserver:=reserver or inp(1)shift (-40) extract 8='r';
user:=user or inp(1)shift (-40) extract 8='u';
end else fpnr:=fpnr-1;
end;
getlimit(lowerl,upperl,areasize//2-userwords);
if reserver or user then
begin
id_mask:=identification_mask(cid);
for nt:=ntarea step 2 until ntint-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda+2-2*procbase,areasize);
if (reserver and desc(procbase+res_a)=id_mask) or
(user and testuser(desc,id_mask)) then
type_area_process(pda,desc,lowerl,upperl);
end for nt;
end reserver or user
else
begin
redefarray(desc,pda+2-2*procbase,areasize);
if desc(proc_base+kind_a)=4 or desc(proc_base+kind_a)=64 then
type_area_process(pda,desc,lowerl,upperl);
end;
end area.<name>;
end area;
if readsfp(<:int:>,cid,<::>) then
begin
<*internal*>
if cid(1)=real <:all:> or cid(1)=real <:used:> then
begin
getlimit(lowerl,upperl,internalsize//2);
for nt:=ntint step 2 until ntend-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda-4,internalsize);
if cid(1)=real <:all:> or desc(2)<>0 or nt=ntint then
type_internal(pda,desc,lowerl,upperl,true);
end;
end all or used
else
begin
pda:=if cid(1)=real <:procf:> add 'u' and
cid(2)=real <:nc:> then wordload(ntint) else
description(cid);
if pda=0 then write(out,nl,1,"*",2,cid.lo,<: not found(internal):>)
else
begin
for i:=1 step 1 until 10 do opt(i):=false;
inp(1):=real <::>;
parent:=false;
while readsfpnext(fpnr,inp) do
begin
for j:=1 step 1 until 4 do
begin
if inp(1)= real (case j of (<:times:>,<:bases:>,
<:regis:> add 't',<:claim:> add 's')) then
opt(j):=true;
end;
if inp(1)=real <:p:> then
begin
ppda:=pda;
parent:=ppda>0;
end .p.;
end while;
j:=0;
any:=false;
repeat j:=j+1;
any:=any or opt(j);
until any or j=10;
fpnr:=fpnr-1;
getlimit(lowerl,upperl,internalsize//2);
redefarray(desc,pda-4,internalsize);
if parent then
begin
for nt:=ntint step 2 until ntend-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda-4,internalsize);
if desc(28)=ppda and any then
begin
for j:=1 step 1 until 10 do opt1(j):=opt(j);
type_intstruct(pda,desc,opt1);
end else
if desc(28)=ppda then type_internal(pda,desc,lowerl,upperl,true);
end for nt;
end parent else
if -,any then type_internal(pda,desc,lowerl,upperl,true) else
begin
type_int_struct(pda,desc,opt);
end any;
end pda>0;
end internal.<name>;
end internal;
if readsfp(<:proc:>,cid,<::>) then
begin
<*process*>
if cid(1)=real <:all:> or cid(1)=real <:used:> then
begin
getlimit(lowerl,upperl,200);
for nt:=ntstart step 2 until ntend-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda-4,internalsize);
if cid(1)=real <:all:> or desc(4)<>0 then
begin
proc_kind:=desc(3);
if proc_kind=0 then typeinternal(pda,desc,lowerl,
if upperl*2>internal_size then internalsize//2 else
upperl,true) else
begin
redefarray(desc,pda+2-2*procbase,400);
if proc_kind=4 or proc_kind=64 then
type_area_process(pda,desc,lowerl,upperl) else
begin
upl:=find_ext_size(nt)//2;
type_external(pda,desc,lowerl,upl);
end ext;
end;
end;
end;
end all or used
else
begin
pda:=if cid(1)=real <:procf:> add 'u' and cid(2)=real <:nc:> then
wordload(ntint) else description(cid);
if pda=0 then write(out,nl,1,"*",2,cid.lo,<: not found:(ext):>)
else
begin
getlimit(lowerl,upperl,200);
redefarray(desc,pda-4,400);
proc_kind:=desc(3);
if proc_kind=0 then typeinternal(pda,desc,lowerl,upperl,true) else
begin
redefarray(desc,pda+2-2*procbase,400);
if proc_kind=4 or proc_kind=64 then typeareaprocess(pda,desc,lowerl,
upperl) else
begin
typeexternal(pda,desc,lowerl,upperl);
end;
end proc_kind<>0;
end proc.<name>;
end proc;
end for proc;
if readsfp(<:chain:>,cid,<::>) then
begin
<*chain*>
raf:=18;
getlimit(lowerl,upperl,19);
for nt:=fdrum step 2 until topchain-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda-36,38);
if cid(1)=real <:all:> or (cid(1)=real <:used:> and desc(9)<>0) or
(cid(1)=desc.raf(1) and cid(2)=desc.raf(2)) then
type_chain(pda,desc,lowerl,upperl);
end;
end chain;
if readsfp(<:ext:>,cid,<::>) then
begin
<*external*>
if cid(1)=real <:all:> or cid(1)=real <:used:> then
begin
getlimit(lowerl,upperl,400);
for nt:=ntstart step 2 until ntint-2 do
begin
pda:=wordload(nt);
externalsize:=find_ext_size(nt);
redefarray(desc,pda+2-2*procbase,externalsize);
upl:=externalsize//2;
if upl>upperl then upl:=upperl;
if cid(1)=real <:all:> or desc(proc_base+name_a)<>0 then
type_external(pda,desc,lowerl,upl);
end;
end all or used
else
begin
pda:=if cid(1)=real<:procf:>add'u' and cid(2)=real <:nc:> then
wordload(ntint) else description(cid);
if pda=0 then write(out,nl,1,"*",2,cid.lo,<: not found(external):>)
else
begin
inp(1):=real<::>;
user:=reserver:=false;
if -,readsfpnext(fpnr,inp) then fpnr:=fpnr-1 else
begin
user:=inp(1)shift (-40) extract 8='u';
reserver:=inp(1)shift (-40) extract 8='r';
end;
getlimit(lowerl,upperl,200);
if reserver or user then
begin
id_mask:=identificationmask(cid);
if false then write(out,nl,1,"*",1,<:ntstart,ntarea,ntint:>,
ntstart,ntarea,ntint);
for nt:=ntstart step 2 until ntarea-2 do
begin
pda:=wordload(nt);
redefarray(desc,pda+2-2*procbase,400);
if (reserver and desc(proc_base+res_a)=id_mask) or
(user and testuser(desc,id_mask)) then
typeexternal(pda,desc,lowerl,upperl);
end for nt
end user or reserver else
begin
redefarray(desc,pda+2-2*procbase,400);
type_external(pda,desc,lowerl,upperl);
end;
end pda>0;
end external.<name>;
end external;
if readifp(<:ext:>,devno,0) then
begin
nt:=ntper+2*devno;
pda:=wordload(nt);
raf:=2*procbase;
redefarray(desc,pda+2-2*procbase,400);
getlimit(lowerl,upperl,200);
if desc(procbase+namea)<>0 then typeexternal(pda,desc,lowerl,upperl)
else write(out,nl,1,desc.raf.lo,<: not found (devnr):>);
end devnr;
if fpout then closeout;
end;
▶EOF◀