⟦33a6e3afd⟧

TextFile

<*                                    alutproc

utility procedures
  connectin
  disconnectin
  readtext
  putstruct
  getstruct
  readroman
  writeroman
  writerec
  writedate
  inc
1980-09-10
corrected 1982-11-16
*>

real procedure inc(a);
array a;
begin
own integer i;
i:=i+1;
inc:=a(i);
if a(i) extract 8=0 then i:=0;
end inc;

procedure writedate(out,time);
value time; real time;
zone out;
begin
  real r;
  if time=0.0 then systime(1,0,time);
  write(out,"sp",2,<<  dd dd dd>,systime(4,time,r),r);
end writedate;

procedure connectin(name);
array name;
begin
integer res,i;
res:=connectcuri(name);
if res<>0 then
begin
  unstackcuri;
  i:=1;
  alarm("nl",1,"*",3,<:connect in to :>,string name(increase(i)),res);
end;
setposition(in,0,0);
end connectin;

procedure disconnectin;
begin
setposition(in,0,0);
if instacked>0 then
begin
  unstackcuri;
end;
end;

integer procedure readtext(in,text);
zone in;
array text;
begin
integer char,sh,c,i,cc;
cleararray(text);
i:=1;
cc:=0;
repeatchar(in);
sh:=0;
for c:=readchar(in,char) while char<>34 and char<>25 do;
if char=34 then begin
for c:=readchar(in,char) while char<>34 and char<>25  do
  begin
  text(i):=text(i) shift 8 add char;
  cc:=cc+1;
  sh:=sh+1;
  if sh=6 then begin
    sh:=0;
    i:=i+1;
    end;
  end inner loop;
end char=34;
text(i):=text(i) shift (8*(6-sh));
readtext:=cc;
end readtext;

integer procedure putstruct(name,struct,firstbselem,lastbselem,elemsize,fsegm);
value firstbselem,lastbselem,elemsize,fsegm;
integer firstbselem,lastbselem,elemsize,fsegm;
integer array struct;
array name;
begin
integer array field s;
integer i,j,ebase,els;
els:=s:=0;
connectin(name);
setposition(in,0,fsegm);
for i:=0 step 1 until firstbselem-1 do
  swoprec6(in,elemsize);
for i:=0 step 1 until lastbselem-firstbselem do
begin
  els:=els+elemsize;
  swoprec6(in,elemsize);
  ebase:=i*elemsize//2;
  for j:=elemsize//2 step -1 until 1 do
    in.s(j):=struct(ebase+j);
end loop;
putstruct:=fsegm+els//512+(if els mod 512=0 then 0 else 1);
disconnectin;
end putstructure;

integer procedure getstruct(name,struct,firstbselem,lastbselem,elemsize,fsegm);
value firstbselem,lastbselem,elemsize,fsegm;
integer firstbselem,lastbselem,elemsize,fsegm;
integer array struct;
array name;
begin
integer array field s;
integer i,j,ebase,els;
els:=s:=0;
connectin(name);
setposition(in,0,fsegm);
for i:=0 step 1 until firstbselem-1 do
  inrec6(in,elemsize);
for i:=0 step 1 until lastbselem-firstbselem do
begin
  els:=els+elemsize;
  inrec6(in,elemsize);
  ebase:=i*elemsize//2;
  for j:=elemsize//2 step -1 until 1 do
    struct(ebase+j):=in.s(j);
end loop;
getstruct:=fsegm+els//512+(if els mod 512=0 then 0 else 1);
disconnectin;
end getstructure;

integer procedure writeroman(z,i);
value i; integer i;
zone z;
begin
integer j,char;
char:=0;
while i>0 and i<5000 do begin
  for j:=i//1000 step -1 until 1 do char:=char+write(z,<:M:>);
  i:=i mod 1000;
  if i>=900 then begin
    i:=i-900;
    char:=char+write(z,<:CM:>);
    end;
  if i>=400 then begin
    i:=i-400;
    if i>=100 then i:=i-100 else char:=char+write(z,<:C:>);
    char:=char+write(z,<:D:>);
    end;
  for j:=i//100 step -1 until 1 do char:=char+write(z,<:C:>);
  i:=i mod 100;
  if i>=90 then begin
    i:=i-90;
    char:=char+write(z,<:XC:>);
    end;
  if i>=40 then begin
    i:=i-40;
    if i>=10 then i:=i-10 else char:=char+write(z,<:X:>);
    char:=char+write(z,<:L:>);
    end;
  for j:=i//10 step -1 until 1 do char:=char+write(z,<:X:>);
  i:=i mod 10;
  if i>=9 then begin
    i:=i-9;
    char:=char+write(z,<:IX:>);
    end;
  if i>=4 then begin
    i:=i-4;
    if i>=1 then i:=i-1 else char:=char+write(z,<:I:>);
    char:=char+write(z,<:V:>);
    end;
  for i:=i step -1 until 1 do char:=char+write(z,<:I:>);
end;
writeroman:=char;
end;


integer procedure readroman(z);
zone z;
begin
integer i,j,lj,jc,nj,dsum,fak,char;
nj:=1;
jc:=maxinteger;
dsum:=i:=0;
for j:=readchar(z,char) while char>'B' and char<'Y' and nj<3 do begin
  lj:=jc;
  fak:=0;
  for j:=1 step 1 until 7 do begin
    if char=(case j of ('I','V','X','L','M','D','M')) then
    begin
      jc:=j;
      fak:=case jc of(1,5,10,50,100,500,1000);
    end symbol found;
  end for;
  if fak>0 and nj<3 then begin
    if jc=lj then begin nj:=nj+1; dsum:=dsum+fak end else
    if jc>lj and nj=1 then begin nj:=1; dsum:=fak-dsum end else
    if jc<lj then begin
     nj:=1;
     i:=i+dsum;
     dsum:=fak;
     end else begin fak:=0; nj:=4; end;
   end fak>0 else fak:=0;
  end read;
readroman:=if nj>3 or fak=0 then 0 else i+dsum;
end readroman;

procedure write_rec(out,a,f,l,recsize);
value f,l,recsize; integer f,l,recsize;
zone out;
integer array a;
begin
integer i,j,max;
integer array field ifi;
max:=recsize//2;
for f:=f step 1 until l do
begin
write(out,"nl",1,<<ddd>,f,<: . :>);
ifi:=f*recsize;
for j:=1 step 1 until max do
  write(out,<< dddddd>,a.ifi(j));
end rec_loop;
end write_record;

procedure timing(z,text,first);
value first; boolean first;
zone z; string text;
begin
own integer bread,br;
own long tc,tr,cpu,time;
if first then
begin
  cpu:=doubleload(owndescr+56);
  time:=getclock;
  bread:=blocksread;
end
else
begin
tc:=doubleload(owndescr+56);
tr:=getclock;
br:=blocksread;
cpu:=tc-cpu;
time:=tr-time;
bread:=br-bread;
write(out,"nl",1,<:timing of :>,true,12,text,"nl",1,
    <:cputime used:>,"sp",10,
    << dd dd dd>,cpu/10000,"nl",1,
    <:real time used :>,"sp",7,time/10000,
    "nl",1,<:cpu  <37> :>,"sp",18,<< dd.dd>,cpu/time*100,"nl",1,
    <:blocksread            :>,<<   dddddd>,bread);
outendcur(10);
cpu:=tc;
time:=tr;
bread:=br;
end writing;
end timing;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦33a6e3afd⟧ TextFile

Derivation

TextFile
