|
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: 49920 (0xc300)
Types: TextFile
Names: »tdesc«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦162d2eb5b⟧ »talgprog«
└─⟦this⟧
(describe=algol connect.no xref.no
finisb)
begin <* this program is used for printing monitor data structures *>
integer array kind(0:100),alphabet(0:127),contents(1:1),
chain1,chain2(1:2);
real array ra(0:100),area,param,dummy(1:3);
integer sep,space_name,point_name,space_integer,point_integer,
s_text,p_text,s_number,p_number,type,paramno,start_pos,
last,anything,i,j,int,s_int,byte,halfword,text,octal,bit,all,
userwords,userhw,userhw1,proc_base,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,last_int_w;
boolean ok,not_online,morelines,sp,nl,halfw;
integer array field iaf;
procedure core;
begin
system(5,92,contents);
last_int_w:=38+(contents(3)-contents(1))//2;
comment include number of discs and drums;
system(5,contents(1),contents);
system(5,contents(1)-36,chain1);
system(5,contents(2)-36,chain2);
halfw:=chain1(2) extract 3 +1 = (chain2(1) - chain1(1))//2;
system(5,78,contents);
userwords:=((contents(2)-contents(1))//2 +23)//24;
userhw:=userwords*2;
userhw1:=userhw-1;
proc_base:=3+userwords;
user_a:=-proc_base+1;
end;
procedure commands;
begin
write(out,<:info :>,nl,1,
<:typein :>,nl,1,
<:end :>,nl,1,
<:veri :>,nl,1,
<:internal :>,nl,1,
<:buf :>,nl,1,
<:external :>,nl,1,
<:area :>,nl,1,
<:chain :>,nl,1);
outendcur(0);
end;
procedure info;
begin
next_param(s_text);
write(out,<:call:<10>:>,sp,6,case convert_to_number(param) of (
<:
montest typein
' makes the program enter the conversational mode ' :>,
<:
end
' makes the program leave the conversational mode ' :>,
<:
veri <first halfword>(.<no_of_halfwords>) ,
(format.integer.octal.halfword.byte.bit.text) ,
' verifies contents of <no_of_halfwords> halfwords,
starting at <first_halfword> ' :>,
<:
internal name.<name>(.<first>(.<last>))
all(.<first>(.<last>)) :>,
<::>,<::>,
<:
buf all(.<first>(.<last>))
sender.<sender>(.<first>(.<last>))
receiver.<receiver>(.<first>(.<last>))
sender.<sender> receiver.<receiver>(.<first>(.<last>))
s.<sender>(.<first>(.<last>))
r.<receiver>(.<first>(.<last>))
s.<sender> r.<receiver>(.<first>(.<last>)):>,
<:
external all(.<first>(.<last>))
devno.<devno>(.<first>(.<last>))
user.<user>(.<first>(.<last>))
reserver.<reserver>(.<first>(.<last>))
name.<name>(.<first>(.<last>)):>,
<:
area all(.<first>(.<last>))
user.<user>(.<first>(.<last>))
reserver.<reserver>(.<first>(.<last>))
name.<name>(.<first>(.<last>)) :>,
<:
chain all(.<first>(.<last>))
docname.<docname>(.<first>(.<last>)) :>,
<::>,<::>,<::>,<::>,
<::>,<::>,<::>,<::>,<::>),nl,1);
outendcur(0);
end;
procedure type_error(cause,name);
string cause ;
array name ;
begin
integer i;
i:= 1;
write(out,nl,1,cause,sp,2,string name(increase(i)),nl,1);
outendcur(0);
goto if notonline then endprogram else nextline;
end;
procedure typein;
begin
integer i;
if -,notonline then
begin
outendcur(0);
setposition(in,0,0);
readchar(in,i);
if i = 102 <* f *> then goto nextline;
setposition(in,0,0);
end;
end;
\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;
integer array field iaf;
real array field raf;
iaf:= 512;
found:= false;
raf:= 6;
move( 72,iarr);
no_of_procs:= (iarr(5)-iarr(1))//2;
move(iarr(1),table);
for i:= 1,i+1 while i <= no_of_procs and -,found do
begin
move(table(i)-4,iarr);
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 type_error(<:not found: :>,name);
end get_descr_or_name;
\f
procedure veri;
begin
own boolean mask_set;
integer first,halfwords,i,segments,words,segm,mask,addr,type;
addr:= 0;
next_param(s_number); first:= round param(1);
halfwords:= 2;
type:= anything;
if next_param(type) then
begin
if type = p_number
then halfwords:= round param(1)
else paramno:= paramno - 1; <* try again *>
end;
while next_param(s_text) do
begin
if param(1) = real<:forma:> add 116 then
begin <* format specification *>
mask:= 0; mask_set:= true;
while next_param(p_text) do
begin
case format of
begin
mask:= mask add int;
mask:= mask add octal;
mask:= mask add halfword;
mask:= mask add byte;
mask:= mask add bit;
mask:= mask add text;
mask:= all;
type_error(<:illegal format:>,dummy);
end;
end;
end
else type_error(<:parameter error:>,dummy);
end while;
if -,mask_set then mask:= all; <* default *>
segments:= halfwords//512 + 1;
i:= 1;
write(out,nl,1,
<:core:> ,<:.:>,first,nl,1);
for segm:= 1 step 1 until segments do
begin
move(first,contents);
words:= if halfwords > 512 then 256 else halfwords//2;
for i:= 1 step 1 until words do
begin
write(out,<:+:>,<<ddd>,addr,sp,2);
write_formatted(contents(i),mask);
outchar(out,10);
addr:= addr+2;
outendcur(0);
end;
first:= first + 512;
halfwords:= halfwords - 512;
end;
type_text(<::>);
end veri;
\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 internals,i,j,k;
integer array table,iarr(1:1);
real array field raf;
integer array field id;
raf:= 6; id:= 16;
move( 78,iarr);
internals:= (iarr(2)-iarr(1))//2;
move(iarr(1),table);
for i:= 1,i+1 while i <= internals do
begin
move(table(i)-4,iarr);
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 internals,i,j;
integer array table,iarr(1:1);
boolean found;
real array field raf;
raf:= 6; found:= false;
check_procfunc(name);
move( 78,iarr);
internals:= (iarr(2)-iarr(1))//2;
move(iarr(1),table);
for i:= 1,i+1 while i <= internals do
begin
move(table(i)-4,iarr);
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 type_error(<:not found:>,name);
end identification_mask;
\f
procedure read_params(specif,user_mask,reserver_mask,name,devno);
integer specif,user_mask,reserver_mask, devno ;
array name ;
begin <* used to read in parameters in call of 'area' or 'external' *>
while next_param(s_text) do
begin
if param(1) = real<:all:> then specif:= 4 else
if param(1) = real<:user:> then
begin
specif:= 1;
next_param(p_text);
check_procfunc(param);
user_mask:= identification_mask(param);
end
else
if param(1) = real<:reser:> add 118 then
begin
specif:= 2;
next_param(p_text);
check_procfunc(param);
reserver_mask:= identification_mask(param);
end
else
if param(1) = real<:name:> then
begin
specif:= 3;
next_param(p_text);
name(1):= param(1);
name(2):= param(2);
end
else
if param(1) = real<:devno:> then
begin
next_param(p_number);
devno:= round param(1);
specif:= 5;
end
else type_error(<:parameter error:>,dummy);
end;
end read_params;
\f
procedure external;
begin
procedure type_external;
begin
integer i,j;
real array field raf;
if first_typed then typein;
first_typed:= true;
raf:= 6+userhw; j:= i:= 1;
write(out,nl,1, <:core:>,
<:.:>,<<ddddd>,addr-4,nl,1,<<-ddddddddd>,
<:lower interval : :>,sp,2,contents(proc_base+l_base),nl,1,
<:upper interval : :>,sp,2,contents(proc_base+u_base),nl,1,
<:kind : :>,sp,2,contents(proc_base+kind_a),nl,1,
<:name : :>,sp,2,string contents.raf(increase(i)),
nl,1,
<:main : :>,sp,2,contents(proc_base+main_a),nl,1,
<:reserver : :>,sp,2);
write_formatted(contents(proc_base+res_a),bit);
type_names(contents(proc_base+res_a),-1);
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(contents(proc_base+user_a+(j shift (-1))),bit);
end;
type_names(contents(proc_base+user_a+j//2) shift (-((j+1) mod 2)*12) extract 12,j);
end;
write(out,nl,1,<<-ddddddddd>,
<:next message : :>,sp,2,contents(proc_base+n_mess_a),nl,1,
<:previous message : :>,sp,2,contents(proc_base+p_mess_a),nl,1);
type_text(<::>);
outendcur(0);
end type_external;
integer i,j,externals,user_mask,reserver_mask,specif,addr,k,devno;
real array name(1:2);
integer array table(1:1);
real array field raf;
boolean first_typed,found;
specif:= 4; <* default all *>
read_params(specif,user_mask,reserver_mask,name,devno);
first_typed:= found:= false;
raf:= 6+userhw;
move( 74,contents); <* first device in name table *>
externals:= (contents(2)-contents(1))//2;
move(contents(1),table);
<* scan externals *>
for i:= 1,i+1 while i <= externals do
begin
addr:= table(i);
move(addr-(4+userhw),contents);
case specif of
begin
<* user *>
if contents(proc_base+user_a+user_mask shift (-13))
shift (-((user_mask shift (-12)+1) mod 2)*12) extract 12 =
user_mask extract 12 then type_external;
<* reserver *>
if contents(proc_base+res_a) = reserver_mask then type_external;
<* name *>
if contents.raf(1) = name(1) and
contents.raf(2) = name(2) then
begin found:= true; type_external; end;
<* all *>
type_external;
<* devno *>
if devno+1 = i <* log. dev. no *> then type_external;
end case;
end while;
if specif = 3 <* name *> and -,found then type_error(<:not found:>,name);
end external;
\f
procedure area_process;
begin
procedure type_area_process;
begin
integer i,j;
real array field raf;
if first_typed then typein;
first_typed:= true;
raf:= 6+userhw; i:= j:= 1;
write(out,nl,1, <:core:>,
<:.:>,<<ddddd>,addr,nl,1,<<-ddddddddd>,
<:lower interval : :>,sp,2,contents(proc_base+l_base),nl,1,
<:upper interval : :>,sp,2,contents(proc_base+u_base),nl,1,
<:kind : :>,sp,2,contents(proc_base+kind_a),nl,1,
<:name : :>,sp,2,string contents.raf(increase(i)),
nl,1,
<:proc descr addr : :>,sp,2,contents(proc_base+pda_a),nl,1,
<:reserver : :>,sp,2);
write_formatted(contents(proc_base+res_a),bit);
type_names(contents(proc_base+res_a),-1);
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,25);
write_formatted(contents(proc_base+user_a+(j shift (-1))),bit);
end;
type_names(contents(proc_base+user_a+j//2) shift (-((j+1) mod 2)*12) extract 12,j);
end;
write(out,nl,1,<<-ddddddddd>,
<:first slice : :>,sp,2,contents(proc_base+first_slice_a),nl,1,
<:no of segments : :>,sp,2,contents(proc_base+seg_a),nl,1,
<:document : :>,sp,2);
j:= 1; raf:= 24+userhw;
write(out,string contents.raf(increase(j)),nl,1);
write(out,<<-ddddddddd>,
<:write access counter : :>,sp,2,contents(proc_base+wa_a),nl,1,
<:read access counter : :>,sp,2,contents(proc_base+ra_a),nl,1);
type_text(<::>);
outendcur(0);
end type_area_process;
integer i,j,k,areas,user_mask,reserver_mask,specif,addr;
real array name(1:2);
integer array table(1:1);
boolean first_typed,found;
real array field raf;
specif:= 4; <* default all *>
first_typed:=found:= false;
read_params(specif,user_mask,reserver_mask,name,i);
raf:=6+userhw;
move( 76,contents); <* first area proc in name table *>
areas:= (contents(2) - contents(1))//2;
move(contents(1),table);
<* scan area procs *>
for i:= 1,i+1 while i <= areas do
begin
addr:= table(i);
move(addr-(4+userhw),contents);
case specif of
begin
<* user *>
if contents(proc_base+user_a+user_mask shift (-13))
shift (-((user_mask shift (-12)+1) mod 2)*12) extract 12 =
user_mask extract 12 then type_area_process;
<* reserver *>
if contents(res_a) = reserver_mask then type_area_process;
<* name *>
if contents.raf(1) = name(1) and
contents.raf(2) = name(2) then
begin found:=true; type_area_process; end;
<* all *>
type_area_process;
end case;
end while;
if specif=3 and -,found then type_error(<:not found:>,name);
end area_process;
\f
procedure chain;
begin <* prints chainhead *>
procedure type_chain;
begin
integer i,j,k;
real array field raf1,raf2;
if first_typed then typein;
first_typed:= true;
j:= i:= k:= 1;
raf1:= 8; raf2:= 18;
write(out,nl,1, <:core:>,
<:.:>,<<ddddd>,addr-36,nl,1,<<-ddddddddd>,
<:rel. addr. of claims in i. p. : :>,sp,2,contents(1),nl,1,
<:first slice in auxcat : :>,sp,2,
contents(2) shift (-12) extract 12,nl,1,
<:bs kind : :>,sp,2,if contents(2)
shift (-3) extract 1 = 1 then <:disc:> else <:drum:>,nl,1,
<:permkey : :>,sp,2,
contents(2) extract 3,nl,1,
<:name of auxcat : :>,sp,2,
string contents.raf1(increase(j)),nl,1,
<:size of auxcat : :>,sp,2,contents(9),nl,1,
<:document name : :>,sp,2,
string contents.raf2(increase(k)),nl,1,
<:slice length : :>,sp,2,contents(15),nl,1,
<:last slice of document : :>,sp,2,
contents(16) shift (-12) extract 12,nl,1,
<:first slice of chaintable area : :>,sp,2,
contents(16) extract 12,nl,1,
<:state of document : :>,sp,2);
for i:= 0 step 1 until 6 do
if contents(17) shift (-(12+i)) extract 1 = 1 then
write(out,case i+1 of ( <:idle:>,<:after prepare:>,<:during insert:>,
<:ready:>,<:during delete:>,<:during aux:>));
write(out,nl,1,<:start of chaintable at addr : :>,sp,2,<<-ddddddddd>,addr,nl,1);
typetext(<::>);
end type_chain;
boolean found,first_typed,all;
integer i,j,chains,addr;
real array docname(1:2);
integer array table(1:1);
real array field raf;
all:= true; <* default all *>
found:= first_typed:= false;
raf:= 18;
while next_param(s_text) do
begin
if param(1) = real<:all:> then all:= true else
if param(1) = real<:docna:> add 109 then
begin
next_param(p_text);
docname(1):= param(1);
docname(2):= param(2);
all:= false;
end
else type_error(<:parameter error:>,dummy);
end;
<* scan chainheads *>
move( 92,contents);
chains:= (contents(3)-contents(1))//2;
move(contents(1),table);
for i:= 1,i+1 while i <= chains do
begin
addr:= table(i);
move(addr-36,contents);
if all then type_chain else
if docname(1) = contents.raf(1) and
docname(2) = contents.raf(2) then
begin found:= true; type_chain end;
end;
if -,all and -,found then type_error(<:not found: :>,docname);
end chain;
\f
procedure buf;
begin
procedure type_buf(contents);
integer array contents ;
begin
integer i,j;
real array name(1:2);
if first_typed then typein;
first_typed:= true;
j:= 1;
write(out,nl,1, <:core:>,
<:.:>,<<-dddddd>,start_addr+base,nl,1,
<:message flag : :>,contents(1),nl,1,
<:next buffer : :>,contents(2),nl,1,
<:prev buffer : :>,contents(3),nl,1,
<:receiver/result : :>,contents(4));
if abs(contents(4)) > 7 <* receiver addr *> then
begin
get_descr_or_name(name,abs(contents(4)//2*2),false);
j:= 1;
write(out,sp,3,string name(increase(j)));
end;
outchar(out,10);
write(out,<:sender : :>,<<-dddddd>,contents(5));
if abs(contents(5)) > 0 then
begin
get_descr_or_name(name,abs(contents(5)),false);
j:= 1;
write(out,sp,3,string name(increase(j)));
end;
outchar(out,10);
for i:= 6 step 1 until last//2 do
begin
write_formatted(contents(i),all);
type_text(<::>);
end;
end type_buf;
integer i,j,sender,receiver,check,addr,start_addr,top,moves,buffers;
own integer first,last;
boolean total,ok,first_typed;
integer array field base;
check:= 0;
total:= true; <* default all *>
first_typed:= false;
type:=anything;
while next_param(type) do
begin
case type of
begin
begin
if param(1) = real<:all:> then total:= true else
if param(1) = real<:sende:> add 114 then
begin
check:= check+1;
next_param(p_text);
check_procfunc(param);
get_descr_or_name(param,sender,true);
end
else
if param(1) = real<:recei:> add 118 then
begin
check:= check+2;
next_param(p_text);
check_procfunc(param);
get_descr_or_name(param,receiver,true);
end
else
type_error(<:parameter error:>,dummy);
end;;;
begin <* p_number *>
first:= round param(1);
if first < 1 or first > 26 then first:= 1;
last:= first;
type:= anything;
if next_param(type) then
begin
if type = p_number then
begin
last:= round param(1);
if last < first or last > 26 then last:= 26;
end
else paramno:= paramno-1; <* try again *>
end;
end;
end;
type:= anything;
end while;
<* scan mess buffers *>
total:= check = 0;
move( 86,contents);
start_addr:= contents(1)-2;
buffers:= (contents(2)-contents(1))/26;
top:= 8*26; <*bufsize*8*>
moves:= (buffers-1)//9+1;
for i:= 1 step 1 until moves do
begin
move(start_addr,contents);
for base:= 0 step 26 until top do
begin
if -,total then
begin
ok:= false;
case check+1 of
begin;
ok:= abs(contents.base(5)) = sender;
ok:= abs(contents.base(4)//2*2) = receiver;
ok:= abs(contents.base(4)//2*2) = receiver and
abs(contents.base(5)) = sender;
end;
end;
if ok or total then type_buf(contents.base);
end;
buffers:= buffers-9;
top:= if buffers >= 9 then top else (buffers-1)*26;
start_addr:= start_addr+9*26;
end;
end buf;
\f
procedure internal;
begin
procedure type_descr;
begin
integer i,j;
if first_typed then typein;
first_typed:= true;
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;
write(out,nl,1,<:start of internal process : :>,
<:core:>,<:.:>,<<ddddd>,addr,nl,1);
for i:= first step 1 until last do
begin
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 : :>,
<:bs claims 0 : :>,
<:bs claims 1 : :>,
<:bs claims 2 : :>,
<:bs claims 3 : :>,
<:bs claims 4 : :>,
<:bs claims 5 : :>,
<:bs claims 6 : :>,
<:bs claims 7 : :>,
<:bs claims 8 : :> ));
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);
end;
case i of
begin
begin <* interval limits *>
write_formatted(contents(1),int);
write_formatted(contents(2),int);
end;
<* kind *>
write_formatted(contents(3),int);
<* name *>
for j:= 1 step 1 until 4 do
write_formatted(contents(j+3),text);
<* stop count,state *>
write_formatted(contents(8),halfword + bit);
<* identification *>
write_for_matted(contents(9),bit);
begin <* next,last event *>
write_formatted(contents(10),int);
write_formatted(contents(11),int);
end;
begin <* next,last process *>
write_formatted(contents(12),int);
write_formatted(contents(13),int);
end;
begin <* first,top address *>
write_formatted(contents(14),int);
write_formatted(contents(15),int);
end;
<* buf,area *>
write_formatted(contents(16),halfword);
<* internal claim,function mask *>
write_formatted(contents(17),halfword+bit);
<* priority *>
write_formatted(contents(18),int);
<* mode (pk,pr) *>
write_formatted(contents(19),halfword);
<* interrupt mask *>
write_formatted(contents(20),bit);
begin <* exception,escape address *>
write_formatted(contents(21),int);
write_formatted(contents(22),int);
end;
begin <* initial cpa,base *>
write_formatted(contents(23),int);
write_formatted(contents(24),int);
end;
begin <* initial write limits *>
write_formatted(contents(25),int);
write_formatted(contents(26),int);
end;
<* interrupt levels *>
write_formatted(contents(27),halfword);
<* parent description *>
write_formatted(contents(28),int);
<* quantum *>
write_formatted(contents(29),int);
begin <* run time *>
write_formatted(contents(30),int);
write_formatted(contents(31),int);
end;
begin <* start run *>
write_formatted(contents(32),int);
write_formatted(contents(33),int);
end;
begin <* start wait *>
write_formatted(contents(34),int);
write_formatted(contents(35),int);
end;
<* wait address *>
write_formatted(contents(36),int);
begin <* catalog base *>
write_formatted(contents(37),int);
write_formatted(contents(38),int);
end;
begin <* max base *>
write_formatted(contents(39),int);
write_formatted(contents(40),int);
end;
begin <* std base *>
write_formatted(contents(41),int);
write_formatted(contents(42),int);
end;
<* w0 *>
write_formatted(contents(43),all);
<* w1 *>
write_formatted(contents(44),all);
<* w2 *>
write_formatted(contents(45),all);
<* w3 *>
write_formatted(contents(46),all);
<* status *>
write_formatted(contents(47),bit);
begin <* ic,cause,sb *>
write_formatted(contents(48),int);
write_formatted(contents(49),int);
write_formatted(contents(50),int);
end;
begin <* current cpa,base *>
write_formatted(contents(51),int);
write_formatted(contents(52),int);
end;
begin <* current write limits *>
write_formatted(contents(53),int);
write_formatted(contents(54),int);
end;
<* current interrupt levels *>
write_formatted(contents(55),halfword);
<* save area *>
write_formatted(contents(56),int);
<* g20-g24 *>
for j:= 57 step 1 until 61 do
write_formatted(contents(j),int);
begin <* b18,b19 *>
write_formatted(contents(62),int);
write_formatted(contents(63),int);
end;
<* bs claims 0 *>
for j:= first_bs_claims step 1 until last_bs_claims do
write_formatted(contents(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(contents(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(contents(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(contents(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(contents(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(contents(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(contents(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(contents(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(contents(j),if halfw then halfword else s_int);
end case;
type_text(<::>);
end for;
end type_descr;
own boolean init;
own integer first,last;
integer i,j,type,internals,addr,first_bs_claims,last_bs_claims;
boolean found,type_all,first_typed;
real array name(1:2);
integer array table(1:1);
real array field raf;
type_all:= true;
first_typed:= found:= false;
raf:= 6; <* refers to name in proc descr *>
type:= anything;
while next_param(type) do
begin
case type of
begin
begin <* s_text *>
if param(1) = real<:all:> then type_all:= true else
if param(1) = real<:name:> then
begin
next_param(p_text);
name(1):= param(1);
name(2):= param(2);
check_procfunc(name);
type_all:= false;
end
else type_error(<:parameter error:>,dummy);
end;;;
begin <* p_number *>
first:= round param(1);
init:= true;
if first < 1 or first > 41 then first:= 1;
last:= first;
type:= anything;
if next_param(type) then
begin
if type = p_number then
begin
last:= round param(1);
if last < first or last > last_int_w then last:= last_int_w;
end
else paramno:= paramno-1; <* try again *>
end;
end;
end case;
type:= anything;
end while;
if -,init then
begin
first:= 1;
last:= last_int_w;
end;
<* search internal proc descr *>
move( 78,contents); <* first internal in name table *>
internals:= (contents(2)-contents(1))//2 - 1;
move(contents(1),table);
for i:= 1,i+1 while i <= internals do
begin
addr:= table(i);
move(addr-4,contents);
if type_all then type_descr else
if name(1) = contents.raf(1) and
name(2) = contents.raf(2) then type_descr;
end;
if -,type_all and -,found then type_text(<:<10>not found:>);
end internal;
\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,sp,2); <* integer *>
begin <* octal *>
for j:= 21 step -3 until 0 do
write(out,<<d>,word shift(-j) extract 3);
write(out,sp,2);
end;
write(out,<<dddd>,word shift (-12) extract 12,sp,1,word extract 12,
sp,2); <* halfword *>
write(out,<<ddd>,word shift (-16) extract 8,sp,1,word shift (-8) extract 8,
sp,1,word extract 8,sp,2); <* byte *>
begin <* bit *>
for j:= 0 step 1 until 23 do
write(out,if word shift j < 0 then <:1:> else <:.:>);
write(out,sp,2);
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;
end;
write(out,<<ddddd>,word,sp,2); <* short integer *>
end case;
end;
end for-loop;
end write_formatted;
\f
integer procedure format;
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;
procedure type_text(text);
string text ;
begin
write(out,text,nl,1);
outendcur(0);
end;
\f
procedure move(first,contents);
value first ;
integer first ;
integer array contents ;
begin <* moves 256 words core,starting at absolute
address 'first', to array 'contents', starting at contents(1) *>
if false then system(5)move core area:(first,contents) else
redefarray(contents,first,1024);
end move;
\f
boolean procedure next_param(type);
integer type ;
begin <* this procedure returns the next call parameter in array
'param' .
1<= type <= 4 :
type checking is performed as follows:
type=1 (call): space_name is demanded
type=2 - : point_name -
type=3 - : space_integer -
type=4 - : point_integer -
in case of errors error messages are written
on current output.
type = 5 : any type is accepted. the actual type value
(1,2,3 or 4) is returned.
the procedure returns true as long as the next parameter exists,
otherwise false. *>
procedure conv_error(number,i,type,delim);
value number,i,type,delim ;
integer number,i,type,delim ;
begin <* error-messages in conversational mode *>
write(out,<:<10>illegal parameter no. :>,paramno,
<: , read: :>);
if delim = 0
then write(out,<:<integer>:>)
else outchar(out,delim);
if kind(i) = 6 <* text *>
then write(out,string ra(increase(i)))
else
if kind(i) = 2 <* legal number *>
then write(out,round ra(i))
else write(out,<: illegal number :>);
write(out,<:<10>:>);
outendcur(0);
goto next_line;
end conv_error;
boolean ok;
integer sep,action,number,delim,separator;
if not_online then
begin <* fp_mode *>
sep:= system(4,paramno,param);
if sep <> 0 then
begin
case type of
begin
ok:= sep = space_name;
ok:= sep = point_name;
ok:= sep = space_integer;
ok:= sep = point_integer;
begin <* return actual type *>
type:= if sep = space_name then 1 else
if sep = point_name then 3 else
if sep = space_integer then 3 else
if sep = point_integer then 4 else 5;
ok:= type <> 5;
end;
end;
if -,ok then
begin
separator:= 5;
for i:= 1 step 1 until 4 do
if sep = ( case i of (space_name,point_name,space_integer,
point_integer)) then separator:= i ;
write(out,<:<10>***:>,<:: illegal fpparameter no. :>,
paramno,<: , read: :>,case separator of (<: :>,<:.:>,
<: :>,<:.:>,<::>));
if separator < 3 <* name *> then
begin
i:= 1;
write(out,string param(increase(i)));
end
else
write(out,round param(1));
goto endprogram;
end -, ok;
end;
next_param:= sep <> 0;
end
else
begin <* conversational mode *>
delim:= 0;
number:= -1;
<* search item *>
for i:= 0,i + 1 while kind(i) <> 8 and number < paramno do
begin
action:= case ((kind(i)-1)*8 + kind(i+1)) of
<* kind(i+1) *>
( 3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
<* kind(i) *> 3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
1 , 1 , 3 , 3 , 3 , 1 , 2 , 2 ) ;
case action of
begin
number:= number + 1; <* text or integer found *>
; <* skip *>
begin <* error *>
write(out,<:<10>action-table in error:>);
goto endprogram;
end;
end;
end for-loop;
if number = paramno then
begin <* now 'i' points at the first element of the
item in array 'ra' . get the item and check it . *>
if kind(i-1) = 7 then delim:= round ra(i-1);
case type of
begin
<* space-name *> if delim <> 32 or kind(i) <> 6
then conv_error(number,i,1,delim);
<* point-name *> if delim <> 46 or kind(i) <> 6
then converror(number,i,2,delim);
<* space-int. *> if delim <> 32 or kind(i) <> 2
then conv_error(number,i,3,delim);
<* point-int. *> if delim <> 46 or kind(i) <> 2
then conv_error(number,i,4,delim);
<* any type *> begin
if delim=32 and kind(i)=6 then type:= 1 else
if delim=46 and kind(i)=6 then type:= 2 else
if delim=32 and kind(i)=2 then type:= 3 else
if delim=46 and kind(i)=2 then type:= 4 else
conv_error(number,i,5,delim);
end;
end case;
<* return item in 'param' *>
if type < 3 then
begin <* text *>
param(1):= ra(i);
param(2):= if kind(i+1) <> 6 then real <::> else
ra(i+1) shift(-8) shift 8; <* max 11 chars *>
end
else
param(1):= ra(i);
end;
next_param:= number = paramno;
end conversational mode;
paramno:= paramno + 1;
end next_param;
\f
integer procedure convert_to_number(param);
array param ;
begin
integer i;
convert_to_number:= 19;
for i:= 1 step 1 until 18 do
begin
if param(1) = ( case i of ( real<:typei:> add 110 ,
real<:end:> ,
real<:veri:> ,
real<:inter:> add 110 ,
real<:comma:> add 110 ,
real<:info:> ,
real<:buf:> ,
real<:exter:> add 110 ,
real<:area:> ,
real<:chain:> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> )) and
param(2) = ( case i of ( real<::> ,
real<::> ,
real<::> ,
real<:al:> ,
real<:ds:> ,
real<::> ,
real<::> ,
real<:al:> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ))
then convert_to_number:= i;
end;
end convert_to_number;
\f
procedure outtable(alphabet,length);
value length ;
integer length ;
integer array alphabet ;
begin <* enter 'class shift 12 + value' corresponding to the 'length'
first characters of the current alphabet in array 'alphabet'.
used for later call of 'intable' . *>
zone alpha(25,1,blockproc);
integer class,char,i;
procedure blockproc(z,s,b);
zone z ;
integer s,b ;
if (s shift (-5)) extract 1 <> 1 then stderror(z,s,b) else b:= 25*4;
if length < 0 or length > 127 then length:= 127;
open(alpha,0,<::>,1 shift 5);
for i:= 0 step 1 until length do write(alpha,false add i,1);
write(alpha,false add 10,1);
setposition(alpha,0,0);
for i:= 0 step 1 until length do
begin
class:= readchar(alpha,char);
if char <> i then
begin
class:= 0;
repeatchar(alpha);
end;
alphabet(i):= class shift 12 + i;
end;
end outtable;
\f
<* m a i n p r o g r a m *>
dummy(1):= dummy(2):= real<::>;
iaf:= 0;
<* constant definitions *>
s_text:= 1;
p_text:= 2;
s_number:= 3;
p_number:= 4;
anything:= 5;
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;
sp:= false add 32;
nl:= false add 10;
space_name:= 4 shift 12 + 10;
point_name:= 8 shift 12 + 10;
space_integer:= 4 shift 12 + 4;
point_integer:= 8 shift 12 + 4;
not_online:= true;
kind(0):= 7; <* delimiter *>
ra(0):= 32 ; <* space *>
paramno:= 1;
if system(4,1,param)=6 shift 12 + 10 then
begin
comment output param;
system(4,0,param);
connect_cur_o(param);
paramno:=2;
end;
move(92,contents);
last_int_w:=38+(contents(3)-contents(1))//2;
comment include number of discs and drums;
system(5,contents(1),contents);
system(5,contents(1)-36,chain1);
system(5,contents(2)-36,chain2);
halfw:=chain1(2) extract 3 +1 = (chain2(1) - chain1(1))//2;
system(5,78,contents);
userwords:=((contents(2)-contents(1))//2 +23)//24;
userhw:=userwords*2;
userhw1:=userhw-1;
proc_base:=3+userwords;
user_a:=-proc_base+1;
if next_param(s_text) then
begin
<* decide action *>
case convert_to_number(param) of
begin
begin <* typein - enter conversational mode *>
not_online:= false;
<* modify standardalphabet *>
outtable(alphabet,127);
for i:= 39,43,46 do alphabet(i):= 7 shift 12 + i;
intable(alphabet);
tableindex:= 0;
nextline: morelines:= true;
start_pos:= 1;
while morelines do
begin <* read lines of command *>
setposition(in,0,0);
i:= readall(in,ra,kind,start_pos);
if i < 0 then
begin <* array bounds exceeded *>
write(out,<:<10>command too long - last line skipped<10>:>);
outendcur(0);
kind(start_pos):= 8; <* terminates inf. in 'ra' and 'kind'*>
morelines:= false;
end
else
begin <* check if current line terminates command *>
for i:= 0,i+1 while round ra(i) = 32 do;
if kind(i) = 8 then goto nextline; <* skip if no command *>
for i:= startpos,i+1 while kind(i) <> 8 do;
last:= i;
ra(last):= 32;
kind(last):= 7;
for i:= i,i-1 while kind(i) = 7 and round ra(i) = 32 do;
if (kind(i) = 7 and round ra(i) = 44) <* comma *> then
begin
ra(i):= ra(i+1):= 32; <* space *>
kind(i):= kind(i+1):= 7;
startpos:= i+1;
end
else
begin
morelines:= false;
kind(last):= 8;
end;
end;
end while_loop;
<* start execution of command *>
paramno:= 0;
next_param(s_text);
case convert_to_number(param) of
begin
<* typein ignored *> ;
goto endprogram ; <* end *>
veri ;
internal ;
commands ;
info ;
buf ;
external ;
area_process ;
chain ;;;;;;;;;
begin <* illegal command *>
i:= 1;
write(out,<:<10>*** illegal command : :>,
string param(increase(i)),<:<10>:>);
outendcur(0);
end;
end case;
goto nextline;
end conv_mode;
<* end *> ;
veri ;
internal ;
commands ;
info ;
buf ;
external ;
area_process;
chain ;;;;;;;;;
begin <* illegal fpparameter *>
i:= 1;
write(out,<:<10>*** illegal fpparameter : :>,
string param(increase(i)));
goto endprogram;
end;
end case;
end
else
type_text(<:try 'desc commands' and 'info <command>':>);
endprogram:
outendcur(0);
if fpout then closeout;
end;
▶EOF◀