oz@utcsstat.UUCP (Ozan Yigit) (08/12/84)
The following is a *VERY PORTABLE* pascal program formatter in
pascal. It has appeared in a DECUS Languages SIG tape many moons
ago, along with the swedish pascal compiler. It compiles and
works beautifully under 4.2BSD, VAX/VMS and I am sure it would port
without any problems to many other systems. My apologies for
not providing a proper man page.
Oz (the wizard of one thing or another..)
Dept. of Computer Science
York University
----------------------------- RIP -----------------------------
program pascalformatter (input, output);
{
| ** 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 input 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 input. Blank lines are copied from the input 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 output line are
| continued with additional indentation ("contindent").
|
| INPUT FORM: The program expects as input 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 input file
| to the output file without significant modification. Error
| messages may be inserted into the output 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 input line + 1 }
maxoutlen = 72; { maximum width of output line }
initmargin = 1; { initial value of output margin }
commthresh = 4; { column threshhold in input for
comments to be aligned }
alcommbase = 35; { aligned comments in output 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; { inline.buf[base] precedes word }
size: inrange end; { length of word in inline.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
inline: record { input line data }
endoffile: boolean; { end of file on input? }
ch: char; { current char, buf[index] }
index: inrange; { subscript of current char }
len: natural; { length of input line in buf }
{ string ';BEGINEND' in buf[-8..0] }
buf: array [-8..maxinlen] of char end;
outline: record { output 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 }
{ 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 output file }
var
i: outrange; { loop index }
begin
with outline do begin
while blanklns > 0 do begin
writeln (output);
blanklns := blanklns - 1 end;
if len > 0 then begin
for i := 1 to len do write (output, buf[i]);
writeln (output);
len := 0 end end;
end; { writeline }
procedure writeerror (error: errortype);
{ report error to output }
var
i, ix: inrange; { loop index, limit }
begin
writeline;
write (output, ' (* !!! error, ');
case error of
longline: write (output, 'shorter line');
noendcomm: write (output, 'end of comment');
notquote: write (output, 'final "''" on line');
longword: write (output, 'shorter word');
notdo: write (output, '"do"');
notof: write (output, '"of"');
notend: write (output, '"end"');
notthen: write (output, '"then"');
notbegin: write (output, '"begin"');
notuntil: write (output, '"until"');
notsemicolon: write (output, '";"');
notcolon: write (output, '":"');
notparen: write (output, '")"');
noeof: write (output, 'end of file') end;
write (output, ' expected');
if error >= longword then begin
write (output, ', not "');
with inline, word do begin
if size > maxrwlen then ix := maxrwlen
else ix := size;
for i := 1 to ix do write (output, buf[base + i]) end;
write (output, '"') end;
if error = noeof then write (output, ', FORMATTING STOPS');
writeln (output, ' !!! *)');
end; { writeerror }
procedure readline; { read line into input buffer }
var
c: char; { input character }
nonblank: boolean; { is char other than space? }
begin
with inline do begin
len := 0;
if eof (input) then endoffile := true
else begin { get next line }
while not eoln (input) do begin
read (input, 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 (input);
if len >= maxinlen then begin
{ input 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 input buffer }
begin
with inline do begin
index := index + 1;
ch := buf[index] end;
end; { getchar }
function nextchar: char; { look at next char in input buffer }
begin
with inline 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 input line? }
begin
first := false;
with inline, 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 (output, 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 inline, 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 input buffer into
output 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 output 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] := inline.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 inline 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
output buffer }
begin
copysymbol (newsymbol, newword[newsymbol]);
end; { insert }
procedure getsymbol; { get next non-comment symbol }
procedure findsymbol; { find next symbol in input 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, inline 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[inline.ch] in [letter, digit] do
getchar;
checkresword;
end; { getname }
procedure getnumber;
begin
with inline 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 inline 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 inline 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 output }
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 input }
begin
writeerror (noeof);
with inline 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 inline 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;
initialize;
{ *************** Files may be opened here. }
getsymbol;
block;
if not inline.endoffile then copyrem;
writeline;
end { pascalformatter } .