|
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: 165120 (0x28500)
Types: TextFile
Names: »tincsave«, »vko«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tincsave«
└─⟦this⟧ »vko«
incsave=algol list.no xref.no blocks.no
begin
message vk 1982.02.03 incsave;
boolean last,total,std,list,outp,sys,savenotok;
integer outres,date,i,vksegm,psegm,c2size;
long array input(1:2);
real array outarr(1:3);
long array tapename(1:2),ptapename(1:2),t1tapename(1:2),resname(1:2);
zone zhelp(1,1,stderror);
procedure openout;
begin
long array outname(1:2);
outp:=true;
outname(1):=input(1);outname(2):=input(2);
fpproc(29)stack current out:(0,out,outarr);
outres:=201;
fpproc(28)connect out:(outres,out,outname);
if outres <> 0 then
begin
outp:=false;
fpproc(30)unstack out:(0,out,outarr);
write(out,<:<10> connect error= :>,outres);
goto halt;
end;
end;
procedure closeout;
begin
write(out,<:<10>:>);
if outp then
begin
fpproc(34)close up:(0,out,25);
fpproc(79)terminatezoe:(0,out,0);
fpproc(30)unstack out:(0,out,outarr);
end;
end;
\f
procedure vksortproc(param, keydescr, names, eof, noofrecs,
result, explanation);
value eof;
real eof;
integer array param, keydescr;
real array names;
integer noofrecs, result, explanation;
comment
\f
Algol fortran standard procedure mdsortproc page 1
Purpose.
Mdsortproc, merge_disc_sorting_procedure, is a procedure,
intended for fast sorting of one backing storage area.
The procedure can be called from a program coded in algol or
fortran for RC 4000, RC 6000, and RC 8000.
Function.
The procedure sorts a backing storage file holding records of either
fixed or variable length, using backing storage throughout.
The basic sorting method, is the merge technique:
Sorted strings, as long as possible, are generated by internal sor-
ting during the first reading of the input file.
After that, these strings are merged repeatedly until only one sor-
ted string is left.
The procedure will try to minimize the sorting time by variation of
mergepowers, blocklengths, use of single- or double-buffering, and
by utilization of two disc-stores, if available.
The procedure needs in total a backing storage area of about twice
the size of the data to be sorted.
It can be specified that the input file shall be cleared, so its
area can be used for the merge.
The free core, when the procedure is called, must be more than
about 10000 halfwords, depending on the blocklengths and record-
lengths specified.
The value of 10000 is valid for blocklengths up to 2 segments.
The sort can use any amount of free core to speed up the sorting
and room for a work file on two different discs will reduce the
time for input output.
\f
Algol fortran standard procedure mdsortproc page 2
Call.
mdsortproc (param, keydescr, names, eof, noofrecs,
result, explanation)
param(1:7) (call value, integer array)
This array holds various parameters of type integer
and type boolean, describing the files and the
records.
param(1) segsperinblock.
Blocklength of the input file, given as a number
of segments. 1 <= segsperinblock <= 40.
Supplied by sq system if content = 21.
param(2) clearinput.
1: The input file is cleared, and its area can be
used for the merge.
0: The input file must not be cleared.
param(3) segsperoutblock.
Blocklength of the final output file, given as a
number of segments. 1 <= segsperoutblock <= 40.
If param(3) = 0 , segsperoutblock:= segsperinblock.
param(4) fixedlength.
1: Fixed recordlength. Inrec6/outrec6 are used.
0: Variable recordlength. Invar/outvar are used.
2: variable recordlength but no checksum.
param(5) maxlength.
The maximum length of variable length records, and
the length of fixed length records, measured in
halfwords.
Maxlength >= 2 and maxlengh <= segsperinblock * 512
and maxlength <= segsperoutblock * 512.
Maxlength must be even.
It is important for the efficiency of the sort
that maxlength reflects the real maximum length
of variable length records.
param(6) noofkeys.
The number of keyfields in the sorting key.
1 <= noofkeys <= maxlength and <= 169.
param(7) concerns the reaction on resource troubles.
0: Resource troubles will not stop the execution,
the procedure returns with result > 1.
<>0: Resource troubles causes runtime alarm.
\f
Algol fortran standard procedure mdsortproc page 3
keydescr(1: (call value, integer array)
noofkeys, 1:2) The description of the sorting key.
Keyfield n is specified as: +/- type, position,
in keydescr(n, 1:2).
The type ranges from 1 to 5, indicating: signed
halfword, integer, long, real, or abshalfword.
The sign of the type specifies the sequencing:
+ for ascending, and - for descending order.
The position of the keyfield is specified as the
number of the last halfword in the field, as for
algol field variables.
The position may not excede 2047.
The entire keyfield must be within a maximum length
record.
The length of variable length records must not be
less than the position of keyfield 1, the highest
priority keyfield.
records having equal values in all keyfields are
sorted according to their occurrence in the input
file, i.e. their mutual order is not changed.
In connection with very long records (maxlength=
param(5) >= 2046) the facility is switched off.
names(1:6) (call and return value, real array)
Contains 3 file and disc names.
names(1:2) inputfile.
The name of a backing storage area.
The procedure asumes that the size of the area re-
flects the amount of data to be sorted.
names(3:4) outputfile.
If names(3) = real<::> then the name of the output-
file is returned in names(3:4), otherwise the name
given is used for the final output file.
An existing file of this name on scope temp is
cleared without warning, just before the end.
The sort is not able to use the resources of such
a file.
names(5:6) outdisc.
If names(5) = real<::> then the output disc is
selected according to the most efficient strategy,
otherwise the disc specified is used.
\f
Algol fortran standard procedure mdsortproc page 4
eof (call value, real)
If the parameter noofrecs is negative, then the
end of the input file is indicated by a record
holding the bitpattern given by eof in the first
4 halfwords of the userpart. Halfword 1 to 4 in
case of fixed length and halfword 5 to 8 in case
of variable length records.
The final output file is terminated by an end
of file record of maximum length in this case.
noofrecs (call and return value, integer)
If noofrecs is non negative, then the number of
records in the input file is given by the value of
noofrecs and an eof record is not created.
The number of sorted records is returned in any
case in this parameter.
With an sq file noofrecs <= 0 means that noofrecs
is supplied by the sq system, noofrecs > 0 means
that only this number of records are to be sorted.
result (return value, integer)
The value of result specifies the result of the
call of the procedure.
In general, resource problems will yield a result
different from 1, whereas errors concerning the
parameters or hard errors will stop the execution
by a runtime alarm.
If param(7) <> 0 only result = 1 will occur, the
other results are transformed to alarms.
explanation (return value, integer)
The value of this parameter should give a further
explanation of result. See the next section.
Sq system files.
If the content field of the catalog entry of the input file
is equal to 21, it is supposed that the file conforms to the
conventions of the sq file system.
The output file will be created as an sq file as well.
Results.
result explanation comment
1 segments output the sort was ok
2 -lacking core halfwords not sufficient core
3 see alarm disc not sufficient backing storage
4 see alarm out disc backing store specified by names
(5:6) does not exist or has too
few resources.
Results > 1 are only given if param(7) = 0.
The parameter noofrecs will contain the number of sorted records
if result = 1 , otherwise it is unchanged.
The output file will, provided result = 1, be cut to the minimum
size, and tail(6) of the catalog entry will contain the same
value as noofrecs, if not sq file.
\f
Algol fortran standard procedure mdsortproc page 5
Requirements.
The available amount of core storage before the call of the proce-
dure must satisfy the condition:
free_half_words
> 7000
+ 512*(segsperinblock + segsperoutblock)
+ 4*maxlength + 24*noofkeys.
The procedure requires as working areas two disc files of the
size of the input file.
This means in the case when the input file is removed that
the procedure must be able to create one work file of that size.
If the input file is not removed the procedure must be able
to create two work files of the size of the input file.
If an output disc is specified this disc must be able to
hold the final output file.
already at the beginning of the procedure it is checked that
the output disc is capable of holding a file of the size of the
input file. (this is of course the case if the inputfile is
placed on the disc specified and has to be removed).
the blocking of records may be changed by the sorting, so the
output file may have a greater size than the input file.
Work files are kept at minimum size by concatenation of the
records without regards to block limits.
The procedure needs 2 catalog entries, 2 area processes, and
1 message buffer. So, the job process should at least be the owner
of 4 area processes, and 2 message buffers.
But it is recommended to have a greater number of message buffers,
(10 to 20), especially in the case of a sort of small records,
(about 2 to 20 halfwords), with great core size.
Variable length records.
The sum check facility of invar is used during the reading of the
input file if param(4) = 0 (invar with checksum control).
The record length must not excede maxlength.
The minimum record length is given by the greatest of the two val-
ues: 4 (if noofrecs < 0 then 8) and keydescr(1, 2).
Thus some of the keyfields of a short record may in fact be situ-
ated outside the record.
Such a record is sorted as if all the bits of keyfields outside
the record were equal to zero.
\f
Algol fortran standard procedure mdsortproc page 6
Alarms.
Parameter errors and hard file errors will stop the run with a run
time alarm.
alarmtext integer comment
param param number error at param(param number)
keyfield keyfield illegal position or type of keyfield
<integer>.
create monitor result abnormal result in call of the mon-
itor procedure create entry.
lookup monitor result abnormal result from lookup entry.
This alarm will normally indicate
that names(1:2) does not specify a
catalog entry.
change monitor result abnormal result in call of change
entry. Should not occur.
rename monitor result it is impossible to rename the final
output file to names(3:4).
remove monitor result abnormal result in call of remove
entry. The alarm will normally con-
cern the original input file.
infile tail(1) names(1:2) does not point to a catalog
entry describing an area.
r.length record length variable length record of a length
greater than maxlength, less than key-
descr(1, 2), or less than 8 if eof used.
passes 20 the sort could not be done in 20 mer-
ging passes. This alarm should never
occur.
reccount record count this is a hard error or a programming
error. The counts of records in the
first pass and the last, are not
equal, the last count is shown.
size -lacking halfwords not enough core.
disc -lacking entries too few entries in main catalog.
segments not enough segments, the value
of segments is the size of
one workfile.
out disc -1 the wanted output disc is not
mounted.
segments not room for one workfile on the
wanted output disc.
trap passnumber normally spill in key comparison.
nrecs sq noofrecs param noofrecs > records in sq file.
The alarms: size, disc and out disc (resources) will only be given
in case param(7) <> 0, otherwise the corresponding results, 2 to 4,
with explanation will be given.
In addition, index alarms may occur, if the parameter arrays are
incorrectly declared, and alarms from opensq or stderror may occur,
if file or record formats are illegal or in case of hard errors.
Alarms, with the exception of index alarms, are preceded by the
text, ***mdsortproc alarm:.
The alarm r.length, and stderror alarms occurring during the rea-
ding of the input file are also preceded by a line, specifying the
number of input records accepted before the error was detected.
\f
;
begin
boolean
fixedlength;
integer
bytes_per_inblock,
bytes_per_outblock,
content,
discstores,
freebytes,
i,
maxkeyposition,
maxlength,
maxlength_plus_four,
messbufsforinp,
min_segs_per_block,
noofkeys,
outbytes,
outsegment,
pass,
passes,
recs,
recsout,
segsin,
segsoutzero,
segsperinblock,
segsperoutblock,
shares,
shortclock,
strings1;
real time;
integer array
in_segs, merge_power, segsout(1:20);
real array
sortfiles(1:4);
comment *************************************;
integer resultsq;
procedure opensq(p1,p2,p3,p4);
zone p1; string p2; integer p3,p4;
begin
write(out,<:*******opensq call********* :>);
goto returnfromdiscsort;
end;
comment **************;
comment -test-<
procedure printkey(i1, i2, r) -test-<
value i1, i2 -test-<
integer i1, i2 -test-<
real array r -test-<
begin
integer i, pos -test-<
boolean field bfld -test-<
integer field ifld -test-<
long field lfld -test-<
real field rfld -test-<
pos:= write(out, <:<10>key :>, << ddddd>, i1, i2, <:::>) -test-<
for i:= 3 step 2 until noofkeys*2+1 do
begin
if pos > 100 then
pos:= write(out, <:<10> :>) -test-<
bfld:= ifld:= lfld:= rfld:= keydescr(i+1) -test-<
pos:= pos + (case abs keydescr(i) of (
write(out, << -dddd>, r.bfld extract 12),
write(out, << -ddddddd>, r.ifld),
write(out, <<-dddddddddddd>, r.lfld),
write(out, <<-ddddddddddd>, r.rfld),
write(out, << -dddd>, r.bfld extract 12))) -test-<
end -test-<
write(out, <:<10>:>) -test-<
end printkey ;
\f
procedure print_rec(recno, rec);
value recno; integer recno; real array rec;
comment
prints recno and the keyfields of rec;
begin
integer i, pos;
boolean field bfld;
integer field ifld;
long field lfld;
real field rfld;
pos:= if pass = 0 then
write(out, <:<10>no::>, <<ddddddd>, recno, <: key::>)
else
write(out, <:<10>key::>);
for i:= 3 step 2 until noofkeys*2 + 1 do
begin
bfld:= ifld:= lfld:= rfld:= keydescr(i+1);
if pos > 62 then pos:= write(out, <:<10> :>);
pos:= pos +
(case (abs keydescr(i)) extract 2 + 1 of (
<* 4 *> write(out, <<-dddddddd.dddd'-dd>, rec.rfld),
<* 1,5 *> write(out, << dddd>, rec.bfld extract 12),
<* 2 *> write(out, << -ddddddd>, rec.ifld),
<* 3 *> write(out, << -ddddddddddddddd>, rec.lfld)));
end print keyfields;
write(out, <:<10>:>);
end print_rec;
procedure print_zsort(zsort);
zone zsort;
comment
prints the two last compared records in zsort.
the comparison must have been done by outsort or lifesort;
begin
integer i;
integer field recnumber;
integer array ia(1:20), bases(1:2);
recnumber:= maxlength + 2;
getzone6(zsort, ia);
system(5, ia(2) - 2, bases);
for i:= 1, 2 do
begin
ia(14):= bases(i); <* recordbase *>
setzone6(zsort, ia);
print_rec(zsort.recnumber, zsort);
end print the two records;
end print_zsort;
\f
procedure alarm(text, int);
value text, int;
integer text, int;
comment
this is the common alarm and error procedure.
it removes the workfiles.
the integer text selects the alarmtext, and the integer int
is the alarm integer.
if text >= 100 return is performed to docerror.
if text >= 12 and <= 14 return may be performed with result and
explanation by a jump to return_from_discsort, otherwise
system is called by a jump to the bottom of procedure
discsort in order to get a simple alarm address.
the string value of the text is transmitted in
sortfiles(1), and the integer in segsin.
;
begin
integer i;
for i:= 1, 3 do clear_file(sortfiles, i);
if text >= 12 and text <= 14 then
begin
comment return with result <> 1 depending on param(7);
if param(7) = 0 then
begin
result:= text - 10;
explanation:= int;
goto return_from_discsort;
end continuation wanted;
end text 12 to 14;
write(out, <:<10><10>***mdsortproc alarm:<10>:>);
if text = 9 or text = 100 then
write(out, <:<10> accepted records: :>, recs, <:<10>:>);
if text < 100 then
begin
comment not called from docerror;
sortfiles(1):= real (case text of(
<:<10>param :>,
<:<10>keyfield:>,
<:<10>create :>,
<:<10>lookup :>,
<:<10>change :>,
<:<10>rename :>,
<:<10>remove :>,
<:<10>infile :>,
<:<10>r.length:>,
<:<10>passes :>,
<:<10>reccount:>,
<:<10>size :>,
<:<10>disc :>,
<:<10>out disc:>,
<:<10>trap :>,
<:<10>nrecs sq:>));
segsin:= int;
comment -test-< system(9, segsin, string sortfiles(1));
goto alarmcall;
end not called from docerror;
end alarm;
\f
procedure clear_file(name, i);
value i; integer i; real array name;
begin
zone z(1, 1, stderror);
open(z, 0, string name(increase(i)), 0);
monitor(48, z, 0, in_segs); <* remove entry *>
end clear_file;
procedure docerror(z, s, b);
zone z;
integer s, b;
comment
the procedure calls alarm to have the sortfiles removed and
the alarm headline printed, and calls stderror;
begin
alarm(100 + pass, 0);
stderror(z, s, b);
end docerror;
\f
procedure endoffilerec(zout);
zone zout;
comment
note that this procedure finishes the sort by a jump to the
label return_from_disc_sort.
if the parameter noofrecs < 0, the procedure creates a
record of the maximum length holding the bitpattern given by eof
in the first 4 bytes of the userpart.
if content is not zero, the remaining part of the block, or per-
haps a new block is filled with integers of the value -1.
remember that the final output is super blocked
if made in the mergephase;
begin
integer i, maxlength, remaining, remaining_blocks, segments;
integer array ia(1:20);
integer field ifld;
real array field raf;
if recs <> recsout then alarm(11, recsout);
if noofrecs < 0 then
begin
comment create a maximum length eof record;
maxlength:= param(5); <* use the original maxlength *>
ifld:= outrec6(zout, 0) mod bytes_per_out_block;
if ifld < maxlength then
begin
outrec6(zout, ifld);
for ifld:= ifld step -2 until 2 do zout.ifld:= 0;
end not room for maxlength in current block;
outrec6(zout, maxlength);
for ifld:= 2 step 2 until maxlength do zout.ifld:= 0;
if fixedlength then zout(1):= eof
else
begin
ifld:= 2;
zout.ifld:= maxlength;
zout(2):= eof;
checkvar(zout);
end variable length;
end noofrecs < 0;
\f
comment find the size of the file;
for i:= 1 step 1 until 10 do ia(i):= 0; <* tail for changeentry *>
remaining:= outrec6(zout, 0);
getposition(zout, 0, segments);
if pass = 0 then segments:= segments + segs_per_outblock
else
begin
comment superblocking is used;
remaining_blocks:= (remaining - 2)//bytes_per_out_block;
remaining:= remaining - remaining_blocks * bytes_per_out_block;
segments:= segments + segs_out(pass) - remaining_blocks * segs_per_out_block;
end after merge;
if content <> 0 then
begin
comment
fill the remaining part according to bs and sq system;
outrec6(zout, remaining);
for ifld:= 2 step 2 until remaining do
zout.ifld:= -8388608;
ia(7):= segments // segs_per_out_block - 1; <* blocknumber *>
ia(8):= bytes_per_out_block - remaining;
ia(9):= content shift 12 add segs_per_out_block;
remaining:= 0;
if content = 21 then
begin
integer array field headpart;
setposition(zout, 0, 0);
headpart:= 0;
invar(zout);
i:= zout.headpart(1);
setposition(zout, 0, 0);
swoprec6(zout, i);
headpart:= zout.headpart(3);
headpart:= zout.headpart(1);
resultsq:= 1;
ia(6):= shortclock:= systime(7, 0, time);
for i:= 2 step 1 until 7 do
zout.headpart(i):= case i -1 of
(1,
recs,
ia(7),
ia(8),
0,
shortclock
);
checkvar(zout);
ia(7):= ia(8):= 0;
end sq file;
end bs system;
close(zout, true);
ia(1):= explanation:= segments - remaining//512;
ia(if content = 21 then 10 else 6):= noofrecs:= recs;
i:= monitor(44, zout, 0, ia); <* change entry *>
if i <> 0 then alarm(5, i);
comment rename the file or return workname;
if names(3) <> real<::> then
begin
raf:= -2*4;
for i:= 3 step 1 until 4 do ia.raf(i):= names(i);
i:= monitor(46, zout, 0, ia); <* rename entry *>
if i = 3 <* the name exists already *> then
begin
clear_file(names, 3);
i:= monitor(46, zout, 0, ia); <* repeat rename *>
end i = 3;
if i <> 0 then alarm(6, i);
end rename
else
begin
comment return workname;
getzone6(zout, ia);
raf:= 2 - 2*4;
for i:= 3 step 1 until 4 do names(i):= ia.raf(i);
end return name;
result:= 1;
goto return_from_discsort;
end endoffilerec;
\f
procedure endoutstring(zout, out_base, block_size);
value block_size;
zone zout;
real array field out_base;
integer block_size;
comment
the procedure outrecs a string chaining record of 6 bytes,
pointing to the start of the current outstring.
the first 4 bytes contain the values of the variables outsegment
and outbytes, specifying the position of the preceding chain
record.
the last two bytes hold the value of recsout, specifying the number
of records in the current outstring.
outsegment and outbytes are updated to point to the new chain
record, and recsout is set to zero.
global quantities:
outsegment the segment number of the block holding the
last created string chaining record.
outbytes the number of bytes preceding the chain record
in this block.
recsout the number of records in the current outstring.
;
begin
integer i, segment;
integer field new_base;
getposition(zout, 0, segment);
new_base:= out_base;
for i:= outsegment, outbytes, recsout do
begin
if new_base >= block_size then
begin
outrec6(zout, block_size);
new_base:= 2;
end change output block
else
new_base:= new_base + 2;
zout.new_base:= i;
end for i;
comment -test-< write(out, <:<10>test 14 , outsegment, outbytes,:>,
<: recsout: :>, outsegment, outbytes, recsout);
comment set outsegment, outbytes, recsout for the new string;
outsegment:= out_base // 512 + segment;
outbytes := out_base mod 512;
recsout:= 0;
out_base:= new_base;
end endoutstring;
\f
procedure errorinoutfile(z, s, b);
zone z;
integer s, b;
comment
this procedure is used as the blockprocedure of the output zones.
if not end of document then docerror is called.
else alarm is called;
begin
if s shift (-18) extract 1 <> 1 then docerror(z, s, b);
alarm(13, segsin); <* may give result 3 *>
end errorinoutfile;
\f
procedure select_merge_strategy;
comment
this procedure selects the most efficient strategy for the merge
under the constraints chosen.
the quantities, which can be altered, are the number of passes, the
mergepowers and the blocklengths corresponding to each pass,
and the number of shares to be used for input/output.
important global quantities:
discstores if discstores=2 then the transfertime can be
cut to the half by the use of doublebuffering.
freebytes the amount of core available for buffers.
a reasonable amount of room for programsegments
and variables has been subtracted in advance.
passes at entry, the value of passes defines the pos-
sible numbers of passes:
0: any number of passes is possible.
1: only an odd number of passes is possible.
2: only an even number of passes is possible.
at return, passes contains the selected number
of merging passes.
recs the total number of records.
segsin the number of segments of the input file.
segsperoutblock blocklength of the final output file.
shares the selected number of shares for input/output.
mergepower(1:20) the selected mergepowers for the merge passes.
insegs(1:20) input blocklengths for merging passes.
segsout(1:20) output blocklengths for merging passes.
strings1 the number of strings generated in pass 0.
;
begin
integer test_passes, test_shares,
bytes_per_in_seg, bytes_per_power, bytes_per_out_seg,
first_pass, pass_step,
last_maxpower, maxpower;
real great, min_time, time, time_best_passes;
integer array test_mergepower, test_in_segs, test_segs_out(1:20);
\f
boolean procedure find_powers;
comment
given a specific number of testpasses, the string generation pass not
counted, this procedure will, if sensible, return a series of
test_mergepowers.
;
begin
integer i, last_maxstrings, maxstrings, p;
maxstrings:= p:= if test_passes > 1 then 1
else
if strings1 < last_maxpower then strings1
else last_maxpower;
for i:= 1 step 1 until test_passes do test_mergepower(i):= p;
find_powers:= true;
if maxstrings >= strings1 then goto return;
last_maxstrings:= 0;
for p:= p + 1 while last_maxstrings < maxstrings do
begin
last_maxstrings:= maxstrings;
for i:= 1 step 1 until test_passes do
if p <= (if i < test_passes then maxpower else last_maxpower) then
begin
test_merge_power(i):= p;
maxstrings:= maxstrings // (p-1) * p;
if maxstrings >= strings1 then goto return;
end mergepower can be increased to p;
end for p;
find_powers:= false;
return:
end find_powers;
\f
real
procedure segs_and_time;
comment
given a set of test_mergepowers, the procedure will find the
best blocklengths.
the procedure calculates the time needed for the merge, and if this
time is less than mintime, it is stored in mintime, and the
relevant values are saved in the global variables used to control
the merge.
the time calculation is based upon empirical data for the disc, as
well as for the program.
;
begin
integer i, max_buffer_bytes,
p, p_times_bytes_in, segments_in, segments_out,
test_segments_in, test_segments_out;
real time, disc_for_pass, disc_for_in, disc_for_out,
test_time,
accesstime, transfertime, cpu_for_pass;
\f
comment
define empirical time constants in milliseconds:
for the disc store the following approximation is used:
disctimepersegment = accesstime/segsperblock + transfertime.
if only 1 discstore or only 1 share is used, the times for input
and output are added, otherwise the maximum value is used;
accesstime := 30;
transfertime:= 25/12 <* 12 = some mean track length *>;
comment
if several disc store types are used, the time constants should
be set according to a device type in the external process
for the disc storage device.
it is very difficult to calculate the time used for the disc
in a realistic manner. it should f.ex. be taken into account
that the disc-controller may allow parallel head positioning,
but not parallel data transfers, also
the transfertime may be greater if shorter disc slices chained
together are physically spread over the disc.
the cpu time is estimated as a linear function of the number of
records and the number of segments.
the following time constants should not be quite unrealistic:
but the machinetype should be fetched from the monitor and the
timeconstants set according to the speed of the cpu.
cpu_per_record : 2.0
cpu_per_segment : 3.2
;
cpu_for_pass := recs * 2.0 + segsin * 3.2;
comment
in addition to the times mentioned above, 2 seconds are added per
merging pass, and for 2 shares 10 percent is added to total time
to cover a persumed interference between the discs and the cpu.
another reason for this punishment of double buffering has been
the fact that the total load of the machinery, i.e. the sum of
the individual working times of discs and cpu, is greater with
double buffering due to smaller blocklengths or more passes;
\f
time:= 0;
for i:= 1 step 1 until test_passes do
begin
comment set some usefull variables;
p:= test_merge_power(i);
p_times_bytes_in:= bytes_per_in_seg * p;
max_buffer_bytes:= free_bytes - bytes_per_power * p;
disc_for_pass:= great;
test_segments_in:= min_segs_per_block;
calc_segments_out:
test_segments_out:=
(max_buffer_bytes - test_segments_in * p_times_bytes_in)
// bytes_per_out_seg;
if i = test_passes <* the last pass *> then
testsegmentsout:=
(if content = 21 and testsegmentsout > segsperoutblock then
segsperoutblock else testsegmentsout)
// segs_per_out_block * segs_per_out_block;
if test_segments_out >= min_segs_per_block then
begin
comment calculate the disctime for 1 segment;
disc_for_in := access_time/test_segments_in + transfer_time;
disc_for_out:= access_time/test_segments_out + transfer_time;
test_time:=
if test_shares = 1 or discstores = 1 then
disc_for_in + disc_for_out
else
if disc_for_in > disc_for_out then disc_for_in
else
disc_for_out;
if disc_for_pass > test_time then
begin
disc_for_pass:= test_time;
segments_in := test_segments_in;
segments_out := test_segments_out;
test_segments_in:= test_segments_in + 1;
goto calc_segments_out;
end a better result;
end test_segments_out >= min_segs_per_block;
disc_for_pass:= disc_for_pass * segsin;
time:= (if test_shares = 1 then
disc_for_pass + cpu_for_pass
else
(if disc_for_pass > cpu_for_pass then disc_for_pass
else cpu_for_pass) * 1.10)
+ 2000.0 + time;
test_in_segs (i):= segments_in;
test_segs_out(i):= segments_out;
end for i;
\f
segs_and_time:= time;
if time < mintime then
begin
comment return the hitherto best values;
mintime:= time;
passes:= test_passes;
shares:= test_shares;
for i:= 1 step 1 until test_passes do
begin
merge_power(i):= test_merge_power(i);
in_segs (i):= test_in_segs (i);
segs_out (i):= test_segs_out (i);
end;
end a better result;
end segs_and_time;
\f
comment before pass 1.
strings1 contains the number of strings generated during
pass 0, recs the real number of records, segsin the minimum size
of the output file from the string generation;
bytes_per_power:= maxlength + 106;
<* 1 record + 8 bytes + zonedescriptor and 2 sharedescriptors *>
first_pass:= if passes = 2 then 2 else 1;
pass_step := if passes = 0 then 1 else 2;
min_time:= great:= '10;
for test_shares:= 1 step 1 until 2 do
begin
bytes_per_in_seg:= bytes_per_out_seg:= test_shares * 512;
i:= minsegsperblock * bytes_per_in_seg + bytes_per_power;
max_power := (free_bytes - minsegsperblock
* bytes_per_out_seg) // i;
last_maxpower:= (free_bytes - segs_per_out_block
* bytes_per_out_seg) // i;
if test_shares = 2 then
begin
if maxpower > messbufsforinp then
maxpower:= messbufsforinp;
if last_maxpower > messbufsforinp then
last_maxpower:= messbufsforinp;
end doublebuffering;
time_best_passes:= great;
for test_passes:= first_pass step pass_step
until 20 do
begin
if find_powers then
begin
comment ok;
time:= segs_and_time;
if time < time_best_passes then
time_best_passes:= time
else
goto change_shares;
end find_powers;
end for testpasses;
change_shares:
end for shares;
if mintime >= great then alarm(10, 20);
comment
this situation, that the sort can not be done in 20 passes, after
the checks performed in checkparam, must never occur, and should be
considered a program error;
comment -test-< write(out, <:<10> mintime: :>, <<ddd ddd.dd>,
mintime/1000);
end select_merge_strategy;
\f
procedure select_work_file(situation, infile);
value situation; integer situation;
real array infile;
comment
the procedure creates the workfile needed in the situation:
1. before pass 0, the stringgeneration.
the original inputfile and the final outputdisc is checked.
passes = 0 at calltime signals that the workfile should be
the final outputfile.
if that is impossible passes is set to 1 .
discstores is set to 1 or 2 depending on whether the input-
file and the workfile is placed on the same disc or not.
2. before pass 1, the first merging pass.
the return value of passes specifies the possible numbers
of merging passes:
0: any number is allowed (1, 2, 3, ... )
1: only odd numbers (1, 3, 5, ... )
2: only even numbers (2, 4, 6, ... )
discstores as for situation 1.
;
begin
boolean small_input_disc;
integer best_bsno, best_segments, best_weight, bsno, entries,
free_segs_on_input_disc,
i, input_bsno, max_loss_per_block, output_bsno,
safe_segments, segments, segs_on_input_disc,
slice_length, weight;
integer array ia(1:20), tail(1:10);
integer array field headpart;
long array bestbsname, bsname(1:2);
real array field areaname, discname;
zone z(128, 1, stderror);
\f
boolean procedure claim
(keyno,bsno,bsname,entries,segm,slicelength);
value keyno, bsno;
integer keyno,bsno,entries,segm,slicelength;
long array bsname;
begin
own boolean init;
own integer bsdevices,firstbs;
integer i;
real array ownname(1:2);
long array field name;
integer array core(1:18);
if -,init then
begin
init:=true;
system(5,92,core);
bsdevices:=(core(3)-core(1))//2;
firstbs:=core(1);
system(6,i,ownname);
end;
if bsno<0 or bsno>=bsdevices
or keyno<>0 and keyno<>2 and keyno<>3 then
begin
claim:=false;
goto exitclaim
end;
claim:=true;
begin integer array nametable(1:bsdevices);
name:=18;
system(5,firstbs,nametable);
system(5,nametable(bsno+1)-36,core);
if core(10) = 0 then goto exitclaim;
bsname(1):=core.name(1); bsname(2):=core.name(2);
slicelength:=core(15);
comment lookbs(ownname,bsname,core);
entries:=2;
segm:=c2size*2;
end;
if false then
begin
exitclaim:
entries:=segm:=slicelength:=0;
bsname(1):=bsname(2):=0;
end;
end claim;
\f
comment lookup the input file;
areaname:= discname:= 2;
getzone6(z, ia);
for i:= 1 step 1 until 2 do ia.areaname(i):= infile(i);
setzone6(z, ia);
i:= monitor(42, z, 0, tail); <* lookup entry *>
if i <> 0 then alarm(4, i);
if situation = 1 then
begin
segsin:= tail(1);
if segsin < 0 then alarm(8, segsin); <* no area *>
content:= tail(9) shift(-12);
if content <> 20 <* bs system *> and content <> 21 <*sq system*> then content:= 0;
if content = 21 then
begin
open(z, 4, infile, 0);
invar(z);
headpart:= 0;
headpart:= z.headpart(3);
param(1):= z.headpart(10) extract 12;
headpart:= z.headpart(1);
i:= z.headpart(3);
if i < noofrecs then alarm(16, noofrecs);
if noofrecs <= 0 then
noofrecs:= i;
end;
safe_segments:= 2 * segsin; <* the safe workfile size *>
end situation 1
else
<* situation = 2 *>
begin
comment calculate the safe size of the workfiles;
i:= bytesperoutblock // 2;
max_loss_per_block:=
if fixedlength then bytesperoutblock mod maxlength
else
((if maxlength > i then i else maxlength) - 2);
safe_segments:=
round (segsin / (bytesperoutblock - max_loss_per_block)
* bytesperoutblock)
+ 1 + segsperoutblock;
end situation = 2;
\f
comment
comment now find the best disc for the workfile.
the selection is based upon the following priorities:
1: the final outputdisc if necessary or wanted.
2: a disc with safe_segments free segments.
3: the disc with most free segments.
4: the disc with the greatest slicelength.
5: a disc giving discstores = 2.
6: the final outputdisc.
7: the disc with the highest bsno.
;
bsno:= best_weight:= input_bsno:= output_bsno:= -1;
for bsno:= bsno + 1
while claim(0, bsno, bsname, entries, segments, slicelength) do
if slicelength > 0 <* kit mounted *> then
begin
if bsno = 0 then
begin
comment check the number of entries in main catalog;
i:= (if situation = 1 then param(2) else 1) + entries;
if i < 2 then alarm(13, i - 2);
end bsno = 0;
weight:= if slicelength >= 80 then 16 else slicelength//5;
comment check inputdisc and final outputdisc;
if real bsname(1) = tail.discname(1) and
real bsname(2) = tail.discname(2) then
begin
comment this is the disc of the input file;
input_bsno:= bsno;
segs_on_input_disc:=
(tail(1) + slicelength - 1)//slicelength*slicelength + segments;
small_input_disc:=
segs_on_input_disc//2//slicelength*slicelength < safe_segments;
free_segs_on_input_disc:= segments;
segments:=
(segs_on_input_disc - segsin)//slicelength*slicelength;
<* segments = max unused segments on input disc *>
end inputdisc
else
weight:= weight + 2;
comment include segments in the weight;
weight:= (if segments >= safe_segments then 8000000
else
segments * 20) + weight;
\f
if real bsname(1) = names(5) and
real bsname(2) = names(6) then
begin
comment this is the disc of the final outputfile;
output_bsno:= bsno;
weight:= weight + 1; <* after all the file shall end there *>
if situation = 1 then
begin
comment check that there is room;
if input_bsno <> output_bsno or
param(2) = 0 <* the inputfile is not removed *> then
begin
comment there must be room now;
if segments < segsin then alarm(14, segsin);
if passes = 0 <* sort without merge wanted *> then
weight:= 8100000;
end room must be there now
else
<* input_bsno = output_bsno and param(2) <> 0 *>
begin
if passes = 0 and segments >= safe_segments <* safe *> then
weight:= 8100000 <* sort without merge possible *>
else
passes:= 1;
end perhaps room on outputdisc;
end situation = 1
else
<* situation = 2 *>
if input_bsno <> output_bsno <* it must be selected *> then
weight:= 8100000;
end disc for final output;
if best_weight <= weight then
begin
best_weight:= weight;
best_bsno := bsno;
best_segments:= segments;
for i:= 1 step 1 until 2 do best_bsname(i):= bsname(i);
end better or equal;
end for bsno;
\f
comment now the best disc has been selected;
comment -test-< write(out, <:<10>test 1, inpbs, outbs, bestbs, bestw, :>,
<:bests, safe, soninp, sin::>, input_bsno, output_bsno, best_bsno, best_weight,
bestsegments, safe_segments, segs_on_input_disc, segsin);
if output_bsno = -1 then
begin
comment check that special outputdisc is not wanted;
if names(5) <> real<::> then alarm(14, -1); <* does not exist *>
end;
if best_segments < segsin then alarm(13, segsin);
discstores:= if input_bsno = best_bsno then 1 else 2;
if situation = 1 then
begin
best_segments:= segsin; <* a reasonable filesize *>
end
else
<* situation = 2 *>
begin
if discstores = 1 then
begin
passes:= 0; <* any number of merging passes *>
best_segments:= free_segs_on_input_disc; <* the free segments *>
if small_input_disc or best_segments < safe_segments then
begin
comment cut down the input file to a more safe size;
tail(1):= best_segments:=
if small_input_disc then segsin else safe_segments;
i:= monitor(44, z, 0, tail);
if i <> 0 then alarm(5, i);
end little room or biased distribution;
end discstores = 1
else
<* discstores = 2 *>
begin
passes:=
if output_bsno = -1 then
<* passes is used to select the safest disc for final out *>
(if segs_on_input_disc >= safe_segments and
best_segments >= safe_segments then 0
else
if segs_on_inputdisc < bestsegments then 1 else 2)
else
<* special outputdisc *>
if best_bsno = output_bsno then 1 else 2;
end discstores = 2;
end situation = 2;
\f
comment now, at last, create the workfile;
tail(1):= if best_segments > safe_segments then safe_segments
else best_segments;
for i:= 1 step 1 until 2 do
begin
ia.areaname(i):= real<::>;
tail.discname(i):= real best_bsname(i);
end;
tail.discname(1):=names(5);tail.discname(2):=names(6);
setzone6(z, ia);
i:= monitor(40, z, 0, tail); <* create entry *>
if i <> 0 then alarm(3, i);
getzone6(z, ia);
for i:= 1 step 1 until 2 do
sortfiles(2 * situation - 2 + i):= ia.areaname(i);
end select_work_file;
\f
comment
the sortfiles are initialized with empty names, because they are
removed in case of alarms, see procedure alarm;
for segsin:= 1 step 1 until 4 do sortfiles(segsin):= real<::>;
comment
normalize the names in paramenter names;
for i:= 1 step 2 until 5 do
if names(i) extract 8 = 0 then names(i+1):= real <::>;
selectworkfile(1, names); <*set content, param(1), and noofrecs*>
comment check the parameters;
segsperinblock:= param(1);
if segsperinblock < 1 or segsperinblock > 40 then alarm(1, 1);
comment clear input;
if param(2) <> 0 and param(2) <> 1 then alarm(1, 2);
segsperoutblock:= if param(3) = 0 then segsperinblock else param(3);
if segsperoutblock < 1 or segsperoutblock > 40 then alarm(1, 3);
bytes_perinblock := segsperinblock * 512;
bytes_peroutblock:= segsperoutblock * 512;
i:= param(4);
fixedlength:= i = 1;
if i < 0 or i > 3 then alarm(1, 4);
maxlength:= param(5);
if maxlength < 2 or
maxlength > bytes_perinblock or
maxlength > bytes_peroutblock or maxlength mod 2 <> 0 then
alarm(1, 5);
min_segs_per_block:= (maxlength + 510)//512;
maxlength_plus_four:= maxlength + 4;
comment these two values are often used in the planning;
noofkeys:= param(6);
if noofkeys < 1 or noofkeys > maxlength or noofkeys > 169 then
alarm(1, 6);
begin
comment block for check of keydescr, coresize and messagebuffers;
integer i, abstype, neededcorebytes, position;
real array rarr(1:2);
comment
check the contents of integer array keydescr;
maxkeyposition:= 0;
for i:= 1*2+1 step 2 until noofkeys*2+1 do
begin
abstype:= abs keydescr(i);
if abstype = 5 <* absbyte *> then abstype:= 1;
position:= keydescr(i+1);
if position < abstype or
position > maxlength or
position mod 2 <> 0 and abstype <> 1 or
abstype < 1 or abstype > 4 then alarm(2, i//2);
if position > maxkeyposition then
maxkeyposition:= (position + 1)//2*2;
end checkkeydescr;
if fixedlength then maxkeyposition:= 2;
comment see declaration of array shortrec in block for pass 0;
\f
comment
check the available amount of core;
system(2, freebytes, rarr);
neededcorebytes:= 6650 <* 350 bytes below the 7000 bytes *>
+ bytesperinblock + bytesperoutblock
+ 4*maxlength + 24*noofkeys;
i:= free_bytes - needed_core_bytes;
if i < 0 then alarm(12, i);
comment
subtract from the value of freebytes:
1: room for about 10 program segments + up to 12 segments extra.
2: room for 3 zone-descriptors, and 5 share-descriptors.
3: room for local variables.
4: room for keycode and 1 record in sort-zone;
freebytes:= freebytes
+ (-6650 + 510 + 2*106)
- maxlength
- 24*noofkeys
- ( if i > 3*12*512 then 12*512 else i//3);
comment
as i >= 0 freebytes will now satisfy the relation:
freebytes >= 510 + 2*106 + 3*maxlength
+ 512*(segsperinblock+segsperoutblock).
this is a very important fact since the remaining algorithm of
the program will ensure that the sorting can be done if
freebytes is not less than any of the following two expressions:
1. string generation:
512*(segs_per_in_block + min_segs_per_block)
+ 2*(maxlength + 4) + max_keyposition.
2. merging passes:
512*3*min_segs_per_block + 2*(maxlength + 106).
where min_segs_per_block = (maxlength + 510)//512.
find out the number of free message buffers from the job process;
i:= system(6, 0, rarr);
system(5, i+26, rarr);
messbufsforinp:= rarr(1) shift (-36) extract 12 - 2;
comment
the buffer claim is byte 26 of the job process description.
the output zone requires up to 2 message buffers during a block change,
one of these can also be utilized for write(out,...;
end local block;
\f
comment
now the parameters and the available core storage have been checked,
and various global variables have been initialized;
comment -test-< write(out, <:<10>test 2, freebytes, messbufsforinp: :>,
freebytes, messbufsforinp);
comment test of procedure strategy, mintime is printed at the end of
procedure strategy *test str.*
write(out, <:<10>test 10 <10>:>) *test str.*
for freebytes:= 80000, 40000, 20000,
7000 + 512*(segsperinblock + segsperoutblock) + 4*maxlength - 300,
freebytes - 12*512 - maxlength - 400 do
begin
for segsin:= 8, 30, 125, 500, 2000, 8000 do
begin
for discstores:= 1, 2 do
begin
for outbytes:= 0 step 1 until discstores*2 - 2 do
begin
write(out, <:<10>freebytes, segsin, discstores, passes: :>,
<< dddd>, freebytes, segsin, discstores, outbytes) *test str.*
noofrecs:= segsin * 512.0 / maxlength *test str.*
for strings1:= 1, 10, 100, 1000 do
begin
passes:= outbytes *test str.*
select_merge_strategy *test str.*
write(out, <: shares, strings1: :>, << dddd>,
shares, strings1, <:<10> segs:>) *test str.*
for pass:= 1 step 1 until passes do
write(out, << ddd>, segsout(pass)) *test str.*
write(out, <:<10> insegs :>) *test str.*
for pass:= 1 step 1 until passes do
write(out, << ddd>, insegs(pass)) *test str.*
write(out, <:<10> m.p. :>) *test str.*
for pass:= 1 step 1 until passes do
write(out, << ddd>, mergepower(pass)) *test str.*
end
end
end
end
end;
\f
comment
find out whether the sort can be done without merging passes.
passes = 0 signals to the procedure select_work_file, that
this is the case.
if passes = 0 upon the return it is possible to do without merge;
passes:= if noofrecs < 0 or
noofrecs >
(freebytes - maxkeyposition
- bytes_per_inblock - bytes_per_outblock)
// maxlength_plus_four
then 1 else 0;
comment -test-< write(out, <:<10>test 3 :>, discstores, passes,
segsin);
shares:= 1;
if passes = 0 then
begin
comment sort without merge;
segsoutzero:= segsperoutblock;
recs:= noofrecs; <* records in sortzone *>
end no merging
else
begin
comment
select a reasonable blocklength and number of shares for the
string generating pass (pass 0).
this is done in a quite intuitive manner, as a flat
optimum is assumed;
segsoutzero:=
(free_bytes - bytes_per_inblock - 3*maxlength_plus_four)//(3*512);
comment
as a start take a third of the available core minus room for
inputblock, 2 records in sortzone and maxkeyposition.
this ensures a minimum stringlength of 2 records which in turn
ensures that the string chaining records (6 bytes each) will
not take up as much room as the data records;
\f
if messbufs_for_inp > 0 then
begin
comment doublebuffering is possible;
i:= segsoutzero // segsperinblock;
if i >= 1+2*3 or ( i >= 1+2*1 and discstores = 2) then
begin
comment choose doublebuffering;
shares:= 2;
segsoutzero:= (segsoutzero - segsperinblock) // shares;
end enough core for doublebuffering;
end enough messagebuffers for doublebuffering;
i:= 4 * segsperinblock;
if segsoutzero > i then segsoutzero:= i;
if segsoutzero < minsegsperblock then
segsoutzero:= minsegsperblock;
comment calculate the number of records in sortzone;
recs:= (freebytes - maxkeyposition
- (segsperinblock + segsoutzero) * 512 * shares)
// maxlength_plus_four;
if noofrecs >= 0 and recs > noofrecs then
recs:= noofrecs;
end select segsoutzero and shares;
comment -test-< write(out, <:<10>test 4, shares, segsoutzero, recs::>,
shares, segsoutzero, recs);
\f
pass:= 0;
begin
comment
block for pass 0, string generation.
the algorithm used here does very much look like the correspon-
ding algorithm in the procedure tapesortadp.
in order to speed up the code a bit, most quantities used in
the inner loops are local;
boolean fixedlength;
integer i, active, dead, reclength, recsin, minlength,
actual_maxlength, out_block_size, trap_situation;
real endfile;
integer field ifld, length, recordnumber;
real field endmark;
real array shortrec(1:(maxkeyposition + 2)//4);
long field lfld;
real array field first_part, out_base;
zone zin(shares*segsperinblock*128, shares, docerror),
zout(shares*segsout_zero*128, shares, errorinoutfile),
zsort((recs+1)*maxlength_plus_four//4+3*(noofkeys+1)+6, 1, docerror),
zcomp(3*noofkeys+6, 1, stderror);
\f
comment initialization of constants;
fixedlength:= param(4) = 1;
length:= 2;
endmark:= if fixedlength then 4 else 8;
endfile:= eof;
recsin:= noofrecs;
reclength:= maxlength;
minlength:= keydescr(1*2+2);
if recsin < 0 and minlength < 8 then minlength:= 8;
comment
the minimum length of a variable length record is the position of the
first keyfield or endoffilemark, if it is used;
i:= 1;
if content = 21 then
opensq(zin, string names(increase(i)), 1 shift 18,
(if fixedlength then maxlength else 0) shift 12
add (if param(4) = 0 then 0 else 1))
else
open(zin, 4, names, 1 shift 18);
i:= 1;
if passes = 0 and content = 21 then
opensq(zout, string sortfiles(increase(i)), 0,
(if fixedlength then maxlength else 0) shift 12 add 2)
else
open(zout, 4, sortfiles, 0);
if param(4) = 0 and content <> 21 then
begin
comment checksum control wanted, set free zone parameter;
integer array ia(1:20);
getzone6(zin, ia);
ia(11):= 1 shift 23;
setzone6(zin, ia);
end invar with checksum;
actual_maxlength:= if fixedlength then maxlength else minlength;
out_block_size:= segs_out_zero * 512;
outrec6(zout, out_block_size);
out_base:=
strings1:= outsegment:= outbytes:= recsout:= recs:=
active:= dead:= 0;
if recsin = 0 then goto endoffile;
\f
comment initialize zsort and zcomp.
an extra keyfield, recordnumber, is included for zsort in
order to retain the ordering of synonyms.
zcomp is used in calls of sortcomp to determine whether
a record can participate in the current string or not.
in this comparison it is needless and impossible to in-
clude the recordnumber;
i:= 2*noofkeys + 4;
begin
integer array local_keydescr(3:i);
local_keydescr(i-1):= 2;
local_keydescr(i ):= recordnumber:= maxlength + 2;
for i:= i-2 step -1 until 3 do local_keydescr(i):= keydescr(i);
startsort6(zcomp, local_keydescr, noofkeys , recordnumber);
i:=
startsort6(zsort, local_keydescr,
noofkeys + (if recordnumber < 2047 then 1 else 0),
recordnumber);
end initialize zsort and zcomp;
for i:= i step -1 until 1 do
begin
comment
initial filling of zsort;
if recsin = 0 then goto endoffile;
if fixedlength then inrec6(zin, reclength)
else
begin
invar(zin);
reclength:= zin.length;
if reclength > actual_maxlength then
begin
actual_max_length:= reclength;
if reclength > maxlength then alarm(9, reclength);
end a greater record
else
if reclength < minlength then alarm(9, reclength);
end variable length;
if recsin > 0 then recsin:= recsin - 1
else
if zin.endmark = endfile then goto endoffile;
recs:= recs + 1;
newsort(zsort); active:= active + 1;
for lfld:= maxkeyposition step -4 until reclength + 2 do
zsort.lfld:= 0;
comment set undefined keyfields to zero;
tofrom(zsort, zin, reclength);
zsort.recordnumber:= recs;
end initial filling of zsort;
comment start the writing of the first string;
\f
trap(trap_pass_0);
nextout:
trap_situation:= 1; <* comparison in zsort *>
outsort(zsort); active:= active - 1;
comment test trap - sqrt(param(8)-2);
fromlifesort:
recsout:= recsout + 1;
if -,fixedlength then reclength:= zsort.length;
if out_base + reclength > out_block_size then
begin
comment change the output block;
if pass = passes then
begin
for ifld:= out_base + 2 step 2 until out_blocksize do
zout.ifld:= 0;
first_part:= 0;
end zero fill in last pass
else
begin
first_part:= out_blocksize - out_base;
tofrom(zout.out_base, zsort, first_part);
end not final output;
outrec6(zout, out_blocksize);
out_base:= reclength - first_part;
tofrom(zout, zsort.firstpart, out_base);
end change output block
else
begin
if reclength < 26 then
begin
comment move with a for statement;
for lfld:= reclength step -4 until 4 do
zout.outbase.lfld:= zsort.lfld;
if lfld = 2 then zout.outbase.length:= zsort.length;
end short rec
else
tofrom(zout.outbase, zsort, reclength);
outbase:= reclength + outbase;
end normal record change;
\f
if recsin = 0 then goto endoffile;
if fixedlength then inrec6(zin, reclength)
else
begin
invar(zin);
reclength:= zin.length;
if reclength > actual_maxlength then
begin
actual_maxlength:= reclength;
if reclength > maxlength then alarm(9, reclength);
end a greater record
else
if reclength < minlength then alarm(9, reclength);
end variable length;
if recsin > 0 then recsin:= recsin - 1
else
if zin.endmark = endfile then goto endoffile;
recs:= recs + 1;
\f
if reclength >= maxkeyposition then
begin
comment there are no keyfields outside the record;
trap_situation:= 2; <* in sortcomp zin *>
comment test trap - sqrt(param(8)-3);
if sortcomp(zcomp, zin, zsort) < 0 then
begin
comment
the record just read cannot participate in the current string,
because it should have preceded the last written;
deadsort(zsort); dead:= dead + 1;
end
else
begin
comment
the record can be included in the current string;
newsort(zsort); active:= active + 1;
end sortcomp;
if reclength < 26 then
begin
comment move with for statement;
for lfld:= reclength step -4 until 4 do zsort.lfld:= zin.lfld;
if lfld = 2 then zsort.length:= zin.length;
end short rec
else
tofrom(zsort, zin, reclength);
zsort.recordnumber:= recs;
if active > 0 then goto nextout;
end no reset of undefined
else
begin
comment
the input record does not contain all keyfields, the undefined
keyfields are set to zero before any comparison;
for lfld:= maxkeyposition step -4 until reclength + 2 do
shortrec.lfld:= 0;
tofrom(shortrec, zin, reclength);
trap_situation:= 3; <* in sortcomp shortrec *>
comment test trap - sqrt(param(8)-4);
if sortcomp(zcomp, shortrec, zsort) < 0 then
begin
comment see the comments above;
deadsort(zsort); dead:= dead + 1;
end
else
begin
newsort(zsort); active:= active + 1;
end;
tofrom(zsort, shortrec, maxkeyposition);
zsort.recordnumber:= recs;
if active > 0 then goto nextout;
end reset undefined;
\f
comment
only dead records are now left in the sortzone.
terminate the current string, activate the dead records, and
continue;
strings1:= strings1 + 1;
endoutstring(zout, out_base, out_block_size);
trap_situation:= 1; <* comparison in zsort *>
lifesort(zsort); active:= dead - 1; dead:= 0;
goto fromlifesort;
trap_pass_0:
if trap_situation = 1 then print_zsort(zsort)
else
begin
<* error in sortcomp *>
print_rec(zsort.recordnumber, zsort);
if trap_situation = 2 then print_rec(recs, zin)
else print_rec(recs, shortrec);
end in sortcomp;
alarm(15, 0);
endoffile:
recsin:= 0;
comment
the remaining active records are written to the current string.
recsin = 0 makes the program return to endoffile without at-
tempting further input;
if active > 0 then goto nextout;
strings1:= strings1 + 1;
if dead > 0 then
begin
comment
terminate the current string, activate the dead records, and
write the last string;
endoutstring(zout, out_base, out_block_size);
lifesort(zsort); active:= dead - 1; dead:= 0;
goto fromlifesort;
end remaining dead;
changerec6(zout, out_base);
if param(2) = 1 then
begin
comment remove the input file;
i:= monitor(48, zin, 0, insegs);
if i <> 0 then alarm(7, i);
end clearinput
else
close(zin, true);
if pass = passes then
endoffilerec(zout);
comment endoffilerec jumps to returnfromdiscsort;
comment find the length of the file generated;
getposition(zout, 0, segsin);
segsin:= (out_base - 1)//512 + 1 + segsin;
setposition(zout, 0, 0); <* forces the last block out *>
if actual_maxlength < max_keyposition then
actual_maxlength:= max_keyposition;
maxlength := actual_maxlength;
maxlength_plus_four:= actual_maxlength + 4;
comment -test-< write(out, <:<10>test 5 , strings1, segsin, recs: :>,
strings1, segsin, recs);
end string generation;
\f
comment
now sorted strings have been output to the file, the name of which is
stored in sortfiles(1:2);
select_work_file(2, sortfiles);
comment
a new workfile has been created. its name is stored in sortfiles
(3:4).
the number of disc stores available for the merge is specified by the
value of the integer discstores, and the value of passes specifies the
the possible numbers of passes;
comment -test-< write(out, <:<10>test 6 , discstores, passes: :>,
discstores, passes);
select_merge_strategy;
comment -test-< write(out, <:<10>test 7 , passes, shares: :>,
passes, shares);
comment -test-< for pass:= 1 step 1 until passes do
write(out, <:<10>test 8, s.in, s.out, m.p.: :>, insegs(pass), segsout(pass),
mergepower(pass));
comment
the value of passes defines the number of remaining passes.
insegs, segsout(1:passes) contains the blocklengths of all passes,
and mergepower(1:passes) contains the mergepowers.
the value of shares specifies the number of shares to be used for
input/output;
\f
pass:= 1;
next_merging_pass:
begin
comment
block for one merging pass;
boolean fixedlength;
integer i, reclength, instring, active, insegment, inbytes,
nextrecsin, in_block_size, out_block_size;
integer field ifld, length, stringno;
integer array recsin, save_in_base(1:mergepower(pass));
long field lfld;
real array field first_part, in_base, out_base;
zone array
z(mergepower(pass), shares*in_segs(pass)*128, shares,
docerror);
zone
zout(shares*segsout(pass)*128, shares, errorinoutfile),
zmerge((mergepower(pass)+1)*maxlength_plus_four//4+3*(noofkeys+1)+6,
1, docerror);
procedure end_of_in_block(z, rec);
zone z; real array rec;
comment
reads the next record from z, taking the first part from the
current block and the second part from the next;
begin
first_part:= in_blocksize - in_base;
tofrom(rec, z.in_base, first_part);
in_base:= inrec6(z, 0);
inrec6(z, in_base);
if reclength = 1 000 000 then reclength:= z.length;
in_base:= reclength - first_part;
tofrom(rec.first_part, z, in_base);
end end_of_in_block;
comment
initialize local constants;
fixedlength:= param(4) = 1;
reclength:= maxlength;
length:= 2;
comment
open all the input/output zones, and initialize the merge zone;
\f
for instring:= 1 step 1 until mergepower(pass) do
begin
i:= if pass extract 1 = 1 then 1 else 3;
open(z(instring), 4, string sortfiles(increase(i)), 1 shift 18);
end open instrings;
i:= if pass extract 1 = 1 then 3 else 1;
if pass = passes and content = 21 then
opensq(zout, string sortfiles(increase(i)), 0,
(if fixedlength then maxlength else 0) shift 12 add 2)
else
open(zout, 4, string sortfiles(increase(i)), 0);
in_block_size := in_segs (pass) * 512;
out_block_size:= (if pass = passes then segs_per_out_block
else segs_out(pass)) * 512;
outrec6(zout, out_block_size);
out_base:= 0;
insegment:= outsegment;
inbytes:= outbytes;
nextrecsin:= recsout;
comment
these variables defines the position and length of the first input
string for the merge, it is identical to the last created output
string;
outsegment:= outbytes:= recsout:= 0;
comment -test-< write(out, <:<10>test 20 , start pass: :>, pass);
if nextrecsin = 0 then goto terminatepass;
comment only relevant for zero records to sort;
comment initialize zmerge, stringno is included as the keyfield
of the lowest priority in order to retain the ordering of
synonyms.
the sorting on the stringnumber is in decreasing order
in passes with odd numbers because the strings here are
read in reverse order;
i:= 2*noofkeys + 4;
begin
integer array local_keydescr(3:i);
local_keydescr(i-1):= if pass extract 1 = 1 then -2 else 2;
local_keydescr(i ):= stringno:= maxlength + 2;
for i:= i-2 step -1 until 3 do local_keydescr(i):= keydescr(i);
startsort6(zmerge, local_keydescr,
noofkeys + (if stringno < 2047 then 1 else 0),
stringno);
end initialize zmerge;
active:= 0;
\f
trap(trap_pass_n);
if false then
begin
trap_pass_n:
if active >= 2 then print_zsort(zmerge);
alarm(15, pass);
end trap;
fillzmerge:
for instring:= 1, instring + 1 while instring <= mergepower(pass)
and insegment >= 0 do
begin
comment
position the zone corresponding to instring in front of the next
string, read the string chaining record, and the first real record.
the first record is inserted in zmerge;
setposition(z(instring), 0, insegment);
in_base:= in_bytes;
i:= inrec6(z(instring), 0);
inrec6(z(instring), i);
comment -test-< write(out, <:<10>test 21 , instring, insegment, :>,
<:inbytes, nextrecsin: :>, instring, insegment, inbytes, nextrecsin);
recsin(instring):= nextrecsin - 1;
comment
recsin holds a counter of records for each instring;
if insegment = 0 and inbytes = 0 then insegment:= -1
else
begin
comment read the string chaining record;
ifld:= 0;
for i:= 1 step 1 until 3 do
begin
if in_base >= in_blocksize then
begin
in_base:= inrec6(z(instring), 0);
inrec6(z(instring), in_base);
in_base:= 2;
end blockchange
else
in_base:= in_base + 2;
nextrecsin:= z(instring).in_base.ifld;
case i of
begin
insegment:= nextrecsin;
inbytes := nextrecsin;
<* nextrecsin is ok *>
end case i;
end for i;
end chain to next instring;
\f
newsort(zmerge); active:= active + 1;
if -,fixedlength then
reclength:=
if in_base < in_block_size then
z(instring).in_base.length else 1 000 000;
if in_base + reclength > in_block_size then
end_of_in_block(z(instring), zmerge)
else
begin
tofrom(zmerge, z(instring).in_base, reclength);
in_base:= reclength + in_base;
end normal record change;
save_in_base(instring):= in_base;
for ifld:= reclength + 2 step 2 until maxkeyposition do
zmerge.ifld:= 0;
comment set undefined keyfields to zero;
zmerge.stringno:= instring;
comment -test-< printkey(recsout, instring, zmerge);
end initial filling of zmerge;
\f
nextout:
outsort(zmerge);
comment test trap - sqrt(param(8)-5);
instring:= zmerge.stringno;
recsout:= recsout + 1;
comment -test-< if recsin(instring) mod param(8) = 0 then
printkey(recsout, instring, zmerge);
if -,fixedlength then reclength:= zmerge.length;
if out_base + reclength > out_block_size then
begin
comment change the output block;
if pass = passes then
begin
for ifld:= out_base + 2 step 2 until out_blocksize do
zout.ifld:= 0;
first_part:= 0;
end zero fill in last pass
else
begin
first_part:= out_blocksize - out_base;
tofrom(zout.out_base, zmerge, first_part);
end intermediate pass;
outrec6(zout, out_blocksize);
out_base:= reclength - first_part;
tofrom(zout, zmerge.first_part, out_base);
end change out block
else
begin
if reclength < 26 then
begin
comment move with for statement;
for lfld:= reclength step -4 until 4 do
zout.out_base.lfld:= zmerge.lfld;
if lfld = 2 then zout.out_base.length:= zmerge.length;
end short rec
else
tofrom(zout.out_base, zmerge, reclength);
out_base:= reclength + out_base;
end normal record change;
\f
if recsin(instring) = 0 then goto endofstring;
recsin(instring):= recsin(instring) - 1;
newsort(zmerge);
in_base:= save_in_base(instring);
if -,fixedlength then
reclength:=
if in_base < in_block_size then
z(instring).in_base.length else 1 000 000;
if in_base + reclength > in_block_size then
end_of_in_block(z(instring), zmerge)
else
begin
tofrom(zmerge, z(instring).in_base, reclength);
in_base:= reclength + in_base;
end normal record change;
save_in_base(instring):= in_base;
for ifld:= reclength + 2 step 2 until max_key_position do
zmerge.ifld:= 0;
comment set undefined keyfields to zero;
zmerge.stringno:= instring;
goto nextout;
endofstring:
active:= active - 1;
if active > 0 then goto nextout;
comment
now all strings have been emptied, and a new round should be
started if there are more strings left;
if insegment >= 0 then
begin
endoutstring(zout, out_base, out_block_size);
goto fillzmerge;
end take a new round;
\f
terminatepass:
changerec6(zout, out_base);
if pass = passes then
begin
comment remove input file;
i:= monitor(48, z(1), 0, recsin);
if i <> 0 then alarm(7, i);
comment end the sort by procedure endoffilerec,
which jumps to the label return_from_discsort;
endoffilerec(zout);
end it was the last pass;
setposition(zout, 0, 0);
comment setposition forces the last block out;
comment -test-< write(out, <:<10>test 9 , pass, segsin, recsout: :>,
pass, segsin, recsout);
pass:= pass + 1;
goto next_merging_pass;
end block for one merging pass;
alarmcall:
system(9, segsin, string sortfiles(1));
comment
the alarm is called here in order to obtain a simple alarm address;
returnfromdiscsort:
;comment -test-< write(out, <:<10>test 10, blocksread: :>, blocksread);
end discsort;
\f
procedure readallparam;
begin
real array field rf;
comment
********************************************************
* *
* This procedure reads all the parameters to incsave. *
* *
********************************************************;
last:=true;
list:=true;total:=false;std:=true;
sys:=true;
rf:=0;
vksegm:=8;psegm:=8;
for i:= readparam(input) while i <> 0 do
begin
if i = -1 then
openout else
if input(1) = long <:segm:> then
begin
i:=readparam(input);
if i = 3 then vksegm:=input.rf(1) else paramerror(6);
end else
if input(1) = long <:since:> then
begin
i:=readparam(input);
if input(1) = long <:last:> then last:=true else
if i = 3 then
begin
last:=false;
date:=readdate;
end
else
paramerror(1);
end else
if input(1) = long <:total:> then
begin
i:=readparam(input);
if input(1) = long <:yes:> then total:=true
else if input(1) = long <:no:> then total:=false
else paramerror(2);
end else
if input(1) = long <:tape:> then
begin
sys:=false;
i:=readparam(tapename);
end else
if input(1) = long <:std:> then
begin
i:=readparam(input);
if input(1) = long <:yes:> then std:= true
else if input(1) = long <:no:> then std:=false
else paramerror(3);
end else
if input(1) = long <:list:> then
begin
i:=readparam(input);
if input(1) = long <:yes:> then list:=true
else if input(1) = long <:no:> then list := false
else paramerror(4);
end;
end;
end;
integer procedure readparam(val);long array val;
begin
own integer q;
integer ik;
if q>=0 then
begin
ik:= system(4,q,val);
ik:= (if ik shift (-12) = 8 then 2 else 0)+
ik shift(-2) extract 2;
if q = 0 then
begin
long array a(1:2);
if system(4,1,a)=6 shift 12 + 10 then ik:=-1;
end;
q:= if ik = 0 then -1 else q+1;
readparam:=ik;
end else readparam:=0;
end readparam;
\f
integer procedure readdate;
begin
real array field rf;
long array ra(1:2);
long d;
integer dd,mo,aa,hh,mm,ss,a,feb;
rf:=0;
d:=0;
a:=68;
hh:=0;mm:=0;ss:=0;
ra(1):=input.rf(1);
if ra(1) > 99 or ra(1) < 79 then paramerror(5);
aa:=ra(1); readparam(ra);
if ra.rf(1) >12 or ra.rf(1) < 1 then paramerror(5);
mo:=ra.rf(1); readparam(ra);
if ra.rf(1) < 1 then paramerror(5);
dd:=ra.rf(1); readparam(ra);
if ra.rf(1) > 23 then paramerror(5);
hh:=ra.rf(1);readparam(ra);
if ra.rf(1) > 59 then paramerror(5);
mm:=ra.rf(1);
feb:= if aa // 4*4=a/4*4 then 29 else 28;
if dd>(case mo of (31,feb,31,30,31,30,31,31,30,31,30,31))
then paramerror(5);
for i := i while a<aa do
begin
d:=d+(if a//4*4=a/4*4 then 366 else 365);
a:=a+1;
end;
d:=d+dd-1;
if aa//4*4=aa/4*4 and mo > 2 then d:=d+1;
if mo > 1 then
d:=d+(case mo-1 of (31,59,90,120,151,181,212,243,273,304,334,365));
d:=d*24*60*60+(hh*60*60+mm*60+ss);
readdate:=(d*320000) shift (-24) extract (24);
end readdate;
\f
procedure paramerror(errornum);
integer errornum;
begin
comment **************************************************
* *
* This procedure is used to write the errormessa-*
* ges.When tis procedure is entered the error *
* is hard and the program is terminated. *
* *
**************************************************;
case errornum of
begin
<*1*> write(out,<:<10>*** wrong since specification :>);
<*2*> write(out,<:<10>*** wrong total specification :>);
<*3*> write(out,<:<10>*** wrong standard specification :>);
<*4*> write(out,<:<10>*** wrong list specificaption :>);
<*5*> write(out,<:<10>*** wrong date specification :>);
<*6*> write(out,<:<10>*** wrong segm specefication:>);
<*7*> write(out,<:<10>*** wrong psegm specification:>);
end;
write(out,<:<10> insave stopped ***** :>);
goto halt;
end;
\f
procedure incrementdump;
begin
comment **************************************************
* *
* Declarations of global variabels. *
* *
**************************************************;
integer hashentries,pagenr,nooflisten,dumpensize,bittsize,
restondumps,dkey,mtrsize,ntape,noofentries,noofsegm,antalsegm,
notapen,mtsize,device,nenintemp,notapsegm,modekind,pfileno,
stofentry,filno,entrystart,blockno,bitpattern,newstofentry,
pblockno,pfno,pbno,takind,totalsegm,entryno,ntshift,tntshift,
dumpsize,outres,pdate,segmno,blocksize,trecordsize,
ptapenr,tapenr,labelno,i,ii,j,k,l,m,ik,jk,kk,today,
noofrecs,result,explanation,noofeninaux,totalsegmno,tq1;
real array sortname(1:6);
long array dcname(1:2),mt1pool(1:2),mtpool(1:2),
tname(1:2),dump1name(1:2),p2catname(1:2),pcatname(1:2),t2name(1:2),
tempname(1:2),tempdoc(1:2),
temp1name(1:2),
entryname(1:2),xlabel(1:25);
real array field raf;
real array field discname;
long array field name,mtname,taname,docname,dname,tadocname,lo;
integer field lbase,ubase,mtdate,mtnr,permkey,talbase,taubase,
mttotal,tasize,size,kind,wordno,key,dbase1,dbase2,tasegmno,
startofbit,catnr,shortclock,contents,ih,mtno,dumpkey,proaddr;
integer array field startofbitt;
long rx;
real wdate,r,whour,lastdate,eof,maxhashsize;
boolean found,tapeshift,endtape,tendtape,identical,
ttest,t1test,missingclock,listmore,sysdump,int,ptapeshift,
harderror,nomess1;
integer array entrybase(1:2),tail(1:10),iarr(1:10),interval(1:8),
param(1:7),keydescr(1:4,1:2),ttail(1:17);
zone entry(128,1,stderror);
zone newcat(128,1,stderror);
zone cat(128,1,stderror);
zone cat1(128,1,stderror);
zone outfil(128,1,stderror);
zone help(1,1,stderror);
zone help1(1,1,stderror);
zone mtrecord(128,1,stderror);
zone mt1record(128,1,stderror);
\f
procedure tapeproc(z,s,b);
zone z;
integer s,b;
begin
comment
***************************************************
* *
* This procedure is a blockprocedure used to test *
* endtape.If endtape is reached the boolean end- *
* tape is set to true. *
* *
***************************************************;
if s shift (-18) extract 1 = 0 then stderror(z,s,b);
endtape:=true;
end;
\f
procedure ptapeproc(z,s,b);
zone z;
integer s, b;
begin
comment
**************************************************
* *
* This procedure is also used to test endtape. *
* It is necsacary to have two becaurse this *
* procedure is working with an ther tape. *
* *
**************************************************;
if s shift (-18) extract 1 = 0 then stderror(z,s,b);
tendtape:=true;
end;
\f
procedure warning(warningno);
integer warningno;
begin
case warningno of
begin
<*1*>
begin
ii:=1;
write(out,<:<10> *** area process can not be created :>,
entry.name,<: not saved.:>);
nooflisten:=nooflisten+2;
if ttest then
begin
write(out,<:<10> size =:>,entry.kind);
write(out,<:<10>result of create= :>,i);
end;
end;
<*2*>
begin
ii:=1;
write(out,<:<10> *** The base of tempcat not ok.:>);
end;
<*3*>
begin
write(out,<:<10>:>);
write(out,<:<10> *** No savelabel on tape.The label is written:>);
nooflisten:=nooflisten+2;
end;
<*4*>
begin
write(out,<:<10> *** Wrong savelabel on :>);
write(out,tapename);
goto halt;
end;
end;
end;
\f
procedure test(testno);
integer testno;
begin
comment **************************************************
* *
* This procedure is used to test the system. It *
* can be removed if the system is funktioning *
* *
**************************************************;
if ttest then
begin
case testno of
begin
write(out,<:<10>*** test 1:>);
write(out,<:<10>*** test 2:>);
write(out,<:<10>*** test 3:>);
write(out,<:<10>*** test 4:>);
write(out,<:<10>*** test 5:>);
write(out,<:<10>*** test 6:>);
end;
end;
end;
\f
procedure error(errorno);
integer errorno;
begin
comment **************************************************
* *
* This procedure is used to write the errormessa-*
* ges.When tis procedure is entered the error *
* is hard and the program is terminated. *
* *
**************************************************;
savenotok:=true;
case errorno of
begin
<*1*>;
<*2*>;
<*3*>;
<*4*>write(out,<:<10>*** Savecat does not exist:>);
<*5*>write(out,<:<10>*** No permanent ressources on :>,resname);
<*6*>write(out,<:<10>*** Temperary mtpool not ok:>);
<*7*> write(out,<:<10>*** Mtpool does not exist.:>);
<*8*> write(out,<:<10>*** Creation of temporary savecat not ok:>);
<*9*> write(out,<:<10>*** Savecat not renamed:>);
<*10*> write(out,<:<10>*** Tempcat does not exist:>);
<*11*> write(out,<:<10>*** Tempcat not ok :>);
<*12*> write(out,<:<10>*** Renaming tempcat impossibel:>);
<*13*> write(out,<:<10>*** creation of tem1cat not ok:>);
<*14*> write(out,<:<10>*** creation of new tempcat not ok :>);
<*15*> write(out,<:<10>*** creation of tem1cat not ok:>);
<*16*>
begin
write(out,<:<10>*** the catalog can not be sorted:>);
write(out,<: result of mdsortproc = :>,result);
write(out,<: explanantion = :>,explanation);
end;
end;
write(out,<:<10> insave stopped ***** :>);
goto halt;
end;
\f
procedure auxscan(idate);
integer idate;
begin
comment
********************************************************
* *
* This procedure search all auxcat through to find *
* those entries which shall be saved. *
* *
********************************************************;
long t2date,idag;
procedure bsareaproc(z,s,b);
zone z;
integer s,b;
begin
if s shift (-23) extract 1 = 0 then stderror(z,s,b);
noofeninaux:=0;
write(out,<:<10>*** intervention from auxcat : :>);
write(out,auxcat);
int:=true;
end;
long array doc2name(1:2),en2name(1:2);
long array field d2name;
integer array iarr(1:20),ihelp(1:1),t2tail(1:10);
long array field tdocname;
integer field endate,hsize;
boolean field slize;
integer catalogs,ik,csize,coraddr;
long array catalog(1:2),auxcat(1:2),auxdoc1(1:2);
zone dumpcat(128,1,stderror),auxentry(128,1,bsareaproc);
slize:=1;
idag := extend 0 add idate;
endate:=18;d2name:=18;
hsize:=16;tdocname:=2;
for i:=1 step 1 until 10 do tail(i):=0;
system(5) move core area:(92,iarr);
catalogs:= (iarr(3)-iarr(1))/2;
begin
long array auxdoc(1:catalogs,1:2);
long array catname(1:catalogs,1:2);
integer array catsize(1:catalogs,1:1);
test(1);
noofentries:=0;noofeninaux:=0;noofsegm:=0;
int:=false;
k:=iarr(1);
for j:=1 step 1 until catalogs do
begin
system(5)move core area:(k,ihelp);
k:=k+2;
system(5,ihelp(1)-2,iarr);
system(5,ihelp(1)-28,catalog);
test(2); open(entry,4, catalog,0);
i:=monitor(76)look up head and tail:( entry,0,iarr);
if ttest then write(out,<:<10> look up head and tail result=:>,i);
close(entry,true);
catname(j,1):=iarr.name(1);
catname(j,2):=iarr.name(2);
catsize(j,1):=iarr.hsize;
auxdoc(j,1):=iarr.docname(1);
auxdoc(j,2):=iarr.docname(2);
if ttest then
begin
write(out,
<:<10> catalog name =:>,iarr.name);
end;
end;
open(dumpcat,4,tname,0);
if monitor(42)lookupentry:(dumpcat,0,tail) <> 0 then
begin
tail(1):=100;
tail(2):=1;tail(3):=0;tail(4):=0;tail(5):=0;
i:=monitor(40)create entry:(dumpcat,0,tail);
if i <> 0 then error(13);
end;
for j:=1 step 1 until catalogs do
begin
test(3);
auxcat(1):=catname(j,1);
auxcat(2):=catname(j,2);
csize:=catsize(j,1);
open(help,0,auxcat,0);
close(help,false);
if monitor(76) lookup head and tail :(help,0,iarr) = 0 then
begin
open(auxentry,4,auxcat,1 shift 23);
noofeninaux:=0;
csize:=csize-1;
if int then goto intven;
for ik := inrec6(auxentry,0)
while ik > 0 and csize >= 0 and -,int do
begin
test(4);
if ttest then
write(out,<:<10> result of inrec6 =:>,ik);
if int then goto intven;
if ik = 2 then
begin
inrec6(auxentry,2);csize:=csize-1;
end else
begin
inrec6(auxentry,34);
if auxentry.key <>-1 and auxentry.key extract 3 >2 then
begin
monitor(72)set catalog base:(zhelp,0,interval);
if auxentry.kind < 0 then
begin
if auxentry.kind <> 1 shift 23 + 4 then goto tsave else
begin
entryname(1):=auxentry.name(1);
entryname(2):=auxentry.name(2);
if entryname(1) = auxentry.docname(1) and
entryname(2) = auxentry.docname(2) then goto tsave;
entrybase(1):=auxentry.lbase;
entrybase(2):=auxentry.ubase;
i:=monitor(72)set catalog base:(zhelp,0,entrybase);
if i <> 0 then goto nottosave;
open(help,0,auxentry.docname,0);
close(help,false);
ii:=monitor(76)lookup head and tail:(help,0,iarr);
if ttest then
begin
write(out,<:<10> result of lookupheadandtail= :>,i);
write(out,<:<10> doc222name= :>,
iarr.docname);
end;
while iarr.kind < 0 and ii = 0 do
begin
if iarr.kind <> 1 shift 23 + 4 then goto tsave;
entrybase(1):=iarr.lbase;
entrybase(2):=iarr.ubase;
monitor(72)set catalog base:(zhelp,0,entrybase);
open(help,0,iarr.docname,0);
close(help,false);
ii:=monitor(76)look up head and tail:(help,0,iarr);
if ttest then write(out,<:name22= :>,
iarr.docname);
end;
if ii <> 0 then goto tsave;
if ii = 0 then
begin
doc2name(1):=iarr.docname(1);
doc2name(2):=iarr.docname(2);
en2name(1):=iarr.name(1);
en2name(2):=iarr.name(2);
if ttest then write(out,<:<10>docname = :>,
auxentry.docname);
if ttest then write(out,<:<10> doc2name= :>,
doc2name);
ii:=lookupaux(en2name,doc2name,t2tail);
if ii <> 0 and ttest
then write(out,<:<10> result of lookupaux= :>,ii);
if ttest then write(out,<:<10>date =:>,t2tail(2));
t2date:= extend 0 add t2tail(2);
if -,(t2date >= idag) then goto nottosave;
end else goto nottosave;
end;
end else
t2date:= extend 0 add auxentry.endate ;
if -,(t2date >= idag) then goto nottosave;
test(5);
antalsegm:=antalsegm+auxentry.size;
tsave:
monitor(72)set catalog base:(zhelp,0,interval);
entrybase(1):=auxentry.lbase;
entrybase(2):=auxentry.ubase;
entryname(1):=auxentry.name(1);
entryname(2):=auxentry.name(2);
if entryname(1) = mtpool(1) and
entryname(2) = mtpool(2) and
entrybase(1) = interval(5) and
entrybase(2) = interval(6) then goto nottosave;
if entryname(1) = dcname(1) and
entryname(2) = dcname(2) and
entrybase(1) = interval(5) and
entrybase(2) = interval(6) then goto nottosave;
if entryname(1) = pcatname(1) and
entryname(2) = pcatname(2) and
entrybase(1) = interval(5) and
entrybase(2) = interval(6) then goto nottosave;
if t1test and entryname(1) = long <:primo:> add 115 then
begin
write(out,<:<10>entry name =:>,
entryname);
write(out,<:<10> date of entry = :>,auxentry.endate);
end;
open(help,0, entryname,0);
close(help,true);
i:=monitor(72)set entry base:(zhelp,0,entrybase);
if i <> 0 then goto nottosave;
if ttest then
begin
write(out,<:<10>entry name:>,
entryname);
write(out,<:<10>set entry base result =:>,i);
end;
i:=monitor(76)lookup head and tail:(help,0,iarr);
if i <> 0 then goto nottosave;
if ttest then
write(out,<:<10> lookup entry result = :>,i);
monitor(72)set catalog base:(zhelp,0,interval);
outrec6(dumpcat,34);
tofrom(dumpcat,auxentry,34);
if iarr.kind >= 0 then
begin
dumpcat.docname(1):=iarr.docname(1);
dumpcat.docname(2):=iarr.docname(2);
end else
begin
dumpcat.docname(1):=auxdoc(j,1);
dumpcat.docname(2):=auxdoc(j,2);
end;
if ttest then
begin
write(out,<:<10>docname=:>,
iarr.docname);
end;
noofeninaux:=noofeninaux+1;
nottosave:
end;
if ttest and ik = 2 then
write(out,<:<10>csize=:>,csize);
end;
end;
if ttest then
begin
write(out,<:<10> catalog with the following name :>);
write(out, auxcat);
write(out,<: is searched through.:>);
end;
intven:
int:=false;
noofentries:=noofentries+noofeninaux;
close(auxentry,true);
end;
end;
end;
monitor(72)set catalog base:(zhelp,0,interval);
monitor(42)look up entry:(dumpcat,0,tail);
c2size:=tail(1);
c2size:=c2size+10;
close(dumpcat,true);
end;
long procedure dumplabel(ii ,typ);
integer ii,typ;
begin
long spaces,stop;
comment
*********************************************************
* *
* returns the i'the real of a savelabel *
* 1: dump *
* 2-3: tapename *
* 4: filno *
* 5: vers. *
* 6: date *
* 7: hour *
* 8: segments *
* 9-10: dumplabelname *
* 11: emtty *
* 12-13: emtty *
* 14: <:nl:> *
* 15: <:em:> *
* The dumplabel is a text which may be read by *
* edit. *
* *
*********************************************************;
long procedure convintg(n);
value n;
integer n;
comment
***********************************************************
* *
* Converts a non negative integer to a text portion *
* with the layout <<zddddd>. *
* *
***********************************************************;
convintg:=if n <10 then long <:00000:> add (n+48)
else convintg (n//10) shift 8 add (n mod 10+48);
\f
long procedure spacefill(text);
value text;
long text;
begin
comment spacefill will replace trailing nulls by spaces;
integer i;
if text = long <::> then text:=spaces
else
begin
i:=-1;
for i:=i+1 while text extract 8 = 0 do text := text shift (-8);
for i:=i-1 while i>-1 do text:= text shift 8 add 32;
end;
spacefill:=text;
end <* spacefill*>;
spaces:= long <: :> add 32;
stop:= long <:<10>:>;
dumplabel:= case ii of (
spacefill(long <:dump:>),
spacefill(tapename(1)),
spacefill(tapename(2)),
spacefill(convintg(filno) shift 24),
spacefill( case typ of ( long <:vers.:>,
long <:empty:>, long <:cont.:>)),
convintg(wdate),
spacefill(long <: .:> add
( convintg(whour) extract 16) shift 24 ),
if typ = 2 then spaces else
spacefill( long <:s=0:> shift (-24) add vksegm shift 24),
spacefill(tapename(1)),
spacefill(tapename(2)),
spacefill(spaces),
spacefill(spaces),
spacefill(spaces),
stop,
long <:<25>:> shift (-8));
end dumplabel;
\f
procedure writelabel(typ);integer typ;
begin
zone zlabel(25,1,eror);
procedure eror(z,s,b);zone z; integer s,b;
if s shift 5 >= 0 then stderror(z,s,b); <*ignore eot*>
if sys then
open(zlabel,modekind, t1tapename,0) else
open(zlabel,modekind,tapename,0);
setposition(zlabel,if typ = 2 then 2 else 1,0);
systime(1,0,r);
wdate:=systime(2,r,r);
whour:=r/10000-0.3;
outrec6(zlabel,100);
if typ = 2 then filno:=2 else filno:=1;
for i:=1 step 1 until 15 do zlabel.lo(i):=dumplabel(i,typ);
for i:=16 step 1 until 25 do zlabel.lo(i):= long <::>;
if typ = 2 then setposition(zlabel,-1,0);
if typ = 3 then
zlabel.lo(25):=long <::> add entryno shift 24 add (segmno-1);
if typ = 3 then
begin
for i:=1 step 1 until 25 do xlabel(i):=zlabel.lo(i);
end;
if list and typ = 1 then
begin
for i:=1 step 1 until 25 do xlabel(i):=zlabel.lo(i);
write(out,<:<12>:>);
write(out,"sp",60,<:page :>,pagenr);
nooflisten:=3;
pagenr:=pagenr+1;
write(out,<:<10>savelabel: :>, xlabel);
end;
close(zlabel,false);
end;
\f
procedure testlabel(update);
boolean update;
begin
integer array ia(1:8);
zone pttape(2*130,2,tapeproc);
long array field lof;
lof:=0;
labelno:=1;
open(pttape, modekind, tapename,0);
setposition(pttape,0,0);
setposition(pttape,labelno,0);
i:=0;
i:=inrec6(pttape,i);
if i <> 100 then
begin
warning(3);
if update then
begin
close(pttape,false);writelabel(1);
goto la;
end;
end
else inrec6(pttape,100);
if pttape.lof(2) <> dumplabel(2,1) or pttape.lof(3) <> dumplabel(3,1) then
begin
tapename(1):=pttape.lof(2);
tapename(2):=pttape.lof(3);
write(out,<:<10>:>);
warning(4);
end;
if update then
begin
setposition(pttape,labelno,0);
systime(1,0,r);
wdate:=systime(2,r,r);
whour:= r/10000 - 0.3;
outrec6(pttape,4*25);
for i:= 1 step 1 until 15 do
pttape.lof(i):= xlabel(i):=dumplabel(i,1);
for i:= 16 step 1 until 25 do pttape.lof(i):= xlabel(i):=long <::>;
if list then
begin
write(out,<:<10>:>);
write(out,<:<12>:>,"sp",60,<:page :>,pagenr);
write(out,<:<10>savelabel: :>, xlabel);
nooflisten:=1;
pagenr:=pagenr+1;
end;
end else
begin
psegm:=pttape(8) shift (-24) extract 8;
psegm:=if psegm = 32 then 1 else psegm-48;
end;
close(pttape,false);
la:
end;
\f
procedure fletcatalog;
begin
integer array ia(1:10);
integer pentryno,pentry;
comment
*******************************************************
* *
* This procedure merged the two catalog tempcat and *
* tem1cat together. *
* *
*******************************************************;
zone dumpcat(128,1,stderror),dump(128,1,stderror),
cat(128,1,stderror);
integer l,antal,catsize;
integer field ih;
long array field lname;
boolean more;
long array field tadocname;
integer array ttail(1:17);
zone help1(1,1,stderror);
procedure indump;
begin
integer kk;
if pentry < pentryno then
begin
kk:=inrec6(dump,0);
if kk = 0 then more:= false else
inrec6(dump,34);
while dump.key = - 1 and more do
begin
kk:=inrec6(dump,0);
if kk = 0 then more := false else
inrec6(dump,34);
end;
pentry:=pentry+1;
if ttest then write(out,<:<10>indump called :>);
end else more:=false;
end;
procedure outdump;
begin
if ttest then
begin
write(out,<:<10>outdump called:>);
write(out,<:<10> navn = :>, dump.name);
end;
notapen:=notapen+1;
outrec6(cat,34);
tofrom(cat,dump,34);
indump;
end;
procedure outcat;
begin
i:=i+1;
if t1test then
begin
write(out,<:<10> antal = :>,i);
write(out,<:<10> navn1= :>, dumpcat.name);
end;
outrec6(cat,34);
tofrom(cat,dumpcat,34);
if i <= noofentries then inrec6(dumpcat,34);
end;
notapen:=0;
lname:=6;more:=true;
monitor(72)set catalog base:(zhelp,0,interval);
open(dumpcat,4, tempname,0);
open(dump,4, pcatname,0);
monitor(42)lookupentry:(dump,0,tail);
pentryno:=tail(10);
pentry:=1;
t2name(1):=0;
t2name(2):=0;
monitor(42)look up entry:(dumpcat,0,tail);
catsize:=tail(1);
k:= monitor(42)look up entry:(dump,0,tail);
if k <> 0 then error(10);
catsize:=catsize+tail(1)+1;
for l:=1 step 1 until 10 do tail(l):= 0;
tail(1):=catsize;
tadocname:=2;
tail(2):=1;
tail(3):=0;tail(4):=0;tail(5):=0;
open(cat,4, p2catname,0);
monitor(48)remove entry:(cat,0,ia);
if monitor(40)create entry:(cat,0,tail) <> 0 then error(14);
i:=monitor(50)permanent entry:(cat,3,tail);
if i <> 0 then
begin
if ttest then write(out,<:<10>tempcat:>);
error(5);
end;
entrybase(1):=interval(5);entrybase(2):=interval(6);
i:=monitor(74)set entry base:(cat,0,entrybase);
if i<> 0 then
begin
if ttest then write(out,<:<10>set entry base tempcat:>);
error(5);
end;
setposition(cat,0,0);
if k <> 0 then goto nopcat;
antal:=0;
l:=0;
setposition(dump,0,0);
inrec6(dumpcat,34);inrec6(dump,34);
i:=1;j:=0;
while i <= noofentries or more do
begin
j:=j+1;
if -, more and i <= noofentries then outcat else
begin
if more then
begin
while dump.key = -1 do
begin
indump;
if -,more then goto la1;
end;
end;
open(help1,0, dump.name,0);
entrybase(1):=dump.lbase;entrybase(2):=dump.ubase;
monitor(72) set catalog base:(zhelp,0,entrybase);
k:= monitor(76)look up head and tail:(help1,0,ttail) ;
monitor(72)set catalog base:(zhelp,0,interval);
if k <> 0 or
dump.lbase <> ttail(2) or dump.ubase <> ttail(3) then
begin
if ttest then write(out,<:<10>name=:>,
dump.name);
end;
close(help1,false);
if i > noofentries then outdump else
begin
if dumpcat.lname(1) < dump.lname(1) then outcat else
begin
if dumpcat.lname(1) = dump.lname(1) then
begin
if dumpcat.lname(2) < dump.lname(2) then outcat else
begin
if dumpcat.lname(2) = dump.lname(2) then
begin
if dumpcat.ubase < dump.ubase then outcat else
begin
if dumpcat.ubase = dump.ubase then
begin
if dumpcat.lbase < dump.lbase then outcat else
begin
if dumpcat.lbase = dump.lbase then
begin
outcat;indump;
end else outdump;
end;
end else outdump;
end;
end else outdump;
end;
end else outdump;
end;
end;
end;
la1:
end;
while more and i>= noofentries do
outdump;
noofentries:=noofentries+notapen;
if t1test then write(out,<:<10> no of entries = :>,noofentries);
for i:= 1 step 1 until 15 do
begin
outrec6(cat,34);
for ih:=2 step 2 until 34 do cat.ih:=-1;
end;
tadocname:=0;
setposition(cat,0,0);
close(cat,true);
close(dump,true);
i:=monitor(40)look_up_entry:(cat,0,tail);
tail(1):=(noofentries+1)//15 +1;
i:=monitor(44)change_entry:(cat,0,tail);
if i <> 0 then error(11);
nopcat:
close(dumpcat,true);close(dump,true);
end;
\f
procedure mount_med_ring(ring);
boolean ring;
begin
integer array ia(1:12),m(1:8);
zone z(128,1,stderror);
for i:=1 step 1 until 8 do m(i):=0;
m(5):=tapename(1) shift (-24) extract 24;
m(6):=tapename(1) extract 24;
m(7):=tapename(2) shift (-24) extract 24;
m(8):=tapename(2) extract 24;
open(z,0, tapename,0);
if monitor(4)process desc:( z,0,ia) = 0 then
begin
m(1):=16 <*opmess*> shift 12;
m(2):= long <:rin:> shift (-24) extract 24;
m(3):= long <:g:> shift (-24) extract 24;
m(4):= 32 shift 16;
system(10)parrant message:(0,m);
end;
sense:
monitor (6)initialize process:( z,0,ia);
getshare6(z,ia,1);
ia(4):=0;
setshare6(z,ia,1);
monitor (16)send message:( z,1,ia);
if monitor(18)wait answer:(z,1,ia) <> 1 <*not normal*> then
begin
comment not mounted;
ia(1):= (if device = 0 then 14 shift 12 else
32 shift 12 +1 shift 9) + 1 shift 0;
ia(2):= long <:mou:> shift (-24) extract 24;
ia(3):= long <:nt:> shift(-24) extract 24;
ia(4):= device;
for i:= 5 step 1 until 8 do ia(i):=m(i);
system(10,0,ia);
goto sense;
end
else
if ring then
begin
if ia(1) shift (-15) extract 1 = 0 then
begin
close(z,false);
open(z,4 shift 12 + 18, tapename,0);
ia(1):= 18<*ring*> shift 12 + 1 shift 0;
ia(2):= long <:rin:> shift (-24) extract 24;
ia(3):= long <:g:> shift (-24) extract 24;
ia(4):=0;
for i:=5 step 1 until 8 do ia(i):=m(i);
system(10,0,ia);
goto sense;
end;
end;
close(z,false);
end mount med ring;
\f
procedure inittempcat(rname);
long array rname;
begin
comment
**********************************************************
* *
* This procedure is used to initialise tempcat and tem1- *
* cat. *
* *
**********************************************************;
integer field a;
open(cat,4, rname,0);
i:=monitor(42)look up entry:(cat,0,iarr);
if i <> 0 then
begin
iarr(1):=10;
iarr(2):=1;iarr(3):=0;iarr(4):=0;iarr(5):=0;
monitor(40)create entry:(cat,0,iarr);
end;
for i:= 1 step 1 until iarr(1) do
begin
setposition(cat,0,i);
outrec6(cat,512);
for ik := 1 step 1 until 256 do
begin
a:=ik*2;
cat.a:=-1;
end;
end;
close(cat,true);
end;
\f
procedure initnewcat;
begin
comment
*************************************************************
* *
* This procedure initialise the new dumpcat so that every *
* word of it contains -1. This is only done if an reorgani- *
* sation of dumpcat is nessacary. *
* *
*************************************************************;
integer field a;
for i:= 0 step 1 until hashentries-1 do
begin
setposition(newcat,0,i);
outrec6(newcat,512);
for ik:=1 step 1 until 256 do
begin
a:=ik*2;
newcat.a:=-1;
end;
a:=2;newcat.a:=0;
end;
end;
\f
procedure reorg;
begin
\f
procedure computenewhash;
begin
integer array primtal(1:19);
integer primi;
primtal(1):=101;
primtal(2):=167;
primtal(3):=217;
primtal(4):=373;
primtal(5):=557;
primtal(6):=787;
primtal(7):=1103;
primtal(8):=1657;
primtal(9):=2459;
primtal(10):=3671;
primtal(11):=5449;
primtal(12):=8039;
primtal(13):=12073;
primtal(14):=18013;
primtal(15):=27091;
primtal(16):=40111;
primtal(17):=60811;
primtal(18):=90203;
primi:=1;
while hashentries > primtal(primi) do primi:=primi+1;
hashentries:=primtal(primi+1);
end;
integer array duname(1:10);
integer field a;
integer array field point;
long array cname(1:2);
integer oldhashentries;
monitor(72)set catalogbase:(zhelp,0,interval);
point:=0;
write(out,<:<10> --- the dumpcat is reorganised:>);
oldhashentries:=hashentries;
computenewhash;
for i:=1 step 1 until 10 do tail(i):=0;
tail(1):=hashentries;
tail(2):=1;
tail(10):=dumpensize;tail(9):=11 shift 12;
cname(1):=long <::>;cname(2):=long <::>;
open(newcat,4, cname,0);
if monitor(40)create entry:(newcat,0,tail) <> 0 then error(8);
monitor(74)setentry base:(newcat,0,interval);
open(cat,4, dump1name,0);
initnewcat;
for i:=0 step 1 until oldhashentries-1 do
begin
setposition(cat,0,i);
swoprec6(cat,2);
rhashentry;
while cat.catnr=-1 do rhashentry;
dkey:=hashkey(cat.dname);
setposition(newcat,0,dkey);
swoprec6(newcat,2);
if newcat.catnr = -1 then newcat.catnr:=0;
newcat.catnr:=newcat.catnr+1;
swoprec6(newcat,dumpensize);
k:=1;
while newcat.catnr <> -1 do swoprec6(newcat,dumpensize);
tofrom(newcat,cat,dumpensize);
newcat.catnr:=dkey;
end;
for i:=1 step 1 until 10 do duname(i):=0;
for i:=1 step 1 until 4 do duname(i):=dump1name.point(i);
close(cat,true);
monitor(48)remove entry:(cat,0,tail);
close(newcat,true);
if monitor(46)rename_entry:( newcat,0,duname) <> 0 then error(9);
end;
\f
procedure hashtsize;
begin
comment
********************************************************
* *
* This procedure finds out how many entries there are *
* in the hash table and if there is more than maxhash- *
* size it is reorganised *
* *
********************************************************;
integer field c;
integer nr_of_en;
c:=2;
nr_of_en:=0;
open(cat,4, dump1name,0);
for i:=0 step 1 until hashentries-1 do
begin
setposition(cat,0,i);
inrec6(cat,1);
nr_of_en:=nr_of_en+cat.c;
end;
close(cat,true);
if ttest then write(out,<:<10>*** size of hashtable= :>,nr_of_en);
if nr_of_en / (hashentries * 28) > maxhashsize then reorg;
end;
\f
procedure rhashentry;
begin
k:=swoprec6(cat,0);
if k = 0 then
begin
setposition(cat,0,0);
swoprec6(cat,2);
end;
if k = 512 then swoprec6(cat,2);
if k = restondumps then
begin
swoprec6(cat,k);
k:=swoprec6(cat,0);
if k = 0 then
setposition(cat,0,0);
swoprec6(cat,2);
swoprec6(cat,dumpensize);
end
else
swoprec6(cat,dumpensize);
end;
\f
procedure dumpcatupdate(nrfiles,nr,stentry);
integer nrfiles,nr,stentry;
begin
integer bitno;
comment
*******************************************************
* *
* This procedure will for the entries in the catalog *
* to the tape copied that day update in dumpcat. *
* nrfiles: specifies how many entries that is to be *
* updated. *
* nr : specifies the tapenr *
* ststentry: specifies where the entries start in the *
* catalog. *
* *
*******************************************************;
\f
procedure removedumpbit;
begin
integer i1,i2;
comment
******************************************************
* *
* This procedure removes the bit beloning to nr in *
* the whole dumpcat. *
* *
******************************************************;
boolean procedure bitsat(bitnummer);integer bitnummer;
begin
bitsat:= if cat.wordno shift(-bitnummer) extract 1 = 1 then
true else false;
end;
integer noonsegm,nremoved,word1;
integer field place;
boolean empty;
if ttest then write(out,<:<10>bit=:>,bitno,
<:<10>bitmoenster =:>,bitpattern);
empty:=true;
nremoved:=0;
open(cat,4, dump1name,0);
for i:= 0 step 1 until hashentries-1 do
begin
setposition(cat,0,i);
swoprec6(cat,2);
noonsegm:=cat.catnr;
if ttest then write(out,<:<10>antal=:>,noonsegm);
while noonsegm > 0 do
begin
rhashentry;
while cat.catnr = -1 do rhashentry;
empty:=true;
if ttest then write(out,<:<10> antal1 = :>,noonsegm);
word1:=cat.wordno;
if bitsat(bitno) then
cat.wordno:=exor(cat.wordno,bitpattern);
if ttest and word1 <> cat.wordno
then write(out,<:word2 = :>,cat.wordno);
for j:=1 step 1 until bittsize do
empty:= empty and (cat.startofbitt(j) = 0);
if empty then
begin
for ik:= 1 step 1 until dumpensize/2 do
begin
place:=ik*2;
cat.place:=-1;
end;
nremoved:=nremoved+1;
end;
noonsegm:=noonsegm-1;
end;
if nremoved > 0 then
begin
setposition(cat,0,i);
swoprec6(cat,2);
cat.catnr:=cat.catnr-nremoved;
nremoved:=0;
end;
end;
close(cat,true);
end;
\f
zone catentry(128,1,stderror);
comment cat is a zone to dumpcat and catentry is a zone to catalog;
integer dkey,noonsegm;
boolean identical,found;
if ttest then write(out,<:<10>bandnr=:>,nr);
bitno:=(nr-1) mod 24;
bitpattern:=1shift(bitno );
wordno:=((nr-1)//24) +startofbit;
if nrfiles <> 1 then removedumpbit;
hashtsize;
open(cat,4, dump1name,0);
open(catentry,4, p2catname,0);
setposition(cat,0,0);
setposition(catentry,0,0);
if ttest then
begin
write(out,<:<10> stentry= :>,stentry,<: nrfiles = :>,nrfiles);
end;
for i:=1 step 1 until stentry do
begin
k:=inrec6(catentry,0);
if k = 2 then inrec6(catentry,2);
inrec6(catentry,34);
if catentry.key = -1 then
begin
k:=inrec6(catentry,0);
if k = 2 then inrec6(catentry,0);
inrec6(catentry,34);
end;
end;
i:=inrec6(catentry,0);
if i = 2 then inrec6(catentry,2);
for i:=1 step 1 until nrfiles do
begin
identical:=found:=false;
inrec6(catentry,34);
while catentry.key = -1 do
begin
k:=inrec6(catentry,0);
if k = 2 then
begin
inrec6(catentry,k);
k:=inrec6(catentry,0);
end;
if k = 0 then goto stop;
inrec6(catentry,34);
end;
dkey:=hashkey(catentry.name);
if ttest then
begin
write(out,<:<10> hash key = :>,dkey);
write(out,<: for the entry with name =:>);
write(out, catentry.name);
end;
setposition(cat,0,dkey);
swoprec6(cat,2);
noonsegm:=cat.catnr;
while noonsegm > 0 do
begin
rhashentry;
while cat.catnr = -1 do rhashentry;
identical:=cat.dname(1)=catentry.name(1) and
cat.dname(2)=catentry.name(2) and
cat.dbase1=catentry.lbase and
cat.dbase2=catentry.ubase and
cat.dumpkey extract 3 = catentry.key extract 3;
if identical then
begin
found:=true;
cat.wordno:=logor(cat.wordno,bitpattern);
noonsegm:=0;
end
else
noonsegm:=noonsegm-1;
end;
if -, found then
begin
setposition(cat,0,dkey);
swoprec6(cat,2);
cat.catnr:=cat.catnr+1;
rhashentry;
while cat.key <> -1 do rhashentry;
cat.key:=dkey;
cat.dname(1):=catentry.name(1);
cat.dname(2):=catentry.name(2);
cat.dbase1:=catentry.lbase;
cat.dbase2:=catentry.ubase;
cat.dumpkey:=catentry.key extract 3;
if catentry.kind >= 0 then cat.dumpkey:=cat.dumpkey + 16;
for j:= 1 step 1 until bittsize do cat.startofbitt(j):=0;
cat.wordno:=bitpattern;
end;
end;
stop:
close(catentry,true);
close(cat,true);
i:=monitor(40)lookupentry:(cat,0,tail);
tail(1):=hashentries;
monitor(44)changeentry:(cat,0,tail);
end;
\f
procedure gettapename(taptotal);
integer taptotal;
begin
comment
*******************************************************
* *
* This procedure will search the mtpool through. It *
* will find the oldest tape which is used to total or *
* not depending on the variabel taptotal. *
* *
*******************************************************;
integer field antal;
long d;
integer tapnr,thisday,a;
long lastdate,t1date;
integer day,mounth,year;
systime(1,0,r);
wdate:=systime(2,r,r);
day:=wdate;
day:=day//10000;
mounth:=wdate;
mounth:=mounth//100 - day*100;
year:=wdate;
year:=year-day*10000-mounth*100;
d:=0;a:=68;
for i:=i while a < year do
begin
d:=d+(if a//4*4=a/4*4 then 366 else 365);
a:=a+1;
end;
d:=d+day-1;
if mounth > 1 then
d:=d+(case mounth-1
of (31,59,90,120,151,181,212,243,273,304,334,365));
d:=d*24*60*60;
a:=0;
thisday:=systime(7,a,0.0);
lastdate:=99388604;
antal:=2;
open(mtrecord,4, mt1pool,0);
i:=monitor(42)look up entry:(mtrecord,0,tail);
if i<> 0 then error(7);
inrec6(mtrecord,2);
ntape:=mtrecord.antal;
for i:= 1 step 1 until ntape do
begin
inrec6(mtrecord,mtrsize);
t1date:= extend 0 add mtrecord.mtdate;
if ttest then write(out,<:<10>mtnr = :>,mtrecord.mtnr);
if taptotal = mtrecord.mttotal extract 4 and
lastdate > t1date then
begin
lastdate:=t1date;
tapnr:=mtrecord.mtnr;
end;
end;
setposition(mtrecord,0,0);
today:=thisday;
swoprec6(mtrecord,2);
for i:=1 step 1 until tapnr do
begin
if ttest then write(out,<:<10>i = :>,i);
swoprec6(mtrecord,mtrsize);
end;
t1tapename(1):=mtrecord.mtname(1);
t1tapename(2):=mtrecord.mtname(2);
tapenr:=mtrecord.mtnr;
mtrecord.mtdate:=thisday;
if total then mtrecord.mttotal:=1+1 shift 10 else
mtrecord.mttotal:=0+1 shift 10;
if ntshift > 0 then
begin
if mtrecord.mttotal shift (-10) extract 1 = 1 then
mtrecord.mttotal:= mtrecord.mttotal-1 shift 10;
end
swoprec6(mtrecord,mtrsize);
close(mtrecord,true);
if ttest then
begin
for k:= 1 step 1 until 100 do
begin
write(out,<:<10>tape to use = :>, t1tapename);
end;
end;
end;
\f
long procedure dateofpdump;
begin
comment
*****************************************************
* *
* This procedure finds the date of the privios dump *
* in the mtpool. *
* *
*****************************************************;
zone mtrecord(128,1,stderror);
integer field antal;
long tdate;
long gdate;
antal:=2;
gdate:=0;
open(mtrecord,4, mtpool,0);
if monitor(42)look up entry:(mtrecord,0,tail) <> 0 then error(7);
setposition(mtrecord,0,0);
inrec6(mtrecord,2);
ntape:=mtrecord.antal;
for i:=1 step 1 until ntape do
begin
inrec6(mtrecord,mtrsize);
tdate:= extend 0 add mtrecord.mtdate;
comment if mtrecord.mttotal >= 16 then gdate:=mtrecord.mtdate;
if tdate > gdate
and mtrecord.mttotal shift (-10) extract 1 = 1
then
gdate:=tdate;
end;
close(mtrecord,true);
dateofpdump:=gdate;
end;
\f
procedure gettape(getdate,number);integer getdate, number;
begin
comment
********************************************************
* *
* This procedure delivers the tapename and tapenr equal*
* to getdate and number, which it finds in mtpool. *
* *
********************************************************;
zone mtrecord(128,1,stderror);
boolean found;
found:=false;
if ttest then
begin
write(out,<:<10>pdate = :>,getdate,<:number = :>,number);
end;
open(mtrecord,4, mt1pool,0);
if monitor(42)look up entry :(mtrecord,0,tail) <> 0 then error(7);
setposition(mtrecord,0,0);
swoprec6(mtrecord,2);
if ttest then write(out,<:<10>getdate = :>,
getdate,<:<10>number = :>,
number);
while -, found do
begin
swoprec6(mtrecord,mtrsize);
if ttest then write(out,<:<10> date = :>,mtrecord.mtdate,
<:<10> mtno =:>,mtrecord.mtno,
<:<10>mttotal = :>,mtrecord.mttotal);
if mtrecord.mtdate = getdate
and mtrecord.mttotal shift (-10) extract 1 = 1 then
begin
found:=true;
if mtrecord.mttotal extract 4 = 1 then
begin
nomess1:=false;
ptapename(1):= long <::>;
ptapename(2):= long <::>;
end else
begin
ptapename(1):=mtrecord.mtname(1);
ptapename(2):=mtrecord.mtname(2);
ptapenr:=mtrecord.mtnr;
end;
end;
end;
close(mtrecord,true);
end;
\f
integer procedure hashkey(hname);long array hname;
begin
comment
******************************************************
* *
* This procedure computes the hashkey used to insert *
* the entry in the dumpcat. *
* *
******************************************************;
long sum,part_1_of_name,part_2_of_name;
part_1_of_name:= hname(1);
part_2_of_name:= hname(2);
sum:=part_1_of_name+part_2_of_name;
sum:=sum shift (-24)+sum extract (24);
sum:=(sum extract 24 + (sum shift (-12) shift 36) ) shift (-36);
sum:=sum extract 24;
hashkey:= sum mod hashentries;
end;
\f
procedure tapedump;
begin
zone tape(vksegm*2*130,2,tapeproc);
zone ptape(2*(psegm*130),2,ptapeproc);
\f
procedure changevol(nr);
integer nr;
begin
comment ******************************************************
* *
* This procedure will find a new tape and this is to *
* be mounted. *
* case nr of *
* 1: the tape is used to usual dump *
* 2: the tape is a privius dumptape *
* 3: the tape is a dumttape but somthing is dumped *
* on the privius tape and this has to be removed *
* from that tape. *
* *
******************************************************;
integer k1;
if ttest then
begin
write(out,<:<10> number of entries saved= :>,entryno);
write(out,<:<10> end tape is reached :>);
end;
monitor(72)set catalog base:(zhelp ,0,interval);
if -,sys then
begin
write(out,<:<10>***end tape is reached. :>);
goto stop;
end else
begin
case nr of
begin
begin
ntshift:=ntshift+1;
newstofentry:=entryno;
dumpcatupdate(entryno-stofentry,tapenr,stofentry);
stofentry:=newstofentry+1;
tapename(1):=t1tapename(1);
tapename(2):=t1tapename(2);
if total then gettapename(1) else gettapename(0);
outrec6(tape,blocksize);
changerec6(tape,100);
tape.lo(1):=rx:=long <::> add 4 shift 24 add 16;
tape.lo(2):= long <::> add entryno shift 24
add (totalsegmno);
tape.lo(3):= t1tapename(1);
tape.lo(4):= t1tapename(2);
for i:= 5 step 1 until 25 do tape.lo(i):= rx;
setposition(tape,-1,0);
close(tape,false add 1);
tapeshift:= true;
tapename(1):=t1tapename(1);
tapename(2):=t1tapename(2);
mount_med_ring(true);
testlabel(true);
writelabel(3);
open(tape,modekind, t1tapename,
1 shift 18);
setposition(tape,1,1);
endtape:=false;
monitor(72)set catalogbase:(zhelp,0,entrybase);
end;
begin
tntshift:=tntshift+1;
tapename(1):=ptape.lo(3);
tapename(2):=ptape.lo(4);
setposition(ptape,-1,0);
close(ptape,true);
mount_med_ring(false);
testlabel(false);
open(ptape,modekind, tapename,1 shift 18);
setposition(ptape,1,1);
tendtape:=false;
end;
begin
comment ***** backspace to privius tape;
gettape(pdate,ntshift);
ntshift:=ntshift-1;
dumpcatupdate(1,tapenr,entryno);
tapename(1):=ptapename(1);
tapename(2):=ptapename(2);
mount_med_ring(true);
testlabel(true);
close(tape,false);
open(tape,modekind,
t1tapename, 1 shift 18);
setposition(tape,pfno,pbno);
tapeshift:=false;
end;
end;
end;
monitor(72)set catalog base:(zhelp,0,entrybase);
end;
\f
procedure transtape;
begin
comment
*******************************************************
* *
* This procedure will take a file from the privius *
* dumptape and copy that file to the tape used now. *
* *
*******************************************************;
integer tarecordsize,tarsize,ii,ai,ik,ta1recordsize,i1;
integer field inf2;
begin
inf2:=2;
notapen:=notapen+1;
entryno:=entryno+1;
if ttest then write(out,<:<10>pfileno=:>,pfileno,
<:<10>pblockno=:>,pblockno);
nexten:
ai:=inrec6(ptape,0);
while ai <> 100 do
begin
if ai = 0 then goto finis;
if ai mod 512 = 8 then inrec6(ptape,ai);
ai:=inrec6(ptape,0);
end;
inrec6(ptape,100);
if ptape.inf2 = 4 then
begin
changevol(2);
goto nexten;
end;
if ttest then
begin
write(out,<:<10> name = :>, ptape.taname);
write(out,<:<10>lbase = :>,
ptape.talbase,<: ubase= :>,ptape.taubase);
end;
identical:= entry.name(1) = ptape.taname(1) and
entry.name(2) = ptape.taname(2) and
entry.lbase = ptape.talbase and
entry.ubase = ptape.taubase ;
if entry.name(1) < ptape.taname(1) or
( entry.name(1) = ptape.taname(1) and
entry.name(2) < ptape.taname(2) ) or
ptape.taname(1)= long <:mtpoo:> add 108 then
begin
if ttest then
begin
write(out,<:<10>entryname = :>,
entry.name);
write(out,<:<10>tapename=:>,
ptape.taname);
end;
entryno:=entryno-1;
permkey:=entry.key extract 3;
ttail.docname(1):=entry.docname(1);
ttail.docname(2):=entry.docname(2);
if list then listentry(true);
write(out,<:****:>);
write(out,
<:<10>*** entry does not exist on disc or previous tape:>);
pageshift;pageshift;
goto finis;
end;
if ttest then
begin
write(out,<:<10>navn = :>, entry.name);
write(out,<: lbase = :>,entry.lbase,<:ubase= :>,entry.ubase);
end;
if identical then
begin
outrec6(tape,blocksize);changerec6(tape,100);
tofrom(tape,ptape,100);
if ttest then write(out,<:<10>tagsegmno =:>,ptape.tasegmno);
tape.lo(2):= long <::> add entryno shift 24 add ptape.tasegmno;
permkey:=entry.key extract 3;
ttail.docname(1):=entry.docname(1);
ttail.docname(2):=entry.docname(2);
if list then listentry(list);
if ttest then write(out,<:<10>tasize= :>,ptape.tasize);
if ptape.tasize >= 0 then
tarsize:=ptape.tasize;
if tarsize > 0 then
begin
totalsegmno:=totalsegmno+tarsize;
tarecordsize:=0;segmno:=0;
k:=ptape.tasize//vksegm;
for i:=0 step 1 until k-1 do
begin
outrec6(tape,blocksize);changerec6(tape,8);
tape.lo(1):=long <::> add 2 shift 24 add blocksize;
tape.lo(2):=long <::> add entryno shift 24 add (i*vksegm);
for ii:= 1 step 1 until vksegm do
begin
ai:=inrec6(ptape,0);
if ai = 100 then
begin
inrec6(ptape,100);
if ptape.inf2 = 4 then changevol(2)
else goto finis;
ai:=inrec6(ptape,0);
end;
if tarecordsize mod psegm = 0 then
begin
inrec6(ptape,8);
ai:=inrec6(ptape,0);
if ai = 100 then
begin
inrec6(ptape,100);
if ptape.inf2 = 4 then
changevol(2) else goto finis;
ai:=inrec6(ptape,0);
end;
end;
if endtape then changevol(1);
ai:=inrec6(ptape,0);
if ai = 100 then
begin
inrec6(ptape,100);
if ptape.inf2 = 4 then
changevol(2) else goto finis;
ai:=inrec6(ptape,0);
end;
if ai = 100 or ai = 0 then goto finis;
if ai mod 512 = 0 then
begin
inrec6(ptape,512);
tarecordsize:=tarecordsize+1;
outrec6(tape,512);
for ik:= 1 step 1 until 128 do tape(ik):=ptape(ik);
end;
end;
end;
ta1recordsize:=tarsize mod vksegm;
if ta1recordsize > 0 then
begin
if endtape then changevol(1);
outrec6(tape,blocksize);
changerec6(tape,ta1recordsize*512+8);
tape.lo(1):=long <::> add 2 shift 24 add (ta1recordsize*512+8);
tape.lo(2):=long <::> add entryno shift 24 add (k*vksegm);
for ii:= 0 step 1 until ta1recordsize-1 do
begin
if inrec6(ptape,0) = 8 then
begin
if tarecordsize mod psegm = 0 then inrec6(ptape,8);
end;
ai:=inrec6(ptape,0);
if ai = 100 then
begin
inrec6(ptape,100);
if ptape.inf2 = 4 then changevol(2) else goto finis;
ai:=inrec6(ptape,0);
end;
if ai = 100 or ai = 0 then goto finis;
if ai mod 512 = 0 then
begin
inrec6(ptape,512);
tarecordsize:=tarecordsize+1;
for ik:= 1 step 1 until 128 do tape(2+ii*128+ik):=ptape(ik);
end;
end;
end;
end;
if tarsize > 0 and tarsize mod psegm <> 0 then
pblockno:=pblockno+1;
pblockno:=pblockno+tarsize//psegm+1;
end
else
begin
if ttest then write(out,<:<10> ta1size= :>,ptape.tasize);
if ptape.tasize > 0 and ptape.tasize mod psegm <> 0 then
pblockno:=pblockno+1;
if ptape.tasize >= 0 then
pblockno:=ptape.tasize//psegm+1+pblockno;
if ttest then write(out,<:<10>pfil=:>,
pfileno,<:pblo=:>,pblockno);
ai:=inrec6(ptape,0);
while ai <> 100 do
begin
if ai = 0 then goto finis;
if ai mod 512 = 8 then inrec6(ptape,ai);
ai:=inrec6(ptape,0);
end;
goto nexten;
end;
end;
pageshift;
finis:
end <*transtape*> ;
procedure pageshift;
begin
nooflisten:=nooflisten+1;
if nooflisten >= 63 then
begin
nooflisten:=1;
write(out,<:<12>:>,"sp",60,<:page :>,pagenr);
write(out,<:<10>savelabel: :>, xlabel);
pagenr:=pagenr+1;
end;
end;
\f
procedure listentry(listspec);
boolean listspec;
begin
comment
**********************************************************
* *
* This procedure is used to list an entry. The procedu- *
* outmodekind is used to list the kind of a filediscrip- *
* tor. *
* *
**********************************************************;
\f
procedure outmodekind;
begin
integer i,modekind;
modekind:=entry.kind;
for i:=1 step 1 until 21 do
begin
if modekind=(case i of (
<*ip*> 1 shift 23 + 0 shift 12 + 0,
<*bs*> 1 shift 23 + 0 shift 12 + 4,
<*tw*> 1 shift 23 + 0 shift 12 + 8,
<*tro*> 1 shift 23 + 0 shift 12 + 10,
<*tre*> 1 shift 23 + 2 shift 12 + 10,
<*trn*> 1 shift 23 + 4 shift 12 + 10,
<*trf*> 1 shift 23 + 6 shift 12 + 10,
<*tpo*> 1 shift 23 + 0 shift 12 + 12,
<*tpe*> 1 shift 23 + 2 shift 12 + 12,
<*tpn*> 1 shift 23 + 4 shift 12 + 12,
<*tpf*> 1 shift 23 + 6 shift 12 + 12,
<*tpt*> 1 shift 23 + 8 shift 12 + 12,
<*lp*> 1 shift 23 + 0 shift 12 + 14,
<*crb*> 1 shift 23 + 0 shift 12 + 16,
<*crd*> 1 shift 23 + 8 shift 12 + 16,
<*crc*> 1 shift 23 + 10 shift 12 + 16,
<*mto*> 1 shift 23 + 0 shift 12 + 18,
<*mte*> 1 shift 23 + 2 shift 12 + 18,
<*nrz*> 1 shift 23 + 4 shift 12 + 18,
<*nrze*> 1 shift 23 + 6 shift 12 + 18,
<*pl*> 1 shift 23 + 0 shift 12 + 20 ))
then goto found
end;
found:
if i=22 then
begin
write(out,<<ddddd>,modekind shift (-12),<:.:>,
<<d>,modekind extract 12," ",
if modekind extract 12<10 then 2 else 1);
end
else
begin
write(out,case i of (
<: ip :>,
<: bs :>,
<: tw :>,
<: tro :>,
<: tre :>,
<: trn :>,
<: trf :>,
<: tpo :>,
<: tpe :>,
<: tpn :>,
<: tpf :>,
<: tpt :>,
<: lp :>,
<: crb :>,
<: crd :>,
<: crc :>,
<: mto :>,
<: mte :>,
<: nrz :>,
<: nrze :>,
<: pl :> ) );
end
end outmodekind;
real k;
integer i,j,p;
if listspec then
begin
write(out,<:<10>:>);
write(out," ",(if listmore then 11 else 0)
-write(out, entry.name));
end;
if listmore then
begin
if entry.kind<0 then outmodekind
else
write(out,<< dddd>,entry.kind," ",2);
if sysdump then write(out,<<d>,permkey,<:.:>);
i:=write(out, ttail.docname);
write(out," ",12-i);
if sysdump then
begin
write(out,
<< -ddddddd>,entry.lbase,entry.ubase);
end;
i:=entry.contents shift (-12);
if i<>4 and i<32 then
begin
i:=entry.shortclock;
missingclock:=false;
if i<>0 then
write(out,<: d.:>,<<zddddd>,
systime(4,(if i>0 then i else i + extend 1 shift 24)
/625*1 shift 15+12,r),
<:.:>,<<zddd>,r/100)
end
else
if entry.kind>0 then missingclock:=true;
end;
monitor(72,zhelp,0,entrybase);
end listentry;
\f
procedure dumptape;
begin
zone bsarea(128*2*vksegm,2,bsproc);
long array field ta;
integer array itail(1:20);
integer noofbutrans;
procedure listclock;
begin
integer field inf,clockadr,startext,seg;
boolean started;
procedure outdate;
begin
inf:=clockadr-2;
write(out,<: d.:>,<<zddddd>,bsarea.inf,<:.:>);
end;
procedure outclock;
begin
write(out,<<zddd>,bsarea.clockadr/100);
missingclock:=false;
end;
startext:=entry.contents extract 12+2;
if startext>500 then
begin
monitor(72,zhelp,0,interval);
write(out,<: entry inconsistent:>);
goto exitlistclock
end;
setposition(bsarea,0,0);
inrec6(bsarea,512);
monitor(72,zhelp,0,interval);
seg:=entry.kind-1;
inf:=startext+2;
clockadr:=6+bsarea.inf extract 12
+12*bsarea.startext extract 12
+2*bsarea.startext shift (-12) +startext;
if clockadr<=502 then
begin
outdate;
outclock
end
else
begin
started:=false;
nextsegm:
if clockadr=504 then
begin
outdate;
started:=true
end;
inf:=504;
if bsarea.inf extract 12>500 or seg=0 then
begin
write(out,<: code inconsistent:>);
goto exitlistclock
end;
clockadr:=clockadr-502+bsarea.inf extract 12;
inrec6(bsarea,512); seg:=seg-1;
if clockadr>502 then goto nextsegm;
if -,started then outdate;
outclock;
end;
exitlistclock:
monitor(72,zhelp,0,entrybase);
end listclock;
procedure bsproc(z,s,b);
zone z;
integer s,b;
begin
comment
*******************************************************
* *
* This block procedure is used when an entry is saved *
* it is then tested if another process is using the *
* entry. *
* *
*******************************************************;
monitor(72)set catalog base:(zhelp,0,interval);
if s shift (-2) extract 1 = 1 or s shift (-5) extract 1 = 1 then
begin
if s shift (-5) extract 1 = 1 and b = 0 then
begin
monitor(72)set catalog base:(zhelp,0,entrybase);
i:=monitor(52)create process:(bsarea,0,iarr);
if i <> 0 and ttest then
write(out,<:<10> result of create process =:>,i);
if i = 0 then goto nextin;
end;
entryno:=entryno-1;
if tapeshift then changevol(3)
else
harderror:=true;
outrec6(tape,blocksize);
setposition(tape,pfno,pbno);
entry.key:=-1;
entry.lbase:=-1;
entry.ubase:=-1;
totalsegmno:=totalsegmno-segmno;
write(out,<:<10> *** entry in use: :>);
write(out, entryname);
pageshift;
if s shift (-2) extract 1 = 1 then write(out,
<: area reserved :>);
if s shift (-5) extract 1 = 1 then write(out,
<: area not created:>);
if ttest then
begin
write(out,<:<10> s=:>,s,<: b= :>,b);
end;
end;
goto next;
end;
monitor(72)set cat base:(zhelp,0,entrybase);
if entry.size >= 0 then
begin
open(bsarea,4,
entryname,1 shift 5 + 1 shift 2);
proaddr:=monitor(4)process description addr:(bsarea,i,itail);
if proaddr > 0 then
begin
system(5)move core area:(proaddr,itail);
if itail(7) <> 0 then
begin
entry.key:=-1;
entry.lbase:=-1;
entry.ubase:=-1;
write(out,<:<10>*** entry reserved: :>,
entryname);
pageshift;
monitor(72)set cat base:(zhelp,0,interval);
goto next;
end;
end;
end;
segmno:=0;
i:=0;
monitor(52)create area process:(bsarea,0,iarr);
entryno:=entryno+1;
nextin:
if endtape then changevol(1);
if ttest then write(out,<:<10>pfno=:>,pfno,<: pbno=:>,pbno);
getposition(tape,pfno,pbno);
outrec6(tape,blocksize);changerec6(tape,100);
tape.lo(1):=rx:=long <::> add 1 shift 24 add 52;
tape.lo(2):= long <::> add entryno shift 24 add
(if entry.kind < 0 then 0 else entry.kind);
tape.lo(3):= entry.name(1);
tape.lo(4):=entry.name(2);
ta:=14;
for i:= 1 step 1 until 5 do tape.lo(4+i):= ttail.ta(i);
permkey:= entry.key extract 3;
tape(10):= entry.key extract 3;
tape.lo(11):=entry.docname(1);
tape.lo(12):=entry.docname(2);
tape.lo(13):= long <::> add entry.lbase shift 24 add entry.ubase;
for i:= 14 step 1 until 25 do tape.lo(i):= rx;
if ttest then write(out,<: size=:>,entry.kind);
if entry.size < 0 then goto nextentry;<*save descriptor*>
for noofbutrans:=inrec6(bsarea,0) while noofbutrans > 2 do
begin
if endtape then changevol(1);
outrec6(tape,blocksize);
if noofbutrans+8 <> blocksize then changerec6(tape,8+noofbutrans);
tape.lo(1):= long <::> add 2 shift 24 add (8+noofbutrans);
tape.lo(2):=long <::> add entryno shift 24 add segmno;
inrec6(bsarea,noofbutrans);
raf:=8;
tofrom(tape.raf,bsarea,noofbutrans);
segmno:=segmno + noofbutrans//512;
totalsegmno:=totalsegmno+ noofbutrans//512;
end;
tapeshift:=false;
nextentry:
if list then listentry(true);
if list and missingclock and entry.size >= 0 then listclock;
if list then pageshift;
next:
if entry.size >= 0 then
close(bsarea,true);
if entryname(1) <> long <:incsa:> add 118
or entryname(2) <> long <:e:> then
begin
monitor(72)set cat base:(zhelp,0,entrybase);
i:=monitor(64)remove process:(bsarea,0,iarr);
if i <> 0 and i <> 3 and ttest then
begin
write(out,<:<10>entryname= :>, entry.name,
<: result of remove = :>,i);
end;
end;
end <*dumttape*>;
comment
*******************************************************
* *
* This procedure dumps the entries on tape. If an en- *
* try can not be saved and something of that entry is *
* saved this will be deleted and the next entry will *
* be saved. *
* *
*******************************************************;
\f
procedure outentry;
begin
long array field doc,tai;
integer field bf;
doc:=14;tai:=0;
for i:=1 step 1 until 5 do tail.tai(i):=ttail.doc(i);
i:=2;
swoprec6(entry,34);
while i <= 34 do
begin
bf:=i;
entry.bf:=ttail.bf;
i:=i+2;
end;
end;
if sys then
open(tape,modekind, t1tapename,1 shift 18) else
open(tape,modekind,tapename,1 shift 18);
setposition(tape,1,1);
open(entry,4, p2catname,0);
setposition(entry,0,0);
for tq1:= 1 step 1 until noofentries do
begin
ii:=monitor(72)set catalog base:(zhelp,0,interval);
if ii <> 0 and ttest then write(out,
<:<10>result of set cat base= :>,ii);
if swoprec6(entry,0) = 2 then swoprec6(entry,2);
i:=swoprec6(entry,0);
if i <> 0 then
begin
swoprec6(entry,34);
if entry.key <> -1 then
begin
entrybase(1):=entry.lbase;
entrybase(2):=entry.ubase;
ii:=monitor(72)set catalog base:( zhelp,0,entrybase);
if ii <> 0 and ttest then write(out,
<:<10>result of set cat base=:>,ii);
entryname(1):=entry.name(1);
entryname(2):=entry.name(2);
open(help,0, entryname,0);
close(help,true);
i:= monitor(76)look up head and tail:(help,0,ttail);
tempdoc(1):=entry.docname(1);
tempdoc(2):=entry.docname(2);
if i=0 and entry.lbase = ttail(2)
and entry.ubase = ttail(3) then tofrom(entry,ttail,34);
entry.docname(1):=tempdoc(1);
entry.docname(2):=tempdoc(2);
if i<>6 then
begin
if ttest then
begin
write(out,<:<10>result of lookup entry = :>,i);
write(out,<:<10> entryname is = :>);
write(out, entryname);
write(out,<: lower base= :>,
ttail(2),<: upper base =:>,ttail(3));
end;
if i = 3 or
entry.lbase <> ttail(2) or entry.ubase <> ttail(3) then
begin
if std and last then
begin
if ptapeshift then
begin
ptapeshift:=false;
open(ptape,modekind,
ptapename,1 shift 18);
setposition(ptape,1,1);
end;
transtape;
end else
begin
entry.key:=-1;
entry.lbase:=-1;
entry.ubase:=-1;
end;
end
else
dumptape;
end
end;
end;
end;
monitor(72)set catalog base:(zhelp,0,interval);
if sys then
begin
if ntshift > 0 then
dumpcatupdate(entryno-stofentry,tapenr,stofentry)
else
dumpcatupdate(entryno,tapenr,entrystart);
end;
if notapen > 0 and sys then
begin
setposition(ptape,-1,0);
close(ptape,true);
end;
comment dump baandpool
dumtt1name
dump dumpcat;
close(entry,true);
if sys then
begin
t2name(1):=0;t2name(2):=0;
open(entry,4, t2name,0);
tail(1):=1;
tail(2):=1;
tail(3):=0;tail(4):=0;tail(5):=0;
i:= monitor(40)create entry:(entry,0,tail);
setposition(entry,0,0);
entryname(1):=long <:mtpoo:> add 108;entryname(2):=long <::>;
open(mt1record,4, mt1pool,0);
open(help,0, entryname,0);
close(help,true);
monitor(48)remove entry:(help,0,tail);
tail.tadocname(1):=mtpool(1);
tail.tadocname(2):=mtpool(2);
monitor(46)rename entry:(mt1record,0,tail);
close(mt1record,true);
open(mt1record,4, mtpool,0);
monitor(42)lookupenty:(mt1record,0,tail);
tail(6):=today;
tail(9):=11 shift 12;
monitor(44)changeentry:(mt1record,0,tail);
monitor(76)lookup head and tail:(mt1record,0,ttail);
swoprec6(entry,34);
tofrom(entry,ttail,34);
close(mt1record,true);
if ttest then write(out,<:<10>result of look up entry1= :>,ik);
dumptape;
entryname(1):=long <:savec:> add 97;entryname(2):=long <:t:>;
monitor(72)set cat base:(zhelp,0,interval);
open(cat1,4, dump1name,0);
open(help,0, entryname,0);
close(help,true);
monitor(48)remove entry:(help,0,tail);
tail.tadocname(1):=dcname(1);
tail.tadocname(2):=dcname(2);
monitor(46)rename entry:(cat1,0,tail);
close(cat1,true);
open(cat1,4, dcname,0);
monitor(42)lookup entry:(cat1,0,tail);
tail(6):=today;
tail(9):=11 shift 12;
tail(10):=dumpensize;
monitor(44)change entry:(cat1,0,tail);
open(help,0, entryname,0);
ik:=monitor(76)lookup head and tail:(help,0,ttail);
outentry;
close(help,true);
if ttest then write(out,<:<10>result of lookup entry2= :>,ik);
dumptape;
entryname(1):=long <:tempc:>add 97;entryname(2):=long <:t:>;
monitor(72)set cat base:(zhelp,0,interval);
close(cat1,true);
open(cat1,4, p2catname,0);
open(help,0, pcatname,0);
close(help,true);
monitor(48)remove entry:(help,0,tail);
tail.tadocname(1):=pcatname(1);
tail.tadocname(2):=pcatname(2);
monitor(46)rename entry:(cat1,0,tail);
monitor(50)permanent entry:(cat1,3,tail);
entrybase(1):=interval(5);entrybase(2):=interval(6);
monitor(74)set entry base:(cat1,0,entrybase);
close(cat1,true);
open(cat1,4, pcatname,0);
monitor(42)lookupentry:(cat1,0,tail);
tail(6):=today;
tail(9):=11 shift 12;
if total then tail(10):=0 else
tail(10):=entryno-2;
monitor(44)changeentry:(cat1,0,tail);
monitor(76)lookup head and tail:(cat1,0,ttail);
swoprec6(entry,34);
tofrom(entry,ttail,34);
close(cat1,true);
dumptape;
end else close(help,true);
outrec6(tape,blocksize);changerec6(tape,100);
tape.lo(1):=rx:=long <::> add 3 shift 24 add 8;
tape.lo(2):=long <::> add entryno shift 24 add totalsegmno;
for i:=3 step 1 until 25 do tape.lo(i):=rx;
setposition(tape,2,0);
close(tape,false);
end;
\f
comment
******************************
* *
* I N I T A L I S E R I N G *
* *
******************************;
open(zhelp,0,<::>,0);
system(11)get catalog base:(0,interval);
pagenr:=1;nooflisten:=1;
stofentry:=0;
lo:=0;
mtpool(1):=long <:mtpoo:> add 108;
mtpool(2):=long <::>;
entryno:=0;totalsegmno:=0;
notapen:=0;device:=0;maxhashsize:=0.5;
nomess1:=true;
ptapename(1):=long <::>;
ptapename(2):=long <::>;
endtape:=false;
catnr:=2;dumpsize:=8;restondumps:=4;
dbase1:=12;tadocname:=0;dbase2:=14;dname:=2;
entrystart:=0;
startofbit:=18;dumpkey:=16;startofbitt:=16;
modekind:= 18 ;
mtrsize:=16;mtno:=16;mtnr:=2;mtname:=2;mtdate:=12;mttotal:=14;
blocksize:= 8+512*vksegm;
sysdump:=true;
missingclock:=false;listmore:=true;
shortclock:=26;contents:=32;
t1test:=false;ttest:=false;
tname(1):=long <:dum1c:> add 97;
tname(2):=long <:t:>;
name:=6;kind:=16;key:=2;size:=16;
lbase:=4;
harderror:=false;
taname:=8;tasegmno:=8;tasize:=8;talbase:=50;taubase:=52;
filno:=1;ubase:=6;docname:=16;
tempname(1):= long <:tem1c:> add 97;
tempname(2):=long <:t:>;
dcname(1):= long <:savec:> add 97;
dcname(2):= long <:t:>;
tntshift:=0;
ntshift:=0;
tendtape:=false;
tapeshift:=false;
pfileno:=1;pblockno:=1;ptapeshift:=false;
filno:=1;ubase:=6;docname:=16;
pfno:=1;pbno:=1;
pdate:=dateofpdump extract 24;
if ttest then write(out,<:<10>pdate = :>,pdate);
if last then date:=dateofpdump;
if ttest then write(out,<:<10> date of call = :>,date);
comment (* find date *);
p2catname(1):= long <:tem2c:> add 97;
p2catname(2):= long <:t:>;
pcatname(1):= long <:tempc:> add 97;
pcatname(2):=long <:t:>;
mt1pool(1):= long <:mt1po:> add 111;
mt1pool(2):= long <:l:>;
open(mtrecord,4, mtpool,0);
open(mt1record,4, mt1pool,0);
i:=monitor(42)lookup entry:( mtrecord,0,tail);
if i <> 0 then error(7);
mtsize:=tail(1);
if monitor(42)lookup entry:(mt1record,0,ttail) = 0 then
monitor(48) remove entry:(mt1record,0,tail);
tail(1):=mtsize;
tail(2):=1;
tail(3):=0;tail(4):=0;tail(5):=0;
if monitor(40)create entry:(mt1record,0,tail) <> 0 then error(7);
entrybase(1):=interval(5);entrybase(2):=interval(6);
discname:=2;
monitor(42)lookup entry:(mt1record,0,tail);
resname(1):=tail.dname(1);resname(2):=tail.dname(2);
i:=monitor(50)permanent entry:(mt1record,3,tail);
if i <> 0 then
begin
monitor(48)remoev entry:(mt1record,0,tail);
if ttest then write(out,<:<10>mt1record:>);
error(5);
end;
i:=monitor(74)set entry base:(mt1record,0,entrybase);
if i <> 0 then
begin
monitor(48)remove entry:(mt1record,0,tail);
if ttest then write(out,<:<10>set base mt1record:>);
error(5);
end;
setposition(mtrecord,0,0);setposition(mt1record,0,0);
inrec6(mtrecord,2);bittsize:=((mtrecord.catnr-1)//24)+1;
setposition(mtrecord,0,0);
ik:=0;
while ik < mtsize do
begin
ik:=ik+1;
inrec6(mtrecord,512);outrec6(mt1record,512);
tofrom(mt1record,mtrecord,512);
end;
close(mtrecord,false);close(mt1record,true);
if sys and std then
begin
gettape(pdate,tntshift);
iarr(1):= ( if device = 0 then 14 shift 12 else
32 shift 12 + 1 shift 9) ;
iarr(2):= long <:mou:> shift (-24) extract 24;
iarr(3):= long <:nt:> shift (-24) extract 24;
iarr(4):= device;
iarr(5):=ptapename(1) shift (-24) extract 24;
iarr(6):=ptapename(1) extract 24;
iarr(7):=ptapename(2) shift (-24) extract 24;
iarr(8):=ptapename(2) extract 24;
iarr(9):=0;
iarr(10):=0;
if nomess1 then
system(10,0,iarr);
end;
if sys then
begin
if total then gettapename(1) else gettapename(0);
iarr(1):=( if device = 0 then 14 shift 12 else
32 shift 12 + 1 shift 9) ;
iarr(2):= long <:mou:> shift (-24) extract 24;
iarr(3):= long <:nt:> shift (-24) extract 24;
iarr(4):= device;
iarr(5):= t1tapename(1) shift (-24) extract 24;
iarr(6):= t1tapename(1) extract 24;
iarr(7):= t1tapename(2) shift (-24) extract 24;
iarr(8):= t1tapename(2) extract 24;
iarr(9):= 0;
iarr(10):=0;
system(10,0,iarr);
end;
if total then auxscan(0) else auxscan(date);
open(help,0, tempname,0);
i:=monitor(42)look up entry:(help,0,tail);
if i = 0 then monitor(48)remove entry:(help,0,tail);
tail(1):=c2size;
tail(2):=1;
tail(3):=0;tail(4):=0;tail(5):=0;
i:=monitor(40)create entry:(help,0,tail);
if i <> 0 then error(15);
i:=monitor(50)permanent entry:(help,3,tail);
if i <> 0 then error(15);
entrybase(1):=interval(5);entrybase(2):=interval(6);
monitor(74)set entry base :(help,0,entrybase);
close(help,false);
inittempcat(tempname);
param(1):=1;param(2):=1;
param(3):=1;param(4):=1;
param(5):=34;
param(6):=4;
param(7):=0;
keydescr(1,1):=3;keydescr(1,2):=10;
keydescr(2,1):=3;keydescr(2,2):=14;
keydescr(3,1):=2;keydescr(3,2):=4;
keydescr(4,1):=2;keydescr(4,2):=6;
sortname(1):=real <:dum1c:> add 97;
sortname(2):=real <:t:>;
open(help,0,tempname,0);
monitor(42)look up entry:(help,0,tail);
sortname(5):=tail.discname(1);
sortname(3):=real <:tem1c:> add 97;
sortname(4):=real <:t:>;
sortname(6):= real <::>;
close(help,false);
eof:=-1;
noofrecs:=noofentries;
if ttest then write(out,<:<10> noofentries to save = :>,noofentries);
vksortproc(param,keydescr,sortname,eof,noofrecs,result,explanation);
name:=6;
eof:=-1;
if ttest then write(out,<:<10> noofrecs = :>,noofrecs);
blocksize:=8+512*vksegm;
tname(1):=long <:dum1c:> add 97;
tname(2):=long <:t:>;
open(help,0,tempname,0);
entrybase(1):=interval(5);entrybase(2):=interval(6);
monitor(42)lookup entry:(help,0,tail);
resname(1):=tail.dname(1);resname(2):=tail.dname(2);
i:=monitor(50)permanent entry:(help,3,tail);
if i <> 0 then
begin
monitor(48)remove entry:(help,0,tail);
if ttest then write(out,<:<10>help:>);
error(5);
end;
i:=monitor(74)set entry base:(help,0,entrybase);
if i <> 0 then
begin
monitor(48)remove entry:(help,0,tail);
if ttest then write(out,<:<10>help set entry base:>);
error(5);
end;
close(help,false);
if result <> 1 then error(16);
if sys then
begin
notapen:=0;
dump1name(1):= long <:dump1:> add 99;
dump1name(2):= long <:at:>;
open(cat1,4, dump1name,0);
open(cat,4, dcname,0);
i:=monitor(42)look up entry:(cat,0,tail);
if i <> 0 then error(4);
hashentries:=tail(1);
dumpensize:=tail(10);
restondumps:=510 mod dumpensize;
if dumpensize = 0 then dumpensize:=18;
if monitor(42)look up entry:(cat1,0,ttail) = 0 then
monitor(48)remove entry:(cat1,0,ttail);
tail(1):=hashentries;
tail(2):=1;tail(3):=0;tail(4):=0;tail(5):=0;
if monitor(40)create entry:(cat1,0,tail) <> 0 then error(7);
entrybase(1):=interval(5);entrybase(2):=interval(6);
monitor(42)lookup entry:(cat1,0,tail);
resname(1):=tail.dname(1);resname(2):=tail.dname(2);
i:=monitor(50)permanent entry:(cat1,3,tail);
if i <> 0 then
begin
monitor(48)remove entry:(cat1,0,tail);
if ttest then write(out,<:<10>cat1:>);
error(5);
end;
i:=monitor(74)set entry base:(cat1,0,entrybase);
if i <> 0 then
begin
monitor(48)remove entry:(cat1,0,tail);
if ttest then write(out,<:<10>set base cat1:>);
error(5);
end;
setposition(cat,0,0);
setposition(cat1,0,0);
i:=inrec6(cat,0);
while i > 2 do
begin
inrec6(cat,i);outrec6(cat1,i);
tofrom(cat1,cat,i);
i:=inrec6(cat,0);
end;
close(cat,false);close(cat1,false);
tapename(1):=t1tapename(1);
tapename(2):=t1tapename(2);
end else
begin
p2catname(1):= long <:tem1c:> add 97;
p2catname(2):= long <:t:>;
end;
mount_med_ring(true);
testlabel(true);
if sys then
begin
if std and last then fletcatalog else
begin
p2catname(1):= long <:tem1c:> add 97;
p2catname(2):= long <:t:>;
end;
if notapen > 0 then
begin
if -, ptapeshift then
begin
ptapeshift:=true;
tapename(1):=ptapename(1);
tapename(2):=ptapename(2);
mount_med_ring(false);
testlabel(false);
ptapename(1):=tapename(1);
ptapename(2):=tapename(2);
end;
end;
end;
notapen:=0;
tapedump;
if total then
begin
open(cat,4, pcatname,0);
setposition(cat,0,0);
outrec6(cat,510);
for ih:=2 step 2 until 510 do cat.ih:=-1;
close(cat,true);
monitor(42)lookup entry:(cat,0,tail);
tail(1):=1;
i:=monitor(44)change entry:(cat,0,tail);
if i <> 0 then write(out,<:<10>result of change entry = :>,i);
end;
stop:
tapename(1):=t1tapename(1);
tapename(2):=t1tapename(2);
writelabel(2);
write(out,<:<10> entries =:>,entryno,<: segm=:>,totalsegmno);
open(help,0,tempname,0);
monitor(48)remove entry:(help,0,tail);
close(help,false);
end;
savenotok:=false;
outp:=false;
readallparam;
incrementdump;
halt:
if outp then closeout;
if savenotok then write(out,<:<10>incsave not ok<10>:>)
else
write(out,<:<10>incsave ok<10>:>);
close(zhelp,true);
fpproc(7)enoprogram:(0,0,0);
end
▶EOF◀