Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/PBTURBO.ZIP/PBTURBO.PAS

Pascal/Delphi Source File | 1985-12-28 | 45.8 KB | 1,108 lines

 program pascalformatter (infile, outfile);
{
| **                Pascal Program Formatter                       **
| **                                                               **
| **   by J. E. Crider, Shell Oil Company, Houston, Texas 77025    **
| **                                                               **
| **   Copyright (c) 1980 by Shell Oil Company.  Permission to     **
| **   copy, modify, and distribute, but not for profit, is        **
| **   hereby granted, provided that this note is included.        **
|
|   This portable program formats Pascal programs and acceptable
|   program fragments according to structured formatting principles
|   [SIGPLAN Notices, Vol. 13, No. 11, Nov. 1978, pp. 15-22].
|   The actions of the program are as follows:
|
|   PREPARATION:  For each structured statement that controls a
|      structured statement, the program converts the controlled
|      statement into a compound statement.  The inserted BEGIN/END
|      pair are in capital letters.  A null statement (with semicolon)
|      is inserted before the last END symbol of each program/
|      procedure/function, if needed.  The semicolon forces the END
|      symbol to appear on a line by itself.
|
|   FORMATTING:  Each structured statement that controls a simple
|      statement is placed on a single line, as if it were a simple
|      statement.  Otherwise, each structured statement is formatted
|      in the following pattern (with indentation "indent"):
|
|            XXXXXX header XXXXXXXX
|               XXXXXXXXXXXXXXXXXX
|               XXXXX body XXXXXX
|               XXXXXXXXXXXXXXXXXX
|
|      where the header is one of:
|
|            while <expression> do begin
|            for <control variable> := <for list> do begin
|            with <record variable list> do begin
|            repeat
|            if <expression> then begin
|            else if <expression> then begin
|            else begin
|            case <expression> of
|            <case label list>: begin
|
|      and the last line either begins with UNTIL or ends with END.
|      Other program parts are formatted similarly.  The headers are:
|
|            <program/procedure/function heading>;
|            label
|            const
|            type
|            var
|            begin
|            (various for records and record variants)
|
|   COMMENTS:  Each comment that starts before or on a specified
|      column on an infile line (program constant "commthresh") is
|      copied without shifting or reformatting.  Each comment that
|      starts after "commthresh" is reformatted and left-justified
|      following the aligned comment base column ("alcommbase").
|
|   LABELS:  Each statement label is justified to the left margin and
|      is placed on a line by itself.
|
|   SPACES AND BLANK LINES:  Spaces not at line breaks are copied from
|      the infile.  Blank lines are copied from the infile if they appear
|      between statements (or appropriate declaration units).  A blank
|      line is inserted above each significant part of each program/
|      procedure/function if one is not already there.
|
|   CONTINUATION:  Lines that are too long for an outfile line are
|      continued with additional indentation ("contindent").
|
|   INPUT FORM:  The program expects as infile a program or program
|      fragment in Standard Pascal.  A program fragment is acceptable
|      if it consists of a sequence of (one or more) properly ordered
|      program parts; examples are:  a statement part (that is, a
|      compound statement), or a TYPE part and a VAR part followed by
|      procedure declarations.  If the program fragment is in serious
|      error, then the program may copy the remainder of the infile file
|      to the outfile file without significant modification.  Error
|      messages may be inserted into the outfile file as comments.
|}

    const
       maxrwlen = 10;              { size of reserved word strings }
       ordminchar = 32;            { ord of lowest char in char set }
       ordmaxchar = 126;           { ord of highest char in char set }
 {  Although this program uses the ASCII character set, conversion to
    most other character sets should be straightforward. }

 {  The following parameters may be adjusted for the installation: }
       maxinlen = 255;             { maximum width of infile line + 1 }
       maxoutlen = 72;             { maximum width of outfile line }
       initmargin = 1;             { initial value of outfile margin }
       commthresh = 4;             { column threshhold in infile for
                                      comments to be aligned }
       alcommbase = 35;            { aligned comments in outfile start
                                      AFTER this column }
       indent = 3;                 { RECOMMENDED indentation increment }
       contindent = 5;             { continuation indentation, >indent }
       endspaces = 3;              { number of spaces to precede 'END' }
       commindent = 3;             { comment continuation indentation }

    type
       natural = 0..maxint;
       inrange = 0..maxinlen;
       outrange = 0..maxoutlen;

       errortype = (longline, noendcomm, notquote, longword, notdo,
            notof, notend, notthen, notbegin, notuntil, notsemicolon,
            notcolon, notparen, noeof);

       chartype = (illegal, special, chapostrophe, chleftparen,
            chrightparen, chperiod, digit, chcolon, chsemicolon,
            chlessthan, chgreaterthan, letter, chleftbrace);

                                   { for reserved word recognition }
       resword = (                 { reserved words ordered by length }
            rwif, rwdo, rwof, rwto, rwin, rwor,
                                   { length: 2 }
            rwend, rwfor, rwvar, rwdiv, rwmod, rwset, rwand, rwnot,
            rwnil,                 { length: 3 }
            rwthen, rwelse, rwwith, rwgoto, rwcase, rwtype, rwfile,
                                   { length: 4 }
            rwbegin, rwuntil, rwwhile, rwarray, rwconst, rwlabel,
                                   { length: 5 }
            rwrepeat, rwrecord, rwdownto, rwpacked,
                                   { length: 6 }
            rwprogram,             { length: 7 }
            rwfunction,            { length: 8 }
            rwprocedure,           { length: 9 }
            rwx);                  { length: 10 for table sentinel }
       rwstring = packed array [1..maxrwlen] of char;

       firstclass = (              { class of word if on new line }
            newclause,             { start of new clause }
            continue,              { continuation of clause }
            alcomm,                { start of aligned comment }
            contalcomm,            { continuation of aligned comment }
            uncomm,                { start of unaligned comment }
            contuncomm,            { continuation of unaligned comment }
            stmtlabel);            { statement label }
       wordtype = record           { data record for word }
          whenfirst: firstclass;   { class of word if on new line }
          puncfollows: boolean;    { to reduce dangling punctuation }
          blanklncount: natural;   { number of preceding blank lines }
          spaces: integer;         { number of spaces preceding word }
          base: -9..maxinlen;      { in_line.buf[base] precedes word }
          size: inrange   end;     { length of word in in_line.buf }

       symboltype = (              { symbols for syntax analysis }
            semicolon, sybegin, syend,
                                   { three insertable symbols first }
            syif, sydo, syof, sythen, syelse, sygoto, sycase, syuntil,
            syrepeat, syrecord, forwhilewith, progprocfunc, declarator,
            otherword, othersym, leftparen, rightparen, period,
            sysubrange, intconst, colon, ident, comment, syeof);
       inserttype = semicolon..syend;
       symbolset = set of symboltype;
 { *** NOTE: set size of 0..26 REQUIRED for symbolset! }

    var
       in_line: record              { infile line data }
          endoffile: boolean;      { end of file on infile? }
          ch: char;                { current char, buf[index] }
          index: inrange;          { subscript of current char }
          len: natural;            { length of infile line in buf }
                                   { string ';BEGINEND' in buf[-8..0] }
          buf: array [-8..maxinlen] of char   end;
       outline: record             { outfile line data }
          blanklns: natural;       { number of preceding blank lines }
          len: outrange;           { number of chars in buf }
          buf: array [1..maxoutlen] of char   end;
       word: wordtype;             { current word }
       margin: outrange;           { left margin }
       lnpending: boolean;         { new line before next symbol? }
       symbol: symboltype;         { current symbol }
       infile,outfile :text;
  { Structured Constants }
       headersyms: symbolset;      { headers for program parts }
       strucsyms: symbolset;       { symbols that begin structured
                                      statements }
       stmtbeginsyms: symbolset;   { symbols that begin statements }
       stmtendsyms: symbolset;     { symbols that follow statements }
       stopsyms: symbolset;        { symbols that stop expression scan }
       recendsyms: symbolset;      { symbols that stop record scan }
       datawords: symbolset;       { to reduce dangling punctuation }
       newword: array [inserttype] of wordtype;
       instring: packed array [1..9] of char;
       firstrw: array [1..maxrwlen] of resword;
       rwword: array [rwif..rwprocedure] of rwstring;
       rwsy: array [rwif..rwprocedure] of symboltype;
       charclass: array [char] of chartype;
  { above is portable form; possible ASCII form is: }
  {    charclass: array [' '..'~'] of chartype;     }
       symbolclass: array [chartype] of symboltype;

    function capital (ch: char): char;
                                   { capitalize char if lower-case
                                      letter }
                                   { !!! implementation-dependent! }

       const
          lettercasediff = 32;     { ASCII character set }

       begin
          if (ch < 'a') or (ch > 'z') then capital := ch
          else capital := chr (ord (ch) - lettercasediff);
          end;                     { capital }

    procedure strucconsts;         { establish values of structured
                                      constants }

       var
          i: ordminchar..ordmaxchar;
                                   { loop index }
          ch: char;                { loop index }

       procedure buildinsert (symbol: inserttype;
            inclass: firstclass;
            inpuncfollows: boolean;
            inspaces, inbase: integer;
            insize: inrange);

          begin
             with newword[symbol] do begin
                whenfirst := inclass;
                puncfollows := inpuncfollows;
                blanklncount := 0;
                spaces := inspaces;
                base := inbase;
                size := insize   end;
             end;                  { buildinsert }

       procedure buildrw (rw: resword;
            symword: rwstring;
            symbol: symboltype);

          begin
             rwword[rw] := symword;{ reserved word string }
             rwsy[rw] := symbol;   { map to symbol }
             end;                  { buildrw }

       begin                       { strucconsts }
                                   { symbol sets for syntax analysis }
          headersyms := [progprocfunc, declarator, sybegin, syeof];
          strucsyms := [sycase, syrepeat, syif, forwhilewith];
          stmtbeginsyms := strucsyms + [sybegin, ident, sygoto];
          stmtendsyms := [semicolon, syend, syuntil, syelse, syeof];
          stopsyms := headersyms + strucsyms + stmtendsyms + [sygoto];
          recendsyms := [rightparen, syend, syeof];

          datawords := [otherword, intconst, ident, syend];

                                   { words for insertable symbols }
          buildinsert (semicolon, continue, false, 0, -9, 1);
          buildinsert (sybegin, continue, false, 1, -8, 5);
          buildinsert (syend, newclause, true, endspaces, -3, 3);
          instring := ';BEGINEND';

                                   { constants for recognizing reserved
                                      words }
          firstrw[1] := rwif;      { length: 1 }
          firstrw[2] := rwif;      { length: 2 }
          buildrw (rwif, 'IF        ', syif);
          buildrw (rwdo, 'DO        ', sydo);
          buildrw (rwof, 'OF        ', syof);
          buildrw (rwto, 'TO        ', othersym);
          buildrw (rwin, 'IN        ', othersym);
          buildrw (rwor, 'OR        ', othersym);
          firstrw[3] := rwend;     { length: 3 }
          buildrw (rwend, 'END       ', syend);
          buildrw (rwfor, 'FOR       ', forwhilewith);
          buildrw (rwvar, 'VAR       ', declarator);
          buildrw (rwdiv, 'DIV       ', othersym);
          buildrw (rwmod, 'MOD       ', othersym);
          buildrw (rwset, 'SET       ', othersym);
          buildrw (rwand, 'AND       ', othersym);
          buildrw (rwnot, 'NOT       ', othersym);
          buildrw (rwnil, 'NIL       ', otherword);
          firstrw[4] := rwthen;    { length: 4 }
          buildrw (rwthen, 'THEN      ', sythen);
          buildrw (rwelse, 'ELSE      ', syelse);
          buildrw (rwwith, 'WITH      ', forwhilewith);
          buildrw (rwgoto, 'GOTO      ', sygoto);
          buildrw (rwcase, 'CASE      ', sycase);
          buildrw (rwtype, 'TYPE      ', declarator);
          buildrw (rwfile, 'FILE      ', othersym);
          firstrw[5] := rwbegin;   { length: 5 }
          buildrw (rwbegin, 'BEGIN     ', sybegin);
          buildrw (rwuntil, 'UNTIL     ', syuntil);
          buildrw (rwwhile, 'WHILE     ', forwhilewith);
          buildrw (rwarray, 'ARRAY     ', othersym);
          buildrw (rwconst, 'CONST     ', declarator);
          buildrw (rwlabel, 'LABEL     ', declarator);
          firstrw[6] := rwrepeat;  { length: 6 }
          buildrw (rwrepeat, 'REPEAT    ', syrepeat);
          buildrw (rwrecord, 'RECORD    ', syrecord);
          buildrw (rwdownto, 'DOWNTO    ', othersym);
          buildrw (rwpacked, 'PACKED    ', othersym);
          firstrw[7] := rwprogram; { length: 7 }
          buildrw (rwprogram, 'PROGRAM   ', progprocfunc);
          firstrw[8] := rwfunction;{ length: 8 }
          buildrw (rwfunction, 'FUNCTION  ', progprocfunc);
          firstrw[9] := rwprocedure;
                                   { length: 9 }
          buildrw (rwprocedure, 'PROCEDURE ', progprocfunc);
          firstrw[10] := rwx;      { length: 10 for table sentinel }

                                   { constants for lexical scan }
          for i := ordminchar to ordmaxchar do begin
             charclass[chr (i)] := illegal   end;
          for ch := 'a' to 'z' do begin
                                   { !!! implementation-dependent!  (but
                                      can be replaced with 52 explicit
                                      assignments) }
             charclass[ch] := letter;
             charclass[capital (ch)] := letter   end;
          for ch := '0' to '9' do charclass[ch] := digit;
          charclass[' '] := special;
          charclass['$'] := special;
          charclass[''''] := chapostrophe;
          charclass['('] := chleftparen;
          charclass[')'] := chrightparen;
          charclass['*'] := special;
          charclass['+'] := special;
          charclass['-'] := special;
          charclass['.'] := chperiod;
          charclass['/'] := special;
          charclass[':'] := chcolon;
          charclass[';'] := chsemicolon;
          charclass['<'] := chlessthan;
          charclass['='] := special;
          charclass['>'] := chgreaterthan;
          charclass['@'] := special;
          charclass['['] := special;
          charclass[']'] := special;
          charclass['^'] := special;
          charclass['{'] := chleftbrace;
          symbolclass[illegal] := othersym;
          symbolclass[special] := othersym;
          symbolclass[chapostrophe] := otherword;
          symbolclass[chleftparen] := leftparen;
          symbolclass[chrightparen] := rightparen;
          symbolclass[chperiod] := period;
          symbolclass[digit] := intconst;
          symbolclass[chcolon] := colon;
          symbolclass[chsemicolon] := semicolon;
          symbolclass[chlessthan] := othersym;
          symbolclass[chgreaterthan] := othersym;
          symbolclass[letter] := ident;
          symbolclass[chleftbrace] := comment;

          end;                     { strucconsts }

{ writeline/writeerror/readline convert between files and lines. }

    procedure writeline;           { write buffer into outfile file }

       var
          i: outrange;             { loop index }

       begin
          with outline do begin
             while blanklns > 0 do begin
                writeln (outfile);
                blanklns := blanklns - 1   end;
             if len > 0 then begin
                for i := 1 to len do write (outfile, buf[i]);
                writeln (outfile);
                len := 0   end   end;
          end;                     { writeline }

    procedure writeerror (error: errortype);
                                   { report error to outfile }

       var
          i, ix: inrange;          { loop index, limit }

       begin
          writeline;
          write (outfile, ' (*  !!! error, ');
          case error of
             longline:     write (outfile, 'shorter line');
             noendcomm:    write (outfile, 'end of comment');
             notquote:     write (outfile, 'final "''" on line');
             longword:     write (outfile, 'shorter word');
             notdo:        write (outfile, '"do"');
             notof:        write (outfile, '"of"');
             notend:       write (outfile, '"end"');
             notthen:      write (outfile, '"then"');
             notbegin:     write (outfile, '"begin"');
             notuntil:     write (outfile, '"until"');
             notsemicolon: write (outfile, '";"');
             notcolon:     write (outfile, '":"');
             notparen:     write (outfile, '")"');
             noeof:        write (outfile, 'end of file')   end;
          write (outfile, ' expected');
          if error >= longword then begin
             write (outfile, ', not "');
             with in_line, word do begin
                if size > maxrwlen then ix := maxrwlen
                else ix := size;
                for i := 1 to ix do write (outfile, buf[base + i])   end;
             write (outfile, '"')   end;
          if error = noeof then write (outfile, ', FORMATTING STOPS');
          writeln (outfile, ' !!!  *)');
          end;                     { writeerror }

    procedure readline;            { read line into infile buffer }

       var
          c: char;                 { infile character }
          nonblank: boolean;       { is char other than space? }

       begin
          with in_line do begin
             len := 0;
             if eof (infile) then endoffile := true
             else begin            { get next line }
                while not eoln (infile) do begin
                   read (infile, c);
                   if c < ' ' then begin
                                   { convert ASCII control chars (except
                                      leading form feed) to spaces }
                      if c = chr (9) then begin
                                   { ASCII tab char }
                         c := ' '; { add last space at end }
                         while len mod 8 <> 7 do begin
                            len := len + 1;
                            if len < maxinlen then buf[len] := c   end;
                         end       { end tab handling }
                      else if (c <> chr (12)) or (len > 0) then c :=
                           ' ';
                      end;         { end ASCII control char conversion }
                   len := len + 1;
                   if len < maxinlen then buf[len] := c   end;
                readln (infile);
                if len >= maxinlen then begin
                                   { infile line too long }
                   writeerror (longline);
                   len := maxinlen - 1   end;
                nonblank := false;
                repeat             { trim line }
                   if len = 0 then nonblank := true
                   else if buf[len] <> ' ' then nonblank := true
                   else len := len - 1
                   until nonblank   end;
             len := len + 1;       { add exactly ONE trailing blank }
             buf[len] := ' ';
             index := 0   end;
          end;                     { readline }

{ startword/finishword/copyword convert between lines and words.
   auxiliary procedures getchar/nextchar precede. }

    procedure getchar;             { get next char from infile buffer }

       begin
          with in_line do begin
             index := index + 1;
             ch := buf[index]   end;
          end;                     { getchar }

    function nextchar: char;       { look at next char in infile buffer }

       begin
          with in_line do nextchar := buf[index + 1];
          end;                     { nextchar }

    procedure startword (startclass: firstclass);
                                   { note beginning of word, and count
                                      preceding lines and spaces }

       var
          first: boolean;          { is word the first on infile line? }

       begin
          first := false;
          with in_line, word do begin
             whenfirst := startclass;
             blanklncount := 0;
             while (index >= len) and not endoffile do begin
                if len = 1 then blanklncount := blanklncount + 1;
                if startclass = contuncomm then writeline
                else first := true;
                readline;          { with exactly ONE trailing blank }
                getchar;
{ ASCII:        if ch = chr (12) then begin
                                   [ ASCII form feed char ]
                   writeline;
                   writeln (outfile, chr (12));
                   blanklncount := 0;
                   getchar   end;  [ end ASCII form feed handling }
                end;
             spaces := 0;          { count leading spaces }
             if not endoffile then begin
                while ch = ' ' do begin
                   spaces := spaces + 1;
                   getchar   end   end;
             if first then spaces := 1;
             base := index - 1   end;
          end;                     { startword }

    procedure finishword;          { note end of word }

       begin
          with in_line, word do begin
             puncfollows := (symbol in datawords) and (ch <> ' ');
             size := index - base - 1   end;
          end;                     { finishword }

    procedure copyword (newline: boolean;
         word: wordtype);          { copy word from infile buffer into
                                      outfile buffer }

       var
          i: integer;              { outline.len excess, loop index }

       begin
          with word, outline do begin
             i := maxoutlen - len - spaces - size;
             if newline or (i < 0) or ((i = 0) and puncfollows) then
                  writeline;
             if len = 0 then begin { first word on outfile line }
                blanklns := blanklncount;
                case whenfirst of  { update LOCAL word.spaces }
                   newclause:  spaces := margin;
                   continue:   spaces := margin + contindent;
                   alcomm:     spaces := alcommbase;
                   contalcomm: spaces := alcommbase + commindent;
                   uncomm:     spaces := base;
                   contuncomm: ;   { spaces := spaces }
                   stmtlabel:  spaces := initmargin   end;
                if spaces + size > maxoutlen then begin
                   spaces := maxoutlen - size;
                                   { reduce spaces }
                   if spaces < 0 then begin
                      writeerror (longword);
                      size := maxoutlen;
                      spaces := 0   end   end   end;
             for i := 1 to spaces do begin
                                   { put out spaces }
                len := len + 1;
                buf[len] := ' '   end;
             for i := 1 to size do begin
                                   { copy actual word }
                len := len + 1;
                buf[len] := in_line.buf[base + i]   end   end;
          end;                     { copyword }

{ docomment/copysymbol/insert/getsymbol/findsymbol convert between
   words and symbols. }

    procedure docomment;           { copy aligned or unaligned comment }

       procedure copycomment (commclass: firstclass;
            commbase: inrange);    { copy words of comment }

          var
             endcomment: boolean;  { end of comment? }

          begin
             with word do begin    { copy comment begin symbol }
                whenfirst := commclass;
                spaces := commbase - outline.len;
                copyword ((spaces < 0) or (blanklncount > 0), word)
                end;
             commclass := succ (commclass);
             with in_line do begin
                repeat             { loop for successive words }
                   startword (commclass);
                   endcomment := endoffile;
                                   { premature end? }
                   if endcomment then writeerror (noendcomm)
                   else begin
                      repeat
                         if ch = '*' then begin
                            getchar;
                            if ch = ')' then begin
                               endcomment := true;
                               getchar   end   end
                         else if ch = '}' then begin
                            endcomment := true;
                            getchar   end
                         else getchar
                         until (ch = ' ') or endcomment   end;
                   finishword;
                   copyword (false, word)
                   until endcomment   end;
             end;                  { copycomment }

       begin                       { docomment }
          if word.base < commthresh then begin
                                   { copy comment without alignment }
             copycomment (uncomm, word.base)   end
          else begin               { align and format comment }
             copycomment (alcomm, alcommbase)   end;
          end;                     { docomment }

    procedure copysymbol (symbol: symboltype;
         word: wordtype);          { copy word(s) of symbol }

       begin
          if symbol = comment then begin
             docomment;            { NOTE: docomment uses global word! }
             lnpending := true   end
          else if symbol = semicolon then begin
             copyword (false, word);
             lnpending := true   end
          else begin
             copyword (lnpending, word);
             lnpending := false   end;
          end;                     { copysymbol }

    procedure insert (newsymbol: inserttype);
                                   { copy word for inserted symbol into
                                      outfile buffer }

       begin
          copysymbol (newsymbol, newword[newsymbol]);
          end;                     { insert }

    procedure getsymbol;           { get next non-comment symbol }

       procedure findsymbol;       { find next symbol in infile buffer }

          var
             chclass: chartype;    { classification of leading char }

          procedure checkresword;  { check if current identifier is
                                      reserved word/symbol }

             var
                rw, rwbeyond: resword;
                                   { loop index, limit }
                symword: rwstring; { copy of symbol word }
                i: 1..maxrwlen;    { loop index }

             begin
                with word, in_line do begin
                   size := index - base - 1;
                   if size < maxrwlen then begin
                      symword := '          ';
                      for i := 1 to size do symword[i] := capital (buf[
                           base + i]);
                      rw := firstrw[size];
                      rwbeyond := firstrw[size + 1];
                      symbol := semicolon;
                      repeat
                         if rw >= rwbeyond then symbol := ident
                         else if symword = rwword[rw] then symbol :=
                              rwsy[rw]
                         else rw := succ (rw)
                         until symbol <> semicolon;
                      if symbol = syend then begin
                         if spaces < endspaces then spaces := endspaces;
                         whenfirst := newclause   end   end   end;
                end;               { checkresword }

          procedure getname;

             begin
                while charclass[in_line.ch] in [letter, digit] do
                     getchar;
                checkresword;
                end;               { getname }

          procedure getnumber;

             begin
                with in_line do begin
                   while charclass[ch] = digit do getchar;
                   if ch = '.' then begin
                                   { thanks to A.H.J.Sale, watch for
                                      '..' }
                      if charclass[nextchar] = digit then begin
                                   { NOTE: nextchar is a function! }
                         symbol := otherword;
                         getchar;
                         while charclass[ch] = digit do getchar   end
                      end;
                   if capital (ch) = 'E' then begin
                      symbol := otherword;
                      getchar;
                      if (ch = '+') or (ch = '-') then getchar;
                      while charclass[ch] = digit do getchar   end
                   end;
                end;               { getnumber }

          procedure getstringliteral;

             var
                endstring: boolean;{ end of string literal? }

             begin
                with in_line do begin
                   endstring := false;
                   repeat
                      if ch = '''' then begin
                         getchar;
                         if ch = '''' then getchar
                         else endstring := true   end
                      else if index >= len then begin
                                   { error, final "'" not on line }
                         writeerror (notquote);
                         symbol := syeof;
                         endstring := true   end
                      else getchar
                      until endstring   end;
                end;               { getstringliteral }

          begin                    { findsymbol }
             startword (continue);
             with in_line do begin
                if endoffile then symbol := syeof
                else begin
                   chclass := charclass[ch];
                   symbol := symbolclass[chclass];
                   getchar;        { second char }
                   case chclass of
                      chsemicolon, chrightparen, chleftbrace, special,
                           illegal:   ;
                      letter:  getname;
                      digit:  getnumber;
                      chapostrophe:  getstringliteral;
                      chcolon:  begin
                         if ch = '=' then begin
                            symbol := othersym;
                            getchar   end   end;
                      chlessthan:  begin
                         if (ch = '=') or (ch = '>') then getchar   end;
                      chgreaterthan:  begin
                         if ch = '=' then getchar   end;
                      chleftparen:  begin
                         if ch = '*' then begin
                            symbol := comment;
                            getchar   end   end;
                      chperiod:  begin
                         if ch = '.' then begin
                            symbol := sysubrange;
                            getchar   end   end   end   end   end;
             finishword;
             end;                  { findsymbol }

       begin                       { getsymbol }
          repeat
             copysymbol (symbol, word);
                                   { copy word for symbol to outfile }
             findsymbol            { get next symbol }
             until symbol <> comment;
          end;                     { getsymbol }

{ block performs recursive-descent syntax analysis with symbols,
   adjusting margin, lnpending, word.whenfirst, and
   word.blanklncount.  auxiliary procedures precede. }

    procedure startclause;         { (this may be a simple clause, or
                                      the start of a header) }

       begin
          word.whenfirst := newclause;
          lnpending := true;
          end;                     { startclause }

    procedure passsemicolons;      { pass consecutive semicolons }

       begin
          while symbol = semicolon do begin
             getsymbol;
             startclause   end;    { new line after ';' }
          end;                     { passsemicolons }

    procedure startpart;           { start program part }

       begin
          with word do begin
             if blanklncount = 0 then blanklncount := 1   end;
          startclause;
          end;                     { startpart }

    procedure startbody;           { finish header, start body of
                                      structure }

       begin
          passsemicolons;
          margin := margin + indent;
          startclause;
          end;                     { startbody }

    procedure finishbody;

       begin
          margin := margin - indent;
          end;                     { finishbody }

    procedure passphrase (finalsymbol: symboltype);
                                   { process symbols until significant
                                      symbol encountered }

       var
          endsyms: symbolset;      { complete set of stopping symbols }

       begin
          if symbol <> syeof then begin
             endsyms := stopsyms + [finalsymbol];
             repeat
                getsymbol
                until symbol in endsyms   end;
          end;                     { passphrase }

    procedure expect (expectedsym: symboltype;
         error: errortype;
         syms: symbolset);

       begin
          if symbol = expectedsym then getsymbol
          else begin
             writeerror (error);
             while not (symbol in [expectedsym] + syms) do getsymbol;
             if symbol = expectedsym then getsymbol   end;
          end;                     { expect }

    procedure dolabel;             { process statement label }

       var
          nextfirst: firstclass;   { (pass whenfirst to statement) }

       begin
          with word do begin
             nextfirst := whenfirst;
             whenfirst := stmtlabel;
             lnpending := true;
             getsymbol;
             expect (colon, notcolon, stopsyms);
             whenfirst := nextfirst;
             lnpending := true   end;
          end;                     { dolabel }

    procedure block;               { process block }

       procedure heading;          { process heading for program,
                                      procedure, or function }

          procedure matchparens;   { process parentheses in heading }

             begin
                getsymbol;
                while not (symbol in recendsyms) do begin
                   if symbol = leftparen then matchparens
                   else getsymbol   end;
                expect (rightparen, notparen, stopsyms + recendsyms);
                end;               { matchparens }

          begin                    { heading }
             getsymbol;
             passphrase (leftparen);
             if symbol = leftparen then matchparens;
             if symbol = colon then passphrase (semicolon);
             expect (semicolon, notsemicolon, stopsyms);
             end;                  { heading }

       procedure statement;        { process statement }

          forward;

       procedure stmtlist;         { process sequence of statements }

          begin
             repeat
                statement;
                passsemicolons
                until symbol in stmtendsyms;
             end;                  { stmtlist }

       procedure compoundstmt (    { process compound statement }
            stmtpart: boolean);    { statement part of block? }

          begin
             getsymbol;
             startbody;            { new line, indent after 'BEGIN' }
             stmtlist;
             if stmtpart and not lnpending then insert (semicolon);
             expect (syend, notend, stmtendsyms);
             finishbody;           { left-indent after 'END' }
             end;                  { compoundstmt }

       procedure statement;        { process statement }

          procedure checkcompound; { if structured then force compound }

             begin
                if symbol = intconst then dolabel;
                if symbol in strucsyms then begin
                                   { force compound }
                   insert (sybegin);
                   startbody;      { new line, indent after 'BEGIN' }
                   statement;
                   insert (syend);
                   finishbody   end{ left-indent after 'END' }
                else statement;
                end;               { checkcompound }

          procedure ifstmt;        { process if statement }

             begin
                passphrase (sythen);
                expect (sythen, notthen, stopsyms);
                checkcompound;
                if symbol = syelse then begin
                   startclause;    { new line before 'ELSE' }
                   getsymbol;
                   if symbol = syif then ifstmt
                   else checkcompound   end;
                end;               { ifstmt }

          procedure repeatstmt;    { process repeat statement }

             begin
                getsymbol;
                startbody;         { new line, indent after 'REPEAT' }
                stmtlist;
                startclause;       { new line before 'UNTIL' }
                expect (syuntil, notuntil, stmtendsyms);
                passphrase (semicolon);
                finishbody;        { left-ident after 'UNTIL' }
                end;               { repeatstmt }

          procedure fwwstmt;       { process for, while, or with
                                      statement }

             begin
                passphrase (sydo);
                expect (sydo, notdo, stopsyms);
                checkcompound;
                end;               { fwwstmt }

          procedure casestmt;      { process case statement }

             begin
                passphrase (syof);
                expect (syof, notof, stopsyms);
                startbody;         { new line, indent after 'OF' }
                repeat
                   passphrase (colon);
                   expect (colon, notcolon, stopsyms);
                   checkcompound;
                   passsemicolons
                   until symbol in stopsyms;
                expect (syend, notend, stmtendsyms);
                finishbody;        { left-indent after 'END' }
                end;               { casestmt }

          begin                    { statement }
             if symbol = intconst then dolabel;
             if symbol in stmtbeginsyms then begin
                case symbol of
                   sybegin:       compoundstmt (false);
                   sycase:        casestmt;
                   syif:          ifstmt;
                   syrepeat:      repeatstmt;
                   forwhilewith:  fwwstmt;
                   ident, sygoto: passphrase (semicolon)   end   end;
             if not (symbol in stmtendsyms) then begin
                writeerror (notsemicolon);
                                   { ';' expected }
                passphrase (semicolon)   end;
             end;                  { statement }

       procedure passfields (forvariant: boolean);

          forward;

       procedure dorecord;         { process record declaration }

          begin
             getsymbol;
             startbody;
             passfields (false);
             expect (syend, notend, recendsyms);
             finishbody;
             end;                  { dorecord }

       procedure dovariant;        { process (case) variant part }

          begin
             passphrase (syof);
             expect (syof, notof, stopsyms);
             startbody;
             passfields (true);
             finishbody;
             end;                  { dovariant }

       procedure doparens (forvariant: boolean);
                                   { process parentheses in record }

          begin
             getsymbol;
             if forvariant then startbody;
             passfields (false);
             lnpending := false;   { for empty field list }
             expect (rightparen, notparen, recendsyms);
             if forvariant then finishbody;
             end;                  { doparens }

       procedure passfields;       { process declarations }
 {     procedure passfields (forvariant: boolean); }

          begin                    { passfields }
             while not (symbol in recendsyms) do begin
                if symbol = semicolon then passsemicolons
                else if symbol = syrecord then dorecord
                else if symbol = sycase then dovariant
                else if symbol = leftparen then doparens (forvariant)
                else getsymbol   end;
             end;                  { passfields }

       begin                       { block }
          while symbol = declarator do begin
             startpart;            { label, const, type, var }
             getsymbol;
             startbody;
             repeat
                passphrase (syrecord);
                if symbol = syrecord then dorecord;
                if symbol = semicolon then passsemicolons
                until symbol in headersyms;
             finishbody   end;
          while symbol = progprocfunc do begin
             startpart;            { program, procedure, function }
             heading;
             startbody;
             if symbol in headersyms then block
             else if symbol = ident then begin
                startpart;         { directive: forward, etc. }
                passphrase (semicolon);
                passsemicolons   end
             else writeerror (notbegin);
             finishbody   end;
          if symbol = sybegin then begin
             startpart;            { statement part }
             compoundstmt (true);
             if symbol in [sysubrange, period] then symbol := semicolon;
                                   { treat final period as semicolon }
             passsemicolons   end;
          end;                     { block }

    procedure copyrem;             { copy remainder of infile }

       begin
          writeerror (noeof);
          with in_line do begin
             repeat
                copyword (false, word);
                startword (contuncomm);
                if not endoffile then begin
                   repeat
                      getchar
                      until ch = ' '   end;
                finishword;
                until endoffile   end;
          end;                     { copyrem }

    procedure initialize;          { initialize global variables }

       var
          i: 1..9;                 { loop index }

       begin
          with in_line do begin
             for i := 1 to 9 do buf[i - 9] := instring[i];
                                   { string ';BEGINEND' in buf[-8..0] }
             endoffile := false;
             ch := ' ';
             index := 0;
             len := 0   end;
          with outline do begin
             blanklns := 0;
             len := 0   end;
          with word do begin
             whenfirst := contuncomm;
             puncfollows := false;
             blanklncount := 0;
             spaces := 0;
             base := 0;
             size := 0   end;
          margin := initmargin;
          lnpending := false;
          symbol := othersym;
          end;                     { initialize }

    begin                          { pascalformatter }
       strucconsts;
       assign(infile,'e:\temp');
       assign(outfile,'e:\temp.out');
       reset(infile);
       rewrite(outfile);
       initialize;
 {  ***************  Files may be opened here. }
       getsymbol;
       block;
       if not in_line.endoffile then copyrem;
       writeline;
       close(outfile);
       end                         { pascalformatter } .