⟦3e35fa2c6⟧

TextFile

clear user contract
contract=set 72 disc1
scope user contract
contract=algol index.no
begin
comment
hcø version
1980-08-01
programcall:
contract <mode>.<libfilename> (security.0)0-1 (test.<testlevel>)0-1  ( <names>)0-14

<mode>       == list ! all ! init ! from ! clear ! entry ! temp ! on
<libfilename>== name of discfile used as library (contents key = 10)
<testlevel>  == 1 ! 2 ! 3 ! 4
<names>      == if mode=init then  name of disckit  else  name of textfile to treat

programfunction:
list   gives on current output name and date for all or specified textfiles contained in libfile
all    gives on current output fileinfo as lookup for all or specified textfiles contained in libfile
init   initiates a new file (scope user) as an empty libfile at specified disckit or at disc
entry  creates entrie pointing at specified textfiles in libfile
temp   copies  from libfile specified textfiles onto temp  files
from   copies  from libfile specified textfiles onto day files
on     copies   to  libfile specified textfiles overwriting old files in libfile with same name
clear  removes from libfile specified textfiles

security.0
has only effect in mode  on  and  clear
means removal of given libfile before permanenting new libfile

testfunction:
only ment for tracing program malfunction
level 1 gives    information for files transferred to libfile
level 2 includes segm count from transfer
level 3 includes buffersize for transfer
level 4 includes names of specified parameters
;
\f


zone  cat(128,1,stderror);

array
fpname(1:14,1:2),
libfilename(1:2),
param(1:2);

integer array
headia(1:17),
tail(1:10),
bases(1:8);

array field
name,
raf;

long array field
laf;

integer array field
iaf;

integer field
word;

boolean field
firstbyte;

real
time;

long
l1,
l2;

integer
i,
j,
mode,
test,
item,
fpnr,
segmprslice,
segmprblock,
block,
restbytes,
segm,
firstsegm,
scope,
key,
catentries,
newentries,
lastentry,
lastitem;

boolean
firsttime,
nosecurity,
new,
nl,
sp;


procedure outshortclock(tailcode);
integer tailcode;
begin
real r;
write(out,<:  d.:>,<<zddddd>,
systime(4,( if tailcode>0 then tailcode else
tailcode + extend 1 shift 24)/625 * 1 shift 15 + 12  ,  r  ),
<:.:>,<<zddd>,  r/100);
end outshortclock;


procedure error(type,ra,streng);
integer type;
array ra;
string streng;
begin
own boolean boo;
integer i;

if boo then outchar(out,10) else write(out,<:<10>**contract error<10>:>);
boo:=true;

if test>=3 then write(out,<:errtype:>,type shift (-12),type extract 12,sp,3);
i:=1;
if type extract 12 = 4 then
write(out,<<-dddddddd>,ra(1),sp,3,streng) else
write(out,sp,12-write(out,string ra(increase(i))),streng);

if type shift (-12)>0 then  system(9,type shift (-12),<:<10>rejected:>);
end error;
\f


name:=6;
firstbyte:=1;
nl:=false add 10;
sp:=false add 32;
test:=0;
nosecurity:=false;

<* segmprslice is set according to installation and chosen kitname
_  after check of call parameters *>

segmprblock:=(system(2,i,param)-12288)//1024;
if segmprblock<=0 then segmprblock:=1;

<*** check fp-param ***>

<* item 0 = programname :  no check *>

<* item 1 = mode of operation *>
for i:=1 step 1 until 8 do fpname(i,1):=real ( case i of
(<:list:>,<:all:>,<:init:>,<:from:>,<:on:>,<:clear:>,<:temp:>,<:entry:>));

if system(4,1,param) <> 4 shift 12 + 10
then error(i,param,<:**call:>);

fpname(9,1):=param(1);
mode:=0;
for mode:=mode+1 while param(1)<>fpname(mode,1) do <*nothing*>;
if mode=9 then error(8 shift 12,param,<:**call:>);

<* item 2 = textstorage filename *>
if system(4,2,libfilename) <> 8 shift 12 + 10
then error(8 shift 12,libfilename,<:**delimitor:>);

<* item 3 to item 14 :
.  save further param in array fpname *>

