ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/RNF-PAS.LBR/RNF4.PQS/RNF4.PAS

Pascal/Delphi Source File | 2000-06-30 | 8KB | 300 lines

(*  ---  rnf4 --- *)

 function BoolOrd (*  (BoolExp: Boolean): integer; *);

   (* circumvent UCSD III boolean expression evaluation error *)

   begin
     if BoolExp then
       BoolOrd := 1
     else
       BoolOrd := 0
   end;

 function ForceUpperCase (*  (achar: char): char   *);

   begin
     if CharCategory[achar] = lcLetter then
       ForceUpperCase := chr(ord(achar) + LowerCaseConvert)
     else
       ForceUpperCase := achar;
   end;

 procedure StackToMacro (* (StartAt: integer;
             var StartMacro, FinishMacro: integer) *);

   var
     i, j: integer;

   begin
     with StgStack[TopOfStack] do
       begin
        if StgEnd - StartAt > FinishMacro - StartMacro then
           begin
             if FreeStgIndx = FinishMacro + 1 then
               FreeStgIndx := StartMacro
             else
               if StartMacro > 0 then
                 for i := StartMacro  to FinishMacro do
                   StgTable[i] := chr(0);
             StartMacro := FreeStgIndx;
             FinishMacro := StartMacro + StgEnd - StartAt;
             FreeStgIndx := FinishMacro + 1;
             if FreeStgIndx > StgTblSize then
               begin
                 writeln(' String table overflow. --- halting.');
                 {exit(program);}halt;
               end;
           end;
         j := StartMacro;
         if j > 0 then (* not an empty macro *)
           for i := StartAt to StgEnd do
             begin
               StgTable[j] := StgTable[i];
               j := j + 1;
             end;
         FinishMacro := j - 1;
       end;
   end;


procedure Error (* (ErrNum: integer)  *);

  var
    i: integer;

  procedure WriteErrPAOC ( var L: ALINE;  width: integer);
  {  Write a Packed Array Of Char, with a field width.  Like global    }
  {  WritePAOC, but this one goes to default output device (console).  }
   var i : integer;
   begin
    if not paocBUG then write(L:width)  { ISO standard way to do it }
     else for i:= 1 to width do write(L[i]);   { Turbo }
   end (* WritePAOCErr *);

  procedure WriteArg(s:string80);
  var i: integer;
  begin i := 1;
     repeat write(s[i]); i:= i+1;
     until (i>length(s)) or (i>80) or (s[i]=' ');
  end { WriteArg };

  begin { Error }
    ErrorsOnLine := ErrorsOnLine + 1;
    ErrorCount := ErrorCount + 1;
    ErrorSet := ErrorSet + [ErrNum];
    writeln;
    writeln(' Error Count: ', ErrorCount: 1, ' Error Number: ', ErrNum: 1, '.');
    if ErrNum in [1 .. 6, 9 .. 11, 15, 19 .. 24,
                  26 .. 30, 34, 39 .. 52, 57 .. 59] then
      begin write(' Working on symbol: "');
            WriteErrPAOC(syl.lin,syl.len); writeln('".');
      end;
    if VarName <> AlfaBlanks then
      begin
        writeln(' Error in variable named: "',VarName);
        VarName := AlfaBlanks;
      end;
    if ErrorsOnLine = 1 then
      begin
        writeln(' On output page: ', VAL[VPAGE]: 1,
                ' on output line: ', VAL[VOLNO]: 1, '.');
        with otl do
          if len > 1 then
            begin
              write('"');  WriteErrPAOC(lin,(len-1));
              writeln('"');
            end;
        if DoInclFl then
          begin write(' From include file '); WriteArg(InclName); i:=IncLNO;
          end
        else
          begin write(' From input file '); WriteArg(InputName); i := ILNO;
          end;
        writeln(', on line ', i: 1, '.');
        (* StgStack[0].StgEnd is first string *)
{} {    writeln('     "', StgTable: StgStack[0].StgEnd,'"'); }
{ Turbo choked on the above, below is equivalent }
        write  ('     "');
        for i:= 1 to StgStack[0].StgEnd do write(StgTable[i]); writeln('"');
{ end of equivalent }
      end;
    writeln(' ': StartToken + 5, '^',ErrNum:1);
    for i := TopOfStack downto 1 do
      with StgStack[TopOfStack] do
        if ActiveMacro <> nil then
          writeln(' --> Within Macro: "', ActiveMacro^.nm: 10,'".')
        else
          writeln(' --> Within deferred macro.');
    if ErrorsOnLine > 30 then
      begin
        writeln(' Too many errors on a line. Halting...');
        {exit(program);}halt
      end;
  end;

