|
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: 8448 (0x2100)
Types: TextFile
Names: »fungedtxt«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »fungedtxt«
funged=set 50
funged=algol
program for editing in list of fungi
call: <objectfile>=funged <sourcefile> <fpparam>(0,n)
begin
integer c,ib,ix,i,dix,ic,il,jl,iw,del,lw,nl,cg,cs,cy,
sg,ss,sv,sf,ca,cn,cd,ci,cj,cl,cc,ch;
boolean bscan,bsearch,bverify,blist;
integer array BUF(1:200),DIX(1:20),CBUF(1:60),CDIX(1:5),
PRF(1:4),T(0:9,0:20);
real array field raf;
long array IFILE,OFILE(1:3);
zone zi,zo(128,1,stderror);
raf:= 0;
cleararray(IFILE); readinfp(IFILE.raf,1);
open(zi,4,IFILE,0);
cleararray(OFILE); readlsfp(OFILE.raf);
open(zo,4,OFILE,0);
cg:= 35; cs:= 64; cy:= 36;
i:= 0; ic:= 1;
readifp(<:lw:>,lw,65);
unstackcuri;
begin
integer procedure writeset(z,kind,A,DIA,B,DIB,ic,lw);
integer kind,ic,lw;
integer array A,DIA,B,DIB;
zone z;
begin
integer i,p,key,a,b,ixa,ixb;
key:= 0; ixa:= ixb:= 1;
a:= DIA(ixa); b:= DIB(ixb);
if a=0 or b=0 then goto lsa;
ls1:key:= 0; a:= DIA(ixa); b:= DIB(ixb);
if false then
begin write(out,"nl",1,a,b);
writeelement(out,CBUF,CDIX,ixa,ic,lw);
end;
if kind=cg then
begin for p:= 32,ca,cn do
if p=A(a+1) and p=B(b+1) then goto l3
else if p=A(a+1) then goto la
else if p=B(b+1) then goto lb;
end
else if kind=cs then
begin for p:= 32,sv,sf,ca,cn,cd,ci,cl,cc,ch do
if p=A(a+1) and p=B(b+1) then goto l3
else if p=A(a+1) then goto la
else if p=B(b+1) then goto lb
end
else if kind=cy then
begin if A(a)=B(b) then goto l2
else if A(a)=cy then goto la else goto lb;
l2:for p:= 32,sg,ss,sv,sf,ca do
if p=A(a+1) and p=B(b+1) then goto l3
else if p=A(a+1) then goto la
else if p=B(b+1) then goto lb;
end
else begin key:= -1; goto lend end;
if A(a+1)=32 then goto le;
l3:if p=32 then goto le;
i:= 1;
l4:i:= i+1;
if A(a+i)=B(b+i) then
begin if A(a+i)=32 then goto le else goto l4 end;
if A(a+i)<B(b+i) then goto la else goto lb;
lb:key:= key+1;
la:key:= key+1;
le:case key+1 of begin
begin writeelement(z,A,DIA,ixa,ic,lw);
ixa:= ixa+1; ixb:= ixb+1 end;
begin writeelement(z,A,DIA,ixa,ic,lw);
ixa:= ixa+1; end;
begin writeelement(z,B,DIB,ixb,ic,lw);
ixb:= ixb+1; end;
end;
if DIA(ixa)<>0 and DIB(ixb)<>0 then goto ls1;
lsa:if DIA(ixa)<>0 then
begin writeelement(z,A,DIA,ixa,ic,lw);
ixa:= ixa+1; goto lsa; end;
lsb:if DIB(ixb)<>0 then
begin writeelement(z,B,DIB,ixb,ic,lw);
ixb:= ixb+1; goto lsb; end;
lend:writeset:= key;
end writeset;
procedure writeelement(z,A,DIA,ixa,ic,lw);
integer ixa,ic,lw;
integer array A,DIA;
zone z;
begin if DIA(ixa)=0 then syntax(1);
if ic+DIA(ixa+1)-DIA(ixa)>lw then
begin write(z,"nl",1,"sp",5); ic:= 6 end;
for i:= DIA(ixa) step 1 until DIA(ixa+1)-1 do
ic:= ic+write(z,false add A(i),if A(i)>0 then 1 else 0);
end;
procedure writeitem(dix);
integer dix;
begin for i:= DIX(dix) step 1 until DIX(dix+1)-1 do
write(out,false add BUF(i),1);
setposition(out,0,0);
end;
procedure syntax(dix);
value dix;
integer dix;
begin write(out,<:<10>syntax error:>);
writeitem(dix);
goto lend
end;
sg:= 103; ss:= 115; sv:= 118; sf:= 102;
ca:= 97; cn:= 110; cd:= 100; ci:= 105; cj:= 106;
cl:= 108; cc:= 99; ch:= 104;
del:= 47;
DIX(1):= 0; CDIX(1):= 0;
PRF(1):= cs; PRF(2):= 32;
for ix:= 0 step 1 until 9 do T(ix,0):= 0;
bverify:= true; blist:=false;
il:= jl:= 0;
l1:readchar(zi,c);
BUF(1):= c;
if -,(c=cg or c=cs or c=cy) then goto l1;
readchar(zi,c);
if c<>32 then syntax(1);
BUF(2):= 32;
l2:i:= 3; DIX(1):= 1; dix:= 2;
l3:readchar(zi,c);
if c=10 then goto l3;
if c=32 and BUF(i-1)=32 then goto l3;
if c=32 and DIX(dix-1)=i-1 then
begin DIX(dix):= 0; goto l4; end;
if c=cg or c=cs or c=cy then
begin
if BUF(i-1)<>32 then begin BUF(i):= 32; i:= i+1 end;
DIX(dix):= i; dix:= dix+1
end;
BUF(i):= c; i:= i+1;
if c=25 then
begin DIX(dix):= i-1; DIX(dix+1):= 0; goto l4 end;
goto l3;
l4:il:= il+1;
l4b:bscan:= il>jl;
if bscan then
begin write(out,"nl",1); writeitem(1);
i:= 1;
lp1:CBUF(i):= PRF(i); write(out,false add PRF(i),1);
if PRF(i)<>32 then begin i:= i+1; goto lp1 end;
ib:= i+1;
setposition(out,0,0);
lp2:readchar(in,c);
if c=cs then
begin readchar(in,c);
if c=ss then
begin for i:= 4,3,2,1 do PRF(i):= 32;
lp3:readchar(in,c);
if c<>10 then
begin PRF(i):= c; i:= i+1; goto lp3 end;
end else if c=cd then readchar(in,del)
else if c=cj then
begin read(in,jl); repeatchar(in); bscan:= false; end
else if c=cl then
begin read(in,i); repeatchar(in);
jl:= il+i; bscan:= false end
else if c=sf then jl:= 10000
else if c=cd then goto l5
else if c=sv then bverify:= -,bverify
else if c>47 and c<58 then
begin i:= 1; ix:= c-48;
lp4:readchar(in,c);
if c=32 and i=1 then goto lp4
else if c=32 and T(ix,i-1)=32 then goto lp4;
if c<>10 then
begin T(ix,i):= c; i:= i+1; goto lp4 end;
T(ix,0):= i-1;
end;
lp5:if c<>10 then
begin readchar(in,c); goto lp5 end;
CDIX(1):= 0; goto l4b;
end else
if c=10 then
begin CDIX(1):= 0;
if blist then goto lpend else goto l4a end
else
lq1:if c=del then
begin readchar(in,c);
if c=10 then
begin
i:= ib;
lq2:readchar(in,c);
lq3:if c<>10 then
begin CBUF(i):= c; i:= i+1; goto lq2 end;
CDIX(1):= 1; CDIX(2):= i; CDIX(3):= 0;
write(zo,"nl",1); ix:= 1; ic:= 1;
writeelement(zo,CBUF,CDIX,ix,ic,lw);
readchar(in,c);
if c<>del then
begin i:= ib; goto lq3 end;
readchar(in,c); CDIX(1):= 0; goto l4;
end
else if c=del then
begin for dix:= 2,dix+1 while DIX(dix)>0 do
begin c:= 0; i:= 0;
for i:= i+1 while PRF(i)<>32 do
c:= c+abs(PRF(i)-BUF(DIX(dix)+i-1));
if c=0 then
begin for i:= DIX(dix) step 1 until DIX(dix+1)-1 do
BUF(i):= 0; DIX(dix):= DIX(dix+1);
end;
end;
for c:= 0,c while c<>10 do readchar(in,c);
CDIX(1):= 0;
end
else begin ix:= c-48;
for i:= 1 step 1 until T(ix,0) do
CBUF(ib+i-1):= T(ix,i);
ib:= ib+T(ix,0);
readchar(in,c); goto lq1;
end
end c=del
else begin
lq4:if c=32 and CBUF(ib-1)=32 then
begin readchar(in,c); goto lq4; end;
if c<>10 then
begin CBUF(ib):= c; ib:= ib+1;
readchar(in,c); goto lq1 end;
CBUF(ib):= 32; CDIX(1):= 1; CDIX(2):= ib+1;
CDIX(3):= 0;
end;
lpend:
end bscan;
if bverify and bscan then
begin ic:= 1;
writeset(out,BUF(1),CBUF,CDIX,BUF,DIX,ic,lw);
setposition(out,0,0);
readchar(in,c);
if c<>10 then
begin
lq5:if c<>10 then begin readchar(in,c); goto lq5 end;
goto l4;
end;
end;
l4a:ic:= 1; write(zo,"nl",1);
writeset(zo,BUF(1),CBUF,CDIX,BUF,DIX,ic,lw);
l5:dix:= 1;
l6:if DIX(dix)>0 then
begin dix:= dix+1; goto l6 end;
BUF(1):= BUF(DIX(dix-1)); BUF(2):= 32;
if BUF(1)<>25 then goto l2;
end;
lend:write(zo,"em",1);
close(zi,true); close(zo,true);
end
▶EOF◀