⟦321a6f997⟧

TextFile

<*read procedures for fp-parameters
Anders Lindgård
1982-04-14
uses the procedures in tmonpr
*>
integer fpbooleans       ;
boolean fpcommand        ;
boolean fpin             ;
integer fpinareas        ;
integer fpints           ;
integer fpitems          ;
boolean fplist           ;
integer fpnr             ;
boolean fpout            ;
integer fpreals          ;
boolean fptestpr         ;
integer fptexts          ;
boolean fpunstacki       ;
<*
takefpitem
general procedure for scanning fpparameters
8 3 76
*>
boolean procedure takefpitem(text,type,nr,A);
value type;
string text;
integer type,nr;
long array A;
begin
  own integer c,inareas;
  own boolean first;
  integer i,j,sep,nsep,item,nitem,itc;
  long array mt,a,na(1:2);
  array field f;

  procedure readnext(no);
  integer no;
  begin
  integer i;
  sep:=nsep;
  item:=nitem;
  for i:=1,2 do a(i):=na(i);
  nsep:=system(4,no,na);
  nitem:=nsep extract 12;
  nsep:=nsep shift (-12);
  if no=0 and (nsep=0 or nsep=2) then nsep:=4;
  fpnr:=no;
  end readnext;

  if -,first or fplist then begin
  boolean nl,ls;
  integer fpcas,chars,v;
    inareas:=c:=0;
    fpitems:=fpinareas:=fpbooleans:=fpints:=fpreals:=
    fptexts:=fpnr:=0;
    ls:=false;
    nl:=fpcommand:=true;
    if fplist then write(out,<:<10>:>);
    nitem:=item:=fpcas:=c:=-1; nsep:=4;
    chars:=0;
    for c:=c+1 while nsep>=4 do
       begin
       readnext(c);
      if fplist then begin
        if nsep>0  then begin
        if -,nl then chars:=chars+
          write(out,case nsep//2 of(<:<10>:>,<: :>,<:=:>,<:.:>));
        nl:=false;
        if nsep=4 and chars>60 then begin chars:=0; 
           write(out,<:,<10>:>); end;
        i:=1;
        if nitem=4 then chars:=chars+
           write(out,<<d>,round(na(1))) else
        if nitem=10 then chars:=chars+
           write(out,na);
        end else if nsep=-2 then write(out,<:):>);
        end;
       if nsep=6 then ls:=true;
       if sep=4 and nsep<=4 and item=10 then begin
        inareas:=inareas+1;
        fpcas:=6;
        end else
     if sep=4 and item=10 then fpcas:=0 else
    if sep=8 and fpcas=0 then begin
      if item=10 then begin
        j:=i:=1;
        fpcas:=2;
        for i:=1 step 1 until 8 do begin
         if a(1)=real (case i of(<:yes:>,<:no:>,<:ja:>,<:nej:>,
           <:true:>,<:false:>,<:sand:>,<:falsk:>)) then fpcas:=7;
          end for loop;
        if fpcas=7 then fpbooleans:=fpbooleans+1 else
         fptexts:=fptexts+1;
        end text.text or text.boolean else
    if item=4 and nsep<=4 then begin
      fpcas:=3; fpints:=fpints+1; end else
    if item=4 and nsep=8 then fpcas:=4;
    end .<int> or .<text>;
    if item=4 and sep=8 and fpcas=4 then begin
      fpcas:=5; fpreals:=fpreals+1;
      end;
       end loop;
    if inareas>0 and -,ls then inareas:=inareas-1;
    fpinareas:=inareas;
    if ls then begin v:=1; fpout:=true; end else v:=0;
    if inareas>0 and c>=1+v then begin
      readnext(1+v);
      readnext(2+v);
      if sep=4 and item=10 and nsep<=4 then fpin:=true;
      if fpin and fpunstacki then unstackcuri
      end RSstackcuri;
   fpitems:=fpbooleans+fpints+fpreals+fptexts+fpinareas;
    fplist:=false;
    first:=true;
    end first;
takefpitem:=type=0 and (fpout or fpitems>0);
if type>1 and type<6 then begin
  mt(2):=0.0 shift(-12);
  f:=0;
  movestring(mt.f,1,text);
  if fptestpr then begin
  i:=1;
  write(out,<:<10>:>,text,<:? :>,mt);
  end;
  end;
