|
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: 16128 (0x3f00)
Types: TextFile
Names: »tlooksave«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tlooksave«
looksave=algol connect.no xref.no blocks.no list.no
begin
message vk 1981.11.29 looksave;
zone dumpcat,mtrecord(128,1,stderror);
boolean all,maxbase,finis,scopeall,t1test,test,found1,outp,b1,
basespec,error1,found2,found,scopelogin,scopeuser,scopeproj,
listed,names;
integer i,k,restondump,ensize,base1,base2,permkey,fpno,key,
antal,j,bit,ik,gdate,hashentries,il,pk,number,nrtotal,ntotal,mtrsize,
bittsize,nooftapen,dumpensize,nr,firstno,antale,antalf,outres,noonhash,
more,ii,baselower,baseupper,kk,q;
integer field lbase,ubase,date,pantal,
total,wordno,bittstart,
dumpkey,mttapenr,mtdate;
long array input,dumpname,mtpool,enname(1:2);
real array outarr(1:3);
long array field name,lo;
integer array interval(1:8),tail(1:10);
\f
procedure error(errorno);integer errorno;
begin
case errorno of
begin
<*1*>write(out,<:<10>Savecat does not exist:>);
<*2*>write(out,<:<10>Mtpool does not exist:>);
<*3*>write(out,<:<10>Savecat inconsisten:>);
<*4*>write(out,<:<10>Param error:>);
end;
write(out,<:<10>looksave not ok :>,<:<10>:>);
goto halt;
end;
\f
integer procedure readparam(val);long array val;
begin
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
procedure outtape;
begin
procedure outshortclock(shortclock);integer shortclock;
begin
real r2;
integer r1;
r1:=shortclock;
write(out,<: date :>,<<zddddd.dddd>,systime(6,r1,r2)+r2/1000000);
end;
integer ii,i1;
write(out,"nl",1);
write(out,<:on:>,"sp",2);
write(out,<: :>);
i1:=write(out, mtrecord.name);
write(out,"sp",12-i1);
if mtrecord.total extract 3 = 1
then write(out,<:total :>) else write(out,<:daily :>);
write(out,<:save tape :>);
outshortclock(mtrecord.mtdate);
if mtrecord.total shift (-10) extract 1 = 0 then
write(out,<: continuation tape:>);
end;
procedure rhashentry;
begin
k:=inrec6(dumpcat,0);
if k = 0 then
begin
setposition(dumpcat,0,0);
inrec6(dumpcat,2);
end;
if test then write(out,<:<10> k=:>,k);
if k = 512 then inrec6(dumpcat,2);
if k = restondump then
begin
inrec6(dumpcat,k);
k:=inrec6(dumpcat,0);
if -,names then
begin
more:=noonhash+10;
finis:=true;
if test then write(out,<:<10>finis= true:>);
end;
if k=0 then
setposition(dumpcat,0,0);
inrec6(dumpcat,2);
inrec6(dumpcat,dumpensize);
end else
inrec6(dumpcat,dumpensize);
more:=more+1;
end;
\f
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);
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(30)unstack out:(0,out,outarr);
end;
end;
\f
procedure readfp;
begin
real array field rf;
rf:=0;
if test then
begin
write(out,<:<10>input = :>, input);
write(out,<:<10>fpno =:>,fpno);
end;
if fpno = - 1 then
begin
openout;
fpno:=readparam(input);
end;
if input(1) = long <:all:> then
begin
fpno:=readparam(input);
if fpno = 4 then
begin
if input(1) = long <:yes:> then all:= true else
if input(1) = long <:no:> then all:=false else error(4);
fpno:=readparam(input);
if fpno <> 0 then
begin
if antale = 0 then antalf:=antalf+1;
names:=true;
enname(1):=input(1);enname(2):=input(2);
end;
end else begin names:=true;
if antale = 0 then antalf:=antalf+1;
q:=q-1;
enname(1):=long <:all:>;enname(2):=long<::>;
end;
end;
if input(1) = long <:scope:> then
begin
fpno:=readparam(input);
if fpno = 4 then
begin
scopeall:=false;
if test then write(out,<:<10> scope spec:>);
if input(1) = long <:login:> then scopelogin:=true else
if input(1) = long <:user:> then scopeuser:=true else
if input(1) = long <:proje:> add 99 and
input(2) = long <:t:> then
begin
scopeproj:=true;
end else
if input(1) = long <:own:> then scopeall:=true else error(4);
fpno:=readparam(input);
if fpno <> 0 then
begin
if antale = 0 then antalf:=antalf+1;
names:=true;
enname(1):=input(1);enname(2):=input(2);
end;
end else begin names:=true;
q:=q-1;
enname(1):= long <:scope:>;enname(2):=long<::>;
if antale = 0 then antalf:=antalf+1;
end;
end;
if input(1) = long <:base:> then
begin
fpno:=readparam(input);
if fpno = 3 then
begin
scopeall:=false;basespec:=true;permkey:=3;
baselower:=input.rf(1);
readparam(input);
baseupper:=input.rf(1);
fpno:=readparam(input);
if fpno <> 0 then
begin
if antale = 0 then antalf:=antalf+1;
names:=true;
enname(1):=input(1);enname(2):=input(2);
end;
end else begin names:=true;
q:=q-1;
if antale = 0 then antalf:=antalf+1;
enname(1):=long <:base:>;enname(2):=long <::>;
end;
end;
if test then
begin
if all then
write(out,<:<10>all true:>) else write(out,<:<10>all false:>);
if scopeall then write(out,<:<10>scopeall true:>)
else write(out,<:<10>scopeall false:>);
end;
end;
\f
integer procedure hashkey(hname);long 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:= 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 listtape;
begin
listed:=true;
open(mtrecord,4, mtpool,0);
if monitor(42)lookup entry:(mtrecord,0,tail) <> 0 then error(2);
inrec6(mtrecord,2);
nrtotal:=number:=mtrecord.pantal;
nooftapen:=0;
bittsize:=((nrtotal-1)//24)+1;
begin
integer array tapenr(0:nrtotal-1,1:2);
for k:=1 step 1 until 2 do
begin
for i:=0 step 1 until nrtotal-1 do tapenr(i,k):=-1;
end;
write(out,"nl",2);
ii:=write(out, dumpcat.name);
write(out,"sp",12-ii,<: scope.:>);
i:=0;
if dumpcat.lbase = interval(3) and dumpcat.ubase = interval(4)
and dumpcat.dumpkey extract 3 = 2 then i:=write(out,<:login :>);
if dumpcat.lbase = interval(5) and dumpcat.ubase = interval(6)
and dumpcat.dumpkey extract 3 = 3
and i = 0 then i:=write(out,<:user :>);
if dumpcat.lbase = interval(7) and dumpcat.ubase = interval(8)
and dumpcat.dumpkey extract 3 = 3
and i = 0 then i:=write(out,<:project:>)
else
if -,(dumpcat.lbase > interval(7)) and
-,(dumpcat.ubase < interval(8)) and i = 0
then i:=write(out,<:system :>);
if i = 0 then write(out,<:*** :>);
if dumpcat.dumpkey > 3 then write(out,<: area :>)
else write(out,<: entry :>);
write(out,<: key.:>,<<d>,dumpcat.dumpkey extract 3);
write(out,"sp",3,dumpcat.lbase,"sp",2,dumpcat.ubase);
found2:=true;
for i:=0 step 1 until bittsize-1 do
begin
wordno:=i*2+bittstart;
for j:=1 step 1 until 24 do
begin
bit:=dumpcat.wordno extract j shift (-j+1);
if bit = 1 and test then write(out,<:<10>bitno=:>,j-1);
if bit = 1 then
begin
if nooftapen = 0 then firstno:=j-1;
nooftapen:=nooftapen+1;
tapenr(j-1+i*24,1):=j-1+i*24;
end;
end;
end;
if test then write(out,<:<10>antal baand =:>,nooftapen);
inrec6(mtrecord,mtrsize);
gdate:=-2;ntotal:=0;nr:=0;
for i:=0 step 1 until nrtotal-1 do
begin
if gdate < mtrecord.date and mtrecord.total extract 1 = 1 then
begin
gdate:=mtrecord.date;
nr:=mtrecord.mttapenr;
end;
if mtrecord.total = 17 then
begin
gdate:=mtrecord.date;nr:=mtrecord.mttapenr;
inrec6(mtrecord,mtrsize);
while mtrecord.total = 1 do
begin
inrec6(mtrecord,mtrsize);
ntotal:=ntotal+1;
end;
end else
begin
inrec6(mtrecord,mtrsize);
ntotal:=ntotal+1;
end;
end;
for i:= 0 step 1 until nrtotal-1 do
begin
if tapenr(i,1) <> -1 then
begin
setposition(mtrecord,0,0);
inrec6(mtrecord,2);
for j:=1 step 1 until i+1 do
inrec6(mtrecord,mtrsize);
tapenr(i,1):=mtrecord.date;
tapenr(i,2):=mtrecord.total extract 1;
end;
end;
for ii:= 0 step 1 until 1 do
begin
for i:= 0 step 1 until nrtotal-2 do
begin
j:=0;ik:=0;
for kk:=0 step 1 until nrtotal-2 do
begin
if tapenr(kk,1) <> -1 and j = 0 and tapenr(kk,2) = ii then
begin
j:=kk;ik:=1;
end;
if tapenr(kk+1,1) <> -1 and tapenr(kk+1,2) = ii then
begin
if tapenr(j,1) < tapenr(kk+1,1) and
tapenr(kk+1,2) = ii then
begin
j:=kk+1;
ik:=1;
end;
end;
end;
if ik <> 0 then
begin
setposition(mtrecord,0,0);
inrec6(mtrecord,2);
for k:= 1 step 1 until j+1 do inrec6(mtrecord,mtrsize);
outtape;
if -, all then i:=nrtotal-1;
tapenr(j,1):=-1;
end;
end;
end;
end;
close(mtrecord,true);
end;
\f
procedure findentry;
begin
more:=1;
if test then write(out,<:<10>key = :>,key);
setposition(dumpcat,0,key);
inrec6(dumpcat,2);
noonhash:=dumpcat.pantal;
if test then
write(out,<:<10>key=:>,key);
if test then write(out,<:<10>noonhash = :>,noonhash);
finis:=false;
while -, finis do
begin
if test then write(out,<: noonhash = :>,noonhash);
if noonhash = 0 then
finis:=true else
begin
while noonhash >= more do
begin
rhashentry;
while dumpcat.pantal=-1 do rhashentry;
if finis then goto stop;
if (-,names and more<=noonhash) or dumpcat.name(1) = enname(1) and
dumpcat.name(2) = enname(2) then
begin
if test then write(out,<:entry found:>);
if -,scopeall then
begin
if scopelogin and dumpcat.lbase = base1 and
dumpcat.ubase = base2 and dumpcat.dumpkey extract 3 = 2
then
begin
listtape;
if names then finis:=true;
end
else
if -,scopelogin and
dumpcat.lbase = base1 and dumpcat.ubase = base2
and dumpcat.dumpkey extract 3 = 3 then
begin
listtape;
if names then finis:=true;
end;
end;
if scopeall then
begin
if -,(dumpcat.lbase > interval(1)) and
-,(dumpcat.ubase < interval(2))
then
listtape else
if dumpcat.lbase > interval(1) and dumpcat.ubase < interval(2)
then listtape;
end;
end;
if more > noonhash then
begin
if -,listed and names then
begin
listed:=true;
write(out,<:<10>*** entry :>,
enname,<: does not exist in savecat:>);
end;
finis:=true;
end;
end;
end;
end;
stop:
end *** findentry;
q:=0;
scopelogin:=false;scopeuser:=false;scopeproj:=false;
names:=false;
error1:=false;
t1test:=false;;test:=false;
if test then write(out,<:<10> readfp called:>);
outp:=false;
all:=false;basespec:=false;
scopeall:=true;
mtpool(1):= long <:mtpoo:> add 108;
mtpool(2):= long <::>;
dumpname(1):= long <:savec:> add 97;
dumpname(2):= long <:t:>;
mtrsize:=16;
date:=12;
restondump:=10;
lo:=0;
name:=2;
bittstart:=18;
mttapenr:=2;
mtdate:=12;
lbase:=12;
ubase:=14;
dumpkey:=16;
total:=14;
pantal:=2;
antale:=0;antalf:=0;
system(11)get catalog base:(0,interval);
fpno:= readparam(input);
if fpno = -1 then readfp;
for fpno:=readparam(input) while fpno <> 0 do
begin
enname(1):=input(1);enname(2):=input(2);
if input(1) = long <:all:> or input(1) = long <:scope:>
or
input(1) = long <:base:>
then readfp else
begin
antalf:=antalf+1;
names:=true;
end;
end;
q:=0;
fpno:=readparam(input);
if fpno = - 1 then readparam(input);
antale:=antale+1;
fpno:=readparam(input);
repeat
begin
if input(1) = long <:all:> or input(1) = long <:scope:>
or input(1) = long <:base:> then readfp else
begin
enname(1):= input(1);enname(2):=input(2);
end;
begin
listed:=false;
maxbase:=false;
found1:=false;b1:=false;
nooftapen:=0;
firstno:=0;
if test then
begin
write(out,<:<10>key=:>,key);
write(out,<:navn =:>, enname);
end;
open(dumpcat,4, dumpname,0);
i:=monitor(42)lookup entry:(dumpcat,0,tail);
if i <> 0 then error(1);
if tail(9) shift (-12) <> 11 then error(3);
if tail(10) = 0 then dumpensize:=18 else dumpensize:=tail(10);
if tail(1) = 0 then hashentries:=217 else hashentries:=tail(1);
restondump:=510 mod dumpensize;
if names then
key:=hashkey(enname);
if test then write(out,<:<10>key = :>,key);
if basespec then
begin
base1:=baselower;base2:=baseupper;
end;
if scopelogin then
begin
base1:=interval(3);base2:=interval(4);
end;
if scopeuser then
begin
base1:=interval(5);base2:=interval(6);
end;
if scopeproj then
begin
base1:=interval(7);base2:=interval(8);
end;
if names then findentry else
begin
for key:= 0 step 1 until hashentries-1 do findentry;
end;
end;
close(dumpcat,true);
antalf:=antalf-1;
fpno:=readparam(input);
end
until antalf = 0 or -,names;
closeout;
halt:
fpproc(7)end_of_program:(0,0,0);
end;
▶EOF◀