ack/lang/m2/test/m2p.mod

MODULE Modula2PrettyPrinter;

FROM InOut IMPORT
	Done, Read, Write, WriteLn, WriteString, OpenInput, OpenOutput,
	CloseInput, CloseOutput;

(*
**      Modula-2 Prettyprinter, November 1985.
**
**      by Ken Yap, U of Rochester, CS Dept.
**
**      Permission to copy, modify, and distribute, but not for profit,
**      is hereby granted, provided that this note is included.
**
**      adapted from a Pascal Program Formatter
**      by J. E. Crider, Shell Oil Company,
**      Houston, Texas 77025
**
**      This program formats Modula-2 programs according
**      to structured formatting principles
**
**      A valid Modula-2 program is read from the input and
**      a formatted program is written to the output.
**      It is basically a recursive descent parser with actions
**      intermixed with syntax scanning.
**
**      The actions of the program are as follows:
**
**      FORMATTING:  Each structured statement is formatted
**      in the following pattern (with indentation "indent"):
**
**                XXXXXX header XXXXXXXX
**                        XXXXXXXXXXXXXXXXXX
**                        XXXXX body XXXXXX
**                        XXXXXXXXXXXXXXXXXX
**                END
**
**      where the header is one of:
**
**                IF <expression> THEN
**                ELSIF <expression> THEN
**                ELSE
**                WHILE <expression> DO
**                FOR <control variable> := <FOR list> DO
**                WITH <RECORD variable> DO
**                REPEAT
**                LOOP
**                CASE <expression> OF
**                <CASE label list>:
**
**      and the last line begins with UNTIL or is END.
**      Other program parts are formatted similarly.  The headers are:
**
**                <MODULE/PROCEDURE heading>;
**                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").
**
**      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 if one is not already there.
**
**      CONTINUATION:  Lines that are too long for an output line are
**      continued with additional indentation ("contindent").
*)

CONST
	TAB = 11C;
	NEWLINE = 12C;                  (* for Unix *)
	FF = 14C;
	maxrwlen = 15;                  (* size of reserved word strings *)
	ordminchar = 0;                 (* ord of lowest char in char set *)
	ordmaxchar = 127;               (* ord of highest char in char set *)
(* The following parameters may be adjusted for the installation: *)
	maxinlen = 255;                 (* maximum width of input line + 1 *)
	maxoutlen = 80;                 (* maximum width of output line *)
	tabinterval = 8;                (* interval between tab columns *)
	initmargin = 0;                 (* initial value of output margin *)
	commthresh = tabinterval;       (* column threshhold in input for
						comments to be aligned *)
	alcommbase = 40;                (* aligned comments in output start
						after this column *)
	indent = tabinterval;           (* RECOMMENDED indentation increment *)
	contindent = tabinterval;       (* continuation indentation, >indent *)
	commindent = tabinterval;       (* comment continuation indentation *)

