|
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 - download
Length: 70656 (0x11400)
Types: Rc489k_TapeFile, TextFile
└─⟦aa55fa693⟧ Bits:30007479 SW8110/1 TAS/SOS/PRIMO Rel 2.3
└─⟦this⟧
begin
<* the program initializes, updates and/or lists a
sos-usercatalog.
for every process (user) the catalog keeps information about
the process' bases, need for resources and a fp-string for use
when starting the process. apart from that informations about
the terminals allowed to communicate this process, is registered.
process-name 8 half-words
! buffers 1 - !
! areas 1 - !
! std-,user-,maxbase 12 - ! process-describtion
! password 8 - !
! min-, maxsize 4 - !
! filler 10 - !
! fp-string 40 - !
! !
! ! !12 !
! ! device-name !288 - device- !
! ! entry-,segms ! describtion !
! ! !12 !
! !
! !
! terminal external id 8 - !
! local id 2 - ! terminal-
! userkey 8 - ! describtion
! bufring 1 - !
! timecount 1 - !
! filler 6 - !
! !
the first n segments of the catalog is an indexregister
for the rest. n is computed from the maximum number of
processes wanted in the catalog (n=(max+49)// 50 , 50
processes per indexsegment). the maximum wanted is specified
when the catalog is initialized.
every process occupies an integer of segments. the segments
of a process are chained in the last word of the segment.
free segments are chained in the last word of the
segments starting at the first indexsegment.
indexsegments:
segment 0:
!--------------------!
! process-name ! 8 half-words
! segm.no of process-descr. ! 2 half-word
!--------------------!
! . !
! . !
! . !
! . !
! !
! !
!--------------------!
! process-name !
! segm.no !
!--------------------!
! -1 !
! -1 !
! -1 !
word 254 ! no of processes ! 2 half-words
word 255 ! max no processes ! 2 half_words
word 256 ! segm.no first free seg/-1 ! 2 half_word
!--------------------!
segment n-1:
!--------------------!
! process-name !
! segm.no !
!--------------------!
! . !
! . !
! . !
! !
! !
!--------------------!
! process-name !
! segm.no !
!--------------------!
! -1 !
! . !
! . !
! !
! !
! -1 !
!--------------------!
segments for processdescribtion:
!--------------------!
! !
! process-describtion !
! -process-name !
! -terminal-descr. !
! ! 364 half-words
! !
! !
!--------------------!
! terminal-descr1 ! 26 half-words
!--------------------!
! . !
! . !
! . !
! !
! !
!--------------------!
! terminal descr 5 !
!--------------------!
word 256 ! segm.no next segm/-1 ! 2 half-words
!--------------------!
!--------------------!
! terminal descr 6 !
!--------------------!
! . !
! . !
! . !
! !
! !
! !
! !
!--------------------!
! terminal descr 24 !
!--------------------!
! -1 !
! . !
! . !
! -1 !
!--------------------!
! segm.no next segm/-1 !
!--------------------!
!--------------------!
! terminal descr !
!--------------------!
! . !
! . !
! . !
!--------------------!
! terminal descr !
!--------------------!
! -1 !
! . !
! . !
! . !
! . !
! . !
! -1 !
!--------------------!
*>\f
boolean em, init, list, data_error, cont, nl, sp,
newpa_read, tempnewcat;
integer elem_in_val, valindex,
elem_in_glval,
no, pa, tr,
maxprocs, index_segm, used_segm, proc_segms,
proc_count, proc_byte,
term_count, term_start, term_byte,
trans, paramno, no1, no2,
i, j, k, last,
new, old, free, proc_no, stop, proc_segm, term, maxsegm,
index_lgt, proc_des_lgt, term_des_lgt, proc_pa_lgt,
term_pa_lgt, proc_pr_index, term_pr_prsegm, term_pr_segm,
free_w_prsegm, free_w_segm, great_trno, tr_end,
tr_maxp, tr_proc, pa_term, pa_dterm, lastterm,no_of_bs;
real short;
integer array cat_table, quote_table(0:127), val, kind(1:120),
glval, glkind(1:120),
proc_params(1:182), term_params(1:13), tail(1:10),
index(1:5);
long array param(0:22), first_bs_device, outfile, oldcat, newcat, proc_name, name(1:2);
boolean field buf, area, bufs, time;
integer field csegm, segm, intid, next, entr,
mins, maxs,
std1, std2, use1, use2, max1, max2, k0s, k0e;
integer array field word, perm1, perm;
long array field pass, exid, key, fp, dev, lbase;
real array field base, base1, base2;
zone zonew, zoold(128*3, 3, stderror),
zoout(128*2, 2, stderror);
<* variables:
area : points to areas in processdescribtion.
base, base1, base2 : help-variables.
buf : points to buffers in processdescr.
bufs : points to bufring in terminal-descr.
cat_table : definition of kinds for characters normally read.
cont : used in connection with for-while statements.
csegm : points to segments in processdescr.
dataerror : true errors has occured during updating
false otherwise.
dev : points to device-name in devicedescr.
elem_in_val : number of elements in val and kind.
em : true the parameter end or the character em
has been read
false otherwise.
entr : points to entries in processdescr.
exid : points to external-id. in terminal-descr.
first_bs_device: name of first bs device from monitor table.
fp : points to fp-command in process-descr.
free : number of segment used during updating.
free_w_prsegm : address of first free word after
last terminal-descr in a segment with process-descr.
free_w_segm : address of first free word after last terminal-descr
in a segment without processdescr.
great_trno : greatest value of a transaction.
i : help-variable.
index : array for indexelements.
index_lgt : length of an indexsegment in half-words.
index_segm : points out an index_segment.
init : true new catalog is to be initialized
false catalog is to be updated.
intid : points to local-id. in terminal-descr.
j, k : help-variables.
key : points to userkey in terminal-descr.
kind : inddata stored by use of readall.
k0e : points to entries of key0 in devicedescr.
k0s : points to segments of key0 in device-descr.
last : number of segment used during updating.
last_term : help-variable.
lbase : help-variable.
list : true new catalog is to be listed after updating
false otherwise.
maxprocs : maximum number of processes for which there are
room in the indexsegments.
maxsegm : no of segments in the catalog beeing updated.
maxs : points to maxsize in process-descr.
max1, max2 : points to maxbases in process-descr.
mins : points to minsize in process-descr.
name : name read from inddata.
new : number of segments used during updating.
newcat : name of new catalog.
new_pa_read : true if a new parameter has been read
false otherwise.
next : help-variable.
nl : =false add 10, used in writestatements.
no : =0, used in calls of the procedure error.
no_of_bs : number of bs devices
no1, no2 : help-variables.
old : number of segments used during updating.
oldcat : name of catalog if updating is wanted.
outfile : name of outfile if listing is wanted.
pa : =1, used in calls of the procedure error.
pa_dterm : value of the parameter dterm.
param : first four characters of all parameters.
paramno : number of the parameter beeing executed.
pass : points to password in process-descr.
pa_term : value of the parameter term.
perm : points to devicename in process-descr.
perm1 : points to devicename of first device (disc)
in process-descr.
proc_byte : used as parameter in calls of the procedure
segm_no.
proc_count : no of process in the catalog.
proc_des_lgt : length of a process-descr in half-words.
proc_name : process-name.
proc_no : number of process.
proc_pa_lgt : great index of the array proc_params.
proc_params : array for process-descr.
proc_pr_index : number of process-names per indexsegment.
proc_segm : number of segment containing process-descr.
proc_segms : segments occupied by one process.
quote_table : definition of kinds for characters read in
connection with quotes.
segm : points to segment-number in endexelement.
short : used in connection with systime(7,..)-
get shortclock.
sp : = false add 32, used in writestatements.
std1, std2 : points to standardbases in process-descr.
stop : used in connection with for-step-statements.
tail : used in connection with monitorprocedures.
tempnewcat : true if a temporary file has been created for
the new catalog
false otherwise.
term : number of segment containing terminal-descr.
term_byte : used as parameter in calls of the procedure
term_segm.
term_count : counts number of terminals belonging to one
process.
term_des_lgt : length of a terminal-descr. in half-words.
term_pa_lgt : great index of the array term_params.
term_params : array for terminal-descr.
term_pr_prsegm : number of terminal-describtions pr segment
with process-descr.
term_pr_segm : number of terminal-descr. pr segment
without terminal-descr.
term_start : points out the start of terminal-describtions
in a segment.
time : points to timecount in terminal-descr.
tr : = 2, used in calls of the procedure error.
trans : number of the transaction beeing executed.
tr_end : value of the transaction end.
tr_maxp : value of the transaction maxp.
tr_proc : value of the transaction proc.
used_segm : counts the segments used by initializing a
new catalog.
use1, use2 : points to userbases in process-descr.
val : inddata stored by use of readall.
valindex : number of next element in val and kind to
be examined.
word : used at word-operating on zones.
zonew : zone for new catalog.
zoold : zone for old catalog.
zoout : zone for listing of catalog.
*>
\f
procedure read_line;
begin
<* reads a new line into val and kind.
assigns elem_in_val (no. of elements in val and kind) and
valindex (points to next element in val to be read)
*>
integer i;
trap(again);
trapmode := 1 shift 2 + 1 shift 3;
again1:
for i:=1, 1 while elem_in_val<=0 do
begin
elem_in_val := read_all(in, val, kind, 1);
if elem_in_val<0 then
begin
elem_in_glval := elem_in_val;
error(<:line too long:>, no);
end;
end;
valindex := 1;
if glval(elem_in_glval)<>34 then elem_in_glval := 0;
for i:=1 step 1 until elem_in_val do
begin
glval(elem_in_glval+i) := val(i);
glkind(elem_in_glval+i) := kind(i);
end;
elem_in_glval := elem_in_glval + elem_in_val;
goto outrl;
again:
elem_in_glval := elem_in_val;
error(<:line too long:>, no);
trapmode := 0;
goto again1;
outrl:
end;
procedure skip_delim;
begin
<* skips delimiters.
at return valindex points to next element in val not beeing
a delimiter.
*>
integer i;
if valindex>elem_in_val then read_line;
i := valindex-1;
for i:=i+1 while kind(i)>=7 do
begin
if kind(i)=9 or val(i)=34
then error(<:illegal char:>, no);
if i=elem_in_val then
begin
if val(i)=25 then
begin
em := true;
goto out_skip;
end
else
begin
read_line;
i := valindex-1;
end;
end;
end for;
out_skip:
valindex := i;
end skip_delim;
procedure skip_to_text;
begin
<* skips to kind=text (6).
at return valindex points to next element in val
of kind text.
*>
boolean rep;
integer i;
rep := true;
for i:=1 while rep do
begin
skip_delim;
if em or kind(valindex)=6 then rep := false
else <* skip kind 1 and 2 *> valindex := valindex + 1;
end;
end skip_to_text;
\f
boolean procedure read_no(no);
integer no;
begin
<* read_no (return) true number is read.
false otherwise
no (return) read_no=false 0
true the number read.
if read_no is false only delimiters has been read
(valindex points to nest element in val not beeing a delimiter).
*>
boolean ok;
no := 0;
ok := true;
skip_delim;
if -,em then
begin
if kind(valindex)=2 then
begin
no := val(valindex);
valindex := valindex + 1;
end
else ok := false;
end
else ok := false;
read_no := ok;
end read_no;
boolean procedure read_name(text, chars);
value chars;
integer chars;
long array text;
begin
<* read_name (return) true name is read
false otherwise.
text (return) read_name=false nulls
true the name read.
chars (call) max number of characters in text.
if read_name is false only delimiters has been read.
*>
boolean ok;
integer i, j, k, longs, char, read_chars, startindex;
skip_delim;
read_chars := 0;
longs := chars//6 + 1;
startindex := valindex;
for i :=(if em then (longs+1) else 1) step 1 until longs do
begin
text(i) := 0;
if kind(valindex) = 6 then
begin
for j:=0,1 do
for k:=-16 step 8 until 0 do
begin
char := val(valindex+j) shift k extract 8;
if read_chars=0 and char=0
then read_chars := (i-1)*6 + j*3 + (k+16)//8;
end;
text(i) := extend val(valindex) shift 24 + val(valindex+1);
valindex := valindex + 2;
end;
end;
ok := read_chars>=1 and read_chars<=chars;
if -,ok then
begin
valindex := startindex;
for i:=1 step 1 until longs do text(i) := 0;
end;
read_name := ok;
end read_name;
\f
procedure read_param(paramno);
integer paramno;
begin
<* paramno (return) -1 parameter not read
i no of parameter read.
if paramno=-1 only delimiters has been read.
*>
integer i, first, last;
long text;
paramno := -1;
skip_delim;
if -,em then
begin
first := i := valindex -1;
for i:=i+1 while kind(i)=6 do;
last := i-1;
if last>first and last-first<=4 then
begin
text := extend val(first+1) shift 24 + val(first+2) shift (-16) shift 16;
i := -1;
for i:=i+1 while i<22 and text<>param(i) do;
if i<22 then
begin
valindex := last + 1;
paramno := i;
end;
end;
end;
end read_param;
\f
boolean procedure read_quote_text(text, chars);
value chars;
long array text;
integer chars;
begin
<* reads string of characters surrounded by quotes into text.
read_quote_text (return) true text is read
false otherwise.
text (return) read_quote_text=false: nulls
else the text read.
chars (call) max no of characters in text.
if read_quote_text is false a line may have been skipped.
*>
boolean ok, rep;
integer i, j, zerono;
for i:=1 step 6 until chars do text(i//6+1) := 0;
rep := ok := true;
for i:=1 while rep and ok do
begin
for j:=valindex step 1 until elem_in_val do
begin
if kind(j)<7 then ok := false else
if kind(j)=9 then error(<:illegal char:>, no) else
if j=elem_in_val then
begin
if val(j)=25 <* em *> then
begin
em := true;
ok := false;
end
else if val(j)=34 then rep:= false
else
begin
read_line;
j := valindex - 1;
end;
end;
end for j;
end for i;
if ok then
begin
intable(quote_table);
read_line;
zerono := 3 - chars mod 3;
if val(elem_in_val)=25 <* em *> then
begin
em := true;
ok := false;
end
else if elem_in_val=1 and val(1)=34
then <* emty text *>
else if elem_in_val>chars//3+2 then ok := false
else if elem_in_val>chars//3 and
val(elem_in_val-1) shift ((3-zerono)*8) <> 0
then ok := false
else
begin
<* text ok *>
j := if zerono=3 then elem_in_val - 2
else elem_in_val - 1;
for i:=1 step 2 until j do
text((i+1)//2) := extend val(i) shift 24 + val(i+1);
end;
intable(cat_table);
read_line;
end ok;
read_quote_text := ok;
end read_quote_text;
\f
procedure init_proc(proc);
integer array proc;
begin
<* initialize proc with default values for process-describtion *>
integer i;
for i:=1 step 1 until proc_pa_lgt do proc(i) := 0;
proc.buf := false add 4;
proc.area := false add 7;
proc.maxs := 8 388 607;
proc.perm1.dev(1) := first_bs_device(1);
proc.perm1.dev(2) := first_bs_device(2);
proc.perm1(5) := 6; <* entries key0 *>
end;
\f
boolean procedure read_proc(proc);
integer array proc;
begin
<* reads process-describtion.
read_proc (return) true: parameters read
false: error in parameters.
proc (return) read_proc-false: undefined
true: the data read.
at return valindex points to next element not beeing a
process-parameter.
*>
boolean cont, ok, found, allzero;
integer i, j, k, no1, no2, paramno, param_start;
long array name(1:2);
integer field segm, entr;
integer array field perm;
ok := true;
for i:=valindex step 1 until elem_in_val do
if kind(i)<=6 then
begin
param_start := valindex;
i := elem_in_val;
end
else param_start := 1;
read_param(paramno);
cont := -,em and paramno<>0;
if -,cont then valindex := param_start;
for i:=1 while cont do
begin
if paramno<=great_trno or paramno>=pa_dterm then
begin
cont := false;
valindex := param_start;
end
else
begin
case (paramno-great_trno) of
begin
begin <* buf *>
if -,read_no(no1) or no1<=0 then
begin
error(<:buf:>, pa);
ok := false;
end
else proc.buf := false add no1;
end;
begin <* area *>
if -,read_no(no1) or no1<=0 then
begin
error(<:area:>, pa);
ok := false;
end
else proc.area := false add no1;
end;
begin <* stdbase *>
if -,read_no(no1) or -,read_no(no2) or no1>no2 then
begin
error(<:stdbase:>, pa);
ok := false;
end
else
begin
proc.std1 := no1;
proc.std2 := no2;
end;
end;
begin <* userbase *>
if -,read_no(no1) or -,read_no(no2) or no1>no2 then
begin
error(<:userbase:>, pa);
ok := false;
end
else
begin
proc.use1 := no1;
proc.use2 := no2;
end;
end;
begin <* maxbase *>
if -,read_no(no1) or -,read_no(no2) or no1>no2 then
begin
error(<:maxbase:>, pa);
ok := false;
end
else
begin
proc.max1 := no1;
proc.max2 := no2;
end;
end;
begin <* password *>
if -,read_quote_text(proc.pass, 11) then
begin
error(<:password:>, pa);
ok := false;
end;
end;
begin <* minsize *>
if -,read_no(proc.mins) or proc.mins<0 then
begin
error(<:minsize:>, pa);
ok := false;
end;
end;
begin <* maxsize *>
if -,read_no(proc.maxs) or proc.maxs<0 then
begin
error(<:maxsize:>, pa);
ok := false;
end;
end;
begin <* fp *>
if -,read_quote_text(proc.fp, 59) then
begin
error(<:fp:>, pa);
ok := false;
end;
end;
begin <* perm *>
if -,read_name(name, 11) then
begin
error(<:device name:>, pa);
ok := false;
end
else
begin
found := false;
i := 0;
for i:=i+1 while -,found and i<=no_of_bs do
begin
perm := perm1 + (i-1)*24;
if proc.perm.dev(1)=0 and proc.perm.dev(2)=0 or
proc.perm.dev(1)=name(1) and proc.perm.dev(2)=name(2) then
begin
<* read entries and segms *>
proc.perm.dev(1) := name(1);
proc.perm.dev(2) := name(2);
found := true;
for j:=0 step 1 until 3 do
begin
for k:= valindex step 1 until elem_in_val do
if kind(k)<=6 then
begin
param_start := valindex;
k := elem_in_val;
end
else param_start := 1;
read_param(paramno);
if paramno<16 or paramno>19 then
begin
error(<:bs:>, no);
valindex := param_start;
ok := false;
j := 4;
i := 5;
end
else
begin
entr := k0e + (paramno-16)*4;
segm := entr + 2;
if -,read_no(no1) or -,read_no(no2) then
begin
error(<:bs:>, pa);
ok := false;
end
else
begin
proc.perm.entr := no1;
proc.perm.segm := no2;
end;
end;
end for j;
<* if all entr and segm area zero device-name is
deleted, except for first bs device *>
name(1) := first_bs_device(1);
name(2) := first_bs_device(2);
for j:=2 step 1 until no_of_bs do
begin
perm := perm1 + (j-1)*24;
allzero := true;
for k := 5 step 1 until 12 do
if proc.perm(k)>0 then allzero := false;
if allzero then
proc.perm.dev(1) :=
proc.perm.dev(2) := long <::>;
end;
end found;
end for i;
if -,found then
begin
error(<:bs full:>, pa);
ok := false;
end;
end;
end perm;
begin <* key0 *>
<* key0 is read in perm - error *>
error(<:bs:>, pa);
ok := false;
end;
begin <* key1 *>
<* key1 is read in perm - error *>
error(<:bs:>, pa);
ok := false;
end;
begin <* key2 *>
<* key2 is read in perm - error *>
error(<:bs:>, pa);
ok := false;
end;
begin <* key3 *>
<* key3 is read in perm - error *>
error(<:bs:>, pa);
ok := false;
end;
end case;
for i:=valindex step 1 until elem_in_val do
if kind(i)<=6 then
begin
param_start := valindex;
i := elem_in_val;
end
else param_start := 1;
read_param(paramno);
end proc_param;
end for cont;
<* entries is summed to disc-entries *>
no1 := no2 := 0;
for i:=2 step 1 until no_of_bs do
begin
perm := perm1 + (i-1)*24;
no1 := no1 + proc.perm(5);
no2 := no2 + proc.perm(7);
end;
proc.perm1(5) := proc.perm1(5) + no1;
proc.perm1(7) := proc.perm1(7) + no2;
read_proc := ok;
end read_proc;
\f
boolean procedure check_proc(proc);
integer array proc;
begin
<* checks that all process-data has a proper value.
check_proc (return) true data is ok
false otherwise.
proc (call) array containing process-data.
valindex is unchanged.
*>
boolean ok;
integer i;
integer field segm0, segm1, segm2, segm3,
entr0, entr1, entr2, entr3;
long array field base;
entr0 := k0e; entr1 := entr0 + 4;
entr2 := entr1 + 4; entr3 := entr2 + 4;
segm0 := k0s; segm1 := segm0 + 4;
segm2 := segm1 + 4; segm3 := segm2 + 4;
ok := true;
<* check bases *>
if proc.std1<proc.use1 or proc.std2>proc.use2 or
proc.use1<proc.max1 or proc.use2>proc.max2 then
begin
error(<:base error:>, no);
ok := false;
end;
<* check size *>
if proc.mins > proc.maxs then
begin
error(<:size error:>, no);
ok := false;
end;
<* check segms and entries *>
for i:=0 step 1 until no_of_bs-1 do
begin
base := perm1 + i*24;
if proc.base.segm0<proc.base.segm1 or proc.base.segm1<proc.base.segm2 or
proc.base.segm2<proc.base.segm3 or
proc.base.entr0<proc.base.entr1 or proc.base.entr1<proc.base.entr2 or
proc.base.entr2<proc.base.entr3 then
begin
error(<:claim error:>, no);
ok := false;
i := 4;
end;
end;
check_proc := ok;
end check_proc;
\f
procedure error(text, skip_to);
string text;
integer skip_to;
begin
<* writes a text and current input line on primary output
and skips some input.
text (call) the text to be written.
skip_to (call) tells how much to skip
0: nothing
1: until next parameter
2: until next transaction (paramno<=5).
at return valindex points to next element to be read.
*>
boolean nl, rep;
integer i, paramno;
nl := false add 10;
write(out, false add 32, 30-write(out, nl,1, text), <:process :>, proc_name, nl,1);
for i:=1 step 1 until elem_in_glval do
begin
case glkind(i) of
begin
<* 1 *> write(out, glval(i));
<* 2 *> write(out, glval(i));
<* 3-5 *>;;;
<* 6 *> write(out, string(extend glval(i) shift 24));
<* 7 *> write(out, false add glval(i),1);
<* 8 *> if glval(i)<>25 then
write(out, false add glval(i),1);
<* 9 *> write(out, false add glval(i),1);
end;
end for;
write(out, nl,1);
if skip_to>no then
begin
<* find next param *>
rep := true;
for i:=1 while rep do
begin
i := valindex - 1;
for i:=i+1 while kind(i)=6 do;
valindex := i;
skip_to_text;
if em then emerror;
i := valindex;
read_param(paramno);
if paramno=tr_end then
begin
if init then goto endinit
else goto endupd;
end
else
if paramno<>-1 then
begin
if skip_to=pa or skip_to=tr and paramno<=great_trno then
begin
<* param/trans found *>
valindex := i;
rep := false;
end;
end;
end skip_to;
end;
data_error := true;
end error;
procedure emerror;
begin
<* writes a text on primary output and stop program-execution *>
error(<:abnormal end:>, no);
data_error := true;
if init then goto endinit
else goto endupd;
end;
\f
integer procedure segm_no(zo, id, byteno);
zone zo;
long array id;
integer byteno;
begin
<* searches for a process in the indexsegments.
segm_no (return) -1 process is not in catalog
else noof index-segment containing processname.
zo (call) zone describing the catalog to search in.
id (call) name of process to be searched for.
byteno (return) no of byte preceding processname
if found, else byte preceding first
free byte.
*>
boolean found;
integer i, psegm_no, index_segm, proc_no;
integer array field index, word;
long array field name;
psegm_no := -1;
index_segm := 0;
setposition(zo, 0, 0);
inrec6(zo, 512);
word := 0;
proc_no := if init then proc_count else zo.word(254);
name := 0;
index := 10;
found := false;
i := 0;
for i:=i+1 while i<=proc_no and -,found do
begin
if i>1 and i mod proc_pr_index=1 then
begin
<* new index_segm is to be read *>
index_segm := index_segm+1;
setposition(zo, 0, index_segm);
inrec6(zo, 512);
name := 0; index := 10;
end;
if id(1)=zo.name(1) and id(2)=zo.name(2) then
begin
psegm_no := index_segm;
found := true;
end
else
begin
name := name + index_lgt;
index := index + index_lgt;
end;
end;
segm_no := psegm_no;
if -,found and i mod proc_pr_index=1 then name := 0;
byteno := name;
end segm_no;
\f
integer procedure term_segm(zo, proc_segm, id1, id2, byteno);
value proc_segm, id2;
zone zo;
integer proc_segm, byteno, id2;
long array id1;
begin
<* searches for a terminal belonging to a certain process.
term_segm (return) abs value is number of segment on hand.
negative: term not found
positive no of segment describing the terminal.
zo (call) zone describing the catalog to search in.
proc_segm (call) no of segment at which to start the search.
id1, id2 (call) names of terminal.
byteno (return) no of byte preceding terminal describtion
if found else byte preceding firste free.
*>
boolean cont;
integer i, segm_no;
integer field name2,next;
integer array field word;
long array field name1;
segm_no := -proc_segm;
setposition(zo, 0, proc_segm);
swoprec6(zo, 512);
word := 0;
name1 := proc_des_lgt; name2 := name1 + 10;
next := name1 + 2;
cont := true;
i := 0;
for i:=i+1 while cont and zo.next<>-1 do
begin
if id1(1)=zo.name1(1) and id1(2)=zo.name1(2) or
id2=zo.name2 then
begin
cont := false;
segm_no := -segm_no;
end
else
begin
name1 := name1 + term_des_lgt; name2 := name2 + term_des_lgt;
next := next + term_des_lgt;
if -segm_no=proc_segm and i=term_pr_prsegm or
-segm_no<>proc_segm and i=term_pr_segm then
begin
if zo.word(256)=-1 then cont := false
else
begin
segm_no:=-zo.word(256);
setposition(zo, 0, -segm_no);
swoprec6(zo, 512);
name1 := 0; name2 := 10;
next := 2;
i := 0;
end;
end
end;
end for i;
term_segm := segm_no;
byteno := name1;
end term_segm;
\f
procedure extendcat(zo);
zone zo;
begin
<* extends the area described by zo with one segment.
the new segment(s) is chained as free.
maxsegm is initialized with the new areasize.
*>
integer oldsegms, newsegm, i, j, old;
integer array tail(1:10);
i := monitor(42) lookup :(zo, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
oldsegms := tail(1);
tail(1) := tail(1) + 1;
i := monitor(44) change entry :(zo, 0, tail);
if i>0 then system(9, i, <:<10>ch.entr:>);
i := monitor(42, zo, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
newsegm := tail(1) - 1;
setposition(zo, 0, 0);
inrec6(zo, 512);
old := -1;
for i:=newsegm step -1 until oldsegms do
begin
setposition(zo, 0, i);
outrec6(zo, 512);
for j:=1 step 1 until 255 do zo.word(j) := -1;
zo.word(256) := old;
old := i;
end;
setposition(zo, 0, 0);
swoprec6(zo, 512);
zo.word(256) := oldsegms;
maxsegm := newsegm;
end udvidcat;
\f
begin <* read and check fp-params *>
<* syntax of programcall:
(<newcat> =) upsoscat (<input>) (oldcat.(<cat>/no)) (list.(<outfile>/no))
*>
boolean ok;
integer i, j, k, l, m, in_no;
real short;
integer array tail(1:10), ia(1:20);
long array field name;
real array arr(1:2);
zone z(128*3, 3, em);
procedure em(z, s, b);
zone z;
integer s, b;
if s shift (-18)=1 then goto copyend
else stderror(z, s, b);
<* get name of first bs device from monitor table *>
system(5) move core :(98,ia); <* ia(1) holds address of chain table
of device holding maincat *>
<* get device name from chaintable *>
system(5) move core :(ia(1)-18,first_bs_device);
name := 2;
j := 0;
for i:=1,2 do
oldcat(i) := newcat(i) := outfile(i) := long <::>;
init := true;
list := false;
i := system(4, 1, arr);
if i=6 shift 12 + 10 then
begin
<* <newcat> is to be read *>
i := system(4, 0, arr);
if i<=0 then system(9, 0, <:<10>call:>);
to_from(newcat, arr, 8);
j := 2;
end
else j := 1;
in_no := j;
for i:=system(4, j, arr) while i>0 do
begin
if i=4 shift 12 + 10 and arr(1)=real <:oldca:> add 116 and
arr(2)= real <::> then
begin <* copy <cat> *>
j := j + 1;
if system(4, j, arr)=8 shift 12 + 10 then
begin
if arr(1)= real <:no:> then init := true
else
begin
to_from(oldcat, arr, 8);
init := false;
end;
end
else system(9, j, <:<10>call:>);
end
else if i=4 shift 12 + 10 and arr(1)=real <:list:> then
begin
<* <outfile> is to be read *>
j := j + 1;
if system(4, j, arr)=8 shift 12 + 10 then
begin
if arr(1)=real <:no:> then list := false
else
begin
to_from(outfile, arr, 8);
list := true;
end;
end
else system(9, j, <:<10>call:>);
end
else if j<>in_no or i<>4 shift 12 + 10 then system(9, j, <:<10>call:>);
j := j + 1;
end for;
if newcat(1)=long <::> then
begin
open(zonew, 4, <::>, 0);
for i:=2 step 1 until 10 do tail(i) := 0;
tail(1) := 1;
tail(6) := systime(7, 0, short);
m := monitor(40) cr entr :( zonew, 0, tail);
if m>0 then system(9, m, <:<10>temp cr:>);
getzone6(zonew, ia);
close(zonew, true);
newcat(1) := extend ia(2) shift 24 add ia(3);
newcat(2) := extend ia(4) shift 24 add ia(5);
tempnewcat := true;
end
else
begin
tempnewcat := false;
k := 1;
open(zonew, 4, newcat(increase(k)), 0);
m := monitor(42) lookup :( zonew, 0, tail);
if m=3 then
begin
for i:=2 step 1 until 10 do tail(i) := 0;
tail(1) := 1;
tail(6) := systime(7, 0, short);
m := monitor(40) cr entr :( zonew, 0, tail);
if m>0 then system(9, m, <:<10>temp cre:>);
end
else if m<>0 then system(9, m,<:<10>newcat:>);
close(zonew, true);
end;
if -,init then
begin
k := 1;
open(z, 4, string oldcat(increase(k)), 1 shift 18);
m := monitor(42)lookup:( z, 0, tail);
if m>0 then system(9, m, <:<10>oldcat:>);
open(zoold, 4, <::>, 0);
tail.name(1) := long <::>;
tail.name(2) := long <::>;
m := monitor(40)create entry:( zoold, 0, tail);
if m>0 then system(9, m, <:<10>temp cre:>);
getzone6(zoold, ia); <* get area-name *>
close(zoold, true);
arr(1) := 0.0 shift 24 add ia(2) shift 24 add ia(3);
arr(2) := 0.0 shift 24 add ia(4) shift 24 add ia(5);
k := 1;
open(zoold, 4, string arr(increase(k)), 0);
ok := true;
for k:=1 while ok do
begin
inrec6(z, 512);
outrec6(zoold, 512);
for l:=1 step 1 until 128 do
zoold(l) := z(l);
end;
copyend:
close(z, true);
end;
if list then
begin
k := 1;
open(zoout, 4, outfile(increase(k)), 0);
m := monitor(42) lookup :( zoout, 0, tail);
if m=3 then
begin
for i:=2 step 1 until 10 do tail(i) := 0;
tail(1) := 1;
tail(6) := systime(7, 0, short);
m := monitor(40)cr entr :( zoout, 0, tail);
if m>0 then system(9, m,<:<10>temp cre:>);
end
else if m<>0 then system(9, m, <:<10>outfile:>);
close(zoout, true);
end;
end fp-param;
\f
<* initialize cat_table and quote_table *>
begin
integer i;
<* cat_table-kinds:
0: same as iso.
1: great number.
2: number.
3: signs.
6: letters.
7: space.
8: quote, ff, nl and em.
9: the rest, illegal characters.
*>
for i:=1 step 1 until 47, 58 step 1 until 64,
94, 95, 96, 126
do cat_table(i) := 9 shift 12 + i;
for i:=0, 13, 127 do cat_table(i) := 0 shift 12 + i;
for i:=48 step 1 until 57 do cat_table(i) := 2 shift 12 + i;
cat_table(43) := 3 shift 12 + 43;
cat_table(45) := 3 shift 12 + 45;
for i:=65 step 1 until 93 do cat_table(i) := 6 shift 12 + i+32;
for i:=97 step 1 until 125 do cat_table(i) := 6 shift 12 + i;
cat_table(32) := 7 shift 12 + 32;
for i:=10, 12, 25, 34 do cat_table(i) := 8 shift 12 + i;
<* quote_table-kinds:
0: same as iso.
8: quote and em.
6: the rest.
*>
for i:=1 step 1 until 127 do quote_table(i) := 6 shift 12 + i;
for i:=0, 13, 127 do quote_table(i) := 0 shift 12 + i;
for i:=25, 34 do quote_table(i) := 8 shift 12 + i;
intable(cat_table);
end;
<* initialize param *>
begin
integer i;
for i:=0 step 1 until 22 do
param(i) := long (case (i+1) of (
<:end:>,
<:maxp:>, <:proc:>, <:dpro:>, <:cpro:>, <:ipro:>,
<:buf:>, <:area:>, <:stdb:>, <:user:>, <:maxb:>,
<:pass:>, <:mins:>, <:maxs:>,
<:fp:>, <:bs:>, <:key0:>, <:key1:>, <:key2:>,
<:key3:>, <:dter:>, <:term:>, <::>) );
end;
data_error := false;
em := false;
elem_in_val := 0;
elem_in_glval := 1;
glval(1) := glkind(1) := 0;
valindex := 1;
proc_name(1) := proc_name(2) := long <::>;
no := 0;
pa := 1;
tr := 2;
nl := false add 10;
sp := false add 32;
word := 0;
base := 0;
segm := 10;
exid := 0;
intid := 10;
key := 10;
bufs := 19;
time := 20;
buf := 1; area := buf + 1;
std1 := area + 2; std2 := std1 + 2;
use1 := std2 + 2; use2 := use1 + 2;
max1 := use2 + 2; max2 := max1 + 2;
pass := max2;
mins := pass + 10;
maxs := mins + 2;
fp := maxs + 10;
perm1 := fp + 40;
dev := 0; k0e := dev + 10; k0s := k0e + 2;
index_lgt := 10;
proc_des_lgt := 364;
term_des_lgt := 26;
proc_pa_lgt := proc_des_lgt//2;
term_pa_lgt := term_des_lgt//2;
no_of_bs := 12; <* 12 bs devices allowed *>
proc_pr_index := (512-6)//index_lgt;
term_pr_prsegm := (512-2-proc_des_lgt)//term_des_lgt;
term_pr_segm := (512-2)//term_des_lgt;
free_w_prsegm := proc_des_lgt + term_des_lgt*term_pr_prsegm + 2;
free_w_segm := term_des_lgt*term_pr_segm + 2;
great_trno := 5;
tr_end := 0;
tr_maxp := 1;
tr_proc := 2;
pa_term := 21;
pa_dterm := 20;
i := 1;
open(zonew, 4, string newcat(increase(i)), 0);
\f
if init then
begin
maxprocs := proc_pr_index;
index_segm := 0;
read_param(trans);
newpa_read := false;
if trans=tr_maxp then
begin
if read_no(no1) then
maxprocs := (no1+proc_pr_index-1)//proc_pr_index*proc_pr_index;
index_segm := (maxprocs-1)//proc_pr_index;
read_param(trans);
end;
i := monitor(42) lookup :(zonew, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
maxsegm := tail(1) - 1;
for i:=1 while maxsegm<index_segm do extendcat(zonew);
for i:=0 step 1 until maxsegm do
begin
setposition(zonew,0,i);
outrec6(zonew,512);
for j:=1 step 1 until 256 do zonew.word(j):=-1;
if i>index_segm then zonew.word(256) := i + 1;
end;
if i>index_segm then zonew.word(256) := -1;
used_segm := index_segm;
index_segm := -1;
proc_count := 0;
for i:=1 while -,em do
begin
if trans=tr_end then
begin
em :=true;
goto endinit;
end
else
if trans<>tr_proc then
begin
error(<:trans:>, tr);
goto read_trans;
end;
if proc_count>=maxprocs then
begin
error(<:cat full:>, no);
goto endinit;
end;
if -,read_name(proc_name, 8) then
begin
error(<:name:>, tr);
goto read_trans;
end;
if segm_no(zonew, proc_name, proc_byte)<>-1 then
begin
error(<:proc in cat:>, tr);
goto read_trans;
end;
init_proc(proc_params);
if read_proc(proc_params) then
begin
if check_proc(proc_params) then
begin
if proc_byte=0 then
index_segm := index_segm + 1;
setposition(zonew, 0, index_segm);
swoprec6(zonew, 512);
used_segm := used_segm + 1;
if used_segm>maxsegm then
begin
extendcat(zonew);
setposition(zonew, 0, index_segm);
swoprec6(zonew, 512);
end;
base := proc_byte;
proc_count := proc_count + 1;
to_from(zonew.base, proc_name, 8);
zonew.base.segm := used_segm;
setposition(zonew, 0, used_segm);
swoprec6(zonew, 512);
zonew.word(256) := -1;
to_from(zonew, proc_params, proc_des_lgt);
proc_segms := 1;
term_count := 0;
term_start := proc_des_lgt;
read_param(paramno);
newpa_read := true;
for i:=1 while paramno=pa_term do
begin
for j:=1 step 1 until term_pa_lgt do term_params(j) := 0;
term_params.bufs := false add 1;
term_params.time := false add 40;
if -,read_name(term_params.exid, 11) then
begin
error(<:name:>, pa);
goto read_term;
end;
if -,read_quote_text(name, 3) then
begin
error(<:locid:>, pa);
goto read_term;
end;
term_params.intid := name(1) shift (-24) extract 24;
if term_segm(zonew, used_segm-proc_segms+1, term_params.exid,
term_params.intid, term_byte)>0 then
begin
error(<:term in cat:>, pa);
goto read_term;
end;
if -,read_quote_text(term_params.key, 11) then
begin
error(<:term-key:>, pa);
goto read_term;
end;
<* read bufring and timecount if present *>
if read_no(j) then
begin
if j<0 then
begin
error(<:bufring:>, pa);
goto read_term;
end
else begin
term_params.bufs := false add j;
if read_no(j) then
begin
if j<=0 then
begin
error(<:timecount:>, pa);
goto read_term;
end
else term_params.time := false add j;
end;
end;
end;
term_count := term_count + 1;
if proc_segms=1 and term_count=term_pr_prsegm+1 or
proc_segms>1 and term_count=term_pr_segm+1 then
begin
used_segm := used_segm + 1;
if used_segm>maxsegm then extendcat(zonew);
setposition(zonew, 0, used_segm-1);
swoprec6(zonew, 512);
zonew.word(256) := used_segm;
setposition(zonew, 0, used_segm);
swoprec6(zonew, 512);
zonew.word(256) := -1;
proc_segms := proc_segms + 1;
term_count := 1;
term_start := 0;
end;
setposition(zonew, 0, used_segm);
swoprec6(zonew, 512);
base := term_start + (term_count-1)*term_des_lgt;
to_from(zonew.base, term_params, term_des_lgt);
read_term:
read_param(paramno);
end for paramno=term;
end if check_proc;
end if read_proc;
read_trans:
if newpa_read and paramno>great_trno or -,newpa_read
then read_param(trans)
else trans := paramno;
newpa_read := false;
end while -,em;
endinit:
setposition(zonew, 0, 0);
swoprec6(zonew, 512);
zonew.word(254) := proc_count;
zonew.word(255) := maxprocs;
if used_segm<maxsegm then
zonew.word(256) := used_segm + 1
else zonew.word(256) := -1;
end init\f
else
begin <* update *>
read_param(trans);
newpa_read := false;
for i:=1 while -,em do
begin
if trans=tr_end then
begin
em := true;
goto end_upd;
end;
if trans>great_trno or trans<=tr_proc then
begin
error(<:trans:>, tr);
goto read_upd;
end;
if -,read_name(proc_name, 8) then
begin
error(<:name:>, tr);
goto read_upd;
end;
index_segm := segm_no(zoold, proc_name, proc_byte);
case (trans-tr_proc) of
begin
begin <* delete process *>
if index_segm=-1 then
begin
error(<:proc not in cat:>, tr);
goto read_upd;
end;
base := proc_byte;
new := zoold.base.segm;
setposition(zoold, 0, 0);
inrec6(zoold, 512);
old := zoold.word(256);
for i:=1 while new<>-1 do
begin
setposition(zoold, 0, new);
swoprec6(zoold, 512);
j:=new;
new := zoold.word(256);
for k:=1 step 1 until 255 do
zoold.word(k) := -1;
zoold.word(256) := old;
old := j;
end;
setposition(zoold, 0, 0);
swoprec6(zoold, 512);
zoold.word(256) := old;
zoold.word(254) := zoold.word(254) - 1;
proc_no := index_segm*proc_pr_index + (proc_byte+index_lgt)//index_lgt;
base1 := proc_byte;
base2 := base1 + index_lgt;
stop := zoold.word(254);
setposition(zoold, 0, index_segm);
swoprec6(zoold, 512);
for i:=proc_no step 1 until stop do
begin
<* index is moved from place i+1 to i *>
if i mod proc_pr_index=0 then
begin
setposition(zoold, 0, index_segm+1);
swoprec6(zoold, 512);
base2 := 0;
end;
to_from(index, zoold.base2, index_lgt);
if i mod proc_pr_index=0 then
begin
setposition(zoold, 0, index_segm);
swoprec6(zoold, 512);
end;
to_from(zoold.base1, index, index_lgt);
if i mod proc_pr_index =0 then
begin
index_segm := index_segm + 1;
setposition(zoold, 0, index_segm);
swoprec6(zoold, 512);
base1 := 0;
end
else base1 := base1 + index_lgt;
base2 := base2 + index_lgt;
end;
stop := index_lgt//2;
for i:=1 step 1 until stop do
zoold.base1.word(i) := -1;
end;
begin <* correct process *>
if index_segm=-1 then
begin
error(<:process not in cat:>, tr);
goto read_upd;
end;
setposition(zoold, 0, index_segm);
inrec6(zoold, 512);
base := proc_byte;
proc_segm := zoold.base.segm;
setposition(zoold, 0, proc_segm);
swoprec6(zoold, 512);
for i:=1 step 1 until proc_pa_lgt do
proc_params.word(i) := zoold.word(i);
no1 := no2 := 0;
for i:=2 step 1 until 4 do
begin
perm := perm1 + (i-1)*24;
no1 := no1 + proc_params.perm(5);
no2 := no2 + proc_params.perm(7);
end;
proc_params.perm1(5) := proc_params.perm1(5) - no1;
proc_params.perm1(7) := proc_params.perm1(7) - no2;
if read_proc(proc_params) then
begin
if check_proc(proc_params) then
begin
to_from(zoold, proc_params, proc_des_lgt);
read_param(paramno);
newpa_read := true;
for k:=1 while paramno=pa_dterm or paramno=pa_term do
begin
for i:=1 step 1 until term_pa_lgt do term_params(i) := 0;
if -,read_name(term_params.exid, 11) then
begin
error(<:name:>, pa);
goto read_upd_term;
end;
if -,read_quote_text(name, 3) then
begin
error(<:locid:>, pa);
goto read_upd_term;
end;
term_params.intid := name(1) shift (-24) extract 24;
term := term_segm(zoold, proc_segm,
term_params.exid, term_params.intid, term_byte);
case (paramno-(pa_dterm-1)) of
begin
begin <* dterm *>
if term<=-1 then
begin
error(<:term not in cat:>, pa);
goto read_upd_term;
end;
base1 := term_byte;
lastterm := (if free_w_prsegm<=free_w_segm
then free_w_prsegm else free_w_segm) -
(term_des_lgt + 2);
base2 := if term_byte>=lastterm <* next term in new segm *> then 0
else term_byte+term_des_lgt;
last := old := term;
if base2=0 and zoold.word(256)<>-1 then
begin
setposition(zoold, 0, zoold.word(256));
swoprec6(zoold, 512);
next := zoold.word(1);
end
else next := if base2<>0 then zoold.base2.word(1)
else -1;
for i:=1 while next<>-1 do
begin
<* compress term_describtions *>
to_from(term_params, zoold.base2, term_des_lgt);
if base2=0 then
begin
setposition(zoold, 0, old);
swoprec6(zoold, 512);
end;
to_from(zoold.base1, term_params, term_des_lgt);
if base2=0 then
begin
last := old;
old := zoold.word(256);
setposition(zoold, 0, old);
swoprec6(zoold, 512);
end;
base1:= if base1>=lastterm then 0
else base1 + term_des_lgt;
base2 := if base2>=lastterm then 0
else base2 + term_des_lgt;
if base2=0 and zoold.word(256)<>-1 then
begin
setposition(zoold, 0, zoold.word(256));
swoprec6(zoold, 512);
next := zoold.word(1);
end
else next := if base2<>0 then zoold.base2.word(1)
else -1;
end;
<* next = -1 *>
for i:=base1+2 step 2 until 512 do
zoold.word(i//2) := -1;
<* segm old is free if base1=0 *>
if base1 = 0 then
begin
setposition(zoold, 0, last);
swoprec6(zoold,512);
zoold.word(256) := -1;
setposition(zoold, 0, 0);
swoprec6(zoold, 512);
i := zoold.word(256);
zoold.word(256) := old;
setposition(zoold, 0, old);
swoprec6(zoold, 512);
zoold.word(256) := i;
end;
end <* dterm *>;
begin <* term *>
if term>0 then
begin
error(<:term in cat:>, pa);
goto read_upd_term;
end;
term_params.bufs := false add 1;
term_params.time := false add 40;
if -,read_quote_text(term_params.key, 11) then
begin
error(<:term-key:>, pa);
goto read_upd_term;
end;
<* read bufring and timecount if present *>
if read_no(j) then
begin
if j<=0 then
begin
error(<:bufring:>, pa);
goto read_upd_term;
end
else begin
term_params.bufs := false add j;
if read_no(j) then
begin
if j<=0 then
begin
error(<:timecount:>, pa);
goto read_upd_term;
end
else term_params.time := false add j;
end;
end;
end;
base := term_byte;
lastterm := (if free_w_prsegm<=free_w_segm
then free_w_segm else free_w_prsegm) -
(term_des_lgt + 2);
if term_byte<=lastterm then
<* room in this segm *>
to_from(zoold.base, term_params, term_des_lgt)
else begin
<* new segm in use *>
setposition(zoold, 0, 0);
inrec6(zoold, 512);
new := zoold.word(256);
if new=-1 then
begin
extendcat(zoold);
setposition(zoold, 0, 0);
inrec6(zoold, 512);
new := zoold.word(256);
end;
setposition(zoold, 0, new);
swoprec6(zoold, 512);
free := zoold.word(256);
to_from(zoold, term_params, term_des_lgt);
setposition(zoold, 0, -term);
swoprec6(zoold, 512);
zoold.word(256) := new;
setposition(zoold, 0, 0);
swoprec6(zoold, 512);
zoold.word(256) := free;
end;
end <* term *>;
end case paramno;
read_upd_term:
read_param(paramno);
end for;
end if check_proc;
end if read_proc;
end cproc;
begin <* insert process *>
if index_segm<>-1 then
begin
error(<:proc in cat:>, tr);
goto read_upd;
end;
init_proc(proc_params);
if read_proc(proc_params) then
begin
if check_proc(proc_params) then
begin
setposition(zoold, 0, 0);
swoprec6(zoold, 512);
if zoold.word(254) = zoold.word(255) then
begin
error(<:cat full:>, tr);
goto read_upd;
end;
zoold.word(254) := zoold.word(254) + 1;
proc_segm := zoold.word(256);
if proc_segm=-1 then
begin
extendcat(zoold);
setposition(zoold, 0, 0);
swoprec6(zoold, 512);
proc_segm := zoold.word(256);
end;
index_segm := (zoold.word(254)-1)//proc_pr_index;
if index_segm<>0 then
begin
setposition(zoold, 0, index_segm);
swoprec6(zoold, 512);
end;
base := proc_byte;
to_from(zoold.base, proc_name, 8);
zoold.base.segm := proc_segm;
setposition(zoold, 0, proc_segm);
swoprec6(zoold, 512);
old := proc_segm;
new := zoold.word(256);
zoold.word(256) := -1;
to_from(zoold, proc_params, proc_des_lgt);
proc_segms := 1;
term_count := 0;
term_start := proc_des_lgt;
read_param(paramno);
newpa_read := true;
for i:=1 while paramno=pa_term do
begin
for j:=1 step 1 until term_pa_lgt do term_params(j) := 0;
term_params.bufs := false add 1;
term_params.time := false add 40;
if -,read_name(term_params.exid, 11) then
begin
error(<:name:>, pa);
goto read_upd_term1;
end;
if -,read_quote_text(name, 3) then
begin
error(<:locid:>, pa);
goto read_upd_term1;
end;
term_params.intid := name(1) shift (-24) extract 24;
if term_segm(zoold, proc_segm, term_params.exid,
term_params.intid, term_byte)>0 then
begin
error(<:term in cat:>, pa);
goto read_upd_term1;
end;
if -,read_quote_text(term_params.key, 11) then
begin
error(<:term-key:>, pa);
goto read_upd_term1;
end;
<* read bufring and timecount if present *>
if read_no(j) then
begin
if j<0 then
begin
error(<:bufring:>, pa);
goto read_upd_term1;
end
else begin
term_params.bufs := false add j;
if read_no(j) then
begin
if j<0 then
begin
error(<:timecount:>, pa);
goto read_upd_term1;
end
else term_params.time := false add j;
end;
end;
end;
term_count := term_count + 1;
if proc_segms=1 and term_count=term_pr_prsegm+1 or
proc_segms>1 and term_count=term_pr_segm+1 then
begin
if new=-1 then
begin
extendcat(zoold);
setposition(zoold, 0, 0);
inrec6(zoold, 512);
new := zoold.word(256);
setposition(zoold, 0, old);
swoprec6(zoold, 512);
end;
zoold.word(256) := new;
setposition(zoold, 0, new);
swoprec6(zoold, 512);
old := new;
new := zoold.word(256);
zoold.word(256) := -1;
proc_segms := proc_segms + 1;
term_count := 1;
term_start := 0;
end;
base := term_start + (term_count-1)*term_des_lgt;
to_from(zoold.base, term_params, term_des_lgt);
read_upd_term1:
read_param(paramno);
end for paramno=term;
setposition(zoold, 0, 0);
swoprec6(zoold, 512);
zoold.word(256) := new;
end if check_proc;
end if read_proc;
end iproc;
end case trans-2;
read_upd:
if newpa_read and paramno>great_trno or -,newpa_read
then read_param(trans)
else trans := paramno;
newpa_read := false;
end while -,em;
endupd:
i := monitor(42) lookup :(zoold, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
maxsegm := tail(1);
i := monitor(42) lookup :(zonew, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
if tail(1)<maxsegm then
begin
tail(1) := maxsegm;
i := monitor(44) change entry :(zonew, 0, tail);
if i>0 then system(9, i, <:<10>ch.entr:>);
end;
setposition(zoold, 0, 0);
setposition(zonew, 0, 0);
for i:=1 step 1 until maxsegm do
begin
inrec6(zoold, 512);
outrec6(zonew, 512);
for j:=1 step 1 until 128 do
zonew(j) := zoold(j);
end;
i := monitor(48) remove entry :( zoold, 0, tail);
if i>0 then system(9, i, <:<10>remove:>);
close(zoold, true);
end update;
i := monitor(42) lookup :( zonew, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
tail(6) := systime(7, 0, short);
i := monitor(44) change entry :(zonew, 0, tail);
if i>0 then system(9, i, <:<10>ch.entr:>);
\f
if list then
begin
i := 1;
open(zoout, 4, string outfile(increase(i)), 0);
setposition(zonew, 0, 0);
inrec6(zonew, 512);
proc_count := zonew.word(254);
write(zoout, false add 12,1, nl,1, string param(1), sp,1, zonew.word(255));
for k:=1 step 1 until proc_count do
begin
setposition(zonew, 0, (k-1)//proc_pr_index);
inrec6(zonew, 512);
lbase := (if k mod proc_pr_index=0 then (proc_pr_index-1) else
(k mod proc_pr_index - 1))*index_lgt;
write(zoout, nl,3, string param(2), sp,1, zonew.lbase);
setposition(zonew, 0, zonew.lbase.segm);
inrec6(zonew, 512);
write(zoout, nl,1, sp,2, string param(6), sp,1, zonew.buf extract 24,
sp,1, sp,2, string param(7), sp,1, zonew.area extract 24,
nl,1, sp,2, string param(8), sp,1, zonew.std1, sp,1, zonew.std2,
nl,1, sp,2, string param(9), sp,1, zonew.use1, sp,1, zonew.use2,
nl,1, sp,2, string param(10), sp,1, zonew.max1, sp,1, zonew.max2,
nl,1, sp,2, string param(11), sp,1, false add 34,1, zonew.pass, false add 34,1,
nl,1, sp,2, string param(12), sp,1, zonew.mins,
nl,1, sp,2, string param(13), sp,1, zonew.maxs,
nl,1, sp,2, string param(14), sp,1, false add 34,1, zonew.fp, false add 34,1);
for i:=0 step 1 until no_of_bs-1 do
begin
no1 := no2 := 0;
if i=0 <* disc *> then
begin
for j:=2 step 1 until no_of_bs do
begin
perm := perm1 + (j-1)*24;
no1 := no1 + zonew.perm(5);
no2 := no2 + zonew.perm(7);
end;
end;
perm := perm1 + i*24;
if zonew.perm(1)<>0 then
begin
lbase := perm;
write(zoout, nl,1, sp,2, string param(15), sp,1, zonew.lbase);
for j:=0 step 1 until 3 do
begin
csegm := k0s + j*4; entr := csegm-2;
write(zoout, sp,1, string param(16+j), sp,1,
zonew.perm.entr-(if j=0 then no1 else
if j=1 then no2 else 0),
sp,1, zonew.perm.csegm);
end;
end;
end;
cont := true;
exid := proc_des_lgt;
intid := exid + 10;
key := intid;
bufs := key + 9;
time := bufs + 1;
next := exid + 2;
for i:=1 while cont and zonew.next<>-1 do
begin
write(zoout, nl,1, sp,2, string param(21), sp,1, zonew.exid,
sp,1, false add 34,1, string extend zonew.intid shift 24,
false add 34,1, sp,1, false add 34,1,
zonew.key, false add 34,1, sp,1, zonew.bufs extract 12,
sp,1, zonew.time extract 12);
exid := exid + term_des_lgt;
intid := intid + term_des_lgt;
key := key + term_des_lgt;
bufs := bufs + term_des_lgt;
time := time + term_des_lgt;
next := next + term_des_lgt;
if next=free_w_prsegm or next=free_w_segm then
begin
proc_segms := zonew.word(256);
if proc_segms=-1 then cont := false
else
begin
setposition(zonew, 0, proc_segms);
inrec6(zonew, 512);
exid := 0;
intid := 10;
key := 10;
bufs := 19;
time := 20;
next := 2;
end;
end;
end;
end for k;
write(zoout, nl,1, string param(0), nl,1, false add 25,1);
i := monitor(42) lookup :( zoout, 0, tail);
if i>0 then system(9, i, <:<10>lookup:>);
tail(6) := systime(7, 0, short);
i := monitor(44) change entry :( zoout, 0, tail);
if i>0 then system(9, i, <:<10>ch.entry:>);
close(zoout, true);
end list;
close (zonew, true);
if tempnewcat then
begin
i := monitor(48) remove entry :(zonew, 0, tail);
if i>0 then system(9, i, <:<10>remove:>);
end;
if data_error then system(9, 0, <:<10>errors:>);
end;
▶EOF◀