|
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: 45312 (0xb100)
Types: TextFile
Names: »tincload«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »tincload«
incload=algol list.no blocks.no connect.no
begin
procedure program(out); zone out;
begin
message vk 1981.11.29 incload;
array fpparam(1:2);
integer array iarr(1:21);
integer sep,fpno,paramnos,spacename,catalogs,
i,ownbase1,ownbase2,modekind; real ownname1, ownname2;
zone zhelp(1,1,stderror);
procedure nextfp;
begin
fpno:=fpno+1;
sep:=system(4,fpno,fpparam);
end nextfp;
procedure lastfp;
begin
fpno:=fpno-1;
sep:=system(4,fpno,fpparam);
end lastfp;
sep:=system(4,1,fpparam);
if sep<>6 shift 12+10 then system(4,0,fpparam);
i:=1;
open(zhelp,0,string fpparam(increase(i)),0);
monitor(76)lookup head and tail:(zhelp,0,iarr);
close(zhelp,false);
ownname1:=fpparam(1);
ownname2:=fpparam(2);
ownbase1:=iarr(2);
ownbase2:=iarr(3);
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;
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;
fpno:=if paramnos<1 then 1 else paramnos;
begin
boolean listnames,listmore,ok,endtape,singles,release,checkno,sp,hard,
sysdump,noname,eof,eot,badrecord,bodoc,survey,loadno,missingclock,allspec;
integer i,j,k,paramno,volumes,actualkitno,permkey,scopekey,skipped,
recordtype,errors,rejected,entryno,segmno,totalsegm,actualscope,
actualnewscope,vol,fileno,lastsurvey,loadedsegm,ztapeentry,created,
ztapesegm,tapekits,totalloaded,segm,blocksize,device,counted;
real r,scopedoc1,scopedoc2;
integer field inf2,inf4,inf6,keys,kind,contents,shortclock;
integer array field base;
real array field tail,name,docname,segbase;
integer array entrybase(1:2),entry(1:17),param(1:fpno),interval(1:10),
fpscope,fpnewscope,fpkitno(1:fpno);
array catname(-4:catalogs+10,1:4),tapenames(1:2),
fpname,fpdocname(1:fpno,1:2);
real procedure dumplabel(i,type);
integer i;
integer type;
begin
real spaces;
comment returns the ith real of a dumplabel
1 : dump
2-3 : tapename
4 : fileno
5 : empty or vers.
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;
dumplabel:= case i of (
spacefill(real<:dump:>),
spacefill(tapenames( 1)),
spacefill(tapenames( 2)),
spacefill(convintg(fileno)shift 24),
spacefill(case type of(real<:vers.:>,real<:empty:>,real<:cont.:>)));
end dumplabel;
procedure readlabel(type);
integer type;
comment readlabel reads a dumplabel if any, lists and checks same
type=1: vers ok, cont ok if checkno else alarm
type=2: empty ok
type=3: cont ok, fortsæt if nodumplabel;
begin
integer i,modecase;
boolean last;
zone zlabel(25,1,nodump);
procedure nodump(z,s,b);
zone z;
integer s,b;
if last then goto found else
if s shift (-14) extract 1=1 and
(-,survey and type=1 or survey and fileno=1) then
begin
if modecase=0 then
begin
modecase:=1;
setposition(zlabel,0,0);
setposition(zlabel,0,0);
modecase:=2;
goto next
end
else
if modecase=1 then
begin
b:=0;
end
else
if modecase=2 then
begin
close(zlabel,false);
modekind:=if modekind=18 then 4 shift 12+18 else 18;
i:=1;
open(zlabel,modekind,string tapenames(increase(i)),0);
modecase:=1;
setposition(zlabel,0,0);
setposition(zlabel,0,0);
modecase:=3;
goto next
end
else stderror(zlabel,s,b);
end
else alarm3(0);
procedure alarm3(i);
integer i;
begin
write(out,<:<10>***load: :>);
if i=0 then
begin
write(out,<:no dumplabel on file:>,fileno);
if type<>1 then goto exitreadlabel
else if -,survey then goto loadnotok
else if fileno=lastsurvey then
begin
close(zlabel,if release then false add 1 else false);
goto exit
end
else goto add1;
end;
write(out,<:dumplabel :>,
case i of (<:tapename:>,
<:fileno:>,
<:cont.label:>,
<:empty label: file not used by save:> ));
if survey then
begin
if i=4 then
begin
if fileno<>lastsurvey then goto add1 else
begin
close(zlabel,if release then false add 1 else false);
goto exitrecordloop
end
end
else
if -,checkno then goto exitreadlabel;
end;
if -,(i<>4 and checkno) then goto loadnotok;
end alarm3;
i:=1;
last:=fileno=0 or lastsurvey=0;
if fileno=0 then fileno:=1;
mount;
open(zlabel,modekind,string tapenames(increase(i)),0);
modecase:=0;
next:
setposition(zlabel,if type=3 then 1 else fileno,0);
i:=inrec6(zlabel,0);
if modecase=3 then
write(out,<:<10>***load, tape is :>,
if modekind=18 then <:mto:> else <:nrz:>);
if i<>100 then alarm3(0) else inrec6(zlabel,100);
if (zlabel(5)=dumplabel(5,1)
or zlabel(5)=dumplabel(5,3)) and last and -,survey then
begin
add1:
fileno:=fileno+1;
goto next
end;
if zlabel(1)<>dumplabel(1,1) then
begin
if last then
begin
found:
if fileno=1 then alarm3(0);
fileno:=lastsurvey:=fileno-1;
last:=false;
if -,survey then goto next;
close(zlabel,if type=2 and release then false add 1 else false);
goto if survey then exit else exitnorecords;
end
else
alarm3(0)
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 type=1 then
begin
for i:=2,3 do if zlabel(i)<>dumplabel(i,1) then alarm3(1);
if zlabel(4)<>dumplabel(4,1) then alarm3(2);
if zlabel(5)=dumplabel(5,1) then entryno:=segmno:=0 else
begin
if zlabel(5)=dumplabel(5,3) and checkno then
begin
entryno:=zlabel(25) shift (-24) extract 24;
segmno:=zlabel(25) extract 24;
end
else
if last then goto found else
alarm3(if zlabel(5)=dumplabel(5,3) then 3 else 4)
end;
end;
segm:=zlabel(8) shift (-24) extract 8;
segm:=if segm=32 then 1 else segm-48;
exitreadlabel:
close(zlabel,if type=1 or -,release then false else false add 1);
end readlabel;
procedure mount;
begin integer array ia(1:12);
integer i;
zone z(128,1,stderror);
i:=1; open(z,0,string tapenames(increase(i)),0);
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<*normal*> then
begin <*not mounted*>
ia(1):=(if device=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;
ia(5):=tapenames(1) shift (-24) extract 24;
ia(6):=tapenames(1) extract 24;
ia(7):=tapenames(2) shift (-24) extract 24;
ia(8):=tapenames(2) extract 24;
system(10,0,ia);
goto sense;
end;
close(z,true);
end mount;
procedure getmtname(file);
integer file;
begin
file:=-1;
close(zhelp,false);
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:=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);
open(zhelp,0,<::>,0);
end getmtname;
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;
integer i,j,k;
real r;
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>,entry.keys,<:.:>)
else write(out,case actualnewscope-2 of (
<: system.:>,<::>,
<:project.:>,
<: user.:>,
<: login.:>,
<: temp.:>));
r:=entry.docname(1);
j:=1;
i:=if r=0.0 or r=1.0 then write(out,<<d>,r) 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);
missingclock:=false;
if i<>4 and i<32 then
begin
i:=entry.shortclock;
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:=-,loadno;
end;
monitor(72,zhelp,0,entrybase);
end listentry;
begin
comment read fpparameters;
integer pointname,pointinteger,min;
real array catalog(1:2);
integer array help(1:1);
integer procedure findkitno;
begin
integer i;
findkitno:=-4;
if sep=pointinteger then
begin
if fpparam(1)=0 or fpparam(1)=1 then findkitno:=fpparam(1)-3
end
else
for i:=-1 step 1 until tapekits do
if fpparam(1)=catname(i,1) and
fpparam(2)=catname(i,2) then findkitno:=i;
end findkitno;
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>***load: error in tapeparam: :>);
listfp;
goto loadnotok;
end alarm;
lastsep:=sep;
modekind:=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:=fpparam(1);
goto mountspecif
end
else
if r=real<:mto:> or r=real<:nrz:> then
begin
modekind:=(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(1):=fpparam(1);
tapenames(2):=fpparam(2);
nextfp;
if lastsep<>spacename or
-,(sep=pointinteger and (fpparam(1)<>0 and file=-1 or
file+fpparam(1)>0) or
sep=pointname and fpparam(1)=real<:last:>) then alarm1;
fileno:=lastsurvey:=if sep=pointname then 0 else
if file=-1 then fpparam(1) else file+fpparam(1);
nextvol:
nextfp;
if sep=spacename or sep=0 then goto exitreadtapeparam;
if sep<>pointname then alarm1;
r:=fpparam(1);
volumes:=volumes+1;
if volumes>10 then alarm1;
goto nextvol;
exitreadtapeparam:
end readtapeparams;
procedure alarm2;
begin
write(out,<:<10>***load: error in param: :>);
listfp;
goto loadnotok;
end alarm2;
tapenames(1):=tapenames(2):=real<::>;
device:=0;
name:=6;
docname:=16;
keys:=2;
base:=2;
kind:=16;
tail:=14;
shortclock:=26;
contents:=32;
inf2:=2;
inf4:=4;
inf6:=6;
endtape:=sysdump:=false;
release:=true;
sp:=false add 32;
errors:=rejected:=0;
pointname:=8 shift 12+10;
pointinteger:=8 shift 12+4;
system(11)get interval:(0,interval);
entrybase(1):=interval(1);
entrybase(2):=interval(2);
open(zhelp,0,<::>,0);
interval(9):=-8388607;
interval(10):=8388605;
catname(-3,1):=catname(-3,3):=0.0;
catname(-3,2):=catname(-3,4):=real<::>;
catname(-2,1):=catname(-2,3):=1.0;
catname(-2,2):=catname(-2,4):=real<::>;
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);
tapekits:=catalogs;
for j:=0 step 1 until catalogs do
begin
zone zbs(128,1,stderror);
system(5,k,help);
k:=k+2;
system(5,help(1)-2,iarr);
system(5,help(1)-28,catalog);
i:=1;
open(zbs,4,string catalog(increase(i)),0);
monitor(76)lookup head and tail:(zbs,0,iarr);
close(zbs,true);
catname(j,1):=catname(j,3):=iarr.docname(1);
catname(j,2):=catname(j,4):=iarr.docname(2);
end;
for j:=catalogs+1 step 1 until catalogs+10 do
for i:=1,2,3,4 do catname(j,i):=real<::>;
fpno:=0;
nextfp;
if sep<>6 shift 12+10 then fpno:=0;
nextfp;
paramno:=0;
if paramnos=-1 then alarm2;
volumes:=1;
paramno:=1;
readtapeparams;
listnames:=listmore:=true;allspec:=false;
loadno:=survey:=checkno:=false;
specialparam:
r:=fpparam(1);
i:=if r=real<:list:> then 1 else
if r=real<:load:> then 2 else
if r=real<:surve:> add 121 and fpparam(2)=real<::> then 3 else
if r=real<:check:> then 4 else
if r=real <:all:> then 5 else 6;
if i<6 then
begin
nextfp;
r:=fpparam(1);
if r<>real<:yes:> and r<>real<:no:> and
(r<>real<:name:> and r<>real<:names:>) and i=1 or
r<>real<:yes:> and r<>real<:no:> and i>=2 or
sep<>pointname then
begin
lastfp;
goto startloop
end;
end;
case i of
begin
begin
listnames:=r<>real<:no:>;
listmore:=r=real<:yes:>
end;
begin
loadno:=r=real<:no:>;
end;
begin
survey:=r=real<:yes:>;
loadno:=loadno or survey;
lastsurvey:=fileno;
fileno:=1;
end;
checkno:=r=real<:no:>;
allspec:= r <> real <:no:>;
goto startloop
end;
paramno:=paramno+1;
nextfp;
goto specialparam;
startloop:
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=-4 then
begin
if tapekits>catalogs+10 then
begin
write(out,<:<10>***load param, kitnames exceeded:>);
goto loadnotok
end;
tapekits:=i:=tapekits+1;
catname(tapekits,1):=fpparam(1);
catname(tapekits,2):=fpparam(2);
end;
nextfp;
if sep<>pointname and sep<>pointinteger then alarm2;
k:=findkitno;
if k=-4 or k>catalogs then alarm2;
catname(i,3):=fpparam(1);
catname(i,4):=fpparam(2);
nextfp;
end
else
if fpname(paramnos+1,1)=real<:kit:> then
begin
actualkitno:=findkitno;
if actualkitno=-4 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
alarm2;
goto loop;
exitloop:
if paramnos=0 then
begin
paramnos:=1;
fpscope(1):=1;
fpnewscope(1):=actualnewscope;
fpkitno(1):=actualkitno;
fpname(1,1):=fpname(1,2):=fpdocname(1,1):=fpdocname(1,2):=real<::>;
end;
singles:=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);
j:=fpscope(i);
if j<>0-20 and j<>3-20 and (j<5-20 or j>8-20) then singles:=false;
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
vol:=fpscope(param(j));
if vol<min then
begin
min:=vol;
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;
vol:=1;
nextlabel:
created:=totalloaded:=counted:=0;
readlabel(1);
k:=2;
if system(2,0,fpparam)-2048*segm<2600 then k:=1;
begin
zone zbs(k*128*segm,k,sterror),ztape(k*(2+128*segm),k,harderror);
procedure sterror(z,s,b);
zone z;
integer s,b;
begin
monitor(72)set catbase:(zhelp,0,interval);
stderror(z,s,b);
end;
procedure harderror(z,s,b);
zone z;
integer s,b;
begin
integer s1;
monitor(72,zhelp,0,interval);
s1:=s;
if s shift (-18) extract 1=0 then
begin
if -,hard then
begin
if -,listnames and -,noname then listentry(true) else
if noname then write(out,<:<10>***unknown :>);
errors:=errors+1;
hard:=true
end;
write(out,<:<10> bad tape::>);
for i:=23,i-1 while s1<>0 do
begin
if s1<0 then write(out,<:+1<60>:>,<<d>,i);
s1:=s1 shift 1;
end;
end;
if s shift (-21) extract 1=1 or
s shift (-20) extract 1=1 or
s shift ( -6) extract 1=1 or
s shift ( -5) extract 1=1 or
s shift ( -3) extract 1=1 then sterror(z,s,b);
if s shift (-18) extract 1=1 then eot:=true else
if s shift (-16) extract 1=1 then
begin
eof:=true;
b:=8+512*segm
end;
if b mod 512<>8 and -,(eot and b=100) then
begin
badrecord:=true;
write(out,<: blocklength=:>,b);
errors:=errors+1;
end;
if s shift (-22) extract 1=1 or
s shift (-19) extract 1=1 then badrecord:=true;
monitor(72,zhelp,0,entrybase);
end harderror;
procedure createentry;
begin
procedure trouble(n);
value n;
integer n;
begin integer i;
i:=n;
errors:=errors+1;
listentry(true);
write(out,sp,6);
if n=445 then n:=485;
if n=906 then n:=506;
monitor(72,zhelp,0,interval);
if -,(n mod 10=2 or n=404 or n=506 or n=485) then
write(out,<: monitor:>,n//10,<: result:>,n mod 10);
write(out,if n mod 10=2 then <: device not mounted:> else
if n=405 then <: process base error:> else
if n=404 then <: no work resources:> else
if n=506 then <: no perm resources:> else
if n=485 then <: entry in use:> else
<: impossible:>);
if (n=404 or n=506) and entry.kind<0 then
begin
i:=3;
write(out,<: on :>,string catname(actualkitno,increase(i)));
end;
monitor(72,zhelp,0,entrybase);
if i<>445 then monitor(48)remove:(zbs,0,iarr);
close(zbs,true);
ok:=false;
goto exitcreateentry
end trouble;
if -, allspec then
begin
entrybase(1):=entry.base(1);
entrybase(2):=entry.base(2);
open(zbs,4,<::>,0);close(zbs,true);
i:=monitor(72)set catbase:(zbs,0,entrybase);
i:=1;
open(zbs,4,string entry.name(increase(i)),0);
i:=monitor(76)look up head and tail:(zbs,0,iarr);
close(zbs,true);
monitor(72,zhelp,0,interval);
if i = 0 then
begin
if entry(2) = iarr(2) and
entry(3) = iarr(3) and
entry(4) = iarr(4) and
entry(5) = iarr(5) and
entry(6) = iarr(6) and
entry(7) = iarr(7) and
entry.keys = iarr(1) extract 3 then
begin
ok:=false;
listentry(true);
write(out,<:*** entry exist :>);
goto exitcreateentry;
end;
end;
end;
if entry.kind>=0 then
begin
entry.docname(1):=catname(actualkitno,3);
entry.docname(2):=catname(actualkitno,4);
if entry.docname(1)=real<:main:>
then entry.docname(1):=catname(0,1);
end;
if entry.docname(1)=0.0 or entry.docname(1)=1.0 then
entry.docname(1):=real<::> add (round entry.docname(1));
if actualnewscope<>actualscope then
begin
i:=actualnewscope;
i:=if i=3 then 10 else (9-i)*2;
entry.base(1):=interval(i-1);
entry.base(2):=interval(i);
entry.keys:=if i=2 then 0 else if i=4 then 2 else 3;
end;
if entry.name(1)=ownname1 and entry.name(2)=ownname2 and
entry.base(1)=ownbase1 and entry.base(2)=ownbase2 then
trouble(445);
entrybase(1):=entry.base(1);
entrybase(2):=entry.base(2);
if entry.kind>=0 then
begin
open(zbs,4,<::>,0); close(zbs,true);
i:=monitor(72)set catbase:(zbs,0,entrybase);
if i<>0 then trouble(720+i);
i:=1;
open(zbs,4,string entry.name(increase(i)),0);
i:=monitor(76)lookup head and tail:(zbs,0,iarr);
if i=0 then
begin
if entrybase(1)=iarr(2) and entrybase(2)=iarr(3) and
entry(9)=iarr(9) and entry(10)=iarr(10) and
entry(11)=iarr(11) and entry(12)=iarr(12) then
begin
for i:=1 step 1 until 10 do iarr(i):=entry(i+7);
i:=monitor(44)change entry:(zbs,0,iarr);
if i=0 then goto done
end
end
end;
close(zbs,true);
open(zbs,4,<::>,0);
i:=monitor(72)set catbase:(zbs,0,interval);
if i<>0 then trouble(720+i);
for i:=1 step 1 until 10 do iarr(i):=entry(i+7);
i:=monitor(40)generate wrk name create entry:(zbs,0,iarr);
if i<>0 then trouble(400+i);
if entry.keys>0 then
begin
if entry.kind<0 then
begin
iarr(1):=catname(actualkitno,3) shift (-24) extract 24;
iarr(2):=catname(actualkitno,3) extract 24;
iarr(3):=catname(actualkitno,4) shift (-24) extract 24;
iarr(4):=catname(actualkitno,4) extract 24;
i:=monitor(90)permanent into auxcat:(zbs,entry.keys,iarr);
if i<>0 then trouble(900+i);
end
else
begin
i:=monitor(50)permanent:(zbs,entry.keys,iarr);
if i<>0 then trouble(500+i);
end
end;
i:=monitor(74)set entry base:(zbs,0,entrybase);
if i<>0 then trouble(740+i);
i:=monitor(72)set catbase:(zhelp,0,entrybase);
if i<>0 then trouble(720+i);
renameloop:
for i:=1 step 1 until 4 do
iarr(i):=entry(i+3);
comment iarr:=entry.name;
i:=monitor(46)rename:(zbs,0,iarr);
if i<>0 and i<>3 then trouble(460+i);
getzone(zbs,iarr);
for j:=0 step 1 until 3 do
begin
comment store wrk name in iarr(18:21) and
set entry.name in iarr(2:5);
iarr(j+18):=iarr(j+2);
iarr(j+2):=entry(j+4);
end;
setzone(zbs,iarr);
if i=3 then
begin
i:=monitor(48)remove:(zbs,0,iarr);
for j:=0 step 1 until 3 do iarr(j+2):=iarr(j+18);
setzone(zbs,iarr);
if i<>0 then trouble(480+i);
goto renameloop
end;
done: listentry(listnames);
exitcreateentry:
end createentry;
procedure listclock;
begin
integer field inf,clockadr,startext,seg;
integer i;
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>500 then
begin
write(out,<: entry inconsistent:>);
goto exitlistclock
end;
i:=1; open(zbs,4,string entry.name(increase(i)),0);
inrec6(zbs,512); seg:=entry.kind-1;
monitor(72,zhelp,0,interval);
inf:=startext+2;
clockadr:=6+zbs.inf extract 12
+12*zbs.startext extract 12
+2*zbs.startext shift (-12) +startext;
if clockadr<=502 and clockadr>4 then
begin
outdate;
outclock
end
else
begin
started:=false;
nextsegm:
if clockadr=504 then
begin
outdate;
started:=true
end;
inf:=504;
if zbs.inf extract 12>500 or clockadr<6 or seg=0 then
begin
write(out,<: code inconsistent:>);
goto exitlistclock
end;
clockadr:=clockadr-502+zbs.inf extract 12;
inrec6(zbs,512); seg:=seg-1;
if clockadr>502 then goto nextsegm;
if -,started then outdate;
outclock;
end;
exitlistclock:
monitor(72,zhelp,0,entrybase);
close(zbs,true);
end listclock;
if listmore and sysdump then write(out,<:<10>:>,sp,43,<:base:>);
i:=1;
open(ztape,modekind,string tapenames(increase(i)),0);
setposition(ztape,fileno,1);
totalsegm:=loadedsegm:=0;
ok:=false;
eot:=eof:=false;
noname:=true;
hard:=true;
skipped:=0;
recordloop:
badrecord:=false;
blocksize:=i:=inrec6(ztape,0);
inrec6(ztape,i);
if i<60 then
begin
skipped:=skipped+1;
goto recordloop
end;
recordtype:=ztape.inf2;
k:=ztape.inf4;
ztapeentry:=ztape.inf6;
ztapesegm:=ztape(2) extract 24;
if recordtype<1 or recordtype>4 or
recordtype=1 and k<>52 and k<>48 or
recordtype=2 and (k mod 512<>8 or ztapesegm<segmno) or
recordtype=3 and k<>8 or
recordtype=4 and k<>16 or
ztapeentry<entryno then
begin
recordtype:=0;
if badrecord and ztape(12)=ztape(13) and ztape(14)=ztape(15)
and ztape(12)=ztape(15) then
begin
ztape(1):=ztape(12);
recordtype:=ztape.inf2;
k:=ztape.inf4;
if -,(recordtype=3 and k=8 or recordtype=4 and k=16)
then recordtype:=0;
end;
if recordtype=0 then
begin
if eot and vol<volumes then
recordtype:=4 else if eot then eof:=true;
if eof then recordtype:=3;
end;
if recordtype=0 then
begin
skipped:=skipped+1;
if skipped<8 then goto recordloop
end;
end;
if skipped>0 then
begin
monitor(72,zhelp,0,interval);
write(out,<:<10> bad tape, blocks skipped:>,skipped);
if skipped=8 then goto exitrecordloop;
monitor(72,zhelp,0,entrybase);
skipped:=0;
errors:=errors+1;
end;
if ok and (recordtype=3 or ztapeentry>entryno) then
begin
close(zbs,if missingclock then false else true);
if missingclock then listclock;
if loadedsegm<>entry.kind and -,(segmno=0 and entry.kind<0)
then
begin
monitor(72,zhelp,0,interval);
write(out,<:<10> bad tape, segm. loaded:>,loadedsegm);
monitor(72,zhelp,0,entrybase);
errors:=errors+1;
end;
ok:=hard:=false;
noname:=true;
end;
if singles then
begin
if (recordtype=1 or recordtype=3) and counted=paramnos then
begin
totalloaded:=totalloaded+loadedsegm;
close(ztape,if release then false add 1 else false);
goto exitrecordloop
end
end;
case recordtype of
begin
begin
comment type 1, entry record;
sysdump:=k=52;
actualscope:=ztape(10);
k:=if actualscope=3 then 10 else (9-actualscope)*2;
entry.base(1):=if sysdump then ztape(13) shift (-24)
extract 24 else interval(k-1);
entry.base(2):=if sysdump then ztape(13) extract 24
else interval(k);
entry.keys:=if sysdump then actualscope else
if k=2 then 0 else if k=4 then 2 else 3;
nextentryno:
entryno:=entryno+1;
if ztapeentry>entryno then
begin
monitor(72,zhelp,0,interval);
write(out,<:<10> bad tape, entry no:>,
entryno,<: missing:>);
monitor(72,zhelp,0,entrybase);
errors:=errors+1;
goto nextentryno
end;
hard:=noname:=false;
totalsegm:=totalsegm+segmno;
totalloaded:=totalloaded+loadedsegm;
segmno:=loadedsegm:=0;
entry.name(1):=ztape(3);
entry.name(2):=ztape(4);
for i:=1 step 1 until 5 do entry.tail(i):=ztape(4+i);
for k:=1 step 1 until paramnos do
begin
paramno:=param(k);
scopekey:=fpscope(paramno);
actualnewscope:=fpnewscope(paramno) extract 10;
if actualnewscope=4 then actualnewscope:=actualscope;
actualkitno:=-4;
for i:=-3 step 1 until tapekits do
if catname(i,1)=ztape(11) and
catname(i,2)=ztape(12) then actualkitno:=i;
if actualkitno=-4 then
begin
catname(-4,3):=ztape(11);
catname(-4,4):=ztape(12);
end;
ok:=fpkitno(paramno)=actualkitno or fpkitno(paramno)=-1
or (fpkitno(paramno)=0 and actualkitno=-1);
if ok and sysdump then
ok:=extend entry.base(1)>=extend interval(7) and
extend entry.base(2)<=extend interval(8) and
(scopekey<2 or scopekey=2 and entry.keys>1 or scopekey>2)
else
if ok then ok:=scopekey<2 or
scopekey=2 and entry.keys>1 or
scopekey=actualscope or
scopekey=4 and actualscope>4 ;
if ok and sysdump then
begin
if -,(interval(5)=interval(7) and
interval(6)=interval(8))
and (entry.base(1)=interval(7) and
entry.base(2)=interval(8)) then
ok:=fpname(paramno,1)<>fpdocname(paramno,1)
and scopekey mod 10=5
end;
if ok and fpname(paramno,1)<>fpdocname(paramno,1) then
begin
if fpname(paramno,1)<>real<::> then
ok:=fpname(paramno,1)=entry.name(1) and
fpname(paramno,2)=entry.name(2)
else
ok:=fpdocname(paramno,1)=entry.docname(1) and
fpdocname(paramno,2)=entry.docname(2);
end;
if ok then goto found
end scan parameters;
found:
if ok then
begin
if fpnewscope(paramno) shift (-10)=0 then counted:=counted+1;
fpnewscope(paramno):=fpnewscope(paramno)+1 shift 10;
if loadno then listentry(listnames) else createentry;
if ok then created:=created+1;
end;
end type 1, entry record;
begin
comment type 2, segment record;
k:=(k-8)//512;
if ok then
begin
nextsegmno:
if ztapesegm>segmno then
begin
monitor(72,zhelp,0,interval);
write(out,<:<10> bad tape, segm.no:>,segmno);
if k>1 then write(out,<<-d>,-(segmno+k-1));
write(out,<: missing:>);
monitor(72,zhelp,0,entrybase);
segmno:=segmno+k;
errors:=errors+1;
if ztapesegm>segmno+7 then
begin
skipped:=skipped+1;
goto recordloop
end;
goto nextsegmno
end;
if blocksize mod 512<>8 then
begin
monitor(72,zhelp,0,interval);
write(out,<:<10> bad tape, segm.no:>,segmno+1);
if k>1 then write(out,<<-d>,-(segmno+k));
write(out,<:, bytes:>,blocksize-8);
monitor(72,zhelp,0,entrybase);
end;
blocksize:=blocksize-8;
segmno:=segmno+k;
loadedsegm:=loadedsegm+k;
if -,loadno then
begin
outrec6(zbs,blocksize);
segbase:=8;
tofrom(zbs,ztape.segbase,blocksize);
end
end;
end type 2, segment record;
begin
comment type 3, end-record;
totalsegm:=totalsegm+segmno;
totalloaded:=totalloaded+loadedsegm;
if ztapeentry<>entryno then
begin
monitor(72,zhelp,0,interval);
write(out,<:<10> bad tape, entries read:>,entryno,
<:, entries saved:>);
if eof then write(out,<: unknown:>) else
write(out,ztape.inf6);
errors:=errors+1;
end;
close(ztape,false);
goto exitrecordloop
end type 3, endrecord;
begin
comment type 4, continue record;
vol:=vol+1;
begin
tapenames(1):=ztape(3);
tapenames(2):=ztape(4);
end;
close(ztape,false add 1);
monitor(72,zhelp,0,interval);
write(out,<:<10>tape shift: <10>:>,<<ddd>,created,
<: entr.,:>,<< ddddd>,totalloaded+loadedsegm,
<: segm. loaded<10>:>,<<ddd>,ztapeentry,
<: entr.,:>,<< ddddd>,ztapesegm,<: segm. saved:>);
if tapenames(1)=real<::> then goto exitrecordloop;
i:=1;
mount;
readlabel(3);
open(ztape,modekind,string tapenames(increase(i)),0);
setposition(ztape,1,1);
monitor(72,zhelp,0,entrybase);
end type 4, continue record;
end case recordtype;
goto recordloop;
end block for ztape declaration;
exitrecordloop:
monitor(72,zhelp,0,interval);
write(out,<:<10>:>,<<ddd>,created,<: entr.,:>,
<< ddddd>,totalloaded,<: segm.<10>:>);
if rejected>0 then
write(out,<:<10>:>,<<ddd>,rejected,<: entr. rejected:>);
if survey and (fileno<lastsurvey or lastsurvey=0) then
begin
fileno:=fileno+1;
goto nextlabel
end;
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
begin
r:=catname(fpkitno(paramno),1);
if r=0.0 or r=1.0 then
write(out,<: kit.:>,<<d>,r) else
write(out,<: kit.:>,
string catname(fpkitno(paramno),increase(i)));
end;
end;
fileno:=fileno+1;
exitnorecords:
if vol<>1 then fileno:=2;
if -,singles then readlabel(2);
exit:
monitor(72)set catbase:(zhelp,0,interval);
if rejected>0 or errors>0 then
loadnotok:
begin
write(out,<:<10>***load not ok :>,<<d>,errors+rejected);
errorbits:=1;
end;
end
end
\f
;
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◀