{[b+,a+]} { NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE: Copyright 1980, 1981, 1982 by Oregon Software, Inc. All Rights Reserved. Whether this program is copied in whole or in part and whether this program is copied in original or in modified form, ALL COPIES OF THIS PROGRAM MUST DISPLAY THIS NOTICE OF COPYRIGHT AND OWNERSHIP IN FULL. Pascal source code formatter. Release version: 2.0K Level: 4 Date: 15-Jan-1982 10:29:38 Processor: PDP11 } {------------------------------------* | PASMAT: PAScal source code forMAT | *-----------------------------------*} program Pasmat(Input, Output, Source, Result); {PASMAT: A Pascal Text Formatter. Pasmat is a program which formats a Pascal program (or fragment) according to standardized formatting rules. It also converts the case of the identifiers and reserved words to your specification. A series of directives allow control over various aspects of the formatting. Many of these are the result of strong differences of opinion amoung potential users of the formatter. Anyone studying this program should have a copy of the Pasmat users manual. The program was originally written by W. D. Thompson, who hashed it badly, and has been re-written piecemeal by M. S. Ball. Almost the only remaining signs of Thompson are in the input lexical analyzer and some mild awkwardnesses in organization and layout. The formatter does an (almost) complete syntactic check of the program as it formats, and if it gets confused as to where it is, aborts and does not create an output element. This avoids a problem which the previous formatter had of losing track of its parsing and producing complete garbage as an output element. This would sometimes get substituted for the original element, and made recovery very difficult. The extra checking costs a bit of time and code space, but seems worth it overall. It also allows a very flexible formatting policy. There is a delayed output buffer to allow conditional modification of formatting decisions. This allows the user to make tentative decisions and modify them later. For instance, the user can note potential break points in a line and go back and use them when the line fills. This facility is also used to allow short statements to follow case labels directly. The statement is put on the next line, then if it would have fit can be moved back up to the line with the label. Comments are always difficult to handle in a Pascal formatter, and pasmat attempts to handle them in a way which provides the user with some control of their formatting. The comment handling is completly separate from the normal formatting, and can be changed without affecting other areas. History: Original version perpetrated by W. D. Thompson 18 Oct 78 Rewritten by M. S. Ball, 18 Oct 79, to make a system which people would be willing to use. Modified by M. S. Ball in Oct 80 to run using OMSI Pascal-2, and to process code for that compiler. The "K", "N", and "A" directives were added at this time. For further data or bug reports: M. S. Ball Oregon Software 2340 SW Canyon RD. Portland, OR 97201 (503)226-7760 Version 2.0K-4, created on 15-Jan-1982 at 10:29:38 } {*----------------------* | Labels and Constants | *----------------------*} label 99; const TitleHeader = 'PASMAT r3.0'; {release.version} {revised 13 Feb 81} MaxLineLen = 132; {max output line length} Bufsize = 134; {output buffer size, > max_line_len} BufsizeP1 = 135; {buffer size +- 1} BufsizeM1 = 133; MaxWordLen = 9; {reserved words char size} NoResWords = 41; {number of reserved words} DefaultOutLine = 78; {default output line length} DefaultTabSpaces = 2; {logical indentation increments} DefaultCommentSpaces = 1; {spacing before and after comments} MaxBreakLevel = 4; {max number of break levels} Ff = 14B; {ascii form feed character} Ht = 11B; {ascii tab character} {identifier spelling constants} HashMax = 64; {size of hash table} HashLim = 63; {top entry in hash table} StringBlockSize = 512; {size of a block of the string table} StringBlockMax = 511; {max entry in a string block} StringIndexMax = 63; {max entry in the string index} {Operating System Constants} filenamelength = 60; {max length of a file name for your system} %include OSCONF {Specifies RSTS, RSX, or, RT11 configuration} rsxprompt = 'PMT>'; {prompt to use if on RSX system} cmdlinelength = 132; { length of a command line } TabInterval = 8; {DEC standard tab interval} {*-------* | Types | *-------*} type Symbols = (AndSy, ArraySy, BeginSy, CaseSy, ConstSy, DivSy, DoSy, DowntoSy, ElseSy, EndSy, ExternSy, FileSy, ForSy, FortranSy, ForwardSy, FunctionSy, GotoSy, IfSy, InSy, LabelSy, ModSy, NilSy, NonpascalSy, NotSy, OfSy, OrSy, OriginSy, OtherwiseSy, PackedSy, ProcedureSy, ProgramSy, RecordSy, RepeatSy, SetSy, ThenSy, ToSy, TypeSy, UntilSy, VarSy, WhileSy, WithSy, Plus, Minus, Mult, Divide, Becomes, Period, Comma, Semicolon, Colon, Equal, RelOp, Pointer, Subrange, Apostrophy, OpenParen, CloseParen, OpenBrack, CloseBrack, Identifier, Number, String, Comment, TextEnd); {basic symbol enumeration} SetOfSyms = set of Symbols; {set ops on basic symbols} StringType = packed array [1..12] of Char; {identifier type for sirtag} WordType = packed array [1..MaxWordLen] of Char; {reserved} LenTableType = {index into reserved word table by length} record LowIndex, HiIndex: 1..NoResWords; end; LineIndex = 0..MaxLineLen; Actions = (Graphic, Spaces, BeginLine); BufferIndex = 0..BufsizeM1; {output buffer index} CharBuffer = array [BufferIndex] of record case ActionIs: Actions of Spaces, BeginLine: (Spacing: LineIndex); Graphic: (Character: Char) end; ColLog = record LogChar: Integer; {char_count at time of log} LogCol: LineIndex; {write_col at time of log} LogLine: Integer; {current_line at time of log} end; BreakLev = 0..MaxBreakLevel; {expression break priorities} AbortKind = (Syntax, Nesting, ComFormat); {error types} HashValue = 0..HashMax; {possible hash values} {string table description} StringBlockIndex = 0..StringIndexMax; {index table index} StringPieceIndex = 0..StringBlockMax; {index to chars in a piece} StringBlock = packed array [StringPieceIndex] of Char; {identifier spelling bookkeeping} IdPtr = ^IdDescr; IdDescr = packed record Next: IdPtr; {next id with this hash entry} Start: Integer; {start of identifier spelling in string table} Len: LineIndex; {length of identifier} end; {Operating system interface types} filename = packed array [1..filenamelength] of Char; cmdindex = 1..cmdlinelength; {pointer to chars in command line} cmdbuffer = packed array [cmdindex] of Char; {command line buffer} errorname = (unknown, twofilenames, badfile, nofile, nooutputfile, noinput, manyouts); {*-----------* | Variables | *-----------*} var {Structured Constants} SpaceBefore, SpaceAfter: SetOfSyms; {individual symbol spacing} Alphanumerics: SetOfSyms; {alpha symbols} ResvWrd: array [1..NoResWords] of WordType; {reserved word table} ResSymbol: array [1..NoResWords] of Symbols; {symbols for resv_wrd} ResLen: array [2..MaxWordLen] of LenTableType; { length index} UpperCase: array [Char] of Char; LowerCase: array [Char] of Char; {case conversion tables} ProgSet, BlockBegSys, StatSet: SetOfSyms; {syntactic symbol types} Constants: SetOfSyms; {symbols which can be constants} HeadingBegSys: SetOfSyms; {symbols which begin a block heading} TypeBegSys: SetOfSyms; {type beginning symbols} ExprBegSys: SetOfSyms; {expression beginning symbols} RelOps: SetOfSyms; {relational operators} ArithOps: SetOfSyms; {arithmetic operators} {Formatting variables} Indent: Integer; {current number of indentation spaces} StatIndent: Integer; {indentation for major statement} WriteCol: Integer; {current output column} SymbolBreak: array [BreakLev] of record BufChar: Integer; {character in buffer} BreakCol: LineIndex; {output column} end; LastSym: Symbols; {last symbol processed} SymWritten: Boolean; {last symbol was written} IndentState: array [LineIndex] of LineIndex; IndentLevel: LineIndex; {these make a stack of indent levels} EndLine: Boolean; {last symbol ends the line} {miscellaneous} Result: Text; {output file} Source: Text; {input file} OutputLine: Integer; {line numbers for output} CurrentLine: Integer; {line number being written} InputLine: Integer; {input line number} {Formatting Control Values} OutLineLen: Integer; {current output line length} OneHalfLine: Integer; {significant point upon line} FiveEighthLine: Integer; {"} ThreeFourthLine: Integer; {"} TabSpaces: Integer; {spaces to indent for each level} ContinueSpaces: Integer; {spaces to indent continuation line} CommentSpaces: Integer; {spaces before statement comment} StatsPerLine: Integer; {statements per line} {flags to direct formatting} UcResWords: Boolean; {convert reserved words to UC} UcIdents: Boolean; {convert identifiers to UC} LitCopy: Boolean; {copy identifiers literally} PortabilityMode: Boolean; {eliminate underscores} Formatting: Boolean; {do formatting (otherwise, copy)} NewFormatting: Boolean; {start formatting at end of comment} Bunching: Boolean; {bunch statements on one line} ConvertToTabs: Boolean; {convert leading spaces to tabs} OtherwiseKluge: Boolean; {converts else to otherwise in case} FirstSpelling: Boolean; {convert equivalent ids to first spelling} NoNewLine: Boolean; {do not insert extra new-lines} NewNoNewline: Boolean; {start NoNewLine at end of comment} StandardRep: Boolean; {convert to standard representation} {lexical scanner variables} SymbolFound: Boolean; {success from lexical analysis} NewInputLine: Boolean; {true when no chars as yet on new line} EndFile: Boolean; {eof read} BlankLine: Boolean; {true when blank line is ok to output} Ch: Char; {current character for lexical analysis} DoublePeriod: Boolean; {set if double period found} Column: Integer; {input column for last char input} TabColumn: Integer; {column at end of tab, for conversion to spaces} Sym: Symbols; {current basic symbol from lex} Symbol: array [LineIndex] of Char; {workspace for lex analysis} SymLen: 0..MaxLineLen; {index into WINDOW array} {output character buffering} Unwritten: CharBuffer; {unwritten characters} CharCount: Integer; {characters written so far} Oldest: BufferIndex; {oldest char in buffer} InitialBlanks: Integer; {initial blanks on a line} SavingBlanks: Boolean; {true if saving blanks to convert to tabs} {error handling variables} Overflows: 0..Maxint; {number of line overflows} FirstOverflow: 0..Maxint; {line where first overflow occured} ComOverflows: 0..Maxint; {number of comment overflows} FirstComOverflow: 0..Maxint; {line of first comment overflow} {identifier spelling variables} HashTable: array [HashValue] of IdPtr; {main hash table} StringIndex: array [StringBlockIndex] of ^StringBlock; {string table base array} StringTop: Integer; {last character in string table} {Operating system interface variables} cmdline: cmdbuffer; {actual command line read} cmdlength: cmdindex; {length of line being read in} fieldsfound: 0..cmdlinelength; {number of fields found by csi} outspeced: Boolean; { true if an output file specified with "=" } firstfound: Boolean; {true if the first field was found} initialdirectives: Boolean; {set if initial directives provided} initdir: cmdindex; {start of initial directives} endinitdir: cmdindex; {end of initial directives} {*--------------------------* | Initialize Set Constants | *--------------------------*} procedure InitSets; begin {initialize set constants} SpaceBefore := [AndSy, DivSy, DoSy, DowntoSy, InSy, ModSy, OfSy, OrSy, ThenSy, ToSy, Plus, Minus, Mult, Divide, Becomes, Equal, RelOp]; SpaceAfter := [AndSy, ArraySy, CaseSy, DivSy, DowntoSy, ForSy, FunctionSy, GotoSy, IfSy, InSy, ModSy, NotSy, OfSy, OrSy, PackedSy, ProcedureSy, ProgramSy, ToSy, UntilSy, WhileSy, WithSy, Plus, Minus, Mult, Divide, Becomes, Comma, Semicolon, Colon, Equal, RelOp, Comment]; Alphanumerics := [AndSy..WithSy, Identifier, Number]; HeadingBegSys := [LabelSy, ConstSy, TypeSy, VarSy, ProcedureSy, FunctionSy]; BlockBegSys := HeadingBegSys + [BeginSy]; StatSet := [BeginSy, IfSy, CaseSy, WhileSy, RepeatSy, ForSy, WithSy, GotoSy, Number, Identifier]; Constants := [Number, Identifier, String, Plus, Minus, NilSy]; ExprBegSys := Constants + [Pointer, NotSy, NilSy, OpenBrack, OpenParen]; ArithOps := [Plus, Minus, Mult, Divide, DivSy, ModSy]; RelOps := [Equal, RelOp, InSy]; TypeBegSys := Constants + [Pointer, SetSy, RecordSy, FileSy, ArraySy, OpenParen] - [NilSy]; end {init_sets} ; {*---------------------------* | initialize reserved words | *---------------------------*} procedure InitResvWrd; begin {[s=2] initialize reserved word array and length indices into reserved word array for length keyed search} ResLen[2].LowIndex := 1; ResLen[2].HiIndex := 6; ResLen[3].LowIndex := 7; ResLen[3].HiIndex := 15; ResLen[4].LowIndex := 16; ResLen[4].HiIndex := 22; ResLen[5].LowIndex := 23; ResLen[5].HiIndex := 28; ResLen[6].LowIndex := 29; ResLen[6].HiIndex := 33; ResLen[7].LowIndex := 34; ResLen[7].HiIndex := 36; ResLen[8].LowIndex := 37; ResLen[8].HiIndex := 38; ResLen[9].LowIndex := 39; ResLen[9].HiIndex := 41; ResvWrd[1] := 'do '; ResSymbol[1] := DoSy; ResvWrd[2] := 'if '; ResSymbol[2] := IfSy; ResvWrd[3] := 'in '; ResSymbol[3] := InSy; ResvWrd[4] := 'of '; ResSymbol[4] := OfSy; ResvWrd[5] := 'or '; ResSymbol[5] := OrSy; ResvWrd[6] := 'to '; ResSymbol[6] := ToSy; ResvWrd[7] := 'and '; ResSymbol[7] := AndSy; ResvWrd[8] := 'div '; ResSymbol[8] := DivSy; ResvWrd[9] := 'end '; ResSymbol[9] := EndSy; ResvWrd[10] := 'for '; ResSymbol[10] := ForSy; ResvWrd[11] := 'mod '; ResSymbol[11] := ModSy; ResvWrd[12] := 'nil '; ResSymbol[12] := NilSy; ResvWrd[13] := 'not '; ResSymbol[13] := NotSy; ResvWrd[14] := 'set '; ResSymbol[14] := SetSy; ResvWrd[15] := 'var '; ResSymbol[15] := VarSy; ResvWrd[16] := 'case '; ResSymbol[16] := CaseSy; ResvWrd[17] := 'else '; ResSymbol[17] := ElseSy; ResvWrd[18] := 'file '; ResSymbol[18] := FileSy; ResvWrd[19] := 'goto '; ResSymbol[19] := GotoSy; ResvWrd[20] := 'then '; ResSymbol[20] := ThenSy; ResvWrd[21] := 'type '; ResSymbol[21] := TypeSy; ResvWrd[22] := 'with '; ResSymbol[22] := WithSy; ResvWrd[23] := 'array '; ResSymbol[23] := ArraySy; ResvWrd[24] := 'begin '; ResSymbol[24] := BeginSy; ResvWrd[25] := 'const '; ResSymbol[25] := ConstSy; ResvWrd[26] := 'label '; ResSymbol[26] := LabelSy; ResvWrd[27] := 'until '; ResSymbol[27] := UntilSy; ResvWrd[28] := 'while '; ResSymbol[28] := WhileSy; ResvWrd[29] := 'downto '; ResSymbol[29] := DowntoSy; ResvWrd[30] := 'packed '; ResSymbol[30] := PackedSy; ResvWrd[31] := 'record '; ResSymbol[31] := RecordSy; ResvWrd[32] := 'repeat '; ResSymbol[32] := RepeatSy; ResvWrd[33] := 'origin '; ResSymbol[33] := OriginSy; ResvWrd[34] := 'fortran '; ResSymbol[34] := FortranSy; ResvWrd[35] := 'forward '; ResSymbol[35] := ForwardSy; ResvWrd[36] := 'program '; ResSymbol[36] := ProgramSy; ResvWrd[37] := 'external '; ResSymbol[37] := ExternSy; ResvWrd[38] := 'function '; ResSymbol[38] := FunctionSy; ResvWrd[39] := 'otherwise'; ResSymbol[39] := OtherwiseSy; ResvWrd[40] := 'procedure'; ResSymbol[40] := ProcedureSy; ResvWrd[41] := 'nonpascal'; ResSymbol[41] := NonpascalSy; end {[s=1] init_resv_wrd} ; {*------------* | initialize | *------------*} procedure Initialize; var P: Integer; C: Char; {induction var} H: HashValue; {induction var} S: StringBlockIndex; {induction var} begin {initialize all global variables} InitSets; for C := Chr(0) to Chr(127) do begin LowerCase[C] := C; UpperCase[C] := C; end; for C := 'A' to 'Z' do begin LowerCase[C] := Chr(Ord(C) + Ord('a') - Ord('A')); UpperCase[Chr(Ord(C) + Ord('a') - Ord('A'))] := C; end; CharCount := 0; OutLineLen := DefaultOutLine; TabSpaces := DefaultTabSpaces; ContinueSpaces := (TabSpaces + 1) div 2; CommentSpaces := DefaultCommentSpaces; IndentLevel := 0; OneHalfLine := OutLineLen div 2; FiveEighthLine := 5 * OutLineLen div 8; ThreeFourthLine := 3 * OutLineLen div 4; StatsPerLine := 1; for P := 1 to OutLineLen do Symbol[P] := ' '; SymLen := 0; Indent := 0; StatIndent := 0; WriteCol := 0; SavingBlanks := false; Column := 0; TabColumn := 0; OutputLine := 1; CurrentLine := 0; InputLine := 1; NewInputLine := true; BlankLine := false; Sym := Period; EndLine := false; EndFile := false; LastSym := Period; SymWritten := false; Ch := ' '; DoublePeriod := false; Formatting := true; NewFormatting := true; UcResWords := false; UcIdents := false; LitCopy := true; PortabilityMode := false; Bunching := false; ConvertToTabs := false; OtherwiseKluge := false; FirstSpelling := false; NoNewLine := false; NewNoNewline := false; StandardRep := true; Overflows := 0; ComOverflows := 0; InitResvWrd; for H := 0 to HashMax do HashTable[H] := nil; for S := 0 to StringIndexMax do StringIndex[S] := nil; StringTop := 0; end {initialize} ; {Command String Interpreter, parses the command string and sets the initial state of the switches. } procedure getline(var line: cmdbuffer; {resulting command line} var length: cmdindex {resulting command length} ); { RT 11 procedure to get a command line no matter what its source. } external; procedure exitst(status: Integer {status for error on exit} ); { Entrance to the library to exit with a status set to "status". } external; procedure csierror(which: errorname; {which error} startind: cmdindex; {start of command to print} endind: cmdindex {end of command to print} ); { Print an error message and exit from the program with a fatal error status. The offending portion of the command line is printed before the error message. } var i: Integer; {induction var} begin for i := startind to endind do write(cmdline[i]); if startind <= endind then writeln; case which of unknown: writeln('Unknown qualifier.'); twofilenames: writeln('Two file names in one field.'); badfile: writeln('Bad file or qualifier syntax.'); nofile: writeln('No file in field.'); nooutputfile: writeln('Output requested but no file provided.'); noinput: writeln('No input file provided.'); manyouts: writeln('More than one output file specification.'); end; exitst(4); {magic number for fatal error} end; {error} procedure skipbalancedstring(startindex: cmdindex; var Next: cmdindex); var endchar: Char; {bracket which terminates string} begin {Skip a string balanced with respect to parentheses and quoted strings} if cmdline[Next] in ['(', '[', '<'] then begin if cmdline[Next] = '(' then endchar := ')' else if cmdline[Next] = '<' then endchar := '>' else endchar := ']'; Next := Next + 1; while (cmdline[Next] <> endchar) and (Next <> cmdlength) do skipbalancedstring(startindex, Next); end else if cmdline[Next] = '"' then repeat Next := Next + 1 until (cmdline[Next] = '"') or (Next = cmdlength); if Next < cmdlength then Next := Next + 1 else csierror(badfile, startindex, cmdlength); end; {skipbalancedstring} procedure csi; { Gets a command line and parse it. The procedure "getfilename", below, is used to get file names after csi has been called. The input line is assumed to be of the form: [ [ output ] "=" ] input [* "," input *] Qualifiers can be attached to any file, and all qualifiers are assumed to have the same effect no matter which file it is attached to. } var Next: cmdindex; {next char in command string} filefound: Boolean; {true if file found in this field} filestart: cmdindex; {start of last file name found} manyfound: Boolean; {more than 1 field found} emptyfile: Boolean; {empty file name found, possibly an error} emptystart: cmdindex; {start of empty file field} emptyend: cmdindex; {end of empty file field} lastfield: cmdindex; {end of last field scanned} procedure getcmdline; { Read the command line into core. } var i: Integer; {induction var} begin if rsx then begin if Input^ <> ' ' then begin repeat get(Input) until (Input^ = ' '); while not eoln and (Input^ = ' ') do get(Input); end; if Input^ = ' ' then write(rsxprompt); if eoln then readln; end else if rsts then write('*'); if rt11 then begin getline(cmdline, cmdlength); cmdlength := cmdlength + 1; end else begin cmdlength := 1; while not eoln do begin if cmdlength < cmdlinelength - 2 then begin cmdline[cmdlength] := Input^; cmdlength := cmdlength + 1; end; get(Input); end; end; for i := cmdlength to cmdlinelength do cmdline[i] := ' '; end; {getcmdline} procedure takequal(var Next: cmdindex); { Parse and look up a qualifier, updating "next" to point to the next character in the command line. In this case we examine only the first character of the qualifier. } var startingindex: cmdindex; {start of qualifier, for error printout} startchar: Char; {first character of qualifier} begin repeat Next := Next + 1; until (cmdline[Next] <> ' ') or (Next = cmdlength); startingindex := Next; startchar := cmdline[Next]; while cmdline[Next] in ['A'..'Z', 'a'..'z', '0'..'9'] do Next := Next + 1; if (startchar = 'O') or (startchar = 'o') then if (cmdline[Next] = ':') or (cmdline[Next] = '=') then begin repeat Next := Next + 1; until (cmdline[Next] <> ' ') or (Next = cmdlength); initialdirectives := true; initdir := Next; repeat skipbalancedstring(startingindex, Next); until (cmdline[Next] in [',', ' ', '/', '=']) or (Next = cmdlength); endinitdir := Next - 1; end else csierror(badfile, startingindex, Next) else csierror(unknown, startingindex, Next); end; {takequal} procedure takefilename(var Next: cmdindex); { Parse a filename. The only data which is taken here is the existance of the file. This routine makes sure that there is only one file specified per field. } var startindex: cmdindex; {start of this field} begin startindex := Next; while (Next < cmdlength) and not (cmdline[Next] in [',', '/', '=', ' ']) do skipbalancedstring(startindex, Next); if filefound then csierror(twofilenames, filestart, Next) else begin filefound := true; filestart := startindex; end; end; {takefilename} procedure endfield(var Next: cmdindex {next character} ); { Terminate a field, making several checks. } begin fieldsfound := fieldsfound + 1; if (fieldsfound = 1) and filefound then firstfound := true else if filefound then manyfound := true; if not filefound then if outspeced then csierror(nofile, lastfield, Next) else if not emptyfile then begin emptyfile := true; emptystart := lastfield; emptyend := Next; end; if cmdline[Next] = '=' then if fieldsfound > 1 then csierror(manyouts, 1, Next) else begin fieldsfound := 1; outspeced := true; end; lastfield := Next; if Next < cmdlength then Next := Next + 1; filefound := false; end; procedure checkconsistancy; { Check the command line and qualifiers for consistancy. This should also set any defaults. } begin if not ((outspeced and manyfound) or firstfound) then csierror(noinput, 2, 1); if not outspeced and emptyfile then csierror(nofile, emptystart, emptyend); end; begin {csi} initialdirectives := false; getcmdline; Next := 1; fieldsfound := 0; lastfield := 1; filefound := false; outspeced := false; emptyfile := false; firstfound := false; manyfound := false; repeat while (Next < cmdlength) and (cmdline[Next] = ' ') do Next := Next + 1; case cmdline[Next] of '=', ',': endfield(Next); '/': takequal(Next); ' ': ; otherwise takefilename(Next); end; until Next = cmdlength; endfield(Next); if not outspeced then fieldsfound := fieldsfound + 1; {fake field} checkconsistancy; end; {csi} procedure getfilename(which: Integer; {file desired} var Result: filename; {resulting file name} var exists: Boolean {true if file exists} ); { Procedure to get file names from the input command line. The desired file name is specified by an index with the following possible values. 1 Output file 2..n Input files } var Next: cmdindex; {search variable} fieldstart: 0..cmdlinelength; {start of the desired field} i: Integer; {induction var for transfer} delims: set of Char; {ending fields} stripdevice: Boolean; {strip off device field} scanning: Boolean; {used in stripping device field} begin if (which <= 0) or (which > fieldsfound) or outspeced and (((which = 0) or (which = 1)) and not firstfound) then exists := false else begin {we have a file to find} delims := [',', ' ', '/', '=']; stripdevice := false; if (which = 1) and not outspeced then begin delims := delims + ['.']; which := fieldsfound; stripdevice := true; end; Next := 1; if which > 1 then begin if outspeced then begin repeat skipbalancedstring(Next, Next); until cmdline[Next] = '='; Next := Next + 1; end; which := which - 1; end; for i := 1 to which - 1 do begin while not (cmdline[Next] in [',', '=']) do skipbalancedstring(Next, Next); Next := Next + 1; end; while cmdline[Next] = ' ' do Next := Next + 1; fieldstart := Next; repeat skipbalancedstring(Next, Next); until cmdline[Next] in delims; if stripdevice then begin fieldstart := Next - 1; scanning := true; repeat scanning := cmdline[fieldstart] in ['A'..'Z', 'a'..'z', '$', '.', '0'..'9']; if scanning then fieldstart := fieldstart - 1; until (fieldstart = 0) or not scanning; fieldstart := fieldstart + 1; end; for i := fieldstart to Next - 1 do Result[i - fieldstart + 1] := cmdline[i]; for i := Next - fieldstart + 1 to filenamelength do Result[i] := ' '; exists := true; end; end; {getfilename} procedure ReadCommandLine; var thisfile: filename; {file just read} exists: Boolean; {dummy var for getfilename} begin csi; getfilename(2, thisfile, exists); if rsx then reset(Source, thisfile, 'sy:.pas') else reset(Source, thisfile, '.pas'); getfilename(1, thisfile, exists); if rsx then rewrite(Result, thisfile, 'sy:.pas') else rewrite(Result, thisfile, '.pas'); end; {ReadCommandLine} {*-----------------------------* | Terminate and Print Message | *-----------------------------*} procedure FinalData; begin {print summary data} if Overflows > 0 then begin write(Output, 'Token too wide for output at ', Overflows: 1, ' place'); if Overflows > 1 then write(Output, 's, first error'); writeln(Output, ' on line ', FirstOverflow: 1, '.'); end; if ComOverflows > 0 then begin write(Output, 'Comment too wide for output at ', ComOverflows: 1, ' place'); if ComOverflows > 1 then write(Output, 's, first'); writeln(Output, ' on line ', FirstComOverflow: 1, '.'); end; write(Output, 'Formatting complete, ', OutputLine - 1: 1, ' line'); if OutputLine > 2 then write('s'); writeln(Output, ' output.'); end; {final_data} {*------------------* | Character output | *------------------*} procedure ClearBreaks; var i: BreakLev; {induction var} begin {clear out all symbol breaks} for i := 0 to MaxBreakLevel do SymbolBreak[i].BufChar := 0; end; {clear_breaks} procedure ResetCharCount; begin {reset the output character count to avoid overflow, taking care to preserve the actual buffer loc} if CharCount > BufsizeP1 then CharCount := CharCount mod Bufsize + 2 * Bufsize; ClearBreaks; end; {reset_char_count} procedure WriteA(Ch: Char); var i: LineIndex; begin {Write a character to the output buffer. If necessary (which it always is after the buffer is filled), write the previous contents of the buffer) } CharCount := CharCount + 1; Oldest := CharCount mod Bufsize; with Unwritten[Oldest] do begin if CharCount >= BufsizeP1 then if ActionIs = Graphic then begin if SavingBlanks then if Character = ' ' then InitialBlanks := InitialBlanks + 1 else begin while ConvertToTabs and (InitialBlanks >= TabInterval) do begin write(Result, Chr(Ht)); InitialBlanks := InitialBlanks - TabInterval; end; while InitialBlanks > 0 do begin write(Result, ' '); InitialBlanks := InitialBlanks - 1; end; SavingBlanks := false; write(Result, Character) end else write(Result, Character); end else if ActionIs = Spaces then begin if SavingBlanks then InitialBlanks := InitialBlanks + Spacing else for i := 1 to Spacing do write(Result, ' '); end else {action_is = begin_line} begin if CharCount > BufsizeP1 then writeln(Result); SavingBlanks := true; InitialBlanks := Spacing; OutputLine := OutputLine + 1; end; ActionIs := Graphic; Character := Ch; if Ch = Chr(Ht) then WriteCol := ((WriteCol + TabInterval) div TabInterval) * TabInterval else WriteCol := WriteCol + 1; end; {with} end; {write_a} procedure NewLine(Indent: LineIndex); begin {start a new line and indent it as specified} {fake a character, then change it} EndLine := false; WriteA(' '); with Unwritten[Oldest] do begin ActionIs := BeginLine; Spacing := Indent; end; WriteCol := Indent; CurrentLine := CurrentLine + 1; end; {new_line} procedure PrintLine(Indent: Integer); begin {print a line for formatting} if Formatting then begin if BlankLine and (CurrentLine > 0) then NewLine(0); NewLine(Indent); end; BlankLine := false; ClearBreaks; end; {print_line} procedure Space(N: Integer); begin {space n characters} if Formatting then begin WriteA(' '); with Unwritten[Oldest] do begin ActionIs := Spaces; if N >= 0 then Spacing := N else Spacing := 0; end; WriteCol := WriteCol + N - 1; end; end; {space} procedure FlushBuffer; var i: 0..BufsizeM1; begin {flush any unwritten buffer} for i := 0 to BufsizeM1 do WriteA(' '); writeln(Result); end; {flush_buffer} procedure FlushSymbol; var P: LineIndex; {induction var} begin {flush any accumulated characters in the buffer} if not SymWritten then for P := 1 to SymLen do WriteA(Symbol[P]); end; {flush_symbol} procedure throwaway(Ch: Char); begin {dummy procedure to throw away an output character} end; {throwaway} {*-------------------------* | INPUT/OUTPUT: get char | *-------------------------*} procedure GetChar; begin {read next character from input file} {The following is a PDP-11 kluge to read initial directives} if initialdirectives then if initdir < endinitdir then begin initdir := initdir + 1; Ch := cmdline[initdir]; end else begin initialdirectives := false; Ch := ']'; end {End PDP 11 kluge} else if Column < TabColumn then begin Column := Column + 1; Ch := ' '; if not Formatting then WriteA(' '); end else if not Eof(Source) then if not eoln(Source) then begin {normal} Read(Source, Ch); if Ch = Chr(Ht) then begin {kluge in input tabs} TabColumn := ((Column + TabInterval) div TabInterval) * TabInterval; Ch := ' '; end; if not Formatting then WriteA(Ch); Column := Column + 1; end {normal} else begin {eoln} if NewInputLine then BlankLine := true else NewInputLine := true; Column := 0; TabColumn := 0; InputLine := InputLine + 1; readln(Source); if not Formatting then begin NewLine(0); ResetCharCount; end; Ch := ' '; end {eoln} else begin {eof} EndFile := true; Ch := ' '; end {eof} end {get_char} ; {*----------------* | Error Handling | *----------------*} procedure LineOverflow; begin {token too long for output line, note it} Overflows := Overflows + 1; if Overflows = 1 then FirstOverflow := CurrentLine + 1; end; {line_overflow} procedure CommentOverflow; begin {block comment too long for output line, note it} ComOverflows := ComOverflows + 1; if ComOverflows = 1 then FirstComOverflow := CurrentLine; end; {comment_overflow} procedure Abort(Kind: AbortKind); begin {abort processing and do not create output element} FlushSymbol; WriteA(Ch); writeln(Output); if Kind = Syntax then write(Output, 'Syntax error detected, ') else if Kind = Nesting then write(Output, 'Too many indentation levels, ') else write(Output, 'Could not format comment, '); writeln(Output, 'processing aborted at input line ', InputLine: 1, '.'); Formatting := false; while not EndFile do GetChar; FlushBuffer; goto 99; end; {abort} {*---------------------* | Indentation Control | *---------------------*} procedure IndentPlus(Delta: Integer); begin {increment indentation and check for overflow} if IndentLevel > MaxLineLen then Abort(Nesting); IndentLevel := IndentLevel + 1; IndentState[IndentLevel] := Indent; Indent := Indent + Delta; if Indent > OutLineLen then Indent := OutLineLen else if Indent < 0 then Indent := 0; end; {indent_plus} procedure Undent; begin {reset indent to the last value} Indent := IndentState[IndentLevel]; IndentLevel := IndentLevel - 1; end; {undent} procedure SetSymbolBreak(Level: BreakLev); begin {mark a good spot to break a line} Space(0); with SymbolBreak[Level] do begin BufChar := CharCount; BreakCol := WriteCol; end; end; {set_symbol_break} procedure FormatLine(Indent: Integer); begin {Make a newline if allowed, otherwise mark this as a good break point.} if NoNewLine and not EndLine then SetSymbolBreak(MaxBreakLevel) else PrintLine(Indent); end; {*---------* | Put_sym | *---------*} procedure PutSym; var Before: LineIndex; {spaces before this character} SymIndent: Integer; {indentation before this symbol} i: LineIndex; {induction var} L: BreakLev; {induction var} LastBreak: Integer; {last break character} function SpacesBefore(ThisSym, OldSym: Symbols): LineIndex; begin {determine the number of spaces before a symbol} if ((ThisSym in Alphanumerics) and (OldSym in Alphanumerics)) or (ThisSym in SpaceBefore) or (OldSym in SpaceAfter) then SpacesBefore := 1 else SpacesBefore := 0; end; {spaces_before} begin {put_sym: put the current symbol to the output, taking care of spaces before the symbol. This also handles full lines, and tries to break lines at a convenient place} Before := SpacesBefore(Sym, LastSym); if EndLine or (Before + SymLen + WriteCol > OutLineLen) then begin {must handle an end of line} L := MaxBreakLevel; while (L > 0) and (SymbolBreak[L].BufChar = 0) do L := L - 1; with SymbolBreak[L] do if not EndLine and Formatting and (BufChar > 0) and (CharCount - BufChar < Bufsize) and (Before + SymLen + Indent + WriteCol - BreakCol <= OutLineLen) then begin with Unwritten[BufChar mod Bufsize] do begin ActionIs := BeginLine; Spacing := Indent end; WriteCol := WriteCol - BreakCol + Indent; CurrentLine := CurrentLine + 1; LastBreak := BufChar; end else begin {no good break spot, break it here} SymIndent := OutLineLen - SymLen; if SymIndent > Indent then SymIndent := Indent else if SymIndent < 0 then begin SymIndent := 0; LineOverflow end; PrintLine(SymIndent); LastBreak := CharCount; end; for L := 0 to MaxBreakLevel do with SymbolBreak[L] do if BufChar <= LastBreak then BufChar := 0; end; {if line overflow} if Unwritten[Oldest].ActionIs = BeginLine then Before := 0; if Before > 0 then with Unwritten[CharCount mod Bufsize] do if Formatting and (ActionIs = Spaces) then begin WriteCol := WriteCol - Spacing + Before; Spacing := Before; end else Space(Before); if Formatting then for i := 1 to SymLen do WriteA(Symbol[i]); LastSym := Sym; SymWritten := true; EndLine := false; end; {put_sym} {*-------------------------* | do_formatter_directives | *-------------------------*} procedure DoFormatterDirectives(procedure putch (C: Char)); var OptChar: Char; {which option specified} procedure CopyAChar; begin {copy a character and get a new one} putch(Ch); GetChar; end; {copy_a_char} procedure SwitchDir(var Switch: Boolean); begin {read and set a switch directive, if char is not + or -, the value is unchanged} if Ch = '+' then begin Switch := true; CopyAChar end else if Ch = '-' then begin Switch := false; CopyAChar end; end; {switch_dir} procedure NumDir(var Value: Integer; Min, Max: Integer {limits} ); var TempVal: Integer; {value being accumulated} begin {read a numeric directive and set value. if the value is out of bounds it is set to the limit value} if Ch = '=' then CopyAChar; if (Ch >= '0') and (Ch <= '9') then begin TempVal := 0; while (Ch >= '0') and (Ch <= '9') do begin if TempVal <= (Maxint - 9) div 10 then TempVal := TempVal * 10 + (Ord(Ch) - Ord('0')); CopyAChar; end; if TempVal < Min then TempVal := Min; if TempVal > Max then TempVal := Max; Value := TempVal; end; end; {num_dir} begin {do_formatter_directives: read a formatter directive and set flags and value appropriately} CopyAChar; repeat if (Ch <> ']') and (Ch <> '}') and (Ch <> '*') then begin OptChar := Ch; CopyAChar; case OptChar of 'a', 'A': SwitchDir(FirstSpelling); 'b', 'B': SwitchDir(Bunching); 'c', 'C': SwitchDir(ConvertToTabs); 'f', 'F': SwitchDir(NewFormatting); 'k', 'K': SwitchDir(OtherwiseKluge); 'l', 'L': SwitchDir(LitCopy); 'm', 'M': SwitchDir(StandardRep); 'n', 'N': SwitchDir(NewNoNewline); 'o', 'O': begin NumDir(OutLineLen, 1, MaxLineLen); OneHalfLine := OutLineLen div 2; FiveEighthLine := (5 * OutLineLen) div 8; ThreeFourthLine := (3 * OutLineLen) div 4; end; 'p', 'P': SwitchDir(PortabilityMode); 'r', 'R': SwitchDir(UcResWords); 's', 'S': NumDir(StatsPerLine, 1, MaxLineLen); 't', 'T': begin NumDir(TabSpaces, 0, MaxLineLen); ContinueSpaces := (TabSpaces + 1) div 2; end; 'u', 'U': SwitchDir(UcIdents); otherwise; end; {case} end; until (Ch = ']') or (Ch = '}') or (Ch = '*'); if Ch = ']' then CopyAChar; end; {do_formatter_directives} {*------------------* | Comment Handling | *------------------*} procedure DoComment(Block: Boolean; {true if block comment} InitCol: LineIndex; {starting column} InitChar: Char {starting char} ); var StatBreak: Integer; {character where line can be broken} StatBlanks: Boolean; {set if blank was last char} FirstInputLine: Boolean; {set if first input line} {Handles all comments. Comments are split into two classes which are handled separately. Comments which begin a line are treated as "block comments" and are not formatted. At most, it will be folded to fit on the output line. Comments which follow other statements on a line are formatted like any other statement.} {*-------------------------* | Block Comment Character | *-------------------------*} procedure BlockComChar(Character: Char); begin {Write a character for a block comment. The comment formatting must be terminated with a call to adjust_block_comment. The comment is copied exactly, and if it will not fit within the out_line_len a message will be printed.} if EndFile then Abort(Syntax); if Formatting then if NewInputLine and (Character = ' ') then begin if WriteCol > OutLineLen then CommentOverflow; PrintLine(Column); FirstInputLine := false; NewInputLine := false; end else WriteA(Character); end; {block_com_char} {*-----------------------------* | Statement Comment Character | *-----------------------------*} procedure BreakStatComment; var ExtraLen: Integer; {length from last break} ComIndent: Integer; {amount to indent the extra} begin {Break a statement comment at the last break. Assumes (stat_break <> 0) and (char_count - stat_break < bufsize)} ExtraLen := CharCount - StatBreak + 1; if WriteCol - ExtraLen > MaxLineLen then Abort(ComFormat) else begin {we can at least write it} if WriteCol - ExtraLen > OutLineLen then CommentOverflow; ComIndent := OutLineLen - ExtraLen; if ComIndent < 0 then ComIndent := 0 else if ComIndent > Indent then ComIndent := Indent; with Unwritten[StatBreak mod Bufsize] do begin ActionIs := BeginLine; Spacing := ComIndent; end; CurrentLine := CurrentLine + 1; WriteCol := ComIndent + ExtraLen; end; end; {break_stat_comment} procedure StatComChar(Character: Char); begin {Take a statement character and format it. assumes that stat_break and stat_blank are initialized before the first character and are unchanged thereafter. The procedure adjust_stat_comment must be called after the comment is done} if EndFile then Abort(Syntax); if Formatting then if Character = ' ' then begin if not StatBlanks then begin if (WriteCol > OutLineLen) and (StatBreak <> 0) then BreakStatComment; WriteA(' '); StatBreak := CharCount; StatBlanks := true; end; end else begin WriteA(Character); StatBlanks := false; end; end; {stat_com_char} {*------------------------* | Do compiler directives | *------------------------*} procedure DoCompilerDirectives(procedure putch (Ch: Char)); begin {scan off compiler directives} while (Ch <> '[') and (Ch <> '*') and (Ch <> '}') do begin putch(Ch); GetChar; end; end; {do_compiler_directives} {*----------------------* | Adjust Block Comment | *----------------------*} procedure AdjustBlockComment(Start: Integer); var ComLength: Integer; {length of comment if on one line} ComIndent: Integer; {amount to indent comment} begin {if the comment is all on one line, adjust it to line up with the indentation if possible, otherwise just try to fit it somehow. In any case, if the comment extends beyond the allowable length, bitch about it.} if Formatting then begin if FirstInputLine then begin ComLength := CharCount - Start; ComIndent := OutLineLen - ComLength; if ComIndent < 0 then ComIndent := 0 else if ComIndent > StatIndent then ComIndent := StatIndent; Unwritten[Start mod Bufsize].Spacing := ComIndent; WriteCol := ComIndent + ComLength; end; if WriteCol > OutLineLen then CommentOverflow; end; {if formatting} end; {adjust_block_comment} {*-------------------------* | Adjust Statment Comment | *-------------------------*} procedure AdjustStatComment; begin {called after the last character of a statment comment has been written to ensure that it all fits on a line} if Formatting then if WriteCol > OutLineLen then if StatBreak = 0 then if WriteCol <= MaxLineLen then CommentOverflow else Abort(ComFormat) else BreakStatComment; end; {adjust_stat_comment} {*---------------* | Block Comment | *---------------*} procedure BlockComment(Column: LineIndex; {starting column} InitChar: Char); var ComStart: Integer; {start of comment} begin {format a block comment: If the comment is all on one input line it will be indented to the current statement level unless it won't fit, in which case it is shifted left until it will fit. If any part of a block comment will not fit in the output line, the output line will be extended and a message printed.} if NoNewLine and not Block then IndentPlus(WriteCol + 1 - Column - Indent) else PrintLine(Column - 1); ComStart := CharCount; FirstInputLine := true; if StandardRep or (InitChar = '{') then BlockComChar('{') else begin BlockComChar('('); BlockComChar('*'); end; GetChar; if Ch = '$' then DoCompilerDirectives(BlockComChar); if Ch = '[' then DoFormatterDirectives(BlockComChar); if InitChar = '/' then {We have a dumb comment, handle it} repeat while Ch <> '*' do begin BlockComChar(Ch); GetChar; end; GetChar; if (Ch <> '/') or not StandardRep then BlockComChar('*'); until Ch = '/' else repeat while not (Ch in ['}', '*']) do begin BlockComChar(Ch); GetChar; end; if Ch = '*' then begin GetChar; if (Ch <> ')') or not StandardRep then BlockComChar('*'); end; until Ch in ['}', ')']; if StandardRep or (Ch = '}') then BlockComChar('}') else BlockComChar(')'); if Block then AdjustBlockComment(ComStart) else if NoNewLine then Undent; end; {block_comment} {*--------------* | stat_comment | *--------------*} procedure StatComment(InitChar: Char); begin {Format a statement comment: These are inserted in the line at the place found, and subsequent lines are indented to the start of the comment. If the start of the comment is too far to the right, it will be indented on the next line. Text will be moved as necessary to fill lines. All breaks will be at blanks, and if it is not possible to break a comment properly the output line will be extended and a message printed} {initialize stat_com_char} StatBreak := 0; StatBlanks := false; IndentPlus(WriteCol + CommentSpaces + 1 - Indent); if Indent > ThreeFourthLine then begin Undent; IndentPlus(TabSpaces); end; if WriteCol < OutLineLen - CommentSpaces - 1 then Space(CommentSpaces); if StandardRep or (InitChar = '{') then StatComChar('{') else begin StatComChar('('); StatComChar('*'); end; GetChar; if Ch = '$' then DoCompilerDirectives(StatComChar); if Ch = '[' then DoFormatterDirectives(StatComChar); if InitChar = '/' then {We have a dumb comment, handle it} repeat while Ch <> '*' do begin StatComChar(Ch); GetChar; end; GetChar; if (Ch <> '/') or not StandardRep then StatComChar('*'); until Ch = '/' else repeat while not (Ch in ['}', '*']) do begin StatComChar(Ch); GetChar; end; if Ch = '*' then begin GetChar; if (Ch <> ')') or not StandardRep then StatComChar('*'); end; until Ch in ['}', ')']; if StandardRep or (Ch = '}') then StatComChar('}') else StatComChar(')'); AdjustStatComment; Undent; BlankLine := false; NewInputLine := false; end; {stat_comment} {*------------------------------* | body of do_comment procedure | *------------------------------*} begin {do_comment} NewInputLine := false; if Block or NoNewLine then BlockComment(InitCol, InitChar) else StatComment(InitChar); Formatting := NewFormatting; NoNewLine := NewNoNewline; NewInputLine := false; GetChar; while (Ch = ' ') and not NewInputLine do GetChar; if Formatting and NewInputLine then EndLine := true; SymbolFound := false; LastSym := Comment; end; {do_comment} {*--------------------------* | Lexical Scanner, Utility | *--------------------------*} procedure SymbolPut(ThisChar: Char); begin {ch to symbol} SymLen := SymLen + 1; Symbol[SymLen] := ThisChar; GetChar; end {symbol_put} ; {*------------* | print char | *------------*} procedure PrintChar; begin {print ASCII chars not belonging to Pascal} if WriteCol >= OutLineLen then PrintLine(Indent + ContinueSpaces); if Formatting then WriteA(Ch); GetChar; end {print_char} ; {*-------------* | scan_blanks | *-------------*} procedure ScanBlanks; begin {scan off blanks in the input} while (Ch = ' ') and not EndFile do GetChar; end; {*-----------------* | String Constant | *-----------------*} procedure StringConstant; var StringEnd: Boolean; begin {character string to symbol} NewInputLine := false; SymbolFound := true; Sym := String; StringEnd := false; repeat SymbolPut(Ch); if Ch = '''' then begin SymbolPut(Ch); StringEnd := Ch <> '''' end; until NewInputLine or StringEnd; if not StringEnd then Abort(Syntax); end {string constant} ; {*-------------------------* | Test for Reserved Words | *-------------------------*} procedure TestResvWrd; var Id: WordType; Index: 1..NoResWords; P: 1..MaxWordLen; begin {test for reserved word} if (SymLen >= 2) and (SymLen <= MaxWordLen) then begin for P := 1 to MaxWordLen do if P > SymLen then Id[P] := ' ' else Id[P] := LowerCase[Symbol[P]]; with ResLen[SymLen] do begin {length index search} Index := LowIndex; while (ResvWrd[Index] <> Id) and (Index < HiIndex) do Index := Index + 1; end {length index search} ; if ResvWrd[Index] = Id then Sym := ResSymbol[Index] else Sym := Identifier; end else Sym := Identifier; end {test_resv_wrd} ; {*-----------------------------* | Identifier or Reserved Word | *-----------------------------*} procedure AdjustSpelling; var ThisId: IdPtr; {Ref for current id} HashBase: HashValue; {hash value for this ident} ThisPiece: StringBlockIndex; {current piece of string table} ThisChar: StringPieceIndex; {character in current piece} J: LineIndex; {induction var} function HashIdent: HashValue; var i: LineIndex; {induction var} H: HashValue; {partial hash value} begin {hash the current identifier} H := 0; for i := 1 to SymLen do if Symbol[i] <> '_' then H := (H * 3 + Ord(UpperCase[Symbol[i]])) mod HashMax; HashIdent := H; end; {hash_ident} function SameIdent(P: IdPtr): Boolean; var i: Integer; {induction var on symbol characters} J: Integer; {count of characters in id} ThisPiece: StringBlockIndex; {current piece of string table} ThisChar: StringPieceIndex; {current character within the piece} begin {returns true if the identifier pointed to by p is the same as the current identifier} if P = nil then SameIdent := true else begin i := 0; J := 0; ThisPiece := (P^.Start - 1) div StringBlockSize; ThisChar := (P^.Start - 1) mod StringBlockSize; repeat if i < SymLen then repeat i := i + 1; until (Symbol[i] <> '_') or (i = SymLen); if J < P^.Len then repeat J := J + 1; if ThisChar = StringBlockMax then begin ThisPiece := ThisPiece + 1; ThisChar := 0; end else ThisChar := ThisChar + 1; until (J = P^.Len) or (StringIndex[ThisPiece]^[ThisChar] <> '_'); until ((J = P^.Len) and (i = SymLen)) or (UpperCase[Symbol[i]] <> UpperCase[StringIndex[ThisPiece]^[ThisChar]]); SameIdent := (J = P^.Len) and (i = SymLen) and ((UpperCase[Symbol[i]] = UpperCase[StringIndex[ThisPiece]^[ThisChar]]) or (Symbol[i] = '_') or (StringIndex[ThisPiece]^[ThisChar] = '_')); end; end; {same_id} begin {Adjust the spelling of the current identifier to the first spelling encountered for the same identifier. Identifiers are matched without regard to case or break-characters. If this is the first appearance of this identifier, the exact spelling is saved for future use. If it is not the first appearance, it is replaced with the spelling from the first appearance.} HashBase := HashIdent; {hash for current identifier} ThisId := HashTable[HashBase]; while not SameIdent(ThisId) do ThisId := ThisId^.Next; if ThisId = nil then begin {Add this identifier to the table for future reference} New(ThisId); with ThisId^ do begin Next := HashTable[HashBase]; HashTable[HashBase] := ThisId; Len := SymLen; Start := StringTop + 1; end; if StringTop = 0 then New(StringIndex[0]); ThisPiece := StringTop div StringBlockSize; ThisChar := StringTop mod StringBlockSize; for J := 1 to SymLen do begin if ThisChar = StringBlockMax then begin ThisPiece := ThisPiece + 1; New(StringIndex[ThisPiece]); ThisChar := 0; end else ThisChar := ThisChar + 1; StringTop := StringTop + 1; StringIndex[ThisPiece]^[ThisChar] := Symbol[J]; end; end else with ThisId^ do begin ThisPiece := Start div StringBlockSize; ThisChar := Start mod StringBlockSize; SymLen := Len; for J := 1 to Len do begin Symbol[J] := StringIndex[ThisPiece]^[ThisChar]; if ThisChar = StringBlockMax then begin ThisPiece := ThisPiece + 1; ThisChar := 0; end else ThisChar := ThisChar + 1; end; end; end; {adjust_spelling} procedure SetSymbolCase(Kind: Symbols); var LastUnderscore: Boolean; {true if last char underscore} i, J: LineIndex; {induction vars} begin {Convert a reserved word or identifier to the proper case} if Kind = Identifier then begin if PortabilityMode then begin J := 0; LastUnderscore := true; For i := 1 to SymLen Do if Symbol[i] = '_' then LastUnderscore := true else if LastUnderscore then begin LastUnderscore := false; J := J + 1; Symbol[J] := UpperCase[Symbol[i]]; end else begin J := J + 1; Symbol[J] := LowerCase[Symbol[i]]; end; for i := J + 1 to SymLen do Symbol[i] := ' '; SymLen := J; end else if FirstSpelling then AdjustSpelling else if not (LitCopy or PortabilityMode) then if UcIdents then for i := 1 to SymLen do Symbol[i] := UpperCase[Symbol[i]] else for i := 1 to SymLen do Symbol[i] := LowerCase[Symbol[i]]; end else begin if PortabilityMode or (not LitCopy) then if UcResWords then for i := 1 to SymLen do Symbol[i] := UpperCase[Symbol[i]] else for i := 1 to SymLen do Symbol[i] := LowerCase[Symbol[i]]; end; end; {set_symbol_case} procedure AlphaChar; begin {identifier or reserved word to symbol} NewInputLine := false; SymbolFound := true; while Ch in ['A'..'Z', 'a'..'z', '0'..'9', '_', '$'] do SymbolPut(Ch); TestResvWrd; SetSymbolCase(Sym); end {alpha char} ; {*--------* | Number | *--------*} procedure NumericChar; begin {unsigned number to symbol} NewInputLine := false; SymbolFound := true; Sym := Number; while (Ch >= '0') and (Ch <= '9') do {integer or fractional portion} SymbolPut(Ch); if Ch = '.' then begin SymbolPut(Ch); if Ch = '.' then begin {actually subrange, must fudge} SymLen := SymLen - 1; {erase period} DoublePeriod := true; end else while (Ch >= '0') and (Ch <= '9') do SymbolPut(Ch); end; if (Ch = 'E') or (Ch = 'e') then begin {exponential portion} SymbolPut('E'); if (Ch = '+') or (Ch = '-') then {sign} SymbolPut(Ch); while (Ch >= '0') and (Ch <= '9') do {characteristic} SymbolPut(Ch); end {exponential} else if (Ch = 'b') or (Ch = 'B') then SymbolPut('B') end {numeric char} ; {*-------------------* | Special Character | *-------------------*} procedure SpecialChar; begin {operators or delimiters to symbol} SymbolFound := true; {untrue only for comments} NewInputLine := false; case Ch of {special symbols} '+': begin {plus} Sym := Plus; SymbolPut(Ch); end {plus} ; '-': begin {minus} Sym := Minus; SymbolPut(Ch); end {minus} ; '*': begin {multiply} Sym := Mult; SymbolPut(Ch); end {multiply} ; '.': begin {subrange or period} Sym := Period; SymbolPut(Ch); if DoublePeriod then begin {fudge a subrange} Symbol[2] := '.'; SymLen := 2; Sym := Subrange; end else if Ch = '.' then begin {subrange} Sym := Subrange; SymbolPut(Ch); end else if Ch = ')' then begin {alternative right bracket} Sym := CloseBrack; if StandardRep then begin Symbol[1] := ']'; GetChar; end else SymbolPut(Ch); end; DoublePeriod := false; end {subrange or period} ; ',': begin {comma} Sym := Comma; SymbolPut(Ch); end {comma} ; ';': begin {semicolon} Sym := Semicolon; SymbolPut(Ch); end {semicolon} ; ':': begin {becomes, or colon} Sym := Colon; SymbolPut(Ch); if Ch = '=' then begin {becomes} Sym := Becomes; SymbolPut(Ch); end {becomes} end {becomes, or colon} ; '=': begin {equals} Sym := Equal; SymbolPut(Ch); end {equals} ; '<': begin {less than, less equal, not equal} Sym := RelOp; SymbolPut(Ch); if (Ch = '=') or (Ch = '>') then SymbolPut(Ch); end {less than, less equal, not equal} ; '>': begin {greater equal, greater than} Sym := RelOp; SymbolPut(Ch); if Ch = '=' then SymbolPut(Ch); end {great than, or great equals} ; '^', '@': begin {pointer} Sym := Pointer; if StandardRep then SymbolPut('^') else SymbolPut(Ch); end {pointer} ; '''': StringConstant; ')': begin {close parenthesis} Sym := CloseParen; SymbolPut(Ch); end {close parenthesis} ; '[': begin {open bracket} Sym := OpenBrack; SymbolPut(Ch); end {open bracket} ; ']': begin {close bracket} Sym := CloseBrack; SymbolPut(Ch); end {close bracket} ; end; {case} end {special_char} ; {*------------------* | Start of Comment | *------------------*} procedure CommentChar; var InitChar: Char; {starting character} begin {possible start of comment} if (Ch = '(') or (Ch = '/') then begin {see if comment or just open paren} InitChar := Ch; SymbolPut(Ch); if Ch = '*' then begin SymLen := 0; DoComment(NewInputLine, Column - 1, InitChar); end else if (InitChar = '(') and (Ch = '.') then begin {alternate representation of left bracket} if StandardRep then begin Symbol[1] := '['; GetChar; end else SymbolPut(Ch); Sym := OpenBrack; SymbolFound := true; end else begin if InitChar = '(' then Sym := OpenParen else Sym := Divide; NewInputLine := false; SymbolFound := true; end; end else DoComment(NewInputLine, Column, Ch); end; {comment_char} procedure LexicalDirective; var Id: WordType; P: 1..MaxWordLen; OnNewline: boolean; {was on a new line} begin {Process a Pascal-2 lexical directive. The only ones are "%include" and "%page", and these are simply passed to the output. Any others are treated as an identifier.} OnNewline := NewInputLine; NewInputLine := false; repeat SymbolPut(Ch); until (Ch = ' ') or (Ch = ';'); for P := 1 to MaxWordLen do if P > SymLen then Id[P] := ' ' else Id[P] := LowerCase[Symbol[P]]; SetSymbolCase(Andsy); {anything but identifier} if Id = '%include ' then begin if Ch = ' ' then SymbolPut(' '); while (Ch = ' ') do GetChar; repeat SymbolPut(Ch); until (Ch = ' ') or (Ch = ';'); if Ch = ';' then SymbolPut(Ch); end; if (Id = '%include ') or (Id = '%page ') then begin Sym := Identifier; if OnNewline then FormatLine(StatIndent); PutSym; SymWritten := false; SymLen := 0; end else AlphaChar; end; {lexical_directive} {*---------------------------* | Get Next Symbol (get_sym) | *---------------------------*} procedure GetSym; begin {extract next basic sym from text} SymLen := 0; SymbolFound := false; SymWritten := false; repeat if EndFile then begin Sym := TextEnd; SymbolFound := true end else if Ch = ' ' then ScanBlanks else begin if NoNewLine then EndLine := NewInputLine; case Ch of {lexical analysis} '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': NumericChar; 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '$': AlphaChar; ')', '*', '+', ',', '-', '.', ':', ';', '<', '=', '>', '[', ']', '^', '@', '''': SpecialChar; '(', '{', '/': CommentChar; '#', '!', '&', '?', '\', '`', '|', '~', '}', '"', '_': PrintChar; '%': LexicalDirective; else if Formatting and (Ch = Chr(Ff)) then begin PrintLine(0); PrintChar; Space(0); ClearBreaks; EndLine := true; end else GetChar; end end; until SymbolFound end {get_sym} ; procedure FudgeSymbol(WordLen: Integer; {length of word provided} Word: WordType {word to substitute} ); var i: 1..MaxWordLen; {induction var} begin {Fudges one reserved word into another. This is used to substitute a reserved word for the current symbol to improve compatibility between compilers.} for i := 1 to WordLen do if UcResWords then Symbol[i] := UpperCase[Word[i]] else Symbol[i] := LowerCase[Word[i]]; SymLen := WordLen; end; {fudge_symbol} {*-------------------------* | Parser Utility Routines | *-------------------------*} {*----------* | next_sym | *----------*} procedure NextSym; begin {output current sym and input next} if Sym <> TextEnd then begin {symbol} if not SymWritten then PutSym; GetSym; end {symbol} end {next_sym} ; {*-------* | check | *-------*} procedure Check(Fsym: SetOfSyms); begin {check if the next symbol is in fsym} if not (Sym in Fsym) then Abort(Syntax); end; {check} {*-----------* | Check sym | *-----------*} procedure CheckSym(Desired: Symbols); begin {abort if current symbol not desired, else next_sym} if Sym = Desired then NextSym else Abort(Syntax); end; {check_sym} {*-----------------* | Next on newline | *-----------------*} procedure NextOnNewline(Spacing, Delta: Integer); begin {space "spacing" lines, indent, put new symbol, and increment indent by "delta"} if NoNewLine then Spacing := 0 else if BlankLine or (CurrentLine = 0) then Spacing := Spacing - 1; repeat FormatLine(Indent); Spacing := Spacing - 1; until Spacing < 0; IndentPlus(Delta); StatIndent := Indent; NextSym; end; {next_on_newline} {*------------------* | Log symbol start | *------------------*} procedure LogSymbolStart(var Log: ColLog); begin {log the starting loc of the next symbol} with Log do begin LogChar := CharCount + 1; LogCol := WriteCol + 1; LogLine := CurrentLine; end; end; {log_symbol_start} {*--------------------* | Statement bunching | *--------------------*} procedure Bunch(Start: ColLog; {start of statement} var Success: Boolean); begin {move a statement up to the previous line if it will fit} with Start do if Formatting and (CharCount - LogChar < Bufsize) and (CharCount >= LogChar) and (LogLine + 1 = CurrentLine) and (WriteCol - Indent + LogCol < OutLineLen) then begin {move it up, adjusting things as we go} with Unwritten[LogChar mod Bufsize] do begin ActionIs := Spaces; Spacing := 1; WriteCol := WriteCol - Indent + LogCol + 1; end; CurrentLine := CurrentLine - 1; Success := true; end else Success := false; end; {bunch} {*------------------* | bunch_statements | *------------------*} procedure BunchStatement(Start: ColLog); var TabInt: Integer; {tab interval} NextTab: Integer; {next tab location} begin {see if we can put multiple statements on a line} if Formatting then with Start do begin TabInt := (OutLineLen - Indent) div StatsPerLine; if TabInt = 0 then TabInt := 1; if LogCol = Indent + 1 then LogCol := Indent; {fudge for start} NextTab := (LogCol - Indent + TabInt - 1) div TabInt * TabInt + Indent; if (NextTab > Indent) and (LogLine + 1 = CurrentLine) and (CharCount - LogChar < Bufsize) and (NextTab + WriteCol - Indent <= OutLineLen) then begin {move up to prior line and fiddle pointers} with Unwritten[LogChar mod Bufsize] do begin ActionIs := Spaces; Spacing := NextTab - LogCol + 1; end; WriteCol := NextTab + WriteCol - Indent; CurrentLine := CurrentLine - 1; end; end; end; {bunch_statement} procedure TerminalSemicolon; begin {Parse a possible terminal semicolon at the end of a statement. This is done this way to make sure that it gets indented properly} if (Sym = Semicolon) and not SymWritten then PutSym; end; {terminal_semicolon} {*-----------------------------* | Parser forward declarations | *-----------------------------*} procedure Statement; forward; procedure Expression; forward; procedure ExprList(BreakAt: Integer); forward; procedure ScanType; forward; procedure DoBlock; forward; {*-----------------* | Identifier list | *-----------------*} procedure IdentList; begin {Scan a list of identifiers separated by commas. Formatting is allowed to continue if a comma is missing } while Sym = Identifier do begin NextSym; if Sym = OriginSy then begin NextSym; Expression; end; if Sym = Comma then begin NextSym; SetSymbolBreak(0); end; end; end; {ident_list} {*----------* | Constant | *----------*} procedure Constant; begin {scan a constant} if Sym in [Plus, Minus] then NextSym; Check(Constants - [Plus, Minus]); NextSym; end; {constant} {*----------* | Variable | *----------*} procedure Variable; begin {scan off a variable, doesn't check much} while Sym in [Identifier, Period, Pointer, OpenBrack] do begin if Sym = OpenBrack then begin NextSym; ExprList(0); CheckSym(CloseBrack); end else NextSym; end; end; {variable} {*---------------* | Constant list | *---------------*} procedure ConstList; begin {scan a list of constants, as for case labels} while Sym in Constants do begin Constant; if Sym = Comma then begin NextSym; SetSymbolBreak(0); end; end; end; {const_list} {*--------* | Factor | *--------*} procedure Factor; begin {scan a factor in an expression, ignores precedence} if Sym = OpenParen then begin NextSym; ExprList(0); {hack to allow structured constants} CheckSym(CloseParen); if Sym = Comma then SetSymbolBreak(3); end else if Sym = OpenBrack then begin {set expression} NextSym; while Sym in ExprBegSys do begin ExprList(1); if Sym = Subrange then NextSym; end; CheckSym(CloseBrack); end else if Sym = Identifier then begin Variable; if Sym = OpenParen then begin PutSym; if WriteCol <= ThreeFourthLine then IndentPlus(WriteCol - Indent) else IndentPlus(0); NextSym; ExprList(3); CheckSym(CloseParen); Undent; end end else Constant; end; {factor} {*------------* | Expression | *------------*} procedure Expression; begin {scan an expression} while Sym in ExprBegSys do begin if Sym in [Plus, Minus, NotSy, Pointer] then NextSym; Factor; if Sym in [AndSy, OrSy] then begin NextSym; SetSymbolBreak(3); end else if Sym in RelOps then begin NextSym; SetSymbolBreak(2); end else if Sym in ArithOps then begin NextSym; SetSymbolBreak(1); end; end; {while} end; {expression} {*-----------------* | Expression list | *-----------------*} procedure ExprList; begin {scan a list of expressions} while Sym in ExprBegSys + [Comma] do begin if Sym in ExprBegSys then Expression; if (Sym = Comma) or (Sym = Colon) then begin NextSym; SetSymbolBreak(BreakAt); end; end; end; {expr_list} {*----------------------------* | Statement List (stat_list) | *----------------------------*} procedure StatList; var StatTerms: SetOfSyms; StatStart: ColLog; FirstStat: Boolean; begin {process a list of statements} StatTerms := StatSet + [Semicolon]; FirstStat := true; repeat LogSymbolStart(StatStart); Statement; {note: may or may not have semicolon} TerminalSemicolon; if (StatsPerLine > 1) and not FirstStat then BunchStatement(StatStart); {split like this so following comments don't screw up} if Sym = Semicolon then GetSym; FirstStat := false; until not (Sym in StatTerms); end; {state_list} {*----------------------------* | Compound statement (begin) | *----------------------------*} procedure DoBegin(ProcBlock: Boolean); var Trim: Integer; {amount to indent} begin {handle a begin - end block, indenting if requested by setting proc_block true} ResetCharCount; if ProcBlock then Trim := TabSpaces else Trim := 0; NextOnNewline(0, Trim); StatList; Undent; FormatLine(Indent); CheckSym(EndSy); end; {do_begin} {*-------------------------------* | Assignment and Procedure Call | *-------------------------------*} procedure DoAssignCall; begin {either assignment or call} FormatLine(Indent); IndentPlus(ContinueSpaces); Variable; if Sym = Becomes then begin NextSym; if WriteCol < ThreeFourthLine then IndentPlus(WriteCol - Indent + 1) else begin IndentPlus(0); SetSymbolBreak(0); end; Expression; TerminalSemicolon; Undent; end else if Sym = OpenParen then begin NextSym; if WriteCol <= ThreeFourthLine then IndentPlus(WriteCol - Indent) else IndentPlus(0); ExprList(3); CheckSym(CloseParen); TerminalSemicolon; Undent; end else TerminalSemicolon; Undent; end; {do_assign_call} {*----------------* | Goto statement | *----------------*} procedure DoGoto; begin {goto statement} FormatLine(Indent); NextSym; CheckSym(Number); TerminalSemicolon; end; {do_goto} {*-----------------* | While statement | *-----------------*} procedure DoWhile; var WhileStart: ColLog; {start of statement} StartLine, EndLine: Integer; {statement lines} Successful: Boolean; {bunching went} begin {while statement} ResetCharCount; FormatLine(Indent); NextSym; if WriteCol < ThreeFourthLine then IndentPlus(WriteCol - Indent + 1) else IndentPlus(ContinueSpaces); StartLine := CurrentLine; Expression; CheckSym(DoSy); Undent; IndentPlus(TabSpaces); EndLine := CurrentLine; LogSymbolStart(WhileStart); StatIndent := Indent; Statement; if Bunching and (StartLine = EndLine) then Bunch(WhileStart, Successful); Undent; end; {do_while} {*----------------* | With statement | *----------------*} procedure DoWith; var StartLine, EndLine: Integer; {starting and ending lines of heading} WithStart: ColLog; {start of statement} Successful: Boolean; {bunching went} begin {with_statement} ResetCharCount; FormatLine(Indent); NextSym; if WriteCol < ThreeFourthLine then IndentPlus(WriteCol - Indent + 1) else IndentPlus(ContinueSpaces); StartLine := CurrentLine; ExprList(3); CheckSym(DoSy); Undent; IndentPlus(TabSpaces); StatIndent := Indent; EndLine := CurrentLine; LogSymbolStart(WithStart); Statement; if Bunching and (StartLine = EndLine) then Bunch(WithStart, Successful); Undent; end; {do_with} {*--------------* | If statement | *--------------*} procedure DoIf(PrevElse: Boolean {set if previous sym was else} ); var IfStart: ColLog; {start of if statement} StartLine, EndLine: Integer; {statement lines} Successful: Boolean; {bunching went} begin {if statement} ResetCharCount; if not PrevElse then FormatLine(Indent); NextSym; if WriteCol < ThreeFourthLine then IndentPlus(WriteCol - Indent + 1) else IndentPlus(ContinueSpaces); StartLine := CurrentLine; Expression; CheckSym(ThenSy); Undent; IndentPlus(TabSpaces); EndLine := CurrentLine; LogSymbolStart(IfStart); Statement; if Bunching and (StartLine = EndLine) then Bunch(IfStart, Successful); Undent; StatIndent := Indent; if Sym = ElseSy then begin FormatLine(Indent); NextSym; if Sym = IfSy then DoIf(true) else begin IndentPlus(TabSpaces); LogSymbolStart(IfStart); Statement; if Bunching then Bunch(IfStart, Successful); Undent; end; end; end; {do_if} {*----------------* | Case statement | *----------------*} procedure DoCase; var CaseStart: ColLog; {start of case} Successful: Boolean; {bunching successful} LabStart, LabEnd: Integer; {label list lines} begin {case_statement} ResetCharCount; FormatLine(Indent); NextSym; if WriteCol < ThreeFourthLine then IndentPlus(WriteCol - Indent + 1) else IndentPlus(ContinueSpaces); Expression; CheckSym(OfSy); Undent; IndentPlus(TabSpaces); StatIndent := Indent; while not (Sym in [EndSy, OtherwiseSy, ElseSy]) do begin if Sym in Constants then begin FormatLine(Indent); LabStart := CurrentLine; ConstList; CheckSym(Colon); LabEnd := CurrentLine; IndentPlus(TabSpaces); LogSymbolStart(CaseStart); Statement; if Bunching and (LabStart = LabEnd) then Bunch(CaseStart, Successful); Undent; StatIndent := Indent; end; {if sym in constants} if Sym = Semicolon then NextSym; Check(Constants + [EndSy, Semicolon, OtherwiseSy, ElseSy]); end; {while} if (Sym = OtherwiseSy) or (Sym = ElseSy) then begin if OtherwiseKluge then FudgeSymbol(9, 'otherwise'); NextOnNewline(0, TabSpaces); LogSymbolStart(CaseStart); StatList; if Bunching then Bunch(CaseStart, Successful); Undent; end; FormatLine(Indent); CheckSym(EndSy); Undent; end; {do_case} {*------------------* | Repeat statement | *------------------*} procedure DoRepeat; begin {repeat statement} ResetCharCount; NextOnNewline(0, TabSpaces); StatList; Undent; StatIndent := Indent; FormatLine(Indent); CheckSym(UntilSy); if WriteCol < ThreeFourthLine then IndentPlus(WriteCol - Indent + 1) else IndentPlus(ContinueSpaces); Expression; TerminalSemicolon; Undent; end; {do_repeat} {*---------------* | For statement | *---------------*} procedure DoFor; var StartLine, EndLine: Integer; {starting and ending lines of header} ForStart: ColLog; {start of controlled statement} Successful: Boolean; {bunching went} begin {for statement} ResetCharCount; NextOnNewline(0, ContinueSpaces); StartLine := CurrentLine; CheckSym(Identifier); CheckSym(Becomes); Expression; Check([ToSy, DowntoSy]); NextSym; Expression; CheckSym(DoSy); Undent; IndentPlus(TabSpaces); EndLine := CurrentLine; LogSymbolStart(ForStart); Statement; if Bunching and (StartLine = EndLine) then Bunch(ForStart, Successful); Undent; end; {do_for} {*-----------* | Statement | *-----------*} procedure Statement; begin {handle a (possibly empty) statement} StatIndent := Indent; if Sym = Number then begin IndentPlus( - TabSpaces); FormatLine(Indent); NextSym; CheckSym(Colon); Undent; end; if Sym in (StatSet - [Number]) then case Sym of BeginSy: DoBegin(false); CaseSy: DoCase; ForSy: DoFor; GotoSy: DoGoto; Identifier: DoAssignCall; IfSy: DoIf(false); RepeatSy: DoRepeat; WhileSy: DoWhile; WithSy: DoWith; end; {case} StatIndent := Indent; end; {statement} {*-----------------------* | Formal Parameter List | *-----------------------*} procedure Parameters; begin {format a formal parameter list: if they start less than halfway across the page, they are all lined up with the first parameter, on successive lines. If they start more than halfway across the page, they begin on the next line, indented double the usual (arbitrary)} if WriteCol > OneHalfLine then FormatLine(Indent + 2 * TabSpaces); NextSym; IndentPlus(WriteCol - Indent); while Sym in [Identifier, FunctionSy, ProcedureSy, VarSy] do begin if Sym in [FunctionSy, ProcedureSy] then begin IndentPlus(ContinueSpaces); NextSym; CheckSym(Identifier); if Sym = OpenParen then Parameters; end else begin if Sym <> Identifier then NextSym; if Sym <> Identifier then Abort(Syntax); IndentPlus(ContinueSpaces); IdentList; end; Undent; if Sym = Colon then begin NextSym; scantype; end; if Sym = Semicolon then begin NextSym; FormatLine(Indent); end; end; CheckSym(CloseParen); TerminalSemicolon; Undent; end; {parameters} {*------------* | Field list | *------------*} procedure FieldList; var InvarPart: Boolean; {true if there was an invarient part} labelstart, labelend: Integer; {lines for case label bunching} CaseStart: ColLog; {start of a variant} Successful: Boolean; {dummy param} begin {scan field list of type specification } InvarPart := false; while Sym = Identifier do begin InvarPart := true; IndentPlus(ContinueSpaces); IdentList; CheckSym(Colon); Undent; ScanType; if Sym = Semicolon then NextSym; if Sym = Identifier then FormatLine(Indent); end; if Sym = CaseSy then begin {case} if InvarPart then FormatLine(Indent); NextSym; IndentPlus(ContinueSpaces); if Sym = Identifier then NextSym else ScanType; if Sym = Colon then begin NextSym; ScanType end; CheckSym(OfSy); Undent; IndentPlus(TabSpaces); StatIndent := Indent; FormatLine(Indent); repeat {variant part} labelstart := CurrentLine; ConstList; CheckSym(Colon); labelend := CurrentLine; IndentPlus(TabSpaces); StatIndent := Indent; LogSymbolStart(CaseStart); FormatLine(Indent); CheckSym(OpenParen); IndentPlus(1); {compensate for paren} FieldList; Undent; CheckSym(CloseParen); Undent; StatIndent := Indent; if Sym = Semicolon then NextSym; if Bunching and (labelstart = labelend) then Bunch(CaseStart, Successful); if not (Sym in [EndSy, CloseParen]) then FormatLine(Indent); until not (Sym in Constants); Undent; StatIndent := Indent; end {case} end; {field_list} {*-------------* | Record type | *-------------*} procedure RecordType(PackedStart: ColLog); begin {handle a record type, includes a kluge to move "packed" down to the next line} IndentPlus(TabSpaces); with PackedStart do if Formatting and (LogChar <> 0) and (CharCount - LogChar < Bufsize) then with Unwritten[LogChar mod Bufsize] do begin {note that this kluge assumes the logged point has become a space so it can be changed to a newline} ActionIs := BeginLine; Spacing := Indent; WriteCol := Indent + WriteCol - LogCol; CurrentLine := CurrentLine + 1; end else FormatLine(Indent); NextSym; IndentPlus(TabSpaces); StatIndent := Indent; FormatLine(Indent); FieldList; Undent; FormatLine(Indent); CheckSym(EndSy); TerminalSemicolon; Undent; end; {record_type} {*------------* | Array type | *------------*} procedure ArrayType; begin {format an array type} IndentPlus(TabSpaces); NextSym; SetSymbolBreak(0); CheckSym(OpenBrack); while Sym in Constants do begin Constant; if Sym = Subrange then begin NextSym; Constant; end; if Sym = Comma then begin NextSym; SetSymbolBreak(0); end; end; {while} CheckSym(CloseBrack); CheckSym(OfSy); ScanType; TerminalSemicolon; Undent; end; {array_type} {*------------------* | Enumeration type | *------------------*} procedure EnumType; begin {handle an enumeration type, align to the right of the opening parenthesis if there is room, otherwise use normal continuation} NextSym; if WriteCol <= ThreeFourthLine then IndentPlus(WriteCol - Indent) else IndentPlus(ContinueSpaces); IdentList; CheckSym(CloseParen); TerminalSemicolon; Undent; end; {enum_type} {*-----------* | Scan type | *-----------*} procedure ScanType; var PackedStart: ColLog; begin {scan a type, formatting differs for each one} IndentPlus(ContinueSpaces); if Sym = PackedSy then begin {mark start of 'packed' - must actually be a space} LogSymbolStart(PackedStart); NextSym; end else PackedStart.LogChar := 0; Undent; Check(TypeBegSys); case Sym of OpenParen: EnumType; ArraySy: ArrayType; FileSy, SetSy: begin NextSym; CheckSym(OfSy); ScanType; end; Identifier, Number, Plus, Minus, String: begin {simple or subrange} Constant; if Sym = Subrange then begin NextSym; Constant; end; end; Pointer: begin NextSym; ScanType; end; RecordSy: RecordType(PackedStart); end; {case} StatIndent := Indent; end; {scan_type} {*-------------------* | Label Declaration | *-------------------*} procedure DoLabel; begin {label declaration} ResetCharCount; NextOnNewline(1, TabSpaces); FormatLine(Indent); while Sym = Number do begin NextSym; if Sym = Comma then NextSym; end; {while} CheckSym(Semicolon); Undent; end; {*----------------------* | Constant Declaration | *----------------------*} procedure DoConst; var ConstStart: ColLog; {start of particular declaration} FirstConst: Boolean; {first constant in decl} begin {constant declaration} ResetCharCount; NextOnNewline(1, TabSpaces); FirstConst := true; while Sym = Identifier do begin LogSymbolStart(ConstStart); FormatLine(Indent); NextSym; CheckSym(Equal); ExprList(0); {hack to allow structured constants} if Sym = Semicolon then PutSym else Abort(Syntax); if (StatsPerLine > 1) and not FirstConst then BunchStatement(ConstStart); NextSym; {split so comments format right} FirstConst := false; end; {while} Undent; StatIndent := Indent; end; {do_const} {*------------------* | Type Declaration | *------------------*} procedure DoType; begin {type_declaration} NextOnNewline(1, TabSpaces); while Sym = Identifier do begin ResetCharCount; FormatLine(Indent); NextSym; CheckSym(Equal); ScanType; CheckSym(Semicolon); end; {while} Undent; StatIndent := Indent; end; {do_type} {*-----------------* | Var Declaration | *-----------------*} procedure DoVar; begin {var declaration} NextOnNewline(1, TabSpaces); while Sym = Identifier do begin ResetCharCount; FormatLine(Indent); IndentPlus(ContinueSpaces); Check([Identifier]); IdentList; CheckSym(Colon); Undent; ScanType; CheckSym(Semicolon); end; {while} Undent; StatIndent := Indent; end; {do_var} {*---------* | Program | *---------*} procedure DoProgram; begin {program or processor} NextOnNewline(0, ContinueSpaces); CheckSym(Identifier); if Sym = OpenParen then begin NextSym; while Sym = Identifier do begin NextSym; if Sym = Comma then begin NextSym; SetSymbolBreak(0); end; end; CheckSym(CloseParen); end; CheckSym(Semicolon); Undent; IndentPlus(TabSpaces); DoBlock; if Sym = Period then NextSym; Undent; end; {do_program} {*-----------------------* | Procedure Declaration | *-----------------------*} procedure DoProcedure; var StartSym: Symbols; begin {procedure} ResetCharCount; StartSym := Sym; NextOnNewline(2, ContinueSpaces); CheckSym(Identifier); if Sym = OpenParen then Parameters; if StartSym = FunctionSy then if Sym = Colon then begin {if function was declared forward, the second appearance has no result type} CheckSym(Colon); CheckSym(Identifier); end; TerminalSemicolon; Undent; CheckSym(Semicolon); IndentPlus(TabSpaces); if Sym in [ExternSy, FortranSy, ForwardSy, NonpascalSy, Identifier] then begin FormatLine(Indent); NextSym; end else if Sym in BlockBegSys then DoBlock else Abort(Syntax); if Sym = Semicolon then begin PutSym; Undent; StatIndent := Indent; NextSym; end else Abort(Syntax); end; {procedure} {*-------* | Block | *-------*} procedure DoBlock; begin {scan a block, including types, etc} StatIndent := Indent; while Sym in HeadingBegSys do begin {declarations} case Sym of LabelSy: DoLabel; ConstSy: DoConst; TypeSy: DoType; VarSy: DoVar; ProcedureSy, FunctionSy: DoProcedure; end; StatIndent := Indent; end; {while} if Sym = BeginSy then begin FormatLine(Indent); DoBegin(true); end; end; {do_block} {*----------------------------* | PROGRAM LOOP: process_text | *----------------------------*} procedure ProcessText; begin {process text} ClearBreaks; if Sym = ProgramSy then DoProgram else if Sym in BlockBegSys then begin DoBlock; if Sym = Semicolon then NextSym; if Sym = Period then NextSym; {set of external procs} end else if Sym in StatSet then StatList; Check([TextEnd]); FlushBuffer; end {process text} ; {*--------------------* | BEGIN PRETTY-PRINT | *--------------------*} begin {pretty-print} Initialize; ReadCommandLine; if initialdirectives then begin DoFormatterDirectives(throwaway); Formatting := NewFormatting; NoNewLine := NewNoNewLine; end else GetChar; {lead one char} GetSym; {lead one symbol} ProcessText; FinalData; 99: end {pasmat} .