|
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: 48384 (0xbd00)
Types: TextFile
Names: »tsave«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦ebd72877b⟧ »tfput«
└─⟦this⟧
begin
procedure program(out); zone out;
begin
message rc 1978.03.17 save;
boolean infile;
zone entry(128,1,caterror), zhelp(1,1,stderror);
array input(1:4),fpparam(1:2);
integer array iarr(1:20),modekind,entrybase(1:2);
integer segm,sep,fpno,paramnos,spacename,pointname,
pointinteger,i,catalogs,ownbase1,ownbase2,errors,rejected;
real ownname1, ownname2;
procedure caterror(z,s,b);
zone z;
integer s,b;
if s shift (-18) extract 1=1 then b:=34 else
if s shift (-2) extract 1=0 then stderror(z,s,b);
procedure nextfp;
begin
fpno:=fpno+1;
if infile then readfp else sep:=system(4,fpno,fpparam);
end nextfp;
procedure lastfp;
begin
fpno:=fpno-1;
sep:=system(4,fpno,fpparam);
end lastfp;
procedure readfp;
begin
integer cl,val,i;
real r;
begin
i:=0;
sep:=10;
for cl:=readchar(entry,val)
while cl<>2 and cl<>6 and val<>25 do sep:=val;
sep:=if val=25 then 0 else
(if sep=46 then 8 else if sep=10 or sep=32 then 4 else 1)
shift 12 add (if cl=2 then 4 else 10);
if cl=2 then
begin
repeatchar(entry);
read(entry,fpparam(1))
end
else
if cl=6 then
begin
fpparam(1):=fpparam(2):=r:=real<::>;
for i:=i+1 while (cl=2 or cl=6) do
begin
r:=r shift 8 add val;
if i=6 then
begin
fpparam(1):=r;
r:=real<::>
end;
cl:=readchar(entry,val);
end
end;
if i>12 then sep:=1;
if i<>0 and i<>7 then
fpparam(if i<=6 then 1 else 2):=
r shift (8*(7-(if i mod 6=0 then 6 else i mod 6)));
repeatchar(entry);
end
end readfp;
infile:=false;
sep:=system(4,1,fpparam);
if sep<>6 shift 12+10 then system(4,0,fpparam);
i:=1;
open(entry,0,string fpparam(increase(i)),0);
monitor(76)lookup head and tail:(entry,0,iarr);
close(entry,false);
ownname1:=fpparam(1);
ownname2:=fpparam(2);
ownbase1:=iarr(2);
ownbase2:=iarr(3);
segm:=iarr(14) shift (-8) extract 4;
open(zhelp,0,<::>,0);
system(5)move core area:(92,iarr);
catalogs:=(iarr(3)-iarr(1))/2-1;
fpno:=if sep<>6 shift 12+10 then 0 else 1;
comment ignore lefthand side;
pointname:=8 shift 12+10;
pointinteger:=8 shift 12+4;
spacename:=4 shift 12 + 10;
paramnos:=-1;
nextfp;
for sep:=sep while sep<>0 do
begin
if sep=spacename then paramnos:=paramnos+1;
nextfp
end;
lastfp;
if sep=pointname then
begin
lastfp;
if sep=spacename and fpparam(1)=real<:in:> then
begin
nextfp;
i:=1;
input(1):=fpparam(1);
input(2):=fpparam(2);
open(entry,4,string input(increase(i)),0);
i:=1;
if monitor(76)lookup head and tail:(entry,0,iarr)<>0 then
begin
write(out,<:<10>***save, infile :>,
string input(increase(i)),<: unknown:>);
goto savenotok
end;
for i:=0,i+1 while readstring(entry,fpparam,1)<>0 do;
paramnos:=paramnos-2+i;
end
end;
close(entry,true);
fpno:=if paramnos<1 then 1 else paramnos;
begin
boolean listnames,listmore,ok,endtape,sysdump,sp,hard,bodoc,release,
missingclock;
integer i,j,k,paramno,copies,volumes,actualkitno,permkey,
scopekey,entryno,segmno,totalsegm,actualscope,
actualnewscope,vol,cop,blocksize,block,posvol,size1,size2,free,buf,sum,const;
long interval1,interval2,interval3,interval4,interval5,
interval6,interval7,interval8,interval9,interval10,
entrybase1,entrybase2;
real r,scopedoc1,scopedoc2;
integer field keys,kind,shortclock,contents;
integer array field base;
real array field tail,name,docname,raf;
boolean array labelparam(1:2);
integer array fileno,date,hour,startfp(1:2),interval(1:10),
device(1:2),param,fpscope,fpnewscope,fpkitno(1:fpno),slices,segm_pr_slice,entries(-1:catalogs);
array catname(-1:catalogs,1:4),tapenames,dumplabelname(1:2,1:2),
fpname,fpdocname(1:fpno,1:2);
long array field document;
real procedure dumplabel(i,type);
integer i;
integer type;
begin
real spaces,stop;
comment returns the ith real of a dumplabel
1 : dump
2-3 : tapename
4 : fileno
5 : empty , vers. og cont.
6 : date
7 : hour
8 : segments
9-10 : dumplabelname
11 : in.
12-13: infile
14: nl
15: em
the dumplabel is a textstring which may be read by edit;
real procedure convintg(n);
value n;
integer n;
comment converts a non negative integer
to a textportion with the layout <<zddddd>;
convintg:= if n < 10 then real<:00000:> add (n+48)
else convintg(n//10) shift 8 add (n mod 10 + 48);
real procedure spacefill(text);
value text;
real text;
begin
comment spacefill will replace trailing nulls by spaces;
integer i;
if text = real<::> 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:=real<: :> add 32;
stop:=real<:<10>:>;
dumplabel:= case i of (
spacefill(real<:dump:>),
spacefill(tapenames( cop, 1)),
spacefill(tapenames( cop, 2)),
spacefill(convintg(fileno(cop))shift 24),
spacefill(case type of(real<:vers.:>,real<:empty:>,real<:cont.:>)),
convintg(date(cop)),
spacefill(real<: .:> add
(convintg(hour(cop)) extract 16) shift 24),
if type=2 then spaces else
spacefill(real<:s=0:> shift (-24) add segm shift 24),
if (dumplabelname(cop,1)=spaces or dumplabelname(cop,1)=stop)
and -,infile then stop else spacefill(dumplabelname(cop,1)),
if (dumplabelname(cop,2)=spaces or dumplabelname(cop,2)=stop
or dumplabelname(cop,2)=real<::>)
and -,infile then stop else spacefill(dumplabelname(cop,2)),
if infile then real<: in:> add 46 else stop,
if infile then spacefill(input(1)) else stop,
if infile then spacefill(input(2)) else stop,
stop,real<:<25>:> shift (-8));
end dumplabel;
procedure writelabel(type);
integer type;
comment writes and prints a label;
begin
integer i;
zone zlabel(25, 1, error);
procedure error(z,s,b); zone z; integer s,b;
if s shift 5>=0 then stderror(z,s,b); <*ignore eot*>
real r;
i:= 1;
open(zlabel, modekind(cop), string tapenames(cop,increase(i)),0);
systime(1, 0, r);
date(cop):= systime(2, r, r);
hour(cop):= r/10000 - 0.3;
setposition(zlabel, if type=3 then 1 else fileno(cop), 0);
outrec6(zlabel, 4*25);
for i:= 1 step 1 until 15 do zlabel(i):= dumplabel(i,type);
for i:=16 step 1 until 25 do zlabel(i):=real<::>;
i:=1;
write(out,<:<10>written::>,
if infile then <:<10>:> else <: :>,
string zlabel(increase(i)));
if type=3 then
zlabel(25):=real<::> add entryno shift 24 add (segmno-1);
close(zlabel,if release and type=2 then false add 1 else false);
end writelabel;
procedure readlabel;
comment readlabel reads, lists and checks a dumplabel if any;
begin
integer i,modecase;
boolean last;
zone zlabel(25,1,nodump); integer array ia(1:8);
procedure nodump(z,s,b);
zone z;
integer s,b;
begin
b:=0;
if s shift (-14) extract 1=0 then alarm3(0);
if modecase=0 then
begin
modecase:=1;
setposition(zlabel,0,0);
setposition(zlabel,0,0);
modecase:=2;
goto next
end
else
if modecase=2 then
begin
write(out,<:<10>***save mode error:>);
goto savenotok
end;
end nodump;
procedure alarm3(i);
integer i;
begin
if i=0 then
begin
write(out,<:<10>no dumplabel on file:>,fileno(cop));
goto exitreadlabel
end;
write(out,<:<10>***save: :>);
write(out,<:dumplabel :>,
case i of (<:tapename:>,
<:fileno:>,
<:version label: file already used by save:>));
goto savenotok
end alarm3;
i:=1;
last:=fileno(cop)=0;
if last then fileno(cop):=1;
mount_med_ring;
open(zlabel,modekind(cop),string tapenames(cop,increase(i)),0);
modecase:=0;
next:
setposition(zlabel,fileno(cop),0);
i:=inrec6(zlabel,0);
if i<>100 then alarm3(0) else inrec6(zlabel,100);
if zlabel(1)<>dumplabel(1,1) then alarm3(0);
if last and (zlabel(5)=dumplabel(5,1) or zlabel(5)=dumplabel(5,3)) then
begin
fileno(cop):=fileno(cop)+1;
goto next
end;
comment repair old versions of dumplabels;
for i:=9 step 1 until 14 do
if zlabel(i)=real<:<10><25>:> then zlabel(i):=real<:<10>:>;
i:=1;
write(out,if zlabel(11)=real<:<10>:> then <:<10>read : :>
else <:<10>read:<10>:>,string zlabel(increase(i)));
if zlabel(4)<>dumplabel(4,1) then alarm3(2);
if -,labelparam(cop) and zlabel(5)=dumplabel(5,1) then
alarm3(3);
if -,labelparam(cop) then
begin
dumplabelname(cop,1):=zlabel(9);
dumplabelname(cop,2):=zlabel(10);
end;
exitreadlabel:
close(zlabel,false);
end readlabel;
procedure mount_med_ring;
begin integer array ia(1:12),m(1:8);
integer i;
zone z(128,1,stderror);
m(5):=tapenames(cop,1) shift (-24) extract 24;
m(6):=tapenames(cop,1) extract 24;
m(7):=tapenames(cop,2) shift (-24) extract 24;
m(8):=tapenames(cop,2) extract 24;
i:=1; open(z,0,string tapenames(cop,increase(i)),0);
if monitor(4)process descr:(z,0,ia)=0 then
begin
m(1):=16<*opmess*> shift 12;
m(2):=real<:rin:> shift (-24) extract 24;
m(3):=real<:g:> shift (-24) extract 24;
m(4):=32 shift 16;
system(10,0,m);
end;
sense:
monitor(6)initialize process:(z,0,ia);
getshare6(z,ia,1);
ia(4):=0 <*sense*>;
setshare6(z,ia,1);
monitor(16)send mess:(z,1,ia);
if monitor(18)wait answ:(z,1,ia)<>1<*not normal*> then
begin <*not mounted*>
ia(1):=(if device(cop)=0 then 14 shift 12 else
32 shift 12 + 1 shift 9) + 1 shift 0;
ia(2):=real<:mou:> shift (-24) extract 24;
ia(3):=real<:nt:> shift (-24) extract 24;
ia(4):=device(cop);
for i:=5 step 1 until 8 do ia(i):=m(i);
system(10,0,ia);
goto sense
end
else
begin <*test om ring*>
if ia(1) shift (-15) extract 1=0 then
begin
close(z,false);
i:=1;
open(z,modekind(cop),string tapenames(cop,increase(i)),0);
ia(1):=18<*ring*> shift 12 + 1 shift 0;
ia(2):=real<:rin:> shift (-24) extract 24;
ia(3):=real<: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;
boolean procedure findentryscope(actualscope,owns);
integer actualscope;
boolean owns;
comment returns the actual scope of the entry;
begin
boolean found;
integer no;
no:=0;
for i:=8 step -1 until 5 do
if no=0 then
begin
if (case 9-i of (permkey=0 and
entrybase1=interval1 and entrybase2=interval2,
permkey=2 and
entrybase1=interval3 and entrybase2=interval4,
permkey=3 and
entrybase1=interval5 and entrybase2=interval6,
permkey=3 and
entrybase1=interval7 and entrybase2=interval8))
then no:=i
end;
found:=no<>0;
if -,found and -,owns then
begin
found:=permkey=3 and
entrybase1=interval9 and entrybase2=interval10;
if found then no:=3
end;
actualscope:=no;
findentryscope:=found
end findentryscope;
procedure listentry(bo);
boolean bo;
begin
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,sp,
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;
monitor(72,zhelp,0,interval);
i:=1;
if bo then
begin
write(out,<:<10>:>);
write(out,sp,(if listmore then 11 else 0)
-write(out,string entry.name(increase(i))));
end;
if listmore then
begin
if entry.kind<0 then outmodekind
else
write(out,<< dddd>,entry.kind,sp,2);
if sysdump then write(out,<<d>,permkey,<:.:>)
else write(out,case scopekey-2 of (
<: system.:>,<::>,
<:project.:>,
<: user.:>,
<: login.:>,
<: temp.:>));
k:=entry.docname(1) ;
j:=1;
i:=if k=0.0 or k=1.0 then write(out,<<d>,k) else
write(out,string entry.docname(increase(j)));
write(out,sp,11-i);
if sysdump then
begin
write(out,
<< -ddddddd>,entry.base(1),entry.base(2));
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;
integer procedure findkitno;
begin
integer i;
findkitno:=-2;
for i:=-1 step 1 until catalogs do
if fpparam(1)=catname(i,1) and
fpparam(2)=catname(i,2) then findkitno:=i;
end findkitno;
procedure getmtname(file);
integer file;
begin integer i;
zone zhelp(1,1,stderror);
file:=-1;
i:=1;
open(zhelp,0,string fpparam(increase(i)),0);
i:=monitor(42)lookup entry tail:(zhelp,0,iarr);
if i=0 and iarr(1) extract 12=18 then
begin
modekind(cop):=iarr(1) extract 23;
fpparam(1):=real<::> add iarr(2) shift 24 add iarr(3);
fpparam(2):=real<::> add iarr(4) shift 24 add iarr(5);
file:=iarr(7);
end;
close(zhelp,true)
end getmtname;
begin
comment read fpparameters;
integer min;
real array catalog(1:2);
integer array help(1:1);
integer procedure findscopeno;
begin
integer i,j;
i:=0;
for j:=1 step 1 until 9 do
if fpparam(1)=real (case j of (<:all:>,
<:perm:>,
<:syste:> add 109,
<:own:>,
<:proje:> add 99,
<:user:>,
<:login:>,
<:temp:>,
<:std:>))
then i:=j;
if i=5 and fpparam(2)<>real<:t:> then i:=0;
findscopeno:=i;
end findscopeno;
procedure listfp;
begin long array field laf;
laf:=0;
for sep:=sep while sep<>0 do
begin
write(out,if sep shift (-12)=8 then <:.:> else <: :>);
if sep extract 12=10 then write(out,fpparam.laf)
else write(out,<<d>,fpparam(1));
nextfp;
end
end listfp;
procedure readtapeparams;
begin
integer lastsep,file;
procedure alarm1;
begin
write(out,<:<10>***save: error in tapeparam: :>);
listfp;
goto savenotok;
end alarm;
lastsep:=sep;
if sep=0 and copies=1 then goto exitreadtapeparam;
copies:=copies+1;
cop:=copies;
modekind(cop):=18;
if false then
mountspecif:
nextfp;
r:=fpparam(1);
if r=real<:mount:>add<*s*>115 and
fpparam(2)=real<:pec:> then
begin
nextfp;
if sep<>pointinteger then alarm1;
device(cop):=fpparam(1);
goto mountspecif
end
else
if r=real<:mto:> or r=real<:nrz:> then
begin
modekind(cop):=(if r=real<:mto:> then 0 else 4)
shift 12 + 18;
goto mountspecif
end
else
if r=real<:relea:>add<*s*>115 and fpparam(2)=real<:e:> then
begin
nextfp;
r:=fpparam(1);
if sep<>pointname or
(r<>real<:yes:> and r<>real<:no:>) then alarm1;
release:=r=real<:yes:>;
goto mountspecif
end;
getmtname(file);
tapenames(copies,1):=fpparam(1);
tapenames(copies,2):=fpparam(2);
nextfp;
if lastsep<>spacename or (sep=pointinteger
and tapenames(copies,1)=real<:segm:>) or
-,(sep=pointinteger and (fpparam(1)<>0 and file=-1 or
file+fpparam(1)>0) or
sep=pointname and fpparam(1)=real<:last:>) then
begin
if (sep=pointname or sep=spacename or sep=0 or
tapenames(copies,1)=real<:segm:>) and copies=2 then
begin
copies:=1;
lastfp;
goto exitreadtapeparam
end
else
alarm1
end;
fileno(copies):=if sep=pointname then 0 else
if file=-1 then fpparam(1) else file+fpparam(1);
startfp(copies):=fpno-1;
nextvol:
nextfp;
if sep=spacename or sep=0 then goto exitreadtapeparam;
if sep<>pointname then alarm1;
r:=fpparam(1);
if r<>real<:label:> then
begin
volumes:=volumes+1;
if volumes>10 then alarm1;
goto nextvol
end;
more:
if fpparam(1)=real<:label:> then
begin
if labelparam(copies) then alarm1;
labelparam(copies):=true;
nextfp;
if sep<>pointname then alarm1;
dumplabelname(copies,1):=fpparam(1);
dumplabelname(copies,2):=fpparam(2);
end
else alarm1;
nextfp;
if sep=pointname or sep=pointinteger then goto more;
exitreadtapeparam:
if copies=2 then
begin
if vol<>volumes then alarm1
end;
end readtapeparams;
procedure alarm2;
begin
write(out,<:<10>***save: error in param: :>);
listfp;
goto savenotok;
end alarm2;
for i:= 0 step 1 until catalogs do entries(i):= slices(i):= 0;
for i:=1,2 do for j:=1,2 do
tapenames(i,j):=real<::>;
labelparam(1):=labelparam(2):=false;
dumplabelname(1,1):=dumplabelname(1,2):=
dumplabelname(2,1):=dumplabelname(2,2):=real<: :> add 32;
date(1):=date(2):=hour(1):=hour(2):=0;
device(1):=device(2):=0;
name:=6;
docname:=16;
shortclock:=26;
contents:=32;
keys:=2;
base:=2;
kind:=16;
tail:=14;
endtape:=sysdump:=false;
release:=true;
sp:=false add 32;
errors:=rejected:=0;
system(11)get interval:(0,interval);
interval1:=interval(1);
interval2:=interval(2);
interval3:=interval(3);
interval4:=interval(4);
interval5:=interval(5);
interval6:=interval(6);
interval7:=interval(7);
interval8:=interval(8);
interval9:=-8388607;
interval(9):=interval9;
interval10:=8388605;
interval(10):=interval10;
catname(-1,1):=catname(-1,3):=real<:main:>;
catname(-1,2):=catname(-1,4):=real<::>;
system(5)move core area:(92,iarr);
k:=iarr(1);
for j:= 0 step 1 until catalogs do
begin
system(5,k,help); k:= k + 2;
system(5,help(1)-18,iarr);
segm_pr_slice(j):= iarr(6);
catname(j,1):= catname(j,3):= real<::> add iarr(1) shift 24
add iarr(2);
catname(j,2):= catname(j,4):= real<::> add iarr(3) shift 24
add iarr(4);
end;
fpno:=0;
nextfp;
if sep<>6 shift 12+10 then fpno:=0;
nextfp;
paramno:=0;
if paramnos=-1 then alarm2;
copies:=0;
volumes:=1;
paramno:=1;
readtapeparams;
vol:=volumes;
volumes:=1;
paramno:=2;
readtapeparams;
volumes:=vol;
paramno:=copies-1;
listnames:=true;
listmore:=true;
blocksize:=8+512*segm;;
specialparam:
paramno:=paramno+1;
r:=fpparam(1);
i:=if r=real<:segm:> then 1 else
if r=real<:list:> then 2 else 3;
if i<3 then
begin
nextfp;
if i=1 then
begin
comment segm;
if sep<>pointinteger then lastfp else
begin
if fpparam(1)=0 or fpparam(1)>9 then alarm2;
segm:=fpparam(1);
blocksize:=8+512*segm;
nextfp;
goto specialparam;
end
end
else
begin
comment list;
if sep=pointinteger then alarm2;
r:=fpparam(1);
if r=real<:yes:> or r=real<:no:> or
r=real<:name:> or r=real<:names:> then
begin
listnames:=r<>real<:no:>;
listmore:=r=real<:yes:>;
nextfp;
goto specialparam
end
else
lastfp;
end;
end;
paramnos:=0;
actualnewscope:=4;
actualkitno:=-1;
loop:
if sep=0 then goto exitloop;
if sep shift (-12)<>4 then alarm2;
paramno:=paramno+1;
fpname(paramnos+1,1):=fpparam(1);
fpname(paramnos+1,2):=fpparam(2);
bodoc:=fpparam(1)=real<:docna:> add 109 and fpparam(2)=real<:e:>;
fpdocname(paramnos+1,1):=fpdocname(paramnos+1,2):=real<::>;
fpscope(paramnos+1):=0;
fpnewscope(paramnos+1):=actualnewscope;
fpkitno(paramnos+1):=actualkitno;
nextfp;
actualscope:=findscopeno;
if sep=0 or sep=spacename then paramnos:=paramnos+1
else
if sep=pointname and fpparam(1)=real<:scope:> then
begin
comment textscope;
nextfp;
if sep=0 or sep=spacename then
begin
if bodoc then goto docnameparam else alarm2
end;
paramnos:=paramnos+1;
actualscope:=findscopeno;
if actualscope>8 then alarm2;
fpscope(paramnos):=actualscope;
if actualscope=0 then
begin
if bodoc and fpparam(1)=real<:scope:> then
begin
fpname(paramnos,1):=fpname(paramnos,2):=real<::>;
fpdocname(paramnos,1):=real<:scope:>;
nextfp;
if sep<>pointname then alarm2;
actualscope:=findscopeno;
fpscope(paramnos):=actualscope;
if actualscope=0 or actualscope>8 then alarm2;
end
else
alarm2
end;
nextfp;
end
else
if fpname(paramnos+1,1)=real<:chang:> add 101 and
fpname(paramnos+1,2)=real<:kit:> then
begin
i:=findkitno;
if i=-2 and fpparam(1)=real<:all:> then i:=-1;
if i=-2 then alarm2;
nextfp;
if sep<>pointname and sep<>pointinteger then alarm2;
if sep=pointinteger and fpparam(1)>1 then alarm2;
catname(i,3):=fpparam(1);
if i=-1 then
for k:=0 step 1 until catalogs do
begin
catname(k,3):=fpparam(1);
catname(k,4):=fpparam(2);
end;
catname(i,4):=fpparam(2);
nextfp;
end
else
if fpname(paramnos+1,1)=real<:kit:> then
begin
actualkitno:=findkitno;
if actualkitno<-1 then alarm2;
nextfp
end
else
if fpname(paramnos+1,1)=real<:newsc:> add 111 and
fpname(paramnos+1,2)=real<:pe:> then
begin
if actualscope=9 then actualscope:=4;
if actualscope<4 then alarm2;
actualnewscope:=actualscope;
nextfp;
end
else
if fpname(paramnos+1,1)=real<:scope:> then
begin
paramnos:=paramnos+1;
fpscope(paramnos):=actualscope;
if actualscope>8 or actualscope=0 then alarm2;
fpname(paramnos,1):=fpname(paramnos,2):=real<::>;
nextfp
end
else
if bodoc then
begin
docnameparam:
paramnos:=paramnos+1;
fpname(paramnos,1):=fpname(paramnos,2):=real<::>;
fpdocname(paramnos,1):=fpparam(1);
fpdocname(paramnos,2):=fpparam(2);
nextfp;
if sep=pointname then
begin
if fpparam(1)<>real<:scope:> then alarm2;
nextfp;
if sep<>pointname then alarm2;
actualscope:=findscopeno;
if actualscope=0 or actualscope>8 then alarm2;
fpscope(paramnos):=actualscope;
nextfp;
end;
end
else
if fpname(paramnos+1,1)=real<:in:> and -,infile then
begin
nextfp;
if sep<>0 then begin paramno:=paramno+1; alarm2 end;
lastfp;
i:=1;
open(entry,4,string fpparam(increase(i)),0);
infile:=true;
nextfp;
end
else
alarm2;
goto loop;
exitloop:
if paramnos=0 then
begin
paramnos:=1;
fpscope(1):=7;
fpnewscope(1):=if actualnewscope=4 then 7 else actualnewscope;
fpkitno(1):=actualkitno;
fpname(1,1):=fpname(1,2):=
fpdocname(1,1):=fpdocname(1,2):=real<::>;
end;
close(entry,true);
for i:=1 step 1 until paramnos do
begin
param(i):=i;
fpscope(i):=fpscope(i)-
(if fpname(i,1)<>real<::> then 20 else
if fpdocname(i,1)<>real<::> then 10 else 0)
end;
for i:=1 step 1 until paramnos-1 do
begin
min:=fpscope(param(i));
k:=i;
for j:=i+1 step 1 until paramnos do
begin
cop:=fpscope(param(j));
if cop<min then
begin
min:=cop;
k:=j
end;
end;
if i<>k then
begin
min:=param(k);
param(k):=param(i);
param(i):=min
end;
end;
for i:=1 step 1 until paramnos do
fpscope(i):=fpscope(i)+
(if fpname(i,1)<>real<::> then 20 else
if fpdocname(i,1)<>real<::> then 10 else 0);
end parameterindlæsning;
open(entry,4,<:catalog:>,1 shift 18);
if monitor(52)create area process:(entry,0,iarr)>0 then
begin
write(out,<:<10>***save, create area process not possible:>);
goto savenotok
end;
vol:=1;
for cop:=1 step 1 until copies do
begin
readlabel;
writelabel(1);
end;
<*
1 buffer = segm*512.
if free core > (16000 bytes + 2 buffers) then
16000 bytes are reserved to avoid algolsegmentation
in central-loop and the remaining bytes are shared
between tape-zone and disc-zone as follows :
2 or 3 buffers available: 1 buffer for singlebuffered
tape-zone and the rest for single-
buffered disc-zone.
more than 3 buffers available: 2 buffers for doublebuffered
tape-zone and the rest for single-
buffered disc-zone.
if free core <= (16000 bytes + 2 buffers) then 1 buffer is reserved
for singlebuffered tape-zone and 1 buffer for singlebuffered disc-
zone.
*>
free:= system(2,0,input);
free:= if free > (16008+segm*512*2)
then free-16000
else segm*512*2 + 8;
buf:= if free < 4*segm*512 then 1 else 2;
size1:= buf*(2+segm*128);
size2:= (free-size1*4)//(segm*512)*segm*128;
begin
zone zbs(size2,1,harderror);
zone array ztape(copies,round(size1/copies)+(copies-1),buf*copies,tapeproc);
integer file,block;
procedure sterror(z,s,b);
zone z;
integer s,b;
begin
monitor(72)set catbase:(zhelp,0,interval);
stderror(z,s,b);
end sterror;
procedure tapeproc(z,s,b);
zone z;
integer s,b;
begin
if s shift (-18) extract 1=0 then sterror(z,s,b);
endtape:=true;
end tapeproc;
procedure changevol(int); integer int;
begin
integer i,j;
monitor(72,zhelp,0,interval);
if int=-1 then
write(out,<:<10>backspace to previous tape:>)
else
write(out,<:<10>tape shift:<10>:>,<<ddd>,entryno,
<: entr.,:>,<< ddddd>,totalsegm+segmno,<: segm.:>);
vol:=vol+int;
for cop:=1 step 1 until copies do
begin
outrec6(ztape(cop),blocksize);
changerec6(ztape(cop),100);
ztape(cop,1):=r:=real<::> add 4 shift 24 add 16;
ztape(cop,2):=real<::> add entryno shift 24
add (totalsegm+segmno);
fpno:=startfp(cop):=startfp(cop)+int;
infile:=false;
nextfp;
getmtname(0);
tapenames(cop,1):=fpparam(1);
tapenames(cop,2):=fpparam(2);
if vol>volumes then
tapenames(cop,1):=tapenames(cop,2):=real<::>;
ztape(cop,3):=tapenames(cop,1);
ztape(cop,4):=tapenames(cop,2);
for i:=5 step 1 until 25 do ztape(cop,i):=r;
end;
for cop:= 1 step 1 until copies do
begin
close(ztape(cop))release:(false add 1);
if vol > volumes then sterror(ztape(cop),1 shift 18,0);
end;
for cop:= 1 step 1 until copies do
begin
mount_med_ring;
writelabel(3);
i:= 1;
open(ztape(cop),modekind(cop),string tapenames(cop,increase(i)),
1 shift 18);
if int = 1 then setposition(ztape(cop),1,1);
end;
endtape:=false;
monitor(72,zhelp,0,entrybase);
end changevol;
procedure harderror(z,s,b);
zone z;
integer s,b;
begin
monitor(72,zhelp,0,interval);
if -,hard then
begin
if -,listnames then listentry(true);
errors:=errors+1;
hard:=true
end;
if s shift (-2) extract 1=1 or s shift (-5) extract 1=1 then
begin
write(out,<: entry in use:>);
if posvol<>vol then changevol(-1);
for cop:=1 step 1 until copies do
setposition(ztape(cop),if vol=1 then fileno(cop)
else 1, block);
rejected:=rejected+1;
entries(actualkitno):= entries(actualkitno)-1;
errors:=errors-1;
entryno:=entryno-1;
monitor(72,zhelp,0,entrybase);
goto exitdump
end;
write(out,<:<10> bad area::>);
for i:=23,i-1 while s<>0 do
begin
if s<0 then write(out,<:+1<60>:>,<<d>,i);
s:=s shift 1;
end;
b:=0;
monitor(72,zhelp,0,entrybase);
end harderror;
procedure listclock;
begin
integer field inf,clockadr,startext,seg;
boolean started;
procedure outdate;
begin
inf:=clockadr-2;
write(out,<: d.:>,<<zddddd>,zbs.inf,<:.:>);
end;
procedure outclock;
begin
write(out,<<zddd>,zbs.clockadr/100);
missingclock:=false;
end;
startext:=entry.contents extract 12+2;
if startext>502 then
begin
monitor(72,zhelp,0,interval);
write(out,<: entry inconsistent:>);
goto exitlistclock
end;
inrec6(zbs,512);
monitor(72,zhelp,0,interval);
seg:=entry.kind-1;
inf:=startext+2;
clockadr:=6+zbs.inf extract 12
+12*zbs.startext extract 12
+2*zbs.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; inf:=zbs.inf extract 12;
if clockadr<6 or inf>500 or seg=0 then
begin
write(out,<: code inconsistent:>);
goto exitlistclock
end;
clockadr:=clockadr-502+inf;
inrec6(zbs,512); seg:=seg-1;
if startext=502 then
begin
startext:=0;
clockadr:=clockadr-inf;
inf:=inf+2;
clockadr:=clockadr+zbs.inf extract 12;
end;
if clockadr>502 then goto nextsegm;
if -,started then outdate;
outclock;
end;
exitlistclock:
setposition(zbs,0,0);
monitor(72,zhelp,0,entrybase);
end listclock;
if copies = 2 then
begin
comment make two zones of a zonearray point at the
same buffer. ;
integer array bufsize,shares(1:2),ia(1:20);
bufsize(1):= size1; bufsize(2):= 2;
shares(1):= shares(2):= buf;
initzones(ztape,bufsize,shares);
allocbuf(ztape(2),ztape(1),0,size1*4);
getzone6(ztape(1),ia);
setzone6(ztape(2),ia);
end;
if listmore and sysdump then
write(out,<:<10>:>,sp,43,<:base:>);
for cop:=1 step 1 until copies do
begin
i:=1;
open(ztape(cop),modekind(cop),
string tapenames(cop,increase(i)),1 shift 18);
comment call blockproc at eot;
setposition(ztape(cop),fileno(cop),1);
end;
totalsegm:=entryno:=0;
inrecentry:
i:=inrec6(entry,34);
if i=0 then goto endinrecentry;
if entry.keys<>-1 then
begin
permkey:=entry.keys extract 3;
entrybase1:=entry.base(1); entrybase(1):=entrybase1;
entrybase2:=entry.base(2); entrybase(2):=entrybase2;
if entry.kind>=0 then
begin
fpparam(1):=entry.docname(1);
fpparam(2):=entry.docname(2);
actualkitno:=findkitno
end
else
begin
actualkitno:=entry.keys shift (-12);
if actualkitno>=2048 then actualkitno:=(actualkitno-2048)/2;
end;
k:=1;
kparam:
;
comment scan fpparameters;
paramno:=param(k);
ok:=fpkitno(paramno)=actualkitno or fpkitno(paramno)=-1;
if ok then
begin
r:=fpname(paramno,1);
scopekey:=fpscope(paramno);
actualscope:=if r<>real<::> then 10 else
if fpdocname(paramno,1)<>real<::> then 11
else scopekey;
nameandscopeloop:
ok:=case actualscope of (
entrybase1>=interval3 and entrybase2<=interval4,
permkey=3 and
entrybase1>=interval3 and entrybase2<=interval4,
permkey=3 and
entrybase1 =interval9 and entrybase2 =interval10,
findentryscope(actualscope,true),
permkey=3 and
entrybase1 =interval7 and entrybase2= interval8,
permkey=3 and
entrybase1 =interval5 and entrybase2 =interval6,
permkey=2 and
entrybase1 =interval3 and entrybase2 =interval4,
permkey=0 and
entrybase1 =interval1 and entrybase2 =interval2 ,
false,
entry.name(1)=r and entry.name(2)=fpname(paramno,2),
entry.docname(1)=fpdocname(paramno,1) and
entry.docname(2)=fpdocname(paramno,2) );
sysdump:=actualscope<3;
if ok then
begin
if actualscope>9 and scopekey<>0 then
begin
actualscope:=scopekey;
goto nameandscopeloop
end
else
if scopekey=0 then ok:=findentryscope(actualscope,false);
if actualscope=0 and fpnewscope(paramno)<>4 then
ok:=entrybase1<=interval1 and entrybase2>=interval2;
end
end;
if ok then
begin
i:= if scopekey=0 then 1 else
if scopekey=3 then 9 else (9-actualscope)*2-1;
iarr(1):=if sysdump then entrybase1 else interval(i);
iarr(2):=if sysdump then entrybase2 else interval(i+1);
monitor(72)set catbase:(zhelp,0,iarr);
if scopekey=0 and actualscope<>8 then
begin
comment check whether entry has smallest scope;
i:=1;
open(zbs,0,string entry.name(increase(i)),0);
close(zbs,false);
monitor(76)lookup head and tail:(zbs,0,iarr);
ok:=permkey=iarr.keys extract 3 and
entrybase1=iarr.base(1) and
entrybase2=iarr.base(2);
end;
if ok then
begin
comment dump;
k:=paramnos;
r:=entry.name(1);
if entrybase1 = -8388607 and
entrybase2 = 8388606 and
permkey = 1 then
begin
monitor(72,zhelp,0,interval);
outtext(out,-11,entry.name,1);
write(out,<: entry outside system - no dump :>);
rejected:= rejected + 1;
goto exitdump ;
end;
if r=real<:c:> or r=real<:v:> or r=real<:fp:> or
r=real<:primo:> add 117 and entry.name(2)=real<:t:> then
begin
if (scopekey=1 or scopekey=4 or scopekey=8)
and (r=real<:c:> or r=real<:v:>)
or (scopekey=1 or scopekey=4 or scopekey=7)
and r=real<:primo:> add 117
then goto exitdump;
monitor(72,zhelp,0,interval);
outtext(out,-11,entry.name,1);
write(out,<: not allowed:>);
rejected:=rejected+1;
goto exitdump
end;
i:=1;
open(zbs,4,string entry.name(increase(i)),1 shift 5 +1 shift 2);
if entry.kind>0 then
begin
i:=monitor(52<*create area proc*>,zbs,0,iarr);
if i<>0 then
begin
if i=1 then
begin
write(out,<:<10>create area process, areas exceeded:>);
goto save_not_ok;
end;
write(out,<:<10>catalog error, create area process, :>,
<:<10>monitor 52, result=:>,i);
goto inrecentry;
end;
end;
entryno:=entryno+1; entries(actualkitno):= entries(actualkitno)+1;
if endtape then changevol(1);
for cop:=1 step 1 until copies do
begin
comment entry record;
getposition(ztape(cop),i,block);
posvol:=vol;
outrec6(ztape(cop),blocksize);
changerec6(ztape(cop),100);
ztape(cop,1):=r:=real<::> add 1 shift 24
add (if sysdump then 52 else 48);
ztape(cop,2):=real<::> add entryno shift 24 add
(if entry.kind<0 then 0 else entry.kind);
ztape(cop,3):=entry.name(1);
ztape(cop,4):=entry.name(2);
if entry.kind>=0 then
begin
comment kitname;
entry.docname(1):=catname(actualkitno,3);
entry.docname(2):=catname(actualkitno,4);
end;
for i:=1 step 1 until 5 do
ztape(cop,4+i):=entry.tail(i);
scopekey:=fpnewscope(paramno)extract 10;
scopekey:=if sysdump then permkey else
if scopekey=4
then actualscope else scopekey;
ztape(cop,10):=scopekey;
ztape(cop,11):=catname(actualkitno,3);
ztape(cop,12):=catname(actualkitno,4);
ztape(cop,13):=if -,sysdump then r else
real<::> add entrybase1 shift 24 add entrybase2;
for i:=14 step 1 until 25 do ztape(cop,i):=r;
end entry record;
segmno:=0;
hard:=false;
listentry(listnames);
if entry.kind<=0 then goto exitdump;
if missingclock and listmore then listclock;
raf:= 8;
for i:= inrec6(zbs,0) while i > 2 do
begin comment segment record;
i:= i mod (segm*512);
if i = 0 then i:= segm*512;
if endtape then changevol(1);
for cop:= 1 step 1 until copies do
begin
outrec6(ztape(cop),blocksize);
if i+8 <> blocksize then changerec6(ztape(cop),8+i);
ztape(cop,1):= real<::> add 2 shift 24 add (8+i);
ztape(cop,2):= real<::> add entryno shift 24 add segmno;
end;
inrec6(zbs,i);
tofrom(ztape(1).raf,zbs,i);
segmno:= segmno+i//512;
end;
if segmno<>entry.kind then
begin
if -,hard and -,listnames then listentry(true)
else monitor(72,zhelp,0,interval);
write(out,<:<10> bad area, segm. saved =:>,
segmno);
monitor(72,zhelp,0,entrybase);
end;
slices(actualkitno):= slices(actualkitno) +
(segmno-1)//segm_pr_slice(actualkitno)+1;
totalsegm:=totalsegm+segmno;
exitdump:
fpnewscope(paramno):=fpnewscope(paramno)+1 shift 10;
close(zbs,-,(entry.name(1)=ownname1 and entry.name(2)=ownname2 and
entrybase1=ownbase1 and entrybase2=ownbase2));
end dump;
end ok;
k:=k+1;
if k<=paramnos then goto kparam;
end;
goto inrecentry;
endinrecentry:
monitor(72,zhelp,0,interval);
for cop:=1 step 1 until copies do
begin
comment end record;
outrec6(ztape(cop),blocksize);
changerec6(ztape(cop),100);
ztape(cop,1):=r:=real<::> add 3 shift 24add 8;
ztape(cop,2):=real<::> add entryno shift 24 add totalsegm;
for i:=3 step 1 until 25 do ztape(cop,i):=r;
close(ztape(cop),false);
end;
write(out,<:<10>:>,<<ddd>,entryno,<: entr.,:>,
<< ddddd>,totalsegm,<: segm.<10><10><10><10>:>);
document:= 8; sum:= 0;
for i:= 0 step 1 until catalogs do
begin
if slices(i) <> 0 then
begin
j:= slices(i) * segm_pr_slice(i);
sum:= sum + j;
write(out,sp,12-write(out,catname.document));
write(out,<:::>,<<dddd>,slices(i),<: slices * :>,
<<ddd>,segm_pr_slice(i),<: = :>,<<dddddd>,j,
<: segments:>,<< dddd>,entries(i),
<: entries<10>:>);
end;
document:= document + 16;
end;
if sum > 0 then write(out,<:<10>:>,sp,25,<:total = :>,
<<dddddd>,sum,<: segments <10><10>:>);
if rejected>0 then
write(out,<:<10>:>,<<ddd>,rejected,<: entr. rejected:>);
ok:=true;
for paramno:=1 step 1 until paramnos do
if fpnewscope(paramno) shift (-10)=0 then
begin
actualscope:=fpscope(paramno);
write(out,if ok then <:<10><10>***not found::> else
<:<10> :>);
ok:=false;
i:=1;
if fpname(paramno,1)<>real<::> then
write(out,string fpname(paramno,increase(i)),
if actualscope<>0 then <:.:> else <::>);
i:=1;
if fpdocname(paramno,1)<>real<::> then
write(out,<:docname.:>,string fpdocname(paramno,increase(i)),
if actualscope<>0 then <:.:> else <::>);
if actualscope<>0 then
write(out,<:scope.:>,case actualscope of (
<:all:>,<:perm:>,<:system:>,<:own:>,
<:project:>,<:user:>,<:login:>,<:temp:>));
i:=1;
if fpkitno(paramno)<>-1 then
write(out,<: kit.:>,
string catname(fpkitno(paramno),increase(i)));
end;
for cop:=1 step 1 until copies do
begin
comment write label on following file;
fileno(cop):=if vol<>1 then 2 else fileno(cop)+1;
infile:=false; writelabel(2);
end;
close(zbs,true);
open(zbs,0,<::>,0);
monitor(72)set catbase:(zbs,0,interval);
end block;
end;
if rejected>0 or errors>0 then
savenotok:
begin
write(out,<:<10>***save not ok :>,<<d>,errors+rejected);
errorbits:=1;
end
end;
boolean procedure openout(z,name);
zone z; array name;
begin integer i,result;
integer array ia(1:17);
long projectbaselow,projectbaseup;
system(11,0,ia);
projectbaselow:=ia(7);
projectbaseup :=ia(8);
i:=1; open(z,4,string name(increase(i)),0);
openout:=true;
result:=monitor(76,z,0,ia);
if result=2 then
begin
openout:=false; goto exit_openout;
end;
if result=0 <*found and system*> and
(extend ia(2)<projectbaselow or extend ia(3)>projectbaseup)
or result=3 <*not found*> then
begin
ia(1):=8<*size*>;
ia(2):=1;
for i:=3 step 1 until 10 do ia(i):=0;
ia(6):=systime(7,0,0.0);
openout:=monitor(40,z,0,ia)=0;
end
else
if result=0 then
begin
monitor(42,z,0,ia);
i:=ia(9) shift (-12);
if i=4 or i>=32 then ia(8):=0;
ia(6):=systime(7,0,0.0);
ia(7):=ia(9):=ia(10):=0;
openout:=monitor(44,z,0,ia)=0;
end;
exit_openout:
end openout;
integer procedure changearea(z,i); zone z; integer i;
begin integer array tail(1:10),ia(1:20);
monitor(42<*lookup*>,z,0,tail);
if i extract 1=1 then
begin
getzone6(z,ia);
tail(1):=ia(9);
end;
if i shift(-1) extract 1=1 then tail(6):=systime(7,0,0.0);
changearea:=monitor(44<*change*>,z,0,tail);
end changearea;
begin integer sep;
array fpparam(1:2);
real array field raf;
sep:=system(4,1,fpparam); raf:=0;
if sep shift (-12)<>6 then goto curout else
begin
zone z(128,1,stderror);
system(4,0,fpparam);
if -,openout(z,fpparam.raf) then goto curout;
program(z); write(z,false add 25,1);
changearea(z,1); close(z,true);
end;
end;
if false then
curout: program(out);
end
▶EOF◀