item:=3;
fpnr:=0;
for i:=system(4,item,param) while i <> 0 do
begin
if i=8 shift 12 + 4 and fpnr>0 then
begin
if fpname(fpnr,1)=real<:secur:> add 105 then
begin
fpnr:=fpnr-1;
i:=param(1);
nosecurity:=  i=0  ;
end
else
if fpname(fpnr,1)=real <:test:> then
begin
fpnr:=fpnr-1;
test:=param(1);
end
else error(4,param,<:in call neglegted:>);
end
else
if i extract 12 <> 10 then error(4,param,<:in call neglegted:>)
else
if fpnr>=14 then error(0,param,<:neglegted.  too many parameters:>)
else
begin
for i:=1 step 1 until fpnr do   <* search for doublets *>
if fpname(i,1)=param(1) and fpname(i,2)=param(2) then i:=16;
if i > 14 then error(0,param,<:double:>)
else
begin
fpnr:=fpnr+1;
fpname(fpnr,1):=param(1);
fpname(fpnr,2):=param(2);
end;
end;
item:=item+1;
end all fp-param;

if test>=4 then
begin
write(out,<:<10>test,mode,fpnr::>,test,mode,fpnr);
for raf:=8 step 8 until fpnr*8 do outtext(out,-11,fpname.raf,1);
end;
i:=1;
if test>=3 then write(out,<:<10>at file :>,string libfilename(increase(i)),<:; segmprblock::>,segmprblock);


<*** check libfile ***>
i:=1;
open(cat,4,string libfilename(increase(i)),0);
i:=monitor(76<*lookup*>,cat,0,headia);
if mode=3 <*init*>
then
begin
if i=0 then error(3 shift 12,libfilename,<:**exists allready:>);
catentries:=0;
<* get kitname *>
if fpnr<=0 then
begin
   fpname(1,1):=real <::>;
   fpname(1,2):=real <::>;
end;
param(1):=fpname(1,1);
param(2):=fpname(1,2);
end
else
begin
if i<>0 or headia(16) shift (-12) <> 10
then error(mode shift 12,libfilename,<:**not initiated:>);

<* get kitname *>
raf:=16;
param(1):=headia.raf(1);
param(2):=headia.raf(2);

<* get libcat *>
inrec6(cat,512);
word:=512;
catentries:=cat.word;
setposition(cat,0,0);
end;


<*set slicelength according to installation and kitname*>
segmprslice:=
if param(1)=real <:drum:>  then   1   else
if param(1)=real <::>      then  14   else
if param(1)=real <:disc:>  then  14   else
if param(1)=real <:disc1:> then  14   else
if param(1)=real <:disc2:> then  14   else
if param(1)=real <:disc3:> then  63   else   0;
i:=1;
if test=4 then write(out,<:; kitname=:>,string param(increase(i)),
<: ; slicelength=:>,segmprslice);
if segmprslice=0 then error(1 shift 12,param,<: ** kitname unknown:>);
\f


if mode <= 2   <* list  and  all *>
then
begin

if mode=2 then system(11,i,bases);

if fpnr=0 then  <* write heading *>
begin
outtext(out,-15,headia.name,1);
outshortclock(headia(13));
write(out,nl,1,<:entries =:>,<<   -dddddddd>,catentries
,nl,1,<:size    =:>,headia(8),nl,1);
lastentry:=catentries;
end
else lastentry:=1 <*specified entries*> ;

for item:=1,item+1 while item<=fpnr do <*step  if entries specified *>
begin
setposition(cat,0,0);
inrec6(cat,34);

if fpnr=0 then i:=1000
else
for i:=1 step 1 until catentries do <* search specified entry *>
if fpname(item,1)=cat.name(1) and fpname(item,2)=cat.name(2)
then i:=1000 else inrec6(cat,34);

if i<1000 then   <* specified entry not found *>
begin
raf:=8*item;
error(2,fpname.raf,<:not found:>);
end
else

for i:=1 step 1 until lastentry do <*write specified or all entries *>
begin
outtext(out,-12,cat.name,1);
word:=26;
if mode=1 then outshortclock(cat.word)
else
begin <* mode = 2 :  all *>
laf:=word:=16;
write(out,<:= set:>,<<dddd>,cat.word,sp,1,cat.laf,sp,2);
word:=26;
outshortclock(cat.word);
for word:=28 step 2 until 34 do
if cat.word=0 then write(out,<:  0:>)
else write(out,sp,2,<<d>,cat.word shift (-12),<:.:>,cat.word extract 12);

segm:=cat.firstbyte  extract 12;
word:=2; key:=cat.word extract 12;
word:=4; l1 :=cat.word;
word:=6; l2 :=cat.word;

