(* this is on p 171 of Pascal with Style *)
 (* by Henry F. Ledgard, Paul A. Lagin, and *)
 (* John F. Hueras.  Typed in by Jim Shaw, *)
 (* 7021 N. Park Ave. Indianapolis, IN 46220 *)
 (* Runs properly under Pascal/M, trademark *)
 (* Sorcim. *)
  (* The program is by Jon F. Hueras and Henry  *)
  (* F. Ledgard.  Permission for the Z Users Group  *)
  (* granted for non-commercial use by Mike Violano *)
  (* of the Hayden Book Company on 3/15/82.  *)


(* Transported to Compaq by Jim Shaw *)
(* 7/22/84 *)
(* Runs properly under Turbo Pascal *)

(*$C-,R-,V-,U-,K-*)

program pretty ( (* from *) inputfile,
(* to   *)      outputfile );

const
      maxsymbolsize = 200;
      maxstacksize  = 100;
      maxkeylnth    =  10;
      maxlinesize   = 120;
      sfail1        =  60;
      sfail2        =  80;
      indent1       =   4;
      indent2       =   2;
      space         = ' ';

(* this is on p 172 *)

type
     keysymbol = ( progsym,    funcsym,     procsym,
                  labelsym,   constsym,    typesym,
                  varsym,     beginsym,    repeatsym,
                  recordsym,  casesym,     casevarsym,
                  ofsym,      forsym,      whilesym,
                  withsym,    dosym,       ifsym,
                  thensym,    elsesym,     endsym,
                  untilsym,   becomes,     opencomment,
                  closecomment,            semicolon,
                  colon,      equals,      openparen,
                  closeparen, period,      endoffile,
                  othersym );

     option = ( crsuppress,
               crbefore,
               blanklinebefore,
               dindentonkeys,
               dindent,
               spacebefore,
               spaceafter,
               gobblesymbols,
               indentbytab,
               indenttoclp,
               crafter );

     optionset = set of option;

     keysymset = set of keysymbol;

     tableentry = record
                   optionsselected   : optionset;
                   dindentsymbols    : keysymset;
                   gobbleterminators : keysymset;
                  end ;

     optiontable = array [ keysymbol ] of tableentry;

(* page 173 *)

     key = packed array [ 1 .. maxkeylnth ] of char;

     keywordtable = array [ progsym..untilsym ] of key;

     specialchar = packed array [ 1..2 ] of char;

     dblchrset = set of becomes..opencomment;

     dblchartable = array [ becomes..opencomment ] of
                    specialchar;
     sglchartable = array [ semicolon..period ] of char;

