Phoenix CD 2.0/Phoenix_CD.cdr/15a/murutil.zip/PRETTYPR.PAS

Pascal/Delphi Source File | 1986-11-11 | 42KB | 1,232 lines

PROGRAM PRETTYPRINT;

  (*  This Program was taken from PASCAL NEWS (PUG) and adapted for
      VAX PASCAL by:

                  Francis J. Monaco
                  Major, US ARMY
                  Systems Manager, Computer Graphics Laboratory
                  Department of Geography and Computer Science
                  The United States Military Academy
                  West Point, New York 10996
                  914-938-2063

    Updated for Borland's "Turbo Pascal", which does not support the GET
    and PUT primitive functions, by Harry M. Murphy,  March 1986.  *)


                  CONST
                        SPECLENGTH = 65;
                        (*  Length of a file specification. *)
                        MAXSYMBOLSIZE = 200;
                        (*  The maximum size (in characters) of a
                            symbol scanned by the lexical scanner. *)
                        MAXSTACKSIZE  = 100;
                        (*  The maximum number of symbols causing
                            indentation that may be stacked.  *)
                        MAXKEYLENGTHY  =  10;
                        (*  The maximum LENGTHY (in characters) of a
                            Pascal reserved keyword. *)
                        MAXLINESIZE   =  72;
                        (*  The maximum size (in characters) of a
                            line output by the PRETTYPRINTER. *)
                        SLOFAIL1      =  36;
                        (*  Up to this column position, each time
                            "INDENTBYTAB" is invoked, the margin
                            will be indented by "INDENT1".  *)
                        SLOFAIL2      =  54;
                        (*  Up to this column position, each time
                            "INDENTBYTAB" is invoked, the margin
                            will be indented by "INDENT2".  Beyond
                            this, no indentation occurs. *)
                        INDENT1       =   2;
                        INDENT2       =   1;
                        SPACE = ' ';

                  TYPE
                       FILESPEC = STRING[SPECLENGTH];
                       FILESTAT = RECORD
                                    FILECH: CHAR;
                                    FILEEF: BOOLEAN;
                                    FILEEL: BOOLEAN
                                  END;
                       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;
                       KEY = PACKED ARRAY [1..MAXKEYLENGTHY] 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;
                       STRINGY = ARRAY [1..MAXSYMBOLSIZE] OF CHAR;
                       SYMBOL = RECORD
                                  NAME       : KEYSYMBOL;
                                  VALUES      : STRINGY;
                                  LENGTHY     : INTEGER;
                                  SPACESBEFORE: INTEGER;
                                  CRSBEFORE  : INTEGER
                                END;
                       SYMBOLINFO = ^SYMBOL;
                       CHARNAME = (LETTER,    DIGIT,    BLANK,    QUOTE,
                                   ENDOFLINE, FILEMARK, OTHERCHAR);
                       CHARINFO = RECORD
                                    NAME: CHARNAME;
                                    VALUES: CHAR
                                  END;
                       STACKENTRY = RECORD
                                     INDENTSYMBOL: KEYSYMBOL;
                                     PREVMARGIN : INTEGER
                                    END;
                       SYMBOLSTACK = ARRAY [1..MAXSTACKSIZE] OF
                                     STACKENTRY;

                  VAR
                      FIN: TEXT;
                      FINCH: CHAR;
                      FINEF: BOOLEAN;
                      FINEL: BOOLEAN;
                      FINNAME: FILESPEC;
                      FINSTAT: FILESTAT;
                      FOUT: TEXT;
                      OUTNAME: FILESPEC;
                      SAWCOMOPEN, SAWCOMCLOSE, SAWQUOTEDSTRING,
                      INACOMMENT   : BOOLEAN;
                      RECORDSEEN: BOOLEAN;
                      CURRCHAR,
                      NEXTCHAR: CHARINFO;
                      CURRSYM,
                      NEXTSYM: SYMBOLINFO;
                      CRPENDING: BOOLEAN;
                      PPOPTION: OPTIONTABLE;
                      KEYWORD: KEYWORDTABLE;
                      DBLCHARS: DBLCHRSET;
                      DBLCHAR: DBLCHARTABLE;
                      SGLCHAR: SGLCHARTABLE;
                      STACK: SYMBOLSTACK;
                      TOP : INTEGER;
                      STARTPOS, (* Starting position of last symbol
                                   written. *)
                      CURRLINEPOS,
                      CURRMARGIN: INTEGER;
                      I: INTEGER;