TYPE
	natural = INTEGER[0..32767];
	inrange = INTEGER[0..maxinlen];
	outrange = INTEGER[0..maxoutlen];

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

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

	chartypeset = SET OF chartype;  (* 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, rwcase, rwtype, rwloop, rwfrom,
					(* length: 4 *)
	rwbegin, rwelsif, rwuntil, rwwhile, rwarray, rwconst,
					(* length: 5 *)
	rwrepeat, rwrecord, rwmodule, rwimport, rwexport,
					(* length: 6 *)
	rwpointer,                      (* length: 7 *)
	rwprocedure, rwqualified,       (* length: 9 *)
	rwdefinition,                   (* length: 10 *)
	rwimplementation,               (* length: 14 *)
	rwx);                           (* length: 15 for table sentinel *)
	rwstring =  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 *)

	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 : [-1..maxinlen];  (* inline.buf[base] precedes word *)
		size : inrange;
	END;                            (* length of word in inline.buf *)

	symboltype = (                  (* symbols for syntax analysis *)
	symodule, sydefinition, syimplementation, syfrom, syimport, syexport,
	syqual, syproc, declarator, sybegin, syend, syif, sythen, syelsif,
	syelse, syloop, sycase, syof, syuntil, syrepeat, forwhilewith, sydo,
	syrecord, ident, intconst, semicolon, leftparen, rightparen, period,
	colon, bar, othersym, otherword, comment, syeof);
	symbolset = SET OF symboltype;

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 *)
		buf : ARRAY [1..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;
	curword : wordtype;             (* current word *)
	margin : outrange;              (* left margin *)
	lnpending : BOOLEAN;            (* new line before next symbol? *)
	inheader : BOOLEAN;             (* are we scanning a proc header? *)
	symbol : symboltype;            (* current symbol *)

  (* Structured Constants *)
	headersyms : symbolset;         (* headers for program parts *)
	strucsyms : symbolset;          (* symbols that begin structured
						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 *)
	firstrw : ARRAY [1..maxrwlen] OF resword;
	rwword : ARRAY [rwif..rwimplementation] OF rwstring;
	rwsy : ARRAY [rwif..rwimplementation] OF symboltype;
	charclass : ARRAY CHAR OF chartype;
	symbolclass : ARRAY chartype OF symboltype;

PROCEDURE StrCmp(a, b : rwstring) : BOOLEAN;
VAR
	i : INTEGER;
BEGIN
	FOR i := 1 TO maxrwlen DO
		IF a[i] # b[i] THEN
			RETURN FALSE;
		END;
	END;
	RETURN TRUE;
END StrCmp;

PROCEDURE StructConsts;
(* establish values of structured constants *)
VAR
	i : [ordminchar..ordmaxchar];   (* loop index *)
	ch : CHAR;                      (* loop index *)

PROCEDURE BuildResWord(rw : resword; symword : rwstring; symbol : symboltype);
BEGIN
	rwword[rw] := symword;          (* reserved word string *)
	rwsy[rw] := symbol;             (* map to symbol *)
END BuildResWord;

BEGIN                                   (* StructConsts *)
(* symbol sets for syntax analysis *)
	headersyms := symbolset{symodule, syproc, declarator, sybegin, syend,
	syeof};
	strucsyms := symbolset{sycase, syrepeat, syif, forwhilewith, syloop};
	stmtendsyms := symbolset{semicolon, bar, syend, syuntil, syelsif,
	syelse, syeof};
	stopsyms := headersyms + strucsyms + stmtendsyms;
	recendsyms := symbolset{rightparen, syend, syeof};
	datawords := symbolset{otherword, intconst, ident, syend};

(* constants for recognizing reserved words *)
	firstrw[1] := rwif;             (* length: 1 *)
	firstrw[2] := rwif;             (* length: 2 *)
	BuildResWord(rwif, 'IF             ', syif);
	BuildResWord(rwdo, 'DO             ', sydo);
	BuildResWord(rwof, 'OF             ', syof);
	BuildResWord(rwto, 'TO             ', othersym);
	BuildResWord(rwin, 'IN             ', othersym);
	BuildResWord(rwor, 'OR             ', othersym);
	firstrw[3] := rwend;            (* length: 3 *)
	BuildResWord(rwend, 'END            ', syend);
	BuildResWord(rwfor, 'FOR            ', forwhilewith);
	BuildResWord(rwvar, 'VAR            ', declarator);
	BuildResWord(rwdiv, 'DIV            ', othersym);
	BuildResWord(rwmod, 'MOD            ', othersym);
	BuildResWord(rwset, 'SET            ', othersym);
	BuildResWord(rwand, 'AND            ', othersym);
	BuildResWord(rwnot, 'NOT            ', othersym);
	BuildResWord(rwnil, 'NIL            ', otherword);
	firstrw[4] := rwthen;           (* length: 4 *)
	BuildResWord(rwthen, 'THEN           ', sythen);
	BuildResWord(rwelse, 'ELSE           ', syelse);
	BuildResWord(rwwith, 'WITH           ', forwhilewith);
	BuildResWord(rwloop, 'LOOP           ', syloop);
	BuildResWord(rwfrom, 'FROM           ', syfrom);
	BuildResWord(rwcase, 'CASE           ', sycase);
	BuildResWord(rwtype, 'TYPE           ', declarator);
	firstrw[5] := rwbegin;          (* length: 5 *)
	BuildResWord(rwbegin, 'BEGIN          ', sybegin);
	BuildResWord(rwelsif, 'ELSIF          ', syelsif);
	BuildResWord(rwuntil, 'UNTIL          ', syuntil);
	BuildResWord(rwwhile, 'WHILE          ', forwhilewith);
	BuildResWord(rwarray, 'ARRAY          ', othersym);
	BuildResWord(rwconst, 'CONST          ', declarator);
	firstrw[6] := rwrepeat;         (* length: 6 *)
	BuildResWord(rwrepeat, 'REPEAT         ', syrepeat);
	BuildResWord(rwrecord, 'RECORD         ', syrecord);
	BuildResWord(rwmodule, 'MODULE         ', symodule);
	BuildResWord(rwimport, 'IMPORT         ', syimport);
	BuildResWord(rwexport, 'EXPORT         ', syexport);
	firstrw[7] := rwpointer;        (* length: 7 *)
	BuildResWord(rwpointer, 'POINTER        ', othersym);
	firstrw[8] := rwprocedure;      (* length: 8 *)
	firstrw[9] := rwprocedure;      (* length: 9 *)
	BuildResWord(rwprocedure, 'PROCEDURE      ', syproc);
	BuildResWord(rwqualified, 'QUALIFIED      ', syqual);
	firstrw[10] := rwdefinition;    (* length: 10 *)
	BuildResWord(rwdefinition, 'DEFINITION     ', sydefinition);
	firstrw[11] := rwimplementation;(* length: 11 *)
	firstrw[12] := rwimplementation;(* length: 12 *)
	firstrw[13] := rwimplementation;(* length: 13 *)
	firstrw[14] := rwimplementation;(* length: 14 *)
	BuildResWord(rwimplementation, 'IMPLEMENTATION ', syimplementation);
	firstrw[15] := rwx;             (* length: 15 FOR table sentinel *)

(* constants for lexical scan *)
	FOR i := ordminchar TO ordmaxchar DO
		charclass[CHR(i)] := illegal;
	END;
	FOR ch := 'a' TO 'z' DO
		charclass[ch] := letter;
		charclass[CAP(ch)] := letter;
	END;
	FOR ch := '0' TO '9' DO
		charclass[ch] := digit;
	END;
	charclass[' '] := special;
	charclass['"'] := chapostrophe;
	charclass['#'] := special;
	charclass['&'] := special;
	charclass["'"] := chapostrophe;
	charclass['('] := chleftparen;
	charclass[')'] := chrightparen;
	charclass['*'] := special;
	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['{'] := special;
	charclass['|'] := chbar;
	charclass['}'] := special;
	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[chbar] := bar;
	symbolclass[letter] := ident;
END StructConsts;

(* FlushLine/WriteError/ReadLine convert between files and lines. *)

PROCEDURE FlushLine;
(* Write buffer into output file *)
VAR
	i, j, vircol : outrange;        (* loop index *)
	nonblankseen : BOOLEAN;
BEGIN
	WITH outline DO
		WHILE blanklns > 0 DO
			WriteLn;
			blanklns := blanklns - 1;
		END;
		IF len > 0 THEN
			vircol := 0;
			nonblankseen := FALSE;
					(* set this to TRUE if you don't want
						blanks to tab conversion *)
			FOR i := 0 TO len - 1 DO
				IF buf[i+1] <> ' ' THEN
					IF NOT nonblankseen THEN
						LOOP
							j := (vircol DIV
							tabinterval + 1) *
							tabinterval;
							IF j > i THEN
								EXIT;
							END;
							Write(TAB);
							vircol := j;
						END;
					END;
					nonblankseen := TRUE;
					WHILE vircol < i DO
						Write(' ');
						vircol := vircol + 1;
					END;
					Write(buf[i+1]);
					vircol := i + 1;
				END;
			END;
			WriteLn;
			len := 0;
		END;
	END;
END FlushLine;

PROCEDURE WriteError(error : errortype; nm : ARRAY OF CHAR);
(* report error to output *)
VAR
	i, ix : inrange;                (* loop index, limit *)
BEGIN
	FlushLine;
	WriteString('(* !!! error, ');
	WriteString(nm);
	CASE error OF
	longline:
		WriteString('shorter line');
	| noendcomm:
		WriteString('END OF comment');
	| notquote:
		WriteString("final ' on line");
	| longword:
		WriteString('shorter word');
	| notdo:
		WriteString('"DO"');
	| notof:
		WriteString('"OF"');
	| notend:
		WriteString('"END"');
	| notthen:
		WriteString('"THEN"');
	| notbegin:
		WriteString('"BEGIN"');
	| notuntil:
		WriteString('"UNTIL"');
	| notident:
		WriteString('"identifier"');
	| notsemicolon:
		WriteString('";"');
	| notperiod:
		WriteString('"."');
	| notcolon:
		WriteString('":"');
	| notparen:
		WriteString('")"');
	| noeof:
		WriteString('END OF file');
	END;
	WriteString(' expected');
	IF error >= longword THEN
		WriteString(', NOT "');
		WITH inline DO
			WITH curword DO
				IF size > maxrwlen THEN
					ix := maxrwlen
				ELSE
					ix := size;
				END;
				FOR i := 1 TO ix DO
					Write(buf[base + i]);
				END;
			END;
		END;
		Write('"');
	END;
	IF error = noeof THEN
		WriteString(', FORMATTING STOPS');
	END;
	WriteString(' !!! *)');
	WriteLn;
END WriteError;

PROCEDURE ReadLine;
(* Read line into input buffer *)
VAR
	c : CHAR;                       (* input character *)
BEGIN
	WITH inline DO
		len := 0;
		LOOP
			Read(c);
			IF NOT Done THEN
				endoffile := TRUE;
				EXIT;
			END;
			IF c = NEWLINE THEN
				EXIT;
			END;
			IF c < ' ' THEN (* convert ISO control chars (except
						leading form feed) to spaces *)
				IF c = TAB THEN
					(* ISO TAB char *)
					c := ' ';
					(* add last space at end *)
					WHILE len MOD 8 <> 7 DO
						len := len + 1;
						IF len < maxinlen THEN
							buf[len] := c;
						END;
					END;
					(* END tab handling *)
				ELSIF (c <> FF) OR (len > 0) THEN
					c := ' ';
				END;
			END;            (* END ISO control char conversion *)
			len := len + 1;
			IF len < maxinlen THEN
				buf[len] := c;
			END;
		END;
		IF NOT endoffile THEN
			IF len >= maxinlen THEN
					(* input line too long *)
				WriteError(longline, "(ReadLine), ");
				len := maxinlen - 1;
			END;
			WHILE (len > 0) AND (buf[len] = ' ') DO
				len := len - 1;
			END;
		END;
		len := len + 1;         (* add exactly ONE trailing blank *)
		buf[len] := ' ';
		index := 0;
	END;
END ReadLine;

PROCEDURE GetChar;
(* get next char from input buffer *)
BEGIN
	WITH inline DO
		index := index + 1;
		ch := buf[index];
	END;
END GetChar;

PROCEDURE NextChar() : CHAR;
(* look at next char in input buffer *)
BEGIN
	RETURN inline.buf[inline.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 DO
		WITH curword DO
			whenfirst := startclass;
			blanklncount := 0;
			WHILE (index >= len) AND NOT endoffile DO
				IF len = 1 THEN
					blanklncount := blanklncount + 1;
				END;
				IF startclass = contuncomm THEN
					FlushLine
				ELSE
					first := TRUE;
				END;
				ReadLine;
					(* with exactly ONE trailing blank *)
				GetChar;
				IF ch = FF THEN
					FlushLine;
					Write(FF);
					blanklncount := 0;
					GetChar;
				END;
			END;
			spaces := 0;    (* count leading spaces *)
			IF NOT endoffile THEN
				WHILE ch = ' ' DO
					spaces := spaces + 1;
					GetChar;
				END;
			END;
			IF first THEN
				spaces := 1;
			END;
			base := index - 1;
		END;
	END;
END StartWord;

PROCEDURE FinishWord;
(* note end of word *)
BEGIN
	WITH inline DO
		WITH curword DO
			puncfollows := (symbol IN datawords) AND (ch <> ' ');
			size := index - base - 1;
		END;
	END;
END FinishWord;

PROCEDURE CopyWord(newline : BOOLEAN; pword : wordtype);
(* copy word from input buffer into output buffer *)
VAR
	i : INTEGER;                    (* outline.len excess, loop index *)
BEGIN
	WITH pword DO
		WITH outline DO
			i := maxoutlen - len - spaces - size;
			IF newline OR (i < 0) OR ((i = 0) AND puncfollows) THEN
				FlushLine;
			END;
			IF len = 0 THEN (* first word on output line *)
				blanklns := blanklncount;
				CASE whenfirst OF
					(* update LOCAL word.spaces *)
				newclause:
					spaces := margin;
				| continue:
					spaces := margin;
				| alcomm:
					spaces := alcommbase;
				| contalcomm:
					spaces := alcommbase + commindent;
				| uncomm:
					spaces := base;
				| contuncomm:
					(* spaces := spaces *);
				END;
				IF spaces + size > maxoutlen THEN
					spaces := maxoutlen - size;
					(* reduce spaces *)
					IF spaces < 0 THEN
						WriteError(longword,
						"(CopyWord), ");
						size := maxoutlen;
						spaces := 0;
					END;
				END;
			END;
			FOR i := 1 TO spaces DO
					(* put out spaces *)
				len := len + 1;
				buf[len] := ' ';
			END;
			FOR i := 1 TO size DO
					(* copy actual word *)
				len := len + 1;
				buf[len] := inline.buf[base + i];
			END;
		END;
	END;
END CopyWord;

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 curword DO                 (* copy comment begin symbol *)
		whenfirst := commclass;
		spaces := commbase - outline.len;
		CopyWord((spaces < 0) OR (blanklncount > 0), curword);
	END;
	commclass := VAL(firstclass, ORD(commclass)+1);
	WITH inline DO
		REPEAT                  (* loop for successive words *)
			StartWord(commclass);
			endcomment := endoffile;
					(* premature end? *)
			IF endcomment THEN
				WriteError(noendcomm, "(CopyComment), ")
			ELSE
				REPEAT
					IF ch = '*' THEN
						GetChar;
						IF ch = ')' THEN
							endcomment := TRUE;
							GetChar;
						END;
					ELSE
						GetChar;
					END;
				UNTIL (ch = ' ') OR endcomment;
			END;
			FinishWord;
			CopyWord(FALSE, curword)
		UNTIL endcomment;
	END;
END CopyComment;

BEGIN                                   (* DoComment *)
	IF curword.base < commthresh THEN
					(* copy comment without alignment *)
		CopyComment(uncomm, curword.base)
	ELSE                            (* align AND format comment *)
		CopyComment(alcomm, alcommbase);
	END;
END DoComment;

PROCEDURE GetSymbol;
(* get next non-comment symbol *)

PROCEDURE CopySymbol(symbol : symboltype; pword : wordtype);
(* copy word(s) of symbol *)
BEGIN
	IF symbol = comment THEN
		DoComment;              (* NOTE: DoComment uses global word! *)
		lnpending := TRUE;
	ELSIF symbol = semicolon THEN
		CopyWord(FALSE, pword);
		lnpending := NOT inheader;
	ELSE
		CopyWord(lnpending, pword);
		lnpending := FALSE;
	END;
END CopySymbol;

PROCEDURE FindSymbol;
(* find next symbol in input buffer *)

VAR
	termch : CHAR;                  (* string terminator *)
	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 curword DO
		WITH inline DO
			size := index - base - 1;
			IF size < maxrwlen THEN
				symword := '               ';
				FOR i := 1 TO size DO
					symword[i] := CAP(buf[ base + i]);
				END;
				rw := firstrw[size];
				rwbeyond := firstrw[size + 1];
				symbol := semicolon;
				REPEAT
					IF rw >= rwbeyond THEN
						symbol := ident
					ELSIF StrCmp(symword, rwword[rw]) THEN
						symbol := rwsy[rw]
					ELSE
						rw := VAL(resword,ORD(rw)+1);
					END;
				UNTIL symbol <> semicolon;
			END;
			whenfirst := newclause;
		END;
	END;
END CheckResWord;

PROCEDURE GetName;
BEGIN
	WHILE charclass[inline.ch] IN chartypeset{letter, digit} DO
		GetChar;
	END;
	CheckResWord;
END GetName;

PROCEDURE GetNumber;
BEGIN
	WITH inline DO
		WHILE charclass[ch] = digit DO
			GetChar;
		END;
		IF ch = '.' THEN
			IF charclass[NextChar()] = digit THEN
					(* NOTE: NextChar is a function! *)
				symbol := otherword;
				GetChar;
				WHILE charclass[ch] = digit DO
					GetChar;
				END;
			END;
		END;
		IF CAP(ch) = 'E' THEN
			symbol := otherword;
			GetChar;
			IF (ch = '+') OR (ch = '-') THEN
				GetChar;
			END;
			WHILE charclass[ch] = digit DO
				GetChar;
			END;
		END;
	END;
END GetNumber;

PROCEDURE GetStringLiteral;
VAR
	endstring : BOOLEAN;            (* end of string literal? *)
BEGIN
	WITH inline DO
		endstring := FALSE;
		REPEAT
			GetChar;
			IF ch = termch THEN
				endstring := TRUE;
			ELSIF index >= len THEN
					(* error, final "'" not on line *)
				WriteError(notquote, "(GetStringLiteral), ");
				symbol := syeof;
				endstring := TRUE;
			END;
		UNTIL endstring;
		GetChar;
	END;
END GetStringLiteral;

BEGIN                                   (* FindSymbol *)
	StartWord(continue);
	WITH inline DO
		IF endoffile THEN
			symbol := syeof
		ELSE
			termch := ch;   (* save for string literal routine *)
			chclass := charclass[ch];
			symbol := symbolclass[chclass];
			GetChar;        (* second CHAR *)
			CASE chclass OF
			chsemicolon, chrightparen, chleftbrace, special,
			illegal: ;
			| letter:
				GetName;
			| digit:
				GetNumber;
			| chapostrophe:
				GetStringLiteral;
			| chcolon:
				IF ch = '=' THEN
					symbol := othersym;
					GetChar;
				END;
			| chlessthan:
				IF (ch = '=') OR (ch = '>') THEN
					GetChar;
				END;
			| chgreaterthan:
				IF ch = '=' THEN
					GetChar;
				END;
			| chleftparen:
				IF ch = '*' THEN
					symbol := comment;
					GetChar;
				END;
			| chperiod:
				IF ch = '.' THEN
					symbol := colon;
					GetChar;
				END;    (* Added by me (CJ):  *)
			ELSE
			END;
			FinishWord;
		END;
	END;                            (* FindSymbol *)
END FindSymbol;

BEGIN                                   (* GetSymbol *)
	REPEAT
		CopySymbol(symbol, curword);
					(* copy word for symbol to output *)
		FindSymbol              (* get next symbol *)
	UNTIL symbol <> comment;
END GetSymbol;

PROCEDURE StartClause;
(* (this may be a simple clause, or the start of a header) *)
BEGIN
	curword.whenfirst := newclause;
	lnpending := TRUE;
END StartClause;

PROCEDURE PassSemicolons;
(* pass consecutive semicolons *)
BEGIN
	WHILE symbol = semicolon DO
		GetSymbol;
		StartClause;
	END;
END PassSemicolons;

PROCEDURE StartBody;
(* finish header, start body of structure *)
BEGIN
	StartClause;
	margin := margin + indent;
END StartBody;

PROCEDURE FinishBody;
(* retract margin *)
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
		endsyms := stopsyms;
		INCL(endsyms, finalsymbol);
		REPEAT
			GetSymbol
		UNTIL symbol IN endsyms;
	END;
END PassPhrase;

PROCEDURE Expect(expectedsym : symboltype; error : errortype; syms : symbolset;
nm : ARRAY OF CHAR);
(* fail if current symbol is not the expected one, then recover *)
BEGIN
	IF symbol = expectedsym THEN
		GetSymbol
	ELSE
		WriteError(error, nm);
		INCL(syms, expectedsym);
		WHILE NOT (symbol IN syms) DO
			GetSymbol;
		END;
		IF symbol = expectedsym THEN
			GetSymbol;
		END;
	END;
END Expect;

PROCEDURE Heading;
(* process heading for program or procedure *)

PROCEDURE MatchParens;                  (* process parentheses in heading *)
VAR
	endsyms : symbolset;
BEGIN
	GetSymbol;
	WHILE NOT (symbol IN recendsyms) DO
		IF symbol = leftparen THEN
			MatchParens
		ELSE
			GetSymbol;
		END;
	END;
	endsyms := stopsyms + recendsyms;
	Expect(rightparen, notparen, endsyms, "(MatchParens), ");
END MatchParens;

BEGIN                                   (* heading *)
	GetSymbol;
	PassPhrase(leftparen);
	IF symbol = leftparen THEN
		inheader := TRUE;
		MatchParens;
		inheader := FALSE;
	END;
	IF symbol = colon THEN
		PassPhrase(semicolon);
	END;
	Expect(semicolon, notsemicolon, stopsyms, "(Heading), ");

END Heading;

PROCEDURE DoRecord;
(* process record declaration *)
BEGIN
	GetSymbol;
	StartBody;
	PassFields(FALSE);
	FinishBody;
	Expect(syend, notend, recendsyms, "(DoRecord), ");
END DoRecord;

PROCEDURE DoVariant;
(* process (case) variant part *)
BEGIN
	PassPhrase(syof);
	Expect(syof, notof, stopsyms, "(Dovariant), ");
	StartBody;
	PassFields(TRUE);
	FinishBody;
END DoVariant;

PROCEDURE DoParens(forvariant : BOOLEAN);
(* process parentheses in record *)
BEGIN
	GetSymbol;
	IF forvariant THEN
		StartBody;
	END;
	PassFields(FALSE);
	lnpending := FALSE;             (* for empty field list *)
	Expect(rightparen, notparen, recendsyms, "(DoParens), ");
	IF forvariant THEN
		FinishBody;
	END;
END DoParens;

PROCEDURE PassFields(forvariant : BOOLEAN);
(* process declarations *)
BEGIN
	WHILE NOT (symbol IN recendsyms) DO
		IF symbol = semicolon THEN
			PassSemicolons
		ELSIF symbol = syrecord THEN
			DoRecord
		ELSIF symbol = sycase THEN
			DoVariant
		ELSIF symbol = leftparen THEN
			DoParens(forvariant)
		ELSE
			GetSymbol;
		END;
	END;
END PassFields;

PROCEDURE Statement;
(* process statement *)
BEGIN
	CASE symbol OF
	sycase:
		CaseStatement;
		Expect(syend, notend, stmtendsyms, "(Case), ");
	| syif:
		IfStatement;
		Expect(syend, notend, stmtendsyms, "(If), ");
	| syloop:
		LoopStatement;
		Expect(syend, notend, stmtendsyms, "(Loop), ");
	| syrepeat:
		RepeatStatement;
	| forwhilewith:
		ForWhileWithStatement;
		Expect(syend, notend, stmtendsyms, "(ForWhileWith), ");
	| ident:
		AssignmentProccall;
	| semicolon: ;                  (*!!! Added by me (CJ) *)
	ELSE ;
	END;
END Statement;

PROCEDURE AssignmentProccall;
(* pass an assignment statement or procedure call *)
BEGIN
	WHILE NOT (symbol IN stmtendsyms) DO
		GetSymbol;
	END;
END AssignmentProccall;

PROCEDURE StatementSequence;
(* process sequence of statements *)
BEGIN
	Statement;
	LOOP
		IF symbol <> semicolon THEN
			EXIT;
		END;
		GetSymbol;
		Statement;
	END;
END StatementSequence;

PROCEDURE IfStatement;
(* process if statement *)
BEGIN
	PassPhrase(sythen);
	Expect(sythen, notthen, stopsyms, "(Ifstatement), ");
	StartBody;
	StatementSequence;
	FinishBody;
	WHILE symbol = syelsif DO
		StartClause;
		PassPhrase(sythen);
		Expect(sythen, notthen, stopsyms, "(Elseif), ");
		StartBody;              (* new line after 'THEN' *)
		StatementSequence;
		FinishBody;
	END;
	IF symbol = syelse THEN
		StartClause;
		GetSymbol;
		StartBody;              (* new line after 'ELSE' *)
		StatementSequence;
		FinishBody;
	END;
END IfStatement;

PROCEDURE CaseStatement;
(* process case statement *)
BEGIN
	PassPhrase(syof);
	Expect(syof, notof, stopsyms, "(caseStatement), ");
	StartClause;
	OneCase;
	WHILE symbol = bar DO
		GetSymbol;
		OneCase;
	END;
	IF symbol = syelse THEN
		GetSymbol;
		StartBody;
		StatementSequence;
		FinishBody;
	END;
END CaseStatement;

PROCEDURE OneCase;
(* process one case clause *)
BEGIN
	IF NOT (symbol IN symbolset{bar, syelse}) THEN
		PassPhrase(colon);
		Expect(colon, notcolon, stopsyms, "(OneCase), ");
		StartBody;              (* new line, indent after colon *)
		StatementSequence;
		FinishBody;             (* left-indent after case *)
	END;
END OneCase;

PROCEDURE RepeatStatement;
(* process repeat statement *)
BEGIN
	GetSymbol;
	StartBody;                      (* new line, indent after 'REPEAT' *)
	StatementSequence;
	FinishBody;                     (* left-ident after UNTIL *)
	StartClause;                    (* new line before UNTIL *)
	Expect(syuntil, notuntil, stmtendsyms, "(repeatstatement), ");
	PassPhrase(semicolon);
END RepeatStatement;

PROCEDURE LoopStatement;
(* process loop statement *)
BEGIN
	GetSymbol;
	StartBody;                      (* new line, indent after LOOP *)
	StatementSequence;
	FinishBody;                     (* left-ident before END *)
END LoopStatement;

PROCEDURE ForWhileWithStatement;
(* process for, while, or with statement *)
BEGIN
	PassPhrase(sydo);
	Expect(sydo, notdo, stopsyms, "(ForWhileWithstatement), ");
	StartBody;
	StatementSequence;
	FinishBody;
END ForWhileWithStatement;

PROCEDURE ProcedureDeclaration;
(* pass a procedure declaration *)
BEGIN
	ProcedureHeading;
	Block;
	Expect(ident, notident, stmtendsyms, "(Proceduredeclaration)1, ");
	Expect(semicolon, notsemicolon, stmtendsyms,
	"(Proceduredeclaration)2, ");
END ProcedureDeclaration;

PROCEDURE ProcedureHeading;
BEGIN
	StartClause;
	Heading;
END ProcedureHeading;

PROCEDURE Block;
BEGIN
	WHILE symbol IN symbolset{declarator, symodule, syproc} DO
		Declaration;
	END;
	IF symbol = sybegin THEN
		GetSymbol;
		StartBody;
		StatementSequence;
		FinishBody;
	END;
	Expect(syend, notend, stmtendsyms, "(Block), ");
END Block;

PROCEDURE Declaration;
BEGIN
	IF symbol = declarator THEN
		StartClause;            (* CONST, TYPE, VAR *)
		GetSymbol;
		StartBody;
		REPEAT
			PassPhrase(syrecord);
			IF symbol = syrecord THEN
				DoRecord;
			END;
			IF symbol = semicolon THEN
				PassSemicolons;
			END;
		UNTIL symbol IN headersyms;
		FinishBody;
	ELSIF symbol = symodule THEN
		ModuleDeclaration;
	ELSIF symbol = syproc THEN
		ProcedureDeclaration;
	END;
END Declaration;

PROCEDURE ModuleDeclaration;
BEGIN
	PassPhrase(semicolon);
	PassSemicolons;
	WHILE symbol IN symbolset{syimport, syexport, syfrom} DO
		ImportExport;
	END;
	Block;
	Expect(ident, notident, stmtendsyms, "(ModuleDeclaration), ");
END ModuleDeclaration;

PROCEDURE ImportExport;
BEGIN
	IF symbol = syfrom THEN
		PassPhrase(syimport);
	END;
	IF symbol = syimport THEN
		GetSymbol;
	ELSIF symbol = syexport THEN
		GetSymbol;
		IF symbol = syqual THEN
			GetSymbol;
		END;
	END;
	StartBody;
	PassPhrase(semicolon);
	FinishBody;
	GetSymbol;
END ImportExport;

PROCEDURE OneDefinition;
BEGIN
	IF symbol = declarator THEN
		Declaration;
	ELSIF symbol = syproc THEN
		ProcedureHeading;
	END;
END OneDefinition;

PROCEDURE DefinitionModule;
BEGIN
	GetSymbol;
	PassPhrase(semicolon);
	GetSymbol;
	WHILE symbol IN symbolset{syimport, syexport, syfrom} DO
		ImportExport;
	END;
	WHILE symbol IN symbolset{declarator, syproc} DO
		OneDefinition;
	END;
	Expect(syend, notend, stmtendsyms, "DefinitionModule1, " );
	GetSymbol;
	Expect(period, notperiod, stmtendsyms, 'DefintionModule2, ');
END DefinitionModule;

PROCEDURE ProgramModule;
BEGIN
	ModuleDeclaration;
	Expect(period, notperiod, stmtendsyms, "ProgramModule, ");
END ProgramModule;

PROCEDURE CompilationUnit;
BEGIN
	IF symbol = syimplementation THEN
		GetSymbol;
		ProgramModule;
	ELSIF symbol = sydefinition THEN
		DefinitionModule;
	ELSE
		ProgramModule;
	END;
END CompilationUnit;

PROCEDURE CopyRemainder;
(* copy remainder of input *)
BEGIN
	WriteError(noeof, "(Copyremainder), ");
	WITH inline DO
		REPEAT
			CopyWord(FALSE, curword);
			StartWord(contuncomm);
			IF NOT endoffile THEN
				REPEAT
					GetChar
				UNTIL ch = ' ';
			END;
			FinishWord;
		UNTIL endoffile;
	END;
END CopyRemainder;

PROCEDURE Initialize;
(* initialize global variables *)
BEGIN
	WITH inline DO
		endoffile := FALSE;
		ch := ' ';
		index := 0;
		len := 0;
	END;
	WITH outline DO
		blanklns := 0;
		len := 0;
	END;
	WITH curword DO
		whenfirst := contuncomm;
		puncfollows := FALSE;
		blanklncount := 0;
		spaces := 0;
		base := 0;
		size := 0;
	END;
	margin := initmargin;
	lnpending := FALSE;
	symbol := othersym;
END Initialize;

BEGIN
	StructConsts;
	Initialize;
(* Files may be opened here. *)
	OpenInput("mod");
	OpenOutput("mod");
	GetSymbol;
	CompilationUnit;
	IF NOT inline.endoffile THEN
		CopyRemainder;
	END;
	FlushLine;
	CloseInput;
	CloseOutput;
END Modula2PrettyPrinter.