function TestOk  (*  (BoolExp: Boolean; ErrNum: integer): Boolean  *);

  begin
    TestOk := BoolExp;
    if not BoolExp then
      Error(ErrNum);
  end;

PROCEDURE CLRTAB;

  var
    i: integer;

  BEGIN FOR i := 1 TO TABMAX DO TABS[i] := 0; END (*CLRTAB*);

PROCEDURE SAVENV  (*  (VAR E: ENVIRON)  *);

  VAR
                  I: INTEGER;

  BEGIN
    WITH E DO
      BEGIN
        LM := VAL[VLM];   RM := VAL[VRM];   PM := PMAR;
        PS := PARSPACE;   PT := PARTEST;   PR := PREL;   J := JUSTIT;
        F := FILL;   SP := VAL[VSP];
        FOR I := 1 TO TABMAX DO TB[I] := TABS[I];   SG := SIGBL;
        UN := UNDL;   Bl := Bold;
      END
  END (*SAVENV*);


procedure PushText (*  (p: pmac)  *);

  begin
    if TopOfStack = StackMax then
      error(57)
    else
      begin
        TopOfStack := TopOfStack + 1;
        with StgStack[TopOfStack], p^ do
          begin
            ActiveMacro := p;
            StgBegin := MacroBegin;
            StgEnd := MacroEnd;
            StgPosition := StgBegin;
          end;
      end;
  end;


PROCEDURE CLRLINE;

  var
    LineIndex: integer;

  BEGIN
    WITH OTL DO
      BEGIN
        FOR LineIndex := 1 TO VAL[VLM] DO
          BEGIN LIN[LineIndex] := ' ';   OverLin[LineIndex] := ' ' END;
        HasBoldPrinting := false;
        HasOverPrinting := false;
        HasUnderScore := false;
        USflag := EmptyFlags;
        BoldFlag := EmptyFlags;
        LEN := VAL[VLM];   JUST.NDX := 0;
        SUP := FALSE;   DEFRB := 0;   EMPTY := TRUE;
        CENTER := FALSE;   FORCE := FALSE;   BBAR := BB;
      END
  END (*CLRLINE*);

PROCEDURE SETSTD;
 { Standard settings }
  BEGIN
    FLAG := NOT YES;   FLAGCAPS := NOT YES;   LOWER := YES;   ESCCHR := YES;
    PERIOD := YES;   JUSTIT := YES;   UL := YES;   FILL := YES;
    SIGBL := NOT YES;
    IF YES   THEN OPTBRKSET := BREAKSET   ELSE OPTBRKSET := [];
  END (*SETSTD*);


PROCEDURE RESENV  (*  (VAR E: ENVIRON)   *)  ;

  VAR
                  I: INTEGER;

  BEGIN
    WITH E DO
      BEGIN
        VAL[VLM] := LM;   VAL[VRM] := RM;   PMAR := PM;
        PARSPACE := PS;   PARTEST := PT;   PREL := PR;   JUSTIT := J;
        FILL := F;   VAL[VSP] := SP;
        FOR I := 1 TO TABMAX DO TABS[I] := TB[I];   SIGBL := SG;
        UNDL := UN;  Bold := Bl;
      END
  END (*RESENV*);


PROCEDURE GETCUR;

  procedure GetInputLine(var f: text; var LnCounter: integer);

    var
      achar: char;
          i:integer;

    begin
      LnCounter := LnCounter + 1;
      with StgStack[0] do
        begin
          StgPosition := 1;

          (* Currentline is first string in string table *)

          i := 1;
          while  not eoln(f) and (i <> linlen) do
            begin
              read(f, achar);
              if achar < ' ' then
                StgTable[i] := ' '
              else
                StgTable[i] := achar;
              i := i + 1;
            end;

          StgEnd := i;
          StgTable[StgEnd] := ' ';

          if not eoln(f) and (StgEnd = linlen) then
            begin
              StartToken := StgEnd;
              Error(53) (* Error - input line truncated *)
            end;
        end;

      readln(f); {Turbo gets I/O error 99 here if no eof in document file }
      StartToken := 1;
    end;

  BEGIN
    while (TopOfStack > 0) and
      (StgStack[TopOfStack].StgPosition >= StgStack[TopOfStack].StgEnd) do
         TopOfStack := TopOfStack - 1       (* !!! should free *);
    if TopOfStack = 0 then
      begin
        LineCount := LineCount + 1;
        if DoInclFl then
          IF EOF(inclfile) THEN
            begin
              close(inclfile);
              DoInclFl := false;
            end
          else
            GetInputLine(inclfile, IncLno);

        if not DoInclFl then
          if eof(infile) then
            EOFINPUT := true
          else
            GetInputLine(InFile, ilno);
      end;
  END (*GETCUR*);