|
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: 20736 (0x5100)
Types: TextFile
Names: »tupdmtpool«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tupdmtpool«
updmtpool=algol list.no blocks.no xref.no
begin
message vk 1982.01.19 updmtpool;
comment
*************************************************************
* *
* This program is used to remove or insert tapes in the mt- *
* pool. *
* The program is called in the following way: *
* <outfile> = updmtpool tape.<tapename> (remove.<boolean)*
* (date.<date>) (nr.<integer>) (total.<boo- *
* ean> *
* If remove.yes not is specified the program normaly insert *
* a tape in the mtpool. *
* *
* Errormessages are: *
* *** Mtpool does not exist *
* *** Creation of temporary mtpool not possible *
* *** The date specification is wrong *
* *** The savecat does not exist *
* *** Creation of temporary savecat not possible *
* *** Param error *
* *** It is not possible to rename mtpool *
* *** It is not possible to rename dumpcat *
* *** Tapename does not exist in mtpool *
* *** Tapename does allready exist in mtpool *
* *
************************************************************* ;
real array inp,dumpname,dump1name,name,mtpool,
dump2name,mt1pool(1:2);
integer array t1tail,tail(1:10),ttail(1:17),interval(1:8);
integer nr,newdumpensize,i,nooftape,j,k,ik,dumpensize,
bitno,bitpattern,restondumps,hashentries,bittsize,
antal,noondump,tapeantal,dkey,cat1nr,sumofhash;
integer field mtnr,size,mtdate,mttotal,mtrsize,pantal,
wordno,catnr,wordno1,startofbit,dbase1,dbase2,dumpkey,key,
lbase,ubase,dusize;
integer array field startofbitt;
real array field mtname,dname,tadocname;
zone cat(128,1,stderror);
zone cat1(128,1,stderror);
zone mt1record(128,1,stderror);
zone mtrecord(128,1,stderror);
boolean found,finis,removed,insert,empty,test,t1test,
last,total,std,list,outp,sys;
integer outres,date,segm,psegm;
real array input(1:2);
real array outarr(1:3),tapename(1:2),ptapename(1:2),t1tapename(1:2);
zone zhelp(1,1,stderror);
\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(cat1,0,i);
outrec6(cat1,512);
for ik:=1 step 1 until 256 do
begin
a:=ik*2;
cat1.a:=-1;
end;
a:=2;cat1.a:=0;
end;
end;
\f
integer procedure hashkey(hname);real array hname;
begin
comment
******************************************************
* *
* This procedure computes the hashkey used to insert *
* the entry in the savecat. *
* *
******************************************************;
long sum,part_1_of_name,part_2_of_name;
part_1_of_name:= long hname(1);
part_2_of_name:= long 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 openout;
begin
real array outname(1:2);
outp:=true;
outname(1):=input(1);outname(2):=input(2);
fpproc(29)stack current out:(0,out,outarr);
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
if outp then
begin
fpproc(34)close up:(0,out,25);
fpproc(30)unstack out:(0,out,outarr);
end;
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 removedumpbit;
begin
comment
******************************************************
* *
* This procedure removes the bit beloning to nr in *
* the whole dumpcat. *
* *
******************************************************;
boolean procedure bitsat(bitnummer);integer bitnummer;
begin
if cat.wordno shift (-bitnummer) extract 1 = 1 then
bitsat:=true else bitsat:=false;
end;
integer noonsegm,nremoved,word1;
integer field place;
boolean empty;
empty:=true;
nremoved:=0;
i:=1;open(cat,4,string dump1name(increase(i)),0);
for i:= 0 step 1 until hashentries do
begin
setposition(cat,0,i);
swoprec6(cat,2);
noonsegm:=cat.catnr;
if t1test then write(out,<:<10>noonsegm= :>,noonsegm);
if t1test then write(out,<:<10>dumpensize=:>,dumpensize);
if noonsegm < 40 then
begin
while noonsegm > 0 do
begin
rhashentry;
while cat.catnr = -1 do rhashentry;
word1:=cat.wordno;
if bitsat(bitno) then
cat.wordno:=exor(cat.wordno,bitpattern);
if t1test 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;
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
procedure error(errorno);
integer errorno;
begin
case errorno of
begin
write(out,<:<10>*** Mtpool does not exist:>);
write(out,<:<10>*** Creation of temporary mtpool not possible:>);
write(out,<:<10>*** It is necsecarry to specify what to insert:>);
write(out,<:<10>*** The date specification is wrong:>);
write(out,<:<10>*** The savecat does not exist:>);
write(out,<:<10>*** Creation of temporary savecat not possible:>);
write(out,<:<10>*** Param error:>);
write(out,<:<10>*** It is not possible to rename mtpool:>);
write(out,<:<10>*** It is not possible to rename dumpcat:>);
write(out,<:<10>*** Tapename does not exist in mtpool:>);
write(out,<:<10>*** Tape does allready exist in mtpool:>);
end;
write(out,<:<10>update not ok :>,<:<10>:>);
goto halt;
end;
\f
integer procedure readparam(val);real array val;
begin
comment
This procedure reads the parameters in the FILE Processor com-
mand, which called the algol program.;
own integer q;
integer ik;
readparam:=0;
if q>=0 then q:=q+1;
if q=1 then
begin
ik:=system(4,1,val);
if ik = 6 shift 12 +10 then
begin
system(4,0,val);
readparam := -1;
end
else if ik<> 0 then goto p;
end
else
if q > 0 then
begin
p: ik:=system(4,q-1,val);
if ik = 0 then q := -1 else
readparam := (if i shift (-12) = 8 then 2 else 0)
+(if i extract 12 = 10 then 2 else 1)
end
end readparam;
\f
integer procedure readdate;
begin
comment
This procedure reads a date and check it for corretness;
real array ra(1:2);
long d;
integer dd,mo,aa,hh,mm,ss,a,feb;
d:=0;
a:=68;
hh:=0;mm:=0;ss:=0;
ra(1):=inp(1);
if ra(1) > 99 or ra(1) < 79 then error(7);
aa:=ra(1); readparam(ra);
if ra(1) >12 or ra(1) < 1 then error(7);
mo:=ra(1); readparam(ra);
if ra(1) < 1 then error(7);
dd:=ra(1); readparam(ra);
if ra(1) >23 then error(7);
hh:=ra(1);readparam(ra);
if ra(1) >59 then error(7);
mm:=ra(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 error(7);
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;
total:=false;removed:=false;insert:=true;found:=false;
dumpensize:=0;restondumps:=0;startofbitt:=16;catnr:=2;
bittsize:=1;
nr:=1;
date:=0;
mtrsize:=16;
antal:=2;
sumofhash:=0;
key:=2;
size:=16;dusize:=34;
pantal:=2;
dumpkey:=16;dbase1:=12;dbase2:=14;dname:=2;
lbase:=4;ubase:=6;
startofbit:=18;tadocname:=2;
mtnr:=2;
mtname:=2;
mtdate:=12;
mttotal:=14;
test:=false;t1test:=false;
for i:=1 step 1 until 10 do tail(i):=0;
mtpool(1):= real <:mtpoo:> add 108;
mtpool(2):= real <::>;
mt1pool(1):= real <:mt1po:> add 111;
mt1pool(2):= real <:l:>;
i:=1;
open(mtrecord,4,string mtpool(increase(i)),0);
i:=1;open(mt1record,4,string mt1pool(increase(i)),0);
i:=monitor(76)look up head and tail:(mtrecord,0,ttail);
if i <> 0 then error(1);
system(11)get catalog base:(0,interval);
if ttail.lbase <> interval(7) and
ttail.ubase <> interval(8) then
error(1);
i:= monitor(42)lookup entry:(mt1record,0,tail);
if i = 0 then
begin
if test then
write(out,<:<10>result of lookup entry = :>,i);
i:=monitor(48) remove entry :(mt1record,0,t1tail);
if test then
write(out,<:<10>result of remove entry = :>,i);
end;
tail(1):=1;
tail(2):=1;
tail(3):=0;tail(4):=0;tail(5):=0;
tail(9):=11 shift 12;
i:= monitor(40) create entry:(mt1record,0,tail);
if i <> 0 then
begin
if test then
write(out,<:<10>result of create entry = :>,i);
error(2);
end;
setposition(mtrecord,0,0);
setposition(mt1record,0,0);
i:=inrec6(mtrecord,0);
while i> 2 do
begin
inrec6(mtrecord,i);outrec6(mt1record,i);
tofrom(mt1record,mtrecord,i);
i:=inrec6(mtrecord,0);
end;
close(mt1record,true);close(mtrecord,true);
i:=1;
open(mtrecord,4,string mt1pool(increase(i)),0);
setposition(mtrecord,0,0);
i:=monitor(42)look up entry :(mtrecord,0,tail);
if i <> 0 then error(1);
for i:=readparam(inp) while i<> 0 do
begin
if i = -1 then error(2);
if inp(1) = real <:tape:> then
begin
i:=readparam(inp);
if i <> 1 then error(2);
name(1):=inp(1);name(2):=inp(2);
end;
if inp(1) = real <:remov:> add 101 then
begin
i:=readparam(inp);
if inp(1) = real <:yes:> then
begin
insert:=false;
removed:=true;
end
else if inp(1) = real <:no:> then removed:=false else error(7);
end;
if inp(1) = real <:date:> then
begin
j:=readparam(inp);
if j <> 1 then error(7) else date:=readdate;
end;
if inp(1) = real <:nr:> then
begin
j:=readparam(inp);
if j <> 1 then error(7) else nr:=inp(1);
end;
if inp(1) = real <:total:> then
begin
j:=readparam(inp);
if inp(1) = real <:yes:> then total:= true
else if inp(1) = real <:no:> then total:=false else error(7);
end;
end;
if test then
begin
write(out,<:<10>date = :>,date,<:<10>nr = :>,nr);
end;
comment end parameter indlaesning;
dump1name(1):= real <:dump1:> add 99;
dump1name(2):= real <:at:>;
dumpname(1):= real <:savec:> add 97;
dumpname(2):= real <:t:>;
i:=1;open(cat,4,string dumpname(increase(i)),0);
if monitor(76) look up head and tail:(cat,0,ttail) <> 0 then error(5);
hashentries:=ttail.size;
dumpensize:=ttail.dusize;
if dumpensize = 0 then dumpensize:=18;
if test then write(out,<:<10>dumpensize = :>,dumpensize);
restondumps:=510 mod dumpensize;
wordno1:=dumpensize+2;
if test then write(out,<:<10>wordno1=:>,wordno1);
restondumps:= 512 mod dumpensize;
if ttail.lbase <> interval(7) and
ttail.ubase <> interval(8) then error(5);
i:=1;open(cat1,4,string dump1name(increase(i)),0);
if monitor(42)look up entry:(cat1,0,tail) = 0 then
monitor(48) remove entry:(cat1,0,t1tail);
tail(1):=hashentries;
tail(2):=1;
tail(9):= 11 shift 12 ;
tail(3):=0;tail(4):=0;tail(5):=0;tail(10):=dumpensize;
tail(7):=1024;
if monitor(40)create entry:(cat1,0,tail) <> 0 then error(6);
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,true);
close(cat1,true);
if removed then
begin
setposition(mtrecord,0,0);
swoprec6(mtrecord,2);
tapeantal:=mtrecord.pantal;
swoprec6(mtrecord,mtrsize);antal:=0;
i:=1;
if test then write(out,<:<10>tapenavn=:>,string name(increase(i)));
finis:=false;
while antal <= tapeantal and -, finis do
begin
antal:=antal+1;
i:=1;if test then
write(out,<:<10>tapename = :>,
string mtrecord.mtname(increase(i)));
if mtrecord.mtname(1) = name(1) and
mtrecord.mtname(2) = name(2)
then finis:=true else
swoprec6(mtrecord,mtrsize);
end;
if antal <= tapeantal and mtrecord.mtnr <> -1 then
begin
bitno:=(antal-1) mod 24;
bitpattern:= 1 shift (bitno);
wordno:= ((antal-1)//24)+startofbit;
removedumpbit;
mtrecord.mtnr:=-1;
mtrecord.mtdate:=-1;
mtrecord.mttotal:=-1;
write(out,<:<10> mttape is removed:>);
end else error(10);
end;
if insert then
begin
setposition(mtrecord,0,0);
swoprec6(mtrecord,2);
tapeantal:=mtrecord.pantal;
i:=1;
finis:=false;antal:=0;
while antal <= tapeantal and -, finis do
begin
antal:=antal+1;
swoprec6(mtrecord,mtrsize);
i:=1;if test then
write(out,<:<10>tapename = :>,string mtrecord.mtname(increase(i)));
if mtrecord.mtname(1) = name(1) and mtrecord.mtname(2) = name(2)
then finis:=true else
end;
if antal <= tapeantal then
begin
if mtrecord.mtnr = -1 then
begin
mtrecord.mtdate:=date;
mtrecord.mttotal:=if total then 1 else 0 + 1 shift 10;
mtrecord.mtnr:=antal ;
end else error(11);
end else
begin
nr:=antal;
while antal > 0 and tapeantal > 0 do
begin
antal:=antal-24;tapeantal:=tapeantal-24;
end;
if tapeantal=0 and antal > 0 then
begin
comment
**********************************************************
* *
* Det er nødvendig at omorganisere dumpcat *
* *
********************************************************** ;
newdumpensize:=dumpensize+2;
i:=1;dump2name(1):= real <:dump2:> add 99;
dump2name(2):= real <:at:>;
open(cat1,4,string dump2name(increase(i)),0);
i:=1;open(cat,4,string dump1name(increase(i)),0);
if monitor(42)lookup entry:(cat1,0,tail) = 0 then
monitor(48)remove entry:(cat1,0,t1tail);
tail(1):=hashentries;
tail(2):=1;
tail(5):=0;tail(3):=0;tail(4):=0;
tail(9):=11 shift 12;
if monitor(40)create entry:(cat1,0,tail) <> 0 then error(6);
initnewcat;
setposition(cat1,0,0);setposition(cat,0,0);
if test then write(out,<:<10>hahsentries=:>,
hashentries);
for j:= 0 step 1 until hashentries-1 do
begin
setposition(cat,0,j);
swoprec6(cat,2);
noondump:=cat.key;
if test then write(out,<:<10>nr =:>,j);
sumofhash:=sumofhash+noondump;
if test then write(out,<:<10>noondump=:>,noondump);
cat1nr:=1;
for i:=1 step 1 until noondump do
begin
rhashentry;
while cat.catnr = -1 do rhashentry;
if cat.dname(1) <> -1 then
begin
dkey:=hashkey(cat.dname);
setposition(cat1,0,dkey);
swoprec6(cat1,2);
if test then write(out,<:<10>catnr= :>,cat1nr);
cat1.catnr:=noondump;
for ik:=1 step 1 until
cat1nr do swoprec6(cat1,newdumpensize);
tofrom(cat1,cat,dumpensize);
cat1.key:=cat.key;
cat1.wordno1:=0;
cat1nr:=cat1nr+1;
end;
end;
end;
close(cat1,true);close(cat,true);
if test then write(out,<:<10>antal hashindgange i hashcatalog =:>,
sumofhash);
i:=1;open(cat,4,string dump2name(increase(i)),0);
close(cat,true);
monitor(42)lookup entry:(cat,0,tail);
dumpensize:=newdumpensize;
tail(10):=newdumpensize;
monitor(44)change entry:(cat,0,tail);
dump1name(1):=dump2name(1);dump1name(2):=dump2name(2);
end;
mtrecord.mtnr:=nr;
mtrecord.mtname(1):=name(1);
mtrecord.mtname(2):=name(2);
mtrecord.mtdate:=date;
mtrecord.mttotal:=if total then 1 else 0+ 1 shift 10;
write(out,<:<10> mttape is inserted:>);
setposition(mtrecord,0,0);
swoprec6(mtrecord,2);
mtrecord.pantal:=mtrecord.pantal+1;
end;
end;
i:=1;
open(cat,4,string dump1name(increase(i)),0);
tail(1):=hashentries;
tail(6):=date;
tail(10):=dumpensize;
tail(9):=11 shift 12;
i:=monitor(44)change entry:(cat,0,tail);
if test then write(out,<:<10>result of change entry= :>,i);
i:=monitor(50)permanent entry:(cat,3,tail);
if test then write(out,<:<10>result of permanent entry =:>,i);
if i <> 0 then error(9);
i:=1;open(cat1,4,string dumpname(increase(i)),0);
close(cat1,true);
i:=monitor(48)remove entry:(cat1,0,tail);
if test then write(out,<:<10>result of remove entry =:>,i);
if i<> 0 then error(9);
tadocname:=0;
tail.tadocname(1):= dumpname(1);
tail.tadocname(2):= dumpname(2);
i:= monitor(46)rename entry:(cat,0,tail) ;
if test then write(out,<:<10>result of rename entry = :>,i);
if i <> 0 then error(9);
close(mtrecord,true);
i:=monitor(50)permanent entry:(mtrecord,3,tail);
if test then write(out,<:<10>result of permanent entry = :>,i);
if i<> 0 then error(8);
i:=1;open(mt1record,4,string mtpool(increase(i)),0);
close(mt1record,true);
i:=monitor(48)remove entry:(mt1record,0,tail);
if test then write(out,<:<10>result of remove entry = :>,i);
if i<> 0 then error(8);
tail.tadocname(1):= mtpool(1);
tail.tadocname(2):= mtpool(2);
i:= monitor(46)rename entry:(mtrecord,0,tail) ;
if test then write(out,<:<10> result of rename entry = :>,i);
if i <> 0 then error(8);
write(out,<:<10>update ok :>,<:<10>:>);
halt:
fpproc(7)end_of_program:(0,0,0);
end;
▶EOF◀