if type=0 then
begin
  <*programname*>
  readnext(if fpout then 1 else 0);
  for i:=1,2 do A(i):=na(i);
  takefpitem:=fpout or fpitems>0;
  i:=1;
  if fptestpr then write(out,<:<10>program name: :>,
    A);
end type=0;
if type=1 then begin
  if fpout then begin 
    readnext(0);  
    for i:=1,2 do A(i):=na(i);
    takefpitem:=true;
    if fptestpr then write(out,<:<10>left side found:>);
    end;
  end else if type=2 and nr<=inareas then begin
  takefpitem:=true;
  i:=0;
  itc:=if fpout then 1 else 0;
  nsep:=0;
  for itc:=itc+1 while itc<=c and i<=nr do begin
    readnext(itc);
    if sep=4 and nsep=4 then i:=i+1;
    if i=nr then i:=i+1;
    end;
    for j:=1,2 do A(j):=a(j);
    i:=1;
    if fptestpr then write(out,<:<10>areaname :>,
      a);
    end type=2 else if type>0 and type<6 then begin
    comment find matching text;
    itc:=if fpout then 1 else 0;
    for itc:=itc+1 while itc<=c and
     -,(sep=4 and nsep=8 and a(1)=mt(1) and a(2)=mt(2)) do
     readnext(itc);
    if itc<=c then begin
      comment item found;
      i:=1;
      if fptestpr then write(out,<:<10>match :>);
      if type=3 and nitem=10 then begin
        takefpitem:=true;
        j:=i:=1;
        if fptestpr then write(out,<:text.text :>,
          a,<:.:>,
          na);
        for i:=1,2 do A(i):=na(i) end else
      if type>3 and nitem=4 then
      begin
      takefpitem:=true;
      i:=1;
      if fptestpr then write(out,<:text.int :>,
        a,<<d>,round na(1));
      A(1):=na(1);
      if type=5 then begin
        readnext(itc);
        if nsep=8 then A(2):=na(1) else A(2):=-1;
       if A(2)>0 and fptestpr then write(out,<:.:>,<<d>,round na(1));
        end;
     end;
    end;
  end;
end;


boolean procedure initfp;
begin
long array A(1:2);
initfp:=takefpitem(<::>,0,0,A);
initfp:=fpitems<>0;
end;


procedure programname(name);
long array name;
begin
  boolean b;
  b:=takefpitem(<::>,0,0,name);
  if -,b then 
  begin
    system(2,0,name);
  end;
end;


boolean procedure readifpnext(no,int);
integer no,int;
begin integer sep,item;
boolean f;
long array A(1:2);
no:=no+1;
sep:=system(4,no,A);
item:=sep extract 11;
sep:=sep shift (-12) extract 11;
readifpnext:=f:=sep=8 and item=4;
if f then int:=A(1);
end;
boolean procedure readsfpnext(no,A);
integer no;
long array A;
begin integer sep,item;
boolean f;
long array B(1:2);
no:=no+1;
sep:=system(4,no,B);
item:=sep extract 12;
sep:=sep shift (-12) extract 11;
readsfpnext:=f:=sep=8 and item=10;
if f then begin
  for sep:=1,2 do A(sep):=B(sep);
  end;
end;


boolean procedure readlsfp(output);
long array output;
begin
readlsfp:=takefpitem(<::>,1,0,output);
end;


boolean procedure readbfp(text,b,initial);
value initial;
string text; boolean b,initial;
begin
  long array A(1:2); integer i,c; boolean f;
  f:=readbfp:=takefpitem(text,3,0,A);
  if f then begin
  f:=false;
  c:=0;
  for i:=1,2,3,4 do begin
    if A(1)=real 
       (case i of(<:yes:>,<:true:>,<:ja:>,<:sand:>)) then
      begin c:=i; f:=b:=true end else
    if A(1)=real 
       (case i of(<:no:>,<:false:>,<:nej:>,<:falsk:>)) then
     begin c:=4+i; f:=true; b:=false; end;
    end casei;
  if -,f then readbfp:=false;
  end item found;
  if -,f then b:=initial;
  end;

