DataMuseum.dk

top - metrics - download

    Length: 4608 (0x1200)
    Types: TextFile
    Names: »tfpread«

└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
    └─⟦4334b4c0b⟧ 
        └─⟦this⟧ »tfpread« 

TextFile

(*fp-parameter reading procedures*)
fpbooleans       ,
fpinareas        ,
fpints           ,
fpitems          ,
fpnr             ,
fpreals          ,
fptexts          : integer;
fpcommand,fplist,fpout,fptestpr,fpfirst: boolean;

value
fpfirst=false;

function takefpitem(var text: alfa;typ: integer;
  var nr: integer;var A: real;var name: alfa): boolean;
var
i,j,sep,nsep,item,nitem,itc,ival: integer;
ch: char;
mt,a,na: alfa;

  procedure readnext(no: integer);
  var i: integer;
  begin
  sep:=nsep;
  item:=nitem;
  a:=na;
  nsep:=system(no,ival,na);
  nitem:=nsep extract 12;
  nsep:=nsep div 4096;
  if (no=0) and ((nsep=0) or (nsep=2)) then nsep:=4;
  fpnr:=no;
  end (* readnext*);

  if (not first) or (fplist) then begin
  var
  nls,ls: boolean;
  fpcas,chars,v: integer;
  begin
    fpitems:=0; fpinareas:=0; fpbooleans:=0; fpints:=0; fpreals:=0; 
    fptexts:=0; fpnr:=0;
    ls:=false;
    nls:=true; fpcommand:=true;
    if fplist then writeln;
    nitem:=-1; item:=-1; fpcas:=-1; 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 not nls then
        begin
          chars:=chars+1;
          case nsep div 2 of
          1: ch:=nl;
          2: ch:=' ';
          3: ch:='=';
          4: ch:='.';
          end;
        write(ch);
        end;
        nls:=false;
        if (nsep=4) and (chars>60) then begin chars:=0; 
           writeln; end;
        i:=1;
        if nitem=4 then
        begin
           chars:=chars+4;
           write(ival:4);
           end else
        if nitem=10 then 
        begin
         chars:=chars+6;
         write(na:12);
        end;
        end else if nsep=-2 then write(')');
        end;
       if nsep=6 then nls:=true;
       if (sep=4) and (nsep<=4) and (item=10) then begin
        fpinareas:=fpinareas+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:=1; i:=1;
        fpcas:=2;
        if (a='yes') or (a='no') or (a='ja') or (a='nej') or
           (a='true') or (a='false') or (a='sand') or (a='falsk') 
           then fpcas:=7;
        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 (fpinareas>0) and (not ls) then fpinareas:=fpinareas-1;
    if ls then begin v:=1; fpout:=true; end else v:=0;
   fpitems:=fpbooleans+fpints+fpreals+fptexts+fpinareas;
    fplist:=false;
    fpfirst:=true;
    end first;
takefpitem:=(type=0) and ((fpout) or (fpitems>0));
if (type>1) and (type<6) then begin
  if fptestpr then begin
  write('nl',text,'? ',text);
  end;
  end;
if type=1 then begin
  if fpout then begin 
    readnext(0);  
    name:=na;
    takefpitem:=true;
    if fptestpr then writeln('left side found');
    end;
  end else if (type=2) and (nr<=fpinareas) 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;
    name:=a;
    i:=1;
    if fptestpr then writeln('areaname ',name);
    end typ=2 else if (typ>0) and (typ<6) then begin
    comment find matching text;
    itc:=if fpout then 2 else 1;
while (itc<=c) and  (not((sep=4) and (nsep=8) and (a=mt)  do
  begin
     itc:=itc+1;
     readnext(itc);
  end;
    if itc<=c then begin
      i:=1;
      if fptestpr then writeln('match ');
      if (type=3) and (nitem=10) then begin
        takefpitem:=true;
        j:=1; i:=1;
        if fptestpr then write('text.text ',
          a,'.',na);
        name:=na;
        end else
      begin
      takefpitem:=true;
      i:=1;
      if fptestpr then write('text.int ',
         a,ival:4);
       A:=ival;
             if type=5 then begin
        readnext(itc);
       if (nsep=8) and (fptestpr) then write(out,'.',ival:1);
        end;
     end;
    end;
  end;
end;
▶EOF◀