|
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: 36096 (0x8d00)
Types: TextFile
Names: »tcatsort«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦ebd72877b⟧ »tfput«
└─⟦this⟧
begin
procedure program(out); zone out;
begin
message rc 1978.04.25 catsort;
integer array limits(1:4);
integer catalogs, main_dev_no, main_dev_chain_addr;
system(5)move core area:(92,limits);
main_dev_chain_addr:=limits(4);
catalogs:=(limits(3)-limits(1))/2-1; <*no. of catalogs-1*>
<*limits(1):=addr of first drum chain in nametable*>
<* - (2):= - - - disc - - - *>
<* - (3):= - - - unused - - *>
<* - (4):= - - chaintable for doc with main catalog *>
<*The aux catalogs are internally numbered 0, ... , catalogs*>
<*The main catalog is internally numbered -1 *>
begin <*second level procedure program*>
comment implementation details:
the program sorts and lists the catalog.
by a call of system(5)move core area:(92,limits) the address of the
catalog names are found.
a sortarea is created by means of a monitor call.
the catalog is moved to the sortarea by inrec and outrec, while at the
same time all empty entries, non-specified entries and the sortarea
is skipped.
if the parameter docsort.yes is specified, each record is prolonged
by 10 bytes holding entryname and 0 or, if the entry is a subentry,
then document name and 1, thus making a sorting on these items
possible.
the sorting is performed by a variation of sldisksort.
at last the sorted entries are output, maybe skipping system files;
procedure discsort(filnavn,læ,antalindiv,segmprblok,ngl);
value segmprblok;
string filnavn;
integer læ,antalindiv,segmprblok;
integer array ngl;
begin
integer fysisksubbloklængde, fysiskbloklængde, b;
integer array ia(1:20);
array ra(1:2);
fysisksubbloklængde := 512 * segmprblok;
b:=system(2,b,ra);
if (b-6*512)//(2*fysisksubbloklængde)<1 then
begin
errorbits:=1;
write(out,<:<10>***catsort, process size too small<10>:>);
goto exit;
end;
b:=(b-9*512)//(2*fysisksubbloklængde);
if b<1 then b:=1; <* will be slow *>
fysiskbloklængde := b * fysisksubbloklængde;
segmprblok := b * segmprblok;
begin
integer diff, fa, indivlæ2, logiskbloklængde,
logisksubbloklængde, nedbasis, nedplads, nedslut, opbasis,
opplads, opslut, slut2, start2, subblokstart, transporter;
array field m, ned, op;
integer array nuvblok(0:1);
zone z(fysiskbloklængde//2,1,blproc);
long r;
long field i;
integer j;
integer field indivlæ;
integer field nøgle1, nøgle2, nøgle3, nøgle6;
long field nøgle4, nøgle5, nøgle7, nøgle8;
long prim4, prim5, prim7, prim8, mid4, mid5, mid7,mid8,
prim1,prim2,mid1,mid2;
integer prim3,mid3,prim6, mid6;
boolean bo1,bo2,bo3,bo4,bo5,bo6,bo7,bo8;
procedure blproc(z,s,b);
zone z;
integer s, b;
if s extract 19 < 1 shift 18 or ia(4)<>5 shift 12 then
<*status indeholder ikke 1<18: end doc and operation<>output*>
stderror(z,s,b);
procedure io(plads,operation);
integer plads, operation;
begin
b:=nuvblok(plads)*segmprblok;
if b>=0 then
begin
ia(4):= operation shift 12;
ia(7):= b;
ia(5):= b:= fa + plads*fysiskbloklængde;
ia(6):= b + fysiskbloklængde - 2;
setshare6(z,ia,1);
monitor(16,z,1,ia);
check(z);
end
end io;
procedure quicksort(start,slut,enblok);
value start, slut, enblok;
integer start, slut;
boolean enblok;
begin
for m:=(start+slut)//indivlæ2*indivlæ while
start<slut-indivlæ2 do
begin
op:= start-opbasis;
ned:= slut-nedbasis;
if enblok then m:=m-opbasis else
begin
transporter:=0;
transport(m,0,opplads,nedplads);
nedslut:=ned;
opslut:=op;
end;
mid1:= if nøgle1=0 then 0 else z.m.nøgle1;
mid2:= if nøgle2=0 then 0 else z.m.nøgle2;
mid3:= if nøgle3=0 then 0 else z.m.nøgle3;
mid4:= if nøgle4=0 then 0 else z.m.nøgle4;
mid5:= if nøgle5=0 then 0 else z.m.nøgle5;
mid6:= if nøgle6=0 then 0 else z.m.nøgle6;
mid7:= z.m.nøgle7;
mid8:= z.m.nøgle8;
søgned:
ned:= ned-indivlæ;
if ned < nedslut then
begin
transport(ned,nedbasis,nedplads,opplads);
nedslut:= subblokstart;
end;
prim1:= if nøgle1=0 then 0 else z.ned.nøgle1 - mid1;
prim2:= if nøgle2=0 then 0 else z.ned.nøgle2 - mid2;
prim3:= if nøgle3=0 then 0 else z.ned.nøgle3 - mid3;
prim4:= if nøgle4=0 then 0 else z.ned.nøgle4 - mid4;
prim5:= if nøgle5=0 then 0 else z.ned.nøgle5 - mid5;
prim6:= if nøgle6=0 then 0 else z.ned.nøgle6 - mid6;
prim7:= z.ned.nøgle7 - mid7;
prim8:= z.ned.nøgle8 - mid8;
bo8:= prim8>0;
bo7:=if prim7=0 then bo8 else prim7>0;
bo6:=if prim6=0 then bo7 else prim6>0;
bo5:=if prim5=0 then bo6 else prim5>0;
bo4:=if prim4=0 then bo5 else prim4>0;
bo3:=if prim3=0 then bo4 else prim3<0;
bo2:=if prim2=0 then bo3 else prim2<0;
bo1:=if prim1=0 then bo2 else prim1>0;
if bo1 then goto søgned;
søgop:
op:= op+indivlæ;
if op >= opslut then
begin
transport(op,opbasis,opplads,nedplads);
opslut:= subblokstart + logisksubbloklængde;
if transporter=3 then enblok:= nedslut=subblokstart;
end;
prim1:= if nøgle1=0 then 0 else z.op.nøgle1 - mid1;
prim2:= if nøgle2=0 then 0 else z.op.nøgle2 - mid2;
prim3:= if nøgle3=0 then 0 else z.op.nøgle3 - mid3;
prim4:= if nøgle4=0 then 0 else z.op.nøgle4 - mid4;
prim5:= if nøgle5=0 then 0 else z.op.nøgle5 - mid5;
prim6:= if nøgle6=0 then 0 else z.op.nøgle6 - mid6;
prim7:= z.op.nøgle7 - mid7;
prim8:= z.op.nøgle8 - mid8;
bo8:=prim8<0;
bo7:=if prim7=0 then bo8 else prim7<0;
bo6:=if prim6=0 then bo7 else prim6<0;
bo5:=if prim5=0 then bo6 else prim5<0;
bo4:=if prim4=0 then bo5 else prim4<0;
bo3:=if prim3=0 then bo4 else prim3>0;
bo2:=if prim2=0 then bo3 else prim2>0;
bo1:=if prim1=0 then bo2 else prim1<0;
if bo1 then goto søgop;
if op+opbasis < ned+nedbasis then
begin
for i:=4 step 4 until indivlæ do
begin
r:=z.op.i;
z.op.i:=z.ned.i;
z.ned.i:=r
end;
if indivlæ extract 2 = 2 then
begin
j:=z.op.indivlæ;
z.op.indivlæ:=z.ned.indivlæ;
z.ned.indivlæ:=j
end;
goto søgned;
end;
slut2:= op+opbasis;
start2:= start;
start:= ned+nedbasis;
if slut-start < slut2-start2 then
begin
i:=slut;
slut:=slut2;
slut2:=i;
i:=start;
start:=start2;
start2:=i;
end;
if start2<slut2-indivlæ2 then quicksort(start2,slut2,enblok);
end for m;
end quicksort;
procedure transport(fysisk,basis,plads,andenplads);
integer fysisk, basis, plads, andenplads;
begin
integer logisk, blok, blokrel, subbloknr, blokbasis;
logisk:= fysisk+basis;
blok:= logisk//logiskbloklængde;
blokrel:= logisk mod logiskbloklængde;
if blok = nuvblok(0) then plads := 0 else
if blok = nuvblok(1) then plads := 1 else
begin
plads := 1-andenplads;
io(plads,5);
nuvblok(plads):= blok;
io(plads,3);
end;
subbloknr := blokrel//logisksubbloklængde;
blokbasis := plads * fysiskbloklængde;
fysisk := blokrel + subbloknr * diff + blokbasis;
subblokstart := subbloknr * fysisksubbloklængde + blokbasis;
basis := logisk - fysisk;
transporter := transporter + 1;
end transport;
open(z,4,filnavn,1 shift 18);
close(z,false);
getzone6(z,ia);
fa:=ia(19)+1;
getshare6(z,ia,1);
indivlæ:=læ;
indivlæ2:=2*indivlæ;
nøgle1:= ngl(1);
nøgle2:= ngl(2);
nøgle3:= ngl(3);
nøgle4:= ngl(4);
nøgle5:= ngl(5);
nøgle6:= ngl(6);
nøgle7:= ngl(7);
nøgle8:= ngl(8);
diff:= fysisksubbloklængde mod indivlæ;
logisksubbloklængde := fysisksubbloklængde - diff;
logiskbloklængde := b * logisksubbloklængde;
nuvblok(0) := nuvblok(1) := -1;
opbasis:= nedbasis:= nedplads:= 0;
quicksort(-indivlæ, indivlæ*antalindiv, false);
io(0,5);
io(1,5);
end zone blok;
end discsort;
zone z(128, 1, stderror);
integer array cattable(0:catalogs,1:7), ia(1:20), key(1:8), help(1:1);
real array param(1:3),fpparam1,fpparam2(1:2),catname(1:6);
long array field laf;
real array field raf;
boolean tempbase, maincat_specified;
array field name,doc, tailname;
integer array field interval;
integer field f,f1,f2,f16;
integer i, j, k, l, length, cat, lim, old1, old2, new1, new2,new,old,
rec,sysbase,baselow,baseup,contents,sep,t,segno,segm,sum,total,
c1,c2,line,page,projectlow,projectup,perm,entrylines,shortclock,
userlow,userup,persegm,totpersegm;
long lg; real r;
boolean array catyes(-1:catalogs);
boolean mini,sp,systemonly,systemyes,basesortyes,docsortyes,
nosortyes,slicesortyes,nameyes,docnameyes,baselim,skip,bo1,bo2;
procedure outshortclock(shortclock); integer shortclock;
begin real r;
write(out,<:d.:>,<<zddddd>,
systime(4,(if shortclock>0 then shortclock
else shortclock + extend 1 shift 24)
/625*1 shift 15+12,r),
<:.:>,<<zddd>,r/100)
end outshortclock;
procedure outmodekind;
begin integer i;
for i:=1 step 1 until 21 do
begin
if segm=(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>,segm shift (-12),<:.:>,
<<d>,segm extract 12,sp,
if segm extract 12<10 then 2 else 1);
end
else
begin
write(out,sp,1,case i of (
<: ip:>,
<: bs:>,
<: tw:>,
<: tro:>,
<: tre:>,
<: trn:>,
<: trf:>,
<: tpo:>,
<: tpe:>,
<: tpn:>,
<: tpf:>,
<: tpt:>,
<: lp:>,
<: crb:>,
<: crd:>,
<: crc:>,
<: mto:>,
<: mte:>,
<: nrz:>,
<:nrze:>,
<: pl:> ),
sp, 4)
end
end outmodekind;
procedure outcr(rest);
value rest;
integer rest;
begin
line:= line - 1;
if line < rest then outpage
else write(out, <:<10>:>);
end;
procedure outpage;
begin
integer i;
i:=1;
page:= page + 1;
if mini then
write(out,<:<12><10><10>:>,string catname(increase(i)),<::<10>:>) else
begin
write(out, <:<12><10>catsort page :>,<<d>,page,
<:, name of catalog: :>,string catname(increase(i)),sp,6);
outshortclock(shortclock);
write(out,<:<10><10>:>);
end;
line:= entrylines-4;
end;
comment initialization;
tempbase:=false;
param(3):=real<::>;
lim:=limits(1)-2;
raf:=10; <*fields dic name in array catname*>
for i:=0 step 1 until catalogs do
begin
laf:=i*14;
lim:=lim+2; <*next chain in nametable*>
system(5,lim,help); <*help(1)=address of next chain table*>
if help(1)=main_dev_chain_addr then main_dev_no:=i;
<*internal no of chaintable for device containing main cat*>
system(5,help(1)-28,catname); <*name of aux. catalog, slice length, doc name etc.*>
tofrom(cattable.laf,catname.raf,8); <*document name*>
cattable(i,5):=catname(6) shift (-24) extract 24; <*slice length*>
end;
interval:=2;
f2:=2;
f16:=16;
name:=6;
tailname:=2;
doc:=16;
page:=0;
sp:=false add 32;
catyes(-1):=true;
maincat_specified:=false;
for i:=0 step 1 until catalogs do catyes(i):=false;
systemonly:=false;
systemyes:=false;
basesortyes:=true;
docsortyes:=false;
slicesortyes:=false;
nosortyes:=false;
nameyes:=false;
docnameyes:=false;
baselim:=false;
mini:=false;
k:=1;
if system(4)fpparam:(k,param)=6 shift 12+10 then k:=2; <*=, name follows*>
system(4,k-1,param); <*program name*>
i:=1; open(z,0,string param(increase(i)),0); <*program name -> z*>
monitor(42<*lookup*>,z,0,ia); <*lookup program name*>
entrylines:=ia(7) shift (-12) extract 11; <*file count bruges til layout*>
close(z,true);
sep:=system(4,k,param); <*first param*>
for sep:=sep while sep<>0 do
begin
t:=0;
for i:=1 step 1 until 10 do
if t=0 then
begin
case i of
begin
if param(1)=real<:mainc:> add 97 and
param(2)=real<:t:> then t:=1;
if param(1)=real<:subca:> add 116 then t:=2;
if param(1)=real<:syste:> add 109 then t:=3;
if param(1)=real<:bases:> add 111 and
param(2)=real<:rt:> then t:=4;
if param(1)=real<:docso:> add 114 and
param(2)=real<:t:> then t:=5;
if param(1)=real<:nosor:> add 116 then t:=6;
if param(1)=real<:name:> then t:=7;
if param(1)=real<:docna:> add 109 and
param(2)=real<:e:> then t:=8;
if param(1)=real<:base:> then t:=11;
if param(1)=real<:slice:> add 115 and
param(2)=real<:ort:> then t:=12;
end
end;
if t=0 then goto paramerror;
k:=k+1;
sep:=system(4,k,param); <*next param*>
if t<>2 and t<>11 and sep<>8 shift 12+10 or
(t=2 or t=11) and sep shift (-12)<>8 then goto paramerror;
if t<>11 then
begin
if t=2 and sep=8 shift 12+4 <*point integer*> then t:=9;
if t=2 and param(1)<>real<:yes:> and param(1)<>real<:no:> then t:=13;
if t=3 and param(1)=real<:only:> then t:=10;
if (t<7 or t=12) and param(1)<>real<:yes:> and param(1)<>real<:no:>
then goto paramerror;
case t of
begin
catyes(-1):=maincat_specified:=param(1)=real<:yes:>;
begin
bo1:=param(1)=real<:yes:>;
for i:=0 step 1 until catalogs do catyes(i):=bo1;
catyes(-1):=maincat_specified or -,bo1;
<*subcat.yes => -,maincat unless specified*>
end;
systemyes :=param(1)=real<:yes:>;
basesortyes:=param(1)=real<:yes:>;
docsortyes:=param(1)=real<:yes:>;
nosortyes:=param(1)=real<:yes:>;
begin
nameyes:=true;
fpparam1(1):=param(1);
fpparam1(2):=param(2)
end;
begin
docnameyes:=true;
fpparam2(1):=param(1);
fpparam2(2):=param(2)
end;
begin
if param(1)>catalogs or param(1)<0 then goto paramerror;
catyes(param(1)):=true;
catyes(-1):=maincat_specified;
<*subcat.<integer> => not maincat unless specified*>
end;
systemonly:=systemyes:=true;
;
slicesortyes:=param(1)=real<:yes:>;
<*13*> begin
for i:=0 step 1 until catalogs do
begin
raf:=0;
if param.raf(1)=real<::> add cattable(i,1) shift 24
add cattable(i,2) and
param.raf(2)=real<::> add cattable(i,3) shift 24
add cattable(i,4) then
begin
catyes(i):=true;
catyes(-1):=maincat_specified;
<*subcat.<name> => not maincat unless specified*>
goto catname_found;
end;
end;
goto paramerror;
catname_found:
end;
end
end
else
begin
baselim:=true;
if sep=8 shift 12+10 then
begin
t:=0;
for i:=1,2,3,4 do
if t=0 then
begin
if param(1)=real(case i of (<:temp:>,<:login:>,<:user:>,
<:proje:> add 99)) then t:=i*2;
end;
if t=0 then goto paramerror;
k:=k+1;
sep:=system(4,k,param);
if sep shift (-12)<>8 then k:=k-1 else
begin
if param(1)<>real<:min:> then goto paramerror;
mini:=true;
end;
system(11)get intervals:(0,ia);
userlow:=ia(5);
userup:=ia(6);
projectlow:=ia(7);
projectup:=ia(8);
baselow:=ia(t-1);
baseup:=ia(t);
if t=2 then tempbase:=true;
end
else
begin
baselow:=param(1);
k:=k+1;
sep:=system(4,k,param);
if sep<>8 shift 12+4 then goto paramerror;
baseup:=param(1);
end
end;
k:=k+1;
sep:=system(4,k,param);
end read parameters;
if slicesortyes then basesortyes:=docsortyes:=false;
if nosortyes then
begin
systemyes:=true;
nameyes:=docnameyes:=basesortyes:=docsortyes:=
baselim:=systemonly:=false;
end;
comment central loop. lookup all catalogs, sort and list each of them;
for cat:=-1 step 1 until catalogs do
<*main cat = -1, aux cats = 0, ... , catalogs*>
if catyes(cat) then
begin <*central loop, catalog specified*>
lim:=limits(1)+2*(if cat=-1 then main_dev_no else cat);
<*entry in nametable to find address of chaintable*>
<*for main cat chaintable for disc containing main cat*>
system(5)move core:(lim, help); <*help(1):=addr of chaintable*>
system(5)move core:(help(1)-28, catname);
<*name of auxcat, size, doc name, last slice no of doc, *>
<*first slice of chaintable area *>
if cat=-1 then
begin <*aux cat name for main dev exchanged with <:catalog:>*>
catname(1):=real <:catal:> add 111;
catname(2):=real <:g:> ;
end;
if catname(1) shift (-24) extract 24 <> 0 then
begin <*sort and print the catalog*>
comment move the catalog into a sortarea;
zone oldcat(128, 1, waitproc);
procedure waitproc(z,s,b);
zone z;
integer s,b;
begin
own integer wait;
if s shift (-2) extract 1=1 then
begin <*rejected*>
wait:=wait+1;
if wait>10000 then
begin
bad:
line:=0;
outcr(0);
write(out,<:<10>device :>,
if wait>10000 then <:inaccessible<10>:>
else <:disconnected<10>:>);
wait:=0;
close(oldcat,true);
goto hopeless
end
end
else
if s shift (-4) extract 1=1 then goto bad <*disconnected*>
else stderror(z,s,b);
end waitproc;
systime(1,0,r);
lg:=r*625;
shortclock:=lg shift (-15) extract 24;
i:=1;
open(oldcat, 4, string catname(increase(i)), 0); <*actual catalog entry*>
monitor(76)lookup head and tail:(oldcat,0,ia);
sysbase:=ia.interval(2)-1; <*upper base of entry name-1*>
comment system files are identified by baseup;
monitor(42)lookup catalog:(oldcat, 0, ia);
length:= ia(1); <*no. of segments in the catalog*>
if docsortyes and -,(nameyes or docnameyes) then
ia(1):=(ia(1)*15)//11+1; <*length of sortarea (11 recs a 46 bytes pr segm)*>
rec:=if docsortyes then 46 else
if slicesortyes or basesortyes then 36 else 34;
<*rec length in sortrea*>
if nosortyes then
begin
length:=15*length; <*no. of entries in the catalog*>
totpersegm:=0;
close(oldcat,true);
goto sorted
end;
ia(2):= 0; <*document name=0 <=> pref. drum*>
comment document = pref.drum;
open(z, 4, <::>, 0); <*entry name=<::> <=> work name*>
if monitor(40)create entry sortarea:(z, 0, ia)<>0 then
begin
write(out,<:<10>***catsort, create sortarea impossible:>);
errorbits:=1;
close(oldcat,true);
goto exit
end;
system(11,0,ia);
old1:=ia(1); <*l. catalog base*>
old2:=ia(2); <*u. - - *>
comment base of actual process;
getzone6(z,ia); <*descr. of actual work area*>
i:=15*length; <*no. of entries in the catalog*>
length:=0;
for i:= i step -1 until 1 do
begin <*one entry at a time*>
inrec6(oldcat,34);
skip:=false;
comment skip empty;
if oldcat.f2 shift (-12)=4095 and -,nosortyes then skip:=true; <*empty entry*>
if -,skip and baselim then
begin
comment skip outsides specified base;
skip:=oldcat.interval(1)<baselow or
oldcat.interval(2)>baseup;
if tempbase and oldcat.f2 extract 3<>0 then skip:=true; <*temp=>-, login*>
end;
if -,skip and (nameyes or docnameyes) then
begin
comment skip unspecified names;
bo1:=nameyes and
(fpparam1(1)<>oldcat.name(1) or
fpparam1(2)<>oldcat.name(2));
bo2:=docnameyes and
(fpparam2(1)<>oldcat.doc(1) or
fpparam2(2)<>oldcat.doc(2));
skip:=if nameyes and docnameyes then
bo1 and bo2 else bo1 or bo2;
end;
comment skip system files;
if -,skip and -,systemyes then
skip:=oldcat.interval(2)=sysbase;
comment skip non-system files;
if -,skip and systemonly then
skip:=oldcat.interval(2)<>sysbase;
comment skip actual work area;
if -,skip and ia.tailname(1)=oldcat.name(1) then
skip:=ia.tailname(2)=oldcat.name(2) and
old1=oldcat.interval(1) and old2=oldcat.interval(2);
if skip and nosortyes then
begin
skip:=false;
oldcat.f2:=-1 <*simulates empty entry*>
end;
if -,skip then
begin
outrec6(z,rec);
length:=length+1; <*counts recs in sortarea*>
tofrom(z,oldcat,34); <*entry=17 words*>
f:=36;
if basesortyes then
begin
z.f:=z.f2;
z.f2:=z.f2 extract 3;
end
else
if slicesortyes then z.f:=z.f2 shift (-12);
if docsortyes then
for f:=38 step 2 until rec do
begin
k:=if z.f16<>2048 shift 12 add 4 then 0 else 1; <*area or bs entry*>
f1:=f-(if k=0 then 30 else 20);
z.f:=if f=46 then k else z.f1
end;
end;
end <*one entry at a time*>;
close(oldcat, true);
setposition(z, 0, 0);
comment sort the catalog;
for i:=1 step 1 until 6 do key(i):=0;
key(7):=10; <*namesort*>
key(8):=14; <* - *>
if basesortyes then
begin
key(1):=4; <*lower entry base*>
key(2):=6; <*upper - - *>
key(3):=2; <*1. slice, namekey*>
end;
if slicesortyes then key(6):=36 <*1. slice*> else
if docsortyes then
begin
key(4):=40; <*document name*>
key(5):=44; <*document name*>
key(6):=46; <*subentry or not*>
end;
i:=1;
if length>1 then
discsort(string ia.tailname(increase(i)),rec,length,1,key);
sorted: if nosortyes then
begin
i:=1; open(z,4,string catname(increase(i)),0);
end;
for i:=0 step 1 until catalogs do cattable(i,6):=cattable(i,7):=0; <*slices, entries*>
comment list the catalog;
sum:=total:=c1:=c2:=segno:=line:=old:=old1:=old2:=perm:=0;
for i:=length step -1 until 1 do
begin <*list the catalog*>
if nosortyes and i<>length and i mod 15=0 then
begin
inrec6(z,2);
persegm:=z.f2;
totpersegm:=totpersegm+persegm;
end;
inrec6(z,rec);
new1:=z.interval(1);
new2:=z.interval(2);
f:=32; contents:=z.f shift (-12);
f:=if docsortyes then 36 else 8;
new:=z.f shift (-16) extract 8;
comment print one line. print layout;
if basesortyes and (new1 <> old1 or new2<>old2
or perm<>z.f2) then
begin
if i<>length then
begin
write(out,<:<10>:>,sp, if basesortyes then 13 else 30,
<<-ddddd>,sum,<: segm.:>,c1,<: entr.:>);
line:=line-1;
sum:=c1:=0;
outcr(5);
end;
outcr(0);
write(out,<: base::>,<<-ddddddd>,new1,new2);
if baselim and z.f2=3 then
write(out,if new1=userlow and new2=userup then
<: user:> else if new1=projectlow and
new2=projectup then <: project:> else
<: perm:>)
else
write(out,case z.f2+1 of
(<: temp:>,<: key1:>,<: login:>,<: perm:>));
outcr(1);
end
else
if nosortyes then
begin
if i mod 15=0 and i<>length then
write(out,<:<10>:>,<<d>,persegm,<: entries<10>:>);
outcr(if i mod 15=0 then 5 else 0);
end
else
begin
if new<>old and -,basesortyes and -,slicesortyes then outcr(5);
outcr(0)
end;
if nosortyes and i mod 15=0 then
begin
write(out,<<d>,segno,<:. segm.<10>:>);
line:=line-1;
segno:=segno+1
end;
old1:=new1;
old2:=new2;
old:=new;
perm:=z.f2 extract 3;
comment print one entry;
k:=1;
if z.f2 shift (-12)=4095 then segm:=0 else
begin <*empty entry*>
segm:=z.f16;
c1:=c1+1;
c2:=c2+1
end;
if z.f2 shift (-12)<>4095 then
begin <*non empty entry*>
if segm>=0 then
begin <*area entry*>
if cat=-1 then
begin <*main cat, the proper auxcat no is found*>
j:=-1;
for j:=j+1 while -,(z.doc(1)=real<::> add cattable(j,1)
shift 24 add cattable(j,2) and
z.doc(2) =real <::> add cattable(j,3)
shift 24 add cattable(j,4)) and j<catalogs do;
end else
<*aux cat, the aux cat no is cat*>
j:=cat;
cattable(j,6):=cattable(j,6)+
(segm+cattable(j,5)-1)//cattable(j,5);
cattable(j,7):=cattable(j,7)+1;
sum:=sum+segm;
total:=total+segm
end
else
begin <*non area entry*>
f:=if basesortyes then 36 else f2;
if z.f shift (-12) <> 0 then
begin <*first slice<>0 <=> entry belongs to an aux cat*>
j:=(z.f shift (-12) extract 11)//2;
cattable(j,7):=cattable(j,7)+1;
end;
<*non area entries belonging to main cat only*>
<*are not counted *>
end;
end <*non empty entry*>;
if nosortyes and z.f2 shift (-12)=4095 then
write(out,<: -:>) else
begin <*print one line*>
write(out, sp, 14 - write(out,
sp,if docsortyes and segm=2048 shift 12 add 4 then 2 else 0,
string z.name(increase(k))));
if -,basesortyes then
begin
write(out,
<<dddd>, z.f2 shift(-12), z.f2 shift(-3) extract 9,
z.f2 extract 3, sp,1);
comment first slice, segment, key;
write(out,<< -ddddddd>,new1,new2);
comment interval;
end;
if segm >= 0 then write(out, <<ddddd>, segm, sp,4)
else outmodekind;
comment length or mode.kind;
f:= 18;
raf:=10; <*to field docname in array catname*>
k:= 1;
write(out, sp, 12 -
write(out, if segm>=0 and cat<>-1 then string catname.raf(increase(k)) else
string z.doc(increase(k))));
<* document name of area entries in aux cats are taken*>
<*from the doc name of the catalog,for area entries*>
<*in the main catalog or non area entries from the *>
<*doc name of the entry itself *>
for f:= 26 step 2 until 34 do
begin
write(out, <: :>);
if f=26 and z.f<>0 and contents<>4 and contents<=32 then
outshortclock(z.f) else
begin
if mini then goto endline;
if z.f shift(-12) <> 0 then
write(out, <<d>, z.f shift(-12), <:.:>);
write(out, <<d>, z.f extract 12);
end;
comment rest of the tail;
end;
endline:
end print one line;
end list the catalog;
if basesortyes and c1<>0 then
begin
write(out,<:<10>:>,sp,13,
<<-ddddd>,sum,<: segm.:>,c1,<: entr.:>);
end;
if nosortyes then
begin
inrec6(z,2);
write(out,<:<10>:>,<<d>,z.f2,<: entries<10>:>);
totpersegm:=totpersegm+z.f2;
end;
if c1=0 then outcr(0);
if nosortyes then
write(out,<:<10>:>,<<d>,totpersegm,<: entries:>);
write(out,<:<10><10>:>,sp,if basesortyes then 6 else 37,
<:total: :>,<<-ddddd>,total,<: segm.:>,c2,<: entr.:>);
hopeless:
close(z, true);
outcr(catalogs+5); sum:=0;
write(out,<:<10><10><10>:>);
for i:=0 step 1 until catalogs do
begin
if cattable(i,1)<>0 and cattable(i,6)+cattable(i,7)<>0 then
begin
k:=1;
j:=cattable(i,5)*cattable(i,6);
sum:=sum+j;
write(out,<:<10>:>);
write(out,sp,10-write(out,string (
real<::> add cattable(i,increase(k)) shift 24 add
cattable(i,increase(k)))));
write(out,<:::>,<<dddd>,cattable(i,6),<: slices *:>,
<<ddd>,cattable(i,5),<: = :>,<<dddddd>,j,<: segments:>,
<< dddd>,cattable(i,7),<: entries:>);
end;
end for i;
j:=0;
for i:=0 step 1 until catalogs do
if cattable(i,6)<>0 then j:=j+cattable(i,5)*cattable(i,6); <*total no of segments in all documents*>
if j>1 then
begin
write(out,<:<10><10><10>:>);
write(out,sp,22,<:total = :>,<<dddddd>, j,<: segments:>);
end;
monitor(48)remove entry:(z, 0, ia);
end <*sort and list the catalog*>;
end <*central loop, catalog specified*>;
if false then
paramerror:
begin long array field laf;
write(out,<:<10>***catsort error param: :>);
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,param.laf)
else write(out,<<d>,param(1));
k:=k+1;
sep:=system(4,k,param);
end;
errorbits:= 1;
end listfp;
exit:
end second level procedure program
end procedure program
;
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◀