boolean procedure readifp(text,int,initial);
value initial;
string text;
integer int,initial;
begin
boolean b;
long array A(1:2);
array field f;
b:=readifp:=takefpitem(text,4,0,A);
if b then int:=A(1) else int:=initial;
end;



boolean procedure readrfp(text,val,initial);
value initial;
string text;
real val,initial;
begin
boolean b;
integer i;
real fak;
long array A(1:2);
b:=readrfp:=takefpitem(text,5,0,A);
fak:=.1;
if b then begin
val:=A(1);
if A(2)>-1 then begin
if A(2)=0 then begin
  fak:=fak*.1;
  i:=0;
  for fpnr:=fpnr while readifpnext(fpnr,i) and i=0 do fak:=.1*fak;
  A(2):=i;
  end;
if A(2)<>0 then
val:=val+fak*A(2)*10**(-entier(ln(A(2))/ln(10)));
end;
end else val:=initial;
end;


boolean procedure readsfp(text,TXT,initial);
string text,initial;
long array TXT;
begin
boolean b;
array field f;
b:=readsfp:=takefpitem(text,3,0,TXT);
f:=0;
if -,b then movestring(TXT.f,1,initial);
end;



boolean procedure readinfp(input,nr);
value nr;
long array input;
integer nr;
readinfp:=takefpitem(<::>,2,nr,input);


boolean procedure connectlso;
begin
integer res,i;
integer array tail(1:10);
long array field aux;
long array output(1:2);
aux:=2;
connectlso:=false;
if readlsfp(output) then
  begin
  res:=lookupentry(output,tail);
  if res=3 then
  begin
    for i:=1 step 1 until 10 do tail(i):=0;
    tail(1):=25;
    res:=createentry(output,tail);
  end unknown;
  if tail(1)>0 then 
  begin
    permanententry(output,2);
    system(11,0,tail);
    set_entry_base(output,tail(5),tail(6));
  end bsarea;
  res:=connectcuro(output);
  if res <>0 then
    begin
    i:=1;
    unstackcuro;
    alarm(<:***connect left side :>,output,
      <: connect result :>,res);
    end else
    begin
      connectlso:=true;
      if tail(1)<0 and tail(1) extract 12=12 then
      begin
        comment punch;
        write(out,false,100);
      end punch;
      setposition(out,tail(7),tail(8));
    end;
  end;
end;
boolean procedure connectinp(nr);
value nr; integer nr;
begin
integer i,res1,res2;
integer array tail(1:10);
long array input(1:2);
res1:=if readinfp(input,nr) then lookupentry(input,tail) else 1;
connectinp:=true;
res2:=connectcuri(input);
if res1<>0 or res2<>0 then
 begin
 unstackcuri;
 i:=1;
  alarm(<:***connect input :>,input,
    if res1<>0 then <: not found in parameterlist :> else <: connect result :>,
    if res1<>0 then nr else res2);
  connectinp:=false;
  end setposition(in,tail(7),tail(8));
end;


procedure cutcloseout;
if fpout then
begin
  integer shcl,i,j,res,ch,char,s;
  integer array zd(1:20),t(1:10);
  long array name(1:2);
  long array field nf;
  long array field lo;
  lo:=0;
  getzone6(out,zd);
  nf:=2;
  for i:=1,2 do name(i):=zd.nf(i);
  res:=lookupentry(name,t);
  closeout;
  if res<>0 then alarm("nl",1,"*",3,name.lo,<: does not exist:>);
  if t(1)>0 then
  begin
    res:=connectcuri(name);
    char:=ch:=0;
    repeat ch:=ch+1;
      res:=readchar(in,char);
    until char=25;
    s:=(ch+767)//768;
    t(1):=s;
    shcl:=t(6):=systime(7,0,0.0);
    t(7):=t(8):=t(9):=t(10):=0;
     res:=changeentry(name,t);
     if res<>0 then write(out,"nl",2,"*",2,name.lo,<: changeentry :>,
        res,t(1));
   end t(1)>0;
end;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦321a6f997⟧ TextFile

Derivation

TextFile
