DataMuseum.dk

top - metrics - download

    Length: 3840 (0xf00)
    Types: TextFile
    Names: »fungbsotxt«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦this⟧ »fungbsotxt« 

TextFile

fungbso=set 50
fungbso=algol
program for preparing a sortfile for fungi
call:  <objectfile>=fungbso <sourcefile> <fpparam>(0,n)
begin
     integer c,ib,ix,i,dix,ipos,del,reci,cg,cs,cy,
        sg,ss,sv,sf,ca,cn,cd,ci,cl,cc,ch;
     integer array BUF(1:200),DIX(1:20),PRIX(1: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;
     unstackcuri;

begin
     boolean bg,bga,bgn,bs,bsa,bsd,bsn,bsi,bsd5;
     integer dixg,dixga,dixgn,dixs,dixsa,dixsd,dixsn,
             dixsi,dixsd5;


boolean procedure prefix(d1,d2,d3,d4,dixt);
integer d1,d2,d3,d4,dixt;
begin
     boolean b;
     b:= true;
     for i:= DIX(dix) step 1 until PRIX(dix)-1 do
     b:= b and BUF(i)=(case i+1-DIX(dix) of (d1,d2,d3,d4));
     if b and dixt=0 then dixt:= dix;
     prefix:= b;
end prefix;
 
procedure putchar(z,ichar,char);
integer ichar,char;
zone z;
begin
     integer irec;
     irec:= ichar//6+1;
     if ichar mod 6 = 0 then zo(reci):= 0;
     zo(reci):= zo(reci) shift 8 add char; ichar:= ichar+1;
end;
 
integer procedure putsortspec(z,dix,mchar);
integer dix,mchar;
zone z;
begin
     if dix>0 then
     begin if DIX(dix)=0 then syntax(1);
        for i:= PRIX(dix) step 1 until DIX(dix+1)-1 do
        putchar(z,ichar,BUF(i);
        for i:= DIX(dix+1)-PRIX(dix) step 1 until mchar do
        putchar(z,ichar,32);
     end
end;
 
 
procedure putitem(z,dix,mchar);
integer dix,mchar;
zone z;
begin
     if dix>0 then
     begin if DIX(dix)=0 then syntax(1);
        for i:= DIX(dix) step 1 until DIX(dix+1)-1 do
        putchar(z,ichar,BUF(i);
        for i:= DIX(dix+1)-DIX(dix) step 1 until mchar do
        putchar(z,ichar,32);
     end
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; 
     cl:= 108; cc:= 99; ch:= 104;
     del:= 47;
     DIX(1):= 0; il:= 1;
  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:for dix:= 1,dix+1 while DIX(dix+1)>0 do
     begin for i:= DIX(dix),i+1 while BUF(i)<>32 do;
        PRIX(dix):= i+1;
     end;
     dixg:= dixga:= dixgn:= dixs:= dixsa:= dixsn:= dixsd5:= 0;
     for dix:= 1,dix+1 while DIX(dix+1)>0 do
     begin
        prefix(cg,32,32,32,dixg);
        prefix(cg,ca,32,32,dixga);
        prefix(cg,cn,32,32,dixgn);
        prefix(cs,32,32,32,dixs);
        prefix(cs,ca,32,32,dixsa);
        prefix(cs,cn,32,32,dixsn);
        prefix(cs,cd,53,32,dixsd5);
     end;
     if dixg>0 then
     begin
     end;
     if dixs>0 then
     begin
     end;
  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:
     close(zi,true); close(zo,true);
end
▶EOF◀