|
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: 48384 (0xbd00)
Types: TextFile
Names: »tmontest«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦393858ad9⟧ »tsysprog«
└─⟦this⟧
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »tmontest«
begin <* this program is used for monitor testing *>
integer array kind(0:100),alphabet(0:127),contents(1:256);
real array ra(0:100),area,param,dummy(1:2);
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,byte,halfword,text,octal,bit,all;
boolean ok,not_online,dump_area,morelines,sp,nl;
integer array field iaf;
zone zdump(128,1,stderror);
\f
procedure dump;
begin <* creates an area process to a backing storage area
containing a coredump *>
integer i;
next_param(p_text);
area(1):= param(1);
area(2):= param(2);
dump_area:= true;
i:= 1;
close(zdump,true);
open(zdump,4,string param(increase(i)),0);
end dump;
procedure core;
dump_area:= false;
procedure commands;
begin
write(out,<:info :>,nl,1,
<:typein :>,nl,1,
<:end :>,nl,1,
<:dump :>,nl,1,
<:core :>,nl,1,
<:veri :>,nl,1,
<:internal :>,nl,1,
<:buf :>,nl,1,
<:external :>,nl,1,
<:area :>,nl,1,
<:chain :>,nl,1);
setposition(out,0,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 ' :>,
<:
dump.<dumparea>
' further commands will refer to the bs-file
given by <dumparea> ' :>,
<:
core
' further commands will refer to the core
residing system ' :>,
<:
veri <first halfword>(.<no_of_halfwords>) ,
(format.integer.octal.halfword.byte.bit.text) ,
(dump.<dumparea>)
' verifies contents of <no_of_halfwords> halfwords,
starting at <first_halfword> ' :>,
<:
internal name.<name>(.<first>(.<last>)) (dump.<dumparea>)
all(.<first>(.<last>)) - '' - :>,
<::>,<::>,
<:
buf all (dump.<dumparea>)
sender.<sender> - '' -
receiver.<receiver> - '' -
sender.<sender> receiver.<receiver> - '' - :>,
<:
external all (dump.<dumparea>)
devno.<devno> - '' -
user.<user> - '' -
reserver.<reserver> - '' -
name.<name> - '' - :>,
<:
area all (dump.<dumparea>)
user.<user> - '' -
reserver.<reserver> - '' -
name.<name> - '' - :>,
<:
chain all (dump.<dumparea>)
docname.<docname> - '' - :>,
<::>,<::>,<::>,<::>,
<::>,<::>,<::>,<::>,<::>),nl,1);
setposition(out,0,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);
setposition(out,0,0);
goto if notonline then endprogram else nextline;
end;
procedure typein;
begin
integer i;
if -,notonline then
begin
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:256),table(1:512);
integer i,j,no_of_procs;
boolean found;
integer array field iaf;
real array field raf;
iaf:= 512;
found:= false;
raf:= 6;
move(if dump_area then 1200 else 72,iarr);
no_of_procs:= (iarr(5)-iarr(1))//2;
move(iarr(1),table);
if dump_area then
move(iarr(1)+512,table.iaf);
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
if param(1) = real<:dump:> then
begin
dump;
area(1):= param(1);
area(2):= param(2);
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,if dump_area then string area(increase(i))
else <: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;
setposition(out,0,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);
integer mask ;
begin
integer internals,i,j,k;
integer array table,iarr(1:256);
real array field raf;
integer array field id;
raf:= 6; id:= 16;
move(if dump_area then 1206 else 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 23 do
if mask shift (-k) extract 1 = 1 and
iarr.id(1) shift (-k) extract 1 = 1 then
begin <* id-mask of internal is contained in 'mask' *>
if iarr.raf(1) = real<:pro:> shift (-24) <* i. e. procfunc *> then
begin
iarr.raf(1):= real<:procf:> add 117;
iarr.raf(2):= real<:nc:>;
end;
j:= 1;
write(out,sp,2,string iarr.raf(increase(j)));
end;
end;
end type_names;
\f
integer procedure identification_mask(name);
array name ;
begin
integer internals,i,j;
integer array table,iarr(1:256);
boolean found;
real array field raf;
raf:= 6; found:= false;
check_procfunc(name);
move(if dump_area then 1206 else 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<:dump:> then dump 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; j:= i:= 1;
write(out,nl,1,if dump_area then string area(increase(j)) else <:core:>,
<:.:>,<<ddddd>,addr-4,nl,1,<<-ddddddddd>,
<:lower interval : :>,sp,2,contents(1),nl,1,
<:upper interval : :>,sp,2,contents(2),nl,1,
<:kind : :>,sp,2,contents(3),nl,1,
<:name : :>,sp,2,string contents.raf(increase(i)),
nl,1,
<:main : :>,sp,2,contents(8),nl,1,
<:reserver : :>,sp,2);
write_formatted(contents(9),bit);
type_names(contents(9));
write(out,nl,1,
<:users : :>,sp,2);
write_formatted(contents(10),bit);
type_names(contents(10));
write(out,nl,1,<<-ddddddddd>,
<:next message : :>,sp,2,contents(11),nl,1,
<:previous message : :>,sp,2,contents(12),nl,1);
type_text(<::>);
setposition(out,0,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:256);
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;
move(if dump_area then 1202 else 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,contents);
case specif of
begin
<* user *>
for k:= 0 step 1 until 23 do
if contents(10) shift (-k) extract 1 = 1 and
user_mask shift (-k) extract 1 = 1 then type_external;
<* reserver *>
if contents(9) = 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; i:= j:= 1;
write(out,nl,1,if dump_area then string area (increase(j)) else <:core:>,
<:.:>,<<ddddd>,addr,nl,1,<<-ddddddddd>,
<:lower interval : :>,sp,2,contents(1),nl,1,
<:upper interval : :>,sp,2,contents(2),nl,1,
<:kind : :>,sp,2,contents(3),nl,1,
<:name : :>,sp,2,string contents.raf(increase(i)),
nl,1,
<:proc descr addr : :>,sp,2,contents(8),nl,1,
<:reserver : :>,sp,2);
write_formatted(contents(9),bit);
type_names(contents(9));
write(out,nl,1,
<:users : :>,sp,2);
write_formatted(contents(10),bit);
type_names(contents(10));
write(out,nl,1,<<-ddddddddd>,
<:first slice : :>,sp,2,contents(11),nl,1,
<:no of segments : :>,sp,2,contents(12),nl,1,
<:document : :>,sp,2);
j:= 1; raf:= 24;
write(out,string contents.raf(increase(j)),nl,1);
write(out,<<-ddddddddd>,
<:write access counter : :>,sp,2,contents(17),nl,1,
<:read access counter : :>,sp,2,contents(18),nl,1);
type_text(<::>);
setposition(out,0,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:256);
boolean first_typed;
real array field raf;
specif:= 4; <* default all *>
raf:= 6;
first_typed:= false;
read_params(specif,user_mask,reserver_mask,name,i);
move(if dump_area then 1204 else 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,contents);
case specif of
begin
<* user *>
for k:= 0 step 1 until 23 do
if contents(10) shift (-k) extract 1 = 1 and
user_mask shift (-k) extract 1 = 1 then type_area_process;
<* reserver *>
if contents(9) = reserver_mask then type_area_process;
<* name *>
if contents.raf(1) = name(1) and
contents.raf(2) = name(2) then type_area_process;
<* all *>
type_area_process;
end case;
end while;
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,if dump_area then string area(increase(i)) else <: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:256);
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<:dump:> then dump 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(if dumparea then 1214 else 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,if dump_area then string area(increase(j)) else <: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 13 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;
boolean total,ok,first_typed;
integer array field base;
check:= 0;
total:= true; <* default all *>
first_typed:= false;
while next_param(s_text) do
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
if param(1) = real<:dump:> then dump else
type_error(<:parameter error:>,dummy);
end while;
<* scan mess buffers *>
total:= check = 0;
move(if dump_area then 1210 else 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;
j:= 1;
write(out,nl,1,<:start of internal process : :>,if dump_area then string area(increase(j)) else
<: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 : :> ));
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),int);
<* 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),int);
<* 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:= 64 step 1 until 67 do
write_formatted(contents(j),halfword);
<* bs claims 1 *>
for j:= 68 step 1 until 71 do
write_formatted(contents(j),halfword);
<* bs claims 2 *>
for j:= 72 step 1 until 75 do
write_formatted(contents(j),halfword);
end case;
type_text(<::>);
end for;
end type_descr;
own boolean init;
own integer first,last;
integer i,j,type,internals,addr;
boolean found,type_all,first_typed;
real array name(1:2);
integer array table(1:256);
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<:dump:> then dump else
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 > 41 then last:= 41;
end
else paramno:= paramno-1; <* try again *>
end;
end;
end case;
type:= anything;
end while;
if -,init then
begin
first:= 1;
last:= 41;
end;
<* search internal proc descr *>
move(if dump_area then 1206 else 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 5 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;
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);
setposition(out,0,0);
end;
\f
procedure move(first,contents);
value first ;
integer first ;
integer array contents ;
begin <* moves 256 words from dumparea or core,starting at absolute
address 'first', to array 'contents', starting at contents(1) *>
integer start_segment,no_of_segments,segment,start_word,no_of_words,
word,index;
integer array field iaf;
if dump_area then
begin <* move from dump area *>
no_of_words:= 256;
index:= 1;
iaf:= 0;
start_segment:= first//512;
no_of_segments:= if (first mod 512) = 0 then 1 else 2;
start_word:= (first//2) mod 256 + 1;
setposition(zdump,0,start_segment);
for segment:= 1 step 1 until no_of_segments do
begin
inrec6(zdump,512);
for word:= start_word step 1 until no_of_words do
begin
contents(index):= zdump.iaf(word);
index:= index + 1;
end;
no_of_words:= startword-1;
start_word:= 1;
end;
end
else
system(5)move core area:(first,contents);
end move;
\f
procedure lockall;
begin
integer oldprogmode, oldtrapmode, segm;
begin <*make sure that the process size is sufficient *>
integer array coresize (1 : 256 * discprogsiz);
end;
lock (6, discprogsiz - 1); <*lock all upper part of prog in core*>
oldprogmode := progmode; progmode := 1 shift 1; <* lock all segm*>
oldtrapmode := trapmode; trapmode := -1 ; <* no alarms *>
trap (after_load);
lock (0, 0); <* this will maybe provoke an error *>
after_load:
<* now all prog segments, incl alarmsegment 0, has been locked *>
progmode := oldprogmode;
trapmode := oldtrapmode;
if alarmcause extract 24 = -1 <* stack alarm *> then
system (9, alarmcause shift (-24) extract 24, <:<10>stack :>);
end procedure lockall;
\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>:>);
setposition(out,0,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:= 21;
for i:= 1 step 1 until 20 do
begin
if param(1) = ( case i of ( real<:typei:> add 110 ,
real<:end:> ,
real<:dump:> ,
real<:core:> ,
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<::> ,
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;
all:= 63;
dump_area:= false; <* default core *>
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 next_param(s_text) then
begin
<* decide action *>
case convert_to_number(param) of
begin
begin <* typein - enter conversational mode *>
not_online:= false;
lockall;
<* 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>:>);
setposition(out,0,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 *>
dump ;
core ;
veri ;
internal ;
commands ;
info ;
buf ;
external ;
area_process ;
chain ;;;;;;;;;
begin <* illegal command *>
i:= 1;
write(out,<:<10>*** illegal command : :>,
string param(increase(i)),<:<10>:>);
setposition(out,0,0);
end;
end case;
goto nextline;
end conv_mode;
<* end *> ;
<* dump *> ;
<* core *> ;
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 'montest commands' and 'info <command>':>);
endprogram:
end;
▶EOF◀