PROGRAM rnf(infile, lst, input, output);

(*$d-,n- no run-time checks nor line numbers               *)
(* Compilation time, on Kaypro IV, Pascalp V3.1.9, 24+ min *)
(* with compiler "tuned" to 06000H codespace.  Requires    *)
(* about 60K CPM system for this, else reduce codespace.   *)
(* The above using RUNPCDI to execute the compiler.        *)

(* Author unknown. Modified by R.J.Cichelli & C.B.Falconer *)
(* The original ran on a Control Data Cyber installation.  *)
(* 1.0   83-Apr-11 Working version on PascalP              *)
(* 1.1   83-Dec-2  Somewhat reorganized. Forwards removed. *)
(*       Nested include capability.                        *)
(* 1.2   87-Jan-19 Speeded up system almost factor of 2.   *)
(* 1.3   87-Jan-24 Non-printing on .FMT 5 and 6. .BOLD, .U *)
(*       and overstrikes now work in the middle of lines.  *)
(*       Added console page/line# monitor, easy aborts.    *)
(*       Now possible to embed printer control via macros. *)
 
  CONST
    version          = ' Ver. PP-1.3';
    extensions       = true;     (* control use of PascalP extensions *)

(* These following 3 lines added for profiler operation *)
    minln            = 4000;
    maxln            = 5300;
    profileit        = true;    (* false suppresses all profiler code *)

01000000(*$i'rnfglobs.pas' *)
02000000(*$s'errmsgs',i'rnferrs.pas'*)
02700000
  (* 1---------------1 *)

(*$s'support'*)
  FUNCTION forceuppercase(achar : char) : char;

    BEGIN (* forceuppercase *)
    IF charcategory[achar] = lcletter THEN
      forceuppercase := chr(ord(achar) + lowercaseconvert)
    ELSE forceuppercase := achar;
    END; (* forceuppercase *)

  (* 1---------------1 *)

  PROCEDURE stacktomacro(startat : integer;
            VAR startmacro, finishmacro : stringlocation);

    VAR
      i, j  : integer;

    BEGIN (* stacktomacro *)
    WITH stgstack[topofstack] DO BEGIN
      IF stgend - startat > finishmacro - startmacro THEN BEGIN
        IF freestgindx = succ(finishmacro) 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 := succ(finishmacro);
        IF freestgindx > stgtblsize THEN BEGIN
          writeln(' String table overflow. --- halting.');
          terminate; END;
        END;
      j := startmacro;
      IF j > 0 THEN (* NOT an empty macro *)
        FOR i := startat TO stgend DO BEGIN
          stgtable[j] := stgtable[i]; j := succ(j); END;
      finishmacro := pred(j); END;
    END; (* stacktomacro *)

  (* 1---------------1 *)

  (*$s'rareuse'*)
  PROCEDURE error(errnum : integer);

    VAR
      i   : integer;

    BEGIN (* error *)
    errorsonline := succ(errorsonline);
    errorcount := succ(errorcount);
    errorset := errorset + [errnum];
    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
      writeln(' Working on symbol: "', syl.lin : syl.len, '".');
    IF varname <> alfablanks THEN BEGIN
      write(' Error in variable named: "');
      i := 1;
      WHILE i <= alfalen DO BEGIN
        IF varname[i] <> ' ' THEN write(varname[i])
        ELSE i := alfalen;
        i := succ(i); END;
      writeln('"');
      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
          writeln('"', lin : pred(len), '"');
      write(' On line ');
      IF doinclfl THEN BEGIN
        filename(inclf^.f, inclname);
        writeln(inclf^.lno : 1, ', from include file ', inclname); END
      ELSE writeln(ilno : 1, ', from input file ', inputname);
      writeln('"' : 6,
             stgtable : stgstack[0].stgend (* first stg. *), '"'); 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...');
      terminate; END;
    END; (* error *)

  (* 1---------------1 *)

(*$s'support'*)
  FUNCTION testok(boolexp : boolean; errnum : integer) : boolean;

    BEGIN (* testok *)
    testok := boolexp;
    IF NOT boolexp THEN error(errnum);
    END; (* testok *)

  (* 1---------------1 *)

  PROCEDURE clrtab;

    VAR
      i : integer;

    BEGIN (* clrtab *)
    FOR i := 1 TO tabmax DO tabs[i] := 0;
    END (* clrtab *);

  (* 1---------------1 *)

  PROCEDURE savenv(VAR e : environ);

    VAR
      i   : integer;

    BEGIN (* savenv *)
    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 *);

  (* 1---------------1 *)

  PROCEDURE pushtext(p : pmac);

    BEGIN (* pushtext *)
    IF topofstack = stackmax THEN error(57)
    ELSE BEGIN
      topofstack := succ(topofstack);
      WITH stgstack[topofstack], p^ DO BEGIN
        activemacro := p;
        stgbegin := macrobegin;
        stgend := macroend;
        stgposition := stgbegin; END;
      END;
    END; (* pushtext *)

  (* 1---------------1 *)

  PROCEDURE clrline(VAR l : line);

    VAR
      lineindex : integer;

    BEGIN (* clrline *)
    WITH l DO BEGIN
      IF extensions THEN BEGIN (* PascalP specific code *)
        lin[1] := ' '; moveto(lin[2], lin[1], pred(val[vlm]));
        overlin := lin; END
      ELSE (* Standard Pascal code *)
        FOR lineindex := 1 TO val[vlm] DO BEGIN
          lin[lineindex] := ' '; overlin[lineindex] := ' ' END;
      hasboldprinting := false; hasoverprinting := false;
      hasunderscore := false;   hasnonprints := false;
      nonprtcount := 0; nonprtflgs := emptyflags;
      usflag := emptyflags; boldflags := emptyflags;
      len := val[vlm]; center := false; bbar := bb; END;
    END (* clrline *);

  (* 1---------------1 *)

  PROCEDURE clear;

    VAR
      lineindex : integer;

    BEGIN (* clear *)
    clrline(otl);
    just.ndx := 0; sup := false; defrb := 0;
    empty := true; force := false;
    END (* clear *);

  (* 1---------------1 *)

  PROCEDURE setstd;

    BEGIN (* setstd *)
    flag := yes; flagcaps := 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 *);

  (* 1---------------1 *)

  PROCEDURE resenv(VAR e : environ);

    VAR
      i   : integer;

    BEGIN (* resenv *)
    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 *);

  (* 1---------------1 *)

  PROCEDURE processline;

    VAR
      lasttop,
      lineindex,
      curlinindx : integer;

    (* 2---------------2 *)