PROCEDURE GETINPFIL(VAR INP: TEXT; VAR FINNAME: FILESPEC);

(*  This file gets an input file, either as the first parameter
   on the command line or by requesting it from the user.

   Procedure by Harry M. Murphy,  22 February 1986.  *)

  VAR
      L: INTEGER;

  BEGIN
    IF PARAMCOUNT = 0
      THEN
        BEGIN
          WRITE('Input  file: ');
          READLN(FINNAME)
        END
      ELSE
        FINNAME := PARAMSTR(1);
    FOR L:=1 TO LENGTH(FINNAME) DO FINNAME[L] := UPCASE(FINNAME[L]);
    ASSIGN(INP,FINNAME);
      (*$I-*) RESET(INP) (*$I+*);
    IF IORESULT <> 0
      THEN
        BEGIN
          CLOSE(INP);
          WRITELN('ERROR!  Can''t find file ',FINNAME,'!');
          HALT
        END;
  END (* Procedure GETINPFIL *);


PROCEDURE GETOUTFIL(VAR OUT: TEXT; VAR OUTNAME: FILESPEC);

(*  This file gets an output file, either as the second parameter
   on the command line or by requesting it from the user.

   Procedure by Harry M. Murphy,  22 February 1986.  *)

 VAR
     L: INTEGER;

  BEGIN
    IF PARAMCOUNT < 2
      THEN
        BEGIN
          WRITE('Output file: ');
          READLN(OUTNAME)
        END
      ELSE
        OUTNAME := PARAMSTR(2);
    FOR L:=1 TO LENGTH(OUTNAME) DO OUTNAME[L] := UPCASE(OUTNAME[L]);
    ASSIGN(OUT,OUTNAME);
    (*$I-*) REWRITE(OUT) (*$I-*);
    IF IORESULT <> 0
      THEN
        BEGIN
          CLOSE(OUT);
          WRITELN('ERROR!  Can''t open ',OUTNAME,'!');
          HALT
        END
  END (* Procedure GETOUTFIL *);


PROCEDURE GETFIN;

BEGIN
  WITH FINSTAT DO
    BEGIN
      FINCH := FILECH;
      FINEF := FILEEF;
      FINEL := FILEEL;
      FILECH := ' ';
      FILEEF := EOF(FIN);
      FILEEL := EOLN(FIN);
      IF NOT FILEEF
        THEN
          IF FILEEL
            THEN
              READLN(FIN)
            ELSE
              READ(FIN,FILECH)
      END
