Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / print / afmt2.pas < prev next >

Wrap

Pascal/Delphi Source File | 1988-05-03 | 165.6 KB | 3,160 lines

(*====================================================================*) (* *) (* PROGRAM TITLE: ADA PRETTYPRINTING PROGRAM *) (* *) (* AUTHORS: MARLOW HENNE AIR FORCE ARMANENT LABORATORY(DLMM) AND *) (* LARRY NEAL, GENERAL RESEARCH CORP,FT WALTON BEACH,FLA *) (* *) (* HISTORY: MODIFIED BY RICK CONN (LOOK FOR -- RLC --) TO SUPPORT *) (* CAPITALIZATION OF KEYWORDS OR IDENTIFIERS. *) (* ALSO CORRECTED AN ERROR IN THE NUMBER PARSER (GETNUMBER) *) (* DEALING WITH THE EVALUATION OF BASED NUMBERS. *) (* ALSO CORRECTED A PROBLEM WITH INDENTATION (SEE -- RLC -- *) (* IN INITIALIZE ROUTINE). *) (* ALSO ADDED SEVERAL MORE RESERVED WORDS SO CASE *) (* CONVERSION IS MORE EFFECTIVE (SEE -- RLC --). *) (* HISTORY: MODIFIED BY ALAN WOODY TO COMPENSATE FOR TAB CHARACTERS *) (* USED IN THE PLACE OF SPACES IN THE INPUT FILE (LOOK FOR *) (* CAW ). MODIFIED TO HANDLE INSTANTIATIONS OF GENERIC *) (* PACKAGES, AND MODIFIED TO HANDLE with function STATEMENTS*) (* ALSO MODIFIED TO HANDLE PRIVATE TYPE STATEMENTS. SEE *) (* COMMENTS BELOW FOR THE ADDED VARIABLES AND THEIR PURPOSE.*) (* HISTORY: THIS PROGRAM IS AN ADAPTION OF A PASCAL PRETTYPRINTER *) (* WRITTEN ORIGINALLY BY JON F. HUERAS AND HENRY F. *) (* LEDGARDOF THE COMPUTER AND INFORMATION SCIENCE DEPARTMENT*) (* UNIVERSITY OF MASSACHUSETTS, AMHERST IN AUGUST 1976, *) (* WITH EARLIER VERSIONS AND CONTRIBUTIONS BY RNADY CHOW *) (* AND JOHN GORMAN. CONTRIBUTIONS TO THE ORIGNIAL PASCAL *) (* WAS ALSO MADE TO MODIFY IT FOR THE CDC-6000 PASCAL *) (* RELEASE 3 BY RICK L. MARCUS,UNIVERSITY COMPUTER CENTER, *) (* UNIVERSITY OF MINNESOTA IN SEPTEMBER 1978. *) (* *) (* PROGRAM SUMMARY: *) (* *) (* THIS PROGRAM TAKES AS INPUT AN ADA PROGRAM AND *) (* REFORMATS THE PROGRAM ACCORDING TO A STANDARD SET OF *) (* PRETTYPRINTING RULES. THE PRETTYPRINTED PROGRAM IS GIVEN *) (* AS OUTPUT. THE PRETTYPRINTING RULES ARE GIVEN BELOW. *) (* *) (* NO ATTEMPT IS MADE TO DETECT OR CORRECT SYNTACTIC ERRORS IN *) (* THE USER'S PROGRAM. HOWEVER, SYNTACTIC ERRORS MAY RESULT IN *) (* ERRONEOUS PRETTYPRINTING. *) (* *) (* *) (* INPUT FILE: INPUT - A FILE OF CHARACTERS, PRESUMABLY AN *) (* ADA PROGRAM OR PROGRAM FRAGMENT. *) (* *) (* OUTPUT FILE: OUTPUT - THE PRETTYPRINTED PROGRAM. *) (* *) (* PROCEURES/FUNCTIONS USED *) (* INITIALIZE *) (* GETSYMBOL *) (* INSERTCR *) (* INSERTBLANKLINE *) (* LSHIFT *) (* INSERTSPACE *) (* PPSYMBOL *) (* RSHIFT *) (* GOBBLE *) (* STACKFULL *) (* PUSHSTACK *) (* *) (*====================================================================*) (*====================================================================*) (* *) (* ADA PRETTYPRINTING RULES *) (* *) (* *) (* [ GENERAL PRETTYPRINTING RULES ] *) (* *) (* 1. COMMENTS ARE LEFT WHERE THEY ARE FOUND, UNLESS *) (* THEY ARE SHIFTED RIGHT BY PRECEEDING TEXT ON A LINE. *) (* *) (* 2. ALL STATEMENTS AND DECLARATIONS BEGIN ON SEPARATE LINES *) (* WITH ONE EXCEPTION BEING THE CONTEXT_SPECIFICATION USING A *) (* WITH_CLAUSE AND A USE_CLAUSE. FOR EXAMPLE THE FOLLOWING *) (* CONTEXT_SPECIFICATION WOULD APPEAR ON THE SAME LINE: *) (* *) (* WITH TEXT_IO, REAL_OPERATIONS; USE REAL_OPERATIONS; *) (* *) (* *) (* 3. NO LINE MAY BE GREATER THAN 80 CHARACTERS LONG. ANY LINE *) (* LONGER THAN THIS IS CONTINUED ON A SEPARATE LINE. *) (* *) (* 4. THE KEYWORDS *) (* "BEGIN" *) (* "LOOP"(EXCEPT WHEN USED FOLLOWING A ITERATION CLAUSE) *) (* "ELSE" *) (* "DECLARE" *) (* "EXCEPTION"(EXCEPT WHEN USED AS AN EXCEPTION_DECLARATION *) (* OR AS A RENAMING_DECLARATION) *) (* "SELECT" *) (* "PRIVATE"(EXCEPT WHEN USED AS A PRIVATE_TYPE_DEFINITION) *) (* "GENERIC" *) (* "OR"(EXCEPT WHEN USED AS A LOGICAL_OPERATOR) *) (* ARE FORCED TO STAND ON LINES BY THEMSELVES(OR POSSIBLY *) (* FOLLOWED BY SUPPORTING COMMENTS) *) (* *) (* 5. A BLANK LINE IS FORCED BEFORE THE KEYWORDS *) (* "PROCEDURE", "FUNCTION", "PACKAGE", "EXCEPTION", *) (* "TASK", "GENERIC", AND "PRIVATE"(EXCEPT WHEN USED *) (* AS A PRIVATE_TYPE_DECLARATION) *) (* 6. A SPACE IS FORCED BEFORE AND AFTER THE SYMBOLS ":=". *) (* ADDITIONALLY, A SPACE IS FORCED AFTER THE SYMBOL ":". *) (* 7. THE FOLLOWING SYNTATIC CHANGE IS FORCED BY THE PRETTYPRINTER *) (* PROGRAM: *) (* END [ IDENTIFIER] ::= END IDENTIFIER *) (* 8. THE FOLLOWING SIMPLE STATEMENTS BEGIN ON A SEPARATE LINE *) (* BUT DO NOT AFFECT INDENTATION: *) (* *) (* ASSIGNMENT_STATEMENTS *) (* RETURN_STATEMENTS *) (* EXIT_STATEMENTS *) (* GOTO_STATEMENTS *) (* PROCEDURE_CALLS *) (* RAISE_STATEMENTS *) (* CODE_STATEMENTS *) (* ENTRY_CALL_STATEMENTS *) (* ABORT_STATEMENTS *) (* DELAY_STATEMENTS *) (* NULL_STATEMENTS *) (* 9. THE FOLLOWING COMPOUND STATEMENTS ARE INDENTED *) (* AS FOLLOWS: *) (* *) (* A. GENERAL IF_STATEMENTS *) (* *) (* IF CONDITION THEN *) (* SEQUENCE_OF_STATEMENTS *) (* ELSIF CONDITION THEN *) (* SEQUENCE_OF_STATEMENTS *) (* . *) (* . *) (* ELSE *) (* SEQUENCE_OF_STATEMENTS *) (* END IF; *) (* *) (* B. GENERAL CASE_STATEMENTS *) (* *) (* CASE EXPRESSION IS *) (* WHEN CHOICE => *) (* SEQUENCE_OF_STATEMENTS *) (* . *) (* . *) (* WHEN CHOICE => *) (* SEQUENCE_OF_STATEMENTS *) (* WHEN OTHERS => *) (* SEQUENCE_OF_STATEMENTS *) (* END CASE; *) (* *) (* C. GENERAL LOOP_STATEMENTS *) (* *) (* 1. BASIC_LOOP *) (* *) (* LOOP *) (* SEQUENCE_OF_STATEMENTS *) (* END LOOP; *) (* *) (* 2. FOR_LOOP *) (* *) (* FOR LOOP_PARAMETER IN DISCRETE_RANGE LOOP *) (* SEQUENCE_OF_STATEMENTS *) (* END LOOP; *) (* *) (* 3. WHILE_LOOP *) (* *) (* WHILE CONDITION LOOP *) (* SEQUENCE_OF_STATEMENTS *) (* END LOOP; *) (* *) (* D. GENERAL ACCEPT_STATEMENTS *) (* *) (* ACCEPT ENTRY_NAME [ FORMAL_PART ] DO *) (* SEQUENCE_OF_STATEMENTS *) (* END ENTRY_NAME; *) (* *) (* E. GENERAL SELECT_STATEMENTS *) (* *) (* 1. SELECTIVE_WAIT STATEMENTS *) (* *) (* SELECT *) (* WHEN CONDITION => *) (* SELECT_ALTERNATIVE *) (* OR *) (* WHEN CONDITION => *) (* SELECT_ALTERNATIVE *) (* ELSE *) (* SEQUENCE_OF_STATEMENTS *) (* END SELECT; *) (* *) (* 2. CONDITIONAL_ENTRY_CALL STATEMENTS *) (* *) (* SELECT *) (* ENTRY_CALL; *) (* ELSE *) (* SEQUENCE_OF_STATEMENTS *) (* END SELECT; *) (* *) (* 3. TIMED_ENTRY_CALL STATEMENTS *) (* *) (* SELECT *) (* ENTRY_CALL; *) (* SEQUENCE_OF_STATEMENTS *) (* OR *) (* DELAY_STATEMENT *) (* SEQUENCE_OF_STATEMENTS *) (* END SELECT; *) (* *) (* F. BLOCKS *) (* *) (* BLOCKNAME: *) (* DECLARE *) (* DECLARATIVE_PART *) (* BEGIN *) (* SEQUENCE_OF_STATEMENTS *) (* END BLOCKNAME; *) (* *) (*====================================================================*) (*====================================================================*) (* GENERAL ALGORITHM *) (* *) (* *) (* THE STRATEGY OF THE PRETTYPRINTER IS TO SCAN SYMBOLS FROM *) (* THE INPUT PROGRAM AND MAP EACH SYMBOL INTO A PRETTYPRINTING *) (* ACTION, INDEPENDENTLY OF THE CONTEXT IN WHICH THE SYMBOL *) (* APPEARS. THIS IS ACCOMPLISHED BY A TABLE OF PRETTYPRINTING *) (* OPTIONS. *) (* *) (* FOR EACH DISTINGUISHED SYMBOL IN THE TABLE, THERE IS AN *) (* ASSOCIATED SET OF OPTIONS. IF THE OPTION HAS BEEN SELECTED FOR *) (* THE SYMBOL BEING SCANNED, THEN THE ACTION CORRESPONDING WITH *) (* EACH OPTION IS PERFORMED. *) (* *) (* THE BASIC ACTIONS INVOLVED IN PRETTYPRINTING ARE THE INDENT- *) (* ATION AND DE-INDENTATION OF THE MARGIN. EACH TIME THE MARGIN IS *) (* INDENTED, THE PREVIOUS VALUE OF THE MARGIN IS PUSHED ONTO A *) (* STACK, ALONG WITH THE NAME OF THE SYMBOL THAT CAUSED IT TO BE *) (* INDENTED. EACH TIME THE MARGIN IS DE-INDENTED, THE STACK IS *) (* POPPED OFF TO OBTAIN THE PREVIOUS VALUE OF THE MARGIN. *) (* *) (* THE PRETTYPRINTING OPTIONS ARE PROCESSED IN THE FOLLOWING *) (* ORDER, AND INVOKE THE FOLLOWING ACTIONS: *) (* *) (* *) (* CRSUPPRESS - IF A CARRIAGE RETURN HAS BEEN INSERTED *) (* FOLLOWING THE PREVIOUS SYMBOL, THEN IT IS *) (* INHIBITED UNTIL THE NEXT SYMBOL IS PRINTED. *) (* *) (* CRBEFORE - A CARRIAGE RETURN IS INSERTED BEFORE THE *) (* CURRENT SYMBOL (UNLESS ONE IS ALREADY THERE) *) (* *) (* BLANKLINEBEFORE - A BLANK LINE IS INSERTED BEFORE THE CURRENT *) (* SYMBOL (UNLESS ALREADY THERE). *) (* *) (* DINDENT - THE STACK IS UNCONDITIONALLY POPPED AND THE *) (* MARGIN IS DE-INDENTED. *) (* *) (* SPACEBEFORE - A SPACE IS INSERTED BEFORE THE SYMBOL BEING *) (* SCANNED (UNLESS ALREADY THERE). *) (* *) (* [ THE SYMBOL IS PRINTED AT THIS POINT ] *) (* *) (* SPACEAFTER - A SPACE IS INSERTED AFTER THE SYMBOL BEING *) (* SCANNED (UNLESS ALREADY THERE). *) (* *) (* GOBBLESYMBOLS - SYMBOLS ARE CONTINUOUSLY SCANNED AND PRINTED *) (* WITHOUT ANY PROCESSING UNTIL ONE OF THE *) (* SPECIFIED SYMBOLS IS SEEN (BUT NOT GOBBLED). *) (* *) (* INDENTBYTAB - THE MARGIN IS INDENTED BY A STANDARD AMOUNT *) (* FROM THE PREVIOUS MARGIN. *) (* *) (* INDENTMARGIN - THE MARGIN IS INDENTED BY A STANDARD AMOUNT *) (* FROM THE PREVIOUS MARGIN. *) (* *) (* CRAFTER - A CARRIAGE RETURN IS INSERTED FOLLOWING THE *) (* SYMBOL SCANNED. *) (* *) (* *) (* *) (*====================================================================*) PROGRAM PRETTYPRINT( (* FROM *) INPUT, (* TO *) OUTPUT ); CONST CAPITALIZEID = TRUE; (* CAPITALIZE IDENTIFIERS - TRUE MAKES *) (* THEM CAPS, FALSE MAKES THEM LOWER *) CAPITALIZEKEY = FALSE; (* CAPITALIZE KEYWORDS - TRUE MAKES THEM *) (* CAPS, FALSE MAKES THEM LOWER *) MAXSYMBOLSIZE = 200; (* THE MAXIMUM SIZE (IN CHARACTERS) OF A *) (* SYMBOL SCANNED BY THE LEXICAL SCANNER. *) MAXSTACKSIZE = 50; (* THE MAXIMUM NUMBER OF SYMBOLS CAUSING *) (* INDENTATION THAT MAY BE STACKED. *) MAXKEYLENGTH = 10; (* THE MAXIMUM LENGTH (IN CHARACTERS) OF A *) (* PASCAL RESERVED KEYWORD. *) MAXLINESIZE = 80; (* THE MAXIMUM SIZE (IN CHARACTERS) OF A *) (* LINE OUTPUT BY THE PRETTYPRINTER. *) SLOFAIL1 = 30; (* UP TO THIS COLUMN POSITION, EACH TIME *) (* "INDENTBYTAB" IS INVOKED, THE MARGIN *) (* WILL BE INDENTED BY "INDENT1". *) SLOFAIL2 = 72; (* UP TO THIS COLUMN POSITION, EACH TIME *) (* "INDENTBYTAB" IS INVOKED, THE MARGIN *) (* WILL BE INDENTED BY "INDENT2". BEYOND *) (* THIS, NO INDENTATION OCCURS. *) INDENT1 = 3; (* UP TO THE COLUMN POSTION,SLOFAIL1, EACH *) (* TIME "INDENTBYTAB" IS INVOKED,THE MARGIN*) (* WILL BE INDENTED THIS MUCH. *) INDENT2 = 1; (* WHEN THE COLUMN POSITION IS BETWEEN *) (* SLOFAIL1 AND SLOFAIL2, EACH TIME THE *) (* "INDENTBYTAB" IS INVOKED, THE MARGIN *) (* WILL BE INDENTED THIS MUCH. *) SPACE = ' '; TYPE KEYSYMBOL = ( FUNCSYM , PROCSYM , ISSYM , WHENSYM , LOOPSYM , TYPESYM , BEGINSYM , RECORDSYM , EXCEPTIONSYM, CASESYM , USESYM , EXITSYM , FORSYM , WHILESYM , WITHSYM , DOSYM , IFSYM , THENSYM , ELSESYM , SPECIALLOOPSYM , SPECIALISSYM, SEPARATESYM , SPECIALUSESYM , SPECIALORSYM, ELSIFSYM , PACKAGESYM , GENERICSYM , TASKSYM , DECLARESYM , SELECTSYM , ORSYM , ACCEPTSYM , BODYSYM , SPEXCEPTIONSYM , PRIVATESYM , NEWSYM , ABORTSYM , ABSSYM , ACCESSSYM , ALLSYM , ANDSYM , ARRAYSYM , ATSYM , CONSTANTSYM , DELAYSYM , DELTASYM , DIGITSSYM , ENTRYSYM , GOTOSYM , INSYM , SPECIALPKSYM, LIMITEDSYM , MODSYM , NOTSYM , NULLSYM , OFSYM , OTHERSSYM , OUTSYM , PRAGMASYM , RAISESYM , RANGESYM , REMSYM , RENAMESSYM , RETURNSYM , REVERSESYM , SUBTYPESYM , TERMINATESYM , XORSYM , SPECIALWTH , ENDSYM , BECOMES , ARROWSYM , OPENCOMMENT , SEMICOLON , SPSEMICOLON , COLON , EQUALS , OPENPAREN , CLOSEPAREN , UNDSCORE , SPECIALCOLON , PERIOD , ENDOFFILE , OTHERSYM ); OPTION = ( CRSUPPRESS , CRBEFORE , BLANKLINEBEFORE , DINDENT , SPACEBEFORE , SPACEAFTER , GOBBLESYMBOLS , INDENTMARGIN , INDENTBYTAB , CRAFTER ); OPTIONSET = SET OF OPTION; KEYSYMSET = SET OF KEYSYMBOL; TABLEENTRY = RECORD OPTIONSSELECTED : OPTIONSET; GOBBLETERMINATORS: KEYSYMSET END; OPTIONTABLE = ARRAY [ KEYSYMBOL ] OF TABLEENTRY; KEY = PACKED ARRAY [ 1..MAXKEYLENGTH ] OF CHAR; KEYWORDTABLE = ARRAY [ FUNCSYM..ENDSYM ] OF KEY; SPECIALCHAR = PACKED ARRAY [ 1..2 ] OF CHAR; DBLCHRSET = SET OF BECOMES..OPENCOMMENT; DBLCHARTABLE = ARRAY [ BECOMES..OPENCOMMENT ] OF SPECIALCHAR; SGLCHARTABLE = ARRAY [ SEMICOLON..PERIOD ] OF CHAR; STRING = ARRAY [ 1..MAXSYMBOLSIZE ] OF CHAR; SYMBOL = RECORD NAME : KEYSYMBOL; VALU : STRING; LENGTH : INTEGER; SPACESBEFORE: INTEGER; CRSBEFORE : INTEGER END; SYMBOLINFO = ^SYMBOL; CHARNAME = ( LETTER , UNDERSCORE , DIGIT , BLANK , QUOTE , ENDOFLINE , FILEMARK , TAB , OTHERCHAR ); (*CAW*) CHARINFO = RECORD NAME : CHARNAME; VALU : CHAR END; STACKENTRY = RECORD INDENTSYMBOL : KEYSYMBOL; PREVMARGIN : INTEGER; ENDSYMBOL : STRING; LLENGTH : INTEGER END; SYMBOLSTACK = ARRAY [ 1..MAXSTACKSIZE ] OF STACKENTRY; VAR LOOPSWITCH, (* USED TO SWITCH BETWEEN A BASIC LOOP AND AND A BASIC_LOOP USED WITH A ITERATION_ CLAUSE *) USESWITCH, (* USED TO DETECT A REPRESENTATION_SPECI- FICATION AS OPPOSED TO A USE CLAUSE *) ORSWITCH, (* USED TO DIFFERIENTATE BETWEEN A LOGICAL OPERATOR AND SELECTIVE-WAIT AND TIMED_ ENTRIE_CALLS *) WITHSEEN, (* USED TO DETECT THE PRESENCE OF A WITH_ CLAUSE-USE_CLAUSE COMBINATION *) ISSWITCH, (* USED TO DIFFERIENTATE BETWEEN A USESYM AND A SPECIALISSYM *) SPECIAL_FLAG, CRPENDING : BOOLEAN; TOP, (* NUMBER OF RECORDS ON THE STACK *) STARTPOS, (* STARTING POSITION OF LAST SYMBOL WRITTEN *) PARENINDENT, (* USED FOR INDENTION FOR: DISCRIMINANT_PART OF RECORDS; FORMAL_PART OF SUBPROGRAM DECLARATIONS; GENERIC_FORMAL_PARAMETER LIST*) PARENCOUNTER, (* INDICATES THE LEVEL OF NESTING OF PAREN- THESES SETS *) PREVMARGIN, (* VALUE OF PREVIOUS MARGIN, STORED ON STACK *) CURRLINEPOS, (* CURRENT LINE POSITION OF THE OUTPUT FILE *) CURRMARGIN : INTEGER; CURRCHAR, NEXTCHAR : CHARINFO; (*************************************************************************** --- CAW --- The following variables, with a brief description, have been added to make this pretty printer more versatile. CRSAFTER - Is used to print out the same number of carriage returns in the pretty printed file as there is in the source file. PRIVATE_FLAG - A boolean flag used to signal that the "private" keyword is the current symbol and the private section follows. This flag is used to DINDENT the "end" symbol for the package specification. RECORD_FLAG - A boolean flag that is used in conjunction with the PRIVATE_FLAG. It signals that a record definition exists in the private section and that an "end record" should be expected before the "end" for the specification. P_CASE_FLAG - A boolean flag used in conjunction with the PRIVATE_FLAG. It signals that a case statement exists within the private section and that an "end case" should be expected before the "end" for the package specification. SPECIAL_FLAG - A boolean flag used to signal whether the symbols "procedure" or "package" (without the keyword 'body') have been encountered. NUM_BEGINS - An integer flag that keeps count of the number of begin structures have been encountered -- so the corresponding ends can have the same indentation as their structure's initial indentation. BEGIN_FLAG - A boolean flag that is set to true when the keyword "begin" has been found. FIRST_BEGIN - A boolean flag that is set to true when the first begin, or loop structure, has been encountered. WHEN_FLAG - An integer flag used to keep count of the number of "when" statements that have been parsed. This is to provide for all of the related "when's" to have identical indentation. ---- All of the following variables are arrays of boolean flags. They are used to synchronize the ends with the begins in nested CASE, EXCEPTION, and block statements. By turning the flags off and on in an array, the index can be incremented as nesting occurs and the end statement will match the associated structure by stepping back through the array when an end is parsed. SPECIAL_BEGIN - Signals that a block statement is embedded in a CASE or EXCEPTION statement. EXCEPTION_FLAG - Signals that an exception statement has occurred and an end -- in the same column as the "exception" -- should be expected. CASE_FLAG - Signals that a case statement has been parsed and that an end statement -- in the same column as the CASE -- should be expected. SPECIAL_INDEX - The global index into the three arrays to keep track of the current level of nesting. *) CRSAFTER, NUM_BEGINS : INTEGER; WHEN_FLAG, SPECIAL_INDEX : INTEGER; BEGIN_FLAG : BOOLEAN; PRIVATE_FLAG, RECORD_FLAG, P_CASE_FLAG : BOOLEAN; FIRST_BEGIN : BOOLEAN; SPECIAL_BEGIN, CASE_FLAG, EXCEPTION_FLAG : ARRAY[1..100] OF BOOLEAN; (************************* CAW ***********************************) ENDIDENTIFIER : STACKENTRY; CURRSYM, NEXTSYM : SYMBOLINFO; PPOPTION : OPTIONTABLE; KEYWORD : KEYWORDTABLE; DBLCHARS : DBLCHRSET; DBLCHAR : DBLCHARTABLE; SGLCHAR : SGLCHARTABLE; STACK : SYMBOLSTACK; (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** WRITECRS ***) (*** ***) (*** DESCRIPTION ***) (*** THIS PROCEDURE WRITES TO THE OUTPUT FILE. IF ***) (*** "CRSBEFORES" EQUALS ZERO, THEN NOTHING IS WRITTEN. ***) (*** IF "CRSBEFORE" EQUALS N, THEN N-1 BLANK LINES ARE ***) (*** INSERTED AND THE CURRENT LINE POSTION SET TO ZERO ***) (*** IN ALL CASES WHREE N IF GREATER THAN ZERO. ***) (*** ***) (*** ***) (*** INPUTS ***) (*** NUMBEROFCRS--- NUMBER OF CARRIAGE RETURNS TO BE ***) (*** OUTPUT PRIOR TO OUTPUTING THE ***) (*** CURRENT SYMBOL ***) (*** ***) (*** OUTPUTS ***) (*** CURRLINEPOS--- SET TO ZERO ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** INSERTCR ***) (*** INSERTBLANKLINE ***) (*** PPSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE WRITECRS( (* USING *) NUMBEROFCRS : INTEGER; (* UPDATING *) VAR CURRLINEPOS : INTEGER (* WRITING TO OUTPUT *) ); VAR I: INTEGER; BEGIN (* WRITECRS *) IF NUMBEROFCRS > 0 THEN BEGIN FOR I := 1 TO NUMBEROFCRS DO WRITELN; CURRLINEPOS := 0 END END; (* WRITECRS *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETCHAR ***) (*** ***) (*** DESCRIPTION ***) (*** THE PURPOSE OF THIS PROCEDURE IS THREEFOLD; ***) (*** A- BEFORE FETCHING THE NEST CHARACTER FROM THE ***) (*** INPUT-FILE,IT UPDATES THE CURRENT-CHARACTER ***) (*** TO THE VALUE OF THE PREVIOUS NEXT-CHARACTER. ***) (*** B- EXAMINATION AND CLASSIFICATION OF THE CHARACTER ***) (*** NAME OF THE NEXT CHARACTER ON THE INPUT FILE. ***) (*** C- READ THE NEXT CHARACTER FROM THE INPUT FILE. ***) (*** ***) (*** INPUTS ***) (*** NONE ***) (*** ***) (*** OUTPUTS ***) (*** CURRCHAR ***) (*** NEXTCHAR ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** STORENEXTCHAR ***) (*** SKIPSPACES ***) (*** INITIALIZE ***) (*** ***) (**********************************************************************) PROCEDURE GETCHAR( (* FROM INPUT *) (* UPDATING *) VAR NEXTCHAR : CHARINFO; (* RETURNING *) VAR CURRCHAR : CHARINFO ); CONST (*CAW*) TAB_CHAR = ' '; (*CAW*) BEGIN (* GETCHAR *) CURRCHAR := NEXTCHAR; WITH NEXTCHAR DO BEGIN IF EOF(INPUT) THEN NAME := FILEMARK ELSE IF EOLN(INPUT) THEN NAME := ENDOFLINE ELSE IF INPUT^ IN ['A'..'Z','a'..'z'] THEN NAME := LETTER ELSE IF INPUT^ = '_' THEN NAME := UNDERSCORE ELSE IF INPUT^ IN ['0'..'9'] THEN NAME := DIGIT ELSE IF INPUT^ = '"' THEN NAME := QUOTE ELSE IF INPUT^ = SPACE THEN NAME := BLANK ELSE IF INPUT^ = TAB_CHAR (*CAW*) THEN NAME := TAB (*CAW*) ELSE NAME := OTHERCHAR; IF NAME IN [ FILEMARK, ENDOFLINE ] THEN VALU := SPACE ELSE VALU := INPUT^; IF NAME <> FILEMARK THEN GET(INPUT) END (* WITH *) END; (* GETCHAR *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** STORENEXTCHAR ***) (*** ***) (*** DESCRIPTION ***) (*** THE ADA PRETTYPRINTER PROCESSES ONE TOKEN AT A TIME. ***) (*** THE INPUT-FILE IS CONTINOUSLY READ, ONE CHARACTER AT A ***) (*** TIME, UNTIL A COMPLETE TOKEN IS OBTAINED. THIS PROCED- ***) (*** URE PROVIDES THE BUFFER TO STORE THE INPUT CHARACTER ***) (*** UNTIL A COMPLETE TOKEN STORED. ***) (*** ***) (*** ***) (*** INPUTS ***) (*** CURRCHAR.VALUE--THE VALUE OF THE CURRENT CHARACTER. ***) (*** LENGTH-- THE NUMBER OF CHARACTERS PRESENTLY STORED ***) (*** IN THE INPUT BUFFER. ***) (*** ***) (*** OUTPUTS ***) (*** LENGTH-- THE UPDATED LENGTH OF THE PRESENT INPUT ***) (*** CHARACTER STRING. ***) (*** VALU-- ARRAY WHOSE COMPONETS CONTAINS THE CHARACTERS ***) (*** OF THE CURRENT TOKEN OF THE INPUT FILE. ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** GETCHAR ***) (*** ***) (*** REFERENCED BY ***) (*** GETCOMMENT ***) (*** GETIDENTIFIER ***) (*** GETNUMBER ***) (*** GETSTRINGLITERAL ***) (*** GETSPECIALCHAR ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) VAR LENGTH : INTEGER; VAR CURRCHAR, NEXTCHAR : CHARINFO; (* PLACING IN *) VAR VALU : STRING ); BEGIN (* STORENEXTCHAR *) GETCHAR( (* FROM INPUT *) (* UPDATING *) NEXTCHAR, (* RETURNING *) CURRCHAR ); IF LENGTH < MAXSYMBOLSIZE THEN BEGIN LENGTH := LENGTH + 1; VALU [LENGTH] := CURRCHAR.VALU END END; (* STORENEXTCHAR *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** SKIPSPACES ***) (*** ***) (*** DESCRIPTION ***) (*** THE PURPOSE OF THIS PROCEDURE IS TO CONTINOUSLY READ ***) (*** THE INPUT FILE UNTIL A CHARACTER IS READ WHICH IS NOT ***) (*** A BLANK. THE NUMBER OF BLANKS READ IS RECORDED AS WELL ***) (*** AS THE NUMBER OF CARRIAGE RETURNS ENCOUNTERED. ***) (*** ***) (*** INPUTS ***) (*** CURRCHAR.NAME-- FROM THE INPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** SPACESBEFORE-- NUMBER OF SPACES ENCOUNTERED PRIOR TO ***) (*** NEXT SYMBOL ON THE INPUT FILE. ***) (*** CRSBEFORE----- NUMBER OF CARRIAGE RETURNS ENCOUNTERED ***) (*** INPUT FILE PRIOR TO THE NEXT SYMBOL. ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** GETCHAR ***) (*** ***) (*** REFERENCED BY ***) (*** GETSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE SKIPSPACES( (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; (* RETURNING *) VAR SPACESBEFORE, CRSBEFORE : INTEGER ); BEGIN (* SKIPSPACES *) SPACESBEFORE := 0; CRSBEFORE := 0; WHILE NEXTCHAR.NAME IN [ BLANK, ENDOFLINE, TAB ] DO (*CAW*) BEGIN GETCHAR( (* FROM INPUT *) (* UPDATING *) NEXTCHAR, (* RETURNING *) CURRCHAR ); CASE CURRCHAR.NAME OF ENDOFLINE: BEGIN SPACESBEFORE := 0; CRSBEFORE := CRSBEFORE + 1; END; BLANK : SPACESBEFORE := SPACESBEFORE + 1; TAB : SPACESBEFORE := SPACESBEFORE + 6; (*CAW*) END; (*CASE*) END (* WHILE *) END; (* SKIPSPACES *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETCOMMENT ***) (*** ***) (*** DESCRIPTION ***) (*** THE PURPOSE OF THIS PROCEDURE IS TO CONTINOUSLY ***) (*** READ AND STORE ALL CHARACTERS FROM THE INPUT FILE ***) (*** UNTIL THE OF END OF A LINE (WHICH REPRESENTS THE END ***) (*** OF THE COMMENT) IS DETECTED. ***) (*** ***) (*** INPUTS ***) (*** NEXTCHAR.NAME-- THE NAME OF THE NEXT CHARACTER FROM ***) (*** THE INPUT FILE (USED TO TERMINATE THE ***) (*** READ OPERATIONS). ***) (*** ***) (*** OUTPUTS ***) (*** NONE ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STORENEXTCHAR ***) (*** ***) (*** REFERENCED BY ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE GETCOMMENT( (* FROM INPUT *) (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; VAR NAME : KEYSYMBOL; VAR VALU : STRING; VAR LENGTH : INTEGER ); BEGIN (* GETCOMMENT *) NAME := OPENCOMMENT; WHILE NOT ( (NEXTCHAR.NAME = ENDOFLINE) OR (NEXTCHAR.NAME = FILEMARK)) DO STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU); END; (* GETCOMMENT *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** IDTYPE ***) (*** ***) (*** DESCRIPTION ***) (*** AFTER A INPUT TOKEN IS DETERMINED TO BE AN ***) (*** IDENTIFIER, IT IS NECESSARY TO DETERMINE IF ***) (*** THE IDENTIFIER IS ONE OF THE KEYWORDS IN THE KEYWORD- ***) (*** TABLE WHICH REQUIRES SPECIAL PROCESSING. IF IT IS ***) (*** NOT A KEYWORD, THEN IT IS NAMED AN "OTHERSYM" FOR PRO- ***) (*** PROCESSING. THIS IS ACCOMPLISHED BY: ***) (*** A- WRITING THE IDENTIFIER INTO KEYVALU WHICH IS ***) (*** AN OBJECT OF THE PACKED ARRAY "KEY". ***) (*** B- FILLING THE REST OF THE PACKED ARRAY WITH ***) (*** BLANKS UP TO MAXKEYLENGTH. ***) (*** C- LOOPING THROUGH THE KEYWORDTABLE AND COMPARING ***) (*** "KEYVALU" TO KEYWORD. ***) (*** D- IF A COMPARISON IS TRUE THEN THE IDENTIFIER IS ***) (*** ASSIGNED THE VALUE OF THE KEYSYMBOL. ***) (*** ***) (*** INPUTS ***) (*** LENGTH-- THE NUMBER OF CHARACTER IN THE STRING ***) (*** OF THE NAME OF THE IDENTIFIER. ***) (*** VALU---- THE ARRAY WHOSE COMPONETS ARE THE CHAR- ***) (*** ACTERS OF THE NAME OF THE IDENTIFIER. ***) (*** ***) (*** OUTPUTS ***) (*** IDTYPE-- EQUAL "OTHERSYM" IF VALU IS NOT IN THE ***) (*** KEYWORDTABLE. IF VALU IS FOUND IN THE ***) (*** KEYWORDTABLE THE IDTYPE IS SET TO THIS ***) (*** SYMBOL. ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** GETIDENTIFIER ***) (*** ***) (**********************************************************************) FUNCTION IDTYPE( (* OF *) VALU : STRING; (* USING *) LENGTH : INTEGER ) (* RETURNING *) : KEYSYMBOL; VAR I : INTEGER; KEYVALU : KEY; HIT : BOOLEAN; THISKEY : KEYSYMBOL; BEGIN (* IDTYPE *) IDTYPE := OTHERSYM; IF LENGTH <= MAXKEYLENGTH THEN BEGIN FOR I := 1 TO LENGTH DO IF ORD(VALU[I]) > ORD('Z') THEN KEYVALU[I] := CHR(ORD(VALU[I])-32) ELSE KEYVALU [I] := VALU [I]; FOR I := LENGTH + 1 TO MAXKEYLENGTH DO KEYVALU [I] := SPACE; THISKEY := FUNCSYM; HIT := FALSE; WHILE NOT (HIT OR (THISKEY = SUCC(ENDSYM))) DO IF KEYVALU = KEYWORD [THISKEY] THEN HIT := TRUE ELSE THISKEY := SUCC(THISKEY); IF HIT THEN IDTYPE := THISKEY END; END; (* IDTYPE *) (**********************************************************************) (* -- RLC -- CAPITALIZATION AND LOWER-CASE CONVERSION ROUTINES *) (* ROUTINES *) (* TOUPPER -- CONVERTS INPUT CHAR TO UPPER CASE IF LOWER CASE *) (* TOLOWER -- CONVERTS INPUT CHAR TO LOWER CASE IF UPPER CASE *) (**********************************************************************) FUNCTION TOUPPER (INCH : CHAR) : CHAR; BEGIN IF INCH IN ['a'..'z'] THEN TOUPPER := CHR(ORD(INCH) - ORD(' ')) ELSE TOUPPER := INCH; END; (* TOUPPER *) FUNCTION TOLOWER (INCH : CHAR) : CHAR; BEGIN IF INCH IN ['A'..'Z'] THEN TOLOWER := CHR(ORD(INCH) + ORD(' ')) ELSE TOLOWER := INCH; END; (* TOLOWER *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETIDENTIFIER ***) (*** ***) (*** DESCRIPTION ***) (*** WHEN THE FIRST CHARACTER OF A TOKEN FROM ***) (*** THE INPUT FILE IS A LETER (A..Z) , THEN THIS PRO- ***) (*** CEDURE IS CALLED AND WILL CONTINUE TO READ AND STORE ***) (*** CHARACTERS FROM THE INPUT FILE AS LONG AS THEY ARE ***) (*** LETTERS (A..Z), NUMBERS (0..9) OR AN UNDERSCORE (_). ***) (*** AFTER THE COMPLETE TOKEN IS READ AND STORED, A CALL ***) (*** TO FUNCTION IDTYPE IS MADE TO IDENTIFY THE SPECIFIC ***) (*** SYMBOL. ***) (*** ***) (*** MODIFICATION BY RLC ***) (*** OPTIONAL CAPITALIZATION IS PERFORMED OF THE IDENTIFIER ***) (*** BASED ON CAPITALIZEID (CAP IDENTIFIERS) AND CAPITALIZEKEY ***) (*** (CAP KEYWORDS) GLOBAL VARIABLES ***) (*** ***) (*** INPUTS ***) (*** NEXTCHAR.NAME-- THE NAME OF THE NEXT CHARACTER ***) (*** FROM THE INPUT FILE. ***) (*** ***) (*** OUTPUTS ***) (*** NONE ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STORENEXTCHAR ***) (*** IDTYPE ***) (*** ***) (*** REFERENCED BY ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE GETIDENTIFIER( (* FROM INPUT *) (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; (* RETURNING *) VAR NAME : KEYSYMBOL; VAR VALU : STRING; VAR LENGTH : INTEGER ); VAR I : INTEGER; BEGIN (* GETIDENTIFIER *) WHILE NEXTCHAR.NAME IN [ LETTER .. DIGIT ] DO STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ); NAME := IDTYPE( (* OF *) VALU, (* USING *) LENGTH ); (* -- RLC -- CAPITALIZATION ROUTINE FOR KEYWORDS/IDENTIFIERS *) FOR I := 1 TO LENGTH DO BEGIN IF (NAME = OTHERSYM) AND CAPITALIZEID THEN VALU[I] := TOUPPER(VALU[I]); IF (NAME = OTHERSYM) AND (NOT CAPITALIZEID) THEN VALU[I] := TOLOWER(VALU[I]); IF (NOT (NAME = OTHERSYM)) AND CAPITALIZEKEY THEN VALU[I] := TOUPPER(VALU[I]); IF (NOT (NAME = OTHERSYM)) AND (NOT CAPITALIZEKEY) THEN VALU[I] := TOLOWER(VALU[I]); END; (* -- RLC -- *) END; (* GETIDENTIFIER *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETNUMBER ***) (*** ***) (*** DESCRIPTION ***) (*** WHEN THE FIRST CHARACTER OF A TOKEN FROM THE ***) (*** FILE IS A DIGIT (0..9), THEN THIS PROCEDURE IS ***) (*** CALLED TO CONTINUOUSLY READ AND STORE CHARACTERS ***) (*** FROM THE INPUT FILE AS LONG AS THEY ARE DIGITS OR ***) (*** AN UNDERSCORE (_) OR HASH (#) OR DOT (.) OR LETTER. ***) (*** AFTER THE COMPLETE TOKEN ***) (*** IS READ AND STORED, THE NUMBER IS ASSIGNED THE NAME ***) (*** "OTHERSYM" FOR FURTHER PROCESSISNG. ***) (*** ***) (*** INPUTS ***) (*** NEXTCHAR--FROM THE INPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** NAME---- CURRENT TOKEN("CURRSYM") AND IS EQUAL ***) (*** TO "OTHERSYM" ***) (*** LENGTH-- NUMBER OF CHARACTERS IN THE NUMBER ***) (*** VALU---- PACKED ARRAY CONTAINING THE CHARACTERS ***) (*** (DIGITS, UNDERSCORES) OF THE NUMBER ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STORENEXTCHAR ***) (*** ***) (*** REFERENCED BY ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE GETNUMBER( (* FROM INPUT *) (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; (* RETURNING *) VAR NAME : KEYSYMBOL; VAR VALU : STRING; VAR LENGTH : INTEGER ); BEGIN (* GETNUMBER *) WHILE (NEXTCHAR.NAME IN [ DIGIT, UNDERSCORE, LETTER ]) OR (NEXTCHAR.VALU = '.') OR (NEXTCHAR.VALU = '#') DO STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ); NAME := OTHERSYM END; (* GETNUMBER *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETSTRINGLITERAL ***) (*** ***) (*** DESCRIPTION ***) (*** WHEN THE FIRST CHARACTER OF A TOKEN FROM THE ***) (*** INPUT FILE IS A QUOTE ('), THEN THIS PROCEDURE IS ***) (*** CALLED BY THE PROCEDURE GETNEXTSYMBOL TO CONTINUOUSLY ***) (*** READ AND STORE CHARACTERS FROM THE INPUT FILE UNTIL ***) (*** THE ENTIRE CHARACTER LITERAL IS READ AND STORED. BE- ***) (*** "OTHERSYM" FOR SUBSEQUENT PROCESSING. ***) (*** ***) (*** INPUTS ***) (*** NEXTCHAR.NAME -- NAME OF THE NEXT CHARACTER FROM THE ***) (*** INPUT FILE. ***) (*** ***) (*** OUTPUTS ***) (*** NAME --- NAME OF CURRENT SYMBOL AND EQUALS "OTHERSYM". ***) (*** LENGTH - NUMBER OF CHARACTERS IN THE CHARACTER LITERAL ***) (*** INCLUDING THE QUOTE CHARACTERS. ***) (*** VALU --- PACKED ARRAY CONTAINING THE CHARACTER OF THE ***) (*** CHARACTERAL LITERAL. ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STORENEXTCHAR ***) (*** ***) (*** REFERENCED BY ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE GETSTRINGLITERAL( (* FROM INPUT *) (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; (* RETURNING *) VAR NAME : KEYSYMBOL; VAR VALU : STRING; VAR LENGTH : INTEGER ); BEGIN (* GETSTRINGLITERAL *) WHILE NEXTCHAR.NAME = QUOTE DO BEGIN STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ); WHILE NOT(NEXTCHAR.NAME IN [ QUOTE, ENDOFLINE, FILEMARK ]) DO STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ); IF NEXTCHAR.NAME = QUOTE THEN STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ) END; NAME := OTHERSYM END; (* GETSTRINGLITERAL *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** CHARTYPE ***) (*** ***) (*** DESCRIPTION ***) (*** THIS FUNCTION WILL LOOP THROUGH A SET OF ***) (*** SPECIAL CHARACTERS TO SEE IF THE CURRENT CHAR- ***) (*** ACTER(FIRST CHARACTER OF THE NEXT TOKEN ON THE ***) (*** INPUT FILE) AND POSSIBLY THE NEXT CHARACTER ( ***) (*** NEXTCHAR) BELONG TO THE SET OF (':=', '=>', ***) (*** '--', ';', ':', '_', '(', ')', '='). IF SO, ***) (*** THE NAME OF THE SYMBOL IS RETURNED. IF NOT ***) (*** "OTHERSYM" IS RETURNED. ***) (*** ***) (*** INPUTS ***) (*** CURRCHAR -- FROM THE INPUT FILE ***) (*** NEXTCHAR -- FROM THE INPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** CHARTYPE -- NAME OF THE SYMBOL IF FOUND, ***) (*** OTHERWISE EQUALS "OTHERSYM". ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** GETSPECIALCHAR ***) (*** ***) (**********************************************************************) FUNCTION CHARTYPE( (* OF *) CURRCHAR, NEXTCHAR : CHARINFO ) (* RETURNING *) : KEYSYMBOL; VAR NEXTTWOCHARS: SPECIALCHAR; HIT: BOOLEAN; THISCHAR: KEYSYMBOL; BEGIN (* CHARTYPE *) NEXTTWOCHARS[1] := CURRCHAR.VALU; NEXTTWOCHARS[2] := NEXTCHAR.VALU; THISCHAR := BECOMES; HIT := FALSE; WHILE NOT(HIT OR (THISCHAR = SEMICOLON)) DO IF NEXTTWOCHARS = DBLCHAR [THISCHAR] THEN HIT := TRUE ELSE THISCHAR := SUCC(THISCHAR); IF NOT HIT THEN BEGIN THISCHAR := SEMICOLON; WHILE NOT(HIT OR (PRED(THISCHAR) = PERIOD)) DO IF CURRCHAR.VALU = SGLCHAR [THISCHAR] THEN HIT := TRUE ELSE THISCHAR := SUCC(THISCHAR) END; IF HIT THEN CHARTYPE := THISCHAR ELSE CHARTYPE := OTHERSYM END; (* CHARTYPE *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETSPECIALCHAR ***) (*** ***) (*** DESCRIPTION ***) (*** IF THE NAME OF THE FIRST CHARACTER OF THE NEXT ***) (*** TOKEN FROM THE INPUT FILE IS NOT IN ( FILEMARK, END- ***) (*** OFLINE, LETTER, UNDERSCORE, DIGIT, QUOTE, SPACE, BLANK) ***) (*** THEN IT IS INITIALLY LABLED AS A "OTHERCHAR". THIS ***) (*** PROCEDURE WILL CALL THE FUNCTION CHARTYPE TO ATTEMPT ***) (*** TO FURTHER IDENTIFY IT FOR SPECIALIZED PROCESSING. ***) (*** ***) (*** INPUTS ***) (*** CURRCHAR -- FROM THE INPUT FILE ***) (*** NEXTCHAR -- FROM THE INPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** NAME --- NAME OF THE CURRENT SYMBOL ***) (*** LENGTH - NUMBER OF CHARACTERS OF THE SYMBOL ***) (*** VALU --- PACKED ARRAY CONTAINING THE CHARACTERS ***) (*** OF THE SYMBOL. ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STORENEXTCHAR ***) (*** ***) (*** REFERENCED BY ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE GETSPECIALCHAR( (* FROM INPUT *) (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; (* RETURNING *) VAR NAME : KEYSYMBOL; VAR VALU : STRING; VAR LENGTH : INTEGER ); BEGIN (* GETSPECIALCHAR *) STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ); NAME := CHARTYPE( (* OF *) CURRCHAR, NEXTCHAR ); IF NAME IN DBLCHARS THEN STORENEXTCHAR( (* FROM INPUT *) (* UPDATING *) LENGTH, CURRCHAR, NEXTCHAR, (* IN *) VALU ) END; (* GETSPECIALCHAR *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** CHECKSYMBOL ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** IN MANY APPLICATIONS THE INDENTATION OF KEYWORDS VARIES ***) (*** AS A FUNCTION OF IT APPLICATION. SUCH IS THE CASE FOR THE ***) (*** ADA PRETTYPRINTER. THE PURPOSE OF THIS PROCEDURE IS TO ***) (*** DETERMINE THE APPLICATION IN ORDER TO PROPERLY PERFORM THE ***) (*** FORMATTING OF THE OUTPUT. THIS PROCEDURE WILL: ***) (*** ***) (*** A- DIFFERIENTIATE BETWEEN A "BASIC_LOOP" ACTING ALONE ***) (*** OR USED IN CONJUNCTION WITH A "ITERATION_CLAUSE". ***) (*** THIS IS ACCOMPLISHED BY SETTING A FLAG, "LOOPSWITCH",***) (*** WHENEVER A "FOR" OR A "WHILE" KEYWORD IS ENCOUNTERED ***) (*** AND RESETTING IT WHEN A ";" IS PROCESSED(INDICATING ***) (*** THE END OF THE RANGE OF THE "LOOPSWITCH"). WHEN THE ***) (*** "BASIC_LOOP" IS USED ALONE, THE KEYWORD "LOOP" IS ***) (*** FORCED ON A LINE BY ITSELF AND THE "SEQUENCE_OF_ ***) (*** STATEMENTS" IS INDENTED. ***) (*** ***) (*** B- DETECT THE USE OF "SELECTIVE_WAIT" AND "TIMED_ENTRY_ ***) (*** CALL" STATEMENTS. THIS IS REQUIRED TO PROPERLY PRO- ***) (*** CESS THE KEYOWRD "OR" TO DIFFERIENTIATE ITS USEAGE ***) (*** WITH THESE STATEMENTS AS OPPOSED TO A "LOGICAL_OPER- ***) (*** ATOR". WHEN THE KEYWORD "SELECT" IS PROCESSED. THE ***) (*** SWITCH IS RESET WHEN THE "END SELECT" IS PROCESSED. ***) (*** ***) (*** C- DETECT THE USE OF "REPRESENTATION_SPECIFICATION". ***) (*** THIS IS NECESSARY BECAUSE OF THE "FOR-LOOP" STATE- ***) (*** MENTS. THE PRETTYPRINTER ASSUMES THAT WHEN A "FOR" ***) (*** IS ENCOUNTERED THAT THE STATEMENT IS A "FOR-LOOP" ***) (*** STATEMENT AND THE MARGIN IS INDENTED. HOWEVER, IF ***) (*** A "USE" KEYWORD IS DETECTED PRIOR TO A "LOOP" KEY- ***) (*** WORD, THEN IT IS EVIDENT THAT THE STATEMENT BEING ***) (*** PROCESSED IS A "REPRESENTATION_SPECIFICATION" AND ***) (*** THE MARGIN IS DEINDENTED. ***) (*** ***) (*** D- DETECT THE PRESENCE OF A "WITH_CLAUSE-USE_CLAUSE" ***) (*** COMBINATION. THIS IS THE ONLY CASE WHEN TWO STATE- ***) (*** MENTS ARE ALLOWED ON THE SAME LINE ACCORDING TO THE ***) (*** RULES. THIS IS ACCOMPLISHED BY: ***) (*** ***) (*** 1- FIRST, THE SETTING OF THE FLAG, "WITHSEEN", ***) (*** UPON DETECTION OF THE KEYWORD "WITH". ***) (*** 2- WHEN THE NEXT ";" IS PROCESSED, EXAMINE THE ***) (*** KEYWORD AND IF IT IS A "USE" KEYWORD THEN ***) (*** SUPPRESS A CARRIAGE RETURN FOLLOWING THE SEMI-***) (*** COLON. ***) (*** ***) (*** E- DETECT THE PRESENCE OF A BODY STUB. THIS IS NECES- ***) (*** SARY BECAUSE THE PRETTYPRINTER ASSUMES THAT WHEN ANY ***) (*** ONE OF THE KEYWORDS "PROCEDURE", "FUNCTION", "TASK" ***) (*** OR "PACKAGE" IS DECTED FOLLOWED BY THE KEYWORD "IS" ***) (*** THAT A FULL COMPILATION UNIT IS BEING PROCESSED ***) (*** WHICH CALLS FOR A CARRIAGE RETURN FOLLOWING THE ***) (*** KEYWORD "IS". IF THE NEXT SYMBOL IS THE KEYWORD ***) (*** "SEPARATE" THEN THE PRETTYPRINTER CORRECTS ITSELF ***) (*** KNOWS THAT IT IS NOW PROCESSING A "BODY_STUB" AND ***) (*** SUPPRESSES THE CARRIAGE RETURN. ***) (*** ***) (*** F- DIFFERIENTIATE BETWEEN AN "EXCEPTION_DECLARATION" ***) (*** AND AN "EXCEPTION_HANDLER". THIS IS ACCOMPLISHED ***) (*** BY EXAMINING THE CURRENT SYMBOL AND THE NEXT SYMBOL ***) (*** TOGETHER. IF THE CURRENT SYMBOL IS A COLON,":", ***) (*** AND IF THE NEXT SYMBOL IS THE KEYWORD "EXCEPTION", ***) (*** THEN IT IS AN "EXCEPTION_DECLARATION", OTHERWISE ***) (*** IT IS AN "EXCEPTION_HANDLER". ***) (*** ***) (*** G- DETECT THE PRESENCE OF A BLOCK.. THIS IS ACCOMP- ***) (*** LISHED BY ALSO EXAMINING THE CURRENT SYMBOL AND THE ***) (*** COLLECTIVELY. IF THEY ARE ":" AND "DECLARE" OR ***) (*** ":" AND "BEGIN" THEN A BLOCK IS BEING PROCESSED. ***) (*** ***) (*** H- DIFFERIENTIATE BETWEEN A "SUBPROGRAM_DECLARATION" ***) (*** AND A "SUBPROGRAM_SPECIFICATION". THIS IS ACCOMP- ***) (*** LISHED BY: ***) (*** ***) (*** 1- IF THE KEYWORD "PROCEDURE", "FUNCTION", ***) (*** "TASK" OR "PACKAGE" IS ENCOUNTERED, ASSUME ***) (*** IT IS A "SUBPROGRAM_SPECIFICATION" AND SET ***) (*** THE MARGIN FOR INDENTATION. ***) (*** 2- IF, HOWEVER, A SEMICOLON,";", IS ENCOUNTERED ***) (*** PRIOR TO THE KEYWORD "IS", THEN DEINDENT THE ***) (*** MARGIN. ***) (*** ***) (*** INPUTS ***) (*** CURRSYM--FROM THE INPUT FILE ***) (*** NEXTSYM--FROM THE INPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** CURRSYM ***) (*** NEXTSYM ***) (*** LOOPSWITCH ***) (*** ORSWITCH ***) (*** USESWITCH ***) (*** ISSWITCH ***) (*** WITHSEEN ***) (*** ***) (*** PROCEDURE REFERENCED BY: ***) (*** GETNEXTSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE CHECKSYMBOL( VAR PARM : SYMBOLINFO); BEGIN (*CHECKSYMBOL*) WITH PARM^ DO CASE NAME OF FORSYM : BEGIN LOOPSWITCH := TRUE; USESWITCH := TRUE; END; USESYM : IF USESWITCH THEN BEGIN USESWITCH := FALSE; NEXTSYM^.NAME := SPECIALUSESYM; END; SELECTSYM : ORSWITCH := TRUE; ORSYM : IF ORSWITCH THEN CURRSYM^.NAME := SPECIALORSYM; ENDSYM : ORSWITCH := FALSE; LOOPSYM : IF LOOPSWITCH THEN BEGIN LOOPSWITCH := FALSE; NEXTSYM^.NAME := SPECIALLOOPSYM; END; WHILESYM : LOOPSWITCH := TRUE; WITHSYM : WITHSEEN := TRUE; SEMICOLON : BEGIN IF NEXTSYM^.NAME = USESYM THEN CURRSYM^.NAME := SPSEMICOLON; WITHSEEN := FALSE; IF NOT(NEXTSYM^.NAME IN [ FORSYM, WHILESYM ]) THEN LOOPSWITCH := FALSE; IF PARENCOUNTER = 0 THEN ISSWITCH := FALSE; END; SEPARATESYM : IF ISSWITCH THEN ISSWITCH := FALSE; PROCSYM, FUNCSYM, TASKSYM, PACKAGESYM : BEGIN FIRST_BEGIN := FALSE; BEGIN_FLAG := FALSE; ISSWITCH := TRUE; ENDIDENTIFIER.ENDSYMBOL := NEXTSYM^.VALU; ENDIDENTIFIER.LLENGTH := NEXTSYM^.LENGTH; END; CASESYM : ISSWITCH := TRUE; ACCEPTSYM, BODYSYM : BEGIN ENDIDENTIFIER.ENDSYMBOL := NEXTSYM^.VALU; ENDIDENTIFIER.LLENGTH := NEXTSYM^.LENGTH; END; ISSYM : IF ISSWITCH THEN BEGIN ISSWITCH := FALSE; CURRSYM^.NAME := SPECIALISSYM; END; COLON : IF NAME IN [ DECLARESYM, BEGINSYM ] THEN CURRSYM^.NAME := SPECIALCOLON ELSE IF NEXTSYM^.NAME = EXCEPTIONSYM THEN NEXTSYM^.NAME := SPEXCEPTIONSYM; END; (*CASE*) END; (*CHECKSYMBOL*) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETNEXTSYMBOL ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE EXAMINES THE NEXT CHARACTER NAME OF THE ***) (*** FIRST CHARACTER OF THE NEXT TOKEN ON THE INPUT FILE TO DET- ***) (*** MINE THE TYPE OF THE NEXT TOKEN AND THEN CALLS THE APPRO- ***) (*** PRIATE PROCEDURE TO FETCH THE TOKEN. ***) (*** ***) (*** INPUTS ***) (*** NEXTCHAR------FROM THE INPUT FILE ***) (*** GOBBLESWITCH--TRUE IF IN THE GOBBLE MODE ***) (*** NAME----------COMPONET OF "NEXTSYM" ***) (*** ***) (*** OUTPUTS ***) (*** CURRCHAR--UPDATED VALUE ***) (*** NEXTCHAR--UPDATED VALUE ***) (*** NAME------OF NEXT SYMBOL ***) (*** LENGTH----NUMBER OF CHARACTERS IN NAME STRING ***) (*** VALU------ARRAY WHOSE COMPONETS CONTAINS THE ***) (*** CHARACTERS OF THE NAME ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** GETIDENTIFIER ***) (*** STORENEXTCHAR ***) (*** GETNUMBER ***) (*** GETSTRINGLITERAL ***) (*** GETSPECIALCHAR ***) (*** GETCOMMENT ***) (*** ***) (*** REFERENCED BY ***) (*** GETSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE GETNEXTSYMBOL( (* FROM INPUT *) (* UPDATING *) VAR CURRCHAR, NEXTCHAR : CHARINFO; (* RETURNING *) VAR NAME : KEYSYMBOL; VAR VALU : STRING; VAR LENGTH : INTEGER ); BEGIN (* GETNEXTSYMBOL *) CASE NEXTCHAR.NAME OF LETTER : GETIDENTIFIER( (* FROM INPUT *) (* UPDATING *) CURRCHAR, NEXTCHAR, (* RETURNING *) NAME, VALU, LENGTH ); UNDERSCORE : BEGIN STORENEXTCHAR(LENGTH , CURRCHAR, NEXTCHAR, VALU); GETNEXTSYMBOL ( CURRCHAR, NEXTCHAR, NAME, VALU, LENGTH ); END; DIGIT : GETNUMBER( (* FROM INPUT *) (* UPDATING *) CURRCHAR, NEXTCHAR, (* RETURNING *) NAME, VALU, LENGTH ); QUOTE : GETSTRINGLITERAL( (* FROM INPUT *) (* UPDATING *) CURRCHAR, NEXTCHAR, (* RETURNING *) NAME, VALU, LENGTH ); OTHERCHAR : BEGIN GETSPECIALCHAR( (* FROM INPUT *) (* UPDATING *) CURRCHAR, NEXTCHAR, (* RETURNING *) NAME, VALU, LENGTH ); IF NAME=OPENCOMMENT THEN GETCOMMENT( (* FROM INPUT *) (* UPDATING *) CURRCHAR, NEXTCHAR, NAME, VALU, LENGTH); END; FILEMARK : NAME := ENDOFFILE END (* CASE *); END; (* GETNEXTSYMBOL *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GETSYMBOL ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THE PURPOSE OF THIS PROCEDURE IS TO UPDATE THE CURRENT ***) (*** SYMBOL TO THE VALUE OF THE PLREVIOUS "NEXTSYM". THE NEXT ***) (*** SYMBOL FROM THE INPUT FILE IS FETCHED AND THE VARIABLE ***) (*** "NEXTSYM" IS UPDATED WITH THIS SYMBOL. THIS PROCEDURE ***) (*** ALSO RESTRICTS THE NUMBER OF SPACES BETWEEN SYMBOL TO ONE ***) (*** AND REMOVES EXTRANEOUS BLANK LINES FROM THE OUTPUT ***) (*** ***) (*** INPUTS ***) (*** CURRSYM ----- FROM THE INPUT FILE ***) (*** NEXTSYM ----- FROM THE INPUT FILE ***) (*** CURRLINEPOS-- OF THE OUTPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** CURRCHAR ---- UPDATED VALUE ***) (*** NEXTCHAR ---- UPDATED VALUE ***) (*** CURRSYM ---- UPDATED VALUE ***) (*** NEXTSYM ---- UPDATED VALUE ***) (*** STARTPOS ---- SAVED FOR INDENTATION PURPOSES ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** SKIPSPACES ***) (*** CHECKSYMBOL ***) (*** GETNEXTSYMBOL ***) (*** ***) (*** REFERENCED BY ***) (*** INITIALIZE ***) (*** GOBBLE ***) (*** PRINTENDIDENTIFIER ***) (*** ***) (**********************************************************************) PROCEDURE GETSYMBOL( (* FROM INPUT *) (* UPDATING *) VAR NEXTSYM : SYMBOLINFO; (* RETURNING *) VAR CURRSYM : SYMBOLINFO ); VAR DUMMY: SYMBOLINFO; BEGIN (* GETSYMBOL *) DUMMY := CURRSYM; CURRSYM := NEXTSYM; NEXTSYM := DUMMY ; WITH NEXTSYM^ DO BEGIN SKIPSPACES( (* UPDATING *) CURRCHAR, NEXTCHAR, (* RETURNING *) SPACESBEFORE, CRSBEFORE ); CRSAFTER := CRSBEFORE; (* CAW *) LENGTH := 0; GETNEXTSYMBOL( (* FROM INPUT *) (* UPDATING *) CURRCHAR, NEXTCHAR, (* RETURNING *) NAME, VALU, LENGTH ); IF NAME IN [ OPENPAREN, CLOSEPAREN ] THEN IF NAME = OPENPAREN THEN BEGIN PARENCOUNTER := PARENCOUNTER + 1; IF PARENCOUNTER = 1 THEN IF CURRSYM^.CRSBEFORE = 0 THEN PARENINDENT := CURRLINEPOS + CURRSYM^.LENGTH + 1 ELSE PARENINDENT := CURRMARGIN + CURRSYM^.LENGTH +1; END ELSE PARENCOUNTER := PARENCOUNTER - 1; IF PARENCOUNTER >= 1 THEN IF NAME IN [SEMICOLON, OPENCOMMENT, OPENPAREN ] THEN STARTPOS := CURRLINEPOS ELSE NAME := OTHERSYM; IF (SPACESBEFORE > 1) AND (NOT(NAME = OPENCOMMENT)) THEN SPACESBEFORE := 1; IF (CURRLINEPOS+CURRSYM^.LENGTH<= MAXLINESIZE)AND (NOT(CURRSYM^.NAME = OPENCOMMENT)) THEN CURRSYM^.CRSBEFORE := 0; IF NAME IN [ SELECTSYM, ORSYM , SEPARATESYM, FORSYM , WHILESYM , LOOPSYM , ENDSYM , WITHSYM , USESYM ] THEN CHECKSYMBOL(NEXTSYM); IF CURRSYM^.NAME IN [ PACKAGESYM, FUNCSYM, ACCEPTSYM, PROCSYM , CASESYM, TASKSYM , BODYSYM , ISSYM , COLON , SEMICOLON ] THEN CHECKSYMBOL(CURRSYM); END (* WITH *) END; (* GETSYMBOL *) (**********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** INITIALIZE ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THE PRIMARY FUNCTION OF THIS PROCEDURE IS TO SET THE ***) (*** PROCESSING OPTIONS SELECTED FROM THE SET OF OPTIONS FOR ***) (*** EACH SYMBOL TO PROCESED AS WELL AS THE GOBBLE SYMBOLS IF ***) (*** THE OPTION "GOBBLESYMBOL" IS SELECTED. ADDITIONALLY THE ***) (*** "NEXTCHAR" IS FETCH FROM THE INPUT FILE TO INITIATE THE ***) (*** THE INPUTTING OF THE INPUT FILE. A CALL TO GETSYMBOL THEN ***) (*** INITIALIZES THE "NEXTSYM" AS WELL AS UPDATING OF "NEXTCHAR" ***) (*** AND "CURRCHAR". FINALLY OTHER GOBAL VARIABLES AND ARRAYS ***) (*** ARE INITIALIZED. ***) (*** ***) (*** INPUTS ***) (*** NONE ***) (*** ***) (*** OUTPUTS ***) (*** CURRCHAR ***) (*** NEXTCHAR ***) (*** CURRSYM ***) (*** NEXTSYM ***) (*** ***) (*** INITIALIZES ***) (*** TOP ***) (*** CURRLINPOS ***) (*** CURRMARGIN ***) (*** KEYWORD ***) (*** DBLCHARS ***) (*** SGLCHAR ***) (*** LOOPSWITCH ***) (*** USESWITCH ***) (*** WITHSEEN ***) (*** ORSWITCH ***) (*** CRPENDING ***) (*** ISSWITCH ***) (*** CURRCHAR ***) (*** NEXTCHAR ***) (*** CURRSYM ***) (*** NEXTSYM ***) (*** PPOPTION ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** GETSYMBOL ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE INITIALIZE; BEGIN (* INITIALIZE *) LINELIMIT(OUTPUT,MAXINT); TOP := 0; NUM_BEGINS := 0; (* CAW *) WHEN_FLAG := 0; (* CAW *) SPECIAL_INDEX := 1; (* CAW *) EXCEPTION_FLAG[1] := FALSE; (* CAW *) CASE_FLAG[1] := FALSE; (* CAW *) FIRST_BEGIN := FALSE; (* CAW *) P_CASE_FLAG := FALSE; (* CAW *) RECORD_FLAG := FALSE; (* CAW *) PRIVATE_FLAG := FALSE; (* CAW *) BEGIN_FLAG := FALSE; (* CAW *) SPECIAL_BEGIN[1] := FALSE; (* CAW *) CURRLINEPOS := 0; CURRMARGIN := 0; PARENCOUNTER := 0; KEYWORD [ FUNCSYM ] := 'FUNCTION ' ; KEYWORD [ PROCSYM ] := 'PROCEDURE ' ; KEYWORD [ ABORTSYM ] := 'ABORT ' ; (* -- RLC -- *) KEYWORD [ ABSSYM ] := 'ABS ' ; (* -- RLC -- *) KEYWORD [ ACCESSSYM ] := 'ACCESS ' ; (* -- RLC -- *) KEYWORD [ ALLSYM ] := 'ALL ' ; (* -- RLC -- *) KEYWORD [ ANDSYM ] := 'AND ' ; (* -- RLC -- *) KEYWORD [ ARRAYSYM ] := 'ARRAY ' ; (* -- RLC -- *) KEYWORD [ ATSYM ] := 'AT ' ; (* -- RLC -- *) KEYWORD [ CONSTANTSYM ] := 'CONSTANT ' ; (* -- RLC -- *) KEYWORD [ DELAYSYM ] := 'DELAY ' ; (* -- RLC -- *) KEYWORD [ DELTASYM ] := 'DELTA ' ; (* -- RLC -- *) KEYWORD [ DIGITSSYM ] := 'DIGITS ' ; (* -- RLC -- *) KEYWORD [ ENTRYSYM ] := 'ENTRY ' ; (* -- RLC -- *) KEYWORD [ GOTOSYM ] := 'GOTO ' ; (* -- RLC -- *) KEYWORD [ INSYM ] := 'IN ' ; (* -- RLC -- *) KEYWORD [ LIMITEDSYM ] := 'LIMITED ' ; (* -- RLC -- *) KEYWORD [ MODSYM ] := 'MOD ' ; (* -- RLC -- *) KEYWORD [ NOTSYM ] := 'NOT ' ; (* -- RLC -- *) KEYWORD [ NULLSYM ] := 'NULL ' ; (* -- RLC -- *) KEYWORD [ OFSYM ] := 'OF ' ; (* -- RLC -- *) KEYWORD [ OTHERSSYM ] := 'OTHERS ' ; (* -- RLC -- *) KEYWORD [ OUTSYM ] := 'OUT ' ; (* -- RLC -- *) KEYWORD [ PRAGMASYM ] := 'PRAGMA ' ; (* -- RLC -- *) KEYWORD [ RAISESYM ] := 'RAISE ' ; (* -- RLC -- *) KEYWORD [ RANGESYM ] := 'RANGE ' ; (* -- RLC -- *) KEYWORD [ REMSYM ] := 'REM ' ; (* -- RLC -- *) KEYWORD [ RENAMESSYM ] := 'RENAMES ' ; (* -- RLC -- *) KEYWORD [ RETURNSYM ] := 'RETURN ' ; (* -- RLC -- *) KEYWORD [ REVERSESYM ] := 'REVERSE ' ; (* -- RLC -- *) KEYWORD [ SUBTYPESYM ] := 'SUBTYPE ' ; (* -- RLC -- *) KEYWORD [ TERMINATESYM ] := 'TERMINATE ' ; (* -- RLC -- *) KEYWORD [ XORSYM ] := 'XOR ' ; (* -- RLC -- *) KEYWORD [ ISSYM ] := 'IS ' ; KEYWORD [ SPECIALISSYM ] := 'IS ' ; KEYWORD [ NEWSYM ] := 'NEW ' ; KEYWORD [ TYPESYM ] := 'TYPE ' ; KEYWORD [ BEGINSYM ] := 'BEGIN ' ; KEYWORD [ RECORDSYM ] := 'RECORD ' ; KEYWORD [ CASESYM ] := 'CASE ' ; KEYWORD [ FORSYM ] := 'FOR ' ; KEYWORD [ WHENSYM ] := 'WHEN ' ; KEYWORD [ WHILESYM ] := 'WHILE ' ; KEYWORD [ USESYM ] := 'USE ' ; KEYWORD [ SPECIALUSESYM ] := 'USE ' ; KEYWORD [ LOOPSYM ] := 'LOOP ' ; KEYWORD [ SPECIALLOOPSYM ] := 'LOOP ' ; KEYWORD [ WITHSYM ] := 'WITH ' ; KEYWORD [ SPECIALWTH ] := 'WITH ' ; (* CAW *) KEYWORD [ DOSYM ] := 'DO ' ; KEYWORD [ IFSYM ] := 'IF ' ; KEYWORD [ THENSYM ] := 'THEN ' ; KEYWORD [ ELSESYM ] := 'ELSE ' ; KEYWORD [ ELSIFSYM ] := 'ELSIF ' ; KEYWORD [ ENDSYM ] := 'END ' ; KEYWORD [ EXITSYM ] := 'EXIT ' ; KEYWORD [ PACKAGESYM ] := 'PACKAGE ' ; KEYWORD [ SPECIALPKSYM ] := 'PACKAGE ' ; (* CAW *) KEYWORD [ TASKSYM ] := 'TASK ' ; KEYWORD [ GENERICSYM ] := 'GENERIC ' ; KEYWORD [ EXCEPTIONSYM ] := 'EXCEPTION ' ; KEYWORD [ SPEXCEPTIONSYM ] := 'EXCEPTION ' ; KEYWORD [ PRIVATESYM ] := 'PRIVATE ' ; KEYWORD [ SELECTSYM ] := 'SELECT ' ; KEYWORD [ ORSYM ] := 'OR ' ; KEYWORD [ SPECIALORSYM ] := 'OR ' ; KEYWORD [ DECLARESYM ] := 'DECLARE ' ; KEYWORD [ SEPARATESYM ] := 'SEPARATE ' ; KEYWORD [ ACCEPTSYM ] := 'ACCEPT ' ; KEYWORD [ BODYSYM ] := 'BODY ' ; DBLCHARS := [ BECOMES, ARROWSYM, OPENCOMMENT ]; DBLCHAR [ BECOMES ] := ':='; DBLCHAR [ OPENCOMMENT ] := '--'; DBLCHAR [ ARROWSYM ] := '=>'; SGLCHAR [ SEMICOLON ] := ';' ; SGLCHAR [ SPSEMICOLON ] := ';' ; SGLCHAR [ COLON ] := ':' ; SGLCHAR [ SPECIALCOLON ] := ':' ; SGLCHAR [ UNDSCORE ] := '_' ; SGLCHAR [ EQUALS ] := '=' ; SGLCHAR [ OPENPAREN ] := '(' ; SGLCHAR [ CLOSEPAREN ] := ')' ; SGLCHAR [ PERIOD ] := '.' ; LOOPSWITCH := FALSE; USESWITCH := FALSE; WITHSEEN := FALSE; ORSWITCH := FALSE; ISSWITCH := FALSE; CRPENDING := FALSE; GETCHAR( (* FROM INPUT *) (* UPDATING *) NEXTCHAR, (* RETURNING *) CURRCHAR ); NEW(CURRSYM); NEW(NEXTSYM); GETSYMBOL( (* FROM INPUT *) (* UPDATING *) NEXTSYM, (* RETURNING *) CURRSYM ); WITH PPOPTION [ FUNCSYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, GOBBLESYMBOLS , SPACEAFTER ]; GOBBLETERMINATORS := [ ISSYM, SEMICOLON ]; END; WITH PPOPTION [ ABORTSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ABSSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ACCESSSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ALLSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ANDSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ARRAYSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ATSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ CONSTANTSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ DELAYSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ DELTASYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ DIGITSSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ENTRYSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ GOTOSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ INSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ LIMITEDSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ MODSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ NOTSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ NULLSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ OFSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ OTHERSSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ OUTSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ PRAGMASYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ RAISESYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ RANGESYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ REMSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ RENAMESSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ RETURNSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ REVERSESYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ SUBTYPESYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ TERMINATESYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ XORSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ PROCSYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, GOBBLESYMBOLS , SPACEAFTER ]; GOBBLETERMINATORS := [ ISSYM, OPENCOMMENT, SEMICOLON ]; END; WITH PPOPTION [ SPECIALISSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEBEFORE , INDENTMARGIN , CRAFTER ]; GOBBLETERMINATORS := [ ] END; WITH PPOPTION [ ISSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ SEMICOLON , RECORDSYM ] END; WITH PPOPTION [ NEWSYM ] DO (* -- RLC -- *) BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ TYPESYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , GOBBLESYMBOLS]; GOBBLETERMINATORS := [ SEMICOLON , RECORDSYM , ISSYM ] END; WITH PPOPTION [ TASKSYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ ISSYM , BODYSYM , SEMICOLON ] END; WITH PPOPTION [ GENERICSYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SPECIALPKSYM] DO (* CAW *) BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ NEWSYM , SEMICOLON ]; END; WITH PPOPTION [ PACKAGESYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ ISSYM , BODYSYM , SEMICOLON ] END; WITH PPOPTION [ BEGINSYM ] DO BEGIN OPTIONSSELECTED := [ INDENTBYTAB , DINDENT , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ USESYM ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SPECIALUSESYM ] DO BEGIN OPTIONSSELECTED := [ DINDENT ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ RECORDSYM ] DO BEGIN OPTIONSSELECTED := [ CRAFTER , CRSUPPRESS , INDENTMARGIN ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ CASESYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , CRBEFORE , (* -- RLC -- *) GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ ISSYM ] END; WITH PPOPTION [ EXITSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ SEMICOLON ] END; WITH PPOPTION [ FORSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , CRBEFORE , INDENTBYTAB , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ SPECIALLOOPSYM , SPECIALUSESYM , USESYM ] END; WITH PPOPTION [ SPECIALLOOPSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEBEFORE , CRSUPPRESS , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ LOOPSYM ] DO BEGIN OPTIONSSELECTED := [ INDENTBYTAB , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ WHILESYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , CRBEFORE , INDENTBYTAB , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ SPECIALLOOPSYM , OPENCOMMENT ] END; WITH PPOPTION [ SPECIALWTH ] DO (* CAW *) BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, GOBBLESYMBOLS , SPACEAFTER ]; GOBBLETERMINATORS := [ SEMICOLON ]; END; WITH PPOPTION [ WITHSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ DOSYM ] DO BEGIN OPTIONSSELECTED := [ CRSUPPRESS , SPACEBEFORE , INDENTMARGIN , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ IFSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER , CRBEFORE , INDENTBYTAB , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ THENSYM , OPENCOMMENT ] END; WITH PPOPTION [ THENSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEBEFORE , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ ELSESYM ] DO BEGIN OPTIONSSELECTED := [ CRBEFORE , DINDENT , INDENTBYTAB , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ ELSIFSYM ] DO BEGIN OPTIONSSELECTED := [ DINDENT , CRBEFORE , INDENTBYTAB , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ THENSYM ]; END; WITH PPOPTION [ ENDSYM ] DO BEGIN OPTIONSSELECTED := [ DINDENT , GOBBLESYMBOLS , CRBEFORE ]; GOBBLETERMINATORS := [ SEMICOLON ]; END; WITH PPOPTION [ WHENSYM ] DO BEGIN OPTIONSSELECTED := [ INDENTBYTAB , CRBEFORE , (* -- RLC -- *) GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ ARROWSYM ] END; WITH PPOPTION [ EXCEPTIONSYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, INDENTBYTAB ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SPEXCEPTIONSYM ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END; WITH PPOPTION [ PRIVATESYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE, INDENTBYTAB , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ ACCEPTSYM ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SELECTSYM ] DO BEGIN OPTIONSSELECTED := [ CRBEFORE , INDENTBYTAB , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ BODYSYM ] DO BEGIN OPTIONSSELECTED := [ GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ ISSYM , SEMICOLON ]; END; WITH PPOPTION [ ORSYM ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SPECIALORSYM ] DO BEGIN OPTIONSSELECTED := [ CRBEFORE , DINDENT , INDENTBYTAB , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ DECLARESYM ] DO BEGIN OPTIONSSELECTED := [ CRBEFORE , INDENTBYTAB , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SEPARATESYM ] DO BEGIN OPTIONSSELECTED := [ BLANKLINEBEFORE ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ ARROWSYM ] DO BEGIN OPTIONSSELECTED := [ SPACEBEFORE , CRSUPPRESS , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ BECOMES ] DO BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER , GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ SEMICOLON ] END; WITH PPOPTION [ OPENCOMMENT ] DO BEGIN OPTIONSSELECTED := [ CRSUPPRESS , CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SEMICOLON ] DO BEGIN OPTIONSSELECTED := [ CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SPSEMICOLON ] DO BEGIN OPTIONSSELECTED := [ CRSUPPRESS ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ COLON ] DO BEGIN OPTIONSSELECTED := [ SPACEAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ SPECIALCOLON ] DO BEGIN OPTIONSSELECTED := [ CRAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ EQUALS ] DO BEGIN OPTIONSSELECTED := [ SPACEBEFORE , SPACEAFTER ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ OPENPAREN ] DO BEGIN OPTIONSSELECTED := [ GOBBLESYMBOLS ]; GOBBLETERMINATORS := [ CLOSEPAREN ] END; WITH PPOPTION [ CLOSEPAREN ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END; WITH PPOPTION [ PERIOD ] DO BEGIN OPTIONSSELECTED := [ CRSUPPRESS ]; GOBBLETERMINATORS := [] END; WITH PPOPTION [ ENDOFFILE ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END; WITH PPOPTION [ OTHERSYM ] DO BEGIN OPTIONSSELECTED := []; GOBBLETERMINATORS := [] END END; (* INITIALIZE *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** STACKEMPTY ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS FUNCTION CHECKS TO ENSURE THAT THE ***) (*** STACK IS NOT EMPTY. THIS IS ACCOMPLISHED BY ***) (*** EXAMINATION OF THE TOP OF THE STACK INDICATOR, ***) (*** "TOP". IF ZERO THEN THIS FUNCTION RETURNS A ***) (*** VALUE OF FALSE, OTHERWISE TRUE IS RETURNED. ***) (*** ***) (*** INPUTS ***) (*** TOP----TOP OF STACK INDICATOR ***) (*** ***) (*** OUTPUTS ***) (*** STACKEMPTY--EQUAL TRUE IF "TOP" EQUALS ZERO, ***) (*** OTHERWISE FALSE. ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** LSHIFT ***) (*** ***) (**********************************************************************) FUNCTION STACKEMPTY (* RETURNING *) : BOOLEAN; BEGIN (* STACKEMPTY *) IF TOP = 0 THEN STACKEMPTY := TRUE ELSE STACKEMPTY := FALSE END; (* STACKEMPTY *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** STACKFULL ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS FUNCTON CHECKS TO ENSURE THAT THE ***) (*** STACK IS NOT FULL. THIS IS ACCOMPLISHED BY ***) (*** EXAMINTION OF THE TOP-OF-THE-STACK INDICATOR, ***) (*** "TOP". IF IT EQUALS THE MAXIMUN THEN THIS ***) (*** RETURNS TRUE, OTHERWISE FALSE IS RETURNED. ***) (*** ***) (*** INPUTS ***) (*** TOP---TOP-OF-THE-STACK INDICATOR ***) (*** ***) (*** OUTPUTS ***) (*** STACKFULL--EQUALS TRUE IF TOP EQUAL MAXSTACKSIZE, ***) (*** OTHERWISE FALSE ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** RSHIFT ***) (*** PRINTENDIDENTIFIER ***) (*** ***) (**********************************************************************) FUNCTION STACKFULL (* RETURNING *) : BOOLEAN; BEGIN (* STACKFULL *) IF TOP = MAXSTACKSIZE THEN STACKFULL := TRUE ELSE STACKFULL := FALSE END; (* STACKFULL *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** PUSHSTACK ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE SAVES THE RECORD ENDIDENTIFIER ***) (*** ONTO THE STACK FOR LATER RETREIVAL. THIS IS USED ***) (*** TO SAVE THE VALUE OF THE ENDIDENTIFIER SYMBOL FOR ***) (*** FOR AUTOMATIC INSERTION FOLLOWING AN "END" IF ONE ***) (*** IS NOT ALREADY PRESENT. ***) (*** ***) (*** INPUTS ***) (*** TOP -------TOP-OF-THE-STACK INDICATOR ***) (*** PREVMARGIN ***) (*** ENDSYMBOL ***) (*** LLENGTH ***) (*** ***) (*** OUTPUTS ***) (*** TOP ------UPDATED VALUE ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** RSHIFT ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE PUSHSTACK( INDENTSYMBOL : KEYSYMBOL; PREVMARGIN : INTEGER; ENDSYMBOL : STRING; LLENGTH : INTEGER ); BEGIN (* PUSHSTACK *) TOP := TOP + 1; STACK[TOP].PREVMARGIN := PREVMARGIN; STACK[TOP].ENDSYMBOL := ENDSYMBOL; STACK[TOP].LLENGTH := LLENGTH; END; (* PUSHSTACK *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** INSERTCR ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE CHECKS TO SEE IF A NEW LINE IS ***) (*** INDICATED PRIOR TO THE OUTPUTTING OF THE CURRENT ***) (*** SYMBOL. IF NOT, THEN A CALL "PROCEDURE WRITECRS" ***) (*** IS MADE TO OUTPUT A CARRIAGE RETURN. ***) (*** ***) (*** ***) (*** ***) (*** INPUTS ***) (*** CURRSYM^.CRSBEFORE -- NUMBER OF CARRIAGE RETURNS ***) (*** INDICATED PRIOR TO THE OUT- ***) (*** PUTTING OF THE CURRENT SYMBOL ***) (*** ***) (*** OUTPUTS ***) (*** CURRSYM^.SPACESBEFORE-- SET TO ZERO ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** WRITECRS ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE INSERTCR( (* UPDATING *) VAR CURRSYM : SYMBOLINFO (* WRITING TO OUTPUT *) ); CONST ONCE = 1; BEGIN (* INSERTCR *) IF CURRSYM^.CRSBEFORE = 0 THEN BEGIN WRITECRS( ONCE, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ); CURRSYM^.SPACESBEFORE := 0 END END; (* INSERTCR *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** INSERTBLANKLINE ***) (*** ***) (*** DESCRIPTION ***) (*** THIS PROCEDURE CAUSES A BLANKLINE TO BE WRITTEN ***) (*** ON THE OUTPUT FILE IF ONE IS NOT ALREADY REQUIRED. ***) (*** ***) (*** INPUTS ***) (*** CURRSYM^.CRSBEFORE--- CHECKS TO SEE IF A BLANK- ***) (*** LINE IS INDICATED ALREADY ***) (*** ***) (*** CURRLINEPOS --------- OF THE OUTPUT FILE ***) (*** ***) (*** ***) (*** OUTPUTS ***) (*** CURRSYM^.SPACESBEFORE-- SET TO ZERO IF A BLANK- ***) (*** LINE IS INSERTED ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** WRITECRS ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE INSERTBLANKLINE( (* UPDATING *) VAR CURRSYM : SYMBOLINFO (* WRITING TO OUTPUT *) ); CONST ONCE = 1; TWICE = 2; BEGIN (* INSERTBLANKLINE *) IF CURRSYM^.CRSBEFORE = 0 THEN BEGIN IF CURRLINEPOS = 0 THEN WRITECRS( ONCE, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ) ELSE WRITECRS( TWICE, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ); CURRSYM^.SPACESBEFORE := 0 END ELSE IF CURRSYM^.CRSBEFORE = 1 THEN IF CURRLINEPOS > 0 THEN WRITECRS( ONCE, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ) END; (* INSERTBLANKLINE *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** LSHIFT ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE CAUSE THE MARGIN TO BE RESET ***) (*** TO THE VALUE WHICH IS WAS PREVIOUSLY. THIS VALUE ***) (*** VALUE IS OBTSAINED FROM THE TOP OF THE STACK. ***) (*** ***) (*** ***) (*** ***) (*** INPUTS ***) (*** STACK[TOP] ***) (*** TOP ***) (*** ***) (*** OUTPUTS ***) (*** TOP ***) (*** CURRMARGIN ***) (*** ENDIDENTIFIER ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STACKEMPTY ***) (*** ***) (*** REFERENCED BY ***) (*** GOBBLE ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE LSHIFT; BEGIN (* LSHIFT *) IF NOT STACKEMPTY THEN BEGIN CURRMARGIN := STACK[TOP].PREVMARGIN; ENDIDENTIFIER.ENDSYMBOL := STACK[TOP].ENDSYMBOL; ENDIDENTIFIER.LLENGTH := STACK[TOP].LLENGTH; TOP := TOP - 1 END ELSE PREVMARGIN := 0 END; (* LSHIFT *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** INSERTSPACE ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE WRITES A SINGLE SPACE ON THE ***) (*** OUTPUT FILE. BEFORE RETURNING, IT PERFORMS SOME ***) (*** HOUSEKEEPING FUNCTIONS TO UPDATE THE CURRENT LINE ***) (*** POSITION INDICATOR OF THE OUTPUT FILE, AND TO ***) (*** ADJUST THE NUMBER OF SPACES TO BE PRINTED PRIOR ***) (*** TO THE OUTPUTTING OF THE CURRENT SYMBOL ***) (*** ***) (*** INPUTS ***) (*** CURRLINEPOS---OF THE OUTPUT FILE ***) (*** SYMBOL ***) (*** ***) (*** ***) (*** OUTPUTS ***) (*** CURRLINEPOS ***) (*** SYMBOL ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** PRINTENDIDENTIFIER ***) (*** ***) (**********************************************************************) PROCEDURE INSERTSPACE( (* USING *) VAR SYMBOL : SYMBOLINFO (* WRITING TO OUTPUT *) ); BEGIN (* INSERTSPACE *) IF CURRLINEPOS < MAXLINESIZE THEN BEGIN WRITE(SPACE); CURRLINEPOS := CURRLINEPOS + 1; WITH SYMBOL^ DO IF (CRSBEFORE = 0) AND (SPACESBEFORE > 0) THEN SPACESBEFORE := SPACESBEFORE - 1 END END; (* INSERTSPACE *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** MOVELINEPOS ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE WRITES SPACES ON THE OUTPUT ***) (*** FILE FROM THE CURRENT LINE POSITION PLUS ONE TO ***) (*** NEW LINE POSITION. ***) (*** ***) (*** ***) (*** ***) (*** INPUTS ***) (*** CURRLINEPOS--- OF THE OUTPUT FILE ***) (*** NEWLINEPOS---- NEW POSITION REQUIRED ***) (*** ***) (*** OUTPUTS ***) (*** CURRLINEPOS--- SET EQUAL TO "NEWLINEPOS" ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** PPSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE MOVELINEPOS( (* TO *) NEWLINEPOS : INTEGER; (* FROM *) VAR CURRLINEPOS : INTEGER (* WRITING TO OUTPUT *) ); VAR I: INTEGER; BEGIN (* MOVELINEPOS *) FOR I := CURRLINEPOS+1 TO NEWLINEPOS DO WRITE(SPACE); CURRLINEPOS := NEWLINEPOS END; (* MOVELINEPOS *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** PRINTSYMBOL ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE WRITES THE CURRENT SYMBOL TO ***) (*** THE OUTPUT FILES AND UPDATES THE CURRENT LINE POS- ***) (*** ITION PRIOR TO RETURNING. ***) (*** ***) (*** ***) (*** INPUTS ***) (*** CURRSYM -----OF THE INPUT FILE ***) (*** CURRLINEPOS--OF THE OUTPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** CURRLINEPOS--UPDATED CURRENT LINE POSITION ***) (*** STARTPOS-----STARTING POSITION OF LAST SYMBOL WRITTEN ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** PPSYMBOL ***) (*** ***) (**********************************************************************) PROCEDURE PRINTSYMBOL( (* IN *) CURRSYM : SYMBOLINFO; (* UPDATING *) VAR CURRLINEPOS : INTEGER (* WRITING TO OUTPUT *) ); VAR I: INTEGER; BEGIN (* PRINTSYMBOL *) WITH CURRSYM^ DO BEGIN FOR I := 1 TO LENGTH DO WRITE(VALU[I]); STARTPOS := CURRLINEPOS; (* SAVE START POS FOR TAB PURPOSES *) CURRLINEPOS := CURRLINEPOS + LENGTH END (* WITH *) END; (* PRINTSYMBOL *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** PPSYMBOL ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE DETERMINES THE PROPER POSITION OF ***) (*** THE WRITE HEAD OF THE OUTPUT FILE ACCORDING TO THE ***) (*** VALUES OF "CURRLINEPOS", "CRSBEFORE", "SPACESBEFORE", ***) (*** AND "LENGTH". THE OUTPUT FILE IS POSITIONED TO THIS ***) (*** POSITION VIA CALLS TO "PROCEDURE WRITECRS" AND "PRO ***) (*** CEDURE MOVELINEPOS" TO MOVE THE CURRENT LINE POSITION ***) (*** TO THE NEW LINE POSITION. THE CURRENT SYMBOL IS THEN ***) (*** OUTPUTTED VIA A CALL TO "PROCEDURE PRINTSYMBOL". ***) (*** ***) (*** INPUTS ***) (*** CURRLINEPOS---OF THE OUTPUT FILE ***) (*** CURRSYM-------OF THE INPUT FILE ***) (*** CURRMARGIN----CURRENT MARGIN FOR INDENTATION ***) (*** PARENINDENT---MARGIN FOR INDENTION FOR CERTAIN LISTS ***) (*** ***) (*** OUTPUTS ***) (*** NEWLINEPOS----NEW POSITION THAT CURRENT LINE POSITION ***) (*** MUST BE RELOCATED TO BEFORE OUTPUTTING ***) (*** THE CURRENT CYMBOL ***) (*** CURRLINEPOS---UPDATED CURRENT LINE POSITION ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** WRITECRS ***) (*** MOVELINEPOS ***) (*** PRINTSYMBOL ***) (*** ***) (*** REFERENCED BY ***) (*** GOBBLE ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE PPSYMBOL( (* IN *) CURRSYM : SYMBOLINFO (* WRITING TO OUTPUT *) ); CONST ONCE = 1; VAR NEWLINEPOS: INTEGER; BEGIN (* PPSYMBOL *) WITH CURRSYM^ DO BEGIN WRITECRS( (* USING *) CRSBEFORE, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ); IF (CURRLINEPOS + SPACESBEFORE > CURRMARGIN) OR (NAME IN [ OPENCOMMENT ]) THEN NEWLINEPOS := CURRLINEPOS + SPACESBEFORE ELSE IF (PARENCOUNTER > 0) AND (NEXTSYM^.NAME <> OPENPAREN) THEN NEWLINEPOS := PARENINDENT ELSE NEWLINEPOS := CURRMARGIN; IF NEWLINEPOS + LENGTH > MAXLINESIZE THEN BEGIN WRITECRS( ONCE, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ); IF CURRMARGIN + LENGTH <= MAXLINESIZE THEN NEWLINEPOS := CURRMARGIN ELSE IF LENGTH < MAXLINESIZE THEN NEWLINEPOS := MAXLINESIZE - LENGTH ELSE NEWLINEPOS := 0 END; MOVELINEPOS( (* TO *) NEWLINEPOS, (* FROM *) CURRLINEPOS (* IN OUTPUT *) ); PRINTSYMBOL( (* IN *) CURRSYM, (* UPDATING *) CURRLINEPOS (* WRITING TO OUTPUT *) ) END (* WITH *) END; (* PPSYMBOL *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** GOBBLE ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE "GOBBLES" SYMBOLS FROM THE IN- ***) (*** PUT FILE AND OUTPUTS THEM ONTO THE OUTPUT FILE UNTIL ***) (*** A SYMBOL IS ENCOUNTERED WHICH IS ONE OF THE TERMIN- ***) (*** ATORS. ***) (*** ***) (*** INPUTS ***) (*** TERMINATORS---LIST OF SYMBOLS WHICH TERMINATE THE ***) (*** "GOBBLE" MODE. ***) (*** CURRSYM-------OF THE INPUT FILE ***) (*** NEXTSYM-------OF THE INPUT FILE ***) (*** ***) (*** OUTPUTS ***) (*** CURRSYM-------UPDATED ***) (*** NEXTSYM-------UPDATED ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** GETSYMBOL ***) (*** PPSYMBOL ***) (*** LSHIFT ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE GOBBLE( (* SYMBOLS FROM INPUT *) (* UP TO *) TERMINATORS : KEYSYMSET; (* UPDATING *) VAR CURRSYM, NEXTSYM : SYMBOLINFO (* WRITING TO OUTPUT *) ); BEGIN (* GOBBLE *) WHILE NOT(NEXTSYM^.NAME IN (TERMINATORS + [ENDOFFILE])) DO BEGIN GETSYMBOL( (* FROM INPUT *) (* UPDATING *) NEXTSYM, (* RETURNING *) CURRSYM ); PPSYMBOL( (* IN *) CURRSYM (* WRITING TO OUTPUT *) ) END; (* WHILE *) END; (* GOBBLE *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** RSHIFT ***) (*** ***) (*** DESCRIPTION ***) (*** ***) (*** THIS PROCEDURE INDENTS THE CURRENT MARGIN BY A ***) (*** AMOUNT. THE PREVIOUS MARGIN IS SAVED BY BEING ***) (*** PUSHED ONTO A STACK FOR LATER RETREIVAL. ***) (*** ***) (*** INPUTS ***) (*** ENDIDENTIFIER---RECORD CONTAINING A "END IDENT- ***) (*** IFIER" NAME ,VALU AND LENGTH ***) (*** CURRMARGIN ***) (*** CURRSYM ***) (*** STARTPOS ***) (*** ***) (*** OUTPUTS ***) (*** CURRMARGIN ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** STACKFULL ***) (*** PUSHSTACK ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE RSHIFT( (* USING *) CURRSYM : KEYSYMBOL ); BEGIN (* RSHIFT *) IF NOT STACKFULL THEN PUSHSTACK( (* USING *) CURRSYM, CURRMARGIN, ENDIDENTIFIER.ENDSYMBOL, ENDIDENTIFIER.LLENGTH ); (* IF EXTRA INDENTATION WAS USED, UPDATE MARGIN. *) IF STARTPOS > CURRMARGIN THEN CURRMARGIN := STARTPOS; IF CURRMARGIN < SLOFAIL1 THEN CURRMARGIN := CURRMARGIN + INDENT1 ELSE IF CURRMARGIN < SLOFAIL2 THEN CURRMARGIN := CURRMARGIN + INDENT2 END; (* RSHIFT *) (*=********************************************************************) (**********************************************************************) (*** ***) (*** NAME ***) (*** PRINTENDIDENTIFIER ***) (*** ***) (*** DESCRIPTION ***) (*** THIS PROCEDURE WRITE TO THE OUTPUT FILE AFTER THE ***) (*** KEYWORD "END" OF THE BLOCK WHICH IS TERMINATED. BEFORE ***) (*** RETURNING, THE STARTING POSITION AND THE CURRENT LINE ***) (*** ARE UPDATED. ***) (*** ***) (*** INPUTS ***) (*** CURRLINEPOS--OF THE OUTPUT FILE ***) (*** ENDIDENTIFIER.LLENGTH--THE NUMBER OF CHARACTER IN THE ***) (*** IDENTIFIER-NAME-STRING. ***) (*** ENDIDENTIFIER.ENDSYMBOL-- AN ARRAY CONTAINING THE CHAR- ***) (*** OF THE IDENTIFIER-NAME-STRING. ***) (*** ***) (*** OUTPUTS ***) (*** CURRLINEPOS--UDATED NEW LINE POSITION AFTER OUTPUTING. ***) (*** STARTPOS--STARTING POSITION OF LAST SYMBOL WRITTEN ***) (*** PURPOSES. ***) (*** A ENDIDENTIFIER IS WRITTEN ON THE OUTPUT FILE ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE PRINTENDIDENTIFIER; VAR I:INTEGER; BEGIN WITH ENDIDENTIFIER DO BEGIN WRITE(SPACE); FOR I := 1 TO LLENGTH DO WRITE(ENDSYMBOL[I]); STARTPOS := CURRLINEPOS; CURRLINEPOS := CURRLINEPOS + LLENGTH; END; (* WITH *); END;(* PRINTENDIDENTIFIER *) (*=********************************************************************) (**********************************************************************) (*** -- CAW -- ***) (*** ***) (*** NAME ***) (*** WHENANDENDFLAGS ***) (*** ***) (*** DESCRIPTION ***) (*** THIS PROCEDURE IS USED TO KEEP TRACK OF THE INDENTATION ***) (*** OF THE CASE STATEMENTS, EXCEPTION HANDLERS, AND THE ***) (*** BEGIN/END BLOCK STATEMENTS. ***) (*** ***) (*** INPUTS ***) (*** CURRSYM-- THE CURRENT TOKEN THAT IS BEING PROCESSED. ***) (*** ***) (*** OUTPUTS ***) (*** NONE ***) (*** ***) (*** PROCEDURES/FUNCTIONS USED ***) (*** NONE ***) (*** ***) (*** REFERENCED BY ***) (*** PRETTYPRINT ***) (*** ***) (**********************************************************************) PROCEDURE WHENANDENDFLAGS(CURRSYM : SYMBOLINFO); VAR INDEX : INTEGER; TEMP : STRING; BEGIN CASE CURRSYM^.NAME OF WHENSYM : IF WHEN_FLAG > 0 THEN BEGIN WHEN_FLAG := WHEN_FLAG - 1; FOR INDEX:=1 TO 3 DO INSERTSPACE(CURRSYM); END ELSE LSHIFT; EXCEPTIONSYM : BEGIN WHEN_FLAG := WHEN_FLAG + 1; IF SPECIAL_BEGIN[SPECIAL_INDEX] THEN BEGIN EXCEPTION_FLAG[SPECIAL_INDEX] := TRUE; CASE_FLAG[SPECIAL_INDEX] := FALSE; END ELSE BEGIN SPECIAL_INDEX := SPECIAL_INDEX + 1; EXCEPTION_FLAG[SPECIAL_INDEX] := TRUE; CASE_FLAG[SPECIAL_INDEX] := FALSE; SPECIAL_BEGIN[SPECIAL_INDEX] := FALSE; END; END; CASESYM : BEGIN WHEN_FLAG := WHEN_FLAG + 1; SPECIAL_INDEX := SPECIAL_INDEX + 1; CASE_FLAG[SPECIAL_INDEX] := TRUE; EXCEPTION_FLAG[SPECIAL_INDEX] := FALSE; SPECIAL_BEGIN[SPECIAL_INDEX] := FALSE; END; BEGINSYM : BEGIN IF BEGIN_FLAG THEN BEGIN PUSHSTACK(CURRSYM^.NAME,CURRMARGIN,TEMP,0); END; IF (CASE_FLAG[SPECIAL_INDEX]) OR (EXCEPTION_FLAG[SPECIAL_INDEX]) OR (SPECIAL_BEGIN[SPECIAL_INDEX]) THEN BEGIN SPECIAL_INDEX := SPECIAL_INDEX + 1; SPECIAL_BEGIN[SPECIAL_INDEX] := TRUE; EXCEPTION_FLAG[SPECIAL_INDEX] := FALSE; CASE_FLAG[SPECIAL_INDEX] := FALSE; END; END; ENDSYM : BEGIN IF (CASE_FLAG[SPECIAL_INDEX]) THEN BEGIN CASE_FLAG[SPECIAL_INDEX] := FALSE; SPECIAL_INDEX := SPECIAL_INDEX - 1; LSHIFT; END ELSE IF (EXCEPTION_FLAG[SPECIAL_INDEX]) THEN BEGIN EXCEPTION_FLAG[SPECIAL_INDEX] := FALSE; SPECIAL_INDEX := SPECIAL_INDEX - 1; LSHIFT; LSHIFT; END ELSE IF SPECIAL_BEGIN[SPECIAL_INDEX] THEN BEGIN SPECIAL_BEGIN[SPECIAL_INDEX] := FALSE; SPECIAL_INDEX := SPECIAL_INDEX - 1; END; END; END; END; BEGIN (* PRETTYPRINT *) INITIALIZE; WHILE (NEXTSYM^.NAME <> ENDOFFILE) DO BEGIN GETSYMBOL( (* FROM INPUT *) (* UPDATING *) NEXTSYM, (* RETURNING *) CURRSYM ); (* CAW *) IF ((CURRSYM^.NAME = SPECIALISSYM) AND ((NEXTSYM^.NAME = PRIVATESYM) OR (NEXTSYM^.NAME = LIMITEDSYM))) THEN CURRSYM^.NAME := ISSYM; SPECIAL_FLAG := FALSE; IF ((CURRSYM^.NAME = PACKAGESYM) AND (NEXTSYM^.NAME <> BODYSYM)) OR ((CURRSYM^.NAME = PROCSYM) AND (NEXTSYM^.NAME <> BODYSYM)) THEN BEGIN INSERTBLANKLINE(CURRSYM); PPSYMBOL(CURRSYM); SPECIAL_FLAG := TRUE; CRPENDING := FALSE; GETSYMBOL (NEXTSYM,CURRSYM); PPSYMBOL(CURRSYM); GETSYMBOL (NEXTSYM,CURRSYM); IF NEXTSYM^.NAME = NEWSYM THEN CURRSYM^.NAME := SPECIALPKSYM END; IF ((CURRSYM^.NAME = WITHSYM) AND ((NEXTSYM^.NAME = FUNCSYM) OR (NEXTSYM^.NAME = PROCSYM))) THEN CURRSYM^.NAME := SPECIALWTH; (* END CAW *) WITH PPOPTION [CURRSYM^.NAME] DO BEGIN (*** CAW ***) IF CURRSYM^.NAME IN [LOOPSYM, SPECIALLOOPSYM, IFSYM, BEGINSYM] THEN BEGIN FIRST_BEGIN := TRUE; NUM_BEGINS := NUM_BEGINS + 1; END; IF ((CURRSYM^.NAME = ENDSYM) AND (FIRST_BEGIN)) THEN IF NUM_BEGINS > 0 THEN NUM_BEGINS := NUM_BEGINS - 1; IF CURRSYM^.NAME IN [WHENSYM, EXCEPTIONSYM, CASESYM, BEGINSYM, ENDSYM ] THEN WHENANDENDFLAGS(CURRSYM); (*** END CAW ***) IF (CRPENDING AND NOT(CRSUPPRESS IN OPTIONSSELECTED)) OR (CRBEFORE IN OPTIONSSELECTED) THEN BEGIN INSERTCR( (* USING *) CURRSYM (* WRITING TO OUTPUT *) ); CRPENDING := FALSE END; IF ((BLANKLINEBEFORE IN OPTIONSSELECTED) AND NOT (SPECIAL_FLAG)) THEN BEGIN INSERTBLANKLINE( (* USING *) CURRSYM (* WRITING TO OUTPUT *) ); CRPENDING := FALSE END; IF DINDENT IN OPTIONSSELECTED THEN BEGIN LSHIFT; IF (PRIVATE_FLAG) AND (CURRSYM^.NAME = ENDSYM) (*CAW*) AND (NOT(RECORD_FLAG)) AND (NOT(P_CASE_FLAG)) (*CAW*) THEN BEGIN (*CAW*) CURRMARGIN := CURRMARGIN - 3; (*CAW*) PRIVATE_FLAG := FALSE; (*CAW*) END; (*CAW*) END; IF SPACEBEFORE IN OPTIONSSELECTED THEN INSERTSPACE( (* USING *) CURRSYM (* WRITING TO OUTPUT *) ); PPSYMBOL( (* IN *) CURRSYM (* WRITING TO OUTPUT *) ); (******* CAW *********) IF (CURRSYM^.NAME = CASESYM) AND (PRIVATE_FLAG) THEN P_CASE_FLAG := TRUE; IF (CURRSYM^.NAME = ENDSYM) AND (P_CASE_FLAG) THEN P_CASE_FLAG := FALSE; IF (CURRSYM^.NAME = RECORDSYM) AND (PRIVATE_FLAG) THEN RECORD_FLAG := TRUE; IF (CURRSYM^.NAME = ENDSYM) AND (RECORD_FLAG) THEN RECORD_FLAG := FALSE; IF CRSAFTER > 1 THEN WRITECRS((CRSAFTER - 1),CURRLINEPOS); (********* END CAW **********) IF SPACEAFTER IN OPTIONSSELECTED THEN INSERTSPACE( (* USING *) NEXTSYM (* WRITING TO OUTPUT *) ); IF CURRSYM^.NAME = ENDSYM THEN IF NEXTSYM^.NAME = SEMICOLON THEN PRINTENDIDENTIFIER; IF INDENTBYTAB IN OPTIONSSELECTED THEN RSHIFT( (* USING *) CURRSYM^.NAME ); IF GOBBLESYMBOLS IN OPTIONSSELECTED THEN GOBBLE( (* SYMBOLS FROM INPUT *) (* UP TO *) GOBBLETERMINATORS, (* UPDATING *) CURRSYM, NEXTSYM (* WRITING TO OUTPUT *) ); IF INDENTMARGIN IN OPTIONSSELECTED THEN BEGIN IF NOT STACKFULL THEN PUSHSTACK(CURRSYM^.NAME, CURRMARGIN, ENDIDENTIFIER.ENDSYMBOL, ENDIDENTIFIER.LLENGTH ); IF CURRMARGIN < SLOFAIL1 THEN CURRMARGIN := CURRMARGIN + INDENT1 ELSE IF CURRMARGIN < SLOFAIL2 THEN CURRMARGIN:=CURRMARGIN+INDENT2 END; IF CRAFTER IN OPTIONSSELECTED THEN CRPENDING := TRUE; (********* CAW **********) IF ((FIRST_BEGIN) AND (NUM_BEGINS = 0) AND (NEXTSYM^.NAME = BEGINSYM)) THEN LSHIFT; IF CURRSYM^.NAME = PRIVATESYM THEN PRIVATE_FLAG := TRUE; IF CURRSYM^.NAME = BEGINSYM THEN BEGIN_FLAG := TRUE; (******** END CAW ********) END (* WITH *) END; (* WHILE *) IF CRPENDING THEN WRITELN END.