if segm=0 then write(out,<:; ***:>)
else
begin
case key extract 3 +1 of
begin

<*key 0*>
scope:=if ( l1=extend bases(3) and l2=extend bases(4)) then 1 else 7;

<*key 1*>
scope:=7;

<*key 2*>
scope:=if ( l1=extend bases(3) and l2=extend bases(4)) then 2 else 
       if ( l1=extend bases(5) and l2=extend bases(6)) then 3 else 7;

<*key 3*>
scope:=if ( l1=extend bases(5) and l2=extend bases(6)) then 4
else   if ( l1=extend bases(7) and l2=extend bases(8)) then 5
else   if ( l1<=extend bases(7) and l2>=extend bases(8)) then 6
else 7;
end;

write(out,case scope of(
<:; temp:>,<:; login:>,<:; day:>,<:; user:>,<:; project:>,<:; system:>,<:; ***:>));
end;

write(out,nl,1,sp,12,false add 59,1,<<-ddd>,segm,<:    :>);
if segm=0 then write(out,key,<: *   * :>,l1,l2)
else write(out,key shift (-3),key extract 3,l1,l2);
end mode=2 : all;

inrec6(cat,34);
end for i to lastentry;
end for item to fpnr;
close (cat,true);
end mode <=2

else
\f


if mode = 3   <* init *>
then
begin
<* set tail for creation of lib-entry *>
tail(1):=1;
iaf:=raf:=2;
if fpnr=0 then
begin
tail.iaf(1):=1;
end
else
if fpnr=1 and fpname(1,1) shift (-16) = real <:disc:> shift (-16) then
begin
tail.raf(1):=fpname(1,1);
tail.raf(2):=fpname(1,2);
end
else
begin
raf:=8*fpnr;
error(3 shift 12,fpname.raf,<:**disc_kit_name:>);
end;

systime(1,0,time);
l1:=time*625;
tail(6):=l1 shift (-15) extract 24;
tail(7):=tail(8):=tail(10):=0;
tail(9):=10 shift 12;
tail(10):=512;

if monitor(40<*create*>,cat,0,tail)<>0
then error(3 shift 12,libfilename,<:**create trouble:>);
if monitor(50<*perm entry*>,cat,3,tail)<>0
then error(3 shift 12,libfilename,<:**no perm ressources:>);

system(11,i,bases);
bases(1):=bases(5);
bases(2):=bases(6);

if monitor(74<*set entry base*>,cat,0,bases)<>0 
then error(3,libfilename,<:entry base trouble:>);
outrec6(cat,512);
cat(128):=real<::>  <* set catentries to zero *>;
close (cat,true);
end mode=3  init

else
\f


begin
zone
zin,zout(128*segmprblock,1,stderror),
catnew(128,1,stderror);


integer procedure transfer(zout,zin,headinf);
zone zout,zin;
integer array headinf;
begin
getposition(zin,0,block);
new:=headinf(16) = 0  and block=0;
firsttime:=true;

