DataMuseum.dk

top - metrics - download

    Length: 7680 (0x1e00)
    Types: TextFile
    Names: »tcompress«

└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
    └─⟦4334b4c0b⟧ 
        └─⟦this⟧ »tcompress« 

TextFile

mode list.yes
compresslib=algol  connect.no blocks.yes details.no
1981-02-04
begin
boolean list,test,survey;
integer lb,ub,segm,i,j,char,content,scopetype,permkey,
 spermkey,entrysegm,olb,oub,area,result,chars;
integer array field rec;
array field raf;
long array field doc,name;
integer array obas,bases(1:8),t(1:10),ht(1:17);
long array oname,progname,scope,sname(1:3);

procedure listentry(ht,text);
integer array ht;
string text;
begin
write(out,"nl",1,true,12,ht.name,
      << dd>,ht(8),"sp",2,true,12,ht.doc,"sp",2,text);
end;

boolean procedure disccopy;
begin
integer result,i,free,
  blocklength,s,fsegm;
integer array todesc,fromdesc(1:20),t,tail(1:10);

free:=((system(2,i,progname)-1536)//512)+1;
blocklength:=free*512;
if test then write(out,"nl",1,<:*disccopy from :>,sname,<: to :>,
   oname);
disccopy:=true;
result:=lookuptail(oname,t);
if result>0 then
begin
  i:=1;
  write(out,<:<10>**:>,string oname(increase(i)),
    <: lookup entry result :>,result,t(1));
disccopy:=false;
end outfile improper
else
begin
  fsegm:=t(1);
  result:=lookuptail(sname,tail);
  if result>0 or tail(1)<=0 then
  begin
    write(out,<:<10>**:>,sname,
    if result>0 then <: lookup result :> else
    <: tail(1) :>,if result>0 then result else
     tail(1));
  end else
  begin
    t(1):=t(1)+tail(1);
    result:=changetail(oname,t);
    if result>0 then
    begin
      write(out,<:<10>**:>,oname,
        <: changeentry result :>,result);
    end;
  end;
end;
if result=0 then
begin
zone z(free*128,1,stderror);

procedure flip;
begin
  getzone6(z,fromdesc);
  setzone6(z,todesc);
end;

procedure flop;
begin
  getzone6(z,todesc);
  setzone6(z,fromdesc);
end;

getzone6(z,todesc);
open(z,4,sname,0);
setposition(z,0,0); flip;
open(z,4,oname,0);
setposition(z,0,fsegm);
s:=tail(1);
if test then write(out,"nl",1,"*",1,oname,<: free :>,free,
   <: first :>,fsegm,<: segments :>,s);;
for i:=free step free until s do
begin
  flop;
  inrec6(z,free*512); flip;
  outrec6(z,free*512);
  outrec6(z,0);
  if test then write(out,"nl",1,<:free moved :>,free*512);
end;
flop;
i:=(tail(1) mod free)*512;
if test then write(out,"nl",1,<:rest :>,i);
inrec6(z,i); flip;
outrec6(z,i); close(z,true); flop;
close(z,true); flip;
close(z,true); flop;
end zone;
end disccopy;

procedure compress;
if oname(1)<>sname(1) or oname(2)<>sname(2) then
begin
integer res,fsegm;
integer array ht(1:17),tail(1:10);
integer array field t;
long array field doc;
if test then write(out,"nl",1,<:*compress :>,sname,<: on :>,oname);
t:=14;
doc:=t+2;
res:=headandtail(sname,ht);
if res=0 and ht.t(1)>0 then
begin
if ht.t(9) shift (-12) extract 12=4 then
begin
  fsegm:=entrysegm;
  entrysegm:=entrysegm+ht.t(1);
  disccopy;
  if list then listentry(ht,<: sub entry:>);
  tail(1):=1 shift 23+4;
  doc:=2;
  for i:=1,2 do tail.doc(i):=oname(i);
  tail(9):=((32+fsegm)shift 12) add (ht.t(9) extract 12);
  for i:=6,7,8,10 do tail(i):=ht.t(i);
  outendcur(10);
  res:=removeentry(sname);
  if res=0 then
  begin
    res:=createentry(sname,tail);
    if res=0 then
    begin
      res:=permentry(sname,permkey);
      if res=0 then
      begin
        res:=setenbase(sname,olb,oub);
        if res<>0 then write(out,"nl",1,<:**:>,sname,
           <: set entry base :>,res);
      end else write(out,"nl",1,<:**:>,sname,
          <: permanent entry :>,res);
    end else write(out,"nl",1,<:**:>,sname,
          <: create entry :>,res);
  end else write(out,"nl",1,<:**remove entry :>,sname,res);
end else
  write(out,"nl",1,<:**:>,true,12,sname,<: content key:>);
end else
  write(out,"nl",1,<:**:>,true,12,sname,if result=0 then
    <:segments <=0 :> else <: lookup result :>,
    if result>0 then result else ht.t(1));
end compress;


rec:=0;
name:=6;
raf:=0;
doc:=16;
lookup_tail(<:catalog:>,t);
segm:=t(1);
content:=4;
readbfp(<:test:>,test,false);
readbfp(<:survey:>,survey,false);
readbfp(<:list:>,list,survey);
if survey then
begin
  readlsfp(oname.raf);
  if fpout then 
  begin
    oname(1):=oname(1) shift 8 add (oname(2) shift (-40) extract 8);
    oname(2):=oname(2) shift 8;
    if test then write(out,"nl",1,<:*proc name :>,oname);
    connectlso;
    permentry(oname,spermkey);
    setenbase(oname,lb,ub);
    write(out,<:<10>; library procedure
:>,oname,<:=algol
external integer procedure :>,oname,
   <:;
begin
write(out,<'<'>:
:>);
end;
end survey else
begin
if -,readlsfp(oname.raf) then alarm(<:<10>***no left side in call:>);
result:=headandtail(oname,ht);
if result>0  then alarm(<:<10>***left side :>,oname,
  <: lookup result :>,result);
if ht(8)<=0 then alarm(<:<10>***left side :>,oname,
  <:disc size<=0:>);
if list then listentry(ht,<: main entry:>);
entrysegm:=ht(8);
permkey:=ht(1) extract 3;
olb    :=ht(2);
oub    :=ht(3);
end -,survey;
raf:=0;
readsfp(<:scope:>,scope.raf,<::>);
i:=scopetype:=0;
repeat
i:=i+1;
if scope(1)=long (case i of (<:login:>,<:day:>,
  <:user:>,<:proje:> add 'c')) then scopetype:=i;
until scopetype>0 or i=4;
i:=case scopetype+1 of (1,3,5,5,7);
spermkey:=case scopetype+1 of (0,2,2,3,3);
system(11,j,bases);
bases(1):=1; bases(2):=0;
lb:=bases(i);
ub:=bases(i+1);
if test then write(out,"nl",1,<:*scopetype :>,scopetype,
  "nl",1,<:*base interval :>,lb,ub,<: key :>,spermkey);
if fpinareas=0 then
begin
integer namecount;
long array names(1:500,1:2);
namecount:=0;
connectcuri(<:catalog:>);
chars:=0;
setposition(in,0,0);
for segm:=segm step -1 until 1 do
begin
  inrec6(in,512);
  for rec:=0 step 34 until 512-34 do
  begin
    if in.rec(1)<>-1 then
    begin
      if lb=in.rec(2) and ub=in.rec(3) then
      begin
        if in.rec(16)shift (-12) extract 12=content and
           in.rec(1) extract 3=spermkey and
           extend in.rec(8)>0 then
        begin
          for i:=1,2 do sname(i):=in.rec.name(i);
          if survey then
          begin
            headandtail(sname,ht);
            if fpout then
             begin
               namecount:=namecount+1;
               for i:=1,2 do names(namecount,i):=sname(i);
               chars:=chars+write(out,"sp",1,true,12,sname);
               if chars>60 then chars:=0*write(out,"nl",1);
             end else
             listentry(ht,<::>);
          end else compress;
        end content;
      end user base;
    end entry;
  end record;
end segments;
  unstackcuri;
if survey and fpout then
begin
  write(out,"nl",1,<::<'>'>);
:>,oname,<::=:>,namecount,<:;
end;
end;
scope :>,case scopetype+1 of (<::>,<:login:>,<:day:>,
   <:user:>,<:project:>),"sp",1,oname,"nl",1,
  true,12,oname,<:=compresslib list.yes :>);
for i:=1 step 1 until namecount do
begin
  name:=8*i;
  write(out,true,12,names.name,if (i+3) mod 5=1 then <:,<10>:> else <: :>);
end;
write(out,"nl",2);
closeout;
end survey and fpout;
end fpinareas=0 else
begin
for area:=1 step 1 until fpinareas do
begin
  readinfp(sname.raf,area);
  if test then write(out,"nl",1,<:*area :>,area,sname);
  compress;
end for area;
end fpinares>0;
end;
mode list.yes
if warning.yes
end
scope user compresslib
clear temp t1 t2
t1=algol list.yes
external procedure t1;
write(out,"nl",1,<:t1:>);
end;
t2=algol list.yes
external procedure t2;
write(out,"nl",1,t2);
end;
if warning.yes
end
lookup t1 t2
t1=compresslib t2 list.yes test.yes
lookup t1 t2
writestd t1 t2
compresslib scope.user survey.yes test.yes
tlibrary=compresslib scope.project survey.yes
mode list.no
finisb
▶EOF◀