(* the book calls for a type STRING which pascal/m
has as a predefined type.  The bandaid is to
call the book's type STRING the name STRINGC. *)

     stringc = array [ 1..maxsymbolsize ] of char;

     symbol = record
                name         : keysymbol;
                value        : stringc;
                lnth       : integer;
                spacesbefore : integer;
                crsbefore    : integer;
              end ;

     symbolinfo = ^symbol;

     charname = ( letter,     digit,      blank,
                 quote,      endofline,  filemark,
                 otherchar );

     charinfo = record
                 name  : charname;
                 value : char
                end ;

     stackentry = record
                   indentsymbol : keysymbol;
                   prevmargin   : integer
                  end ;

     symbolstack = array [ 1..maxstacksize ] of stackentry;

     workstring = string[80];


(* page 174 *)

var

    inputfile,
    outputfile : text;

    inname : workstring;
    outname : workstring;

    ok,
    recordseen : boolean;

    currchar,
    nextchar : charinfo;

    currsym,
    nextsym : symbolinfo;

    crpending : boolean;

    ppoption : optiontable;

    keyword : keywordtable;

    dblchars : dblchrset;

    dblchar : dblchartable;
    sglchar : sglchartable;

    stack : symbolstack;
    top   : integer;

    currlinepos,
    currmargin : integer;

    file1,file2 : Workstring;
(* part of initalize from page 187 *)


procedure init2( var ppoption : optiontable);
begin


(* page 187 *)

  with ppoption [ progsym ] do
    begin
      optionsselected := [ blanklinebefore,
                         spaceafter ];
      dindentsymbols  := [];
      gobbleterminators := []
    end ;
  with ppoption [ funcsym ] do
    begin
      optionsselected   := [ blanklinebefore,
                           dindentonkeys,spaceafter ];
      dindentsymbols    := [ labelsym,constsym,
                           typesym,varsym ];
      gobbleterminators := []
    end ;
  with ppoption [ procsym ] do
    begin
      optionsselected   := [ blanklinebefore,
                           dindentonkeys,spaceafter ];
      dindentsymbols    := [ labelsym,constsym,
                           typesym,varsym ];
      gobbleterminators := []
    end ;
  with ppoption [ labelsym ] do
    begin
      optionsselected   := [ blanklinebefore,
                           spaceafter, indenttoclp ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ constsym ] do
    begin
      optionsselected   := [ blanklinebefore,
                           dindentonkeys,spaceafter,indenttoclp
                           ];
      dindentsymbols    := [ labelsym,constsym,typesym,varsym ];
      gobbleterminators := []
    end ;
  with ppoption [ typesym ] do
    begin
      optionsselected   := [ blanklinebefore,
                           dindentonkeys,spaceafter,indenttoclp
                           ];
      dindentsymbols    := [ labelsym,constsym,typesym,varsym ];
      gobbleterminators := []
    end ;

(* page 188 *)

  with ppoption [ varsym ] do
    begin
      optionsselected   := [ blanklinebefore,
                           dindentonkeys,spaceafter,indenttoclp
                           ];
      dindentsymbols    := [ labelsym,constsym,
                           typesym,varsym ];
      gobbleterminators := []
    end ;
  with ppoption [ beginsym ] do
    begin
      optionsselected   := [ crbefore,dindentonkeys,
                             indentbytab,crafter ];
      dindentsymbols    := [ labelsym,constsym,
                           typesym,varsym ] ;
      gobbleterminators := []
    end ;
  with ppoption [ repeatsym ] do
    begin
      optionsselected   := [ indentbytab,crafter];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ recordsym ] do
    begin
      optionsselected   := [ indentbytab,crafter ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ casesym ] do
    begin
      optionsselected   := [ spaceafter,indentbytab,
                           gobblesymbols,crafter ];
      dindentsymbols    := [];
      gobbleterminators := [ ofsym ]
    end ;
  with ppoption [ casevarsym ] do
    begin
      optionsselected   := [ spaceafter,indentbytab,
                           gobblesymbols,crafter ];
      dindentsymbols    := [];
      gobbleterminators := [ ofsym ]
    end ;

(* page 189 *)

  with ppoption [ ofsym ] do
    begin
      optionsselected   := [ crsuppress,spacebefore ];
      dindentsymbols    := [];
      gobbleterminators := [];
    end ;
  with ppoption [ forsym ] do
    begin
      optionsselected   := [ spaceafter,indentbytab,
                           gobblesymbols,crafter ];
      dindentsymbols    := [];
      gobbleterminators := [ dosym ];
    end ;
  with ppoption [ whilesym ] do
    begin
      optionsselected   := [ spaceafter,indentbytab,
                           gobblesymbols,crafter ];
      dindentsymbols    := [];
      gobbleterminators := [ dosym ]
    end ;
  with ppoption [ withsym ] do
    begin
      optionsselected   := [ spaceafter,indentbytab,
                           gobblesymbols,crafter ];
      dindentsymbols    := [];
      gobbleterminators := [ dosym ]
    end ;
  with ppoption [ dosym ] do
    begin
      optionsselected   := [ crsuppress,spacebefore];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ ifsym ] do
    begin
      optionsselected   := [ spaceafter,
                           gobblesymbols ];
      dindentsymbols    := [];
      gobbleterminators := [ thensym ]
    end ;
end ;(* init2 *)

(* some more init of ppoption *)


procedure init3 (var ppoption : optiontable);
begin