segm:=headinf(8);
if new then segm:=((segm-1)//segmprslice)*segmprslice   <* move all but last slice *> ;

restbytes:=segm*512;


for block:=inrec6(zin,0) while restbytes>0 do   <* move without check *>
begin
if restbytes<block then block:=restbytes;
outrec6(zout,block);
inrec6 (zin ,block);
tofrom (zout,zin,block);
restbytes:=restbytes-block;
end;

for word:=0 while new do   <* move from last slice until em met *>
begin
outrec6(zout,512);
inrec6 (zin ,512);
segm:=segm+1;
for word:=word+2 while new and word<=512 do
begin
zout.word:=block:=zin.word;
for restbytes:=block extract 8,block extract 8,block  do
if restbytes = 25 then new:=false else block:=block shift (-8);
end;

if segm=headinf(8) and new then
begin  <* <em> not met in last slice *>
if firsttime then
begin  <* try again from first slice *>
setposition(zin ,0,0);
setposition(zout,0,firstsegm);
segm:=0;
firsttime:=false;
end
else
begin
error(5,fpname.raf,<:<em> not found:>);
fpname.raf(1):=real<::>;  <* erase name *>
end;
end;
end;
if test>=2 and segm<>headinf(8) then write(out,<:  segm transferred:>,segm);
headinf(8):=segm  <* update headinf with actual segmcount *>;
transfer:=segm;
end transer;

lastentry:=1;
if fpnr=0 and (mode=4 or mode=7 or mode=8) then lastentry:=catentries  <* all entries *>
else
if fpnr=0 then error(mode shift 12,libfilename,<:**entrynames missing:>);
if catentries=0 and mode<>5 then error(mode shift 12,libfilename,
<:**contains no entries:>);


if mode=8   <* entry *>   then
begin
 
for item:=1, item+1 while item <= fpnr do
begin
setposition(cat,0,0);
inrec6(cat,34);
if fpnr = 0 then i:=1000
else
for i:=1 step 1 until catentries do  <* search specified name *>
if fpname(item,1)=cat.name(1) and fpname(item,2)=cat.name(2)
then i:=1000  else  inrec6(cat,34);

raf:=8*item;
if i<1000 then error(7,fpname.raf,<:not found:>)
else
for j:=1 step 1 until lastentry do
begin
open(zout,4, cat.name,0);
iaf:=14;
tail(1):=1 shift 23 + 4;
for i:=2 step 1 until 5 do tail(i):=headia(i+2);
for i:=6 , 7 , 9 , 10   do tail(i):=cat.iaf(i);
tail(8):=cat.firstbyte  extract 12;


if monitor(40<*create*>,zout,0,tail)<>0
then error(7,cat.name,<:create trouble:>);
close(zout,true);
inrec6(cat,34)
end;
end;
close(cat,true);
end mode=7 temp

else

if mode=4 or mode=7   <* from or temp *>
then
begin
i:=1;
open(zin,4,string libfilename(increase(i)),0);

for item:=1, item+1 while item <= fpnr do
begin
setposition(cat,0,0);
inrec6(cat,34);
if fpnr=0 then i:=1000
else
for i:=1 step 1 until catentries do  <* search specified entry *>
if fpname(item,1)=cat.name(1) and fpname(item,2)=cat.name(2)
then i:=1000 else inrec6(cat,34);

if i<1000 then
begin
raf:=8*item;
error(1,fpname.raf,<:not found:>);
end
else
for j:=1 step 1 until lastentry do
begin
i:=1;
open(zout,4,string cat.name(increase(i)),0);
iaf:=14;
tofrom(tail,cat.iaf,20);
tail(2):=1;
for i:=8,9,10 do tail(i):=0;
i:=monitor(40<*create*>,zout,0,tail);
if i=3 then   <* replace entry achieving correct head and tail *>
begin
monitor(76<*lookup*>,zout,0,headia);
monitor(48<*remove*>,zout,0,headia);
i:=monitor(40<*create*>,zout,0,tail);
end;
if i<>0 then error(1,cat.name,<:create trouble:>)
else
begin
firstsegm:=cat.firstbyte  extract 12;
setposition(zin,0,firstsegm);
iaf:=0;
transfer(zout,zin,cat.iaf);

if mode=4   <* from *>   then
begin
setposition(zout,0,0);
if monitor(50<*perm entry*>,zout,2,tail)<>0 then
error(1,cat.name,<:temp.  *no login ressources*:>);
system(11,i,bases);
bases(1):=bases(5);
bases(2):=bases(6);
if monitor(74<*set entry base*>,zout,0,bases)<>0 then
error(1,cat.name,<:perm. *set entry base*:>);
end from;
inrec6(cat,34);
end;
close(zout,true);
end specified entry;
end for item to fpnr;

close(zin,true);
close(cat,true);
end mode = 4  <* from *>

else
\f


begin   <**  on  and  clear  **>

<** find scope **>
system(11,i,bases);
scope:=headia(1) extract 3;
l1   :=headia(2);
l2   :=headia(3);
if scope < 3 then
begin
if l1 <> extend bases(3) or l2 <> extend bases(4) then  <* undef. *>
scope:=3   <* default user *>
end
else
if l1 = extend bases(5) and l2 = extend bases(6) then <* user *> else
if l1 = extend bases(7) and l2 = extend bases(8) then scope:=4   else
scope:=3;  <* system or undef. -> user *>

open(catnew,4,<::>,0);
tail(1):=1;
for i:=2 step 1 until 10 do tail(i):=headia(i+7);
systime(1,0,time);
l1:=time*625;
tail(6):=l1 shift (-15) extract 24;
monitor(40<*create*>,catnew,0,tail);
if monitor(76<*lookup*>,catnew,0,headia)<>0 then
error(mode shift 12,headia.name,<:**create trouble:>);
i:=1;
open(zout,4,string headia.name(increase(i)),0);

firstsegm:=(catentries+(if mode=5 then fpnr else 0)-1)//14 + 1;
newentries:=0;
if mode=5  <* on *>
then
begin
for item:=1 step 1 until fpnr do   <* transfer files to new lib *>
begin
raf:=item*8;
i:=1;
open(zin,4,string fpname.raf(increase(i)),0);
i:= monitor(76<*lookup*>,zin,0,headia);
if i<>0 or headia(8)<0 or headia(16) shift (-12)<>0 then
begin
error(5,fpname.raf,if i<>0 then <:not found:> else <:not a textfile:>);
fpname.raf(1):=real <::>  <*erase names not treated to maintain evt. copy *>;
end
else
begin
laf:=name;
if test>=1 then write(out,<:<10>file :>,headia.laf,<:  entryno:>,newentries+1);
headia.firstbyte:=false add firstsegm ;
setposition(zout,0,firstsegm);
firstsegm:=firstsegm+transfer(zout,zin,headia);
outrec6(catnew,34);
tofrom(catnew,headia,34);
newentries:=newentries+1;
end;
close(zin,true);
end item to fpnr;
if test>=3 then write(out,<:<10>fpnames treated:>,newentries,<: of:>,fpnr);
if test>=4 then for laf:=8 step 8 until fpnr*8 do write(out,if laf mod 80 = 8 then nl else sp,1,fpname.laf);
if newentries=0 then goto exit;
end mode=5;


<**  on and clear continued  **>
<**  transfer from old lib to new lib **>

iaf:=0;
i:=1;
open(zin,4,string libfilename(increase(i)),0);
setposition(cat,0,0);
for item:=1 step 1 until catentries do
begin
inrec6(cat,34);

for i:=1 step 1 until fpnr do   <* matching names means no copying *>
if cat.name(1)=fpname(i,1) and cat.name(2)=fpname(i,2) then i:=i+999;
if i>1000 then fpname(i-1000,1):=real<::>  <* erase names of files not copied *>
else
begin
if test>=1 then
begin
laf:=name;
write(out,<:<10>file :>,
   cat.laf,<:  old.:>,<<d>,cat.firstbyte extract 12,
    <: - new.:>,firstsegm,<:  entryno :>,newentries+1);
end;
setposition(zin,0,cat.firstbyte  extract 12);
cat.firstbyte:=false add firstsegm ;
setposition(zout,0,firstsegm);
firstsegm:=firstsegm+transfer(zout,zin,cat.iaf);
outrec6(catnew,34);
tofrom(catnew,cat,34);
newentries:=newentries+1;
end;
end item to catentries;

if mode=6 and newentries<>catentries-fpnr then
<**  some fpnames not found in catalog  **>
begin
for item:=1 step 1 until fpnr do  <*names not erased did not match *>
if fpname(item,1)<>real<::> then
begin
raf:=8*item;
error(6,fpname.raf,<:not found:>);
end;
end;

exit:
close(zout,true);
close(zin,true);
close(cat,true);
setposition(catnew,0,0);
swoprec6(catnew,512);
word:=512;
catnew.word:=newentries;
close(catnew,true);

if newentries=0
or (mode=6 and newentries=catentries) then <* keep old *>
else
begin
if nosecurity then goto rename;
permanent:
monitor(76<*lookup*>,catnew,0,headia);
if scope > 0 then   <* permanent *>
begin
for i:=1 step 1 until 9 do tail(i):=headia(i+7);
tail(10):=tail(1)*512;
monitor(44<*change entry*>,catnew,0,tail);
if monitor(50<*perma*>,catnew,if scope <= 2 then 2 else 3,tail)<>0
then error(mode shift 12,headia.name,<:**no perm ressources:>);
end
else scope:=2;  <* login, temp *>

<**
.   scope = 2 : temp, login
.         = 3 : user
.         = 4 : project
**>

system(11,i,bases);
bases(1):=bases( 2*scope - 1);
bases(2):=bases( 2*scope    );

if monitor(74<*set base*>,catnew,0,bases)<>0
then error(mode,headia.name,<:entry base trouble:>);

if nosecurity then close(catnew,true) else
rename:
begin
monitor(48<*remove*>,cat,0,tail);
monitor(46<*rename*>,catnew,0,libfilename.iaf);
if nosecurity then
begin
i:=1;
open(catnew,4,string libfilename(increase(i)),0);
goto permanent;
end;
end;
end;

end on and clear;
end mode>3;
end;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦3e35fa2c6⟧ TextFile

Derivation

TextFile
