|
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: 87552 (0x15600)
Types: TextFile
Names: »incsavetxt«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »incsavetxt«
incsave=algol list.no xref.no blocks.no
begin
message vk 1981.03.30 incsave;
boolean last,total,std,list,outp,sys;
integer outres,date,i,segm,psegm;
long array input(1:2);
real array outarr(1:3);
long array tapename(1:2),ptapename(1:2),t1tapename(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);
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 readallparam;
begin
real array field rf;
comment
********************************************************
* *
* This procedure reads all the parameters to incsave. *
* *
********************************************************;
last:=true;
list:=true;total:=false;std:=false;
sys:=true;
rf:=0;
segm:=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 segm:=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;
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,savenotok,
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.:>);
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 now written:>);
end;
<*4*>
begin
write(out,<:<10> *** Wrong savelabel on :>);
write(out,tapename);
goto halt;
end;
end;
savenotok:=true;
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. *
* *
**************************************************;
case errorno of
begin
<*1*>;
<*2*>;
<*3*>;
<*4*>;
<*5*>;
<*6*>;
<*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. *
* *
********************************************************;
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;
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 = 3 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));
if idate > t2tail(2) then goto nottosave;
end else goto nottosave;
end;
end else
if auxentry.endate < idate 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);
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:
close(help,false);
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);
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 segm 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,<:<10>:>);
write(out,<:<10>savelabel: :>, zlabel);
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 lo;
lo:=0;
labelno:=1;
open(pttape, modekind, tapename,0);
setposition(pttape,labelno,0);
i:=inrec6(pttape,0);
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.lo(2) <> dumplabel(2,1) or pttape.lo(3) <> dumplabel(3,1) then
begin
tapename(1):=pttape.lo(2);
tapename(2):=pttape.lo(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.lo(i):= xlabel(i):=dumplabel(i,1);
for i:= 16 step 1 until 25 do pttape.lo(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
if pentry < pentryno then
begin
inrec6(dump,34);
while dump.key = - 1 do inrec6(dump,34);
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);
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.lbase < dump.lbase then outcat else
begin
if dumpcat.lbase = dump.lbase then
begin
if dumpcat.ubase < dump.ubase then outcat else
begin
if dumpcat.ubase = dump.ubase 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;
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(7):=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
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
if ttest then write(out,<:<10> antal1 = :>,noonsegm);
rhashentry;
while cat.catnr = -1 do rhashentry;
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 dumpsize 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;
integer lastdate;
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:=8388604;
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);
if ttest then write(out,<:<10>mtnr = :>,mtrecord.mtnr);
if taptotal = mtrecord.mttotal extract 4 and
lastdate > mtrecord.mtdate then
begin
lastdate:=mtrecord.mtdate;
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;
mtrecord.mttotal:=mtrecord.mttotal+16;
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
real procedure dateofpdump;
begin
comment
*****************************************************
* *
* This procedure finds the date of the privios dump *
* in the mtpool. *
* *
*****************************************************;
zone mtrecord(128,1,stderror);
integer field antal;
real 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);
comment if mtrecord.mttotal >= 16 then gdate:=mtrecord.mtdate;
if mtrecord.mtdate > gdate then gdate:=mtrecord.mtdate;
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
then
begin
found:=true;
if mtrecord.mttotal > 16 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;
if mtrecord.mttotal > 2 then
mtrecord.mttotal:=mtrecord.mttotal-16;
end;
end;
close(mtrecord,true);
if ttest then
begin
write(out,<:<10> name of previous tape = :>,
tapename);
end;
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(segm*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. *
* *
******************************************************;
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;
end;
begin
tntshift:=tntshift+1;
gettape(pdate,tntshift);
tapename(1):=ptapename(1);
tapename(2):=ptapename(2);
mount_med_ring(false);
testlabel(false);
close(ptape,true);
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;
begin
notapen:=notapen+1;
entryno:=entryno+1;
if ttest then write(out,<:<10>pfileno=:>,pfileno,
<:<10>pblockno=:>,pblockno);
setposition(ptape,pfileno,pblockno);
nexten:
inrec6(ptape,100);
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;
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//segm;
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*segm);
for ii:= 1 step 1 until segm do
begin
ai:=inrec6(ptape,0);
if tarecordsize mod psegm = 0 then
begin
inrec6(ptape,8);
ai:=inrec6(ptape,0);
end;
comment if ai mod 128 <> 0 then goto error1;
if endtape then changevol(1);
if tendtape then changevol(2);
outrec6(tape,512);
inrec6(ptape,512);tarecordsize:=tarecordsize+1;
for ik:= 1 step 1 until 128 do tape(ik):=ptape(ik);
end;
end;
ta1recordsize:=tarsize mod segm;
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*segm);
for ii:= 0 step 1 until ta1recordsize-1 do
begin
if tarecordsize mod psegm = 0 then inrec6(ptape,8);
ai:=inrec6(ptape,0);
comment if ai mod 128 <> 0 then goto error1;
if tendtape then changevol(2);
inrec6(ptape,512);tarecordsize:=tarecordsize+1;
for ik:= 1 step 1 until 128 do tape(2+ii*128+ik):=ptape(ik);
end;
end;
end;
if tarsize > 0 and tarsize mod psegm <> 0 then
pblockno:=pblockno+1;
pblockno:=pblockno+tarsize//psegm+1;
goto error2;
error1:
setposition(tape,pfno,pbno);
write(out,<:*** cannot be saved:>);
error2:
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);
setposition(ptape,pfileno,pblockno);
if tendtape then changevol(2);
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*segm,2,bsproc);
long array field ta;
integer array itail(1:20);
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 i:=inrec6(bsarea,0) while i > 2 do
begin
if endtape then changevol(1);
outrec6(tape,blocksize);
if i+8 <> blocksize then changerec6(tape,8+i);
tape.lo(1):= long <::> add 2 shift 24 add (8+i);
tape.lo(2):=long <::> add entryno shift 24 add segmno;
inrec6(bsarea,i);
raf:=8;
tofrom(tape.raf,bsarea,i);
segmno:=segmno + i//512;
totalsegmno:=totalsegmno+ i//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
and 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);
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 = tail(2)
and entry.ubase = tail(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
else
begin
write(out,<:<10> tilkald vk:>);
goto halt;
end;
close(help,false);
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;
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);
i:=monitor(50)permanent entry:(mt1record,3,tail);
if i <> 0 then error(11);
entrybase(1):=interval(5);entrybase(2):=interval(6);
i:=monitor(74)set entry base:(mt1record,0,entrybase);
if i <> 0 then
begin
warning(2);
pageshift;pageshift;
end;
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);
i:=monitor(50)permanent entry:(cat1,3,tail);
if i <> 0 then error(11);
entrybase(1):=interval(5);
entrybase(2):=interval(6);
i:=monitor(74)set entry base:(cat1,0,entrybase);
if i <> 0 then
begin
warning(2);
pageshift;
pageshift;
end;
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);
i:=monitor(50)permanent entry:(cat1,3,tail);
if i <> 0 then error(11);
entrybase(1):=interval(5);
entrybase(2):=interval(6);
i:=monitor(74)set entry base:(cat1,0,entrybase);
if i <> 0 then
begin
warning(2);
pageshift;pageshift;
end;
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);
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);
if notapen > 0 and sys then
begin
setposition(ptape,-1,0);
close(ptape,true);
end;
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);
savenotok:=false;
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*segm;
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;
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):=1;
tail(2):=1;
tail(3):=0;tail(4):=0;tail(5):=0;
if monitor(40)create entry:(mt1record,0,tail) <> 0 then error(7);
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
begin
tail(1):=200;
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);
end;
close(help,false);
inittempcat(tempname);
param(1):=1;param(2):=0;
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:>;
sortname(3):=real <:tem1c:> add 97;
sortname(4):=real <:t:>;
sortname(5):=real <:disc1:>;
sortname(6):= real <::>;
eof:=-1;
noofrecs:=noofentries;
if ttest then write(out,<:<10> noofentries to save = :>,noofentries);
mdsortproc(param,keydescr,sortname,eof,noofrecs,result,explanation);
if ttest then write(out,<:<10> noofrecs = :>,noofrecs);
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(5);
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);
if monitor(40)create entry:(cat1,0,tail) <> 0 then error(7);
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(40)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);
if savenotok then write(out,<:<10> save not ok :>)
else write(out,<:<10> save ok :>);
end;
outp:=false;
readallparam;
incrementdump;
halt:
if outp then closeout;
close(zhelp,true);
end
▶EOF◀