|
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: 81408 (0x13e00)
Types: TextFile
Names: »montest3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »montest3tx «
\f
begin
integer array kind(0:100), alphabet(0:127), contents(1:256), bs_name(1:4);
boolean array userbits(1:12);
real array ra(0:100), area, param, m_name , dummy(1:2);
long array progname, file_name, curr_filename (1:2),
out_file, chain____name (1:10, 1:2);
integer sep, space_name, point_name, space_integer, point_integer,
s_text, p_text, s_number, p_number, type, paramno, first,
last, anything, i, j, int, byte, halfword, text, octal, bit, all,
code, unsigned_halfw, offset, id_array_size, neg_offset,
monitor_release, name_table_start, first_device,
first_area, first_internal, name_table_end, first_mess, last_mess,
bufsize, first_drum, first_disc, last_bs, result, sepleng,
extra_lines, mask, k_value, fp_paramno, main;
boolean ok, fp_mode, dump_area, sp, nl, oldmon, repeet, quit;
integer array field iaf;
long array field file_f, chain_f;
real array field eprocname;
boolean array field userid;
zone zdump(128,1,stderror);
\f
procedure dump;
begin <* creates an area process to a backing storage area
containing a coredump *>
integer i, type;
integer array iadummy (1:1);
type := anything;
next_param (type);
if type <> s_text then
type_error (type, <:parameter error ::>, param)
else
begin
area(1):= param(1);
area(2):= param(2);
dump_area:= true;
i:= 1;
close(zdump,true);
open(zdump,4,string param(increase(i)),0);
i := monitor (52) create area process :(zdump, 0, iadummy);
if i > 0 then
typeerror (s_text, case i of (
<:create area process claims exceeded:>,
<:create area process catalog i/o error:>,
<:create area process entry not found:>,
<:create area process not area entry:>,
<:create area process name format illegal:>), param);
init_pointers;
end;
end dump;
procedure core;
begin
dump_area:= false;
init_pointers;
end;
\f
procedure commands;
begin
write (out,
<:(<outfile> =) :>, nl, 2,
<:montest <commands>:>, nl, 2,
<:<commands> =:>, nl, 2,
<:typein :>, nl, 1,
<:end :>, nl, 1,
<:dump :>, nl, 1,
<:core :>, nl, 1,
<:veri :>, nl, 1,
<:internal :>, nl, 1,
<:commands :>, nl, 1,
<:info :>, nl, 1,
<:buf :>, nl, 1,
<:external :>, nl, 1,
<:area :>, nl, 1,
<:chain :>, nl, 1,
<:lock :>, nl, 1,
<:o :>, nl, 1,
<:extra :>, nl, 1,
<:format :>, nl, 1,
<:lines :>, nl, 1);
outend (out);
end;
\f
procedure info;
begin real infor;
infor := real
<:
info <command>
' displays information on how to execute <command> ' :>;
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,
i.e. parameters are read from current input in-
stead of fp call.
In conversational mode four one letter directives
prompted by '>' may be used after each display of a
process descriptor / message buffer / chain :
<empty> <nl> : displays the next record
repeat <nl> : repeats the same record
out <file> <nl> : connects current output to file and
accepts the next directive
finis <nl> : finishes displaying and accepts new
command ':>,
<:
end
' terminates conversational mode and returns to fp
mode, i.e. commands are read from fp call again.
If typein is the last parameter, the program ter-
minates.
in fp mode the command is blind ':>,
<:
dump <dumparea>
' further commands will refer to the backing storage
area given by <dumparea>, cf.the command core ':>,
<:
core
' further commands will re residentfer to the core
system, cf. the command dump ':>,
\f
<:
veri <first half> (.<no of halfs>)
' verifies contents of <no_of_halfwords> halfwords,
starting at <first_halfword> displaying them in
in the format at present valid, cf. the command
format ':>,
<:
internal all
name.<name>
' displays a number of lines from the internal
process descriptions specified, cf. the com-
mand lines ' :>,
<:
commands
' displays the repertoire of commands ' :>,
string infor,
<:
buf all
sender.<sender>
receiver.<reveiver>
sender.<sender>.receiver.<receiver>
receiver.<receiver>.sender.<sender>
addr.<int>
addr.<int>.all
' displays the message buffers specified ' :>,
<:
external all
user.<user>
reserver.<reserver>
main.<main process>
name.<name>
devno.<devno>
devno.<devno>.all
' displays the external process descriptions
specified, cf. the command extra ' :>,
\f
<:
area all
user.<user>
reserver.<reserver>
main.<main process>
name.<name>
' displays the area process descriptions
specified, cf. the command extra ' :>,
<:
chain all
docname.<docname>
' displays the chaintables specified ' :>,
<:
lock
' the command will cause all of the programs segments
to be transferred to core and locked ':>,
<:
o filename
' the command will stack current output and connect
it to the file specified
the connection will exist until the next o command ':>,
<:
extra <lines>
' the specified number of extra lines from process
and area process descriptions will be displayed
in the format at present valid, cf. the command
format
the number is valid until changed by another ex-
tra command
default is zero ':>,
<: format (one or more of below names separated by point)
integer octal half byte bit text all code
' sets the format used by the commands veri and extra
the format will be valid until changed by another
format command
all is all except code
default is all except code and bit ':>,
<:
lines <first line> (.<last line>)
' sets the line interval used in displaying internal
processes
the interval is valid until another lines command
default is first line = 1, last line = max integer ':>,
string infor,
string infor,
string infor,
string infor), nl, 1);
outend (out);
end;
\f
procedure type_error (type, cause, name);
value type ;
integer type ;
string cause ;
array name ;
begin
integer i;
i := 1;
write (out,
"nl", 1, <:***:>, prog_name,
"sp", 1, cause, "sp", 2);
if type = s_text or type = p_text then
write (out, string name (increase (i)))
else
if type = s_number or type = p_number then
write (out, <<d>, round name (1))
else
write (out, <:missing:>);
write (out, "nl", 1);
outend (out);
end type_error;
\f
procedure typein;
begin
integer i, char, kind;
real array param (1:2);
integer array zdescr (1:20);
long array field laf;
laf := 0;
if -,fp_mode then
begin
getzone (in, zdescr);
kind := zdescr (1) extract 12;
if kind = 0
or kind = 8 then
begin <*ip or tw*>
stopzone (in, false );
write (in, ">", 1);
stopzone (in, false );
end;
readchar (in, char);
i := char;
if i = 'o' then
begin <*o file*>
repeatchar (in);
readstring (in, param, 1);
for i := 1, 2 do
param (i) := real <::>;
readstring (in, param, 1);
repeatchar (in);
read__char (in, char);
while char <> 'nl' do
readchar (in, char); <*skip rest of line*>
connect_or_reconnect (out, param.laf, curr_filename, true <*stack*>);
typein; <*wait for next directive*>
end <*o file*> else
begin
while char <> 'nl' do
readchar (in, char); <*skip rest of line*>
if i = 'r' then repeet := true else
if i = 'f' then quit := true ;
end;
end <*-, fp_mode*>;
end type_in;
\f
procedure connect_param;
begin
integer type;
long array field laf;
laf := 0;
type := anything;
if -,next_param (type)
or type <> s_text then
type_error (type, <:parameter error ::>, param)
else
connect_or_reconnect (out, param.laf, curr_filename, true <*stack*>);
end connect_param;
\f
procedure connect_or_reconnect (z, new_filename, curr_filename, stack_curr);
zone z ;
long array new_filename, curr_filename ;
boolean stack_curr ;
begin
integer i, curr, new;
real array field raf;
long array la (1:2);
raf := 0;
<*search entry with filename = curr filename*>
curr := 11;
for i := 1 step 1 until 10 do
begin
file_f := 8 * i;
if out_file.file_f (1) = curr_filename (1) and
out_file.file_f (2) = curr_filename (2) then
begin
curr := i;
i := 10;
end else
if out_file.file_f (1) = long <::> and i < curr then
curr := i;
end <*for i*>;
if new_filename (1) = curr_filename (1) and
new_filename (2) = curr_filename (2) then
new := curr <*same*>
else
begin <*search entry with filename = new filename*>
new := 0;
for i := 1 step 1 until 10 do
begin
file_f := 8 * i;
if outfile.file_f (1) = new_filename (1) and
outfile.file_f (2) = new_filename (2) then
begin new := i; i := 10; end;
end;
end <*search entry with filename = new filename*>;
if stack_curr then
begin <*only during use, not in unstacking mode*>
write (z, "nl", 1, <:*o :>, new_filename, "nl", 1);
fp_proc (33, 0, z, 0); <*outend z with zero char*>
fp_proc (79, 0, z, 0); <*terminate z*>
end;
\f
if curr = 11 and stack_curr then
type_error (s_text, <:too many outfiles:>, new_filename.raf)
else
begin <*entry for current file name found*>
if curr > new and -,stack_curr then
begin <*close up and terminate*>
fpproc (34, 0, z, 'em'); <*close up with 'em' character*>
fpproc (79, 0, z, 0 ); <*terminate current connection*>
end else
begin <*stack current*>
file__f :=
chain_f := 8 * curr; <*fields entry*>
if outfile.file_f (1) = long <::> then
for i := 1, 2 do
outfile.file_f (i) := curr_filename (i); <*if blank then insert name*>
fpproc (29, 0, z, la); <*stack zone*>
tofrom (chain_name.chain_f, la, 8);
end <*stack current*>;
if new = 0 then
begin <*new entry, connect new*>
result := 2; <*1 < 1 : 1 segment, preferably drum*>
fpproc (28, result, z, new_filename); <*connect to new file*>
\f
if result = 0 then
begin <*connect ok*>
for i := 1, 2 do
curr_filename (i) := new_filename (i);
end <*connect ok*> else
begin <*connect not ok*>
tofrom (la, chain_name.chain_f, 8);
fpproc (30, 0, z, la); <*unstack, reconnect*>
if chainname.chain_f (1) = long <::> then
for i := 1, 2 do
outfile.file_f (i) := long <::>; <*blank entry*>
write (z,
"nl", 1, <:***:>, progname, "sp", 1, <:connect :>, new_filename,
"sp", 1, case result of (
<:no resources:> , <:malfunction:>, <:not user, not exist:>,
<:convention error:>, <:not allowed:>, <:name format error:> ));
end <*connect not ok*>;
end <*new entry*> else
begin <*old entry, unstack and reconnect*>
file__f :=
chain_f := 8 * new; <*fields entry*>
tofrom (la, chain_name.chain_f, 8);
fpproc (30, 0, z, la); <*unstack, reconnect*>
for i := 1, 2 do
curr_filename (i) := new_filename (i);
if chain_name.chain_f (1) = long <::> then
for i := 1, 2 do
outfile.file_f (i) := long <::>; <*blank entry*>
end <*entry with new filename found*>;
if stack_curr then
begin <*only in use, not in unstacking mode*>
write (z, "nl", 1, "ff", 1, "nl", 1);
outend (z); <*outend with zero character*>
end;
end <*entry for current file name found*>;
end connect_or_reconnect;
\f
boolean
procedure get_descr_or_name(name,addr,descr);
value descr ;
boolean descr ;
integer addr ;
array name ;
begin
integer array iarr(1:256),table(1:256);
integer i,j,no_of_procs,moves,k,move_addr;
boolean found;
real array field raf;
raf:= 6;
found := true;
if descr then
begin <* find process description address *>
found:= false;
move_addr:= name_table_start;
no_of_procs:= (name_table_end-name_table_start)//2;
moves:= no_of_procs//256 +1;
for k:= 1 step 1 until moves do
begin
move(move_addr+512*(k-1),table);
for i:= 1,i+1 while i <= no_of_procs and
i <= 256 and
-,found do
begin
move(table(i)-4,iarr);
if name(1) = iarr.raf(1) and
name(2) = iarr.raf(2) then
begin
found:= true;
addr:= table(i);
end;
end;
no_of_procs:= no_of_procs - 256;
end;
if -,found then
type_error(s_text, <:process does not exist: :>, name);
end
else
begin <* return name from process description *>
move(addr-4,iarr);
name(1):= iarr.raf(1);
name(2):= iarr.raf(2);
end;
get_descr_or_name := found;
end get_descr_or_name;
\f
procedure init_pointers;
begin
if dump_area then
begin
move (1200, contents);
name_table_start:= contents(1);
first_device:= contents(2);
first_area:= contents(3);
first_internal:= contents(4);
name_table_end:= contents(5);
first_mess:= contents(6);
last_mess:= contents(7);
first_drum:= contents(8);
first_disc:= contents(9);
last_bs:= contents(10);
if contents(11) <* start of interrupt stack *> < 1226 then
begin comment release < 9 as no space is allocated for
monitor release in 'dump_area addr. 1224;
oldmon:= true;
monitor_release:= 0;
end else
begin
monitor_release:= contents(13);
oldmon:= false;
end;
buf_size :=
if old_mon then
26
else
if monitor_release < 10 shift 12 + 0 then
26
else
28;
<*end else*>
\f
end else
begin
move (54, contents);
monitor_release:= contents(6);
oldmon:= monitor_release < 9 shift 12;
name_table_start:= contents(10);
first_device:= contents(11);
first_area:= contents(12);
first_internal:= contents(13);
name_table_end:= contents(14);
first_mess:= contents(17);
last_mess:= contents(18);
buf_size := contents(19);
first_drum:= contents(20);
first_disc:= contents(21);
last_bs:= contents(22);
end;
userid:= if oldmon then 18 else 0;
id_array_size:= (((name_table_end-first_internal)//2+23)//24)*2;
eprocname:= if oldmon then 6 else 6+id_array_size;
if monitor_release < 9 shift 12 + 0 then
begin
neg_offset:= -4;
offset:= 0;
end else
begin
neg_offset:= -4-id_array_size;
offset:=(id_array_size//2);
end;
end init_pointers;
\f
procedure bsclaim (bs_no, offset, bs_name);
value bs_no ;
integer bs_no, offset ;
integer array bs_name ;
begin
integer array table (1:1);
move (first_drum+(bs_no*2), table);
move (table(1)-18, bs_name);
move (table(1)-36, table);
offset:= table(1);
end procedure bsclaim;
procedure outend (z);
zone z ;
begin
fpproc (33, 0, z, 0); <* empty zone with zero character *>
end outend;
\f
procedure veri;
begin
integer first,halfwords,i,segments,words,segm,addr,type;
addr:= 0; first := -1;
type := anything;
next_param (type);
if type <> s_number then
type_error (type, <:parameter error ::>, param)
else
first := round param (1);
if first >= 0 then
begin <*param ok*>
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;
\f
segments := halfwords // 512 + 1;
i:= 1;
write(out,nl,1,if dump_area then string area(increase(i))
else <:core:> ,<:.:>,first,nl,1);
k_value := first;
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,<:+:>,<<dddd>,addr,sp,1);
write_formatted(contents(i),mask);
outchar(out,10);
outend (out);
addr := addr + 2;
k_value := k_value + 2;
end;
first:= first + 512;
halfwords:= halfwords - 512;
end;
type_text(<::>);
end <*param ok*>;
end veri;
\f
procedure extra_param;
begin
integer type;
type := anything;
if -,next_param (type)
or type <> s_number then
type_error (type, <:parameter error ::>, param)
else
extra_lines := round param (1);
end extra_param;
procedure mask_param;
begin
integer j, type, type_wanted;
j := 0;
type := type_wanted := s_text;
while next_param (type) and type = type_wanted do
begin
if format (param) > 8 then
type_error (type, <:illegal format:>, param)
else
j :=
logor (j, case format (param) of (
int, octal, halfword, byte, bit, text, all, code)
) extract 24;
type := anything;
type_wanted := p_text;
end;
param_no := param_no - 1;
if j = 0 then
type_error (type, <:parameter error:>, param)
else
mask := j;
end mask_param;
\f
procedure line_param;
begin
integer type;
type := anything;
if -,next_param (type)
or type <> s_number then
type_error (type, <:parameter error ::>, param)
else
begin <*s_number*>
first := round param (1);
type := anything;
if -,next_param (type) or type <> p_number then
param_no := param_no - 1 <*sorry*>
else
last := round param (1);
end <*s_number*>;
end line_param;
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_usernames (index, usermask);
value index ;
integer index ;
boolean array usermask ;
begin
integer array iar(1:8);
integer array table(1:256);
integer i,j,k;
real array field name;
integer proc,p_index,internals,names;
boolean found,p_bit;
name:= 2;
names:=1;
found:= false;
internals:= (name_table_end-first_internal)//2;
index := (index+neg_offset)extract 12;
move (first_internal, table);
for proc:= 1 step 1 until internals do
begin
move (table(proc), iar);
p_index:= iar(7) shift(-12) extract 12;
p_bit:= false add ( iar(7) extract(12));
found :=
p_index = index and
(p_bit and usermask (1)) extract 12 <> 0
or p_index = index + 1 and
(p_bit and usermask (2)) extract 12 <> 0 ;
if found then
begin
if names mod 5=1 then
write(out,nl,1,<: : :>,sp,2);
if iar.name(1)=real <:pro:> shift (-24) then
begin
iar.name(1):= real <:procf:> add 117;
iar.name(2):= real <:nc:>;
end;
j:=1;
write(out,true,12,string iar.name(increase(j)));
names:= names+1;
end;
end;
end type usernames;
\f
procedure type_names (resv, mask);
value resv, mask ;
boolean resv ;
integer mask ;
begin
integer internals,i,j,k;
integer array table,iarr(1:256);
integer array field iaf;
real array field raf;
boolean found;
iaf:= 16;
raf:= 6;
internals:= (name_table_end-first_internal)//2;
move(first_internal, table);
for i:= 1,i+1 while i <= internals do
begin
move(table(i)-4, iarr);
if resv then found:= mask=iarr.iaf(1)
else
begin
k:=logand(mask,iarr.iaf(1));
found:= k<>0;
end;
if found 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);
real array field raf;
boolean found;
raf:= 2;
j := -1; <*impossible id mask*>
found:= false;
check_procfunc(name);
internals:= (name_table_end-first_internal)//2;
move(first_internal, table);
for i:= 1,i+1 while i <= internals do
begin
move(table(i), iarr);
if name(1) = iarr.raf(1) and
name(2) = iarr.raf(2) then
begin
found:= true;
j := iarr (7);
end;
end;
if -,found then
type_error (s_text, <:process does not exist:>,name);
identification_mask := j;
end identification_mask;
\f
procedure read_params(specif, user_mask, reserver_mask, name, devno);
<* specif : 1 - user.<name>
2 - reserver.<name>
3 - name.<name>
4 - all
5 - devno.<integer>
6 - devno.<integer>.all
7 - main.<name>
8 - undefined specification *>
integer specif, user_mask, reserver_mask, devno ;
array name ;
begin <* used to read in parameters in call of 'area' or 'external' *>
integer i, j, type;
for i := 1, 2 do
name (i) := real <::>;
specif:= 8; <*default param error*>
type := anything;
next_param (type);
if type<> s_text then
type_error (type, <:parameter error ::>, param)
else
begin <*s_text*>
if param(1) = real<:all:> then specif:= 4 else
if param(1) = real<:user:> then
begin
if next_param (p_text) then
begin
specif:= 1;
for i := 1, 2 do
name (i) := param (i);
check_procfunc(param);
user_mask:= identification_mask(param);
if user_mask = -1 then
specif:= 8; <*proc didnt exist*>
end else
type_error (anything, <:parameter error ::>, dummy);
end else
if param(1) = real<:reser:> add 118 then
begin
if next_param (p_text) then
begin
specif:= 2;
for i := 1, 2 do
name (i) := param (i);
check_procfunc(param);
reserver_mask:= identification_mask(param);
if reserver_mask = -1 then
specif:= 8; <*proc didnt exist*>
end else
type_error (anything,<:parameter error ::>, dummy);
<*end else*>
\f
end else
if param(1) = real <:name:> then
begin
if next_param (p_text) then
begin
specif:= 3;
for i := 1, 2 do
name (i) := param (i);
end else
type_error (anything, <:parameter error ::>, dummy);
end else
if param(1) = real<:devno:> then
begin
if next_param (p_number) then
begin
devno := round param(1);
name (1) := param (1);
i := anything;
if -, next_param (i) or i <> p_text then
begin <*no more or not .text*>
param_no := param_no - 1;
specif := 5;
end else
begin <*.text*>
if param (1) <> real <:all:> then
type_error (p_text, <:parameter unknown ::>, param)
else
specif := 6;
end <*.text*>;
end else
type_error (anything, <:parameter error ::>, dummy);
end else
if param(1) = real <:main:> then
begin
if next_param (p_text) then
begin
for i:= 1, 2 do
name (i):= param (i);
if get_descr_or_name (name, main, true) then specif:= 7 else specif:= 8;
end else type_error (anything, <:parameter error ::>, dummy);
end else
type_error (type, <:parameter unknown ::>,param);
end <*s_text*>;
end read_params;
\f
procedure external;
begin
procedure type_external;
begin
integer i,j;
boolean array field id;
found := true;
id:= 0;j:= i:= 1;
write(out,nl,1,if dump_area then string area(increase(j)) else <:core:>,
<:.:>,<<ddddd>,addr);
if device>-1 then write(out,sp,2,<:,device number : :>,<<ddd>,device);
write(out,nl,1);
if -, oldmon then
begin
for i:=2 step 2 until id_array_size do
begin
write(out,nl,1,<:users : :>,sp,2);
userbits(1):= contents.userid(i-1);
userbits(2):= contents.userid( i);
write_formatted(contents(i//2),bit);
type_usernames(i-2,userbits);
end;
end;
i:=1;
write(out,nl,1,<<-ddddddddd>,
<:lower base : :>,sp,2,contents(1+offset),nl,1,
<:upper base : :>,sp,2,contents(2+offset),nl,1,
<:kind : :>,sp,2,contents(3+offset),nl,1,
<:name : :>,sp,2,string contents.eprocname(increase(i)),
nl,1,
<:main : :>,sp,2,contents(8+offset));
if contents(offset+8) > 0 then
begin
j:= 1;
if get_descr_or_name (m_name,contents(offset+8),false) then
write (out, <: (:>, string m_name (increase (j)), <:):>);
end;
write (out, nl, 1);
write(out,<:reserver : :>,sp,2);
userbits.iaf(1):= contents(9+offset);
write_formatted(contents(9+offset),bit);
type_names(true,contents(9+offset));
if oldmon then
begin
write(out,nl,1,<:users : :>,sp,2);
write_formatted(contents(10+offset),bit);
type_names(false,contents(10+offset));
end else
begin
write(out,nl,1,<:work0,work1 : :>,sp,2);
write_formatted(contents(10+offset),halfword);
end;
\f
write(out,nl,1,<<-ddddddddd>,
<:next message : :>,sp,2,contents(11+offset),nl,1,
<:previous message : :>,sp,2,contents(12+offset),nl,1);
for i := 12 + 1 step 1 until 12 + extra do
begin
write (out, "nl", 1, "sp", 21, ":", 1, "sp", 3);
write_formatted (contents (i + offset), mask);
end;
type_text(<::>);
outend (out);
typein; <*wait for directive*>
if repeet then
begin
repeet := false;
type_external;
end;
end type_external;
integer i, j, externals, user_mask, reserver_mask, specif, addr, devno,
moves, k, l, move_addr, device, extra;
real array name(1:2);
integer array table(1:256);
boolean found;
\f
specif:= 4; <* default all *>
read_params (specif, user_mask, reserver_mask, name, devno);
if specif < 8 then
begin <*param ok*>
extra := extra_lines;
if extra + 12 + offset > 256 then
extra := 256 - (12 + offset);
found := false;
if specif = 5 <*devno*>
or specif = 6 <*devno.<int>.all*> then
begin
move_addr := first_device;
device := 0;
end else
begin
move_addr := name_table_start;
device := (name_table_start - first_device) // 2;
end;
externals := (first_area - move_addr) // 2;
moves := (externals - 1 ) // 256 + 1;
for k:= 1 step 1 until moves do
begin
move(move_addr+512*(k-1),table);
<* scan externals *>
i := 1;
while i <= externals and
i <= 256 do
begin
addr:= table(i);
move(addr+neg_offset,contents);
case specif of
begin
<* user *>
if oldmon then
begin
for l:= 0 step 1 until 23 do
if contents(10+offset) shift (-l) extract 1 = 1 and
user_mask shift (-l) extract 1 = 1 then type_external;
end else
begin
integer index,bits,k;
index:= (user_mask shift(-12))+(4095 shift 12);
index:=index-neg_offset+1;
bits:= user_mask extract 12;
if false add index then bits:= bits shift 12;
k:=logand(bits,contents((index+1)//2));
if k<>0 then type_external;
end;
\f
<* reserver *>
if contents(9+offset) = reserver_mask then type_external;
<* name *>
if contents.eprocname(1) = name(1) and
contents.eprocname(2) = name(2) then
type_external;
<* all *>
type_external;
<* devno *>
if devno+1 = i + (k-1)*256 <* log. device no. *> then
begin
i := 256;
k := moves;
type_external;
end;
<* devno.<int>.all *>
if devno + 1 <= i + (k-1) * 256 <*log. dev no*> then
type_external;
<* main.<name> *>
if contents(8+offset) = main then type_external;
end case;
if quit then
begin
quit := false;
i := 257 ;
k := moves;
end else
begin
i := i + 1;
device:= device+1;
end;
end while;
externals:= externals - 256;
end;
if -,found then
type_error (if specif < 5 or specif = 7 then s_text else s_number,
case specif of (
<:not found : user.:>, <:not found : reserver.:>,
<:not found : name.:>, <:not found : all:> ,
<:not found : devno.:>, <:not found : devno.:>, <:not found : main.:>), name);
end <*param ok*>;
end external;
\f
procedure area_process;
begin
procedure type_area_process;
begin
integer i,j;
real array field raf;
found := true;
i:= j:= 1;
write(out,nl,1,if dump_area then string area (increase(j)) else <:core:>,
<:.:>,<<ddddd>,addr,nl,1);
if -, oldmon then
begin
if monitor_release> 9 shift 12 then
begin
integer array parr(1:id_array_size//2);
move(addr+neg_offset-2-id_array_size,parr);
for i:=2 step 2 until id_array_size do
begin
write(out,nl,1,<:write protect : :>,sp,2);
userbits(1):= false add (parr(i//2) shift (-12));
userbits(2):= false add (parr(i//2) extract 12) ;
write_formatted(parr(i//2),bit);
type_usernames(i-2,userbits);
end;
end;
for i:=2 step 2 until id_array_size do
begin
write(out,nl,1,<:users : :>,sp,2);
userbits(1):= contents.userid(i-1);
userbits(2):= contents.userid( i);
write_formatted(contents(i//2),bit);
type_usernames(i-2,userbits);
end;
end;
i:=1;
write(out,nl,1,<<-ddddddddd>,
<:lower base : :>,sp,2,contents(1+offset),nl,1,
<:upper base : :>,sp,2,contents(2+offset),nl,1,
<:kind : :>,sp,2,contents(3+offset),nl,1,
<:name : :>,sp,2,string contents.eprocname(increase(i)),
nl,1,
<:proc descr addr : :>,sp,2,contents(8+offset));
if contents(offset+8) > 0 then
begin
j:= 1;
if get_descr_or_name (m_name,contents(offset+8),false) then
write (out, <: (:>, string m_name (increase (j)), <:):>);
end;
write (out, nl, 1);
write(out,<:reserver : :>,sp,2);
\f
write_formatted(contents(9+offset),bit);
userbits.iaf(1):= contents(9+offset);
type_names(true,contents(9+offset));
if oldmon then
begin
write(out,nl,1,<:users : :>,sp,2);
write_formatted(contents(10+offset),bit);
type_names(false, contents(10+offset));
end else
begin
write(out,nl,1,<:work0,work1 : :>,sp,2);
write_formatted(contents(10+offset),halfword);
end;
write(out,nl,1,<<-ddddddddd>,
<:first slice : :>,sp,2,contents(11+offset),nl,1,
<:no of segments : :>,sp,2,contents(12+offset),nl,1,
<:document : :>,sp,2);
j:= 1; raf:= 24 + offset*2;
write(out,string contents.raf(increase(j)),nl,1);
write(out,<<-ddddddddd>,
<:write access counter : :>,sp,2,contents(17+offset),nl,1,
<:read access counter : :>,sp,2,contents(18+offset),nl,1);
for i := 18 + 1 step 1 until 18 + extra do
begin
write (out, "nl", 1, "sp", 21, ":", 1, "sp", 3);
write_formatted (contents (i + offset), mask);
end;
type_text(<::>);
outend (out);
type_in; <*wait for directive*>
if repeet then
begin
repeet := false;
type_area_process;
end;
end type_area_process;
\f
integer i, j, k, l,
areas, user_mask, reserver_mask, specif, addr, moves, extra;
real array name(1:2);
integer array table(1:256);
boolean found;
specif:= 4; <* default all *>
found := false;
read_params(specif, user_mask, reserver_mask, name, i);
if specif > 4 and
specif < 7 then
type_error (p_number, <:parameter error :>, name);
if specif < 8 then
begin <*param ok*>
extra := extra_lines;
if extra + 18 + offset > 256 then
extra := 256 - (18 + offset);
areas:= (first_internal-first_area)//2;
moves:= (areas-1)//256 + 1;
for k:= 1 step 1 until moves do
begin
move(first_area+512*(k-1),table);
<* scan area procs *>
\f
i := 1;
while i <= areas and i <= 256 <*and -,found*> do
begin
addr:= table(i);
move(addr+neg_offset,contents);
case specif of
begin
<* user *>
if oldmon then
begin
for l:= 0 step 1 until 23 do
if contents(10+offset) shift (-l) extract 1 = 1 and
user_mask shift (-l) extract 1 = 1 then type_area_process;
end else
begin
integer index,bits,k;
index:= (user_mask shift(-12))+(4095 shift 12);
index:= index-neg_offset+1;
bits:= user_mask extract 12;
if false add index then bits:= bits shift 12;
k:= logand(bits,contents((index+1)//2));
if k<>0 then type_area_process;
end;
<* reserver *>
if contents(9+offset) = reserver_mask then type_area_process;
<* name *>
if contents.eprocname(1) = name(1) and
contents.eprocname(2) = name(2) then
type_area_process;
<* all *>
type_area_process;
; <* 5 *>
; <* 6 *>
<* main *>
if contents (8+offset) = main then type_area_process;
end case;
if quit then
begin
quit := false;
i := 257 ;
k := moves;
end else
i := i + 1;
end while;
areas:= areas - 256;
end;
if -,found then
type_error (s_text,
case specif of (
<:not found : user.:>, <:not found : reserver.:>,
<:not found : name.:>, <:not found : all:>, <::>, <::>, <:not found : main:> ), name);
end <*param ok*>;
end area_process;
\f
procedure chain;
begin
procedure type_chain;
begin
integer i,j,k;
real array field raf1,raf2;
found := 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(<::>);
type_in; <*wait directive*>
if repeet then
begin
repeet := false;
type_chain;
end;
end type_chain;
\f
boolean all, found, ok;
integer i, j, chains, addr, type;
real array docname(1:2);
integer array table(1:256);
real array field raf;
all:= ok := true; <* default all *>
found := false;
type := anything;
raf:= 18;
next_param (type);
if type <> s_text then
begin
ok := false;
type_error (type, <:parameter error ::>, param);
end else
begin <*s_text*>
if param(1) = real<:all:> then all:= true else
if param(1) = real<:docna:> add 109 then
begin
if next_param (p_text) then
begin
docname(1):= param(1);
docname(2):= param(2);
all:= false;
end else
type_error (anything, <:parametererror ::>, dummy);
end else
begin
ok := false;
type_error (type, <:parameter unknown::>, param);
end;
end;
if ok then
begin <*param ok*>
<* scan chainheads *>
chains:= (last_bs-first_drum)//2;
move (first_drum, table);
for i:= 1,i+1 while i <= chains and (all or -,found) 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
type_chain;
if quit then
begin
quit := false;
i := chains;
end;
end;
if -,found then
type_error (s_text, <:not found: :>, docname);
end <*param ok*>;
end chain;
\f
procedure buf;
begin
procedure type_buf(contents);
integer array contents ;
begin
integer i,j;
real array name(1:2);
found := true;
j:= 1;
write(out,nl,1,if dump_area then string area(increase(j)) else <:core:>,
<:.:>,<<-dddddd>,start_addr+addr,nl,1);
if buf_size > 26 then
write (out,
<:message state : :>,contents(0),nl,1);
write (out,
<: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
if check <> 2 and check <> 3 <*no receiver name in command*> then
get_descr_or_name(receiver_name,abs(contents(4)//2*2),false);
j:= 1;
write(out,sp,3,string receiver_name(increase(j)));
end;
outchar(out,10);
write(out,<:sender : :>,<<-dddddd>,contents(5));
if abs(contents(5)) > 0 then
begin
if check <> 1 and check <> 3 <*no sender name in command*> then
get_descr_or_name(sender_name,abs(contents(5)),false);
j:= 1;
write(out,sp,3,string sender_name(increase(j)));
end;
outchar(out,10);
for i:= 6 step 1 until 13 do
begin
write_formatted(contents(i),all);
type_text(<::>);
end;
type_in; <*wait for directive*>
if repeet then
begin
repeet := false;
type_buf (contents);
end;
end type_buf;
\f
integer i, j, sender, receiver, check, addr, start_addr, top, moves, buffers,
length, bufs_pr_move, buf_addr, type, type_wanted;
boolean total, ok, found;
real array receiver_name, sender_name(1:2);
integer array field base;
total := ok := true; <* default all *>
found := false;
check := 6; <*default param error*>
type := type_wanted := s_text;
while next_param (type) and type = type_wanted do
begin
type_wanted := p_text ;
type := anything;
if param(1) = real<:all:> then check := 0 else
if param(1) = real<:sende:> add 114 then
begin
if next_param (p_text) then
begin
check := if check = 2 or check = 3 then 3 else 1;
sender_name(1):= param(1);
sender_name(2):= param(2);
end else
type_error (anything, <:parameter error ::>, dummy);
end else
if param(1) = real<:recei:> add 118 then
begin
if next_param (p_text) then
begin
check := if check = 1 or check = 3 then 3 else 2;
receiver_name(1):= param(1);
receiver_name(2):= param(2);
end else
type_error (anything, <:parameter error ::>, dummy);
end else
if param (1) = real <:addr:> then
begin
if next_param(p_number) then
begin
buf_addr := round param (1);
i := anything;
\f
if -, next_param (i) or i <> p_text then
begin
param_no := param_no - 1;
check := 4;
end else
begin <*.text*>
if param (1) <> real <:all:> then
type_error (i, <:parameter error ::>, param)
else
check := 5;
end <*.text*>;
end;
end else
type_error (s_text, <:parameter unknown ::>, param);
end <while p_text*>;
param_no := param_no - 1;
case check+1 of
begin
ok := true; <*all*>
begin
check_procfunc(sender_name);
ok :=
get_descr_or_name(sender_name,sender,true);
end;
begin
check_procfunc(receiver_name);
ok :=
get_descr_or_name(receiver_name,receiver,true);
end;
begin
check_procfunc(sender_name);
ok :=
get_descr_or_name(sender_name,sender,true);
check_procfunc(receiver_name);
ok :=
get_descr_or_name(receiver_name,receiver,true);
end;
param (1) := buf_addr; <*addr*>
param (1) := buf_addr; <*addr.<int>.all*>
ok := false; <*param error*>
end case;
\f
<* scan mess buffers *>
if ok then
begin <*param ok*>
total:= check = 0;
system (3) bounds :(length, contents); <*lower is checked in move*>
if 2 * length < buf_size then
system (9, length, <:<10>bounds:>);
start_addr := if bufsize > 26 then
first_mess <*since mon rel 10.0*>
else
first_mess - 2 <*error in older mon*>;
length := 2 * length ;
bufs_pr_move := length // buf_size ;
buffers := (last__mess -
first_mess ) // bufsize ;
moves := (buffers - 1) // bufs_pr_move + 1;
top := (bufs_pr_move - 1) * buf_size ;
for i:= 1 step 1 until moves do
begin
move(start_addr,contents);
for addr:= 0 step buf_size until top do
begin
base := if buf_size > 26 then addr + 2 else addr;
if -,total then
begin
case check+1 of
begin
ok := true; <*all*>
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;
ok:= start_addr + addr = buf_addr ;
ok:= start_addr + addr >= buf_addr ;
end;
\f
end <*-,total*>;
if ok then type_buf(contents.base);
if quit then
begin
quit := false;
addr := top ;
i := moves;
end;
end <*for addr*>;
buffers := buffers-bufs_pr_move;
top := if buffers >= bufs_pr_move then
top
else
(buffers - 1) * buf_size;
start_addr := start_addr + bufs_pr_move * buf_size;
end;
if -,found then
begin
case check + 1 of
begin
type_error (s_text , <:not found : all:> , dummy );
type_error (s_text , <:not found : sender.:> , sender_name );
type_error (s_text , <:not found : receiver.:>, receiver_name);
type_error (s_text , <:not found : receiver.:>, receiver_name);
type_error (s_number, <:not found : addr.:> , param );
type_error (s_number, <:not found : addr.:> , param );
end;
end;
end <*param ok*>;
end buf;
\f
procedure internal;
begin
procedure type_descr;
begin
integer i,j,k,l,offset;
found := true;
j:= 1;
write (out, nl, 1, <:start of internal proces : :>,
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 : :>));
\f
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 *>
begin
write_formatted(contents(8),halfword + bit);
state:= contents(8) extract 12;
for j:= 1 step 1 until 10 do
if state = (case j of (72,8,176,160,184,168,204,141,142,143))
then write(out,sp,2,case j of (
<:running:>,
<:running after error:>,
<:wait. f. stop by par.:>,
<:wait. f. stop by anc.:>,
<:wait. f. start by par.:>,
<:wait. f. start by anc.:>,
<:waiting f. procfunc:>,
<:waiting for message:>,
<:waiting for answer:>,
<:waiting for event:>));
end;
<* 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;
\f
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;
\f
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);
\f
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;
end case;
type_text(<::>);
end for;
\f
if bs_claims_to_type > 0 then
begin
for i:= 0 step 1 until bs_claims_to_type - 1 do
begin
bsclaim(i, offset, bsname);
if bsname.name_f (1) shift (-24) extract 24 <> 0 then
begin <*active chain*>
write(out, <:claim :>);
k:=1;
l:=write(out,string bsname.namef(increase(k)));
write (out, false add 32, 12-l, <:::>);
if oldmon then
begin
for j:=0 step 1 until 3 do
write_formatted(contents((offset//2)+3+j),unsigned_halfw);
end else
begin
for j:=0 step 1 until 7 do
write_formatted(contents((offset//2)+3+j),int);
end;
typetext(<::>);
end <*active chain*>;
end;
end;
type_in; <*wait for directive*>
if repeet then
begin
repeet := false;
type_descr;
end;
end type_descr;
\f
integer i, j, type, internals, addr, state, bs_claims, bs_claims_to_type;
boolean found, type_all, ok;
real array name(1:2);
integer array table(1:256);
real array field raf,namef;
type_all := true;
found := ok := false;
raf:= 6; <* refers to name in proc descr *>
namef:=0;
type:= anything;
next_param (type);
if type <> s_text then
type_error (type, <:parameter error ::>, param)
else
begin <*s_text*>
if param (1) = real <:all:> then
ok := type_all := true
else
if param (1) = real <:name:> then
begin <*name*>
if next_param (ptext) then
begin
for i := 1, 2 do
name (i) := param (i);
check_procfunc (name);
ok := true;
type_all := false;
end else
type_error (type, <:parameter error ::>, param);
end <*name*> else
type_error (type, <:parameter unknown ::>, param);
end <*s_text*>;
\f
if ok then
begin <*param ok*>
bs_claims := (last_bs - first_drum) // 2; <*dump or core*>
<*check first and last*>
if first < 1 or first > 38 + bs_claims then
first := 1;
if last < first or last > 38 + bs_claims then
last := 38 + bs_claims;
bs_claims_to_type := if last <= 38 then 0 else last - 38;
last := last - bs_claims_to_type;
<* search internal proc descr *>
internals:= (name_table_end-first_internal)//2;
move(first_internal, 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;
if quit then
begin
quit := false;
i := internals;
end;
end;
if -,found then
type_error (s_text, <:not found ::>, name);
end <*param ok*>;
end internal;
\f
procedure write_formatted (word, mask);
value mask ;
integer word, mask ;
begin <* writes the contents of 'word' according to format specification
given in 'mask' *>
integer i, j, char, halfword1, halfword2, code, w, m, x, disp;
long array instr (1:1);
boolean rel, ind, w0;
for i:= 0 step 1 until 7 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,1);
end;
begin <* halfword *>
halfword1:= (word shift(-12) shift 12)//4096;
halfword2:= (word shift 12)//4096;
write(out,<<-dddd>,halfword1,sp,1,halfword2,sp,2);
end;
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 shift (-12) extract 12,sp,1,word extract 12,
sp,2); <* unsigned halfword *>
\f
begin <*code*>
code := word shift (-18) ;
w := word shift (-16) extract 2;
m := word shift (-14) extract 2;
x := word shift (-12) extract 2;
disp := word extract 12;
rel := m > 1; <*relative*>
ind := m extract 1 = 1; <*indirect*>
instr (1) := long (case code + 1 of (
<:,00:>, <: do:>, <: el:>, <: hl:>, <: la:>, <: lo:>, <: lx:>, <: wa:>,
<: ws:>, <:,am:>, <: wm:>, <: al:>, <:,ri:>, <:,jl:>, <:,jd:>, <:,je:>,
<:,xl:>, <: es:>, <: ea:>, <: zl:>, <: rl:>, <:,sp:>, <:,re:>, <: rs:>,
<: wd:>, <: rx:>, <: hs:>, <:,xs:>, <: gg:>, <: di:>, <: ap:>, <:,ul:>,
<: ci:>, <: ac:>, <: ns:>, <: nd:>, <: as:>, <: ad:>, <: ls:>, <: ld:>,
<: sh:>, <: sl:>, <: se:>, <: sn:>, <: so:>, <: sz:>, <:,sx:>, <: gp:>,
<: fa:>, <: fs:>, <: fm:>, <:,ks:>, <: fd:>, <: cf:>, <: dl:>, <: ds:>,
<: aa:>, <: ss:>, <:,dp:>, <: mh:>, <:,lk:>, <: ix:>, <:,62:>, <:,63:>));
w0 := instr (1) shift (-40) extract 8 = 'sp';
instr (1) := instr (1) shift 8;
write (out, instr,
if rel then <:.:> else <: :>, "sp", 1,
case w + 1 of ( if w0 then <:w0:> else <: :>, <:w1:>, <:w2:>, <:w3:>),
"sp", 1, if ind then <:(:> else <: :>,
case x + 1 of (<: :>, <:x1:>, <:x2:>, <:x3:>),
if x > 0 then <<+d> else <<-d>,
true, 7, disp, if ind then <:):> else <: :>);
if m = 1 <*relative and not indirect*> and x = 0 then
write (out, "sp", 4, <<dddddddd>, k_value + disp);
write (out, "sp", if m = 1 and x = 0 then 2 else 14, ";", 1);
end;
end case;
end;
end for-loop;
end write_formatted;
\f
integer procedure format (param);
array param ;
format:= if param(1) = real<:integ:> add 'e' and
param(2) = real<:r:> then 1 else
if param(1) = real<:octal:> then 2 else
if param(1) = real<:half:> 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
if param(1) = real<:code:> then 8 else 9;
procedure type_text(text);
string text ;
begin
write(out,text,nl,1);
outend (out);
end;
\f
procedure move (first_addr, object);
value first_addr ;
integer first_addr ;
integer array object ;
<**********************************************************>
<* *>
<* The procedure moves to integer array object (1:last) *>
<* words from core or dump area starting in absolute add- *>
<* ress first_addr. *>
<* *>
<**********************************************************>
begin
integer present_segment, segment, relative, first_index,
last_index, word, no_of_words;
integer field ifld;
first_index := system (3) bounds :(last_index, object);
if first_index <> 1 then
system (9) alarm :(first_index,<:<10>bounds:>);
no_of_words := last_index;
if -,dump_area then
system (5) move core :(first_addr, object)
else
begin <*from dump area*>
segment := first_addr shift (-9);
relative := first_addr extract 9 ;
getposition (zdump, 0, present_segment);
if segment <> present_segment then
begin
setposition (zdump, 0, segment);
inrec6 (zdump, 512 );
end;
for word := 1, word + 1 while word <= no_of_words do
begin <*move*>
if relative > 510 then
begin
inrec6 (zdump, 512);
relative := 0;
end;
ifld := relative := relative + 2;
object (word) := zdump.ifld;
end <*move*>;
end <*dump area*>;
end procedure move;
\f
procedure lockall;
begin
begin <*make sure that the process size is sufficient *>
integer array coresize (1 : 256 * progsize);
end;
lock (0, progsize - 1); <*lock all upper part of prog in core*>
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, "nl", 1, <:***:>, prog_name,
<: illegal parameter no. :>, number,
<: , 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>:>);
outend (out);
number := param_no - 1; <*to return false*>
end conv_error;
boolean ok;
integer sep,action,number,delim,separator;
\f
if fp_mode 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 2 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, "nl", 1, <:***:>, prog_name, <: 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));
write (out, "nl", 1);
sep := 0; <*to return false*>
end -, ok;
end;
next_param:= sep <> 0;
end
else
<*begin conversational mode *>
\f
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 *>
write(out, <:<10>action-table in error:>);
end;
end for-loop;
\f
if kind (i) = 8 then
begin <*kind (i) = 8, terminator, prepare next line, get next param*>
if type = anything then
number := param_no - 1 <*return false*>
else
begin <*get next*>
nextline;
next_param (type);
number := param_no := param_no - 1;<*to return true *>
end;
end <*kind (i) = 8*> else
begin <* number = param_no, 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 <> 'sp' or kind(i) <> 6
then conv_error(number,i,1,delim);
<* point-name *> if delim <> '.' or kind(i) <> 6
then converror(number,i,2,delim);
<* space-int. *> if delim <> 'sp' or kind(i) <> 2
then conv_error(number,i,3,delim);
<* point-int. *> if delim <> '.' or kind(i) <> 2
then conv_error(number,i,4,delim);
<* any type *> begin
if delim='sp' and kind(i)=6 then type:= 1 else
if delim='.' and kind(i)=6 then type:= 2 else
if delim='sp' and kind(i)=2 then type:= 3 else
if delim='.' 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 <:lock:> ,
real <:o:> ,
real <:extra:> ,
real <:forma:> add 't' ,
real <:lines:> ,
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 next_line;
begin
own boolean init;
integer last, i, start_pos;
boolean more_lines;
if -,init then
begin
<* modify standardalphabet *>
isotable (alphabet);
for i:= ''', '+', '-', '.' do alphabet(i):= 7 shift 12 + i;
intable(alphabet);
tableindex:= 0;
end;
\f
morelines := true;
startpos := 1;
while morelines do
begin <* read lines of command *>
i:= readall(in,ra,kind,start_pos);
if i < 0 then
begin <* array bounds exceeded *>
write (out, "nl", 1, <:***:>, prog_name,
<:command too long, last line skipped:>);
outend (out);
kind (start_pos) := 8; <* terminates inf. in 'ra' and 'kind'*>
morelines := false;
end else
begin <* check if current line terminates command *>
i := 1;
while round ra (i) = 'sp' and
kind (i) = 7 do
i := i + 1; <*skip leading spaces*>
if kind (i) <> 8 then
begin <*line holds a command*>
i := startpos - 1;
repeat
i := i + 1; <*find line terminator*>
until kind (i) = 8
or kind (i) = 7 and round ra (i) = ';'
or kind (i) = 7 and round ra (i) = '*';
last := i ;
ra (i) := 'sp';
kind (i) := 7 ; <*line terminator becomes delimiter 'sp'*>
while kind (i) = 7 and
round ra (i) = 'sp' do i := i - 1; <*backup trailing sp*>
if kind (i) = 7 and round ra (i) = ',' <* comma *> then
begin <*the latest non space is a comma*>
ra (i) := ra (i+1) := 'sp'; <* space *>
kind (i) := kind (i+1) := 7 ;
startpos := i+1 ;
end <*the latest non space is a comma*> else
begin <*the latest non space is not a comma*>
morelines := false;
kind(last):= 8 ; <*line terminator becomes a terminator*>
end <*the latest non space is not a comma*>;
end <*line holds a command*>;
end <*check if current line terminates command*>;
end <*while morelines*>;
paramno:= 0;
end next_line;
\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;
unsigned_halfw:= 1 shift 6;
code:= 1 shift 7;
all := 63;
mask := int + octal + halfword + byte + text ; <*default*>
first := 1; <*default*>
last := 10000; <*default*>
extra_lines := 0; <*default*>
dump_area := false; <* default core *>
repeet := false;
quit := false;
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;
fp_mode:= true;
kind (0) := 7 ; <* delimiter *>
ra (0) := 'sp'; <* space *>
\f
trapmode := 1 shift 10; <*no end alarm written*>
for i := 1 step 1 until 10 do
for j := 1 , 2 do
out___file (i, j) :=
chain_name (i, j) := long <::>;
curr_filename (1) := long <:c:>;
curr_filename (2) := long <::> ;
file__f := 8; <*fields first entry in outfile*>
system (4, 0, file_name);
sepleng :=
system (4, 1, progname);
if sepleng shift (-12) <> 6 <*=*> then
begin <*noleft side, progname is param after programname*>
for i := 1, 2 do
begin
prog_name (i) := file_name (i);
file_name (i) := long <::> ;
param_no := 1 ;
end;
end <*no left side*> else
param_no := 2;
if file_name (1) <> long <::> then
connect_or_reconnect (out, filename, curr_filename, true <*stack*>);
\f
init_pointers;
while next_param (s_text) do
begin
<* decide action *>
case convert_to_number(param) of
begin
if fp_mode then
begin <* typein - enter conversational mode *>
fp_mode := false ;
fp_paramno := param_no;
next_line; <*prepare next line for next param*>
end typein;
if -,fp_mode then
begin <*end - leave conversational mode*>
fp_mode := true;
param_no := fp_paramno;
end;
dump ;
core ;
veri ;
internal ;
commands ;
info ;
buf ;
external ;
area_process;
chain ;
lock_all ;
connect_param;
extra_param;
mask__param;
line__param;
;;;
begin <* illegal parameter *>
i:= 1;
write(out, "nl", 1, <:***:>, prog_name, <: illegal parameter : :>,
string param(increase(i)));
typetext (<:<10>try 'montest commands' and 'info <command>':>);
end;
end case;
end <*while*>;
\f
for i := 10 step -1 until 1 do
begin
file_f := 8 * i;
if outfile.file_f (1) <> long <::> then
connect_or_reconnect (out, outfile.file_f, curr_filename, false <*dont stack*>);
end;
end;
▶EOF◀