(* page 190 *)

  with ppoption [ thensym ] do
    begin
      optionsselected   := [indentbytab,crafter ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ elsesym ] do
    begin
      optionsselected   := [ crbefore,dindentonkeys,
                           dindent,indentbytab,crafter ];
      dindentsymbols    := [ ifsym,elsesym ];
      gobbleterminators := []
    end ;
  with ppoption [ endsym ] do
    begin
      optionsselected   := [ crbefore,dindentonkeys,
                           dindent,crafter ];
      dindentsymbols    := [ ifsym,thensym,elsesym,
                           whilesym,withsym,casevarsym,
                           forsym,colon,equals ];
      gobbleterminators := []
    end ;
  with ppoption [ untilsym ] do
    begin
      optionsselected   := [ crbefore,dindentonkeys,
                           dindent,spaceafter,gobblesymbols,
                           crafter ];
      dindentsymbols    := [ ifsym,thensym,elsesym,
                           forsym,whilesym,withsym,colon,equals
                           ];
      gobbleterminators := [ endsym,untilsym,elsesym,
                           semicolon ]
    end ;

(* page 191 *)

  with ppoption [ becomes ] do
    begin
      optionsselected   := [ spacebefore,spaceafter
                           ,gobblesymbols];
      dindentsymbols    := [];
      gobbleterminators := [ endsym,untilsym,elsesym,
                           semicolon ]
    end ;
  with ppoption [ opencomment ] do
    begin
      optionsselected   := [ crsuppress ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ closecomment ] do
    begin
      optionsselected   := [ crsuppress ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ semicolon ] do
    begin
      optionsselected   := [ crsuppress,dindentonkeys,
                           crafter ];
      dindentsymbols   := [ifsym,thensym,elsesym,
                          forsym,whilesym,withsym,colon,equals ]
      ;
      gobbleterminators := []
    end ;
  with ppoption [ colon ] do
    begin
      optionsselected   := [ spaceafter,indenttoclp ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;

(* page 192 *)

  with ppoption [ equals ] do
    begin
      optionsselected   := [ spacebefore,spaceafter,
                           indenttoclp ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ openparen ] do
    begin
      optionsselected   := [ gobblesymbols ];
      dindentsymbols    := [];
      gobbleterminators := [ closeparen ]
    end ;
  with ppoption [ closeparen ] do
    begin
      optionsselected   := [];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ period ] do
    begin
      optionsselected   := [ crsuppress ];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
  with ppoption [ endoffile ] do
    begin
      optionsselected   := [];
      dindentsymbols    := [];
      gobbleterminators := [];
    end ;
  with ppoption [ othersym ] do
    begin
      optionsselected   := [];
      dindentsymbols    := [];
      gobbleterminators := []
    end ;
end ; (* init2 *)

procedure commandline (var f1,f2: workstring);

type 
     CommandString  = string[127];

var 
    buffer         : CommandString;
    CL             : CommandString absolute cseg: $80;
begin
  Buffer := Copy(cl,2,127);
  if (Pos(' ',buffer) <> 0)
    then
      begin
        File1 := Copy(buffer,1,Pos(' ',buffer)-1);
        File2 := buffer;
        Delete(file2,1,Pos(' ',file2));
      end
    else
      begin
        File1 := Copy(buffer,1,14);
        File2 := '';
      end;
end; (* end commandline *)

function openout : boolean;

 (* returns TRUE for successfull open *)

var
    result : integer;
    escape : boolean;


begin (* openout *)
  OutName := file2;
  repeat (* begin repeat *)
    if (length(file2) = 0)
      then
        begin
          writeln ;
          write ('Type output file name, or CR to quit ');
          readln (OutName);
        end;
    if (Length (OutName) > 0)
      then
        begin
          escape := false;
          assign (OutputFile, OutName);
          {$I-} Rewrite (OutputFile) {$I+};
          result := IOResult;
          if (result <> 0)
           then
            writeln ('Cannot open ',OutName,'code ', result);
        end
      else (* just typed CR *)
        begin
          result := 0;
          escape := true;
        end;
  until (result = 0);
  openout := NOT escape;
end; (* openout *)


(********************************************************************)

function openin : boolean;

  (* Return True for successfull open *)

var
    result : integer;
    escape : boolean;
