|
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: 43008 (0xa800)
Types: TextFile
Names: »catsort3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »catsort3tx «
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 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>***:>, progname, <: 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 entryname,docname,param(1:3),fpparam1,fpparam2(1:2),catname(1:6);
long array outfile, chainname, progname (1:2);
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,f18,f26,f32;
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,syslow,sysup,persegm,totpersegm, sepleng, result,
fromsize,tosize,fromcont,tocont;
long lg;
real r,fromtime,totime,time;
boolean array catyes(-1:catalogs);
boolean mini,sp,systemonly,systemyes,basesortyes,docsortyes,
nosortyes,slicesortyes,nameyes,docnameyes,baselim,scopelim,timeyes,
sizeyes,skip,bo1,bo2;
integer
procedure stack_current_output (file_name);
long array file_name ;
begin
integer result ;
result := 2; <*1<1 <=> 1 segment, preferably disc*>
fp_proc (29, 0, out, chain_name); <*stack c o*>
fp_proc (28, result, out, file__name); <*connect *>
if result <> 0 then
fp_proc (30, 0, out, chain_name); <*unstack *>
stack_current_output := result;
end stack_current_output;
procedure unstack_current_output ;
begin
fp_proc (34, 0, out, 25); <*close up*>
fp_proc (79, 0, out, 0); <*terminate*>
fp_proc (30, 0, out, chain_name); <*unstack *>
end unstack_current_output;
procedure outshortclock(shortclock); integer shortclock;
begin real r;
write(out,<:d.:>,<<zddddd>,
systime (6, shortclock, r),
<:.:>,<<zddd>,entier (r/100));
end outshortclock;
real
procedure check_time (ra, ymd );
real array ra ;
boolean ymd ;
begin
integer r1, r2, r3;
r1 := entier ( ra (1) / 10000);
r2 := entier (( ra (1) - r1 * 10000 )/ 100 );
r3 := entier ( ra (1) - r1 * 10000 - r2 * 100 );
if ymd then
begin <*year, month, date*>
if r1 < 76 or r1 > 99
or r2 < 1 or r2 > 12 then
goto paramerror;
if r3 < 1 or r3 > ( case r2 of (
31, if r1 mod 4 = 0 and r1 mod 400 <> 0 then 29 else 28,
31, 30, 31, 30, 31, 31, 30, 31, 30, 31))
then goto paramerror;
end else
begin <*hour, min , sec*>
if r1 >= 24
or r2 >= 60
or r3 >= 60 then
goto paramerror;
end;
checktime := r1 * 10000 + r2 * 100 + r3;
end procedure checktime;
procedure outmodekind;
begin integer i;
for i:=1 step 1 until 23 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,
<*mthh*> 1 shift 23 +128 shift 12 + 18,
<*mthl*> 1 shift 23 +132 shift 12 + 18,
<*pl*> 1 shift 23 + 0 shift 12 + 20 ))
then goto found
end;
found:
if i=24 then
begin
write(out,<<dddd>,segm shift (-12),<:.:>,
<<d>,segm extract 12,sp,
if segm extract 12<10 then 2 else 1);
end
else
begin
write(out, true, 8, case i of (
<: ip:>,
<: bs:>,
<: tw:>,
<: tro:>,
<: tre:>,
<: trn:>,
<: trf:>,
<: tpo:>,
<: tpe:>,
<: tpn:>,
<: tpf:>,
<: tpt:>,
<: lp:>,
<: crb:>,
<: crd:>,
<: crc:>,
<:mtlh:>,
<: mte:>,
<:mtll:>,
<:nrze:>,
<:mthh:>,
<:mthl:>,
<: pl:> ));
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 or progname (1) = long <:cat:> then
write(out,<:<12><10><10>:>,string catname(increase(i)),<::<10>:>) else
begin
write(out, <:<12><10>:>, true, 8, progname, <: 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;
f18:=18;
f26:=26;
f32:=32;
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:=true;
basesortyes:=true;
docsortyes:=false;
slicesortyes:=false;
nosortyes:=false;
nameyes:=false;
docnameyes:=false;
timeyes := false;
sizeyes := false;
baselim:=scopelim:=false;
mini:=false;
fromtime := 0; <*default*>
to__time := '600; <*default*>
fromsize :=
fromcont := 0; <*default*>
to__size :=
to__cont := 8388607; <*default*>
trapmode := 1 shift 10; <*no end alarm written*>
system (4, 0, out_file);
sepleng :=
system (4, 1, progname);
if sepleng shift (-12) <> 6 <*=*> then
begin <*noleft side, progname is param after programname*>
for i := 1, 2 do
begin
prog_name (i) := out_file (i);
out__file (i) := long <::> ;
k := 1 ;
end;
end <*no left side*> else
k := 2;
if out_file (1) <> long <::> then
begin <*stack current out and connect*>
result := stack_current_output (out_file);
if result <> 0 then
begin
write (out, "nl", 1, <:***:>, progname, "sp", 1, <:connect :>, outfile,
"sp", 1, case result of (
<:no resources:>,
<:malfunction:>,
<:not user, not exist:>,
<:convention error:>,
<:not allowed:>,
<:name format error:> ));
out_file (1) := long <::>;
end else
trap (exit);
end <*stack current out and connect*>;
open (z, 0, progname, 0);
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*>
if sep = 0 then
begin <*default : base.project*>
system (11) get intervals :(0, ia);
baselow := projectlow := ia (7);
baseup := projectup := ia (8);
baselim := true ;
end else
begin <*at least one parameter*>
for sep:=sep while sep<>0 do
begin
t:=0;
for i := 1 step 1 until 18 do
if param (1) = real ( case i of (
<:main:> ,
<:cat:> ,
<:syste:> add 'm',
<:bases:> add 'o',
<:docso:> add 'r',
<:sort:> ,
<:name:> ,
<:docna:> add 'm',
<:*:> ,
<:*:> ,
<:base:> ,
<:slice:> add 's',
<:scope:> ,
<:befor:> add 'e',
<:after:> ,
<:min:> ,
<:size:> ,
<:cont:> )) and
param (2) = real ( case i of (
<::> ,
<::> ,
<::> ,
<:rt:> ,
<:t:> ,
<::> ,
<::> ,
<:e:> ,
<::> ,
<::> ,
<::> ,
<:ort:> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> )) then
begin t := i; i := 18; end;
if t = 0 then
begin <*alternative param names*>
if param (1) = real <:mainc:> add 'a' and
param (2) = real <:t:> then
t := 1
else
if param (1) = real <:subca:> add 't' and
param (2) = real <::> then
t := 2
else
if param (1) = real <:nosor:> add 't' and
param (2) = real <::> then
t := 19;
end;
if t=0 then goto paramerror;
k:=k+1;
sep:=system(4,k,param); <*next param*>
if t<>2 and t<>11 and t <> 13 and t <> 14 and t <> 15 and t<>17 and t<>18 and
<*not cat, base, scope, before, after, size, cont*>
sep <> 8 shift 12 + 10
or (t= 2 or t= 11 or t = 13) and
<*cat, base or scope*>
sep shift (-12) <> 8
or (t=14 or t= 15 or t = 17 or t = 18) and
<*before, after, size, cont*>
sep <> 8 shift 12 + 4 then
goto paramerror;
if t<>11 and t<>13 then
begin <*not base or scope*>
if t=2 and sep=8 shift 12+4 <*point integer*> then t:=9; <*cat.<integer>*>
if t=2 and param(1)<>real<:yes:> and param(1)<>real<:no:> then t:=13; <*cat/<yes.no>*>
if t=3 and param(1)=real<:only:> then t:=10; <*system.only*>
if (t<7 or t=12 or t=16) 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<:no:>;
begin
nameyes:=true;
entryname(1):=param(1);
entryname(2):=param(2)
end;
begin
docnameyes:=true;
docname(1):=param(1);
docname(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
j := -1;
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*>
j := i;
i := catalogs;
end;
end;
if j = -1 and param (1) = real <:main:> then
begin <*disc holding main catalog*>
catyes (main_devno) := true;
catyes ( -1) := maincat_specified;
end else
if j = -1 then
goto paramerror;
end <*case 13*>;
begin <*14 : before*>
timeyes := true;
fpparam1 (1) := param (1); <*year, month, date*>
k := k + 1;
sep := system (4, k, param);
if sep <> 8 shift 12 + 4 then
goto paramerror;
to__time :=
check_time (fpparam1, true ) * 1000000 +
check_time ( param , false);
end <*case 14*>;
begin <*15 : after*>
timeyes := true;
fpparam1 (1) := param (1);
k := k + 1;
sep := system (4, k, param);
if sep <> 8 shift 12 + 4 then
goto paramerror;
from_time :=
check_time (fpparam1, true ) * 1000000 +
check_time ( param , false);
end <*case 15*>;
<*16*> mini := param (1) = real <:yes:>;
begin <*17, size*>
sizeyes := true;
fromsize := param (1);
k := k + 1;
sep := system (4, k, param);
if sep <> 8 shift 12 + 4 then
goto paramerror
else
to__size := param (1);
end <*17*>;
begin <*18, cont*>
fromcont := param (1);
k := k + 1;
sep := system (4, k, param);
if sep <> 8 shift 12 + 4 then
goto paramerror
else
to__cont := param (1);
end <*18*>;
<*19*> nosortyes := param (1) = real <:yes:>;
end
end
else
begin <*t = 11 of t = 13*>
if t = 11 then baselim := true else scopelim := true;
if sep=8 shift 12+10 then
begin
t:=0;
for i:=1,2,3,4,5 do
if t=0 then
begin
if param(1)=real(case i of (<:temp:>,<:login:>,<:user:>,
<:proje:> add 'c', <:syste:> add 'm')) 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);
syslow:=ia( 9):=-8388607;
sysup :=ia(10):= 8388605;
baselow:=ia(t-1);
baseup:=ia(t);
if t=2 then tempbase:=true;
if t=5 then systemyes:=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;
end <*at least one parameter*>;
if slicesortyes then basesortyes:=docsortyes:=false;
if progname (1) = long <:cat:> then
begin <*ignore nosort param and set endless page*>
nosortyes := false ;
entrylines := 8388607;
end else
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>***:>, progname, <: 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*>
comment skip system files;
if -,skip and -,systemyes then
skip:=oldcat.interval(1)=syslow and oldcat.interval(2)=sysup;
comment skip non-system files;
if -,skip and systemonly then
skip:=oldcat.interval(1)<>syslow or oldcat.interval(2)<>sysup;
if -,skip and (baselim or scopelim) then
begin
skip :=
if baselim then
oldcat.interval (1) < extend baselow or
oldcat.interval (2) > extend baseup
else
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
(entryname(1)<>oldcat.name(1) or
entryname(2)<>oldcat.name(2));
bo2:=docnameyes and
(docname(1)<>oldcat.doc(1) or
docname(2)<>oldcat.doc(2));
skip:=if nameyes and docnameyes then
bo1 and bo2 else bo1 or bo2;
end;
if -,skip and timeyes then
begin <*check shortclock*>
segm := oldcat.f16 ;
contents := oldcat.f32 shift (-12);
time :=
if cat = -1 and contents <> 4 and contents < 32
or cat > -1 and contents <> 4 and contents < 32 and segm < 0 then
<*maincat non procedure or auxcat non procedure file descr*>
oldcat.f26 <*shortclock*>
else
if cat > -1 and segm >= 0 then
<*auxcat area*>
oldcat.f18 <*latest changed*>
else
-'600; <*all other skipped*>
if time >= 0 and
time <= 4213806 then
time := 4213807; <*750101.000000*>
if time > -'600 then
time :=
systime (6) short to decimal :(time, r) * 1000000 + r;
skip := time < fromtime - .5 or
time > to__time + .5 ;
end <*check shortclock*>;
<*skip area entry with size outside interval*>
if -,skip and sizeyes then
begin
segm := oldcat.f16;
skip := segm < fromsize or segm > tosize;
end;
<*skip entries with contents outside interval*>
if -,skip then
begin
contents := oldcat.f32 shift (-12);
skip := contents < fromcont or contents >tocont;
end;
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);
if progname (1) = long <:cat:> then
goto sorted;
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
if new1=syslow and new2=sysup then <: system:> else
<: perm:>)
else
write(out,case z.f2+1 of
(<: temp:>,<: temp spec:>,<: 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,if docsortyes and segm=2048 shift 12 add 4 then 2 else 0,
true, 12, 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);
comment first slice, segment, key;
write(out,<< -ddddddd>,new1,new2);
comment interval;
end;
if segm >= 0 then write(out, true, 8, <<ddddddd>, segm)
else outmodekind;
comment length or mode.kind;
f:= 18;
raf:=10; <*to field docname in array catname*>
k:= 1;
if cat = -1 or segm < 0 then <*maincat or auxcat non area*>
write (out, true, 12, string z.doc (increase (k)), "sp", 10)
else
begin <*auxcat area entry => counters instead of docname*>
write (out, <:->:>);
for f := 20, 22 do
write (out, true, 9, << ddddddd>, z.f); <*write and read counters*>
write (out, <:<-:>);
end;
<* document name of area entries in aux cats are dis-*>
<*played as the relevant counters , 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
if -,mini then
begin
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;
if cat >= 0 and segm >= 0 then
begin
write (out, "nl", 1, "sp", if basesortyes then 16 else 46);
for f := 18, 24 do
begin
write (out, "sp", 4, if f = 18 then <:-> :> else <:<- :>);
outshortclock (z.f);
end;
end;
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>***:>, progname, <: 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,<<dddddd>,param(1));
k:=k+1;
sep:=system(4,k,param);
end;
errorbits:= 1;
end listfp;
exit:
outchar (out, 'nl');
if outfile (1) <> long <::> then
unstack_current_output;
end;
end second level program
▶EOF◀