(*&D+*) (*$c+ *) (*Contents*) (*Page description*) (*01*) (*02*) (* Title page *) (*03*) (*Description and history*) (*04*) (*Valid switches*) (*05*) (*Start of program*) (*06*) (*Var*) (*07*) (*Initialization:*) (*Initprocedures,hash,find_sy,firstdef,reinitialize,initialize*) (*08*) (*Ccl scanner:*) (*Getdirectives[setswitch]*) (*09*) (*Page control:*) (*Newpage*) (*10*) (*Output procs:*) (*Block[error,writeline,vardef,procdef,popoff*) (*11*) (*Scanner:*) (*Insymbol[readbuffer[readline],resword,proccall*) (*12*) (*Parenthese,docomment[nextchar,options]*) (*13*) (*] Insymbol*) (*14*) (*Parsing of declarations:*) (*Recdef[casedef,parenthese]*) (*15*) (*Parsing of statements:*) (*Statement[endedstatseq,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*) (*16*) (*] Block*) (*17*) (*Main program*) (*02*) (*Title page*) (********************************************************************** * * * P f o r m * --------- * * Reformats (prettyprints) a pascal source program. * * Input: pascal source file. (oldsource) * Output: reformatted source file. (newsource) * * Default input extension: none. * Default output extension: .new * Default output file name: same as the input name, with extension .new * * Machine dependency: uses features supported by the pascal/passgo * compilers for DEC-10, DEC-20, as implemented by Armando R. Rodriguez * at Stanford University. * * Implementor: Armando R. Rodriguez * P.O. Box 5771 * Stanford, CA 94305 * U.S.A. * * Distributor: J. Q. Johnson * LOTS computer facility * Stanford University * Stanford, CA 94305 * U.S.A. * * From an original cross-reference processor written by * Manuel Mall, University of Hamburg (1974) and distributed * with the Hamburg compiler for DEC-10, DEC-20 computers, by Decus. * * * Part of the developement effort applied to this programs was * performed as part of the effort in developement of programming * languages and compilers at Stanford University, under a subcontract * from LawrenceLivermore Laboratory to the computer science department, * principal investigarors Profs. Forest Baskett and John Hennessy, * contract no. ... LLL PO9628303. The S-1 work hardware development * has been supported by the department of the navy via office of naval * research order numbers 00014-76-F-0023, N00014-77-F-0023, and * N00014-78-F-0023 to the University of California Lawrence Livermore * Laboratory (which is operated for the U.S. Department of Energy * under contract no. W-7405-ENG-48), from the computations group of * the Stanford Linear Accelerator Center (supported by the U.S. * Department of Energy under contract no. EY-76-C-03-0515), and from * the Stanford Artificial Intelligence Laboratory (which receives * support from the Defense Advanced Research Projects Agency and the * National Science Foundation). * (********************************************************************** (*03*) (*Description and history*) (********************************************************************** * * May-80. Richard J. Beigel * + implement capitalization of procedure names * + fix newpage to not eat the first page mark * + change some defaults * * Apr-80. Richard J. Beigel * + add the super switch * + add the quiet switch * + add the bar switch. * + fix indention algorithm (mostly) * + improve docomment (no longer capitalize i.e., e.g., p.o., * and the like) * + implement runtime switches * * Feb-80. Richard J. Beigel * + fix bugs in docomment and recdef * + add the capitalize switch * + add the setco m switch * + add the denny switch * * Jul-79. Armando R. Rodriguez. * + separate it into pform and pcref * + adapt it for the lineprinter at sail. * + improve the implementation of statement counts. * + fix bugs * * Mar-79. Armando R. Rodriguez * + implement statement counts. * * Dec-78. Armando R. Rodriguez (Stanford) * + speed up and cleanning of the code. * + fix small bugs. * * Jul-78. Armando R. Rodriguez (Stanford). * + improve the cross reference listing. * + listing of proc-func call nesting. * + report the line numbers of begin and end of body of procedures. * * Mar-78. Armando R. Rodriguez (Stanford). * + a new set of switch options. * + some new errors are reported. * * Date unknown. Larry Paulson (Stanford). * + make the files of type text * + not as many forced newlines. * + the report on procedure calls was cancelled. * * (**********************************************************************) (*04*) (*Valid switches*) (*--------------------------------------------------------------------- ! ! Valid switches are: brackets indicate optional. ! stands for an integer number. ! (defaults in parens are at SAIL) stands for a letter. ! ! Switch meaning default. ! ! Files. ! /Version: behave as if conditionally compiling % ! comments. -1 ! ! Page and line format ! /Indent: indentation between levels. 4 ! /Save-comment if set, causes indentation of comments to be ! preserved. Otherwise, they will be ! indented like statements. Off ! ! /Bar [*] causes comments ! * like this one ! * to be indented correctly. ! [*] (with parentheses of course) ! ! Statement format ! /Begin:[-] if the [-] is not there, the contents of a ! begin..end block is indented n spaces further. ! If it is there, the block will not be indented, ! but the begin and end statements will be ! exdented n spaces. -2 ! (or as specified by /indent) ! ! /[No]force forces newline in standard places. (Before and ! after begin, end, then, else, repeat, etc.) Off ! ! /[No]super forces newline after semicolon and sets force ! (no need to specify the /force option) off ! ! /[No]preserve preserves your own indentation off ! ! /[No]denny puts programs into denny brown's format. ! it is not compatible with /begin:. ! ! It sets endexd to -feed overriding /begin. ! It also prevents the /force ! option from causing newline after do, else, or ! then. Also puts reserved words into lower case, ! unless you specify otherwise. Off ! ! Upper and lower case ! Note: the possible values for are: ! U means upper case. ! L means lower case. ! C means capitalize where appropriate. ! S means same case -- unchanged ! ! /Res: case used for reserved words. U ! /Nonres: case for non-reserved words. L ! /Comm: case for comments. S ! /Str: case for strings. S ! /Proc: case for procedures C ! /Case: resets all the defaults to . Off ! ! ! If set, the c switch will capitalize sentences in comments, put ! strings in all-capitals, and capitalize reserved words and ! identifers. ! ! Miscellaneous switches. ! /Quiet suppress runtime progress reports. ! +--------------------------------------------------------------------*) (*05*) program Pform; include 'p:pascmd.pas','p:string.pas'; const ht = 9; nul = 0; version = 'PFORM/LOTS 1.1 4-SEP-80'; verlength = 10; backslash = '\'; linsize = 600; (*Maximum size of an input line*) linsiz1plus = 601; (*Linsize + 1*) linsizplus2 = 602; (*Linsize + 2*) blanks = ' '; (*For initializing strings*) maxinc = 4000; (*Maximum allowable line number*) linnumsize = 5; tablesize = 996; (* For hash table of procedure names *) oneplustablesize = 997; undefined = 0; uppercase = 1; samecase = 2; lowercase = 3; capitalize = 4; type casetype = undefined..capitalize; pack6 = packed array[1..6] of char; pack9 = packed array[1..9] of char; pack15 = packed array[1..15] of char; errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit, missgrpar,missgquote,missgmain,missgpoint,linetoolong, missgrbrack,missguntil,missgcommentend); symbol = (labelsy,constsy,typesy,varsy,programsy, (*Decsym*) functionsy,proceduresy,initprocsy, (*Prosym*) endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*Endsymbols*) beginsy,casesy,loopsy,repeatsy,ifsy, (*Begsym*) recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,(*Langsy,*)forsy,whilesy, (* Langsy is unnecessary: 'fortran' translates to externsy *) rbracket,rparent,semicolon,comma,point,lparent,lbracket,colon,eqlsy,otherssy(*Delimiter*)); linenrty = 0..maxint; pagenrty = 0..maxint; stacktype = packed record top: boolean; next: ^stacktype; end; entry = packed record (* A linked list (for procedure names) *) string: alfa; next: ^entry; stack: ^stacktype; end; list = ^entry; tableindex = 0..tablesize; (*06*) (* Variable declarations *) var pm: char; rtime: integer; definitions: integer; proctable, baretable: array[tableindex] of list; (* (*Input control*) (* (***************) bufflen, (*Length of the current line in the input buffer*) buffmark, (*Length of the already printed part of the buffer*) bufferptr, (*Pointer to the next character in the buffer*) syleng: integer; (*Length of the last read identifier or label*) (* (*Nesting and matching control*) (* (******************************) level, (*Nesting depth of the current procedure*) variant_level, (*Nesting depth of variants*) errcount: integer; (*Counts the errors encountered*) (* (*Formatting*) (* (************) indentbegin, (*Indentation after a begin*) begexd, (*Exdentation for begin*) endexd, (* Exdentation for end *) feed, (*Indentation by procedures and blocks*) spacepreserve, (* Number of spaces at the beginning of a line -- if we are preserving*) nextspaces, (* Indentation for the next line as computed so far *) presentspaces, (* Indentation for current line *) goodversion, (*Keeps the value of the version option*) pagecnt, (*Counts the file pages*) line500, (*To give a tty message every 500 lines*) linecnt : integer; (*Counts the lines per file page*) tabs: array [1:17] of char; (* A string of tabs for formatting*) lower, upper: array [char] of char; (* for changing cases *) (* (*Scanning*) (* (**********) buffer : array [-1..linsizplus2] of char; (*Input buffer*) (* Buffer has 2 extra positions on the left and one on the right*) linenb : packed array [1..5] of char; (*Sos-line number*) prog_name: alfa; (*Name of current program*) sy : alfa; (*Last symbol read*) syty : symbol; (*Type of the last symbol read*) (* (*Version system*) (* (****************) (* (*Switches*) (* (**********) savecom, (* Set if comments get indentation preserved *) elseifing, (*Set if the sequence else if should stay in one line*) (* Debugging, (not implemented) *) (*Set if the unprinted counts are to be reported*) forcing, (*Set if then, else, do, repeat, etc. Will force newline*) super, (*Forcing and putting newline after semicolon*) preserving, (* Preserving indentation *) dennying, (* Denny brown's format *) barring, (*) Comments set up * like this comment *) (* (*) quiet, (* Don't give runtime progress reports (doesn't affect format) *) counting, (*Counting functions and procedures*) anyversion: boolean; (*Set if goodversion > 9*) (* The following switches tell whether to capitalize, make all upper case or make all lower case the following: *) rescase, (* Reserved words *) nonrcase, (* Nonreserved words *) comcase, (* Comments *) proccase, (* Procedure calls *) strcase (* Strings *) : casetype; (* (*Other controls*) (* (****************) comment_at_boln, (* Comment is at beginning of line: required for constant indentation *) notokenyet, (*Set in each line until the first token is scanned*) thenbeginning, (* Removing crlf from between then and begin for /denny *) endelseing, (* Removing crlf from between end and else for /denny *) thendo, (*Set whenever 'nextspaces := nextspaces+dofeed' is executed*) elsehere, (*Set while an else token is to be printed*) fwddecl, (*Set true by block after 'forward', 'extern'*) oldspaces, (*Set when presentspaces should be used -- usually means beginnning of line*) eoline, (*Set at end on input line*) programpresent, (*Set after program encountered*) nobody, (*Set if no main body is found*) invars, (*While parsing var and type declarations*) eob : boolean; (*Eof-flag*) errmsg : packed array[errkinds,1..40] of char; (*Error messages*) ch : char; (*Last read character*) (* (*Sets*) (* (******) delsy : array [' '..'_'] of symbol; (*Type array for delimiter characters*) resnum: array['A'..'['] of integer; (*Index of the first keyword beginning with the indexed letter*) reslist : array [1..46] of alfa; (*List of the reserved words*) ressy : array [1..46] of symbol; (*Type array of the reserved words*) alphanum, (*Characters from 0..9 and a..z*) digits : set of char; (*Characters from 0..9*) openblocksym, (*Symbols after which a basic block starts*) relevantsym, (*Start symbols for statements and procedures*) prosym, (*All symbols which begin a procedure*) decsym, (*All symbols which begin declarations*) begsym, (*All symbols which begin compound statements*) endsym : set of symbol; (*All symbols which terminate statements or procedures*) (* (*Pointers and files*) (* (********************) old_name: pack9; oldsource: text; oldfilename: packed array[1..50] of char; newsource: text; newfilename: packed array[1..50] of char; (*07*) (*Initialization:*) (*Initprocedures,reinitialize,initialize*) initprocedure; begin (*Reserved words*) resnum['A'] := 1; resnum['B'] := 3; resnum['C'] := 4; resnum['D'] := 6; resnum['E'] := 9; resnum['F'] := 13; resnum['G'] := 18; resnum['H'] := 19; resnum['I'] := 19; resnum['J'] := 22; resnum['K'] := 22; resnum['L'] := 22; resnum['M'] := 24; resnum['N'] := 25; resnum['O'] := 27; resnum['P'] := 30; resnum['Q'] := 33; resnum['R'] := 33; resnum['S'] := 35; resnum['T'] := 36; resnum['U'] := 39; resnum['V'] := 40; resnum['W'] := 41; resnum['X'] := 43; resnum['Y'] := 43; resnum['Z'] := 43; resnum['['] := 43; reslist[ 1] :='AND '; ressy [ 1] := othersy; reslist[ 2] :='ARRAY '; ressy [ 2] := othersy; reslist[ 3] :='BEGIN '; ressy [ 3] := beginsy; reslist[ 4] :='CASE '; ressy [ 4] := casesy; reslist[ 5] :='CONST '; ressy [ 5] := constsy; reslist[ 6] :='DO '; ressy [ 6] := dosy; reslist[ 7] :='DIV '; ressy [ 7] := othersy; reslist[ 8] :='DOWNTO '; ressy [ 8] := othersy; reslist[ 9] :='END '; ressy [ 9] := endsy; reslist[10] :='ELSE '; ressy [10] := elsesy; reslist[11] :='EXIT '; ressy [11] := exitsy; reslist[12] :='EXTERN '; ressy [12] := externsy; reslist[13] :='FOR '; ressy [13] := forsy; reslist[14] :='FILE '; ressy [14] := othersy; reslist[15] :='FORWARD '; ressy [15] := forwardsy; reslist[16] :='FUNCTION '; ressy [16] := functionsy; reslist[17] :='FORTRAN '; ressy [17] := externsy; reslist[18] :='GOTO '; ressy [18] := gotosy; reslist[19] :='IF '; ressy [19] := ifsy; reslist[20] :='IN '; ressy [20] := othersy; reslist[21] :='INITPROCED'; ressy [21] := initprocsy; reslist[22] :='LOOP '; ressy [22] := loopsy; reslist[23] :='LABEL '; ressy [23] := labelsy; reslist[24] :='MOD '; ressy [24] := othersy; reslist[25] :='NOT '; ressy [25] := othersy; reslist[26] :='NIL '; ressy [26] := othersy; reslist[27] :='OR '; ressy [27] := othersy; reslist[28] :='OF '; ressy [28] := ofsy; reslist[29] :='OTHERS '; ressy [29] := otherssy; reslist[30] :='PACKED '; ressy [30] := othersy; reslist[31] :='PROCEDURE '; ressy [31] := proceduresy; reslist[32] :='PROGRAM '; ressy [32] := programsy; reslist[33] :='RECORD '; ressy [33] := recordsy; reslist[34] :='REPEAT '; ressy [34] := repeatsy; reslist[35] :='SET '; ressy [35] := othersy; reslist[36] :='THEN '; ressy [36] := thensy; reslist[37] :='TO '; ressy [37] := othersy; reslist[38] :='TYPE '; ressy [38] := typesy; reslist[39] :='UNTIL '; ressy [39] := untilsy; reslist[40] :='VAR '; ressy [40] := varsy; reslist[41] :='WHILE '; ressy [41] := whilesy; reslist[42] :='WITH '; ressy [42] := othersy; end (*Reserved words*); initprocedure; begin (*Sets*) digits := ['0'..'9']; alphanum := ['0'..'9','A'..'Z'] (*Letters or digits*); decsym := [labelsy,constsy,typesy,varsy,programsy]; prosym := [functionsy..initprocsy]; endsym := [functionsy..eobsy]; (*Prosym or endsymbols*) begsym := [beginsy..ifsy]; relevantsym := [labelsy..initprocsy (*Decsym or prosym*),beginsy,forwardsy,externsy,eobsy]; openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy] end (*Sets*); initprocedure; begin (*Error messages*) errmsg[begerrinblkstr] := 'Error in block structure: BEGIN expected'; errmsg[missgend ] := 'Missing ''END'' statement '; errmsg[missgthen ] := 'Missing ''THEN'' for ''IF'' '; errmsg[missgof ] := 'Missing ''OF'' in ''CASE'' '; errmsg[missgexit ] := 'Missing ''EXIT'' in ''LOOP'' '; errmsg[missgrpar ] := 'Missing right parenthesis '; errmsg[missgquote ] := 'Missing closing quote on this line '; errmsg[missgmain ] := 'WARNING: This file has no main body '; errmsg[missgpoint ] := 'Missing closing point at end of program.'; errmsg[linetoolong ] := 'Line too long. I''m gonna get confused. '; errmsg[missguntil ] := 'Missing ''UNTIL'' for ''REPEAT'' '; errmsg[missgrbrack ] := 'Missing right bracket '; errmsg[missgcommentend]:= 'Missing close comment at end of program.'; end (*Error messages*); procedure Quit; extern; function rescanit:integer; extern; procedure reljfn(var f:file); extern; procedure getname(var f:file;var s:string); extern; function Min(a,b: integer): integer; begin if a <= b then Min := a else Min := b; end; (* min *) function Max(a,b: integer): integer; begin if a >= b then Max := a else Max := b; end; (* max *) (*08*) procedure Startfiles; const casescount = 4; optioncount = 19; swversion = 1; swtas = 2; swsuper = 3; swstr = 4; swsave_comment = 5; swres = 6; swquiet = 7; swproc = 8; swpreserve = 9; swnonres = 10; swindent = 11; swforce = 12; swelseif = 13; swcount = 14; swcase = 15; swbegin = 16; swbar = 17; swcomm = 18; var help,cases,options,calltable: table; i: integer; eachcase: casetype; rescanning: boolean; procedure Defineoptions; const invisible = 1; var rstring: packed array[1..1] of char; begin calltable := tbmak(4); tbadd(calltable,1,'START',0); tbadd(calltable,1,'RUN',0); tbadd(calltable,1,'ERUN',0); rstring[1] := 'R'; tbadd(calltable,1,rstring,0); help := tbmak(1); tbadd(help,1,'HELP',0); cases := tbmak(casescount); tbadd(cases,uppercase,'UPPERCASE',0); tbadd(cases,samecase,'SAMECASE',0); tbadd(cases,lowercase,'LOWERCASE',0); tbadd(cases,capitalize,'CAPITALIZE',0); options := tbmak(optioncount); tbadd(options,swversion,'VERSION:',0); tbadd(options,swtas,'TASMANIAN',0); tbadd(options,swsuper,'SUPER',0); tbadd(options,swstr,'STRING-CASE:',0); tbadd(options,swsave_comment,'SAVE-COMMENT',invisible); tbadd(options,swres,'RESERVED-CASE:',0); tbadd(options,swquiet,'QUIET',invisible); tbadd(options,swproc,'PROCEDURE-CASE:',0); tbadd(options,swpreserve,'PRESERVE',invisible); tbadd(options,swnonres,'NONRESERVED-CASE:',0); tbadd(options,swindent,'INDENT:',0); tbadd(options,swforce,'FORCE',0); tbadd(options,swelseif,'ELSEIF',0); tbadd(options,swtas,'DENNY',invisible); tbadd(options,swcount,'COUNT',invisible); tbadd(options,swcomm,'COMMENT-CASE:',0); tbadd(options,swcase,'CASE:',0); tbadd(options,swbegin,'BEGIN:',0); tbadd(options,swbar,'BAR',0); end; (* defineoptions *) procedure Setdefaults; begin goodversion := -1; anyversion := false; dennying := false; super := false; strcase := samecase; savecom := false; rescase := uppercase; quiet := false; proccase := capitalize; preserving := false; nonrcase := lowercase; feed := 4; forcing := false; elseifing := false; counting := false; comcase := samecase; eachcase := undefined; indentbegin := 0; begexd := 0; endexd := 0; barring := false; end; (* setdefaults *) procedure Getoptions; begin if goodversion > 9 then begin goodversion := -1; anyversion := true; end; if feed < 0 then begin feed := 4; end; if indentbegin < 0 then begin begexd := -indentbegin; endexd := begexd; indentbegin := 0; end else begin begexd := 0; endexd := 0; end; if dennying then begin begexd := feed; indentbegin := 0; endexd := feed; rescase := lowercase; end; if eachcase <> undefined then begin rescase := eachcase; nonrcase := eachcase; comcase := eachcase; strcase := eachcase; proccase := eachcase; end; end; (* getoptions *) procedure Errcheck; begin if cmerr then begin cmerrmsg; Quit; end; end; procedure Startold; begin gjgen(100000000000B); (* get an input file *) cmauto(false); (* turn off automatic error handling *) gjext('PAS'); (* try a file with pas extension *) cmfil(oldsource); if cmerr then begin (* try pgo extension *) gjext('PGO'); cmfil(oldsource); end; if not rescanning then begin cmauto(true); end; if cmerr then begin (* OK, any old extension *) cmifi(oldsource); end; Errcheck; end; (* Startold *) procedure Readrescanned; const rscan = 500B; rljfn = 23B; begin cmauto(false); (* error handling off *) i := rescanit; (* read the rscan buffer *) rescanning := i > 0; (* any characters in buffer *) if rescanning then begin (* rescanning := cmkey(calltable)=0; (* not called via "run", etc. *) end; if rescanning then begin (* Note: From pascal this is the preferred way to parse a field*) (* The next three lines get and release a jfn on the filespec *) (* PFORM *) gjgen(40000000B); (* get a fake jfn on PFORM *) cmfil(oldsource); (* not really the source, just a dummy *) reljfn(oldsource); (* release the jfn *) cmcfm; rescanning := cmerr; (* cmerr means something is left *) end; end; (* readrescanned *) procedure Startnew; const jfns = 30B; fieldlength = 39; flplus5 = 44; var oldname: packed array[1..fieldlength] of char; newname: packed array[1..flplus5] of char; ptr: integer; begin getname(oldsource,oldname); if rescanning then begin (* construct the name of newsource by hand *) ptr := 1; while (oldname[ptr] <> Chr(0)) and (ptr < 39) do begin newname[ptr] := oldname[ptr]; ptr := ptr + 1; end; if oldname[ptr] <> Chr(0) then begin ptr := ptr + 1; end; newname[ptr] := '.'; newname[ptr+1] := 'n'; newname[ptr+2] := 'e'; newname[ptr+3] := 'w'; newname[ptr+4] := Chr(0); Rewrite(newsource, newname); end else begin (* use comnd to find out the name of newsource *) cmini('Newsource? '); (* prompt for newsource *) gjgen(400000000000B); (* newsource will be an output file *) gjext('NEW'); (* with default extension .NEW *) gjnam(oldname); (* with default name the same as oldsource's *) cmfil(newsource); (* now that we have the defaults set, get the name*) cmcfm; (* wait for CRLF *) Rewrite(newsource); (* open newsource *) end; end; (* Startnew *) begin (* Startfiles *) Defineoptions; cmini(''); Readrescanned; if not rescanning then begin cmini('Oldsource? '); end; Startold; if not rescanning then begin cmauto(true); end; Setdefaults; loop cmmult; (* two possibilities *) {1} cmcfm; (* CRLF *) {2} i := cmswi(options); (* a switch *) i := cmdo; (* now do the comnd *) exit if i = 1; (* done if CRLF *) Errcheck; case cmint of (* otherwise evaluate the switch value returned *) -swversion: goodversion := cmnum; swtas: begin cmnoi('FORMAT'); dennying := true; end; swsuper: super := true; -swstr: begin strcase := cmkey(cases); end; swsave_comment: begin cmnoi('INDENTATION'); savecom := true; end; -swres: begin rescase := cmkey(cases); end; swquiet: quiet := true; -swproc: begin proccase := cmkey(cases); end; swpreserve: begin cmnoi('INDENTATION'); preserving := true; end; -swnonres: begin nonrcase := cmkey(cases); end; -swindent: feed := cmnum; swforce: begin cmnoi('NEWLINES IN STANDARD PLACES'); forcing := true; end; swelseif: elseifing := true; swcount: begin cmnoi('PROCEDURE AND FUNCTION DECLARATIONS'); counting := true; end; -swcomm: begin comcase := cmkey(cases); end; -swcase: eachcase := cmkey(cases); -swbegin: indentbegin := cmnum; swbar: begin cmnoi('FORMAT FOR COMMENTS'); barring := true; end; end; end; Errcheck; Reset(oldsource,'','/E'); Getoptions; Startnew; end; (* Startfiles *) function Hash(var sy: alfa): tableindex; var hack: record case boolean of true: (int1: integer; int2: integer); false: (alf: alfa); end; begin hack.alf := sy; Hash := Abs(Abs(hack.int1) - Abs(hack.int2)) mod oneplustablesize; end; (* Hash *) function Find_sy: list; var pointer: list; (* Runs through proctable looking for sy*) found : boolean; (* Did we find sy? *) begin pointer := proctable[Hash(sy)]; found := false; while (pointer <> nil) and not found do (* Look for sy *) begin if pointer^.string = sy then found := true else pointer := pointer^.next; end; if found then Find_sy := pointer else Find_sy := nil; end; (* Find_sy *) procedure Firstdef(sy: alfa); var pointer : list; (* Runs through proctable looking for sy *) pos : tableindex; begin definitions := definitions + 1; pos := Hash(sy); New(pointer); New(pointer^.stack); pointer^.string := sy; pointer^.stack^.top := true; pointer^.stack^.next := nil; pointer^.next := proctable[pos]; proctable[pos] := pointer; end; (* Firstdef *) procedure Reinitialize; begin (*Reinitialize*) proctable := baretable; bufflen := 0; buffmark := 0; errcount := 0; bufferptr := 2; variant_level := 0; level := 0; line500 := 0; linecnt :=0; pagecnt := 1; eoline := true; notokenyet := true; programpresent := false; oldspaces := false; sy := blanks; prog_name := blanks; end; (* Reinitialize *) procedure Initialize; var i: integer; begin thenbeginning := false; elsehere := false; eob := false; nobody := false; for i := 0 to tablesize do proctable[i] := nil; Firstdef('GET '); Firstdef('GETLN '); Firstdef('PUT '); Firstdef('PUTLN '); Firstdef('RESET '); Firstdef('REWRITE '); Firstdef('READ '); Firstdef('READLN '); Firstdef('BREAK '); Firstdef('WRITE '); Firstdef('WRITELN '); Firstdef('PACK '); Firstdef('UNPACK '); Firstdef('NEW '); Firstdef('GETLINENR '); Firstdef('PAGE '); Firstdef('PROTECTION'); Firstdef('CALL '); Firstdef('DATE '); Firstdef('TIME '); Firstdef('DISPOSE '); Firstdef('HALT '); Firstdef('GETSEG '); Firstdef('PUTSEG '); Firstdef('MESSAGE '); Firstdef('LINELIMIT '); Firstdef('REALTIME '); Firstdef('ABS '); Firstdef('SQR '); Firstdef('ODD '); Firstdef('ORD '); Firstdef('CHR '); Firstdef('PRED '); Firstdef('SUCC '); Firstdef('EOF '); Firstdef('EOLN '); Firstdef('CLOCK '); Firstdef('CARD '); Firstdef('LOWERBOUND'); Firstdef('UPPERBOUND'); Firstdef('EOS '); Firstdef('MIN '); Firstdef('MAX '); Firstdef('FIRST '); Firstdef('LAST '); Firstdef('COS '); Firstdef('EXP '); Firstdef('SQRT '); Firstdef('LN '); Firstdef('ARCTAN '); Firstdef('LOG '); Firstdef('SIND '); Firstdef('COSD '); Firstdef('SINH '); Firstdef('COSH '); Firstdef('TANH '); Firstdef('ARCSIN '); Firstdef('ARCCOS '); Firstdef('RANDOM '); Firstdef('SIN '); Firstdef('ROUND '); Firstdef('EXPO '); Firstdef('OPTION '); Firstdef('TRUNC '); Firstdef('LENGTH '); Firstdef('GETCHAR '); Firstdef('POS '); Firstdef('STRLT '); Firstdef('STRLE '); Firstdef('STREQ '); Firstdef('STRGE '); Firstdef('STRGT '); Firstdef('STRNE '); Firstdef('GETFILENAM'); Firstdef('GETOPTION '); Firstdef('GETSTATUS '); Firstdef('ASKFILENAM'); Firstdef('STARTFILE '); Firstdef('GETPARAMET'); Firstdef('GETNEXTCAL'); Firstdef('FILNAM '); Firstdef('REENTER '); Firstdef('SETTIME '); Firstdef('TIMEREPORT'); Firstdef('RUNTIME '); Firstdef('ELAPSEDTIM'); Firstdef('PUTCHAR '); Firstdef('ASSIGN '); Firstdef('SUBSTR '); Firstdef('CONCAT '); Firstdef('SETRAN '); definitions := 0; baretable := proctable; for ch := ' ' to '_' do delsy[ch] := othersy; delsy['('] := lparent; delsy[')'] := rparent; delsy['['] := lbracket; delsy[']'] := rbracket; delsy[';'] := semicolon; delsy[','] := comma; delsy['.'] := point; delsy[':'] := colon; delsy['='] := eqlsy; for i := -1 to 201 do buffer [i] := ' '; (* easier to debug *) for i := 1 to 17 do tabs [i] := Chr(ht); (* Ht is horizontal tab *) for ch := Chr(nul) to '@' do begin lower[ch] := ch; upper[ch] := ch; end; for ch := 'A' to 'Z' do begin lower[ch] := Chr (Ord(ch) + 40B); upper[ch] := ch; end; for ch := '[' to '`' do begin lower[ch] := ch; upper[ch] := ch; end; for ch := 'a' to 'z' do begin lower[ch] := ch; upper[ch] := Chr (Ord(ch) - 40B); end; for ch := '{' to Chr(177B) do begin lower[ch] := ch; upper[ch] := ch; end; Reinitialize; end (*Initialize*); procedure Setcase(whichcase: casetype); var j: integer; begin case whichcase of uppercase: begin for j := bufferptr - syleng - 1 to bufferptr-2 do buffer[j] := upper[buffer[j]]; end; lowercase: begin for j := bufferptr - syleng - 1 to bufferptr-2 do buffer[j] := lower[buffer[j]]; end; capitalize: begin buffer[bufferptr-syleng-1] := upper[ buffer[bufferptr-syleng-1] ]; for j := bufferptr - syleng to bufferptr - 2 do buffer[j] := lower[buffer[j]]; end; end; (* Case *) end; (* Setcase *) (*09*) (*Page control:*) (*Newpage*) procedure Newpage; begin (*Newpage*) pagecnt := pagecnt + 1; linecnt := 0; line500 := 0; if (prog_name <> blanks) and not quiet then Write(tty, pagecnt: 3, '..'); Page(newsource); end (*Newpage*); (*10*) (*Output procs:*) (*Block[error,writeline]*) procedure Block; type poplist = record pointer: list; next: ^poplist; end; var i: integer; whattopop: ^poplist; procedure Skipcomment; forward; procedure Error (errnr : errkinds); begin (*Error*) errcount := errcount+1; Write (newsource, '(*??* '); case errnr of begerrinblkstr: Write(newsource, sy, errmsg[begerrinblkstr]); missgend, missgthen, missguntil, missgexit : Write(newsource, errmsg[errnr]); others : Write(newsource, errmsg[errnr]); end; Writeln(newsource,' *??*)'); Writeln(tty); Write (tty, 'ERROR AT '); if (linenb = '-----') or (linenb = ' ') then begin Write(tty,linecnt: linnumsize) end else begin Write(tty, linenb); end; Write(tty, '/', pagecnt:2,': '); case errnr of begerrinblkstr: Write(tty, sy, errmsg[begerrinblkstr]); missgend, missgthen, missguntil, missgexit : Write(tty, errmsg[errnr]); others : Write(tty, errmsg[errnr]); end; Writeln(tty); end (*Error*) ; procedure Writeline(position (*Letztes zu druckendes zeichen im puffer*): integer); var i, j : integer; (*Markiert erstes zu druckENDes zeichen*) begin (*Writeline*) position := position - 2; if position > 0 then begin i := buffmark + 1; (* 1. Discard blanks at both ends *) while (buffer [i] = ' ') and (i <= position) do i := i + 1; buffmark := position; while (buffer [position] = ' ') and (i < position) do position := position - 1; if i <= position then (* 2. If anything left, write it. *) begin if not oldspaces then presentspaces := nextspaces; if preserving then presentspaces := spacepreserve; if thenbeginning then begin Write(newsource,' '); thenbeginning := false; end else begin Write(newsource,tabs:presentspaces div 8); if presentspaces mod 8 > 0 then Write(newsource,' ':presentspaces mod 8); end; for j := i to position do begin newsource^ := buffer[j]; Put(newsource); end; if dennying and (syty in [endsy,thensy,elsesy,dosy])then begin if syty = endsy then begin endelseing := true end else begin thenbeginning := true end; end else begin Writeln(newsource); end; (* 3. Reset pointers and flags *) while (buffmark+1 < bufflen) and (buffer[buffmark+1]=' ') do begin buffmark := buffmark + 1; (* Move buffmark past space *) end; if buffmark > bufflen then begin if (linenb = ' ') or (linecnt >= maxinc) then begin Newpage; end; end; end (* If i <= position *); end (* If position > 0 *); presentspaces := nextspaces; oldspaces := false; thendo := false; elsehere := false; end (*Writeline*) ; procedure Vardef; var pointer: list; s: ^stacktype; p: ^poplist; begin pointer := Find_sy; if pointer <> nil then if pointer^.stack^.top then begin New(s); s^.top := false; s^.next := pointer^.stack; pointer^.stack := s; New(p); p^.pointer := pointer; p^.next := whattopop; whattopop := p; end; end; (* Vardef *) procedure Procdef; var pointer: list; s: ^stacktype; p: ^poplist; begin pointer := Find_sy; if pointer = nil then begin Firstdef(sy); New(p); p^.pointer := Find_sy; p^.next := whattopop; whattopop := p; end else if not pointer^.stack^.top then begin New(s); s^.top := true; s^.next := pointer^.stack; pointer^.stack := s; New(p); p^.pointer := pointer; p^.next := whattopop; whattopop := p; end; end; (* Procdef *) procedure Popoff; var p: ^poplist; begin p := whattopop; while p <> nil do begin if p^.pointer^.stack^.next = nil then p^.pointer^.stack^.top := false (* Almost as good as new *) else p^.pointer^.stack := p^.pointer^.stack^.next; (* Pop stack *) p := p^.next; end; end; (* Popoff *) (*11*) (*Scanner:*) (*Insymbol[readbuffer[readline],resword*) procedure Readbuffer; (*Reads a character from the input buffer*) procedure Readline; (*Handles leading blanks and blank lines, reads next nonblank line (without leading blanks) into buffer*) var i, tabstop: integer; begin (*Readline*) (*Entered at the beginning of a line*) spacepreserve := 0; loop while Eoln (oldsource) and not Eof (oldsource) do begin (*Is this a page mark?*) Getlinenr(oldsource,linenb); if oldsource^ = Chr(15B) then begin Get(oldsource); if oldsource^ = Chr(14B) then begin linenb := ' '; end; if Eoln(oldsource) then begin Readln(oldsource); end; end else begin if oldsource^ = Chr(14B) then begin linenb := ' '; end; Readln(oldsource); end; if linenb = ' ' then begin Newpage end else begin (*Handle blank line*) line500 := line500 + 1; linecnt := linecnt + 1; if line500 = 500 then begin line500 := 0; if not quiet then begin if linenb = '-----' then begin Write(tty, '(', linecnt: 4, ')') end else begin Write(tty, '(', linenb, ')'); end; end; end; Writeln(newsource); if linecnt >= maxinc then begin Newpage; end; end (*Handle blank line*); spacepreserve := 0; end (*While eoln(oldsource)...*); exit if not (oldsource^ in [' ',Chr(ht)]) or (Eof (oldsource)); spacepreserve := spacepreserve + 1; Get(oldsource); end (*Loop*); bufflen := 0; (*Read in the line*) while not Eoln(oldsource) do (* Buggy *) begin if oldsource^ = Chr(ht) then begin tabstop := Min(8 * (1 + bufflen div 8), linsiz1plus); for i := bufflen+1 to tabstop do buffer[i] := ' '; bufflen := tabstop; end else begin bufflen := Min( bufflen + 1 , linsiz1plus ); buffer [bufflen] := oldsource^; end; Get(oldsource); end; if bufflen > linsize then begin Error(linetoolong); bufflen := linsize; end else begin buffer[bufflen+1]:=' '; (*So we can always be one char ahead*) buffer[bufflen+2] := ' '; end; if not Eof (oldsource) then begin Getlinenr(oldsource,linenb); if oldsource^ = Chr(15B) then begin Get(oldsource); if oldsource^ = Chr(14B) then begin linenb := ' '; end; if Eoln(oldsource) then begin Readln(oldsource); end; end else begin if oldsource^ = Chr(14B) then begin linenb := ' '; end; Readln(oldsource); end; linecnt := linecnt + 1; line500 := line500 + 1; if line500 = 500 then begin line500 := 0; if not quiet then begin if (linenb = '-----') or (linenb = ' ') then begin Write(tty, '(', linecnt: 4, ')') end else begin Write(tty, '(', linenb, ')'); end; end; end; end; bufferptr := 1; buffmark := 0; notokenyet := true; end (*Readline*) ; begin (*Readbuffer*) (*If reading past the extra blank on the END, get a new line*) if eoline then begin Writeline(bufferptr); ch := ' '; if Eof (oldsource) then begin eob := true end else begin Readline; end; end else begin ch := upper[ buffer[bufferptr] ]; bufferptr := bufferptr + 1; end; eoline := bufferptr >= bufflen + 2; end (*Readbuffer*) ; procedure Docomment(final_ch: char); var at_first_word_of_sentence: boolean; oldspacesmark: integer; procedure Nextchar; begin if savecom and (bufferptr = 1) then begin presentspaces := spacepreserve; nextspaces := spacepreserve; end; case comcase of lowercase: buffer[bufferptr] := lower[buffer[bufferptr]]; capitalize: if at_first_word_of_sentence then begin buffer[bufferptr] := upper[buffer[bufferptr]] end else begin buffer[bufferptr] := lower[buffer[bufferptr]]; end; uppercase: buffer[bufferptr] := upper[buffer[bufferptr]]; end; (* Case *) Readbuffer; if ((bufferptr-1 = bufflen) or (buffer[bufferptr] in ['"', '''' , ')' , ']' , '*' , ' '])) and (ch in ['.' , '?' , '!']) then at_first_word_of_sentence := true else if not (ch in ['/','"','''',')','(' , '[' , ']' , '*' , ' ']) then at_first_word_of_sentence := false; end; (* Nextchar *) procedure Options; var och : char; oswitch : boolean; ovalue : integer; ocase : casetype; begin (* Options *) repeat ovalue := 0; oswitch := true; ocase := capitalize; Readbuffer; och := ch; if ch <> '*' then begin Readbuffer; buffer[bufferptr-1] := lower[buffer[bufferptr-1]]; end; if ch in ['U','C','L','M'] then (* Get a case *) begin if ch = 'U' then ocase := uppercase else if ch = 'C' then ocase := capitalize else if ch = 'L' then ocase := lowercase else if ch = 'S' then ocase := samecase; Readbuffer; end else begin (* Get a plus, a minus, or an integer *) if ch in ['+','-'] then begin oswitch := ch = '+'; Readbuffer; end; if ch in ['0'..'9'] then begin repeat ovalue := ovalue * 10 + (Ord(ch)-Ord('0')); Readbuffer; until not (ch in digits); if not oswitch then (* Ch was '-' *) begin oswitch := true; ovalue := -ovalue; end; end; end; (* Get a plus, a minus, or an integer *) case och of 'V': if ovalue > 9 then begin goodversion := -1; (* Impossible version *) anyversion := true; end else begin goodversion := ovalue; anyversion := false; end; 'C': savecom := oswitch; 'I': if ovalue >= 0 then begin feed := ovalue; begexd := feed div 2; indentbegin := 0; if dennying then endexd := feed else endexd := feed div 2; end; 'G': if ovalue < 0 then begin begexd := -ovalue; endexd := begexd; indentbegin := 0; end else begin begexd := 0; endexd := 0; indentbegin := ovalue; end; 'D': begin dennying := true; begexd := feed; indentbegin := 0; endexd := feed; rescase := lowercase; end; 'S': begin super := oswitch; forcing := forcing or oswitch; end; 'F': forcing := oswitch; 'B': barring := oswitch; 'Q': quiet := oswitch; 'E': elseifing := oswitch; 'P': preserving := oswitch; 'R': rescase := ocase; 'N': nonrcase := ocase; 'M': comcase := ocase; 'Z': strcase := ocase; 'X': proccase := ocase; 'A': begin proccase := ocase; nonrcase := ocase; rescase := ocase; strcase := ocase; comcase := ocase; end; (* Other options may cause conflicts *) end; (* Case *) until ch <> ','; end; (* Options *) begin (* Docomment *) at_first_word_of_sentence := true; oldspacesmark := nextspaces; if not oldspaces then begin presentspaces := nextspaces; oldspaces := true; end; if savecom and comment_at_boln then begin nextspaces := spacepreserve; presentspaces := spacepreserve; end else begin nextspaces := presentspaces + bufferptr - buffmark - 2; end; if final_ch in [')','/'] then begin Nextchar; if ch = '&' then begin Options; end; repeat Nextchar; until ((ch = final_ch) and (buffer[bufferptr-2] = '*')) or eob; if eob then begin Error(missgcommentend); end; end else begin while (ch <> final_ch) and not eob do begin Nextchar; end; if eob then begin Error(missgcommentend); end; end; if barring and (bufflen = 3) then nextspaces := nextspaces - 1;(* Align the bottom of the bar *) repeat Readbuffer; until (ch <> ' ') or eoline; if eoline and notokenyet then Readbuffer; nextspaces := oldspacesmark; if not oldspaces then presentspaces := nextspaces; end (* Docomment *); procedure Insymbol; label 1,111; var i: integer; incondcomp: boolean; function Resword: boolean ; (*Determines if the current identifier is a reserved word*) var i,j: integer; local: boolean; begin (*Resword*) local:= false; i := resnum[sy[1]]; while (i < resnum[Succ(sy[1])]) and not local do begin if reslist[i] = sy then begin local := true; syty := ressy[i]; Setcase(rescase); end else begin i := i + 1; end; end; Resword := local; end (*Resword*) ; function Proccall: boolean; var pointer: list; (* Runs through proctable looking for sy*) found : boolean; (* Did we find sy? *) begin if invars or (syty = point) then begin Proccall := false end else begin (* Not (invars or ... *) pointer := Find_sy; Proccall := false; if pointer <> nil then begin if pointer^.stack^.top then begin Proccall := true; Setcase(proccase); end; end; end; (* Not (invars or ... *) end; (* Proccall *) (*12*) (*Parenthese*) procedure Parenthese (which: symbol); (*Handles the formatting of parentheses, except those in variant parts of records*) var oldspacesmark : integer; (*Alter zeichenvorschub bei formatierung von klammern*) begin (*Parenthese*) oldspacesmark := nextspaces; if not oldspaces then begin (* i.e., at beginning of line *) oldspaces := true; presentspaces := nextspaces; end; nextspaces := presentspaces + bufferptr - buffmark - 2; repeat Insymbol; if syty in [functionsy,proceduresy] then begin Insymbol; if syty = ident then Procdef; end else if invars and (syty = ident) then begin Vardef; end; until syty in [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy]; nextspaces := oldspacesmark; oldspaces := true; if syty = which then Insymbol else if which = rparent then Error(missgrpar) else Error(missgrbrack); end (*Parenthese*) ; (*13*) (*] Insymbol*) begin (*Insymbol*) 111: syleng := 0; while (ch in ['/','_','(',' ','$','?','@','%',backslash,'!','{']) and not eob do begin case ch of '/': begin Readbuffer; if ch = '*' then begin comment_at_boln := bufferptr = 3; Docomment('/'); end; end; '(': begin Readbuffer; if ch = '*' then begin comment_at_boln := bufferptr = 3; Docomment(')') end else begin syty := lparent; if variant_level = 0 then begin Parenthese(rparent); end; goto 1; end; end; '%': begin comment_at_boln := bufferptr = 2; incondcomp := false; Readbuffer; if not anyversion then while ch in digits do begin if Ord(ch) - Ord('0') = goodversion then begin incondcomp := true; end; Readbuffer; end; if not (incondcomp or anyversion) then begin Docomment(backslash) end; end; '{': Docomment('}'); others: begin Readbuffer; end; end; (* case *) end; (* while *) case ch of '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': begin syleng := 0; sy := ' '; repeat syleng := syleng + 1; if syleng <= 10 then sy [syleng] := ch; Readbuffer; until not (ch in (alphanum + ['_'])); if not Resword then begin if not Proccall then begin if syty in[proceduresy,functionsy,programsy]then begin Setcase(proccase) end else begin Setcase(nonrcase); end; end; syty := ident; end; end; (* 'A'..'Z' *) '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': begin repeat syleng := syleng + 1; Readbuffer; until not (ch in digits); syty := intconst; if ch = 'B' then begin Readbuffer; end else begin if ch = '.' then begin repeat Readbuffer until not (ch in digits); syty := othersy; syleng := 0; (*Reals can't be labels*) end; if ch = 'E' then begin Readbuffer; if ch in ['+','-'] then begin Readbuffer; end; while ch in digits do begin Readbuffer; end; syty := othersy; syleng := 0; (*Reals can't be labels*) end; end; end; (* digits *) '''': begin syleng := 1; syty := strgconst; repeat repeat if strcase = lowercase then begin buffer[bufferptr] := lower[buffer[bufferptr]]; end; Readbuffer; syleng := syleng + 1; until (ch = '''') or eob or eoline; if ch <> '''' then begin Error(missgquote); end; Readbuffer; syleng := syleng + 1; until ch <> ''''; end; '"': begin repeat Readbuffer until not (ch in (digits + ['A'..'F'])); syty := intconst; end; ' ': syty := eobsy; (* end of file *) ':': begin Readbuffer; if ch = '=' then begin syty := othersy; Readbuffer; end else begin syty := colon; end; end; '\': begin Readbuffer; if incondcomp then begin incondcomp := false; goto 111; end else begin syty := othersy; end; end; '[': begin syty := lbracket; Readbuffer; Parenthese(rbracket); end; ';': begin syty := semicolon; Readbuffer; if super then begin Skipcomment; Writeline(bufferptr); end; end; others: begin syty := delsy[ch]; Readbuffer; end; end (* Case ch of *); 1: notokenyet := false; if thenbeginning then begin if not oldspaces then begin if syty <> beginsy then begin Writeln(newsource); (* put back the CRLF *) thenbeginning := false; end; end; end; if endelseing then begin endelseing := false; if syty = elsesy then begin thenbeginning := true (* To suppress crlf after else *) end else begin Writeln(newsource); (* Put back the crlf after the end *) end; end; end (*Insymbol*) ; (*14*) (*Parsing of declarations:*) (*Recdef[casedef,parenthese]*) procedure Recdef; var oldspacesmark : integer; (*Alter zeichenvorschub bei formatierung von records*) procedure Casedef; var oldspacesmark : integer; (*Alter zeichenvorschub bei formatierung von variant parts*) procedure Parenthese; (*Handles the formatting of parentheses inside variant parts*) var oldspacesmark : integer; (*Saved value of 'nextspaces'*) begin (*Parenthese*) oldspacesmark := nextspaces; if not oldspaces then begin oldspaces := true; presentspaces := nextspaces; end; nextspaces := nextspaces + bufferptr - 2; Insymbol; repeat case syty of casesy : Casedef; recordsy : Recdef; rparent: ; others : begin if syty = ident then Vardef; Insymbol; end; end; (*Until we apparently leave the declaration*) until syty in [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy, loopsy..ifsy,forwardsy]; nextspaces := oldspacesmark; oldspaces := true; if syty = rparent then Insymbol else Error(missgrpar); end (*Parenthese*) ; begin (*Casedef*) variant_level := variant_level+1; oldspacesmark := nextspaces; if not oldspaces then begin oldspaces := true; presentspaces := nextspaces; end; nextspaces := bufferptr - buffmark + presentspaces - syleng + 3; Insymbol; Vardef; repeat if syty = lparent then Parenthese else begin if syty = ident then Vardef; Insymbol; end; until syty in [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy]; nextspaces := oldspacesmark; variant_level := variant_level-1; end (*Casedef*) ; begin (*Recdef*) oldspacesmark := nextspaces; if not oldspaces then begin oldspaces := true; presentspaces := nextspaces; end; nextspaces := bufferptr - buffmark + presentspaces - syleng - 2 + feed; Insymbol; while not (syty in [untilsy..exitsy,labelsy..endsy,dosy..beginsy]) do case syty of casesy : Casedef; recordsy : Recdef; others : begin Vardef; repeat Insymbol; until syty in [untilsy..exitsy,labelsy..endsy,dosy..beginsy,semicolon,casesy,recordsy]; if syty = semicolon then Insymbol; end; end; (* Case *) if not oldspaces then begin presentspaces := nextspaces - feed; oldspaces := true; end; nextspaces := oldspacesmark; if syty = endsy then Insymbol else Error(missgend); end (*Recdef*) ; (*15*) (*Parsing of statements:*) (*Statement[ENDedstatseq,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*) procedure Statement; var oldspacesmark, (*Nextspaces at entry of this procedure*) curblocknr : integer; (*Current blocknumber*) procedure Endedstatseq(endsym: symbol); begin Statement; while syty = semicolon do begin Insymbol; Statement; end; while not (syty in [endsym,eobsy,proceduresy,functionsy]) do begin Error(missgend); if not (syty in begsym) then Insymbol; Statement; while syty = semicolon do begin Insymbol; Statement; end; end; if forcing then Writeline(bufferptr-syleng); if endelseing then begin endelseing := false; Writeln(newsource); end; end (*ENDedstatseq*); procedure Compstat; begin (*Compstat*) if not oldspaces then begin oldspaces := true; presentspaces := Max (0, nextspaces - begexd - indentbegin); (* Subtract begexd to exdent the begin and subtract indentbegin to undo the extra indentation for the block *) end; Insymbol; if (forcing or dennying) then Writeline(bufferptr-syleng); Endedstatseq(endsy); if syty = endsy then begin if not oldspaces then begin oldspaces := true; presentspaces := Max(0,nextspaces - endexd - indentbegin); (* Subtract endexd to exdent the end and subtract indentbegin to undo the extra indentation for the block*) end; Insymbol; if forcing then begin if syty = semicolon then Skipcomment; Writeline(bufferptr-syleng); end; end else Error(missgend) end (*Compstat*) ; procedure Casestat; var oldspacesmark : integer; (*Saved value of 'nextspaces'*) begin (*Casestat*) if not oldspaces then begin oldspaces := true; presentspaces := Max (0,nextspaces-feed); end; Insymbol; Statement; if syty = ofsy then if forcing then begin Skipcomment; Writeline(bufferptr); end else else Error (missgof); loop repeat repeat Insymbol; until syty in [colon, functionsy .. eobsy]; if syty = colon then begin oldspacesmark := nextspaces; presentspaces := nextspaces; nextspaces := nextspaces + feed; (* Nextspaces := bufferptr - buffmark + nextspaces - 4; *) oldspaces := true; thendo := true; Insymbol; Statement; if syty = semicolon then Insymbol; nextspaces := oldspacesmark; end; until syty in endsym; exit if syty in [endsy,eobsy,proceduresy,functionsy]; Error (missgend); end; (* Loop *) if forcing then Writeline(bufferptr-syleng); if syty = endsy then begin Insymbol ; if dennying then nextspaces := nextspaces - feed; if forcing then begin if syty = semicolon then Skipcomment; Writeline(bufferptr-syleng); end; end else Error (missgend); end (*Casestat*) ; procedure Loopstat; begin (*Loopstat*) if not oldspaces then begin oldspaces := true; presentspaces := Max (0,nextspaces - feed); end; Insymbol; Statement; while syty = semicolon do begin Insymbol; Statement; end; if syty = exitsy then begin Writeline(bufferptr-syleng); oldspaces := true; presentspaces := nextspaces-feed; Insymbol; Insymbol; end else Error(missgexit); Endedstatseq(endsy); if syty = endsy then begin if not oldspaces then begin oldspaces := true; presentspaces := Max(0,nextspaces - feed - indentbegin); (* Subtract feed to exdent the END and subtract indentbegin to undo the extra indentation for the block*) end; Insymbol ; if forcing then begin if syty = semicolon then Skipcomment; Writeline(bufferptr-syleng); end; end else Error(missgend); end (*Loopstat*) ; procedure Ifstat; var oldspacesmark: integer; begin (*Ifstat*) oldspacesmark := nextspaces; if not elsehere then begin if not oldspaces then begin oldspaces := true; presentspaces := Max (0,nextspaces - feed); end; (*Make 'then' and 'else' line up with 'if' unless on same line*) nextspaces := presentspaces + bufferptr - buffmark + feed - 4; end (*If not elsehere*); Insymbol; Statement; (*Will eat the expression and stop on a keyword*) if syty = thensy then begin if not oldspaces then begin oldspaces := true; presentspaces := Max (0,nextspaces-feed); end; if forcing (*and not dennying*) then begin Skipcomment; Writeline(bufferptr); end else thendo:=true; (*Suppress further indentation from a 'do'*) Insymbol; Statement; end else Error (missgthen); if syty = elsesy then begin (*Parse the else part*) Writeline(bufferptr-syleng); if not oldspaces then begin oldspaces := true; presentspaces := Max (0,nextspaces-feed); end; if forcing and not (elseifing (*or dennying*)) then begin Skipcomment; Writeline(bufferptr); end else thendo := true; elsehere := true; Insymbol; Statement; end; oldspaces := true; (* Preserve indentation of statement *) if syty = semicolon then Skipcomment; Writeline(bufferptr-syleng); nextspaces := oldspacesmark; end (*Ifstat*) ; procedure Labelstat; begin (*Labelstat*) presentspaces := level * feed; oldspaces := true; Insymbol; if forcing then Writeline(bufferptr-syleng); end (*Labelstat*) ; procedure Repeatstat; begin if not oldspaces then begin oldspaces := true; presentspaces := Max (0,nextspaces - feed); end; Insymbol; if (forcing or dennying) then Writeline(bufferptr-syleng); Endedstatseq(untilsy); if syty = untilsy then begin if not oldspaces then begin oldspaces := true; presentspaces := Max(0,nextspaces - feed); end; Insymbol; Statement; if forcing then begin if syty = semicolon then Skipcomment; Writeline(bufferptr-syleng); end; end else Error(missguntil); end (*Repeatstat*) ; begin (*Statement*) oldspacesmark := nextspaces; (*Save the incoming value of nextspaces to be able to restore it*) if syty = intconst then begin Insymbol; if syty = colon then Labelstat; end; if syty in begsym then begin if not thendo then begin if forcing then Writeline(bufferptr-syleng); if (syty <> beginsy) then nextspaces := nextspaces + feed else nextspaces := nextspaces + indentbegin; end; case syty of beginsy : Compstat; loopsy : Loopstat; casesy : Casestat; ifsy : Ifstat; repeatsy: Repeatstat; end; end else begin if forcing then if syty in [forsy,whilesy] then Writeline(bufferptr-syleng); while not (syty in [semicolon,functionsy..recordsy]) do Insymbol; if syty = dosy then begin if not thendo then begin oldspaces := true; presentspaces := nextspaces; nextspaces := nextspaces + feed; if dennying or not forcing then thendo := true; end; Insymbol; Statement; if syty = semicolon then Skipcomment; Writeline(bufferptr-syleng); end; end; nextspaces := oldspacesmark; end (*Statement*) ; procedure Skipcomment; var last_ch: char; begin while not eoline and (ch = ' ') do begin Readbuffer; end; if (ch in ['(','/','{']) and not eoline and (buffer[bufferptr] = '*') then begin if ch = '(' then begin last_ch := ')'; Readbuffer; end else if ch = '/' then begin last_ch := '/'; Readbuffer; end else begin last_ch := '}'; end; Docomment(last_ch); end; end; (* Skipcomment *) (*16*) (*]Block*) begin (*Block*) invars := true; whattopop := nil; repeat Insymbol; until syty in relevantsym; level := level + 1; nextspaces := level * feed; repeat fwddecl := false; if syty = programsy then begin Writeline(bufferptr-syleng); oldspaces := true; presentspaces := Max(0,nextspaces-feed); programpresent := true; Insymbol; prog_name := sy; Writeln(tty); Write(tty, version:verlength, ': ', old_name:6 , ' [ ', prog_name, ' ]'); if not quiet then begin Write(tty,' Page'); for i := 1 to pagecnt do Write (tty, i:3, '..'); end; repeat Insymbol; until syty in relevantsym; end; (* Syty = programsy *) while syty in decsym do (*Declarations: labels, types, vars*) begin Writeline(bufferptr-syleng); oldspaces := true; presentspaces := Max(0,nextspaces-feed); if forcing then begin Skipcomment; Writeline(bufferptr); end; Insymbol; while not (syty in relevantsym) do begin loop Vardef; Insymbol; exit if syty <> comma; Insymbol; end; (* Loop *) while not (syty in [semicolon] + relevantsym) do if syty = recordsy then Recdef else Insymbol; Insymbol; end; end; (* While syty in decsym *) invars := false; while syty in prosym do (*Procedure and function declarations*) begin Writeline(bufferptr-syleng); oldspaces := true; presentspaces := Max(0,nextspaces-feed); if syty <> initprocsy then begin Insymbol; if syty = ident then Procdef; (*Put the symbol in proctable*) end; Block; if syty = semicolon then Insymbol; end (*While syty in prosym*) (*Forward and external declarations may come before 'var', etc.*) until not fwddecl; if forcing then Writeline(bufferptr-syleng); level := level - 1; nextspaces := level * feed; if not (syty in [beginsy,forwardsy,externsy,eobsy(*,langsy*)]) then begin if (level = 0) and (syty = point) then nobody := true else Error (begerrinblkstr); while not (syty in [beginsy,forwardsy,externsy,eobsy,(*Langsy,*)point]) do Insymbol end; if syty = beginsy then Statement else if not nobody then begin fwddecl := true; Insymbol; end; if level = 0 then begin if programpresent then begin if nobody then begin Error (missgmain); errcount := errcount - 1; end; if syty <> point then Error(missgpoint); Writeln(tty); Writeln(tty,errcount:4,' error(s) detected'); end; (* If programpresent *) Writeline(bufflen+2); end; (* Level = 0 *) Popoff; end; (*Block*) (*17*) (*Main program*) begin rtime := Runtime; Startfiles; Initialize; ch := ')'; (* Hack -- forces first character to be read *) loop Block; exit if not programpresent or (syty = eobsy); Reinitialize; end; while not Eof(oldsource) do (* Otherwise you can lose half a program *) begin while not Eoln(oldsource) do begin newsource^ := oldsource^; Get(oldsource); Put(newsource); end; Readln(oldsource); Writeln(newsource); end; if counting then begin Writeln(tty,definitions:6,' procedure and function definitions'); end; rtime := Runtime - rtime; Write(tty,'Runtime: ',(rtime div 60000):0,':'); rtime := rtime mod 60000; if rtime div 1000 < 10 then begin Write(tty,'0'); end; Write(tty,(rtime div 1000):0,'.'); rtime := rtime mod 1000; if rtime < 100 then begin if rtime < 10 then begin Write(tty,'00'); end else begin Write(tty,'0'); end; end; Writeln(tty,rtime:0) end (* Pform *).