(*    cmdline1,cmdline2 : string[80]; *)
begin (* OpenIn *)

  InName := file1;
  repeat
    if (Length(file1) = 0)
      then
        begin
          Writeln ;
          Write ('Type input file name, or CR to quit ');
          Readln (InName);
        end;
    if (Length (InName) > 0)
      then
        begin
          Assign (InputFile,InName);
          {$I-} Reset (InputFile) {$I+};
          result := IOResult;
          escape := false;
          if (result <> 0)
           then
            begin
            writeln ('Cannot find ',InName);
            file1:='';
            end;
        end
      else (* just typed CR *)
        begin
          result := 0;
          escape := true;
        end;
  until (result = 0);
  openin := NOT escape;
end; (* openin *)

(* page 175 *)

procedure getchar (var inputfile : text;
                   var nextchar  : charinfo;
                   var currchar  : charinfo );

var ch : char;

begin (* getchar *)
  currchar := nextchar;
  with nextchar do
    begin
      if eof ( inputfile )
        then
          name := filemark
        else
          if eoln ( inputfile )
            then
              name := endofline
            else
             begin (* check of name type *)
              read (inputfile,ch);
              if ch in ['A'..'Z']
                then
                 name := letter
                else
                 if ch in ['a'..'z']
                  then
                   name := letter
                  else
                   if ch in ['0'..'9']
                    then
                     name := digit
                    else
                     if ch = ''''
                      then
                       name := quote
                      else
                       if ch = space
                        then
                         name := blank
                        else
                         name := otherchar;
             end; (* check of name type *)
      if name in [ filemark, endofline ]
        then
          value := space
        else
          value := ch ;
      if name = endofline
        then
          readln (inputfile);
    end; (* with *)
end ; (* getchar *)

(* page 176 *)

procedure storenextchar ( var inputfile : text;
                         var lnth    : integer;
                         var currchar,
                         nextchar  : charinfo;
                         var value     : stringc );

begin (* storenextchar *)
  getchar ( inputfile, nextchar, currchar );
  if lnth < maxsymbolsize
    then
      begin
        lnth := lnth+1;
        value [lnth] := currchar.value
      end
end ; (* storechar *)


procedure skipspaces ( var inputfile    : text;
                      var currchar,
                      nextchar     : charinfo;
                      var spacesbefore,
                      crsbefore    : integer );
begin (* skipspaces *)
  crsbefore := 0;
  spacesbefore := 0;
  while nextchar.name in [ blank,endofline ] do
    begin
      getchar (inputfile,nextchar,currchar );
      case currchar.name of
        blank     : spacesbefore := spacesbefore+1;
        endofline : begin
                     crsbefore    := crsbefore+1;
                     spacesbefore := 0
                    end
      end; (* case *)
    end; (* begin of while *)
end ; (* skipspaces *)


(* page 177 *)

procedure getcomment (
(* form *)            var inputfile : text;
(* updating *)        var currchar,
                      nextchar  : charinfo;
                      var name      : keysymbol;
                      var value     : stringc;
                      var lnth    : integer    );
begin (* getcomment *)
  name := opencomment;
  while not ( ((currchar.value = '*') and
        (nextchar.value = ')') )
        or (nextchar.name = endofline )
        or (nextchar.name = filemark )
        ) do
    storenextchar (inputfile,lnth,currchar,nextchar,
                   value);
  if (currchar.value = '*') and (nextchar.value=')')
    then
      begin
        storenextchar (inputfile,lnth,currchar,nextchar,
                       value );
        name := closecomment
      end
end ; (* getcomment *)

(* page 178 *)

function idtype (value  : stringc;
                 lnth : integer )
: keysymbol;

var 
    i: integer;
    keyvalue : key;
    hit      : boolean;
    thiskey  : keysymbol;

begin (* idtype *)
  idtype := othersym;
  if lnth <= maxkeylnth
    then
      begin
        for i := 1 to lnth do
          keyvalue [i] := value [i];
        for i := lnth+1 to maxkeylnth do
          keyvalue [i] := space;
        thiskey := progsym;
        hit := false;
        while not(hit or (pred(thiskey) = untilsym)) do
          if keyvalue = keyword [thiskey]
            then
              hit := true
            else
              thiskey := succ(thiskey);
        if hit
          then
            idtype := thiskey
      end ;
end ; (* idtype *)

(* page 179 *)

procedure getidentifier (
                         var inputfile : text;
                         var currchar,nextchar : charinfo;
                         var name      : keysymbol;
                         var value     : stringc;
                         var lnth    : integer );

begin (* getidentifier *)
  while nextchar.name in [ letter,digit ] do
    storenextchar(inputfile,lnth,currchar,nextchar,value);
  name := idtype ((* of *) value, (* using *) lnth);
  if name in [ recordsym, casesym, endsym ]
    then
      case name of
        recordsym : recordseen := true;
        casesym   : if recordseen
                     then
                      name := casevarsym;
        endsym    : recordseen := false
      end (* case *)
end ; (* getindentifier *)

procedure getnumber (
                     var inputfile : text ;
                     var currchar,nextchar : charinfo;
                     var name   : keysymbol;
                     var value  : stringc;
                     var lnth : integer );
begin (* getnumber *)
  while nextchar.name = digit do
    storenextchar (inputfile,lnth,currchar,nextchar,
                   value );
  name := othersym
end ; (* getnumber *)

(* page 180 *)

procedure getcharliteral (
                          var inputfile : text;
                          var currchar,nextchar : charinfo ;
                          var name   : keysymbol;
                          var value  : stringc;
                          var lnth : integer    );
begin (* getcharliteral *)
  while nextchar.name = quote do
    begin (* while *)
      storenextchar (inputfile,lnth,currchar,nextchar,
                     value );
      while not(nextchar.name in [quote,endofline,filemark]) 
        do
        storenextchar (inputfile,lnth,currchar,
                       nextchar,value);
      if nextchar.name = quote
        then
          storenextchar (inputfile,lnth,currchar,
                         nextchar,value)
    end ; (* while *)
  name := othersym
end ; (* getcharliteral *)

(* page 181 *)

function chartype (currchar,nextchar : charinfo )
: keysymbol ;

var 
    nexttwochars : specialchar;
    hit : boolean;
    thischar : keysymbol;
begin (* chartype *)
  nexttwochars[1] := currchar.value;
  nexttwochars[2] := nextchar.value;
  thischar := becomes;
  hit      := false;
  while not(hit or (thischar = closecomment)) do
    if nexttwochars = dblchar [thischar]
      then
        hit := true
      else
        thischar := succ(thischar);
  if not hit
    then
      begin
        thischar := semicolon;
        while not(hit or (pred(thischar)=period)) do
          if currchar.value = sglchar[thischar]
            then
              hit := true
            else
              thischar := succ(thischar)
      end ; (* begin after else *)
  if hit
    then
      chartype := thischar
    else
      chartype := othersym
end ; (* chartype *)

(* page 182 *)

procedure getspecialchar (
                          var inputfile : text;
                          var currchar,nextchar : charinfo;
                          var name : keysymbol;
                          var value : stringc;
                          var lnth : integer    );
begin (* getspecialchar *)
  storenextchar ( inputfile,lnth,currchar,
                 nextchar,value );
  name := chartype ( currchar,nextchar );
  if name in dblchars
    then
      storenextchar ( inputfile,lnth,currchar,
                     nextchar,value )
end ; (* getspecialchar *)

(* page 183 *)

procedure getnextsymbol (
                         var inputfile : text;
                         var currchar,nextchar : charinfo;
                         var name : keysymbol;
                         var value : stringc;
                         var lnth : integer  );
begin (* getnextsymbol *)
  case nextchar.name of
    letter : getidentifier(inputfile,currchar,nextchar,
                           name,value,lnth );
    digit : getnumber (inputfile,currchar,nextchar,
                       name,value,lnth );
    quote : getcharliteral(inputfile,currchar,nextchar,
                           name,value,lnth );
    otherchar : 
                begin
                 getspecialchar (inputfile,currchar,nextchar
                                 ,
                                 name,value,lnth );
                 if name = opencomment
                  then
                   getcomment (inputfile,currchar,
                               nextchar,
                               name,value,lnth )
                end ; (* begin otherchar case *)
    filemark : name := endoffile
  end (* case *)
end ; (* getnextsymbol *)

(* page 184 *)

procedure getsymbol (
                     var inputfile : text;
                     var nextsym : symbolinfo;
                     var currsym : symbolinfo );

var 
    dummy : symbolinfo;
begin (* getsymbol *)
  dummy := currsym;
  currsym := nextsym;
  nextsym := dummy;
  with nextsym^ do
    begin
      skipspaces (inputfile,currchar,nextchar,
                  spacesbefore,crsbefore );
      lnth := 0;
      if currsym^.name = opencomment
        then
          getcomment (inputfile,currchar,nextchar,
                      name,value,lnth )
        else
          getnextsymbol (inputfile,currchar,nextchar,
                         name,value,lnth );
    end; (* with *)
end ; (* getsymbol *)

(* page 185 *)

procedure initalize (
                     var inputfile,outputfile : text;
                     var topofstack : integer;
                     var currlinepos,currmargin : integer;
                     var keyword : keywordtable;
                     var dblchars : dblchrset;
                     var dblchar : dblchartable;
                     var sglchar : sglchartable;
                     var recordseen : boolean;
                     var currchar,nextchar : charinfo;
                     var currsym,nextsym : symbolinfo );

var i : integer;
(* page 186 *)

begin (* initalize *)
  topofstack := 0;
  currlinepos := 0;
  currmargin := 0;
  keyword [ progsym    ] := 'PROGRAM   ';
  keyword [ funcsym    ] := 'FUNCTION  ';
  keyword [ procsym    ] := 'PROCEDURE ';
  keyword [ labelsym   ] := 'LABEL     ';
  keyword [ constsym   ] := 'CONST     ';
  keyword [ typesym    ] := 'TYPE      ';
  keyword [ varsym     ] := 'VAR       ';
  keyword [ beginsym   ] := 'BEGIN     ';
  keyword [ repeatsym  ] := 'REPEAT    ';
  keyword [ recordsym  ] := 'RECORD    ';
  keyword [ casesym    ] := 'CASE      ';
  keyword [ casevarsym ] := 'CASE      ';
  keyword [ ofsym      ] := 'OF        ';
  keyword [ forsym     ] := 'FOR       ';
  keyword [ whilesym   ] := 'WHILE     ';
  keyword [ withsym    ] := 'WITH      ';
  keyword [ dosym      ] := 'DO        ';
  keyword [ ifsym      ] := 'IF        ';
  keyword [ thensym    ] := 'THEN      ';
  keyword [ elsesym    ] := 'ELSE      ';
  keyword [ endsym     ] := 'END       ';
  keyword [ untilsym   ] := 'UNTIL     ';

  dblchars := [ becomes, opencomment ];
  dblchar [ becomes      ] := ':=' ;
  dblchar [ opencomment  ] := '(*' ;
  sglchar [ semicolon  ] := ';' ;
  sglchar [ colon      ] := ':' ;
  sglchar [ equals     ] := '=' ;
  sglchar [ openparen  ] := '(' ;
  sglchar [ closeparen ] := ')' ;
  sglchar [ period     ] := '.' ;
  recordseen := false;
  nextchar.name := blank;
  nextchar.value := space;
  new(currsym);
  new(nextsym);
  with nextsym^ do
    begin
      name := othersym;
      for i := 1 to maxsymbolsize do
        value[i] := space;
      lnth := 1;
      spacesbefore := 0;
      crsbefore := 0;
    end ; (* with *)

  getchar (inputfile,nextchar,currchar);
  getsymbol(inputfile,nextsym,currsym );
end ; (* initalize *)
(* page 193 *)

function stackempty : boolean;
begin (* stackempty *)
  if top = 0
    then
      stackempty := true
    else
      stackempty := false
end ; (* stackempty *)

function stackfull : boolean;
begin (* stackfull *)
  if top = maxstacksize
    then
      stackfull := true
    else
      stackfull := false
end ; (* stackfull *)

(* page 194 *)

procedure popstack( var indentsymbol : keysymbol;
                   var prevmargin : integer );
begin (* popstack *)
  if not stackempty
    then
      begin
        indentsymbol := stack[top].indentsymbol;
        prevmargin := stack[top].prevmargin;
        top := top-1;
      end
    else
      begin
        indentsymbol := othersym;
        prevmargin := 0;
      end ;
end ; (* popstack *)

procedure pushstack ( indentsymbol : keysymbol;
                     prevmargin : integer );
begin (* pushstack *)
  top := top+1;
  stack[top].indentsymbol := indentsymbol;
  stack[top].prevmargin := prevmargin;
end ; (* pushstack *)

(* page 195 *)

procedure writecrs( numberofcrs : integer;
                   var currlinepos : integer;
                   var outputfile : text );

var
    i : integer;
begin
  if numberofcrs > 0
    then
      begin
        for i := 1 to numberofcrs do
          writeln(outputfile);
        currlinepos := 0;
      end ;
end ; (* writecrs *)

procedure insertcr ( var currsym : symbolinfo;
                    var outputfile : text );

const 
      once = 1;
begin
  if currsym^.crsbefore = 0
    then
      begin
        writecrs(once,currlinepos,outputfile);
        currsym^.spacesbefore := 0;
      end ;
end ; (* insertcr *)

(* page 196 *)

procedure insertblankline ( var currsym : symbolinfo;
                           var outputfile : text );

const 
      once = 1;
      twice = 2;
begin
  if currsym^.crsbefore = 0
    then
      begin
        if currlinepos = 0
          then
            writecrs(once,currlinepos,outputfile)
          else
            writecrs(twice,currlinepos,outputfile);
        currsym^.spacesbefore := 0
      end
    else
      if currsym^.crsbefore = 1
        then
          if currlinepos > 0
            then
              writecrs (once,currlinepos,outputfile);
end ; (* insertblankline *)

(* page 197 *)

procedure lshifton ( dindentsymbols : keysymset );

var 
    indentsymbol : keysymbol;
    prevmargin   : integer;
begin (* lshifton *)
  if not stackempty
    then
      begin
        repeat
          popstack(indentsymbol,prevmargin );
          if indentsymbol in dindentsymbols
            then
              currmargin := prevmargin
        until (not(indentsymbol in dindentsymbols))
              or (stackempty);
        if not (indentsymbol in dindentsymbols)
          then
            pushstack(indentsymbol,prevmargin );
      end ;
end ; (* lshifton *)

procedure lshift;

var 
    indentsymbol : keysymbol;
    prevmargin   : integer;
begin
  if not stackempty
    then
      begin
        popstack (indentsymbol,prevmargin );
        currmargin := prevmargin;
      end ;
end ; (* lshift *)

(* page 198 *)

procedure insertspace ( var symbol : symbolinfo;
                       var outputfile : text );
begin (* insertspace *)
  if currlinepos < maxlinesize
    then
      begin
        write(outputfile, space);
        currlinepos := currlinepos +1;
        with symbol^ do
          if (crsbefore =0)and(spacesbefore > 0 )
            then
              spacesbefore := spacesbefore-1
      end ;
end ; (* insertspace *)

procedure movelinepos ( newlinepos : integer;
                       var currlinepos : integer;
                       var outputfile : text );

var 
    i : integer;
begin (* movelinepos *)
  for i := currlinepos+1 to newlinepos do
    write(outputfile,' ');
  currlinepos := newlinepos;
end ; (* movelinepos *)

(* page 199 *)

procedure printsymbol ( currsym : symbolinfo;
                       var currlinepos : integer;
                       var outputfile : text );

var 
    i : integer;
begin (* printsymbol *)
  with currsym^ do
    begin
      for i := 1 to lnth do
        write (outputfile,value[i]);
      currlinepos := currlinepos + lnth;
    end (* with *)
end ; (* printsymbol *)

(* page 200 *)

procedure ppsymbol ( currsym : symbolinfo;
                    var outputfile : text );

const 
      once = 1;

var 
    newlinepos : integer;
begin (* ppsymbol *)
  with currsym^ do
    begin
      writecrs(crsbefore,currlinepos,outputfile);
      if (currlinepos + spacesbefore > currmargin)
         or(name in [opencomment,closecomment])
        then
          newlinepos := currlinepos + spacesbefore
        else
          newlinepos := currmargin;
      if newlinepos + lnth > maxlinesize
        then
          begin
            writecrs(once,currlinepos,outputfile);
            if currmargin + lnth <= maxlinesize
              then
                newlinepos := currmargin
              else
                if lnth < maxlinesize
                 then
                  newlinepos := maxlinesize - lnth
                 else
                  newlinepos := 0
          end ;
      movelinepos(newlinepos,currlinepos,outputfile);
      printsymbol(currsym,currlinepos,outputfile);
    end ; (* with *)
end ; (* ppsymbol *)

(* page 201 *)

procedure rshifttoclp(currsym : keysymbol );
forward;

procedure gobble(var inputfile : text;
                 terminators : keysymset;
                 var currsym,nextsym : symbolinfo ;
                 var outputfile : text );
begin (* gobble *)
  rshifttoclp (currsym^.name);
  while not(nextsym^.name in (terminators+[endoffile])) do
    begin
      getsymbol(inputfile,nextsym,currsym );
      ppsymbol (currsym,outputfile );
    end ; (* while *)
  lshift;
end ; (* gobble *)

(* page 202 *)

procedure rshift( currsym : keysymbol);
begin
(* rshift *)
  if not stackfull
    then
      pushstack (currsym,currmargin);
  if currmargin < sfail1
    then
      currmargin := currmargin + indent1
    else
      if currmargin < sfail2
        then
          currmargin := currmargin + indent2
end ; (* rshift *)

procedure rshifttoclp;
begin (* rshifttoclp *)
  if not stackfull
    then
      pushstack(currsym,currmargin);
  currmargin := currlinepos
end ; (* rshifttoclp *)

(* page 203 *)


(* ************** *)

begin (* prettyprint *)
  commandline(file1,file2);
  writeln;
  writeln ('Program to prettyprint Pascal source code.');
  ok := openin;
  if ok
    then
      ok := ok and openout;
  if ok
    then (* the files were opened correctly *)
      begin (* so do the main part *)
        initalize ( inputfile,  outputfile, top,
                   currlinepos,  currmargin, keyword, dblchars,
                   dblchar, sglchar, recordseen, currchar, nextchar,
                   currsym, nextsym );
        init2 (ppoption);
        init3 (ppoption); (* it takes 3 procs to init *)
        crpending := false;
        while (nextsym^.name <> endoffile) do
          begin
           getsymbol(inputfile,nextsym,currsym);
           with ppoption [currsym^.name] do
            begin
             if ((crpending and not
                (crsuppress in optionsselected))
                or(crbefore in optionsselected))
              then
               begin
                insertcr(currsym,outputfile);
                crpending := false;
               end ;
             if blanklinebefore in optionsselected
              then
               begin
                insertblankline(currsym,outputfile);
                crpending := false;
               end ;
             if dindentonkeys in optionsselected
              then
               lshifton(dindentsymbols);
             if dindent in optionsselected
              then
               lshift;
             if spacebefore in optionsselected
              then
               insertspace(currsym,outputfile);
             ppsymbol(currsym,outputfile);
             if spaceafter in optionsselected
              then
               insertspace(nextsym,outputfile);
             if indentbytab in optionsselected
              then
               rshift(currsym^.name);
             if indenttoclp in optionsselected
              then
               rshifttoclp(currsym^.name );
             if gobblesymbols in optionsselected
              then
               gobble ( inputfile,gobbleterminators,
                       currsym,nextsym,outputfile);
             if crafter in optionsselected
              then
               crpending := true;
            end (* with *)
          end ; (* while *)
        if crpending
          then
           writeln(outputfile);
        close (outputfile);
        close (inputfile);
        writeln ('Prettyprint successful.');
      end (* begin by ok *)
    else
      writeln ('Prettyprint stopped.');
end.