END (* Procedure GETFIN *);


   PROCEDURE GETCHAR(VAR NEXTCHAR :CHARINFO;
                     VAR CURRCHAR :CHARINFO);
   BEGIN (* GETCHAR *)
     CURRCHAR := NEXTCHAR;
     WITH NEXTCHAR DO
       BEGIN
         IF FINEF OR (FINCH=CHR(26))
           THEN
             NAME  := FILEMARK
           ELSE
             IF FINEL
               THEN
                 NAME  := ENDOFLINE
               ELSE
                 IF (((ORD(FINCH)) >= (ORD('a'))) AND
                    ((ORD(FINCH)) <= (ORD('z'))) AND
                    (NOT SAWQUOTEDSTRING)  AND
                    (NOT INACOMMENT))
                   THEN
                     BEGIN
                       FINCH := UPCASE(FINCH);
                       NAME := LETTER
                     END
                   ELSE
                     IF SAWCOMOPEN
                       THEN
                         BEGIN
                           SAWCOMOPEN := FALSE;
                           FINCH := '*';
                           NAME := OTHERCHAR
                         END
                       ELSE
                         IF SAWCOMCLOSE
                           THEN
                             BEGIN
                               SAWCOMCLOSE := FALSE;
                               FINCH := ')';
                               NAME := OTHERCHAR
                             END
                           ELSE
                             IF  ((FINCH = '{') AND (NOT SAWQUOTEDSTRING))
                               THEN
                                 BEGIN
                                   SAWCOMOPEN := TRUE;
                                   INACOMMENT := TRUE;
                                   FINCH := '(';
                                   NAME := OTHERCHAR
                                 END
                               ELSE
                                 IF  ((FINCH = '}')  AND (NOT
                                    SAWQUOTEDSTRING))
                                   THEN
                                     BEGIN
                                      SAWCOMCLOSE := TRUE;
                                      INACOMMENT := FALSE;
                                      FINCH := '*';
                                      NAME := OTHERCHAR
                                     END
                                   ELSE
                                     IF FINCH IN ['A' .. 'Z', '_']
                                      THEN
                                       NAME  := LETTER
                                      ELSE
                                       IF FINCH IN ['0'..'9']
                                        THEN
                                         NAME  := DIGIT
                                        ELSE
                                         IF (FINCH = '''') AND (NOT
                                            INACOMMENT)
                                          THEN
                                           IF SAWQUOTEDSTRING
                                            THEN
                                             BEGIN
                                              NAME := QUOTE;
                                              SAWQUOTEDSTRING := FALSE
                                             END
                                            ELSE
                                             BEGIN
                                              NAME := QUOTE;
                                              SAWQUOTEDSTRING := TRUE
                                             END
                                          ELSE
                                           IF FINCH = SPACE
                                            THEN
                                             NAME  := BLANK
                                            ELSE
                                             NAME := OTHERCHAR;
         IF NAME IN [FILEMARK, ENDOFLINE]
           THEN
             VALUES := SPACE
           ELSE
             VALUES := FINCH;
         IF (NAME <> FILEMARK) AND (NOT SAWCOMOPEN) AND (NOT SAWCOMCLOSE
            )
           THEN
             GETFIN
       END (* WITH *)
   END; (* GETCHAR *)

  PROCEDURE STORENEXTCHAR(VAR LENGTHY:INTEGER;VAR CURRCHAR,
                          NEXTCHAR: CHARINFO;VAR VALUES: STRINGY);
   BEGIN (* STORENEXTCHAR *)
     GETCHAR(NEXTCHAR,CURRCHAR);
     IF LENGTHY < MAXSYMBOLSIZE
       THEN
         BEGIN
           LENGTHY := LENGTHY + 1;
           VALUES [LENGTHY] := CURRCHAR.VALUES
         END
   END; (* STORENEXTCHAR *)

  PROCEDURE SKIPSPACES(VAR CURRCHAR,NEXTCHAR: CHARINFO;VAR SPACESBEFORE,
                       CRSBEFORE:INTEGER);
   BEGIN (* SKIPSPACES *)
     SPACESBEFORE := 0;
     CRSBEFORE    := 0;
     WHILE NEXTCHAR.NAME IN [BLANK, ENDOFLINE] DO
       BEGIN
         GETCHAR(NEXTCHAR,CURRCHAR);
         CASE CURRCHAR.NAME OF
           BLANK    : SPACESBEFORE := SPACESBEFORE + 1;
           ENDOFLINE :
                       BEGIN
                         CRSBEFORE    := CRSBEFORE + 1;
                         SPACESBEFORE := 0
                       END
         END (* CASE *)
       END (* WHILE *)
   END; (* SKIPSPACES *)

  PROCEDURE GETCOMMENT(VAR CURRCHAR,NEXTCHAR:CHARINFO;VAR NAME:KEYSYMBOL
                       ;VAR VALUES:STRINGY;VAR LENGTHY:INTEGER);
   BEGIN (* GETCOMMENT *)
     INACOMMENT := TRUE;
     NAME := OPENCOMMENT;
     WHILE NOT(((CURRCHAR.VALUES = '*') AND (NEXTCHAR.VALUES = ')'))
           OR (NEXTCHAR.NAME = ENDOFLINE)
           OR (NEXTCHAR.NAME = FILEMARK)) DO
       STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
     IF (CURRCHAR.VALUES = '*') AND (NEXTCHAR.VALUES = ')')
       THEN
         BEGIN
           STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
           NAME := CLOSECOMMENT;
           INACOMMENT := FALSE
         END
   END; (* GETCOMMENT *)

  FUNCTION IDTYPE(VALUES : STRINGY; LENGTHY: INTEGER): KEYSYMBOL;

  VAR
      I: INTEGER;
      KEYVALUES: KEY;
      HIT: BOOLEAN;
      THISKEY: KEYSYMBOL;
   BEGIN (* IDTYPE *)
     IDTYPE := OTHERSYM;
     IF LENGTHY <= MAXKEYLENGTHY
       THEN
         BEGIN
           FOR I := 1 TO LENGTHY DO KEYVALUES [I] := VALUES [I];
           FOR I := LENGTHY+1 TO MAXKEYLENGTHY DO KEYVALUES [I] := SPACE;
           THISKEY := PROGSYM;
           HIT     := FALSE;
           WHILE NOT(HIT OR (THISKEY = SUCC(UNTILSYM))) DO
             IF KEYVALUES = KEYWORD [THISKEY]
               THEN
                 HIT := TRUE
               ELSE
                 THISKEY := SUCC(THISKEY);
           IF HIT
             THEN
               IDTYPE := THISKEY
         END;
   END; (* IDTYPE *)

  PROCEDURE GETIDENTIFIER(VAR CURRCHAR,NEXTCHAR:CHARINFO;VAR NAME:
                          KEYSYMBOL;VAR VALUES:STRINGY;VAR LENGTHY:
                          INTEGER);
   BEGIN (* GETIDENTIFIER *)
     WHILE NEXTCHAR.NAME IN [LETTER, DIGIT] DO
       STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
     NAME := IDTYPE(VALUES,
             LENGTHY);
     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; (* GETIDENTIFIER *)

  PROCEDURE GETNUMBER(VAR CURRCHAR,NEXTCHAR:CHARINFO;VAR NAME:KEYSYMBOL;
                      VAR VALUES:STRINGY;VAR LENGTHY:INTEGER);
   BEGIN (* GETNUMBER *)
     WHILE NEXTCHAR.NAME = DIGIT DO
       STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
     NAME := OTHERSYM
   END; (* GETNUMBER *)

  PROCEDURE GETCHARLITERAL(VAR CURRCHAR,NEXTCHAR :CHARINFO;
                           VAR NAME: KEYSYMBOL;VAR VALUES: STRINGY;VAR
                           LENGTHY   :INTEGER);
   BEGIN (* GETCHARLITERAL *)
     WHILE NEXTCHAR.NAME = QUOTE DO
       BEGIN
         STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
         WHILE NOT(NEXTCHAR.NAME IN [QUOTE, ENDOFLINE, FILEMARK]) DO
           STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
         IF NEXTCHAR.NAME = QUOTE
           THEN
             STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES)
       END;
     NAME := OTHERSYM
   END; (* GETCHARLITERAL *)

  FUNCTION CHARTYPE(CURRCHAR,NEXTCHAR: CHARINFO): KEYSYMBOL;

  VAR
      NEXTTWOCHARS: SPECIALCHAR;
      HIT: BOOLEAN;
      THISCHAR: KEYSYMBOL;

   BEGIN (* CHARTYPE *)
     NEXTTWOCHARS[1] := CURRCHAR.VALUES;
     NEXTTWOCHARS[2] := NEXTCHAR.VALUES;
     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.VALUES = SGLCHAR [THISCHAR]
               THEN
                 HIT := TRUE
               ELSE
                 THISCHAR := SUCC(THISCHAR)
         END;
     IF HIT
       THEN
         CHARTYPE := THISCHAR
       ELSE
         CHARTYPE := OTHERSYM
   END; (* CHARTYPE *)

  PROCEDURE GETSPECIALCHAR(VAR CURRCHAR,NEXTCHAR :CHARINFO;
                           VAR NAME     :KEYSYMBOL;VAR VALUES    :
                           STRINGY;VAR LENGTHY   :INTEGER);
   BEGIN (* GETSPECIALCHAR *)
     STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES);
     NAME := CHARTYPE(CURRCHAR,
             NEXTCHAR);
     IF NAME IN DBLCHARS
       THEN
         STORENEXTCHAR(LENGTHY,CURRCHAR,NEXTCHAR,VALUES)
   END; (* GETSPECIALCHAR *)

  PROCEDURE GETNEXTSYMBOL(VAR CURRCHAR,NEXTCHAR:CHARINFO;VAR NAME:
                          KEYSYMBOL;VAR VALUES:STRINGY;VAR LENGTHY:
                          INTEGER);
   BEGIN  (* GETNEXTSYMBOL *)
     CASE NEXTCHAR.NAME OF
       LETTER     : GETIDENTIFIER(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY)
       ;
       DIGIT      : GETNUMBER(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY);
       QUOTE      : GETCHARLITERAL(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY
                    );
       OTHERCHAR:
                  BEGIN
                    GETSPECIALCHAR(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY
                    );
                    IF NAME = OPENCOMMENT
                      THEN
                        GETCOMMENT(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY
                        )
                  END;
       FILEMARK   : NAME := ENDOFFILE
      END (* CASE *)
   END; (* GETNEXTSYMBOL *)

  PROCEDURE GETSYMBOL(VAR NEXTSYM  :SYMBOLINFO;VAR CURRSYM  :SYMBOLINFO)
;

  VAR
      DUMMY: SYMBOLINFO;
   BEGIN  (* GETSYMBOL *)
     DUMMY   := CURRSYM;
     CURRSYM := NEXTSYM;
     NEXTSYM := DUMMY;
     WITH NEXTSYM^ DO
       BEGIN
         SKIPSPACES(CURRCHAR,NEXTCHAR,SPACESBEFORE,CRSBEFORE);
         LENGTHY := 0;
         IF CURRSYM^.NAME = OPENCOMMENT
           THEN
             GETCOMMENT(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY)
           ELSE
             GETNEXTSYMBOL(CURRCHAR,NEXTCHAR,NAME,VALUES,LENGTHY)
       END (* WITH *)
   END; (* GETSYMBOL *)

  PROCEDURE INT2 (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 PPOPTION  :OPTIONTABLE);
   BEGIN
     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,
                              INDENTBYTAB,
                              GOBBLESYMBOLS,
                              CRAFTER];
         DINDENTSYMBOLS    := [];
         GOBBLETERMINATORS := [THENSYM]
       END;
     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,
                              FORSYM,
                              WHILESYM,
                              WITHSYM,
                              CASEVARSYM,
                              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;
     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;
     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; (* INITIALIZE2 *)

  PROCEDURE INITIALIZE(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 PPOPTION:
                       OPTIONTABLE);
   BEGIN (* INITIALIZE *)
     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;
     SAWCOMOPEN := FALSE;
     SAWCOMCLOSE := FALSE;
     INACOMMENT := FALSE;
     SAWQUOTEDSTRING := FALSE;
     GETCHAR(NEXTCHAR,CURRCHAR);
     NEW(CURRSYM);
     NEW(NEXTSYM);
     GETSYMBOL(NEXTSYM,CURRSYM);
     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,
                              CRAFTER];
         DINDENTSYMBOLS    := [];
         GOBBLETERMINATORS := []
       END;
     WITH PPOPTION [CONSTSYM] DO
       BEGIN
         OPTIONSSELECTED   := [BLANKLINEBEFORE,
                              DINDENTONKEYS,
                              SPACEAFTER,
                              INDENTTOCLP,
                              CRAFTER];
         DINDENTSYMBOLS    := [LABELSYM];
         GOBBLETERMINATORS := []
       END;
     WITH PPOPTION [TYPESYM] DO
       BEGIN
         OPTIONSSELECTED   := [BLANKLINEBEFORE,
                              DINDENTONKEYS,
                              SPACEAFTER,
                              INDENTTOCLP,
                              CRAFTER];
         DINDENTSYMBOLS    := [LABELSYM,
                              CONSTSYM];
         GOBBLETERMINATORS := []
       END;
     WITH PPOPTION [VARSYM] DO
       BEGIN
         OPTIONSSELECTED   := [BLANKLINEBEFORE,
                              DINDENTONKEYS,
                              SPACEAFTER,
                              INDENTTOCLP,
                              CRAFTER];
         DINDENTSYMBOLS    := [LABELSYM,
                              CONSTSYM,
                              TYPESYM];
         GOBBLETERMINATORS := []
       END;
     WITH PPOPTION [BEGINSYM] DO
       BEGIN
         OPTIONSSELECTED   := [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;
     INT2 (TOPOFSTACK, CURRLINEPOS, CURRMARGIN, KEYWORD, DBLCHARS,
           DBLCHAR,
           SGLCHAR, RECORDSEEN, CURRCHAR, NEXTCHAR, CURRSYM, NEXTSYM,
           PPOPTION);
   END;

  FUNCTION STACKEMPTY  : BOOLEAN;
   BEGIN
     STACKEMPTY:= (TOP=0)
   END; (* STACKEMPTY *)

  FUNCTION STACKFULL  : BOOLEAN;
   BEGIN
     STACKFULL:= (TOP=MAXSTACKSIZE)
   END; (* STACKFULL *)

  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 *)

  PROCEDURE WRITECRS(NUMBEROFCRS:INTEGER;VAR CURRLINEPOS:INTEGER);

  VAR
      I: INTEGER;
   BEGIN (* WRITECRS *)
     IF NUMBEROFCRS > 0
       THEN
         BEGIN
           FOR I := 1 TO NUMBEROFCRS DO WRITELN(FOUT);
           CURRLINEPOS := 0
         END
   END; (* WRITECRS *)

  PROCEDURE INSERTCR(VAR CURRSYM   :SYMBOLINFO);

  CONST
        ONCE = 1;
   BEGIN (* INSERTCR *)
     IF CURRSYM^.CRSBEFORE = 0
       THEN
         BEGIN
           WRITECRS(ONCE,CURRLINEPOS);
           CURRSYM^.SPACESBEFORE := 0
         END
   END; (* INSERTCR *)

  PROCEDURE INSERTBLANKLINE(VAR CURRSYM:SYMBOLINFO);

  CONST
        ONCE  = 1;
        TWICE = 2;
   BEGIN  (* INSERTBLANKLINE *)
     IF CURRSYM^.CRSBEFORE = 0
       THEN
         BEGIN
           IF CURRLINEPOS = 0
             THEN
               WRITECRS(ONCE,     CURRLINEPOS)
             ELSE
               WRITECRS(TWICE,     CURRLINEPOS);
           CURRSYM^.SPACESBEFORE := 0
         END
       ELSE
         IF CURRSYM^.CRSBEFORE = 1
           THEN
             IF CURRLINEPOS > 0
               THEN
                 WRITECRS(ONCE,     CURRLINEPOS)
   END; (* INSERTBLANKLINE *)

  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 (* LSHIFT *)
     IF NOT STACKEMPTY
       THEN
         BEGIN
           POPSTACK(INDENTSYMBOL,
                    PREVMARGIN);
           CURRMARGIN := PREVMARGIN
         END
   END; (* LSHIFT *)

  PROCEDURE INSERTSPACE(VAR SYMBOL:SYMBOLINFO);
   BEGIN (* INSERTSPACE *)
     IF CURRLINEPOS < MAXLINESIZE
       THEN
         BEGIN
           WRITE(FOUT, 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
      I: INTEGER;
   BEGIN (* MOVELINEPOS *)
     FOR I := CURRLINEPOS+1 TO NEWLINEPOS DO WRITE(FOUT, SPACE);
     CURRLINEPOS := NEWLINEPOS
   END; (* MOVELINEPOS *)

  PROCEDURE PRINTSYMBOL(CURRSYM    :SYMBOLINFO;
                        VAR CURRLINEPOS:INTEGER);

  VAR
      I: INTEGER;
   BEGIN (* PRINTSYMBOL *)
     WITH CURRSYM^ DO
       BEGIN
         FOR I := 1 TO LENGTHY DO
           BEGIN
             WRITE(FOUT, VALUES[I])
           END;
         STARTPOS := CURRLINEPOS (* Save start position for tabbing *);
         CURRLINEPOS := CURRLINEPOS + LENGTHY
       END (* WITH *)
   END; (* PRINTSYMBOL *)

  PROCEDURE PPSYMBOL(CURRSYM:SYMBOLINFO);

  CONST
        ONCE  = 1;

  VAR
      NEWLINEPOS: INTEGER;
   BEGIN (* PPSYMBOL *)
     WITH CURRSYM^ DO
       BEGIN
         WRITECRS(CRSBEFORE,CURRLINEPOS);
         IF (CURRLINEPOS + SPACESBEFORE > CURRMARGIN)
            OR (NAME IN [OPENCOMMENT, CLOSECOMMENT])
           THEN
             NEWLINEPOS := CURRLINEPOS + SPACESBEFORE
           ELSE
             NEWLINEPOS := CURRMARGIN;
         IF NEWLINEPOS + LENGTHY > MAXLINESIZE
           THEN
             BEGIN
               WRITECRS(ONCE,CURRLINEPOS);
               IF CURRMARGIN + LENGTHY <= MAXLINESIZE
                 THEN
                   NEWLINEPOS := CURRMARGIN
                 ELSE
                   IF LENGTHY < MAXLINESIZE
                     THEN
                       NEWLINEPOS := MAXLINESIZE - LENGTHY
                     ELSE
                       NEWLINEPOS := 0
             END;
         MOVELINEPOS( NEWLINEPOS,CURRLINEPOS);
         PRINTSYMBOL(CURRSYM,
                     CURRLINEPOS)
       END (* WITH *)
   END; (* PPSYMBOL *)

  PROCEDURE RSHIFTTOCLP(CURRSYM:KEYSYMBOL);
  FORWARD;

  PROCEDURE GOBBLE(TERMINATORS:KEYSYMSET;VAR CURRSYM,NEXTSYM    :
                   SYMBOLINFO);
   BEGIN (* GOBBLE *)
     RSHIFTTOCLP(CURRSYM^.NAME);
     WHILE NOT(NEXTSYM^.NAME IN (TERMINATORS + [ENDOFFILE])) DO
       BEGIN
         GETSYMBOL(NEXTSYM,CURRSYM);
         PPSYMBOL(CURRSYM)
       END; (* WHILE *)
     LSHIFT
   END; (* GOBBLE *)

  PROCEDURE RSHIFT(CURRSYM:KEYSYMBOL);
   BEGIN (* RSHIFT *)
     IF NOT STACKFULL
       THEN
         PUSHSTACK(CURRSYM,
                   CURRMARGIN);
     IF STARTPOS > CURRMARGIN
       THEN
         CURRMARGIN := STARTPOS;
     IF CURRMARGIN < SLOFAIL1
       THEN
         CURRMARGIN := CURRMARGIN + INDENT1
       ELSE
         IF CURRMARGIN < SLOFAIL2
           THEN
             CURRMARGIN := CURRMARGIN + INDENT2
   END; (* RSHIFT *)

  PROCEDURE RSHIFTTOCLP;
   BEGIN (* RSHIFTTOCLP *)
     IF NOT STACKFULL
       THEN
         PUSHSTACK(CURRSYM,
                   CURRMARGIN);
     CURRMARGIN := CURRLINEPOS
   END; (* RSHIFTTOCLP *)
 BEGIN  (* PRETTYPRINT *)
   LOWVIDEO;
   WRITELN
    ('This is the PASCAL User''s Group PASCAL Prettyprinter:');
   WRITELN;
   GETINPFIL(FIN,FINNAME);
   GETOUTFIL(FOUT,OUTNAME);
   WITH FINSTAT DO
     BEGIN
       FILECH := ' ';
       FILEEF := FALSE;
       FILEEL := FALSE
     END;
   GETFIN;
   INITIALIZE(TOP,        CURRLINEPOS,
              CURRMARGIN, KEYWORD,    DBLCHARS,    DBLCHAR,
              SGLCHAR,    RECORDSEEN, CURRCHAR,    NEXTCHAR,
              CURRSYM,    NEXTSYM,    PPOPTION);
   CRPENDING := FALSE;
   WHILE (NEXTSYM^.NAME <> ENDOFFILE) DO
     BEGIN
       GETSYMBOL(NEXTSYM,CURRSYM);
       WITH PPOPTION [CURRSYM^.NAME] DO
         BEGIN
           IF (CRPENDING AND NOT(CRSUPPRESS IN OPTIONSSELECTED))
              OR (CRBEFORE IN OPTIONSSELECTED)
             THEN
               BEGIN
                 INSERTCR(CURRSYM);
                 CRPENDING := FALSE
               END;
           IF BLANKLINEBEFORE IN OPTIONSSELECTED
             THEN
               BEGIN
                 INSERTBLANKLINE(CURRSYM);
                 CRPENDING := FALSE
               END;
           IF DINDENTONKEYS IN OPTIONSSELECTED
             THEN
               LSHIFTON(DINDENTSYMBOLS);
           IF DINDENT IN OPTIONSSELECTED
             THEN
               LSHIFT;
           IF SPACEBEFORE IN OPTIONSSELECTED
             THEN
               INSERTSPACE(CURRSYM);
           PPSYMBOL(CURRSYM);
           IF SPACEAFTER IN OPTIONSSELECTED
             THEN
               INSERTSPACE(NEXTSYM);
           IF INDENTBYTAB IN OPTIONSSELECTED
             THEN
               RSHIFT(CURRSYM^.NAME);
           IF INDENTTOCLP IN OPTIONSSELECTED
             THEN
               RSHIFTTOCLP(CURRSYM^.NAME);
           IF GOBBLESYMBOLS IN OPTIONSSELECTED
             THEN
               GOBBLE(GOBBLETERMINATORS,CURRSYM,NEXTSYM);
           IF CRAFTER IN OPTIONSSELECTED
             THEN
               CRPENDING := TRUE
         END (* WITH *)
     END; (* WHILE *)
   CLOSE(FIN);
   IF CRPENDING THEN WRITELN(FOUT);
   CLOSE (FOUT)
 END.