{======================================================================}
{ }
{ Program Title: Pascal Prettyprinting Program }
{ }
{ Program Summary: }
{ }
{ This program takes as input a Pascal program and }
{ reformats the program according to a standard set of }
{ prettyprinting rules. The prettyprinted program is given }
{ as output. The prettyprinting rules are given below. }
{ }
{ An important feature is the provision for the use of extra }
{ spaces and extra blank lines. They may be freely inserted by }
{ the user in addition to the spaces and blank lines inserted }
{ by the prettyprinter. }
{ }
{ No attempt is made to detect or correct syntactic errors in }
{ the user's program. However, syntactic errors may result in }
{ erroneous prettyprinting. }
{ }
{ }
{ Input File: input - a file of characters, presumably a }
{ Pascal program or program fragment. }
{ }
{ Output File: output - the prettyprinted program. }
{ }
{ }
{ }
{======================================================================}
{======================================================================}
{ }
{ Pascal Prettyprinting Rules }
{ }
{ }
{ [ General Prettyprinting Rules ] }
{ }
{ 1. Any spaces or blank lines beyond those generated by the }
{ prettyprinter are left alone. The user is encouraged, for the }
{ sake of readability, to make use of this facility. }
{ In addition, comments are left where they are found, unless }
{ they are shifted right by preceeding text on a line. }
{ }
{ 2. All statements and declarations begin on separate lines. }
{ }
{ 3. No line may be greater than 120 characters long. Any line }
{ longer than this is continued on a separate line. }
{ }
{ 4. The keywords "BEGIN", "END", "REPEAT", and "RECORD" are }
{ forced to stand on lines by themselves (or possibly followed by }
{ supporting comments). }
{ In addition, the "UNTIL" clause of a "REPEAT-UNTIL" state- }
{ ment is forced to start on a new line. }
{ }
{ 5. A blank line is forced before the keywords "PROGRAM", }
{ "PROCEDURE", "FUNCTION", "LABEL", "CONST", "TYPE", and "VAR". }
{ }
{ 6. A space is forced before and after the symbols ":=" and }
{ "=". Additionally, a space is forced after the symbol ":". }
{ Note that only "="s in declarations are formatted. "="s in }
{ expressions are ignored. }
{ }
{ }
{ [ Indentation Rules ] }
{ }
{ 1. The bodies of "LABEL", "CONST", "TYPE", and "VAR" declara- }
{ tions are indented from their corresponding declaration header }
{ keywords. }
{ }
{ 2. The bodies of "BEGIN-END", "REPEAT-UNTIL", "FOR", "WHILE", }
{ "WITH", and "CASE" statements, as well as "RECORD-END" struc- }
{ tures and "CASE" variants (to one level) are indented from }
{ their header keywords. }
{ }
{ 3. An "IF-THEN-ELSE" statement is indented as follows: }
{ }
{ IF < expression > }
{ THEN }
{ < statement > }
{ ELSE }
{ < statement > }
{ }
{ }
{======================================================================}
{======================================================================}
{ }
{ General Algorithm }
{ }
{ }
{ The strategy of the prettyprinter is to scan symbols from }
{ the input program and map each symbol into a prettyprinting }
{ action, independently of the context in which the symbol }
{ appears. This is accomplished by a table of prettyprinting }
{ options. }
{ }
{ For each distinguished symbol in the table, there is an }
{ associated set of options. If the option has been selected for }
{ the symbol being scanned, then the action corresponding with }
{ each option is performed. }
{ }
{ The basic actions involved in prettyprinting are the indent- }
{ ation and de-indentation of the margin. Each time the margin is }
{ indented, the previous value of the margin is pushed onto a }
{ stack, along with the name of the symbol that caused it to be }
{ indented. Each time the margin is de-indented, the stack is }
{ popped off to obtain the previous value of the margin. }
{ }
{ The prettyprinting options are processed in the following }
{ order, and invoke the following actions: }
{ }
{ }
{ crsuppress - If a carriage return has been inserted }
{ following the previous symbol, then it is }
{ inhibited until the next symbol is printed. }
{ }
{ crbefore - A carriage return is inserted before the }
{ current symbol (unless one is already there). }
{ }
{ blanklinebefore - A blank line is inserted before the current }
{ symbol (unless already there). }
{ }
{ dindentonkeys - If any of the specified keys are on top of }
{ of the stack, the stack is popped, de-indent- }
{ ing the margin. The process is repeated }
{ until the top of the stack is not one of the }
{ specified keys. }
{ }
{ dindent - The stack is unconditionally popped and the }
{ margin is de-indented. }
{ }
{ spacebefore - A space is inserted before the symbol being }
{ scanned (unless already there). }
{ }
{ [ the symbol is printed at this point ] }
{ }
{ spaceafter - A space is inserted after the symbol being }
{ scanned (unless already there). }
{ }
{ gobbleSymbols - Symbols are continuously scanned and printed }
{ without any processing until one of the }
{ specified symbols is seen (but not gobbled). }
{ }
{ indentbytab - The margin is indented by a standard amount }
{ from the previous margin. }
{ }
{ indenttoclp - The margin is indented to the current line }
{ position. }
{ }
{ crafter - A carriage return is inserted following the }
{ symbol scanned. }
{ }
{ }
{ }
{======================================================================}
PROGRAM prettyprint( { from } INPUT,
{ to } OUTPUT);
{$A15} { Set up initial prettyprinting alignment width }
CONST
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. }
maxkeylength = 10;
{ the maximum length (in characters) of a }
{ pascal reserved keyword. }
maxlinesize = 90;
{ the maximum size (in characters) of a }
{ line output by the prettyprinter. }
slofail1 = 50;
{ up to this column position, each time }
{ "indentbytab" is invoked, the margin }
{ will be indented by "indent1". }
slofail2 = 70;
{ up to this column position, each time }
{ "indentbytab" is invoked, the margin }
{ will be indented by "indent2". Beyond }
{ this, no indentation occurs. }
indent1 = 3;
indent2 = 1;
space = ' ';
keybefore = '<b>';
keyafter = '</b>';
{ Highlight keywords in bold }
numbefore = '<font color ="000080">';
numafter = '</font>';
{ numbers in blue }
commentbefore = '<font color ="408080">';
commentafter = '</font>';
{ comments in green }
stringbefore = '<font color ="FF0000">';
stringafter = '</font>';
{ strings/constant symbols in red }
TYPE
keysymbol = ( progsym, funcsym, procsym,
labelsym, constsym, typesym, varsym,
beginsym, repeatsym, recordsym,
casesym, casevarsym, ofsym,
forsym, whilesym, withsym, dosym,
ifsym, thensym, elsesym,
endsym, forwardsym, untilsym,
becomes, opencomment,closecomment,
semicolon, colon, coloncase ,equals,
openparen, closeparen, period,
endoffile,
othersym );
option = ( crsuppress,
crbefore,
markposition,
firstindentbytab,
blanklinebefore,
dindentonkeys,
dindent,
dindentafter,
spacebefore,
spaceafter,
gobblesymbols,
indentbytab,
indenttoclp,
crbeforegobble,
crnotbegin,
crnotiforbegin,
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..maxkeylength ] 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 [ opencomment..period ] OF CHAR;
string = array [ 1..maxsymbolsize ] OF CHAR;
symbol = RECORD
name : keysymbol;
valu : string;
length : INTEGER;
spacesbefore : INTEGER;
actualstartpos : INTEGER;
crsbefore : INTEGER
END;
symbolinfo = ^symbol;
charname = ( letter, digit, blank, quote,
endofline, filemark, otherchar );
charinfo = RECORD
actuallinepos : INTEGER;
name : charname;
valu : CHAR
END;
stackentry = RECORD
indentsymbol : keysymbol;
prevmargin : INTEGER;
actualstartpos : INTEGER;
END;
symbolstack = ARRAY [ 1..maxstacksize ] OF stackentry;
VAR
recordseen : BOOLEAN;
formattingrequired : BOOLEAN;
currchar,
nextchar : charinfo;
currsym,
nextsym : symbolinfo;
crpending : BOOLEAN;
ppoption : optiontable;
keyword : keywordtable;
dblchars : dblchrset;
dblchar : dblchartable;
sglchar : sglchartable;
stack : symbolstack;
top : INTEGER;
lastsymbolpoppedfromstack : keysymbol;
startpos, { starting position of last symbol written }
currlinepos,
lastlinestartpos ,
thislinestartpos ,
currmargin : INTEGER;
decidlength : INTEGER;
indecsection : BOOLEAN;
gobbling : BOOLEAN;
gobblestart : INTEGER;
gobbleoffset : INTEGER;
PROCEDURE getchar( { from input }
{ updating } VAR nextchar : charinfo;
{ returning } VAR currchar : charinfo );
BEGIN
currchar := nextchar;
WITH nextchar DO BEGIN
IF EOF(INPUT) THEN
name := filemark
ELSE IF EOLN(INPUT) THEN
name := endofline
ELSE IF INPUT^ IN ['a'..'z','A'..'Z'] THEN
name := letter
ELSE IF INPUT^ IN ['0'..'9'] THEN
name := digit
ELSE IF INPUT^ = '''' THEN
name := quote
ELSE IF INPUT^ = space THEN
name := blank
ELSE
name := otherchar;
IF name IN [ filemark, endofline ] THEN BEGIN
thislinestartpos := 0;
actuallinepos := 0;
valu := space
END
ELSE BEGIN
actuallinepos := SUCC(actuallinepos);
valu := INPUT^
END;
IF name <> filemark THEN
GET(INPUT)
END
END;
PROCEDURE storenextchar( { from input }
{ updating } VAR length : INTEGER;
VAR currchar,
nextchar : charinfo;
{ placing in } VAR valu : string );
BEGIN
getchar( { from input }
{ updating } nextchar,
{ returning } currchar );
IF length < maxsymbolsize THEN BEGIN
length := length + 1;
valu [length] := currchar.valu
END
END;
PROCEDURE skipspaces (
{ updating } VAR currchar,
nextchar : charinfo;
{ returning } VAR spacesbefore,
crsbefore : INTEGER );
BEGIN
spacesbefore := 0;
crsbefore := 0;
WHILE nextchar.name IN [ blank, endofline ] DO BEGIN
getchar( { from input }
{ updating } nextchar,
{ returning } currchar );
CASE currchar.name OF
blank :
spacesbefore := spacesbefore + 1;
endofline : BEGIN
crsbefore := crsbefore + 1;
spacesbefore := 0
END
END
END
END;
PROCEDURE checkfordirective (valu : string);
VAR
start : 1..maxsymbolsize;
num : INTEGER;
index : INTEGER;
BEGIN
IF (valu[1] = '{') AND (valu[2] = '$') THEN
start := 3
ELSE IF (valu[1] = '(') AND (valu[2] = '*') AND (valu[3] = '$') THEN
start := 4
ELSE
start := 1;
IF (start > 1) AND (valu[start] IN ['P','A']) THEN
CASE valu[start] OF
'P' :
IF valu[start+1] = '+' THEN
formattingrequired := TRUE
ELSE IF valu[start+1] = '-' THEN
formattingrequired := FALSE;
'A' : BEGIN
num := 0;
index := start + 1;
WHILE valu[index] IN ['0'..'9'] DO BEGIN
num := num * 10 + (ord(valu[index]) - ord('0'));
index := index + 1;
END;
decidlength := num;
END;
END;
END;
PROCEDURE getcomment( { from input }
{ updating } VAR currchar,
nextchar : charinfo;
VAR name : keysymbol;
VAR valu : string;
VAR actualstartpos : INTEGER;
VAR length : INTEGER );
VAR
i : 1..maxsymbolsize;
from : 1..maxsymbolsize;
BEGIN
name := opencomment;
{actualstartpos := nextchar.actuallinepos;}
WHILE NOT ( ((currchar.valu = '*') AND (nextchar.valu = ')'))
OR (currchar.valu = '}')
OR (nextchar.name = endofline)
OR (nextchar.name = filemark)) DO
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
IF (currchar.valu = '}')
OR ((currchar.valu = '*') AND (nextchar.valu = ')')) THEN BEGIN
IF (currchar.valu = '*') AND (nextchar.valu = ')') THEN
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
name := closecomment;
END
END;
FUNCTION idtype( { of } valu : string;
{ using } length : INTEGER )
{ returning } : keysymbol;
VAR
i : INTEGER;
keyvalu : key;
hit : BOOLEAN;
thiskey : keysymbol;
BEGIN
idtype := othersym;
IF length <= maxkeylength THEN BEGIN
FOR i := 1 TO length DO
IF valu [i] IN ['A'..'Z'] THEN
keyvalu [i] := valu [i]
ELSE
keyvalu [i] := CHR( (ORD(valu [i]) - ORD('a')) + ORD('A'));
FOR i := length + 1 TO maxkeylength DO
keyvalu [i] := space;
thiskey := progsym;
hit := FALSE;
WHILE NOT (hit OR (thiskey = SUCC(untilsym))) DO
IF keyvalu = keyword [thiskey] THEN
hit := TRUE
ELSE
thiskey := SUCC(thiskey);
IF hit THEN
idtype := thiskey
END;
END;
PROCEDURE getidentifier( { from input }
{ updating } VAR currchar,
nextchar : charinfo;
{ returning } VAR name : keysymbol;
VAR valu : string;
VAR length : INTEGER );
BEGIN
WHILE nextchar.name IN [ letter, digit ] DO
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
name := idtype( { of } valu,
{ using } length );
IF name IN [ recordsym, casesym, endsym ] THEN
CASE name OF
recordsym :
recordseen := TRUE;
casesym :
IF recordseen THEN
name := casevarsym;
endsym :
recordseen := FALSE
END
END;
PROCEDURE getnumber( { from input }
{ updating } VAR currchar,
nextchar : charinfo;
{ returning } VAR name : keysymbol;
VAR valu : string;
VAR length : INTEGER );
BEGIN
WHILE nextchar.name = digit DO
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
name := othersym
end;
PROCEDURE getcharliteral( { from input }
{ updating } VAR currchar,
nextchar : charinfo;
{ returning } VAR name : keysymbol;
VAR valu : string;
VAR length : INTEGER );
BEGIN
WHILE nextchar.name = quote DO BEGIN
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
WHILE NOT (nextchar.name IN [ quote, endofline, filemark ]) DO
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
IF nextchar.name = quote THEN
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu )
END;
name := othersym
END;
FUNCTION chartype( { of } currchar,
nextchar : charinfo )
{ returning } : keysymbol;
VAR
nexttwochars : specialchar;
hit : boolean;
thischar : keysymbol;
BEGIN
nexttwochars[1] := currchar.valu;
nexttwochars[2] := nextchar.valu;
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 := opencomment;
WHILE NOT (hit OR (pred(thischar) = period)) DO
IF currchar.valu = sglchar [thischar] THEN
hit := TRUE
ELSE
thischar := SUCC(thischar)
END;
IF hit THEN BEGIN
IF (thischar = colon)
AND (stack[top].indentsymbol = casesym) THEN
thischar := coloncase;
chartype := thischar;
END
ELSE
chartype := othersym
END;
PROCEDURE getspecialchar( { from input }
{ updating } VAR currchar,
nextchar : charinfo;
{ returning } VAR name : keysymbol;
VAR valu : string;
VAR length : INTEGER );
BEGIN
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
name := chartype( { of } currchar,
nextchar );
IF (name IN dblchars) AND NOT (currchar.valu IN ['{','}']) THEN
storenextchar( { from input }
{ updating } length,
currchar,
nextchar,
{ in } valu );
END;
PROCEDURE getnextsymbol( { from input }
{ updating } VAR currchar,
nextchar : charinfo;
{ returning } VAR name : keysymbol;
VAR valu : string;
VAR actualstartpos : INTEGER;
VAR length : INTEGER );
BEGIN
actualstartpos := nextchar.actuallinepos;
CASE nextchar.name OF
letter :
getidentifier( { from input }
{ updating } currchar,
nextchar,
{ returning } name,
valu,
length );
digit :
getnumber( { from input }
{ updating } currchar,
nextchar,
{ returning } name,
valu,
length );
quote :
getcharliteral( { from input }
{ updating } currchar,
nextchar,
{ returning } name,
valu,
length );
otherchar : BEGIN
getspecialchar( { from input }
{ updating } currchar,
nextchar,
{ returning } name,
valu,
length );
IF name = opencomment THEN
getcomment( { from input }
{ updating } currchar,
nextchar,
name,
valu,
actualstartpos,
length );
END;
filemark :
name := endoffile
END
END;
PROCEDURE getsymbol ( { from input }
{ updating } VAR nextsym : symbolinfo;
{ returning } VAR currsym : symbolinfo );
VAR
dummy : symbolinfo;
index : INTEGER;
BEGIN
dummy := currsym;
currsym := nextsym;
nextsym := dummy;
IF currsym^.crsbefore > 0 THEN
thislinestartpos := currsym^.spacesbefore;
IF lastlinestartpos = 0 THEN
lastlinestartpos := thislinestartpos;
WITH nextsym^ DO BEGIN
skipspaces (
{ updating } currchar,
nextchar,
{ returning } spacesbefore,
crsbefore );
length := 0;
IF currsym^.name = opencomment THEN
getcomment( { from input }
{ updating } currchar,
nextchar,
{ returning } name,
valu,
actualstartpos,
length )
ELSE
getnextsymbol( { from input }
{ updating } currchar,
nextchar,
{ returning } name,
valu,
actualstartpos,
length );
END;
IF indecsection
AND (currsym^.name = othersym)
AND (nextsym^.name IN [colon , equals]) THEN BEGIN
IF (currsym^.length < decidlength)
AND (decidlength > 0) THEN BEGIN
FOR index := currsym^.length + 1 TO decidlength DO
currsym^.valu[index] := ' ';
currsym^.length := decidlength;
nextsym^.spacesbefore := 1;
END;
END;
END;
PROCEDURE initialise( { returning }
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
topofstack := 0;
currlinepos := 0;
currmargin := 0;
gobbling := FALSE;
thislinestartpos := 0;
lastlinestartpos := 0;
lastsymbolpoppedfromstack := othersym;
decidlength := 10;
formattingrequired := TRUE;
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 [ forwardsym ] := 'FORWARD ';
keyword [ untilsym ] := 'UNTIL ';
dblchars := [ becomes, opencomment ];
dblchar [ becomes ] := ':=';
dblchar [ opencomment ] := '(*';
sglchar [ opencomment ] := '{';
sglchar [ closecomment] := '}';
sglchar [ semicolon ] := ';';
sglchar [ colon ] := ':';
sglchar [ coloncase ] := ':';
sglchar [ equals ] := '=';
sglchar [ openparen ] := '(';
sglchar [ closeparen ] := ')';
sglchar [ period ] := '.';
recordseen := FALSE;
getchar( { from input }
{ updating } nextchar,
{ returning } currchar );
new(currsym);
new(nextsym);
getsymbol( { from input }
{ updating } nextsym,
{ returning } currsym );
WITH ppoption [ progsym ] DO BEGIN
optionsselected := [ blanklinebefore,
spaceafter ];
dindentsymbols := [];
gobbleterminators := []
END;
WITH ppoption [ funcsym ] DO BEGIN
optionsselected := [ blanklinebefore,
dindentonkeys,
indentbytab,
spaceafter ];
dindentsymbols := [ labelsym,
constsym,
forwardsym,
typesym,
varsym ];
gobbleterminators := []
END;
WITH ppoption [ procsym ] DO BEGIN
optionsselected := [ blanklinebefore,
dindentonkeys,
indentbytab,
spaceafter ];
dindentsymbols := [ labelsym,
constsym,
typesym,
forwardsym,
varsym ];
gobbleterminators := []
END;
WITH ppoption [ labelsym ] DO BEGIN
optionsselected := [ blanklinebefore,
dindentonkeys,
crafter,
indentbytab ];
dindentsymbols := [ funcsym,
procsym ];
gobbleterminators := []
END;
WITH ppoption [ constsym ] DO BEGIN
optionsselected := [ blanklinebefore,
dindentonkeys,
crafter,
indentbytab ];
dindentsymbols := [ funcsym,
procsym,
labelsym ];
gobbleterminators := []
END;
WITH ppoption [ typesym ] DO BEGIN
optionsselected := [ blanklinebefore,
dindentonkeys,
crafter,
indentbytab ];
dindentsymbols := [ funcsym,
procsym,
labelsym,
constsym ];
gobbleterminators := []
END;
WITH ppoption [ varsym ] DO BEGIN
optionsselected := [ blanklinebefore,
dindentonkeys,
crafter,
indentbytab ];
dindentsymbols := [ funcsym,
procsym,
labelsym,
constsym,
typesym ];
gobbleterminators := []
END;
WITH ppoption [ beginsym ] DO BEGIN
optionsselected := [ dindentonkeys,
indentbytab,
crafter ];
dindentsymbols := [ funcsym,
procsym,
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,
markposition,
gobblesymbols,
crafter ];
dindentsymbols := [];
gobbleterminators := [ ofsym ]
END;
WITH ppoption [ casevarsym ] DO BEGIN
optionsselected := [ spaceafter,
gobblesymbols,
crafter ];
dindentsymbols := [];
gobbleterminators := [ ofsym ]
END;
WITH ppoption [ ofsym ] DO BEGIN
optionsselected := [ crsuppress,
spacebefore ];
dindentsymbols := [];
gobbleterminators := []
END;
WITH ppoption [ forsym ] DO BEGIN
optionsselected := [ spaceafter,
gobblesymbols];
dindentsymbols := [];
gobbleterminators := [ dosym ]
END;
WITH ppoption [ whilesym ] DO BEGIN
optionsselected := [ spaceafter,
gobblesymbols];
dindentsymbols := [];
gobbleterminators := [ dosym ]
END;
WITH ppoption [ withsym ] DO BEGIN
optionsselected := [ spaceafter,
gobblesymbols ];
dindentsymbols := [];
gobbleterminators := [ dosym ]
END;
WITH ppoption [ dosym ] DO BEGIN
optionsselected := [ crbeforegobble,
crsuppress,
spacebefore,
gobblesymbols,
indentbytab ];
dindentsymbols := [];
gobbleterminators := [ semicolon,
forsym,
ifsym,
beginsym ]
END;
WITH ppoption [ ifsym ] DO BEGIN
optionsselected := [ spaceafter,
dindentonkeys,
gobblesymbols ];
dindentsymbols := [ elsesym ];
gobbleterminators := [ thensym ]
END;
WITH ppoption [ thensym ] DO BEGIN
optionsselected := [ crsuppress,
spacebefore,
indentbytab,
crnotbegin ];
dindentsymbols := [];
gobbleterminators := []
END;
WITH ppoption [ elsesym ] DO BEGIN
optionsselected := [ crbefore,
dindentonkeys,
indentbytab,
crnotiforbegin ];
dindentsymbols := [ ifsym,
elsesym ];
gobbleterminators := []
END;
WITH ppoption [ endsym ] DO BEGIN
optionsselected := [ crbefore,
dindentonkeys,
dindentafter,
crafter ];
dindentsymbols := [ ifsym,
thensym,
elsesym,
dosym,
casevarsym,
procsym,
funcsym,
colon,
coloncase,
equals ];
gobbleterminators := []
END;
WITH ppoption [ forwardsym ] DO BEGIN
optionsselected := [firstindentbytab,
crafter,
dindent ];
dindentsymbols := [ ];
gobbleterminators := [ ];
END;
WITH ppoption [ untilsym ] DO BEGIN
optionsselected := [ crbefore,
dindentonkeys,
dindent,
spaceafter,
gobblesymbols,
crafter ];
dindentsymbols := [ ifsym,
thensym,
elsesym,
dosym,
colon,
equals ];
gobbleterminators := [ endsym,
untilsym,
elsesym,
semicolon ]
END;
WITH ppoption [ becomes ] DO BEGIN
optionsselected := [ spacebefore,
spaceafter,
gobblesymbols ];
dindentsymbols := [];
gobbleterminators := [ endsym,
untilsym,
elsesym,
dosym ,
semicolon ]
END;
WITH ppoption [ opencomment ] DO BEGIN
optionsselected := [ firstindentbytab,
dindentafter ];
dindentsymbols := [];
gobbleterminators := []
END;
WITH ppoption [ closecomment ] DO BEGIN
optionsselected := [ firstindentbytab,
dindentafter ];
dindentsymbols := [];
gobbleterminators := []
END;
WITH ppoption [ semicolon ] DO BEGIN
optionsselected := [ crsuppress,
dindentonkeys,
crafter ];
dindentsymbols := [ ifsym,
thensym,
elsesym,
dosym,
colon,
coloncase,
equals ];
gobbleterminators := []
END;
WITH ppoption [ colon ] DO BEGIN
optionsselected := [ spaceafter,
indenttoclp ];
dindentsymbols := [];
gobbleterminators := []
END;
WITH ppoption [ coloncase ] DO BEGIN
optionsselected := [ crnotbegin,
indentbytab ];
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;
FUNCTION stackempty { returning } : BOOLEAN;
BEGIN
IF top = 0 THEN
stackempty := TRUE
ELSE
stackempty := FALSE
END;
FUNCTION stackfull { returning } : BOOLEAN;
BEGIN
IF top = maxstacksize THEN
stackfull := TRUE
ELSE
stackfull := FALSE
END;
PROCEDURE popstack( { returning } VAR indentsymbol : keysymbol;
VAR actualstartpos: INTEGER;
VAR prevmargin : INTEGER);
BEGIN
IF NOT stackempty THEN BEGIN
indentsymbol := stack[top].indentsymbol;
prevmargin := stack[top].prevmargin;
actualstartpos := stack[top].actualstartpos;
lastsymbolpoppedfromstack := indentsymbol;
top := top - 1
END
ELSE BEGIN
indentsymbol := othersym;
prevmargin := 0
END;
END;
PROCEDURE pushstack( { using } indentsymbol : keysymbol;
actualstartpos : INTEGER;
prevmargin : INTEGER );
BEGIN
top := top + 1;
stack[top].indentsymbol := indentsymbol;
stack[top].prevmargin := prevmargin;
stack[top].actualstartpos := actualstartpos;
END;
PROCEDURE writecrs( { using } numberofcrs : INTEGER;
{ updating } VAR currlinepos : INTEGER
{ writing to output } );
VAR
i : INTEGER;
BEGIN
IF numberofcrs > 0 THEN BEGIN
FOR i := 1 TO numberofcrs DO
WRITELN(OUTPUT);
currlinepos := 0
END
END;
PROCEDURE insertcr( { updating } VAR currsym : symbolinfo
{ writing to output } );
CONST
once = 1;
BEGIN
IF currsym^.crsbefore = 0 THEN BEGIN
writecrs( once, { updating } currlinepos
{ writing to output } );
currsym^.spacesbefore := 0
END
END;
PROCEDURE insertblankline( { updating } VAR currsym : symbolinfo
{ writing to output } );
CONST
once = 1;
twice = 2;
BEGIN
IF currsym^.crsbefore = 0 THEN BEGIN
IF currlinepos = 0 THEN
writecrs( once, { updating } currlinepos
{ writing to output } )
ELSE
writecrs( twice,{ updating } currlinepos
{ writing to output } );
currsym^.spacesbefore := 0
END
ELSE IF currsym^.crsbefore = 1 THEN
IF currlinepos > 0 THEN
writecrs( once, { updating } currlinepos
{ writing to output } )
END;
PROCEDURE lshifton( { using } dindentsymbols : keysymset );
VAR
indentsymbol : keysymbol;
actualstartpos : INTEGER;
msg : symbol;
prevmargin : INTEGER;
BEGIN
IF NOT stackempty THEN BEGIN
REPEAT
popstack( { returning } indentsymbol,
actualstartpos,
prevmargin );
IF indentsymbol IN dindentsymbols THEN BEGIN
currmargin := prevmargin;
lastlinestartpos := 0;
thislinestartpos := 0
END;
UNTIL NOT (indentsymbol IN dindentsymbols)
OR (stackempty);
IF NOT (indentsymbol IN dindentsymbols) THEN
pushstack( { using } indentsymbol,
actualstartpos,
prevmargin );
END
END;
PROCEDURE lshift;
VAR
indentsymbol : keysymbol;
actualstartpos : INTEGER;
msg : symbol;
prevmargin : INTEGER;
BEGIN
IF NOT stackempty THEN BEGIN
popstack( { returning } indentsymbol,
actualstartpos,
prevmargin );
currmargin := prevmargin;
lastlinestartpos := 0;
thislinestartpos := 0
END
END;
PROCEDURE insertspace( { using } VAR symbol : symbolinfo
{ writing to output } );
BEGIN
IF currlinepos < maxlinesize THEN BEGIN
WRITE(OUTPUT,space);
currlinepos := currlinepos + 1;
WITH symbol^ DO
IF (crsbefore = 0) AND (spacesbefore > 0) THEN
spacesbefore := spacesbefore - 1
END
END;
PROCEDURE movelinepos( { to } newlinepos : INTEGER;
{ from } VAR currlinepos : INTEGER
{ writing to output } );
VAR
i : INTEGER;
BEGIN
FOR i := currlinepos+1 TO newlinepos DO
WRITE(OUTPUT, space);
currlinepos := newlinepos
END;
PROCEDURE printsymbol( { in } currsym : symbolinfo;
{ updating } VAR currlinepos : INTEGER
{ writing to output } );
VAR
i : INTEGER;
num : BOOLEAN;
extrakey : BOOLEAN;
string : BOOLEAN;
BEGIN
num := FALSE;
extrakey := FALSE;
string := FALSE;
WITH currsym^ DO BEGIN
CASE name OF
progsym:
WRITE(OUTPUT, keybefore);
labelsym:;
beginsym:
WRITE(OUTPUT, keybefore);
casesym:
WRITE(OUTPUT, keybefore);
forsym:
WRITE(OUTPUT, keybefore);
ifsym:
WRITE(OUTPUT, keybefore);
endsym:
WRITE(OUTPUT, keybefore);
becomes:;
semicolon:;
openparen:;
endoffile:;
othersym: BEGIN
IF valu[1] IN ['0'..'9'] THEN BEGIN
num := TRUE;
WRITE(OUTPUT, numbefore);
END
ELSE IF valu[1] = '''' THEN BEGIN
string := TRUE;
WRITE(OUTPUT, stringbefore);
END
END;
funcsym:
WRITE(OUTPUT, keybefore);
constsym:
WRITE(OUTPUT, keybefore);
repeatsym:
WRITE(OUTPUT, keybefore);
casevarsym:;
whilesym:
WRITE(OUTPUT, keybefore);
thensym:
WRITE(OUTPUT, keybefore);
forwardsym:
WRITE(OUTPUT, keybefore);
opencomment:;
colon:;
closeparen:;
procsym:
WRITE(OUTPUT, keybefore);
typesym:
WRITE(OUTPUT, keybefore);
recordsym:
WRITE(OUTPUT, keybefore);
ofsym:
WRITE(OUTPUT, keybefore);
withsym:
WRITE(OUTPUT, keybefore);
elsesym:
WRITE(OUTPUT, keybefore);
untilsym:
WRITE(OUTPUT, keybefore);
closecomment:
WRITE(OUTPUT, commentbefore);
coloncase:;
period:;
varsym:
WRITE(OUTPUT, keybefore);
dosym:
WRITE(OUTPUT, keybefore);
equals:;
OTHERWISE
END;
{ This is a SHORT-TERM hack to get something working. I think ideally }
{ these should be added to the keywords table and suitable options applied - }
{ probably the empty set options. }
IF (length = 2) AND (valu[1] IN ['i', 'I']) AND (valu[2] IN ['n', 'N']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 2) AND (valu[1] IN ['t', 'T']) AND (valu[2] IN ['o', 'O']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 2) AND (valu[1] IN ['o', 'O']) AND (valu[2] IN ['r', 'R']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 3) AND (valu[1] IN ['a', 'A']) AND (valu[2] IN ['n', 'N']) AND (valu[3]
IN ['d', 'D']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 3) AND (valu[1] IN ['n', 'N']) AND (valu[2] IN ['o', 'O']) AND (valu[3]
IN ['t', 'T']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 3) AND (valu[1] IN ['s', 'S']) AND (valu[2] IN ['e', 'E']) AND (valu[3]
IN ['t', 'T']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 4) AND
(valu[1] IN ['c', 'C']) AND
(valu[2] IN ['h', 'H']) AND
(valu[3] IN ['a', 'A']) AND
(valu[4] IN ['r', 'R']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 5) AND
(valu[1] IN ['a', 'A']) AND
(valu[2] IN ['r', 'R']) AND
(valu[3] IN ['r', 'R']) AND
(valu[4] IN ['a', 'A']) AND
(valu[5] IN ['y', 'Y']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 6) AND
(valu[1] IN ['p', 'P']) AND
(valu[2] IN ['a', 'A']) AND
(valu[3] IN ['c', 'C']) AND
(valu[4] IN ['k', 'K']) AND
(valu[5] IN ['e', 'E']) AND
(valu[6] IN ['d', 'D']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 7) AND
(valu[1] IN ['b', 'B']) AND
(valu[2] IN ['o', 'O']) AND
(valu[3] IN ['o', 'O']) AND
(valu[4] IN ['l', 'L']) AND
(valu[5] IN ['e', 'E']) AND
(valu[6] IN ['a', 'A']) AND
(valu[7] IN ['n', 'N']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
IF (length = 7) AND
(valu[1] IN ['i', 'I']) AND
(valu[2] IN ['n', 'N']) AND
(valu[3] IN ['t', 'T']) AND
(valu[4] IN ['e', 'E']) AND
(valu[5] IN ['g', 'G']) AND
(valu[6] IN ['e', 'E']) AND
(valu[7] IN ['r', 'R']) THEN BEGIN
extrakey := TRUE;
WRITE(OUTPUT, keybefore);
END;
FOR i := 1 TO length DO BEGIN
IF valu[i] = '<' THEN BEGIN
WRITE(OUTPUT, '<');
END
ELSE IF valu[i] = '>' THEN BEGIN
WRITE(OUTPUT, '>');
END
ELSE IF valu[i] = '&' THEN BEGIN
WRITE(OUTPUT, '&');
END
ELSE BEGIN
WRITE(OUTPUT, valu[i]);
END
END;
IF extrakey THEN
WRITE(OUTPUT, keyafter);
CASE name OF
progsym:
WRITE(OUTPUT, keyafter);
labelsym:;
beginsym:
WRITE(OUTPUT, keyafter);
casesym:
WRITE(OUTPUT, keyafter);
forsym:
WRITE(OUTPUT, keyafter);
ifsym:
WRITE(OUTPUT, keyafter);
endsym:
WRITE(OUTPUT, keyafter);
becomes:;
semicolon:;
openparen:;
endoffile:;
othersym: BEGIN
IF num THEN
WRITE(OUTPUT, numafter);
IF string THEN
WRITE(OUTPUT, stringafter);
END;
funcsym:
WRITE(OUTPUT, keyafter);
constsym:
WRITE(OUTPUT, keyafter);
repeatsym:
WRITE(OUTPUT, keyafter);
casevarsym:;
whilesym:
WRITE(OUTPUT, keyafter);
thensym:
WRITE(OUTPUT, keyafter);
forwardsym:
WRITE(OUTPUT, keyafter);
opencomment:;
colon:;
closeparen:;
procsym:
WRITE(OUTPUT, keyafter);
typesym:
WRITE(OUTPUT, keyafter);
recordsym:
WRITE(OUTPUT, keyafter);
ofsym:
WRITE(OUTPUT, keyafter);
withsym:
WRITE(OUTPUT, keyafter);
elsesym:
WRITE(OUTPUT, keyafter);
untilsym:
WRITE(OUTPUT, keyafter);
closecomment:
WRITE(OUTPUT, commentafter);
coloncase:;
period:;
varsym:
WRITE(OUTPUT, keyafter);
dosym:
WRITE(OUTPUT, keyafter);
equals:;
OTHERWISE
END;
startpos := currlinepos;
{ save start pos for tab purposes }
currlinepos := currlinepos + length
END
END;
PROCEDURE ppsymbol( { in } currsym : symbolinfo
{ writing to output } );
CONST
once = 1;
VAR
newlinepos : INTEGER;
BEGIN
WITH currsym^ DO BEGIN
writecrs( { using } crsbefore,
{ updating } currlinepos
{ writing to output } );
IF gobbling
AND (crsbefore > 0) THEN
newlinepos := gobblestart + (actualstartpos - gobbleoffset)
ELSE IF (currlinepos + spacesbefore > currmargin)
AND (crsbefore = 0) THEN
newlinepos := currlinepos + spacesbefore
ELSE
newlinepos := currmargin;
IF newlinepos + length > maxlinesize THEN BEGIN
writecrs( once, { updating } currlinepos
{ writing to output } );
IF currmargin + length <= maxlinesize THEN
newlinepos := currmargin
ELSE IF length <= maxlinesize THEN
newlinepos := maxlinesize - length
ELSE
newlinepos := 0
END;
movelinepos( { to } newlinepos,
{ from } currlinepos
{ in output } );
printsymbol( { in } currsym,
{ updating } currlinepos
{ writing to output } )
END
END;
PROCEDURE rshifttoclp( { using } csym : keysymbol );
FORWARD;
PROCEDURE gobble( { symbols from input }
{ up to } terminators : keysymset;
{ updating } VAR currsym,
nextsym : symbolinfo
{ writing to output } );
VAR
startsym : keysymbol;
BEGIN
startsym := currsym^.name;
gobbling := TRUE;
IF NOT (startsym IN [dosym]) THEN BEGIN
gobblestart := startpos;
gobbleoffset := currsym^.actualstartpos;
END
ELSE BEGIN
gobblestart := currmargin;
gobbleoffset := nextsym^.actualstartpos;
END;
WHILE NOT (nextsym^.name IN (terminators + [ endoffile ] )) DO BEGIN
getsymbol( { from input }
{ updating } nextsym,
{ returning } currsym );
ppsymbol ( { in } currsym
{ writing to output } )
END;
gobbling := FALSE;
END;
PROCEDURE rshift( { using } csym : keysymbol );
BEGIN
IF NOT stackfull THEN
pushstack( { using } csym,
currsym^.actualstartpos,
currmargin );
{ if extra indentation was used, update margin. }
{IF startpos > currmargin
THEN currmargin := startpos; }
IF currmargin < slofail1 THEN
currmargin := currmargin + indent1
ELSE IF currmargin < slofail2 THEN
currmargin := currmargin + indent2;
lastlinestartpos := nextsym^.actualstartpos;
thislinestartpos := 0
END;
PROCEDURE rshifttoclp;
BEGIN
IF NOT stackfull THEN
pushstack( { using } csym,
currsym^.actualstartpos,
currmargin);
currmargin := currlinepos;
lastlinestartpos := 0;
thislinestartpos := 0
END;
PROCEDURE markcurrentposition( { using } csym : keysymbol );
BEGIN
IF NOT stackfull THEN
pushstack( { using } csym,
currsym^.actualstartpos,
currmargin );
END;
PROCEDURE crifnot(sym : keysymset);
BEGIN
IF nextsym^.name IN sym THEN BEGIN
crpending := FALSE;
nextsym^.crsbefore := 0;
nextsym^.spacesbefore := 1
END
ELSE IF nextsym^.crsbefore = 0 THEN
nextsym^.crsbefore := 1
END;
BEGIN
initialise( top , currlinepos,
currmargin, keyword , dblchars , dblchar,
sglchar , recordseen , currchar , nextchar,
currsym , nextsym , ppoption );
crpending := FALSE;
indecsection := FALSE;
WRITE('<html><body bgcolor="FFFFFF"><pre>');
WHILE (nextsym^.name <> endoffile) DO BEGIN
getsymbol( { from input }
{ updating } nextsym,
{ returning } currsym );
IF currsym^.name IN [opencomment , closecomment] THEN
checkfordirective(currsym^.valu);
IF formattingrequired THEN
WITH ppoption [currsym^.name] DO BEGIN
IF currsym^.name IN [labelsym,constsym,typesym,varsym] THEN
indecsection := TRUE
ELSE IF (currsym^.name IN [beginsym , procsym , funcsym ]) AND indecsection
THEN BEGIN
indecsection := FALSE;
insertblankline(currsym);
crpending := FALSE;
END;
IF (crpending AND NOT (crsuppress IN optionsselected))
OR (crbefore IN optionsselected) THEN BEGIN
insertcr( { using } currsym
{ writing to output } );
crpending := FALSE;
END;
IF blanklinebefore IN optionsselected THEN BEGIN
insertblankline( { using } currsym
{ writing to output } );
crpending := FALSE
END;
IF crsuppress IN optionsselected THEN BEGIN
currsym^.crsbefore := 0;
currsym^.spacesbefore := 0;
END;
IF dindentonkeys IN optionsselected THEN
lshifton(dindentsymbols);
IF dindent IN optionsselected THEN
lshift;
IF firstindentbytab IN optionsselected THEN BEGIN
IF currsym^.name IN [thensym , elsesym] THEN
rshift ( { using } ifsym )
ELSE IF (currsym^.name IN [opencomment , closecomment])
AND (NOT indecsection) THEN
{ do nothing }
ELSE
rshift ( { using } currsym^.name );
END;
IF spacebefore IN optionsselected THEN
insertspace( { using } currsym
{ writing to output } );
ppsymbol( { in } currsym
{ writing to output } );
IF spaceafter IN optionsselected THEN
insertspace( { using } nextsym
{ writing to output } );
IF indentbytab IN optionsselected THEN BEGIN
IF (currsym^.name = elsesym) AND (nextsym^.name = ifsym) THEN
{ do nothing }
ELSE IF (currsym^.name = beginsym)
AND (stack[top].indentsymbol IN [dosym,coloncase,ifsym]) THEN BEGIN
lshift;
rshift(beginsym);
END
ELSE IF currsym^.name IN [thensym , elsesym] THEN
rshift ( { using } ifsym )
ELSE
rshift ( { using } currsym^.name );
END;
IF indenttoclp IN optionsselected THEN
rshifttoclp( { using } currsym^.name);
IF markposition IN optionsselected THEN
markcurrentposition( { using } currsym^.name);
IF crbeforegobble IN optionsselected THEN
crifnot([beginsym]);
IF gobblesymbols IN optionsselected THEN
gobble( { symbols from input }
{ up to } gobbleterminators,
{ updating } currsym,
nextsym
{ writing to output } );
IF dindentafter IN optionsselected THEN BEGIN
IF (currsym^.name IN [opencomment , closecomment])
AND (NOT indecsection) THEN
{ do nothing }
ELSE
lshift;
END;
IF crnotbegin IN optionsselected THEN
crifnot([beginsym]);
IF crnotiforbegin IN optionsselected THEN
crifnot([ifsym , beginsym]);
IF crafter IN optionsselected THEN BEGIN
IF (currsym^.name = endsym)
AND (nextsym^.name IN [opencomment,closecomment])
AND (nextsym^.crsbefore = 0) THEN
{ do nothing }
ELSE
crpending := TRUE;
END;
END
ELSE
ppsymbol(currsym);
END;
IF crpending THEN
WRITELN(OUTPUT);
WRITE('</pre></body></html>')
END.