03000000(*$s'rnfexpr',i'rnfexpr.pas'*)
(* $n+*)
04000000(*$s'rnfout',i'rnfout.pas',@2000 *)
05000000(*$s'rnfin',i'rnfin.pas',@3000 *)
(* $n-*)
06000000(*$s'rnfcmds',i'rnfcmds.pas',@4000 *)
07000000
(*$s'support'*)
    BEGIN (* processline *)
    IF eofinput THEN fin
    ELSE
      WITH stgstack[topofstack] DO
        IF asis AND (topofstack = 0) THEN BEGIN
          IF stgtable[stgbegin]  = '!' THEN BEGIN
            stgposition := stgend; asis := false; END
          ELSE BEGIN
            WITH otl DO BEGIN
              lineindex := val[vlm];
              FOR curlinindx := stgbegin TO stgend DO BEGIN
                lin[lineindex] := stgtable[curlinindx];
                lineindex := succ(lineindex); END;
              lin[lineindex] := ' '; len := lineindex;

              WHILE ((lineindex > 1) AND (lin[lineindex] = ' ')) DO
                lineindex := pred(lineindex);
              IF lineindex > succ(val[vrm]) THEN BEGIN
                (* error - asis text past right margin *);
                starttoken := succ(val[vrm]); error(54); END;
              END;

            stgposition := stgend; empty := false;

            putline; END;
          END
        ELSE BEGIN
          IF ap AND (stgtable[stgbegin] = ' ') AND
                    (stgposition = stgbegin) THEN pushtext(paragmacp);
          getsym;
          IF symtype = none THEN blankline
          ELSE
            REPEAT
              CASE symtype OF
