PROCEDURE pshenv;

      BEGIN (* pshenv *)
      savenv(enstk[enp]);
      enp := enp + ord(testok((enp <> maxenp), 7));
                    (* error - too many p OR list levels *)
      END (* pshenv *);

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

    PROCEDURE popenv;

      BEGIN (* popenv *)
      enp := enp - ord(testok((enp <> 0), 8));
                    (* error - too many pops *)
      resenv(enstk[enp]);
      END (* popenv *);

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

    PROCEDURE dojust(VAR l : line; VAR f : juslin; right : boolean);

      VAR
        lineindex : integer;
        i,
        j,
        k,
        n,
        m,
        s         : llen;

      (* 3----------------3 *)

      PROCEDURE clearposn;

        BEGIN (* clearposn *)
        l.lin[j] := ' '; l.overlin[j] := ' ';
        l.boldflag[j] := false; l.usflag[j] := false;
        l.nonprtflgs[j] := false; j := pred(j);
        END; (* clearposn *)

      (* 3----------------3 *)

      BEGIN (* dojust *)
      WITH l, f DO BEGIN
        IF len > 2 THEN IF xtrabl THEN len := pred(len);
        IF (NOT center) AND (ndx > 1) AND
           (len - nonprtcount <= succ(val[vrm])) THEN BEGIN
          i := pred(ndx); j := val[vrm] + nonprtcount;
          n := succ(j - len) DIV i; (* extra blks per gap *)
          m := succ(j - len) MOD i; (* distributed extras *)
          len := succ(j);

          FOR k := ndx DOWNTO 2 DO BEGIN

            IF extensions THEN BEGIN (* PascalP specific code *)
              i := succ(pos[pred(k)]);  (* left source posn *)
              s := succ(pos[k] - i);    (* length *)
              j := succ(j - s);         (* destination left end *)
              moveup(lin[j],        lin[i],        s);
              moveup(overlin[j],    overlin[i],    s);
              moveup(boldflag[j],   boldflag[i],   s);
              moveup(usflag[j],     usflag[i],     s);
              moveup(nonprtflgs[j], nonprtflgs[i], s);
              j := pred(j); END
            ELSE (* Standard Pascal code *)
              FOR lineindex := pos[k] DOWNTO succ(pos[pred(k)]) DO BEGIN
                lin[j] := lin[lineindex];
                overlin[j] := overlin[lineindex];
                boldflag[j] := boldflag[lineindex];
                usflag[j] := usflag[lineindex];
                nonprtflgs[j] := nonprtflgs[lineindex];
                j := pred(j); END;

            FOR lineindex := 1 TO n DO clearposn;
            IF right THEN BEGIN
              IF (ndx - k) <= m THEN clearposn; END
            ELSE IF (k - 2) <= m THEN clearposn; END;
          END;
        END;
      END (* dojust *);

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

    PROCEDURE startline;

      BEGIN (* startline *)
      IF rightspace > 0 THEN write(lst, ' ' : rightspace);
      IF bar THEN
        IF otl.bbar THEN write(lst, '|  ')
        ELSE write(lst, '   ');
      END (* startline *);

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

    PROCEDURE dotop;

      VAR
        i   : integer;

      BEGIN (* dotop *)
      IF nopage THEN
        FOR i := val[volno] TO oepag DO writeln(lst)
      ELSE page(lst);
      val[volno] := 1; startline; ovetxt := pred(oetxt); ovbtxt := 0;
      IF NOT holdbb THEN BEGIN
        holdbb := bb; bb := false; END;
      END (* dotop *);

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

    PROCEDURE dobot;

      VAR
        i   : integer;

      BEGIN (* dobot *)
      FOR i := val[volno] TO oetxt DO writeln(lst);
      val[volno] := succ(oetxt); ovetxt := 32000; holdbb := bb;
      END (* dobot *);

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

    PROCEDURE putblank(count : integer);

      VAR
        i  : integer;

      BEGIN (* putblank *)
      IF val[volno] > ovbtxt THEN
        FOR i := 1 TO count DO
          IF val[volno] <= succ(ovetxt) THEN BEGIN
            val[volno] := succ(val[volno]);
            IF bar THEN startline;
            writeln(lst); END;
      END (* putblank *);

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

    PROCEDURE writeotl;
    (* better to postpone actual line until after overprinting *)
    (* and underscoring, so that CRT test displays make sense  *) 

      VAR
        lineindex  : integer;
        lastpos,
        cents      : integer;

      (* 3----------------3 *)

      PROCEDURE beginline;

        BEGIN (* beginline *)
        startline;
        IF cents > 0 THEN write(lst, ' ' : cents);
        END; (* beginline *)

      (* 3----------------3 *)

      BEGIN (* writeotl *)
      WITH otl DO BEGIN
        len := len - ord(len > 0);
        IF center THEN cents :=
            ((val[vrm] - val[vlm]) DIV 2) - ((len - val[vlm]) DIV 2)
        ELSE cents := 0;

        IF NOT ul THEN
          FOR lineindex := 1 TO len DO BEGIN
            lin[lineindex] := forceuppercase(lin[lineindex]);
            overlin[lineindex] := makeupper[overlin[lineindex]]; END;

        beginline;

        IF hasoverprinting THEN BEGIN
          lastpos := len;
          WHILE (lastpos > 1) AND (overlin[lastpos] = ' ') DO
            lastpos := pred(lastpos);
          write(lst, overlin : lastpos);
{}        overprint(lst); beginline; END;

        IF hasboldprinting THEN BEGIN
          FOR lineindex := 1 TO len DO
            IF boldflag[lineindex] THEN BEGIN
              overlin[lineindex] := lin[lineindex];
              lastpos := lineindex; END
            ELSE overlin[lineindex] := ' ';
          write(lst, overlin : lastpos);
{}        overprint(lst); beginline; END;

        IF hasunderscore THEN BEGIN
          FOR lineindex := 1 TO len DO
            IF usflag[lineindex] THEN BEGIN
              overlin[lineindex] := '_'; lastpos := lineindex; END
            ELSE overlin[lineindex] := ' ';
          write(lst, overlin : lastpos);
{}        overprint(lst); beginline; END;

        writeln(lst, lin : len);
        IF NOT odd(getparm DIV 2) THEN  (* console monitor *)
          overprint(val[vpage] : 3, ' ', val[volno] : 3); END;
      END (* writeotl *);

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

    PROCEDURE domid;

      VAR
        i     : integer;
        dofig : boolean;

      BEGIN (* domid *)
      ovbtxt := val[volno]; dofig := true;
      IF figp > 0 THEN
        WHILE dofig DO
          IF fign[figp] <= succ(ovetxt - ovbtxt) THEN BEGIN
            FOR i := 1 TO fign[figp] DO BEGIN
              writeln(lst);
              val[volno] := succ(val[volno]); END;
            figp := pred(figp);
            IF figp = 0 THEN dofig := false; END;
      clear;
      IF pagotl THEN BEGIN
        otl := pagsav; writeotl; val[volno] := succ(val[volno]);
        pagotl := false; clear; END;
      bb := holdbb; holdbb := false;
      END (* domid *);

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

    PROCEDURE putline;

      BEGIN (* putline *)
      IF (NOT sup) AND (NOT empty) THEN BEGIN
        IF (val[volno] + ord(pushed) > succ(ovetxt)) THEN BEGIN
          pagsav := otl; pagotl := true; pushtext(defrfrcpgmacp); END
        ELSE BEGIN
          pushed := false (* no page throw *);
          val[volno] := succ(val[volno]);
          right := NOT right;
          writeotl; END;
        END;
      putblank(defrb); clear;
      END (* putline *);

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

    PROCEDURE pushsyl(VAR asyl : line); forward;

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

    PROCEDURE testpage(n : integer; savesyl : boolean);

      BEGIN (* testpage *)
      IF pred(n * val[vsp]) > succ(ovetxt - val[volno]) THEN BEGIN
        IF savesyl THEN pushsyl(syl);
        pushtext(defrfrcpgmacp); END;
      END (* testpage *);

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

    PROCEDURE paragraph;

      VAR
        indent  : integer;

      BEGIN (* paragraph *)
      right := true (* reset alternating fill *);
      putblank(parspace * val[vsp]);
      WITH otl DO BEGIN
        IF prel THEN
          IF val[vlm] + pmar > 0 THEN indent := val[vlm] + pmar
          ELSE indent := 1
        ELSE indent := pmar;
        len := indent;
        FOR indent := 1 TO len DO lin[indent] := ' '; END;
      right := true; testpage(partest, true);
      END (* paragraph *);

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

    PROCEDURE markjust(n : llen);

      BEGIN (* markjust *)
      WITH just DO BEGIN
        ndx := succ(ndx); pos[ndx] := n; END
      END (* markjust *);

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

    PROCEDURE addword;

      VAR
        tab, j,
        lineindex : integer;

      (* 3----------------3 *)

      PROCEDURE copydown(offset : integer);

        VAR
          i, indx : integer;

        BEGIN (* copydown *)
        WITH tmpl DO
          FOR i := len DOWNTO 1 DO BEGIN
            indx := i + offset;
            lin[indx] := lin[i]; overlin[indx] := overlin[i];
            usflag[indx] := usflag[i];
            nonprtflgs[indx] := nonprtflgs[i];
            boldflag[indx] := boldflag[i]; END;
        END; (* copydown *)

      (* 3----------------3 *)

      FUNCTION gettab(x : integer) : integer;

        VAR
          tabloc : integer;

        BEGIN (* gettab *)
        tabloc := 1; tabs[tabmax] := x;
        WHILE tabs[tabloc] < x DO tabloc := succ(tabloc);
        just.ndx := 0; rt := false; t := false;
        gettab := tabs[tabloc];
        END (* gettab *);

      (* 3----------------3 *)

      BEGIN (* addword *)
      WITH otl DO BEGIN
        IF (xtend) AND (just.ndx > 0) THEN BEGIN
          just.ndx := pred(just.ndx);
          copydown(lastslen);
          FOR lineindex := 1 TO lastslen DO BEGIN
            j := pred(lineindex + lastlen);
            tmpl.lin[lineindex] := lin[j];
            tmpl.overlin[lineindex] := overlin[j];
            tmpl.nonprtflgs[lineindex] := nonprtflgs[j];
            tmpl.usflag[lineindex] := usflag[j];
            tmpl.boldflag[lineindex] := boldflag[j]; END;
          tmpl.len := tmpl.len + lastslen; len := lastlen;
          FOR lineindex := 1 TO syl.len DO
            addsyl.lin[lineindex + addsyl.len] := syl.lin[lineindex];
          addsyl.len := addsyl.len + syl.len; END
        ELSE addsyl := syl;
        xtend := false;

        tab := 0;
        IF rt THEN tab := succ(gettab(pred(len + tmpl.len)) - tmpl.len)
        ELSE IF t THEN tab := gettab(len);
        WHILE len < tab DO BEGIN
          IF dot AND (NOT (len = pred(tab))) THEN lin[len] := '.'
          ELSE lin[len] := ' ';
          overlin[len] := ' '; len := succ(len); END;

        IF NOT empty AND
           (pred(len - nonprtcount + tmpl.len - tmpl.nonprtcount) >
                val[vrm]) THEN BEGIN
          IF justit THEN dojust(otl, just, right);
          pushed := true; pushsyl(addsyl); (* save current symbol *)
          pushtext(carrtnmacp);       (* AND force the END OF line *)
          putline; pushed := false; END
        ELSE BEGIN
          empty := false;

          IF extensions THEN BEGIN (* PascalP specific code *)
            moveto(overlin[len], tmpl.overlin[1], tmpl.len); 
            moveto(lin[len], tmpl.lin[1], tmpl.len); END
          ELSE (* Standard Pascal code *)
            FOR lineindex := 1 TO tmpl.len DO BEGIN
              overlin[pred(len + lineindex)] := tmpl.overlin[lineindex];
              lin[pred(len + lineindex)] := tmpl.lin[lineindex]; END;

          hasoverprinting := hasoverprinting OR tmpl.hasoverprinting;
          hasunderscore := hasunderscore OR tmpl.hasunderscore;
          IF tmpl.hasunderscore THEN
            FOR lineindex := 1 TO tmpl.len DO
              usflag[pred(len + lineindex)] := tmpl.usflag[lineindex];
          hasboldprinting := hasboldprinting OR tmpl.hasboldprinting;
          IF tmpl.hasboldprinting THEN
            FOR lineindex := 1 TO tmpl.len DO
              boldflag[pred(len + lineindex)] :=
                       tmpl.boldflag[lineindex];
          hasnonprints := hasnonprints OR tmpl.hasnonprints;
          IF tmpl.hasnonprints THEN BEGIN
            FOR lineindex := 1 TO tmpl.len DO
              nonprtflgs[pred(len + lineindex)] :=
                       tmpl.nonprtflgs[lineindex];
            nonprtcount := nonprtcount + tmpl.nonprtcount; END;
          lastlen := len;
          lastslen := tmpl.len; len := len + tmpl.len;
          markjust(pred(len));
          IF NOT sigbl THEN BEGIN
            lin[len] := ' '; overlin[len] := ' '; len := succ(len);
            IF pqend THEN BEGIN
              lin[len] := ' '; overlin[len] := ' ';
              len := succ(len); END;
            xtrabl := pqend; END;
          END;
        END;
      END (* addword *);

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

    PROCEDURE addchr(c : char);

      BEGIN (* addchr *)
      WITH otl DO BEGIN
        lin[len] := c; len := succ(len); END;
      END (* addchr *);

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

    PROCEDURE addnum(n : integer; VAR locotl : line);

      (* 3----------------3 *)

      PROCEDURE addchrotl(c : char);

        BEGIN (* addchrotl *)
        WITH locotl DO BEGIN
          lin[len] := c; len := succ(len); END;
        END (* addchr *);

      (* 3----------------3 *)

      PROCEDURE addn(n : integer);

        BEGIN (* addn *)
        IF n >= 10 THEN addn(n DIV 10);
        addchrotl(chr((n MOD 10) + ord('0')));
        END (* addn *);

      (* 3----------------3 *)

      BEGIN (* addnum *)
      IF n < 0 THEN BEGIN
        addchrotl('-'); addn(-n); END
      ELSE addn(n);
      END (* addnum *);

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

    PROCEDURE unflag(VAR l : line; lower, noprint : boolean);

      VAR
        lineindex : integer;
        fup       : 0 .. 3;
        rchn      : llen;
        over      : boolean;

      (* 3----------------3 *)

      PROCEDURE out(c : char);

        BEGIN (* out *)
        rchn := succ(rchn);
        WITH tmpl DO BEGIN
          lin[rchn] := c; overlin[rchn] := ' ';
          IF noprint THEN BEGIN
            hasnonprints := true; nonprtflgs[rchn] := true;
            nonprtcount := succ(nonprtcount); END
          ELSE BEGIN
            IF undl THEN BEGIN
              hasunderscore := true; usflag[rchn] := true; END;
            IF bold THEN
              IF c <> ' ' THEN BEGIN
                hasboldprinting := true; boldflag[rchn] := true; END;
            END;
          END;
        lineindex := succ(lineindex);
        END (* out *);

      (* 3----------------3 *)

      BEGIN (* unflag *)
      clrline(tmpl); rchn := 0;
      WITH l DO BEGIN
        fup := 0 (* no CASE forcing *);
        lineindex := 1; pqend := false;
        IF len < linlen THEN lin[succ(len)] := ' ';
        WHILE lineindex <= len DO BEGIN
          IF NOT (lin[lineindex] IN ['''', '"', ')']) THEN
            pqend := false;
          CASE charcategory[lin[lineindex]] OF
uparrow:    BEGIN
            IF flag AND (lineindex < len) THEN
              IF charcategory[lin[succ(lineindex)]] IN
                   [ucletter, lcletter] THEN BEGIN
                lineindex := succ(lineindex);
                CASE fup OF
               0,
               1: lin[lineindex] := makeupper[lin[lineindex]];
               2: lin[lineindex] := makelower[lin[lineindex]]
                  END; (* case *)
                END;
            out(lin[lineindex]);
            END;
ucletter:   BEGIN
            IF (fup = 2) OR ((fup = 0) AND lower) THEN
              REPEAT
                lin[lineindex] := makelower[lin[lineindex]];
                out(lin[lineindex])
              UNTIL NOT (charcategory[lin[lineindex]]
                              IN [ucletter, lcletter])
            ELSE
              REPEAT
                out(lin[lineindex])
              UNTIL (charcategory[lin[lineindex]] <> ucletter);
            END;
lcletter:   BEGIN
            IF (fup = 1) OR ((fup = 0) AND NOT lower) THEN
              REPEAT
                lin[lineindex] := makeupper[lin[lineindex]];
                out(lin[lineindex])
              UNTIL NOT (charcategory[lin[lineindex]]
                            IN [ucletter, lcletter])
            ELSE
              REPEAT
                out(lin[lineindex])
              UNTIL (charcategory[lin[lineindex]] <> lcletter);
            END;
leftangle:  BEGIN
            IF flagcaps THEN BEGIN
              fup := succ(fup);
              IF fup = 3 THEN fup := 1;
              lineindex := succ(lineindex); END
            ELSE out(lin[lineindex]);
            END;
endsentence:
            BEGIN
            IF period THEN pqend := true;
            out(lin[lineindex]);
            END;
underscore: BEGIN
            lineindex := lineindex + ord(escchr);
            out(lin[lineindex]);
            END;
numbersign: BEGIN
            IF flagsig THEN BEGIN
              over := undl; undl := undl AND usb;
              out(' ');
              undl := over; END
            ELSE out(lin[lineindex]);
            END;
backslash:  BEGIN
            IF flagover THEN BEGIN
              lineindex := succ(lineindex);
              tmpl.hasoverprinting := true;
              tmpl.overlin[rchn] := lin[lineindex];
              lineindex := succ(lineindex); END
            ELSE out(lin[lineindex]);
            END;
miscchar:   BEGIN
            IF NOT (ul OR lower) THEN
              lin[lineindex] := makeupper[lin[lineindex]];
            out(lin[lineindex]);
            END;
arithchar:  out(lin[lineindex]);
otherchar:  lineindex := succ(lineindex)
            END; (* case *)
          END;
        tmpl.len := rchn; END;
      END (* unflag *);

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

    PROCEDURE roman(n : integer);

      VAR
        i, j : integer;

      BEGIN (* roman *)
      j := 1;
      IF n <= 10000 THEN
        FOR i := 1 TO 13 DO BEGIN
          WHILE n >= romanvalues[i] DO
            WITH syl DO BEGIN
              len := succ(len);
              lin[len] := romanchars[j];
              lin[succ(len)] := romanchars[succ(j)];
              len := len + ord(romanchars[succ(j)] <> ' ');
              n := n - romanvalues[i]; END;
          j := j + 2; END;
      END (* roman *);

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

    PROCEDURE dofmt(f, n : integer);

      VAR
        savesc : boolean;

      BEGIN (* dofmt *)
      syl.len := 0; savesc := escchr; escchr := true;
      IF (f >= 0) AND (f <= 6) THEN
        CASE f OF
0:        BEGIN
          syl.len := 1; addnum(n, syl); syl.len := pred(syl.len);
          unflag(syl, false, false);
          END;
1, 5:     BEGIN
          syl.len := 2;
          syl.lin[1] := '_';
          syl.lin[2] := chr(n MOD chrmod);
          END;
2, 6:     BEGIN
          syl.len := 2;
          syl.lin[1] := '_';
          syl.lin[2] := chr(chrmod + (n MOD chrmod));
          END;
3,4:      roman(n);
          END; (* case *)
      IF syl.len > 0 THEN BEGIN
        unflag(syl, (f = 4), (f IN [5,6])); addword; END;
      escchr := savesc;
      END (* dofmt *);

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

    PROCEDURE break;

      BEGIN (* break *)
      putline;
      END (* break *);

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

    PROCEDURE cr;

      BEGIN (* cr *)
      putblank(pred(val[vsp]));
      END (* cr *);

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

    PROCEDURE endpara;

      BEGIN (* endpara *)
      break; cr;
      END (* endpara *);

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

    PROCEDURE blankline;

      BEGIN (* blankline *)
      IF (NOT ap) THEN BEGIN
        endpara; putblank(1); END
      ELSE pushtext(paragmacp);
      END (* blankline *);

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

    PROCEDURE endline;

      BEGIN (* endline *)
      IF sup THEN clear;
      IF force OR (NOT fill) OR otl.center THEN endpara;
      END (* endline *);

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

    PROCEDURE fin;

      BEGIN (* fin *)
      putline; dotop;
      END (* fin *);

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

    PROCEDURE putword;

      BEGIN (* putword *)
      unflag(syl, lower, false); addword;
      END (* putword *);

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

    PROCEDURE putvar;

      VAR
        n   : integer;
        s   : sign;

      BEGIN (* putvar *)
      getnum(s, n);
      IF s <> invalid THEN BEGIN
        IF showexpr THEN BEGIN
          syl.len := 1; addnum(n, syl);
          syl.len := pred(syl.len);
          putword; END;
        END
      ELSE putword;
      END (* putvar *);

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