command:        BEGIN
                lasttop := topofstack;
                IF cmdtype IN optbrkset THEN break;
                IF cmdtype IN crset THEN cr;
                (* the above break may force (stack) a page eject.
                   DO it first *)
                IF (lasttop <> topofstack) AND
                   (topofstack < stackmax) THEN BEGIN
                  stgstack[succ(topofstack)] := stgstack[topofstack];
                  topofstack := pred(topofstack);
                  (* put the current symbol under the top of stack *)
                  pushsyl(syl);
                  (* and push both down *)
                  topofstack := topofstack + 2; END
                ELSE docommand(cmdtype);
                END;
 word:          putword;
 vars:          putvar;
                END; (* case *)
              getsym;
            UNTIL symtype = none;
          endline; END;
    END; (* processline *)

  (* 1---------------1 *)

  PROCEDURE getcur;

    LABEL 1; (* for exiting include files *)

    VAR
      fp    : inclfptr;

    (* 2---------------2 *)

    PROCEDURE getinputline(VAR f : text; VAR lncounter : integer);

      VAR
        achar : char;
        i     : integer;

      BEGIN (* getinputline *)
      lncounter := succ(lncounter);
      WITH stgstack[0] DO BEGIN
        stgposition := 1;
        (* currentline is first string in string table *)

        IF extensions THEN BEGIN (* PascalP specific code *)
(*$s-*)   read(f, stgtable[1 FOR linlen]);
(*$s+*)   stgend := succ(length(stgtable)); stgtable[stgend] := ' ';
          FOR i := 1 TO pred(stgend) DO  (* map out all controls *)
            IF stgtable[i] < ' ' THEN stgtable[i] := ' '; END
        ELSE BEGIN (* Standard Pascal code *)
          i := 1;
          WHILE  NOT eoln(f) AND (i <> linlen) DO BEGIN
            read(f, achar);
            IF achar < ' ' THEN stgtable[i] := ' '
            ELSE stgtable[i] := achar;
            i := succ(i); END;
          stgend := i; stgtable[stgend] := ' '; END;

        IF NOT eoln(f) AND (stgend = linlen) THEN BEGIN
          starttoken := stgend;
          error(53) (* error - input line truncated *); END;
        END;

      readln(f); starttoken := 1;
      END; (* getinputline *)

    (* 2---------------2 *)

    BEGIN (* getcur *)
    WHILE (topofstack > 0) AND
            (stgstack[topofstack].stgposition >=
               stgstack[topofstack].stgend) DO
         topofstack := pred(topofstack)      (* !!! should free *);
    IF topofstack = 0 THEN BEGIN
      linecount := succ(linecount);
  1:  IF doinclfl THEN
        IF eof(inclf^.f) THEN BEGIN   (* exit the include *)
          close(inclf^.f); fp := inclf; inclf := inclf^.next;
          fp^.next := freefptr; freefptr := fp;
          doinclfl := inclf <> NIL; GOTO 1; END
        ELSE getinputline(inclf^.f, inclf^.lno)
      ELSE IF eof(infile) THEN eofinput := true
      ELSE getinputline(infile, ilno); END;
    END (* getcur *);

  (* 1---------------1 *)

  PROCEDURE format; (* puts loop in busy segments *)

    BEGIN (* format *)
    REPEAT
      errorsonline := 0;
      errorset := [];
      getcur;
      processline;
      IF errorset <> [] THEN writeerrormessages;
    UNTIL eofinput;
    END; (* format *)

  (* 1---------------1 *)

08000000(*$s'initial',i'rnfinit.pas'*)

(* $i'profiler.inc' add in the profiling code *)

09000000  BEGIN (* rnf *)
  writeln(' RNF (infile, lst) - Text Formatter. ', version);
  initialize;
  linecount := 0;

{ THIS is the added line to start profiling } 
{ IF profileit THEN initprofiler(storeptr, eventcount); }

  format; (* infile onto lst *)

{ THESE 2 lines needed to keep the results }
{ IF profileit THEN stoptimer; }
{ IF profileit THEN dumprofile(storeptr); }

  writeln;
  write(pred(linecount) : 1, ' lines read, ');
  writeln(errorcount : 1, ' Errors detected.');
  writeln('Last page processed : ', val[vpage] : 1);
  END. (* rnf *)