|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 337152 (0x52500)
Types: TextFile
Names: »mpasc0«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »mpasc0«
(*$M20 COMPILE 68000 *)
(*$L+ OPTIONS HERE *) (* %M% %I% %H% ID KEYWORDS TO SCCS *)
(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++*
* *
* 10/7/73 SYNTAX ANALYSIS INCLUDING ERROR *
* HANDLING; CHECKS BASED ON DECLARA- *
* TIONS; ADDRESS AND CODE GENERATION *
* FOR A HYPOTHETICAL STACK COMPUTER *
* URS AMMANN ETH ZURICH *
* *
* 05/20/74 *
* THE COMPILER IS NOW WRITTEN IN A SUBSET OF *
* STANDARD PASCAL - AS DEFINED IN THE NEW *
* MANUAL BY K. JENSEN AND N. WIRTH - AND IT *
* PROCESSES EXACTLY THIS SUBSET. *
* KESAV NORI ETH ZURICH *
* *
* THE COMPILER IS NOW CHANGED TO: *
* *
* -PRODUCE THE INTERMEDIATE CODE IN AN *
* ASSEMBLER READABLE FORM (NAMELY THE *
* 370, ASSEMBLER_H), 15-NOV-75. *
* *
* -PRESERVE PROCEDURE NAMES AND THEIR *
* STATIC LEVELS AT THE OBJECT LEVEL, THUS *
* ALLOWING A SET OF 'DISPLAY' REGISTERS TO *
* BE USED IN ACCESSING NON_LOCAL, NON_GLOBAL *
* VARIABLES (INSTEAD OF GOING THROUGH A *
* CHAIN OF POINTERS), 10-DEC-75. *
* *
* -INCLUDE THE TYPE OF THE OPERANDS IN THE *
* P_INSTRUCTIONS AS FOLLOWS: *
* *
* A : ADDRESS (POINTER) OPERAND *
* B : BOOLEAN " *
* C : CHARACTER " *
* I : INTEGER " *
* R : REAL " *
* S : SET " *
* *
* THE P_INSTRUCTION NOW LOOKS LIKE: *
* (LAB) OPCODE (TYPE),(OPERANDS) *
* A NEW PROCEDURE 'HALT(RC: INTEGER)' IS *
* ADDED TO THE SET OF STANDARD PROCEDURES *
* TO FACILITATE TERMINATING A PROGRAM AT *
* ANY POINT AND RETURNING A 'RETURN CODE' *
* TO THE OPERATING SYSTEM, 26-JAN-76. *
* *
* -TREAT THE INPUT AS A TEXT FILE WITH *
* LINES (RECORDS) OF LINELGTH CHAR. EACH, *
* THIS ALLOWS A MORE EFFICIENT STRING *
* ORIENTED INPUT, 20-MAR-76. *
* *
* -ALLOCATE AND PROPERLY ALIGN VARIABLES ON *
* THE BASIS OF THEIR TYPES, I.E. *
* *
* TYPE SIZE ALIGNED ON *
* *
* B,C 1-BYTE 1-BYTE *
* A,I 4-BYTES 4-BYTE *
* S 8-BYTES 4-BYTE *
* R 8-BYTES 8-BYTE *
* *
* DYNAMIC STORAGE HOWEVER IS ALWAYS ALLOC- *
* CATED ON 8-BYTE BOUNDARIES TO AVOID RUN- *
* TIME CHECKING OVERHEAD, 25-APR-76. *
* *
* -'READ' OF 'STRING' VARIABLES (I.E. ARRAY *
* OF CHAR) IS NOW IMPLEMENTED AND IT IS TO *
* COMPLEMENT THE SIMILAR 'WRITE' FUNCTION. *
* ALSO THE STANDARD PROCEDURE: *
* TRAP(I: INTEGER; VAR V: (.ANY TYPE.) ); *
* IS ADDED TO THE SET OF STANDARD PROCEDURES *
* TO FACILITATE COMMUNICATION WITH THE OUT- *
* SIDE WORLD, 10-SEP-76. *
* *
* -RELEVENT INFORMATION ON/ABOUT PROCEDURES *
* ARE NOW SENT TO 'QRD' FILE. THIS INCLUDES *
* SUCH INFORMATION AS THE SIZE OF THE PROCE- *
* DURE AS WELL AS ITS DATA AREA, LIST OF THE *
* PROCEDURES CALLED AND THE # OF CALLS, THE *
* LEVEL OF THE HIGHEST_LEVEL PROCEDURE CALLED *
* ETC. THIS INFORMATION IS MAINLY INTENDED *
* FOR INTER_PROCEDURAL ANALYSIS, BUT IT IS *
* ALSO USEFUL FOR MORE EFFICIENT PROCEDURE *
* ENTRY/EXIT CODE, 22-MAR-77. *
* *
* -THE COMPILER IS NOW SET UP TO GENERATE *
* P_CODE SUITABLE FOR A MICRO_PROCESSOR *
* IMPLEMENTATION. THE LENGTH (IN # OF *
* BYTES) OF BASIC DATA TYPES AS WELL AS *
* THE FORMAT OF THE OUTPUT IS (SLIGHTLY) *
* DIFFERENT FROM THAT OF THE 370 VERSION, *
* 11-FEB-78. *
* *
* *
* THE ABOVE CHANGES (INCLUDING ADDITIONS AND/OR *
* DELETIONS) HAVE BEEN TAGGED BY A '#' TAG AT *
* THE BEGINNING OR THE END OF AFFECTED LINES. *
* S. HAZEGHI SLAC *
* *
* *
* NEW CHANGES MADE 12/78 BY EPS (MARKED BY 'EPS') *
* TO PERMIT COMPILATION BY THE BERKELEY UNIX *
* COMPILER. *
* -FIX LOOSE TYPE MATCHES (ARG TO GENLABEL) *
* (TYPE OF CSTPART) *
* -CHANGE READ(LINEBUF) TO FOR LOOP WHICH *
* READS CHAR BY CHAR *
* -FILL IN ALL UNUSED VARIANTS OF RECORD *
* CASES *
* -COMMENT ALL UNUSED VARIABLES *
* -COMMENT ALL # COMMENTS PUT IN BY HAZEGHI *
* *
* SKIP STRITTER *
* MOTOROLA *
* *
* GOTO'S ELIMINATED IN INSYMBOL, NEW1, SEARCHID, *
* SEARCHSECTION, AND CASESTATEMENT FOR COMPILATION *
* BY NBS COMPILER *
* 12/28/78 EPS MOTOROLA *
* *
* 01/04/79 CHANGES IN INSYMBOL (COLLECTING *
* INTEGERS) FOR NON-DECIMAL RADIX INTEGER CONSTANTS *
* (OF THE FORM RR#NN...N WHERE RR IS BASE 10 AND *
* 1 <= RR <= 16 AND N < RR ) EPS *
* *
* 01/05/79 CHANGE INSYMBOL AND ADD ARRAY UPPER FOR *
* TRANSLATION OF ALL INPUT IDENTIFIERS AND *
* RESERVED WORDS TO UPPER CASE - UPPER CASE *
* AND LOWER CASE ARE INDISTINGUISHABLE TO THE *
* COMPILER EXCEPT IN STRINGS EPS *
* *
* 01/23/79 UPDATE INSYMBOL TO ACCEPT MOTOROLA *
* OPTIONS EPS *
* *
* 01/23/79 CREATE WARNING FACILITY SIMILAR TO *
* EXISTING ERROR FACILITY. NEW PROC WARNING; *
▶1a◀▶1a◀ NEW C▶1a◀LOBALS WARNINGS:BOOLEAN AND WARNCOUNT: ▶1a◀▶1a◀
* INTEGER EPS *
* *
* 01/23/79 CHANGES TO SUPPORT ALPHANUMERIC *
* LABELS. CHANGES MADE IN 'LABELDECL', *
* 'GOTOST', AND 'STATEMENT'. RECORD 'LABL' *
* CHANGED TO INCLUDE A VARIANT FIELD OF INTEGER *
* OR ALPHA VALUE. LABELS ARE KEPT IN A STRING *
* OF 'LABL'S; ALPHA LABELS ARE ALSO ENTERED *
* INTO THE SYMBOL TABLE TO AVOID CONFLICTING *
* DEFINITIONS WITH VARIABLES. 'GOTOST' AND 'ST' *
* SCAN THE STRING OF DECLARED LABELS TO FIND *
* THE LABEL THEY ARE PARSING. EPS *
* *
* 01/25/79 CHANGE TO SUPPORT UNORDERED DECLARATION *
* STATEMENTS. CHANGE 'ERROR(18)' TO 'WARNING(502)' *
* IN 'BLOCK' AND MOVE CHECK FOR UNRESOLVED FORWARD *
* TYPE DECL'S FROM INSIDE 'TYPEDECLARATION' *
* AND 'VARDECLARATION' TO 'BLOCK' EPS *
* *
* 01/30/79 ALL GEN ROUTINES REPLACED BY MOTOROLA *
* VERSIONS. ALL CALLS TO GEN ROUTINES REPLACED *
* BY CALLS TO NEW ROUTINE. THE COMPILER NOW *
* COMPILES TO PM, THE MOTOROLA P LANGUAGE EPS *
* *
* 02/02/79 ADDED 'OTHERWISE' CLAUSE TO 'CASE' *
* STATEMENT. NEW SYMBOL 'OTHERWISE' AND CORRE- *
* SPONDING ENTRIES IN RW AND FRW. 'OTHERWISE' *
* IS OPTIONAL; IT FOLLOWS ALL ALTERNATIVES IN *
* THE CASE BODY; THE SYMBOL ITSELF IS NOT FOLLOWED *
* BY A SEMICOLON. EVEN WITHOUT THE OTHERWISE *
* CLAUSE THE CASE STATEMENT IS SAFE - IT MAY BE *
* EQUIV TO A NULL STATEMENT FOR SOME VALUES OF THE *
* CASE INDEX, BUT IT NEVER EXEC'S BAD CODE *
* EPS *
* *
* 02/02/79 ADDED 'EXIT' STATEMENT. NEW PROCEDURES *
* 'LOOPENTRY', 'LOOPEXIT', AND 'EXITSTATEMENT' *
* AND VARIABLES 'LOOPLISTPTR' AND TYPES 'LOOPPTR' *
* AND LOOPLABL. COMMENTS IN THE CODE. EPS *
* *
* 02/21/79 CHANGED LINELGTH TO 133 TO ALLOW LONGER *
* INPUT LINES. ADDED WARNING(503) IN INSYMBOL WHEN *
* SCANNING A LEFTHAND-CURLY-BRACKET COMMENT IF *
* ENCOUNTER ANOTHER LEFTHAND CURLY BRACKET, *
* TO HELP DETECT BADLY FORMED, E.G. NESTED COMMENTS *
* EPS *
* *
* 02/23/79 ADDED 'ORIGIN' FEATURE. CHANGES IN *
* 'VARDECLARATION', 'SELECTOR', AND ADDITION OF *
* NEW SYMBOL TYPE 'ORIGINSY' AND NEW RESERVED WORD *
* 'ORIGIN' EPS *
* *
* 02/26/79 CHANGE FORM OF CONSTANT TO HAVE PTR TO *
* 'STRCONST' INSTEAD OF CONTAINING THE LITERAL *
* STRING IN THE RECORD. SAVES SPACE AND ALLOWS *
* MAX STRING LITERAL SIZE TO BE BIGGER (NOW 64) *
* EPS *
* FIXIBM SHELL FILE FOR TRANSPORTATION TO IBM/370 *
* EPS *
* *
* 03/30/79 ADDED FACILITY FOR COUNTING EXECUTION *
* UNITS FOR PROFILING BY A DEBUG PROGRAM. UNITS *
* CALLED 'EXECUTION ENTITIES' ARE COUNTED BY *
* 'LSC N' OR 'ISC' P-CODE STATEMENTS. THESE ENTITIES*
* ARE PRIMITIVE STATEMENTS (CALL,ASSIGN,GOTO,EXIT) *
* OR LOOP HEADER COMPUTATIONS (CASE,FOR) OR THE *
* BOOLEAN EXPR COMPUTATION IN (WHILE,IF,REPEAT) *
* CHANGES: IN 'STATEMENT' TO CALL GENKOUNT *
* IN ENDOFLINE TO DELAY PRINTING LINE *
* TO PRINT 'ENTITY' # FOR LINE *
* IN MAIN TO REFLECT CHANGES IN ENDOFLINE *
* ADDITION: OF VARIABLES KOUNT,KOUNTERS,HOLDKOUNT, *
* AND FIRSTKOUNT *
* OF PROC GENKOUNT EPS *
* *
* 04/16/79 CHANGE IN THE WAY VARIABLE OFFSETS ARE *
* GENERATED: PARAMETERS ARE POSITIVE OFFSETS *
* (RELATIVE TO THE "FRAME POINTER") AND LOCAL *
* VARIABLES ARE MINUS OFFSETS. EPS *
* *
* 04/17/79 HANDLING OF STRUCTURED NON-VAR PARAMETERS*
* CHANGED: THEY ARE NOW LOADED DIRECTLY ONTO *
* THE STACK BY THE CALLER (1 INSTRUCTION IN *
* MOTOROLA P-CODE) RATHER THE OLD WAY OF CALLER *
* LOADING PARAMETER ADDRESS ON STACK AND CALLEE *
* COPYING THE STRUCTURED VALUE TO LOCAL STORAGE *
* EPS *
* *
* 04/17/79 STRUCTURED FUNCTION VALUES ALLOWED. *
* SPACE IS ALLOCATED ON THE STACK BEFORE PARAMS *
* ARE PUSHED (BY AST P-INSTRUCTION) FOR ARBITRARY *
* SIZED FUNCTION VALUE EPS *
* *
* 05/02/79 DISPOSE ADDED, 'NEW1' NOW CALLED *
* 'NEWDISPOSE' EPS *
* *
* 05/03/79 HANDLING OF FILES COMPLETELY RESTRUCTURED*
* FILES IN HEADER ARE CHAINED ON 'FEXTFILEP'. *
* FILES IN HEADER MUST BE DECLARED IN OUTERMOST *
* LEVEL. INPUT AND OUTPUT MUST NOT BE DECL'D BUT *
* MUST APPEAR IN HEADER IF THEY ARE USED. *
* FILES ARE DECL'D IN LOCAL SCOPES AND OPENED *
* (WITH 'IFD') AND CLOSED (WITH 'CLO') IN THAT *
* SCOPE. UNDECL'D FILES FROM HEADER GENERATE *
* ERROR MESSAGE. FILE COMPONENTS CAN BE ANY TYPE *
* NOT RESTRICTED TO 'CHAR' EPS *
* *
* 05/04/79 EXTERNAL PROC/FUNCS IMPLEMENTED. *
* 'FORWARD' DEFINED PROCEDURES AND FUNCTIONS ARE *
* NOW FLAGGED IF NOT LATER DEFINED IN THE SAME *
* SCOPE. 'FORWARD' DEFINED PROC/FUNCS AT GLOBAL *
* LEVEL ARE ASSUMED TO BE EXTERNAL REFERENCES, AND *
* THEY GENERATE "$N DEF 'PROCFUNCNAME' " IN THE *
* OUTPUT FILE (AS WELL AS A WARNING IN THE LISTING) *
* EPS *
* 05/09/79 SUBPROGRAM CONCEPT (FOR SEPARATE *
* COMPILATION) IMPLEMENTED. SOURCE FILES BEGINNING *
* WITH 'SUBPROGRAM' ARE COMPILED. THEY MAY NOT HAVE *
* A MAIN PROGRAM BODY. THE LAST INNER PROC/FUNC *
* BODY ENDS WITH '.' INSTEAD OF ';' EPS *
* *
* 06/13/79 MACHINE M OPTION NOW SETS ALIGNMENT SIZE.*
* SMALL OBJECTS (BOOL,CHAR) NOW ALLOCATED THE *
* MINIMUM SPACE REQ'D SUBJECT TO ALIGNMENT RULES *
* OF THE TARGET MACHINE(BELOW). *
* *
* IN THE CASE OF A BYTE ALIGNED MACHINE (6809) ALL *
* OBJECTS TAKE THE MINIMUM NUMBER OF BYTES REGARD- *
* LESS OF COMPOSITION. IN THE CASE OF WORD ALIGNED *
* MACHINE (68000) ANY OBJECT THAT IS 2 BYTES OR *
* BIGGER IS WORD ALIGNED (AND SUB-OBJECTS, SUCH *
* AS RECORDS WITHIN RECORDS, FOLLOW THE SAME RULE.) *
* *
* OBJECTS IN STATIC STORAGE TAKE THE MINIMUM SPACE *
* SUBJECT TO THE ABOVE RULES. OBJECTS IN DYNAMIC *
* STORAGE (HEAP) SHOULD BE NEW'ED ON ALIGNMENT *
* BOUNDARIES SINCE THEIR INTERNAL ALIGNMENT IS NOT *
* KNOWN AT RUNTIME. PARAMETER OBJECTS FOR 68000 ARE *
* CURRENTLY ALL ALIGNED ON WORD BOUNDARIES REGARD- *
* LESS OF SIZE, BECAUSE OF THE STACK POINTER *
* ALIGNMENT RESTRICTION ON THE 68000. SLIGHTLY *
* MORE EFFICIENT STORAGE OF PARAMETERS IS POSSIBLE *
* (WITH CONSIDERABLY MORE WORK.) EPS *
* *
* 7/29/79 STRING FACILITY IMPLEMENTED. A NEW *
* TYPE CONSTRUCTOR "STRING" IS RECOGNIZED. DECL'S *
* TAKE THE FORM "VARIABLENAME: STRING(.INTEGER.);" *
* THE INTEGER INDICATES THE MAXIMUM SIZE IN CHARS *
* THAT THE STRING WILL TAKE. SIZE+1 BYTES ARE *
* ALLOCATED FOR STRING STORAGE; THE FIRST BYTE *
* BEING USED TO HOLD THE CURRENT STRING LENGTH AT *
* RUN-TIME. STRINGS MAY BE INDEXED TO OBTAIN *
* INDIVIDUAL CHARACTERS ("STRINGVAR(.N.)" IS THE NTH *
* CHAR OF STRINGVAR). STRINGS ARE ASSIGNABLE TO *
* PACKED ARRAY OF CHAR BUT NOT VICE VERSA. STRINGS *
* ARE COMPATIBLE WITH OTHER STRINGS REGARDLESS OF *
* SIZE. MANIFEST STRING CONSTANTS ARE STRINGS. *
* EPS *
* 07/25/79 BUILTIN FUNCTIONS AND PROCEDURES CAN *
* NOW BE REDEFINED BY THE USER PROGRAM EPS *
* *
* 07/27/79 LINES MARKED '%MOTO' ARE REMOVED BY *
* FIXMOTO SHELL FILE FOR TRANSPORTATION TO PHOENIX *
* EPS *
* *
* 08/15/79 READ AND WRITE OF NON-TEXT FILES EPS *
* *
* NEXT COMMENT *
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
PROGRAM PASCALCOMPILER(OUTPUT, SOURCE, PCODE, LISTING);
CONST
VERSION = ' 1.10';
M6809 = 1;
M68000 = 2;
MACHINE = M68000;
DISPLIMIT = 20; MAXLEVEL = 8;
MINADDR =-32000; MAXADDR = 32000 ;
MAXINTEGER = 32767;
INT2SIZE = 2; REALSIZE = 4;
INT1SIZE = 1; INT4SIZE = 4;
CHARSIZE = 1; BOOLSIZE = 1;
SETSIZE = 8;
LASTRESWD = 40; NEXTRESWD = 41 ;
STRGLNGTH = 64; ORDMAXCHAR =127 (*WAS 63 EPS*);
REALLNGTH = 11;
DIGMAX = 11 ; (*=REALLNGTH*)
IDLNGTH = 8 ; (*SIZE OF TYPE ALPHA*)
SETRANGE = 63 ;
LINELGTH = 133; (*CHANGED FROM 81 EPS*)
MAXLABEL = 4000; (* MAXIMUM NUMBER OF LABELS *)
PAGEDEFAULT = 76; (* DEFAULT TOTAL LENGTH OF A PAGE *)
ENDOFPAGE = 76; (* DEFAULT END OF PAGE *)
STARTPAGE = 77; (* START PAGE POS HERE (MDOS = 66) *)
WIDTHDEFAULT = 132; (* DEFAULT PAGE WIDTH TO 132 COLUMNS *)
LMARGIN = 21; (* WIDTH OF THE LEFT MARGIN IN LISTING FILE *)
ORDMAXBASECHAR = 255; (* ORD OF MAX CHAR IN BASE CHAR TYPE *)
(* 255 FOR EBCDIC, 127 FOR ASCII *)
SYSTEM = 0;
USER = 1;
TYPE (* DESCRIBING: *)
(* +++++++++++ *)
(* BASIC SYMBOLS
*) (* +++++++++++++
*)
SYMBOL = (IDENT,INT1CONST,INT2CONST,INT4CONST,REALCONST,STRINGCONST,NOTS
Y, MULOP,ADDOP,RELOP,LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLO
N, PERIOD,ARROW,COLON,RANGE,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,
FUNCSY,PROGSY,PROCSY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,
FORWARDSY,BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,
GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
THENSY,OTHERSY,OTHERWZSY,EXITSY,ORIGINSY,STRINGSY,SUBPROGSY);
OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP
, NEOP,EQOP,INOP,NOOP);
(* THE FOLLOWING IS AN ENUMERATED TYPE OF STANDARD NAMES, EXCLUDING *)
(* INPUT AND OUTPUT. THEY ARE ARRANGED IN THE FOLLOWING ORDER: *)
(* CONSTANTS FIRST, TYPES SECOND, FUNCTIONS THIRD, AND PROCEDURES *)
(* LAST. WITHIN EACH CLASS, THE INDIVIDUAL NAMES ARE ARRANGED IN *)
(* THE ORDER IN WHICH THEY WILL GO INTO THE TREE - TO HELP BALANCE *)
(* IT. *)
STDNAMES = (XMAXINT, XFALSE, XTRUE, XNIL,
XTEXT, XCHAR, XREAL, XINTEGER,
XBOOLEAN, XODD, XEOLN, XCONCAT,
XLENGTH, XDELETE, XPOS, XSQR,
XARCTAN, XCHR, XCOPY, XLN,
XPOSITION, XROUND, XSQRT, XABS,
XCLOCK, XCOS, XEOF, XEXP,
XINSERT, XORD, XPRED, XSIN,
XSUCC, XTRUNC, XREWRITE, XPUT,
XHALT, XUNPACK, XDISPOSE, XNEW,
XPACK, XREAD, XRELEASE, XWRITE,
XGET, XMARK, XPAGE, XREADLN,
XRESET, XWRITELN );
SETOFSYS = SET OF SYMBOL;
(*POTENTIAL PORTABILITY PROBLEM: SET OF 54 ELEMENTS*)
CHTYP = (ATOZ, NUMBER, STRQUOTE, COLONCHAR, PERIODCHAR,
LPOINTY, RPOINTY, LPARN, MISCCHAR,
CMNTBRACK,BLANKCHAR, ILLEGALCHAR);
LNGINT = PACKED ARRAY (.1..4.) OF INTEGER;
LNGRELATION = (LNGLESS,LNGEQUAL,LNGGREATER);
(* CONSTANTS *)
(* +++++++++ *)
CSTCLASS = (LINT,REEL,PSET,STRG);
SETCONST = SET OF 0..SETRANGE;
(*POTENTIAL PORTABILITY PROBLEM: SET OF 64 ELEMENTS*)
STRCONST = PACKED ARRAY (.1..STRGLNGTH.) OF CHAR;
CSP = @ CONSTANT;
CONSTANT = RECORD CASE CSTCLASS OF
LINT: (LINTVAL: LNGINT);
REEL: (RVAL: PACKED ARRAY (.0..REALLNGTH.) OF CHAR);
PSET: (PVAL: SETCONST );
STRG: (SLNGTH: 0..STRGLNGTH;
SVAL: @STRCONST)
END;
VALU = RECORD CASE (*INTVAL:*) BOOLEAN OF (*INTVAL NEVER SET NOR TESTED*
) TRUE: (IVAL: INTEGER);
FALSE: (VALP: CSP)
END;
(* DATA STRUCTURES *)
(* +++++++++++++++ *)
MNRANGE = 0..118;
ADDRRANGE = MINADDR..MAXADDR;
LEVRANGE = 0..MAXLEVEL;
LABELRNG = 0..MAXLABEL ;
STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,STRINGS,ARRAYS,RECORDS,
FILES,TAGFLD,VARIANT); (*ORDER OF ELEMENTS IS IMPORTANT*)
CTP = @IDENTIFIER;
STP = @STRUCTURE;
STRUCTURE = PACKED RECORD
SIZE: ADDRRANGE;
CASE FORM: STRUCTFORM OF
SCALAR: (FCONST: CTP);
SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU);
POINTER: (ELTYPE: STP);
POWER: (ELSET: STP);
(*STRINGS: ();*)
ARRAYS: (AELTYPE,INXTYPE: STP);
RECORDS: (FSTFLD: CTP; RECVAR: STP);
FILES: (FILTYPE: STP);
TAGFLD: (TAGFIELDP: CTP; FSTVAR: STP);
VARIANT: (NXTVAR,SUBVAR: STP; VARVAL: VALU)
END;
(* NAMES *)
(* +++++ *)
IDCLASS = (TYPES,LABELS,KONST,VARS,FIELD,PROC,FUNC);
SETOFIDS = SET OF IDCLASS;
IDKIND = (ACTUAL,FORMAL,ORIGINED);
ALPHA = PACKED ARRAY(.1..IDLNGTH.) OF CHAR;(*SIZE(ALPHA) MUST=IDLNGTH*)
DECLKIND = (BUILTIN,DECLARED);
IDENTIFIER = PACKED RECORD
NAME: ALPHA; LLINK, RLINK: CTP;
IDTYPE: STP; NEXT: CTP;
CASE KLASS: IDCLASS OF
(* TYPES,LABELS: ( ); NOT ALLOWED BY AMSTERDAM EPS *)
(* REQ'D BY BERKELEY EPS *)
KONST: (VALUES: VALU);
VARS: (VKIND: IDKIND; EXTRNL: BOOLEAN;
VLEV: LEVRANGE; VADDR: LNGINT);
FIELD: (FLDADDR: ADDRRANGE);
PROC,
FUNC: (CASE PFDECKIND: DECLKIND OF
BUILTIN: (KEY: STDNAMES);
DECLARED: (PFLEV: LEVRANGE; PFNAME: LABELRNG;
PFADDR: ADDRRANGE;
CASE PFKIND: IDKIND OF
(*ORIGINED, FORMAL: ( ); *)
(*ABOVE NOT ALLOWED BY AMSTERDAM EPS *)
(* BUT REQ'D BY BERKELEY EPS *)
ACTUAL: (FORWDECL(*, EXTERN*):
BOOLEAN)))
END;
DISPRANGE = 0..DISPLIMIT;
WHERE = (BLCK,CREC,VREC,REC);
(* EXPRESSIONS *)
(* +++++++++++ *)
ATTRKIND = (CST,VARBL,FILEPTR,EXPR);
VACCESS = (DRCT,INDRCT);
ATTR = RECORD TYPTR : STP;
CASE KIND: ATTRKIND OF
CST: (CVAL: VALU);
(* EXPR: ( ); NOT ALLOWED BY AMSTERDAM EPS *)
(* REQ'D BY BERKELEY EPS *)
VARBL,FILEPTR: (CASE ACCESS: VACCESS OF
DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE);
INDRCT: (IDPLMT: ADDRRANGE) )
END;
TESTP = @ TESTPOINTER;
TESTPOINTER = PACKED RECORD
ELT1,ELT2 : STP;
LASTTESTP : TESTP
END;
(* LABELS *)
(* ++++++ *)
LBP = @ LABL;
LABL = RECORD NEXTLAB: LBP;
DEFINED: BOOLEAN;
LABNO: LABELRNG;
CASE ALF:BOOLEAN OF
FALSE:(LABVAL: INTEGER);
TRUE: (LABNAME: ALPHA )
END;
LOOPPTR = @LOOPLABL;
LOOPLABL = RECORD LABNO: LABELRNG; (*ENTRY ON STACK OF LOOPEXIT LABELS*)
ASSOCLAB: LBP;
NEXTLOOP: LOOPPTR;
USED: BOOLEAN
END;
EXTFILEP = @FILEREC;
FILEREC = RECORD FILENAME:ALPHA;
NEXTFILE:EXTFILEP;
POS: INTEGER;
DEF:BOOLEAN
END;
(* -------------------------------------------------------------------------
*)
VAR
SOURCE,
PCODE,
LISTING: FILE OF CHAR;
(*NOT ALLOWED BY AMSTERDAM; REQ'D BY MOTO AND TSO*)
(* RETURNED BY SOURCE PROGRAM SCANNER
INSYMBOL:
+++++++++ *)
SY: SYMBOL; (* LAST SYMBOL *)
OP: OPERATOR; (* CLASSIFICATION OF LAST SYMBOL *)
CH: CHAR; (* LAST CHARACTER READ *)
EOL: BOOLEAN; (* END OF LINE FLAG *)
DOUBLECHAR: BOOLEAN; (*DOUBLE CHAR FOUND IN NUMBER FLAG*)
DOUBLESYM: SYMBOL; (*SYMBOL TYPE OF DOUBLE CHAR FOUND*)
(* COUNTERS: *)
(* +++++++++ *)
CHCNT: 0..LINELGTH; (* CHARACTER COUNTER *)
LINELEN:1..LINELGTH; (* LENGTH OF CURRENT LINE *)
LOCN,IC,OLDIC: ADDRRANGE ; (* DATA LOCATION AND INSTRUCTION COUNTER
*) LINECOUNT,I: INTEGER;
INTLABEL, (* LABEL NUMBER *)
PROCLAB: LABELRNG; (* PROCEDURE LABEL NUMBER *)
ERRORCOUNT:INTEGER ; (* TOTAL ERROR COUNT *)
WARNCOUNT:INTEGER ;
ERRORS, WARNINGS: BOOLEAN;
GATTR: ATTR; (* DESCRIBES THE EXPR CURRENTLY COMPILED
*) VAL: VALU; (* VALUE OF LAST CONSTANT *)
LNGTH: INTEGER; (* LENGTH OF LAST STRING CONSTANT *)
ID, BLANKID, PROGNAME: ALPHA; (* LAST IDENTIFIER (POSSIBLY TRUNCATED) *
)
(* SWITCHES: *)
(* +++++++++ *)
LONGONLY, (*LONG INTEGER ONLY ALLOWED IN INSYMBOL*)
SUBPROG,
DP, (* DECLARATION PART *)
PRTERR, (* TO ALLOW FORWARD REF IN PTR VARIABLES
*) ASSIGN, (* DECLARATION BY SUPPRESSING ERROR MSG *
) LIST, (* SOURCE PROGRAM LISTING OPTION *)
PLIST, (* INCLUDE SOURCE IN PCODE OPTION *)
PRCODE, (* PRODUCE PCODE OPTION *)
DEBUG, (* PRODUCE RANGE CHECKING *)
KOUNTERS, (* PRODUCE LINE COUNTING CODE OPTION *)
PKOUNTERS, (* PRODUCE PROCEDURE COUNTING CODE OPT *)
STANDARD: BOOLEAN; (* PRINT WARNINGS IF NON STANDARD OPTION
*)
JUMPENTRIES: INTEGER; (*# OF JUMP TABLE ENTRIES*)
JUMPBASE, (*JUMP TABLE BASE ADDRESS*)
HEAPSTART, (*HEAP START ADDRESS*)
STACKSTART: LNGINT; (*STACK START (TOP) ADDRESS*)
ADDRSIZE, ALIGNMENT:INTEGER;
(* SET BY THE OPTION 'M' TO 2 OR 4 DEPENDING ON
ADDRESS SIZE (BYTES) OF TARGET *)
PAGENUM, (* LISTING FORMAT VARIABLES *)
PAGEPOS,
LINEWIDTH,
PAGEEND,
PAGELEN,
LASTERR: INTEGER;
BLEV, MLEV: CHAR; (* BLOCK NESTING ACCOUNTING VARS *)
SBLOCK,
EBLOCK: BOOLEAN;
KOUNT,
MINKOUNT: INTEGER; (* STATEMENT COUNTING VARIBLES *)
PRINTKOUNT,
LABELEDKOUNT: BOOLEAN;
ARITHMETICSIZE: CHAR; (* SIZE OF INTEGER ARITHMETIC *)
(* POINTERS: *)
(* +++++++++ *)
INT1PTR,INT2PTR,INT4PTR,
REALPTR,CHARPTR,
BOOLPTR,NILPTR,TEXTPTR: STP; (* POINTERS TO ENTRIES OF STANDARD IDS *)
SINGLECHARSTRING: STP; (* POINTER TO RESULT OF CONVERTING CHAR TO STR *)
UTYPPTR,UCSTPTR,UVARPTR,
UFLDPTR,UPRCPTR,UFCTPTR, (* POINTERS TO ENTRIES FOR UNDECLARED IDS*)
ULABPTR,FWPTR:CTP; (* HEAD OF CHAIN OF FORW DECL TYPE IDS *)
STDINPUT,STDOUTPUT: CTP; (* POINTERS TO DEFAULT FILES FOR READ,WRITE
*)
GLOBFILELIST: CTP;
FEXTFILEP: EXTFILEP; (* HEAD OF CHAIN OF EXTERNAL FILES *)
GLOBTESTP: TESTP; (* LAST TESTPOINTER *)
CNSTVALPTR : CSP ; (* POINTERS TO CURRENT STRING/REAL CNST*)
CNSTSTRPTR : @STRCONST;
(* BOOKKEEPING OF DECLARATION LEVELS: *)
(* ++++++++++++++++++++++++++++++++++ *)
LEVEL: LEVRANGE; (* CURRENT STATIC LEVEL *)
STKSIZES: ARRAY (.LEVRANGE.) (*MAX STACK SIZE OF EACH STATIC LEVEL*)
OF INTEGER;
DISX, (* LEVEL OF LAST ID SEARCHED BY SEARCHID
*) TOP: DISPRANGE; (* TOP OF DISPLAY *)
DISPLAY: (* WHERE: MEANS: *)
ARRAY (.DISPRANGE.) OF
PACKED RECORD (* =BLCK: ID IS VARIABLE ID *)
FNAME: CTP; FLABEL: LBP; (* =CREC: ID IS FIELD ID IN RECORD WITH*)
CASE OCCUR: WHERE OF (* CONSTANT ADDRESS *)
CREC: (CLEV: LEVRANGE; (* =VREC: ID IS FIELD ID IN RECORD WITH*)
CDSPL: ADDRRANGE);(* VARIABLE ADDRESS *)
VREC: (VDSPL: ADDRRANGE)
END; (* --> PROCEDURE WITHSTATEMENT *)
(* ERROR MESSAGES: *)
(* +++++++++++++++ *)
ERRINX: 0..10; (* NR OF ERRORS IN CURRENT SOURCE LINE *)
ERRLIST:
ARRAY (.1..10.) OF
PACKED RECORD POS: 0..LINELGTH;
NMR: 1..999
END;
(* STRUCTURED CONSTANTS: *)
(* +++++++++++++++++++++ *)
LONGZERO, (*LONG ZERO VALUE*)
LINT1MIN,LINT1MAX,
LINT2MIN,LINT2MAX,
LINT4MIN,LINT4MAX,
LONGORDMAXCHAR: LNGINT; (*LONG VALUE OF ORDMAXCHR*)
LINEBUF: ARRAY(.0..LINELGTH.) OF CHAR ; (* CURRENT LINE BUFFER *)
CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
STATBEGSYS,TYPEDELS,LOOPBEGSYS: SETOFSYS;
RW: ARRAY (.0..LASTRESWD(* NR. OF RES. WORDS *).) OF ALPHA;
FRW: ARRAY (.0..14.) OF 1..NEXTRESWD(* NR. OF RES. WORDS + 1 *);
RSY: ARRAY (.0..LASTRESWD(* NR. OF RES. WORDS *).) OF SYMBOL;
SSY: ARRAY (.CHAR.) OF SYMBOL;
ROP: ARRAY (.0..LASTRESWD(* NR. OF RES. WORDS *).) OF OPERATOR;
SOP: ARRAY (.CHAR.) OF OPERATOR;
MN: ARRAY (.MNRANGE.) OF PACKED ARRAY (.1..4.) OF CHAR;
UPPER: ARRAY(.CHAR.) OF CHAR; (* INSYMBOL UPPERCASE TABLE *)
ASCII: ARRAY(.CHAR.) OF INTEGER;
CHTAB: ARRAY(.CHAR.) OF CHTYP; (* INSYMBOL DIRECTOR TABLE *)
HEADER: PACKED ARRAY (. 1..29 .) OF CHAR; (* HEADER MESSAGE & DATE *)
EOFMESSAGE: PACKED ARRAY (. 1..35 .) OF CHAR; (* EOF MESSAGE *)
STARS: PACKED ARRAY (. 1..5 .) OF CHAR; (* 4 STARS *)
ERRMES: PACKED ARRAY (. 1..9 .) OF CHAR; (* **ERROR-- MESSAGE *)
(*----------------------------------------------------------------------
FUNCTION USUCC
-----------------------------------------------------------------------*)
FUNCTION USUCC(C: CHAR): CHAR; (* UNIVERSAL SUCCSESOR FUNCTION *)
BEGIN
IF (C <> 'I') AND (C <> 'R') THEN
USUCC := SUCC(C)
ELSE IF C = 'I' THEN
USUCC := 'J'
ELSE IF C = 'R' THEN
USUCC := 'S'
END;
(*---------------------------------------------------------
FUNCTION UPRED
----------------------------------------------------------*)
FUNCTION UPRED(C: CHAR): CHAR; (* UNIVERSAL PREDISESOR FUNCTION *)
BEGIN
IF (C <> 'J') AND (C <> 'S') AND (C <> 'A') THEN
UPRED := PRED(C)
ELSE IF C = 'J' THEN
UPRED := 'I'
ELSE IF C = 'S' THEN
UPRED := 'R'
ELSE
UPRED := C
END;
(*-------------------------------------------------------------------
PROCEDURE NEWPAGE
--------------------------------------------------------------------*)
PROCEDURE NEWPAGE;
VAR
I: INTEGER;
BEGIN
PAGENUM := PAGENUM + 1;
FOR I := PAGEPOS TO PAGELEN DO
WRITELN(LISTING,' ');
WRITE(LISTING,'LINE LOC LEV BE ':20,HEADER,VERSION);
WRITELN(LISTING,'PAGE ':(LINEWIDTH - 64),PAGENUM:0);
WRITELN(LISTING,' ');
PAGEPOS := 3
END;
(*-----------------------------------------------------------------
PROCEDURE WRITELINE
------------------------------------------------------------------*)
PROCEDURE WRITELINE;
VAR
I,LINESIZE: INTEGER;
BEGIN (* WRITELINE *)
IF PAGEPOS > PAGEEND THEN
NEWPAGE
ELSE IF ERRORS OR WARNINGS THEN
IF PAGEPOS > PAGEEND - 2 THEN
NEWPAGE;
WRITE(LISTING,LINECOUNT:6);
IF DP THEN
WRITE(LISTING,'(',LOCN:6,')')
ELSE IF PRINTKOUNT THEN
WRITE(LISTING, MINKOUNT:7,' ')
ELSE
WRITE(LISTING, ' ':8);
WRITE(LISTING,LEVEL:2,')');
IF SBLOCK THEN
WRITE(LISTING, MLEV)
ELSE
WRITE(LISTING, '-');
IF EBLOCK THEN
WRITE(LISTING, BLEV,' ')
ELSE
WRITE(LISTING, '- ');
IF LINELEN <= LINEWIDTH - LMARGIN THEN
LINESIZE := LINELEN
ELSE
LINESIZE := LINEWIDTH - LMARGIN;
FOR I := 1 TO LINESIZE DO
WRITE(LISTING, LINEBUF(. I .));
WRITELN(LISTING,' ');
PAGEPOS := PAGEPOS + 1
END; (* WRITELINE *)
(*------------------------------------------------------------------
PROCEDURE PRINTERROR
-------------------------------------------------------------------*)
PROCEDURE PRINTERROR;
VAR
SECONDLINE: BOOLEAN;
F,K,
LASTPOS,
FREEPOS,
CURRPOS,
CURRNMR: INTEGER;
BEGIN (* PRINTERROR *)
IF NOT LIST THEN WRITELINE;
IF ERRORS THEN
WRITE(LISTING, ERRMES:11)
ELSE
WRITE(LISTING, '*WARNING-':11);
WRITE(LISTING, LASTERR:6,'** ':3);
LASTPOS := 0;
FREEPOS := 1;
SECONDLINE := FALSE;
FOR K := 1 TO ERRINX DO
BEGIN
WITH ERRLIST(. K .) DO
BEGIN
CURRPOS := POS;
CURRNMR := NMR
END; (* WITH *)
IF CURRNMR < 10 THEN
F := 1
ELSE IF CURRNMR < 100 THEN
F := 2
ELSE
F := 3;
IF SECONDLINE THEN
BEGIN
WRITE(LISTING,',',CURRNMR:F);
FREEPOS := FREEPOS + F + 1
END
ELSE IF ((CURRPOS = LASTPOS)
AND (FREEPOS + F + 1 > LINEWIDTH - LMARGIN))
OR (CURRPOS + F + 1 > LINEWIDTH - LMARGIN) THEN
BEGIN
IF K > 1 THEN
BEGIN
IF (CURRPOS = LASTPOS) THEN
WRITELN(LISTING,',')
ELSE
WRITELN(LISTING,' ');
PAGEPOS := PAGEPOS + 1;
WRITE(LISTING,'****CONTINUED**** ':20);
FREEPOS := 1
END;
WRITE(LISTING,CURRNMR:F);
FREEPOS := FREEPOS + F;
SECONDLINE := TRUE
END
ELSE
BEGIN
IF CURRPOS = LASTPOS THEN
WRITE(LISTING,',')
ELSE IF CURRPOS <= FREEPOS THEN
WRITE(LISTING,'@')
ELSE
BEGIN
WRITE(LISTING,'@':(CURRPOS - FREEPOS + 1));
FREEPOS := CURRPOS
END;
WRITE(LISTING, CURRNMR:F);
FREEPOS := FREEPOS + F + 1
END;
LASTPOS := CURRPOS;
END; (* FOR K ... *)
IF SECONDLINE THEN
WRITELN(LISTING,'>')
ELSE
WRITELN(LISTING,' ');
PAGEPOS := PAGEPOS + 1;
LASTERR := LINECOUNT;
ERRINX := 0;
PRCODE := NOT ERRORS AND PRCODE;
PLIST := NOT ERRORS AND PLIST;
ERRORS := FALSE;
WARNINGS := FALSE
END; (* PRINTERROR *)
(* -------------------------------------------------------------------------
PROCEDURE ERROR
------------------------------------------------------------------------- *
)
PROCEDURE ERROR(FERRNR: INTEGER);
BEGIN
ERRORS := TRUE;
IF ERRINX >= 9 THEN
BEGIN ERRLIST(.10.).NMR := 255; ERRINX := 10 END
ELSE
BEGIN ERRINX := ERRINX + 1;
ERRLIST(.ERRINX.).NMR := FERRNR
END;
ERRLIST(.ERRINX.).POS := CHCNT ;
ERRORCOUNT := ERRORCOUNT+1 ;
END (* ERROR *) ;
(* -------------------------------------------------------------------------
PROCEDURE WARNING
------------------------------------------------------------------------- *
)
PROCEDURE WARNING(FERRNR: INTEGER);
BEGIN
WARNINGS := TRUE;
IF ERRINX >= 9 THEN
BEGIN ERRLIST(.10.).NMR := 255; ERRINX := 10 END
ELSE
BEGIN ERRINX := ERRINX + 1;
ERRLIST(.ERRINX.).NMR := FERRNR
END;
ERRLIST(.ERRINX.).POS := CHCNT ;
WARNCOUNT := WARNCOUNT+1 ;
END (* ERROR *) ;
(* -------------------------------------------------------------------------
PROCEDURE READLINE
------------------------------------------------------------------------- *
)
PROCEDURE READLINE;
VAR
I: INTEGER;
BEGIN (* READLINE *)
IF EOF(SOURCE) THEN
BEGIN
WRITELN(LISTING,EOFMESSAGE:45);
WRITELN(OUTPUT, EOFMESSAGE:36);
WRITELN(PCODE,'END':4);
(*PP*) HALT (* POSSIBLE PORTABILLITY PROBLEM *)
END
ELSE
BEGIN
LINELEN := 1;
WHILE NOT EOLN(SOURCE) AND (LINELEN < LINELGTH) DO
BEGIN
READ(SOURCE, LINEBUF(. LINELEN .));
LINELEN := LINELEN + 1
END;
READLN(SOURCE);
CHCNT := 0;
LINEBUF(. LINELEN .) := ' ';
MINKOUNT := KOUNT;
PRINTKOUNT := FALSE;
MLEV := BLEV;
SBLOCK := FALSE;
EBLOCK := FALSE;
LINECOUNT := LINECOUNT + 1;
IF PLIST THEN
BEGIN
WRITE(PCODE,'.',' ':10);
FOR I := 1 TO LINELEN DO WRITE(PCODE,LINEBUF(. I .));
WRITELN(PCODE,' ')
END
END (* ELSE *)
END; (* READLINE *)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE WRITELONG (FIL,LVAL) *)
(* *)
(* THIS PROCEDURE WRITES THE VALUE OF THE LONG INTEGER IN *)
(* 'LVAL' TO THE TEXT FILE 'FIL'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE WRITELONG (VAR FIL: TEXT; LVAL: LNGINT);
VAR
I: INTEGER;
BEGIN (*WRITELONG*)
FOR I := 4 DOWNTO 1 DO
BEGIN
WRITE (FIL,LVAL(.I.):1);
IF I <> 1 THEN WRITE (FIL,', ')
END (*FOR*)
END; (*WRITELONG*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE OUTHEX (FIL,LVAL) *)
(* *)
(* THIS PROCEDURE OUTPUTS THE LONG INTEGER IN LVAL TO THE *)
(* FILE FIL IN HEX FORMAT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE OUTHEX (VAR FIL: TEXT; LVAL: LNGINT);
VAR
I: INTEGER;
PROCEDURE OUTBYTE (BYTE: INTEGER);
PROCEDURE OUTNIBBLE (NIBBLE: INTEGER);
BEGIN (*OUTNIBBLE*)
IF NIBBLE < 10
THEN WRITE (FIL,CHR(ORD('0') + NIBBLE))
ELSE WRITE (FIL,CHR(ORD('A') + NIBBLE - 10))
END; (*OUTNIBBLE*)
BEGIN (*OUTBYTE*)
OUTNIBBLE (BYTE DIV 16);
OUTNIBBLE (BYTE MOD 16)
END; (*OUTNIBBLE*)
BEGIN (*OUTHEX*)
FOR I := 4 DOWNTO 1 DO
OUTBYTE (LVAL(.I.))
END; (*OUTHEX*)
(*$E------------------------------------------------------------------*)
(* *)
(* FUNCTION COMPLONGS (VAL1,VAL2): LNGRELATION *)
(* *)
(* THIS FUNCTION COMPARES THE SIGNED VALUE REPRESENTED BY *)
(* THE LONG INTEGER IN 'VAL1' TO THE SIGNED VALUE REPRESENTED *)
(* BY THE LONG INTEGER IN 'VAL2'. *)
(* *)
(*--------------------------------------------------------------------*)
FUNCTION COMPLONGS (VAL1,VAL2: LNGINT): LNGRELATION;
VAR
I: INTEGER;
BEGIN (*COMPLONGS*)
IF (VAL1(.4.) >= 128) AND (VAL2(.4.) < 128)
THEN COMPLONGS := LNGLESS
ELSE
IF (VAL1(.4.) < 128) AND (VAL2(.4.) >= 128)
THEN COMPLONGS := LNGGREATER
ELSE
BEGIN (*SIGNS ARE THE SAME - COMPARE THEM*)
I := 5;
REPEAT
I := I - 1
UNTIL (I = 1) OR (VAL1(.I.) <> VAL2(.I.));
IF VAL1(.I.) < VAL2(.I.)
THEN COMPLONGS := LNGLESS
ELSE
IF VAL1(.I.) = VAL2(.I.)
THEN COMPLONGS := LNGEQUAL
ELSE COMPLONGS := LNGGREATER
END (*ELSE*)
END; (*COMPLONGS*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE ADDLONG (LONGVALUE,ADDVALUE,OVERFLOW) *)
(* *)
(* THIS PROCEDURE ADDS THE INTEGER IN 'ADDVALUE' TO THE LONG *)
(* INTEGER IN 'LONGVALUE'. 'OVERFLOW' IS RETURNED TRUE IF *)
(* THE ADDITION RESULTED IN AN OVERFLOW. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE ADDLONG (VAR LONGVALUE: LNGINT; ADDVALUE: INTEGER;
VAR OVERFLOW: BOOLEAN);
VAR
I: 0..4;
C: INTEGER;
TEMP: INTEGER;
BEGIN (*ADDLONG*)
I := 0;
C := ADDVALUE;
REPEAT
I := I + 1;
TEMP := LONGVALUE(.I.) + C;
C := TEMP DIV 256;
IF C > 0 THEN TEMP := TEMP MOD 256;
LONGVALUE(.I.) := TEMP
UNTIL (I = 4) OR (C = 0);
OVERFLOW := C <> 0
END; (*ADDLONG*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE MULTLONG (LONGVALUE,RADIX,OVERFLOW) *)
(* *)
(* THIS PROCEDURE MULTIPLIES THE LONG INTEGER IN 'LONGVALUE' *)
(* BY THE INTEGER IN 'RADIX'. IF AN OVERFLOW OCCURS, *)
(* 'OVERFLOW' IS RETURNED TRUE. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE MULTLONG (VAR LONGVALUE: LNGINT; RADIX: INTEGER;
VAR OVERFLOW: BOOLEAN);
VAR
I: 1..4;
C: INTEGER;
TEMP: INTEGER;
BEGIN (*MULTLONG*)
C := 0;
FOR I := 1 TO 4 DO
BEGIN
TEMP := LONGVALUE(.I.) * RADIX + C;
C := TEMP DIV 256;
IF C > 0 THEN TEMP := TEMP MOD 256;
LONGVALUE(.I.) := TEMP
END; (*FOR*)
OVERFLOW := C <> 0
END; (*MULTLONG*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE ADD2LONGS (LVAL1,LVAL2,RVAL,OVERFLOW) *)
(* *)
(* THIS PROCEDURE ADDS THE TWO LONG INTEGERS IN 'LVAL1' AND *)
(* 'LVAL2' AND PUTS THE RESULT IN 'RVAL'. IF AN OVERFLOW *)
(* OCCURS, 'OVERFLOW' IS RETURNED TRUE. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE ADD2LONGS (LVAL1,LVAL2: LNGINT; VAR RVAL: LNGINT;
VAR OVERFLOW: BOOLEAN);
VAR
I,C,R: INTEGER;
BEGIN (*ADD2LONGS*)
C := 0; (*INIT THE CARRY*)
FOR I := 1 TO 4 DO
BEGIN (*ADD A BYTE*)
R := LVAL1(.I.) + LVAL2(.I.) + C;
C := R DIV 256;
RVAL(.I.) := R MOD 256
END; (*FOR*)
OVERFLOW := (C <> 0) (*SET UP OVERFLOW FLAG*)
END; (*ADD2LONGS*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE RSHIFTLONG (LVAL,BITS) *)
(* *)
(* THIS PROCEDURE PERFORMS A LOGICAL SHIFT RIGHT OF THE LONG *)
(* INTEGER IN 'LVAL' FOR 'BITS' BITS. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE RSHIFTLONG (VAR LVAL: LNGINT; BITS: INTEGER);
VAR
I,J,C: INTEGER;
BEGIN (*RSHIFTLONG*)
FOR I := 1 TO BITS DO
BEGIN (*SHIFT RIGHT ONE BIT*)
LVAL(.1.) := LVAL(.1.) DIV 2;
FOR J := 2 TO 4 DO
BEGIN
C := LVAL(.J.) MOD 2;
LVAL(.J.) := LVAL(.J.) DIV 2;
IF C = 1 THEN LVAL(.J - 1.) := LVAL(.J - 1.) + 128
END (*FOR*)
END (*FOR*)
END; (*RSHIFTLONG*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE NEGLONG (LVAL) *)
(* *)
(* THIS PROCEDURE NEGATES (TWO'S COMPLEMENT) THE VALUE IN *)
(* THE LONG INTEGER 'LVAL'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE NEGLONG (VAR LVAL: LNGINT);
VAR
I: INTEGER;
B: BOOLEAN;
BEGIN (*NEGLONG*)
B := FALSE; (*INIT THE BORROW FLAG*)
FOR I := 1 TO 4 DO
IF B
THEN LVAL(.I.) := 255 - LVAL(.I.)
ELSE IF LVAL(.I.) > 0 THEN (*HAVE TO BORROW*)
BEGIN
LVAL(.I.) := 256 - LVAL(.I.);
B := TRUE
END (*THEN*)
END; (*NEGLONG*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE MAKELONG (IVAL,LVAL) *)
(* *)
(* THIS PROCEDURE TURNS THE SIGNED INTEGER VALUE IN 'IVAL' *)
(* INTO A SIGNED LONG INTEGER VALUE IN 'LVAL'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE MAKELONG (IVAL: INTEGER; VAR LVAL: LNGINT);
VAR TEMP: INTEGER;
BEGIN (*MAKELONG*)
TEMP := IVAL;
IF TEMP < 0 THEN
BEGIN (*MAKE IT POSITIVE*)
TEMP := TEMP + 32767;
TEMP := TEMP + 1
END; (*THEN*)
LVAL := LONGZERO;
LVAL(.2.) := TEMP DIV 256;
LVAL(.1.) := TEMP MOD 256;
IF IVAL < 0 THEN
BEGIN (*MAKE IT NEGATIVE*)
LVAL(.2.) := LVAL(.2.) + 128;
LVAL(.3.) := 255;
LVAL(.4.) := 255
END (*THEN*)
END; (*MAKELONG*)
(*$E------------------------------------------------------------------*)
(* *)
(* FUNCTION MAKESHORT (LVAL): INTEGER *)
(* *)
(* THIS FUNCTION TURNS THE VALUE IN THE LONG INTEGER 'LVAL' *)
(* INTO A REGULAR INTEGER. *)
(* *)
(*--------------------------------------------------------------------*)
FUNCTION MAKESHORT (LVAL: LNGINT): INTEGER;
VAR
NEG: BOOLEAN;
IVAL: INTEGER;
BEGIN (*MAKESHORT*)
IF LVAL(.4.) >= 128
THEN BEGIN
NEGLONG (LVAL);
NEG := TRUE
END (*THEN*)
ELSE NEG := FALSE;
IVAL := LVAL(.2.) * 256 + LVAL(.1.);
IF NEG THEN IVAL := -IVAL;
MAKESHORT := IVAL
END; (*MAKESHORT*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE INSYMBOL *)
(* *)
(* THIS PROCEDURE GETS THE NEXT BASIC SYMBOL OF THE SOURCE *)
(* PROGRAM AND RETURNS ITS DESCRIPTION IN THE GLOBAL *)
(* VARIABLES 'SY', 'OP', 'ID', 'VAL', AND 'LNGTH'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE INSYMBOL;
VAR SYMBOLGOTTEN: BOOLEAN; (*SYMBOL GOTTEN YET?*)
(* -------------------------------------------------------------------------
PROCEDURE NEXTCH
------------------------------------------------------------------------- *
)
PROCEDURE NEXTCH;
BEGIN (* NEXTCH *)
IF EOL THEN
BEGIN
IF LIST THEN WRITELINE;
IF ERRORS OR WARNINGS THEN PRINTERROR;
READLINE
END;
CHCNT := CHCNT + 1;
EOL := (CHCNT = LINELEN);
CH := LINEBUF (. CHCNT .)
END; (* NEXTCH *)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE OPTIONS *)
(* *)
(* THIS PROCEDURE PROCESSES THE OPTIONS IN A COMMENT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE OPTIONS;
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE COMMENTWARNING *)
(* *)
(* THIS PROCEDURE GENERATES A 511 WARNING IN AN OPTION *)
(* COMMENT. IT THEN SKIPS CHARACTERS UNTIL IT FINDS A *)
(* COMMA, ASTERISK, OR RIGHT CURLY BRACE. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE COMMENTWARNING;
BEGIN (*COMMENTWARNING*)
WARNING (511);
WHILE (CH <> ',') AND (CH <> '*') AND (CH <> 'å') DO
NEXTCH
END; (*COMMENTWARNING*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETARITHMETICSIZE *)
(* *)
(* THIS PROCEDURE GETS THE SIZE OF INTEGER ARITHMETIC. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETARITHMETICSIZE;
BEGIN (*GETARITHMETICSIZE*)
NEXTCH;
IF CH <> '='
THEN COMMENTWARNING
ELSE
BEGIN (*LOOK FOR A 1, 2, OR 4*)
NEXTCH;
IF CH = '1'
THEN BEGIN
ARITHMETICSIZE := 'H';
NEXTCH
END (*THEN*)
ELSE
IF CH = '2'
THEN BEGIN
ARITHMETICSIZE := 'I';
NEXTCH
END (*THEN*)
ELSE
IF CH = '4'
THEN BEGIN
ARITHMETICSIZE := 'J';
NEXTCH
END (*THEN*)
ELSE COMMENTWARNING
END (*ELSE*)
END; (*GETARITHMETICSIZE*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETPLUSORMINUS (PLUSFLAG,ERR) *)
(* *)
(* THIS PROCEDURE LOOKS FOR A PLUS OR MINUS SIGN IN THE NEXT *)
(* CHARACTER OF INPUT. IF A PLUS SIGN IS FOUND, PLUSFLAG IS *)
(* RETURNED TRUE. IF A MINUS SIGN IS FOUND, PLUSFLAG IS *)
(* RETURNED FALSE. IF NEITHER IS FOUND, ERR IS RETURNED TRUE. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETPLUSORMINUS (VAR PLUSFLAG,ERR: BOOLEAN);
BEGIN (*GETPLUSORMINUS*)
PLUSFLAG := FALSE;
ERR := FALSE;
NEXTCH;
IF CH = '+'
THEN BEGIN
PLUSFLAG := TRUE;
NEXTCH
END (*THEN*)
ELSE IF CH = '-'
THEN NEXTCH
ELSE BEGIN
ERR := TRUE;
COMMENTWARNING
END (*ELSE*)
END; (*GETPLUSORMINUS*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GET1PLUSORMINUS (FLAG) *)
(* *)
(* THIS PROCEDURE GETS A PLUS OR MINUS SIGN AND ASSIGNS THE *)
(* PROPER BOOLEAN VALUE TO 'FLAG'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GET1PLUSORMINUS (VAR FLAG: BOOLEAN);
VAR
PLUSFLAG,
ERR: BOOLEAN;
BEGIN (*GET1PLUSORMINUS*)
GETPLUSORMINUS (PLUSFLAG,ERR);
IF NOT ERR THEN FLAG := PLUSFLAG
END; (*GET1PLUSORMINUS*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GET2PLUSORMINUS (FLAG1,FLAG2) *)
(* *)
(* THIS PROCEDURE GETS A PLUS OR MINUS FLAG FOR AN OPTION *)
(* AND ASSIGNS THE PROPER BOOLEAN VALUE TO THE FLAGS 'FLAG1' *)
(* AND 'FLAG2'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GET2PLUSORMINUS (VAR FLAG1,FLAG2: BOOLEAN);
VAR
PLUSFLAG,
ERR: BOOLEAN;
BEGIN (*GET2PLUSORMINUS*)
GETPLUSORMINUS (PLUSFLAG,ERR);
IF NOT ERR THEN
BEGIN
FLAG1 := PLUSFLAG;
FLAG2 := PLUSFLAG
END (*THEN*)
END; (*GET2PLUSORMINUS*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETLINT (LVAL) *)
(* *)
(* THIS PROCEDURE GETS AN '=<LONG INT>' IN AN OPTION COMMENT *)
(* AND ASSIGNS IT TO 'LVAL'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETLINT (VAR LVAL: LNGINT);
BEGIN (*GETLINT*)
NEXTCH;
IF CH <> '='
THEN COMMENTWARNING
ELSE
BEGIN (*NOW LOOK FOR THE LINT*)
NEXTCH;
IF CHTAB(.CH.) <> NUMBER
THEN COMMENTWARNING
ELSE
BEGIN (*GET THE LINT*)
LONGONLY := TRUE;
INSYMBOL;
LONGONLY := FALSE;
IF SY <> INT4CONST
THEN COMMENTWARNING
ELSE LVAL := VAL.VALP@.LINTVAL
END (*ELSE*)
END (*ELSE*)
END; (*GETLINT*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETINT (IVAL) *)
(* *)
(* THIS PROCEDURE GETS AN '=<INTEGER>' IN AN OPTION COMMENT *)
(* AND ASSIGNS IT TO 'IVAL'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETINT (VAR IVAL: INTEGER);
BEGIN (*GETINT*)
NEXTCH;
IF CH <> '='
THEN COMMENTWARNING
ELSE
BEGIN
NEXTCH;
IF CHTAB(.CH.) <> NUMBER
THEN COMMENTWARNING
ELSE
BEGIN
INSYMBOL;
IF (SY <> INT1CONST) AND (SY <> INT2CONST)
THEN COMMENTWARNING
ELSE IVAL := VAL.IVAL
END (*ELSE*)
END (*ELSE*)
END; (*GETINT*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETMACHINETYPE *)
(* *)
(* THIS PROCEDURE GETS THE MACHINE TYPE FROM AN OPTION *)
(* COMMENT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETMACHINETYPE;
VAR
MACHINENUM: 1..2;
BEGIN (*GETMACHINETYPE*)
MACHINENUM := MACHINE;
NEXTCH;
IF CH = '2'
THEN BEGIN (*MAKE SURE 'M20'*)
NEXTCH;
IF CH <> '0'
THEN COMMENTWARNING
ELSE
BEGIN
NEXTCH;
MACHINENUM := M68000;
END;
END (*THEN*)
ELSE
IF CH <> '0' (*MAKE SURE 'M09'*)
THEN COMMENTWARNING
ELSE
BEGIN
NEXTCH;
IF CH <> '9'
THEN COMMENTWARNING
ELSE
BEGIN (*SET UP FOR THE 6809*)
NEXTCH;
MACHINENUM := M6809;
END (*ELSE*)
END (*ELSE*);
ADDRSIZE := 2 * MACHINENUM;
ALIGNMENT := MACHINENUM;
TEXTPTR@.SIZE := 2 * ADDRSIZE;
NILPTR@.SIZE := ADDRSIZE;
END; (*GETMACHINETYPE*)
(*$E------------------------------------------------------------------*)
(* *)
(* OPTIONS STARTS HERE *)
(* *)
(*--------------------------------------------------------------------*)
BEGIN (*OPTIONS*)
REPEAT (*FOR EACH OPTION*)
NEXTCH; (*GET THE... *)
CH := UPPER(.CH.); (*NEXT CHARACTER.*)
IF CH = 'A' THEN GETARITHMETICSIZE
ELSE IF CH = 'C' THEN GET1PLUSORMINUS (PRCODE)
ELSE IF CH = 'D' THEN GET2PLUSORMINUS (DEBUG,KOUNTERS)
ELSE IF CH = 'E' THEN
BEGIN
IF LIST THEN NEWPAGE;
NEXTCH
END (*THEN*)
ELSE IF CH = 'H' THEN GETLINT (HEAPSTART)
ELSE IF CH = 'J' THEN GETLINT (JUMPBASE)
ELSE IF CH = 'K' THEN GET1PLUSORMINUS (KOUNTERS)
ELSE IF CH = 'L' THEN
BEGIN
GET1PLUSORMINUS (LIST);
IF NOT LIST THEN
BEGIN
WRITELN (LISTING,' ');
PAGEPOS := PAGEPOS + 1
END (*THEN*)
END (*THEN*)
ELSE IF CH = 'M' THEN GETMACHINETYPE
ELSE IF CH = 'O' THEN GET1PLUSORMINUS (PLIST)
ELSE IF CH = 'P' THEN GET1PLUSORMINUS (PKOUNTERS)
ELSE IF CH = 'R' THEN GET1PLUSORMINUS (DEBUG)
ELSE IF CH = 'T' THEN GETLINT (STACKSTART)
ELSE IF CH = 'W' THEN GET1PLUSORMINUS (STANDARD)
ELSE IF CH = 'X' THEN GETINT (JUMPENTRIES)
UNTIL CH <> ','
END; (*OPTIONS*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETIDENTIFIER *)
(* *)
(* THIS PROCEDURE GETS AN IDENTIFIER FROM THE SOURCE INPUT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETIDENTIFIER;
VAR
I,J: INTEGER;
FOUND: BOOLEAN;
LASTRW: INTEGER;
BEGIN
J := 1;
ID := BLANKID;
(*GET THE IDENTIFIER*)
REPEAT
IF J <= IDLNGTH THEN
BEGIN (*SAVE THE CURRENT CHARACTER*)
ID(.J.) := UPPER(.CH.);
J := J + 1
END; (*THEN*)
NEXTCH (*GET THE NEXT CHARACTER*)
UNTIL (CHTAB(.CH.) <> ATOZ) AND (CHTAB(.CH.) <> NUMBER);
(*NOW SEE IF THIS IDENTIFIER IS A RESERVED WORD*)
I := FRW(.J - 1.);
LASTRW := FRW(.J.) - 1;
FOUND := FALSE;
WHILE NOT FOUND AND (I <= LASTRW) DO
IF RW(.I.) = ID
THEN FOUND := TRUE
ELSE I := I + 1;
IF FOUND
THEN BEGIN (*IS A RESERVED WORD - SET UP SYMBOL AND OPERATOR
*) SY := RSY(.I.);
OP := ROP(.I.)
END (*THEN*)
ELSE BEGIN (*ISN'T A RESERVED WORD - SHOW IT IS AN IDENTIFIE
R*) SY := IDENT;
OP := NOOP
END (*ELSE*)
END; (*GETIDENTIFIER*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETNUMBER *)
(* *)
(* THIS PROCEDURE GETS A CONSTANT NUMBER FROM THE SOURCE *)
(* INPUT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETNUMBER;
CONST
HEXOK = TRUE; (*HEX DIGITS OK IN NUMBER*)
HEXNOTOK = FALSE; (*HEX DIGITS ARE NOT OK IN NUMBER*)
TYPE
DIGITSTR = PACKED ARRAY (.1..35.) OF CHAR; (*DIGITS IN A NUMBER*)
VAR
REAL: BOOLEAN; (*IS THIS A REAL NUMBER?*)
I: INTEGER;
DIGITS: DIGITSTR; (*DIGITS IN THE NUMBER*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE STORECHAR (CH,INDEX,DIGITS) *)
(* *)
(* THIS PROCEDURE STORES THE CHARACTER 'CH' IN THE DIGIT *)
(* STRING 'DIGITS' AT THE POSITION AFTER 'INDEX'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE STORECHAR (CH: CHAR; VAR INDEX: INTEGER; VAR DIGITS: DIGITSTR);
BEGIN (*STORECHAR*)
INDEX := INDEX + 1;
IF INDEX <= DIGMAX THEN (*SAVE THIS CHARACTER*)
DIGITS(.INDEX.) := CH;
END; (*STORECHAR*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETDIGITS (HEXOK,INDEX,DIGITS) *)
(* *)
(* THIS PROCEDURE GETS A STRING OF DIGITS FROM THE SOURCE *)
(* INPUT. IF 'HEXOK' IS TRUE, HEX DIGITS WILL BE ALLOWED. *)
(* THE DIGITS WILL BE STORED IN THE DIGIT STRING 'DIGITS' *)
(* STARTING AT THE POSITION AFTER 'INDEX'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETDIGITS (HEXOK: BOOLEAN; VAR INDEX: INTEGER;
VAR DIGITS: DIGITSTR);
VAR CHT: CHTYP;
BEGIN (*GETDIGITS*)
REPEAT
STORECHAR (UPPER(.CH.),INDEX,DIGITS); (*STORE CURRENT CHARACTER*
) NEXTCH; (*GET THE NEXT CHARACTER*)
CHT := CHTAB(.CH.)
UNTIL (HEXOK AND (CHT <> NUMBER) AND (CHT <> ATOZ))
OR (NOT HEXOK AND (CHT <> NUMBER))
END; (*GETDIGITS*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE MAKEINT (LEN,DIGITS) *)
(* *)
(* THIS PROCEDURE MAKES AN INTEGER OUT OF THE FIRST 'LEN' *)
(* DIGITS IN THE DIGIT STRING 'DIGITS'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE MAKEINT (LEN: INTEGER; VAR DIGITS: DIGITSTR);
VAR
DIGITCH: CHAR; (*CURRENT CHARACTER CONSIDERING*)
RADIX: 0..99; (*RADIX OF NUMBER BUILDING*)
DIGIT: 0..15; (*VALUE OF CURRENT DIGIT*)
ZERO: INTEGER; (*ORD OF CHARACTER '0'*)
A: INTEGER;
LONGVAL: LNGINT; (*THE LONG VALUE OF THE INTEGER*)
I: INTEGER;
OVRFLW1,
OVRFLW2: BOOLEAN; (*OVERFLOW FLAGS*)
BEGIN (*MAKEINT*)
ZERO := ORD('0');
A := ORD('A');
LONGVAL := LONGZERO;
IF CH <> '#'
THEN RADIX := 10 (*USE DEFAULT RADIX*)
ELSE
BEGIN (*USER SUPPLIED RADIX - USE IT*)
IF STANDARD THEN WARNING(500);
IF LEN = 1
THEN RADIX := ORD(DIGITS(.1.)) - ZERO
ELSE
IF LEN = 2
THEN RADIX := (ORD(DIGITS(.1.)) - ZERO) * 10
+ (ORD(DIGITS(.2.)) - ZERO)
ELSE RADIX := 0; (*FORCE AN ERROR*)
IF (RADIX > 16) OR (RADIX < 2) THEN
BEGIN (*BAD RADIX - LET HIM KNOW*)
ERROR (400);
RADIX := 10
END; (*THEN*)
(*GET DIGITS AFTER RADIX CHARACTER '#'*)
NEXTCH;
LEN := 0;
IF (CHTAB(.CH.) <> NUMBER) AND (CHTAB(.CH.) <> ATOZ)
THEN ERROR (401)
ELSE GETDIGITS (HEXOK,LEN,DIGITS)
END; (*ELSE*)
IF LEN > DIGMAX
THEN BEGIN (*NUMBER IS TOO LONG*)
ERROR (203);
SY := INT2CONST;
VAL.IVAL := 0
END (*THEN*)
ELSE
BEGIN (*MAKE THE INTEGER*)
FOR I := 1 TO LEN DO
BEGIN (*PROCESS A DIGIT*)
DIGITCH := DIGITS(.I.);
IF (DIGITCH >= '0') AND (DIGITCH <= '9')
THEN DIGIT := ORD(DIGITCH) - ZERO
ELSE IF (DIGITCH >= 'A') AND (DIGITCH <= 'F')
THEN DIGIT := ORD(DIGITCH) - A + 10
ELSE BEGIN (*ILLEGAL DIGIT*)
ERROR (402);
DIGIT := 0
END; (*ELSE*)
IF DIGIT >= RADIX
THEN ERROR (402) (*ILLEGAL DIGIT*)
ELSE BEGIN (*ADD DIGIT TO CURRENT NUMBER*)
MULTLONG (LONGVAL,RADIX,OVRFLW1);
ADDLONG (LONGVAL,DIGIT,OVRFLW2);
IF OVRFLW1 OR OVRFLW2 THEN
BEGIN (*NUMBER TOO BIG*)
ERROR (203);
LONGVAL := LONGZERO
END (*THEN*)
END; (*ELSE*)
END; (*FOR*)
WITH CNSTVALPTR@ DO
BEGIN (*NOW SET UP THE CONSTANT*)
IF (LONGVAL(.4.) = 0) AND (LONGVAL(.3.) = 0)
AND (LONGVAL(.2.) <= 127) AND (NOT LONGONLY)
THEN BEGIN (*MAKE A REGULAR INTEGER*)
VAL.IVAL := LONGVAL(.2.) * 256 + LONGVAL(.1
.); IF VAL.IVAL <= 127
THEN SY := INT1CONST
ELSE SY := INT2CONST
END (*THEN*)
ELSE BEGIN (*SET UP A LONG INTEGER*)
SY := INT4CONST;
LINTVAL := LONGVAL;
VAL.VALP := CNSTVALPTR
END (*ELSE*)
END (*WITH*)
END (*ELSE*)
END; (*MAKEINT*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE MAKEREAL (LEN,DIGITS) *)
(* *)
(* THIS PROCEDURE CONSTRUCTS A REAL NUMBER OUT OF THE FIRST *)
(* 'LEN' DIGITS IN THE DIGIT STRINT 'DIGITS'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE MAKEREAL (LEN: INTEGER; VAR DIGITS: DIGITSTR);
VAR I: INTEGER;
BEGIN (*MAKEREAL*)
ERROR (398); (*UNTIL REALS ARE REAL*)
SY := REALCONST; (*SET UP SYMBOL TYPE*)
WITH CNSTVALPTR@ DO
BEGIN (*BUILD THE REAL NUMBER*)
FOR I := 1 TO REALLNGTH DO
RVAL(.I.) := ' ';
IF LEN > REALLNGTH
THEN BEGIN (*REAL IS TOO LONG*)
ERROR (203);
RVAL(.1.) := '0';
RVAL(.2.) := '.';
RVAL(.3.) := '0'
END (*THEN*)
ELSE FOR I := 1 TO LEN DO
RVAL(.I.) := DIGITS(.I.)
END; (*WITH*)
VAL.VALP := CNSTVALPTR
END; (*MAKEREAL*)
(*$E------------------------------------------------------------------*)
(* *)
(* GETNUMBER STARTS HERE *)
(* *)
(*--------------------------------------------------------------------*)
BEGIN (*GETNUMBER*)
OP := NOOP;
I := 0;
REAL := FALSE;
GETDIGITS (HEXNOTOK,I,DIGITS); (*GET STRING OF DIGITS*)
IF CH = '.' THEN
BEGIN (*POSSIBLY HAVE A REAL NUMBER*)
NEXTCH;
IF CH = '.'
THEN BEGIN (*NOPE - HAVE A '..'*)
DOUBLECHAR := TRUE;
DOUBLESYM := RANGE
END (*THEN*)
ELSE
IF CH = ')'
THEN BEGIN (*NOPE - HAVE A '.)'*)
DOUBLECHAR := TRUE;
DOUBLESYM := RBRACK
END (*THEN*)
ELSE
IF CHTAB(.CH.) <> NUMBER
THEN ERROR (201) (*ILLEGAL CHAR AFTER '.'*)
ELSE BEGIN (*HAVE A REAL # - GET THE RES
T*) STORECHAR ('.',I,DIGITS);
GETDIGITS (HEXNOTOK,I,DIGITS);
REAL := TRUE
END (*ELSE*)
END; (*THEN*)
IF UPPER(.CH.) = 'E' THEN
BEGIN (*HAVE AN EXPONENT - GET IT*)
REAL := TRUE;
STORECHAR ('E',I,DIGITS);
NEXTCH;
IF (CH = '+') OR (CH = '-') THEN
BEGIN (*SAVE THE SIGN*)
STORECHAR (CH,I,DIGITS);
NEXTCH
END; (*THEN*)
IF CHTAB(.CH.) <> NUMBER
THEN ERROR (201) (*HAVE TO HAVE AT LEAST ONE DIGIT*)
ELSE GETDIGITS (HEXNOTOK,I,DIGITS)
END; (*THEN*)
IF REAL
THEN MAKEREAL (I,DIGITS) (*MAKE A REAL NUMBER*)
ELSE MAKEINT (I,DIGITS) (*MAKE AN INTEGER*)
END; (*GETNUMBER*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETSTRING *)
(* *)
(* THIS PROCEDURE GETS A CONSTANT STRING FROM THE SOURCE *)
(* INPUT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETSTRING;
BEGIN (*GETSTRING*)
LNGTH := 0;
SY := STRINGCONST;
OP := NOOP;
WITH CNSTVALPTR@ DO
BEGIN (*SET UP THE CONSTANT*)
SVAL := CNSTSTRPTR;
REPEAT
REPEAT
NEXTCH; (*GET THE NEXT CHARACTER*)
LNGTH := LNGTH + 1;
IF LNGTH <= STRGLNGTH THEN
SVAL@(.LNGTH.) := CH (*SAVE THE CHARACTER*)
UNTIL (EOL) OR (CH = '''');
IF EOL
THEN ERROR (202) (*END OF LINE IN MIDDLE OF STR*
) ELSE NEXTCH (*GET NEXT CHARACTER*)
UNTIL CH <> ''''; (*TO CHECK FOR DOUBLE QUOTES*)
LNGTH := LNGTH - 1;
IF LNGTH = 1
THEN VAL.IVAL := ORD(SVAL@(.1.)) (*HAVE A SINGLE CHARACTER
*) ELSE
BEGIN (*CHECK ON LENGTH OF STRING*)
IF LNGTH > STRGLNGTH THEN
BEGIN (*STRING IS TOO LONG*)
ERROR (398);
LNGTH := STRGLNGTH
END; (*THEN*)
VAL.VALP := CNSTVALPTR;
SLNGTH := LNGTH
END (*ELSE*)
END (*WITH*)
END; (*GETSTRING*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETCOLONORBECOMES *)
(* *)
(* THIS PROCEDURE GETS A SINGLE COLON OR A BECOMES SYMBOL. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETCOLONORBECOMES;
BEGIN (*GETCOLONORBECOMES*)
OP := NOOP;
NEXTCH; (*LOOK AT NEXT CHARACTER*)
IF CH = '='
THEN BEGIN (*HAVE A BECOMES (':=')*)
SY := BECOMES;
NEXTCH
END (*THEN*)
ELSE SY := COLON
END; (*GETCOLONORBECOMES*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETPERIODBRACKETORRANGE *)
(* *)
(* THIS PROCEDURE GETS A PERIOD, A RIGHT BRACKET, OR A *)
(* RANGE SYMBOL. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETPERIODBRACKETORRANGE;
BEGIN (*GETPERIODBRACKETORRANGE*)
OP := NOOP;
NEXTCH; (*LOOK AT NEXT CHARACTER*)
IF CH = '.'
THEN BEGIN (*HAVE A RANGE*)
SY := RANGE;
NEXTCH
END (*THEN*)
ELSE IF CH = ')'
THEN BEGIN (*HAVE A RIGHT BRACKET*)
SY := RBRACK;
NEXTCH
END (*THEN*)
ELSE SY := PERIOD (*JUST A PERIOD*)
END; (*GETPERIODBRACKETORRANGE*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETLESSLESSEQUALORNOTEQUAL *)
(* *)
(* THIS PROCEDURE GETS A LESS THAN, A LESS THAN OR EQUAL, OR *)
(* A NOT EQUAL SYMBOL. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETLESSLESSEQUALORNOTEQUAL;
BEGIN (*GETLESSLESSEQUALORNOTEQUAL*)
SY := RELOP;
NEXTCH; (*LOOK AT NEXT CHARACTER*)
IF CH = '='
THEN BEGIN (*LESS THAN OR EQUAL*)
OP := LEOP;
NEXTCH
END (*THEN*)
ELSE IF CH = '>'
THEN BEGIN (*NOT EQUAL*)
OP := NEOP;
NEXTCH
END (*THEN*)
ELSE OP := LTOP (*JUST A LESS THAN*)
END; (*GETLESSLESSEQUALORNOTEQUAL*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETGREATERORGREATEREQUAL *)
(* *)
(* THIS PROCEDURE GETS A GREATER THAN OR A GREATER THAN OR *)
(* EQUAL SYMBOL. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETGREATERORGREATEREQUAL;
BEGIN (*GETGREATERORGREATEREQUAL*)
SY := RELOP;
NEXTCH;
IF CH = '='
THEN BEGIN (*GREATER THAN OR EQUAL*)
OP := GEOP;
NEXTCH
END (*THEN*)
ELSE OP := GTOP (*JUST A GREATER THAN*)
END; (*GETGREATERORGREATEREQUAL*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETMISCCHAR *)
(* *)
(* THIS PROCEDURE HANDLES A MISCELLANEOUS CHARACTER. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETMISCCHAR;
BEGIN (*GETMISCCHAR*)
SY := SSY(.CH.);
OP := SOP(.CH.);
NEXTCH
END; (*GETMISCCHAR*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE SKIPILLEGALCHAR (SYMBOLGOTTEN) *)
(* *)
(* THIS PROCEDURE SKIPS OVER AN ILLEGAL CHARACTER, AFTER *)
(* GENERATING AN ERROR FOR THAT CHARACTER. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE SKIPILLEGALCHAR (VAR SYMBOLGOTTEN: BOOLEAN);
BEGIN (*SKIPILLEGALCHAR*)
SY := OTHERSY;
OP := NOOP;
ERROR (398);
NEXTCH;
SYMBOLGOTTEN := FALSE
END; (*SKIPILLEGALCHAR*)
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETPARNCOMMENTORBRACKET (SYMBOLGOTTEN) *)
(* *)
(* THIS PROCEDURE GETS A LEFT PAREN, A COMMENT, OR A *)
(* LEFT BRACKET. 'SYMBOLGOTTEN' IS RETURNED TRUE IF A *)
(* SYMBOL OTHER THAN A COMMENT WAS FOUND. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETPARNCOMMENTORBRACKET (VAR SYMBOLGOTTEN: BOOLEAN);
BEGIN (*GETPARNCOMMENTORBRACKET*)
NEXTCH; (*TAKE A LOOK AT THE NEXT CHAR*)
IF CH = '*'
THEN BEGIN (*THIS IS A COMMENT*)
NEXTCH;
IF CH = '$' THEN OPTIONS; (*PROCESS OPTION COMMENT*)
REPEAT (*FIND END OF COMMENT*)
WHILE CH <> '*' DO
BEGIN
IF CH = '(' THEN
BEGIN (*CHECK FOR NESTED COMMENT*)
NEXTCH;
IF CH = '*' THEN WARNING (503)
END; (*THEN*)
NEXTCH
END; (*WHILE*)
NEXTCH
UNTIL CH = ')';
NEXTCH;
SYMBOLGOTTEN := FALSE
END (*THEN*)
ELSE IF CH = '.'
THEN BEGIN (*HAVE A LEFT BRACKET*)
SY := LBRACK;
OP := NOOP;
NEXTCH
END (*THEN*)
ELSE BEGIN (*JUST A LEFT PAREN*)
SY := LPARENT;
OP := NOOP
END (*ELSE*)
END; (*GETPARNCOMMENTORBRACKET*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE GETCOMMENT *)
(* *)
(* THIS PROCEDURE GETS A COMMENT THAT WAS STARTED BY A LEFT *)
(* CURLY BRACKET. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE GETCOMMENT (VAR SYMBOLGOTTEN: BOOLEAN);
BEGIN (*GETCOMMENT*)
NEXTCH;
IF CH = '$' THEN OPTIONS; (*PROCESS AN OPTION COMMENT*)
WHILE CH <> 'å' DO (*FIND THE END OF THE COMMENT*)
BEGIN
NEXTCH;
IF CH = 'æ' THEN WARNING (503)
END; (*WHILE*)
NEXTCH;
SYMBOLGOTTEN := FALSE
END; (*GETCOMMENT*)
(*$E------------------------------------------------------------------*)
(* *)
(* INSYMBOL STARTS HERE *)
(* *)
(*--------------------------------------------------------------------*)
BEGIN (*INSYMBOL*)
REPEAT
SYMBOLGOTTEN := TRUE;
IF DOUBLECHAR
THEN BEGIN (*HAVE DOUBLE CHAR LEFT OVER FROM NUM
*) DOUBLECHAR := FALSE;
SY := DOUBLESYM;
OP := NOOP;
NEXTCH
END (*THEN*)
ELSE BEGIN (*HAVE TO GET A SYMBOL*)
(*FIRST SKIP BLANKS*)
WHILE CHTAB(.CH.) = BLANKCHAR DO NEXTCH;
(*NOW XFER CONTROL BASED ON CURRENT CHARACTER*)
CASE CHTAB(.CH.) OF
ATOZ: GETIDENTIFIER;
NUMBER: GETNUMBER;
STRQUOTE: GETSTRING;
COLONCHAR: GETCOLONORBECOMES;
PERIODCHAR: GETPERIODBRACKETORRANGE;
LPOINTY: GETLESSLESSEQUALORNOTEQUAL;
RPOINTY: GETGREATERORGREATEREQUAL;
MISCCHAR: GETMISCCHAR;
ILLEGALCHAR: SKIPILLEGALCHAR (SYMBOLGOTTEN);
LPARN: GETPARNCOMMENTORBRACKET (SYMBOLGOTTEN);
CMNTBRACK: GETCOMMENT (SYMBOLGOTTEN)
END (*CASE*)
END (*ELSE*)
UNTIL SYMBOLGOTTEN
END; (*INSYMBOL*)
(*$E------------------------------------------------------------------*)
(* *)
(* FUNCTION INTTYPE (TYPTR): BOOLEAN *)
(* *)
(* THIS FUNCTION DETERMINES IF THE TYPE POINTED TO BY 'TYPTR' *)
(* IS AN INTEGER (SHORT, MEDIUM, OR TALL). *)
(* *)
(*--------------------------------------------------------------------*)
FUNCTION INTTYPE (TYPTR: STP): BOOLEAN;
BEGIN (*INTTYPE*)
INTTYPE := (TYPTR = INT1PTR) OR (TYPTR = INT2PTR) OR (TYPTR = INT4PTR)
END; (*INTTYPE*)
(* -------------------------------------------------------------------------
PROCEDURE ENTERID
------------------------------------------------------------------------- *
)
PROCEDURE ENTERID(FCP: CTP);
(* ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE *)
VAR NAM: ALPHA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
BEGIN NAM := FCP@.NAME;
LCP := DISPLAY(.TOP.).FNAME;
IF LCP = NIL THEN
DISPLAY(.TOP.).FNAME := FCP
ELSE
BEGIN
REPEAT LCP1 := LCP;
IF LCP@.NAME = NAM THEN (* NAME CONFLICT, FOLLOW RIGHT LINK *)
BEGIN ERROR(101); LCP := LCP@.RLINK; LLEFT := FALSE END
ELSE
IF LCP@.NAME < NAM THEN
BEGIN LCP := LCP@.RLINK; LLEFT := FALSE END
ELSE BEGIN LCP := LCP@.LLINK; LLEFT := TRUE END
UNTIL LCP = NIL;
IF LLEFT THEN LCP1@.LLINK := FCP ELSE LCP1@.RLINK := FCP
END;
FCP@.LLINK := NIL; FCP@.RLINK := NIL
END (* ENTERID *) ;
(* -------------------------------------------------------------------------
PROCEDURE SEARCHSECTION
------------------------------------------------------------------------- *
)
PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
(* TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR *)
VAR DONE: BOOLEAN;
BEGIN
DONE := FALSE;
WHILE (FCP <> NIL) AND NOT DONE DO
IF FCP@.NAME = ID THEN DONE := TRUE
ELSE IF FCP@.NAME < ID THEN FCP := FCP@.RLINK
ELSE FCP := FCP@.LLINK;
FCP1 := FCP
END (* SEARCHSECTION *) ;
(* -------------------------------------------------------------------------
PROCEDURE SEARCHID
------------------------------------------------------------------------- *
)
PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
VAR LCP: CTP;
FOUND: BOOLEAN;
BEGIN
FOUND := FALSE;
DISX := TOP + 1;
WHILE NOT FOUND AND (DISX > 0) DO
BEGIN DISX := DISX - 1;
LCP := DISPLAY(.DISX.).FNAME;
WHILE NOT FOUND AND (LCP <> NIL) DO
IF LCP@.NAME = ID THEN
IF LCP@.KLASS IN FIDCLS THEN FOUND := TRUE
ELSE
BEGIN IF PRTERR THEN ERROR(103);
LCP := LCP@.RLINK
END
ELSE
IF LCP@.NAME < ID THEN
LCP := LCP@.RLINK
ELSE LCP := LCP@.LLINK;
END;
(*IF SEARCH NOT SUCCESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE *)
IF NOT FOUND AND PRTERR THEN
BEGIN ERROR(104);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL *)
IF TYPES IN FIDCLS THEN LCP := UTYPPTR
ELSE
IF VARS IN FIDCLS THEN LCP := UVARPTR
ELSE
IF FIELD IN FIDCLS THEN LCP := UFLDPTR
ELSE
IF KONST IN FIDCLS THEN LCP := UCSTPTR
ELSE
IF PROC IN FIDCLS THEN LCP := UPRCPTR
ELSE
IF LABELS IN FIDCLS THEN LCP := ULABPTR
ELSE LCP := UFCTPTR;
END;
FCP := LCP
END (* SEARCHID *) ;
(* -------------------------------------------------------------------------
PROCEDURE GETBOUNDS
------------------------------------------------------------------------- *
)
PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: LNGINT);
(* GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE *)
(* ASSUME (FSP <> NIL) AND (FSP@.FORM <= SUBRANGE)
AND NOT COMPTYPES(REALPTR,FSP) *)
BEGIN
WITH FSP@ DO
IF FORM = SUBRANGE THEN
BEGIN
IF RANGETYPE = CHARPTR THEN
BEGIN
MAKELONG (ASCII(.CHR(MIN.IVAL).),FMIN);
MAKELONG (ASCII(.CHR(MAX.IVAL).),FMAX)
END
ELSE
IF RANGETYPE = INT4PTR
THEN BEGIN
FMIN := MIN.VALP@.LINTVAL;
FMAX := MAX.VALP@.LINTVAL
END (*THEN*)
ELSE BEGIN
MAKELONG (MIN.IVAL,FMIN);
MAKELONG (MAX.IVAL,FMAX)
END (*ELSE*)
END
ELSE
BEGIN FMIN := LONGZERO;
IF FSP = CHARPTR THEN FMAX := LONGORDMAXCHAR
ELSE IF FSP = INT1PTR THEN
BEGIN
FMIN := LINT1MIN;
FMAX := LINT1MAX
END (*THEN*)
ELSE IF FSP = INT2PTR THEN
BEGIN
FMIN := LINT2MIN;
FMAX := LINT2MAX
END (*THEN*)
ELSE IF FSP = INT4PTR THEN
BEGIN
FMIN := LINT4MIN;
FMAX := LINT4MAX
END (*THEN*)
ELSE
IF (FORM = SCALAR) AND ((* FSP@. *)FCONST <> NIL) THEN
MAKELONG (FSP@.FCONST@.VALUES.IVAL,FMAX)
ELSE FMAX := LONGZERO
END
END (* GETBOUNDS *) ;
(* -------------------------------------------------------------------------
PROCEDURE GENLABEL
------------------------------------------------------------------------- *
)
PROCEDURE GENLABEL(VAR NXTLAB: LABELRNG);
BEGIN INTLABEL := INTLABEL + 1;
NXTLAB := INTLABEL
END (* GENLABEL *);
(* -------------------------------------------------------------------------
PROCEDURE GENLI (USED TO BE INSIDE "BODY" NEAR OTHER "GEN.."S)
------------------------------------------------------------------------- *
)
PROCEDURE GENLI (FOP:MNRANGE; LEVEL:LEVRANGE; OPERAND:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, LEVEL:3, ' ', OPERAND);
IC := IC + 1
END (*THEN*)
END; (*GENLI*)
PROCEDURE GENDEF1(L1: LABELRNG; LNAME:ALPHA ) ;
BEGIN
IF PRCODE THEN
WRITELN(PCODE,'$', L1:3,MN(.17(* DEF *).):5,
'''',LNAME:IDLNGTH,'''');
END (* GENDEF1 *) ;
(* -------------------------------------------------------------------------
PROCEDURE BLOCK
------------------------------------------------------------------------- *
)
PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP);
TYPE FWDREC = RECORD PF:CTP; NEXTPF:@FWDREC END;
VAR LSY: SYMBOL; TEST: BOOLEAN;
LOOPLISTPTR: LOOPPTR;
FWDLIST,KFWD: @FWDREC;
LOCFILELIST: CTP;
PARMLEN: INTEGER ;
(* -------------------------------------------------------------------------
PROCEDURE SKIP
------------------------------------------------------------------------- *
)
PROCEDURE SKIP(FSYS: SETOFSYS);
(* SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND *)
BEGIN
WHILE NOT(SY IN FSYS) DO INSYMBOL
END (* SKIP *) ;
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE NEGICONST (LSP,IVAL,LVAL) *)
(* *)
(* THIS PROCEDURE NEGATES THE INTEGER CONSTANT WHOSE STP IS *)
(* 'LSP' AND VALUE IS 'IVAL' OR 'LVAL'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE NEGICONST (VAR LSP: STP; VAR IVAL: INTEGER; VAR LVAL: LNGINT);
BEGIN (*NEGICONST*)
IF LSP = INT1PTR
THEN
BEGIN (*NEGATE A 1-BYTE VALUE*)
IVAL := -IVAL;
IF IVAL = 128 THEN LSP := INT2PTR
END (*THEN*)
ELSE
IF LSP = INT2PTR
THEN
BEGIN (*NEGATE A 2-BYTE VALUE*)
IF IVAL + 1 = -32767
THEN
BEGIN (*MAKE A LONG VALUE*)
LVAL := LONGZERO;
LVAL(.2.) := 128;
LSP := INT4PTR
END (*THEN*)
ELSE
BEGIN
IVAL := -IVAL;
IF IVAL = -128 THEN LSP := INT1PTR
END (*ELSE*)
END (*THEN*)
ELSE (*NEGATE A 4-BYTE VALUE*)
IF (LVAL(.4.) = 0) AND (LVAL(.3.) = 0)
AND (LVAL(.2.) = 128) AND (LVAL(.1.) = 0)
THEN
BEGIN (*MAKE IT A 2-BYTE VALUE*)
IVAL := -32767;
IVAL := IVAL - 1;
LSP := INT2PTR
END (*THEN*)
ELSE NEGLONG (LVAL)
END; (*NEGICONST*)
(* -------------------------------------------------------------------------
PROCEDURE CONSTANT
------------------------------------------------------------------------- *
)
PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
LVP: CSP; I: 0..REALLNGTH;
INTVAL: INTEGER;
LNGVAL: LNGINT;
BEGIN LSP := NIL; FVALU.IVAL := 0;
IF NOT(SY IN CONSTBEGSYS) THEN
BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END;
IF SY IN CONSTBEGSYS THEN
BEGIN
IF SY = STRINGCONST THEN
BEGIN
IF LNGTH = 1 THEN LSP := CHARPTR
ELSE
BEGIN
NEW(LSP,STRINGS);
WITH LSP@ DO
BEGIN
IF ODD(LNGTH) AND (ALIGNMENT = 2) THEN
LNGTH := LNGTH + 1;
SIZE := LNGTH+ALIGNMENT; FORM := STRINGS;
END ;
LVP := VAL.VALP ;
NEW(VAL.VALP, STRG) ;
VAL.VALP@.SLNGTH := LVP@.SLNGTH ;
VAL.VALP@.SVAL := LVP@.SVAL ;(* COPY STRING CONST TO HEAP *
) END;
FVALU(* .VALP *) := VAL(* .VALP *) ; INSYMBOL;
END
ELSE
BEGIN
SIGN := NONE;
IF (SY = ADDOP) AND (OP IN (.PLUS,MINUS.)) THEN
BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG;
INSYMBOL
END;
IF SY = IDENT THEN
BEGIN SEARCHID((.KONST.),LCP);
WITH LCP@ DO
BEGIN LSP := IDTYPE; FVALU := VALUES END;
IF SIGN <> NONE THEN
IF INTTYPE(LSP) THEN
BEGIN
IF SIGN = NEG THEN
BEGIN (*NEGATE AN INTEGER CONST*)
INTVAL := FVALU.IVAL;
IF LSP = INT4PTR THEN
LNGVAL := FVALU.VALP@.LINTVAL;
NEGICONST (LSP,INTVAL,LNGVAL);
IF (LSP = INT1PTR) OR (LSP = INT2PTR)
THEN FVALU.IVAL := INTVAL
ELSE BEGIN (*MAKE A LONG*)
NEW (LVP,LINT);
LVP@.LINTVAL := LNGVAL;
FVALU.VALP := LVP
END (*ELSE*)
END (*THEN*)
END (*THEN*)
ELSE
IF LSP = REALPTR THEN
BEGIN
IF SIGN = NEG THEN
BEGIN NEW(LVP,REEL);
IF FVALU.VALP@.RVAL(.0.) = '-' THEN
LVP@.RVAL(.0.) := '+'
ELSE LVP@.RVAL(.0.) := '-';
FOR I := 1 TO REALLNGTH DO
LVP@.RVAL(.I.) := FVALU.VALP@.RVAL(.I.);
FVALU.VALP := LVP;
END
END
ELSE ERROR(105);
INSYMBOL;
END
ELSE
IF (SY = INT1CONST) OR (SY = INT2CONST) OR (SY = INT4CONST) T
HEN BEGIN
INTVAL := VAL.IVAL;
IF SY = INT1CONST
THEN LSP := INT1PTR
ELSE
IF SY = INT2CONST
THEN LSP := INT2PTR
ELSE
BEGIN
LSP := INT4PTR;
LNGVAL := VAL.VALP@.LINTVAL
END; (*ELSE*)
IF SIGN = NEG THEN NEGICONST (LSP,INTVAL,LNGVAL);
IF (LSP = INT1PTR) OR (LSP = INT2PTR)
THEN FVALU.IVAL := INTVAL
ELSE BEGIN
NEW (LVP,LINT);
LVP@.LINTVAL := LNGVAL;
FVALU.VALP := LVP
END; (*ELSE*)
INSYMBOL
END (*THEN*)
ELSE
IF SY = REALCONST THEN
BEGIN
WITH VAL.VALP@ DO
IF SIGN = NEG THEN RVAL(.0.) := '-'
ELSE RVAL(.0.) := '+' ;
NEW(LVP, REEL) ;
LVP@.RVAL := VAL.VALP@.RVAL ;
LSP := REALPTR; FVALU.VALP := LVP; INSYMBOL
END
ELSE
BEGIN ERROR(106); SKIP(FSYS) END
END;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END;
FSP := LSP;
END (* CONSTANT *) ;
(*$E------------------------------------------------------------------*)
(* *)
(* FUNCTION COMPTYPES *)
(* *)
(* FUNCTION COMPTYPES CHECKS TO SEE IF THE TYPES DESCRIBED BY *)
(* THE POINTERS FSP1, AND FSP2 ARE ASSIGNMENT COMPATIBLE. *)
(*--------------------------------------------------------------------*)
FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
(*DECIDE WHETHER STRUCTURES PTED AT BY FSP1 & FSP2 ARE COMPATIBLE *)
VAR NXT1,NXT2: CTP; COMP: BOOLEAN;
LTESTP1,LTESTP2 : TESTP;
BEGIN
IF FSP1 = FSP2 THEN COMPTYPES := TRUE
ELSE
IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN
IF FSP1@.FORM = FSP2@.FORM THEN
CASE FSP1@.FORM OF
SCALAR:
COMPTYPES := INTTYPE (FSP1) AND INTTYPE (FSP2);
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE UNLESS THE ARE BOTH
INTEGER TYPES (LONG REG, OR SHORT) *)
SUBRANGE:
COMPTYPES := COMPTYPES(FSP1@.RANGETYPE,FSP2@.RANGETYPE);
POINTER:
BEGIN
COMP := FALSE; LTESTP1 := GLOBTESTP;
LTESTP2 := GLOBTESTP;
WHILE LTESTP1 <> NIL DO
WITH LTESTP1@ DO
BEGIN
IF (ELT1 = FSP1@.ELTYPE) AND
(ELT2 = FSP2@.ELTYPE) THEN COMP := TRUE;
LTESTP1 := LASTTESTP
END;
IF NOT COMP THEN
BEGIN NEW(LTESTP1);
WITH LTESTP1@ DO
BEGIN ELT1 := FSP1@.ELTYPE;
ELT2 := FSP2@.ELTYPE;
LASTTESTP := GLOBTESTP
END;
GLOBTESTP := LTESTP1;
COMP := COMPTYPES(FSP1@.ELTYPE,FSP2@.ELTYPE)
END;
COMPTYPES := COMP; GLOBTESTP := LTESTP2
END;
POWER:
COMPTYPES := COMPTYPES(FSP1@.ELSET,FSP2@.ELSET);
STRINGS:
COMPTYPES := TRUE;
ARRAYS:
COMPTYPES := COMPTYPES(FSP1@.AELTYPE,FSP2@.AELTYPE)
AND (FSP1@.SIZE = FSP2@.SIZE);
(* ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
BE COMPATIBLE.
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
BE THE SAME *)
RECORDS:
BEGIN NXT1 := FSP1@.FSTFLD; NXT2 := FSP2@.FSTFLD; COMP:=TRUE;
WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
BEGIN COMP:=COMP AND COMPTYPES(NXT1@.IDTYPE,NXT2@.IDTYPE)
; NXT1 := NXT1@.NEXT; NXT2 := NXT2@.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND(FSP1@.RECVAR = NIL)AND(FSP2@.RECVAR = NIL)
END;
(* IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IFF NO VARIANTS OCCUR *)
FILES:
COMPTYPES := COMPTYPES(FSP1@.FILTYPE,FSP2@.FILTYPE);
TAGFLD: ;
VARIANT:
END (* CASE *)
ELSE (* FSP1@.FORM <> FSP2@.FORM *)
IF FSP1@.FORM = SUBRANGE THEN
COMPTYPES := COMPTYPES(FSP1@.RANGETYPE,FSP2)
ELSE
IF FSP2@.FORM = SUBRANGE THEN
COMPTYPES := COMPTYPES(FSP1,FSP2@.RANGETYPE)
ELSE COMPTYPES := FALSE
ELSE COMPTYPES := TRUE
END (* COMPTYPES *) ;
FUNCTION SAMELABEL(SYM:SYMBOL; LPTR:LBP) : BOOLEAN;
(* NEW FUNCTION TO SUPPORT ALPHANUMERIC LABELS *)
(* CALLED BY LABELDECLARATION, GOTOSTATEMENT AND *)
(* STATEMENT FOR USE IN LOOKING UP A LABEL VALUE *)
BEGIN
IF LPTR <> NIL THEN
BEGIN IF (SYM = INT2CONST) AND NOT LPTR@.ALF THEN
SAMELABEL := VAL.IVAL = LPTR@.LABVAL
ELSE IF (SYM = IDENT) AND LPTR@.ALF THEN
SAMELABEL := ID = LPTR@.LABNAME
ELSE SAMELABEL := FALSE
END
ELSE SAMELABEL := FALSE;
END (* SAMELABEL *) ;
FUNCTION CHARARRAY(FSP: STP) : BOOLEAN;
BEGIN CHARARRAY := FALSE;
IF FSP <> NIL THEN
IF FSP@.FORM = ARRAYS THEN
CHARARRAY := COMPTYPES(FSP@.AELTYPE,CHARPTR)
END ; (* CHARARRAY *)
FUNCTION ALIGN(OP:INTEGER):INTEGER; (*ALIGN OP TO 'ALIGNMENT' BOUNDARY*)
VAR
ADJUSTMENT: INTEGER;
BEGIN
ADJUSTMENT := ABS(OP) MOD ALIGNMENT;
IF ADJUSTMENT = 0 THEN ALIGN := OP
ELSE
IF OP < 0 THEN
ALIGN := OP - (ALIGNMENT - ADJUSTMENT)
ELSE
ALIGN := OP + (ALIGNMENT - ADJUSTMENT)
END;
(*$E------------------------------------------------------------------------
PROCEDURE TYP
------------------------------------------------------------------------- *
)
PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE);
VAR
LSP,
LSP1,
LSP2: STP;
OLDTOP: DISPRANGE;
LCP: CTP;
KVALU: VALU;
LSIZE,
DISPL: ADDRRANGE;
LMIN,
LMAX: INTEGER;
LNGMIN,
LNGMAX: LNGINT;
(* -------------------------------------------------------------------------
PROCEDURE SIMPLETYP
------------------------------------------------------------------------- *
)
PROCEDURE SIMPLETYPE(FSYS:SETOFSYS;
VAR FSP:STP (* ; VAR FSIZE:ADDRRANGE *));
VAR LSP,LSP1,LSP2: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
LCNT: INTEGER; VAL1,VAL2: VALU;
SUBR,BADRANGE: BOOLEAN;
CVAL: CSP;
LVAL: LNGINT;
BEGIN FSIZE := 1;
IF NOT (SY IN SIMPTYPEBEGSYS) THEN
BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END;
IF SY IN SIMPTYPEBEGSYS THEN
BEGIN
IF SY = LPARENT THEN
BEGIN TTOP := TOP; (* DECL. CONSTS LOCAL TO INNERMOST BLOCK *
) WHILE DISPLAY(.TOP.).OCCUR <> BLCK DO TOP := TOP - 1;
NEW(LSP,SCALAR);
WITH LSP@ DO
BEGIN SIZE := INT2SIZE; FORM := SCALAR;
END;
LCP1 := NIL; LCNT := 0;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,KONST);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := LSP; NEXT := LCP1;
VALUES.IVAL := LCNT; KLASS := KONST
END;
ENTERID(LCP);
LCNT := LCNT + 1;
LCP1 := LCP; INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + (.COMMA,RPARENT.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.COMMA,RPARENT.)) END
UNTIL SY <> COMMA;
LSP@.FCONST := LCP1; TOP := TTOP;
IF LCNT <= 128 THEN LSP@.SIZE := INT1SIZE;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END
ELSE
BEGIN
SUBR := FALSE;
LSP := NIL;
IF SY = IDENT THEN
BEGIN SEARCHID((.TYPES,KONST.),LCP);
INSYMBOL;
IF LCP@.KLASS = KONST THEN
BEGIN
WITH LCP@ DO
BEGIN
LSP1 := IDTYPE;
IF CHARARRAY(LSP1)
THEN ERROR(148)
ELSE BEGIN
SUBR := TRUE;
VAL1 := VALUES
END (*ELSE*)
END (*WITH*)
END
ELSE
BEGIN LSP := LCP@.IDTYPE;
(* IF LSP <> NIL THEN FSIZE := LSP@.SIZE *)
END
END (* SY = IDENT *)
ELSE
BEGIN
CONSTANT(FSYS + (.RANGE.),LSP1,VAL1);
IF CHARARRAY(LSP1)
THEN ERROR(148)
ELSE SUBR := TRUE
END;
IF SUBR THEN
BEGIN (*PROCESS THE REST OF THE SUBRANG
E*) IF SY = RANGE
THEN INSYMBOL
ELSE ERROR(5);
CONSTANT (FSYS,LSP2,VAL2);
IF INTTYPE(LSP1) AND INTTYPE(LSP2) THEN
IF LSP1 <> LSP2 THEN
IF ((LSP1 = INT1PTR) OR (LSP1 = INT2PTR))
AND ((LSP2 = INT1PTR) OR (LSP2 = INT2PTR))
THEN BEGIN (*MAKE EM BOTH REGULAR*)
LSP1 := INT2PTR;
LSP2 := INT2PTR
END (*THEN*)
ELSE
BEGIN
NEW(CVAL,LINT);
IF LSP1 = INT4PTR
THEN BEGIN
MAKELONG (VAL2.IVAL,LVAL);
VAL2.VALP := CVAL;
LSP2 := INT4PTR
END (*THEN*)
ELSE BEGIN
MAKELONG (VAL1.IVAL,LVAL);
VAL1.VALP := CVAL;
LSP1 := INT4PTR
END; (*ELSE*)
CVAL@.LINTVAL := LVAL
END; (*ELSE*)
IF LSP1 <> LSP2
THEN ERROR(107)
ELSE
IF LSP1 = REALPTR
THEN ERROR(398)
ELSE
BEGIN (*CHECK FOR LEGAL RANGE*)
IF LSP1 = INT4PTR
THEN BADRANGE := COMPLONGS (VAL1.VALP@.LINTVAL,
VAL2.VALP@.LINTVAL)
= LNGGREATER
ELSE BADRANGE := VAL1.IVAL > VAL2.IVAL;
IF BADRANGE
THEN ERROR(102)
ELSE
BEGIN (*MAKE THE SUBRANGE*)
NEW (LSP,SUBRANGE);
WITH LSP@ DO
BEGIN
RANGETYPE := LSP1;
FORM := SUBRANGE;
MIN := VAL1;
MAX := VAL2;
SIZE := LSP1@.SIZE
END (*WITH*)
END (*ELSE*)
END (*ELSE*)
END (*THEN*)
END;
FSP := LSP;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE FSP := NIL
END (* SIMPLETYPE *) ;
(* -------------------------------------------------------------------------
PROCEDURE FIELDLIST
------------------------------------------------------------------------- *
)
PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP);
VAR LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP;
MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
BEGIN NXT1 := NIL; LSP := NIL;
IF NOT (SY IN FSYS+(.IDENT,CASESY.)) THEN
BEGIN ERROR(19); SKIP(FSYS + (.IDENT,CASESY.)) END;
WHILE SY = IDENT DO
BEGIN NXT := NXT1;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,FIELD);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT;
KLASS := FIELD
END;
NXT := LCP;
ENTERID(LCP);
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN (.COMMA,COLON.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.COMMA,COLON,SEMICOLON,CASESY.))
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
TYP(FSYS + (.CASESY,SEMICOLON.),LSP,LSIZE);
WHILE NXT <> NXT1 DO
WITH NXT@ DO
BEGIN IDTYPE := LSP;
IF LSIZE > 1 THEN DISPL := ALIGN(DISPL);
FLDADDR := DISPL;
DISPL := DISPL + LSIZE;
NXT := NEXT
END;
NXT1 := LCP;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN (.IDENT,CASESY,ENDSY.)) THEN (*IGNORE EXTRA ;*)
BEGIN ERROR(19); SKIP(FSYS + (.IDENT,CASESY.)) END
END
END (* WHILE *);
NXT := NIL;
WHILE NXT1 <> NIL DO
WITH NXT1@ DO
BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END;
IF SY = CASESY THEN
BEGIN NEW(LSP,TAGFLD);
WITH LSP@ DO
BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM:=TAGFLD END;
FRECVAR := LSP;
INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,FIELD);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := NIL; KLASS:=FIELD;
NEXT := NIL ; (*FLDADDR WILL BE SET WHEN TYPE IS KNOWN*)
END;
PRTERR := FALSE ; SEARCHID((.TYPES.),LCP1) ; PRTERR := TRUE ;
IF LCP1 = NIL THEN BEGIN (* EXPLICIT TAG FIELD *)
ENTERID(LCP); INSYMBOL ;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + (.OFSY,LPARENT.)) END
END (* IF LCP1 = NIL *)
ELSE (* NO EXPLICT TAG FIELD *)
LCP@.NAME := BLANKID ;
BEGIN SEARCHID((.TYPES.),LCP1);
LSP1 := LCP1@.IDTYPE;
IF LSP1 <> NIL THEN
WITH LSP1@ DO
BEGIN
IF LCP@.NAME <> BLANKID THEN BEGIN
IF SIZE > 1 THEN DISPL := ALIGN(DISPL);
LCP@.FLDADDR := DISPL ; DISPL := DISPL + SIZE;
END (* LCP@.NAME <> BLANKID *) ;
IF (FORM <= SUBRANGE) OR CHARARRAY(LSP1) THEN
BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109)
ELSE IF CHARARRAY(LSP1) THEN ERROR(398);
LCP@.IDTYPE := LSP1; LSP@.TAGFIELDP := LCP;
END
ELSE ERROR(110);
END (* WITH LSP1@ DO *) ;
INSYMBOL;
END
END
ELSE BEGIN ERROR(2); SKIP(FSYS + (.OFSY,LPARENT.)) END;
LSP@.SIZE := DISPL;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
REPEAT LSP2 := NIL;
REPEAT CONSTANT(FSYS + (.COMMA,COLON,LPARENT.),LSP3,LVALU);
IF LSP@.TAGFIELDP <> NIL THEN
IF NOT COMPTYPES(LSP@.TAGFIELDP@.IDTYPE,LSP3)THEN ERROR(111)
; NEW(LSP3,VARIANT);
WITH LSP3@ DO
BEGIN NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
FORM := VARIANT
END;
LSP1 := LSP3; LSP2 := LSP3;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
FIELDLIST(FSYS + (.RPARENT,SEMICOLON.),LSP2);
IF DISPL > MAXSIZE THEN MAXSIZE := DISPL;
WHILE LSP3 <> NIL DO
BEGIN LSP4 := LSP3@.SUBVAR; LSP3@.SUBVAR := LSP2;
LSP3@.SIZE := DISPL;
LSP3 := LSP4
END;
IF SY = RPARENT THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + (.SEMICOLON.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.SEMICOLON.)) END
END
ELSE ERROR(4);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN
BEGIN DISPL := MINSIZE;
INSYMBOL ; TEST := SY = ENDSY ; (* IGNORE EXTRA ; *)
END
UNTIL TEST;
DISPL := MAXSIZE;
LSP@.FSTVAR := LSP1;
END
ELSE FRECVAR := NIL
END (* FIELDLIST *) ;
BEGIN (* **START** TYP *)
IF NOT (SY IN TYPEBEGSYS) THEN
BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END;
IF SY IN TYPEBEGSYS THEN
BEGIN
IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP(* ,FSIZE *))
ELSE
(* @ *) IF SY = ARROW THEN
BEGIN NEW(LSP,POINTER); FSP := LSP;
WITH LSP@ DO
BEGIN ELTYPE := NIL;
SIZE := ADDRSIZE; FORM:=POINTER
END;
INSYMBOL;
IF SY = IDENT THEN
BEGIN PRTERR := FALSE; (*NO ERROR IF SRCH NOT SUCCESSFUL*)
SEARCHID((.TYPES.),LCP); PRTERR := TRUE;
IF LCP = NIL THEN (* FORWARD REFERENCED TYPE ID *)
BEGIN NEW(LCP,TYPES);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := LSP;
NEXT := FWPTR; KLASS := TYPES
END;
FWPTR := LCP
END
ELSE
BEGIN
IF LCP@.IDTYPE <> NIL THEN
IF LCP@.IDTYPE@.FORM = FILES THEN ERROR(108)
ELSE LSP@.ELTYPE := LCP@.IDTYPE
END;
INSYMBOL;
END
ELSE ERROR(2);
END
ELSE
BEGIN
IF SY = PACKEDSY THEN
BEGIN INSYMBOL;
IF NOT (SY IN TYPEDELS) THEN
BEGIN
ERROR(10); SKIP(FSYS + TYPEDELS)
END
END;
(* STRING *) IF SY = STRINGSY THEN
BEGIN
IF STANDARD THEN WARNING(510);
INSYMBOL;
IF SY = LBRACK THEN
INSYMBOL
ELSE
ERROR(11);
CONSTANT(FSYS + (. RBRACK .), LSP2, KVALU);
IF (LSP2 = INT1PTR) OR (LSP2 = INT2PTR) THEN
BEGIN
NEW(LSP,STRINGS);
WITH LSP@ DO
BEGIN
FORM := STRINGS;
SIZE := ALIGN(KVALU.IVAL+ALIGNMENT)
END
END
ELSE
BEGIN
LSP := NIL;
IF LSP2 = INT4PTR
THEN ERROR(203)
ELSE ERROR(15)
END;
IF SY = RBRACK THEN
INSYMBOL
ELSE
ERROR(12)
END
ELSE
(* ARRAY *) IF SY = ARRAYSY THEN
BEGIN INSYMBOL;
IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
LSP1 := NIL;
REPEAT NEW(LSP,ARRAYS);
WITH LSP@ DO
BEGIN AELTYPE := LSP1; INXTYPE := NIL;
FORM:=ARRAYS END;
LSP1 := LSP;
SIMPLETYPE(FSYS + (.COMMA,RBRACK,OFSY.),LSP2);
IF LSP2 <> NIL THEN
IF LSP2@.FORM <= SUBRANGE THEN
BEGIN
IF LSP2 = REALPTR THEN
BEGIN ERROR(109); LSP2 := NIL END
ELSE
IF LSP2 = INT4PTR THEN
BEGIN ERROR(149); LSP2 := NIL END;
LSP@.INXTYPE := LSP2
END
ELSE BEGIN ERROR(113); LSP2 := NIL END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
TYP(FSYS,LSP,LSIZE);
REPEAT
WITH LSP1@ DO
BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
IF INXTYPE <> NIL THEN
BEGIN
GETBOUNDS (INXTYPE, LNGMIN, LNGMAX);
LMIN := MAKESHORT (LNGMIN);
LMAX := MAKESHORT (LNGMAX);
LSIZE := LSIZE * (LMAX - LMIN + 1);
SIZE := LSIZE;
END
END;
LSP := LSP1; LSP1 := LSP2
UNTIL LSP1 = NIL
END
ELSE
(* RECORD *) IF SY = RECORDSY THEN
BEGIN INSYMBOL;
OLDTOP := TOP;
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY(.TOP.) DO
BEGIN FNAME := NIL;
FLABEL := NIL;
OCCUR := REC
END
END
ELSE ERROR(250);
DISPL := 0;
FIELDLIST(FSYS-(.SEMICOLON.)+(.ENDSY.),LSP1);
NEW(LSP,RECORDS);
WITH LSP@ DO
BEGIN FSTFLD := DISPLAY(.TOP.).FNAME;
RECVAR := LSP1; SIZE := ALIGN (DISPL);
FORM := RECORDS ;
END;
TOP := OLDTOP;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END
ELSE
(* SET *) IF SY = SETSY THEN
BEGIN INSYMBOL;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
SIMPLETYPE(FSYS,LSP1(* ,LSIZE *));
IF LSP1 <> NIL THEN
IF LSP1@.FORM > SUBRANGE THEN
BEGIN ERROR(115); LSP1 := NIL END
ELSE
IF LSP1 = REALPTR THEN ERROR(114);
NEW(LSP,POWER);
WITH LSP@ DO
BEGIN ELSET:=LSP1;
SIZE:=SETSIZE; FORM:=POWER
END;
END
ELSE
(* FILE *) IF SY = FILESY THEN
BEGIN INSYMBOL ;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8) ;
SIMPLETYPE(FSYS,LSP1(* ,LSIZE *)) ;
IF LSP1 = NIL THEN
BEGIN
ERROR(398);
LSP := NIL;
END
ELSE IF LSP1@.FORM = FILES THEN
BEGIN
ERROR (398);
LSP := NIL
END (*THEN*)
ELSE IF LSP1 = CHARPTR THEN LSP := TEXTPTR
ELSE BEGIN NEW(LSP,FILES);
WITH LSP@ DO BEGIN
FORM := FILES;
SIZE := 2*ADDRSIZE;
FILTYPE := LSP1 END
END
END ;
FSP := LSP
END;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE FSP := NIL;
IF FSP = NIL THEN FSIZE := 1 ELSE FSIZE := FSP@.SIZE
END (* TYP *) ;
(* -------------------------------------------------------------------------
PROCEDURE LABELDECLARATION
------------------------------------------------------------------------- *
)
PROCEDURE LABELDECLARATION;
VAR LLP: LBP; REDEF: BOOLEAN; LBNAME: LABELRNG ;
LCP: CTP;
BEGIN
REPEAT
IF (SY = INT2CONST) OR (SY = IDENT) THEN
WITH DISPLAY(.TOP.) DO
BEGIN LLP := FLABEL; REDEF := FALSE;
WHILE (LLP <> NIL) AND NOT REDEF DO
IF NOT SAMELABEL(SY, LLP) THEN
LLP := LLP@.NEXTLAB
ELSE BEGIN REDEF := TRUE; ERROR(166) END;
IF NOT REDEF THEN
BEGIN NEW(LLP);
WITH LLP@ DO BEGIN
LABNO := 0;
DEFINED := FALSE; NEXTLAB := FLABEL;
IF SY = INT2CONST
THEN BEGIN ALF := FALSE; LABVAL := VAL.IVAL END
ELSE BEGIN ALF := TRUE; LABNAME := ID;
NEW(LCP,LABELS); (* ALPHA LABEL *)
WITH LCP@ DO
BEGIN NAME := ID;
KLASS := LABELS;
NEXT := NIL;
IDTYPE := NIL;
END;
ENTERID(LCP); (* PUT IN SYMBOL TABLE *
) IF STANDARD THEN WARNING(501) END
END;
FLABEL := LLP
END;
INSYMBOL
END
ELSE ERROR(404);
IF NOT ( SY IN FSYS + (.COMMA, SEMICOLON.) ) THEN
BEGIN ERROR(6); SKIP(FSYS+(.COMMA,SEMICOLON.)) END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
END (* LABELDECLARATION *) ;
(* -------------------------------------------------------------------------
PROCEDURE CONSTDECLARATION
------------------------------------------------------------------------- *
)
PROCEDURE CONSTDECLARATION;
VAR LCP: CTP; LSP: STP; LVALU: VALU;
BEGIN
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + (.IDENT.)) END;
WHILE SY = IDENT DO
BEGIN NEW(LCP,KONST);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; KLASS:=KONST END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
CONSTANT(FSYS + (.SEMICOLON.),LSP,LVALU);
ENTERID(LCP);
LCP@.IDTYPE := LSP; LCP@.VALUES := LVALU;
IF LSP = REALPTR THEN
BEGIN
NEW(LCP@.VALUES.VALP);
LCP@.VALUES.VALP@.RVAL := LVALU.VALP@.RVAL;
END
ELSE IF LSP = INT4PTR THEN
BEGIN
NEW (LCP@.VALUES.VALP);
LCP@.VALUES.VALP@.LINTVAL := LVALU.VALP@.LINTVAL
END (*THEN*)
ELSE IF LSP <> NIL THEN
IF LSP@.FORM = STRINGS THEN
BEGIN
NEW(LCP@.VALUES.VALP);
LCP@.VALUES.VALP@.SLNGTH := LVALU.VALP@.SLNGTH;
NEW(LCP@.VALUES.VALP@.SVAL);
LCP@.VALUES.VALP@.SVAL@ := LVALU.VALP@.SVAL@;
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + (.IDENT.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.IDENT.)) END
END
ELSE ERROR(14)
END
END (* CONSTDECLARATION *) ;
(* -------------------------------------------------------------------------
PROCEDURE TYPEDECLARATION
------------------------------------------------------------------------- *
)
PROCEDURE TYPEDECLARATION;
VAR LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
BEGIN
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + (.IDENT.)) END;
WHILE SY = IDENT DO
BEGIN NEW(LCP,TYPES);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := NIL; KLASS := TYPES END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
TYP(FSYS + (.SEMICOLON.),LSP,LSIZE);
ENTERID(LCP);
LCP@.IDTYPE := LSP;
(* HAS ANY FORWARD REFERENCE BEEN SATISFIED: *)
LCP1 := FWPTR;
WHILE LCP1 <> NIL DO
BEGIN
IF LCP1@.NAME = LCP@.NAME THEN
BEGIN LCP1@.IDTYPE@.ELTYPE := LCP@.IDTYPE;
IF LCP1 <> FWPTR THEN
LCP2@.NEXT := LCP1@.NEXT
ELSE FWPTR := LCP1@.NEXT;
END;
LCP2 := LCP1; LCP1 := LCP1@.NEXT
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + (.IDENT.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.IDENT.)) END
END
ELSE ERROR(14)
END;
END (* TYPEDECLARATION *) ;
(* -------------------------------------------------------------------------
PROCEDURE VARDECLARATION
------------------------------------------------------------------------- *
)
PROCEDURE VARDECLARATION;
VAR LCP,NXT,TNEXT: CTP; LSP: STP; LSIZE: ADDRRANGE; COUNT: 0..100 ;
KFILE: EXTFILEP; (* TEMP PTR INTO CHAIN OF EXTERNAL FILES *)
BEGIN NXT := NIL;
REPEAT COUNT := 0 ;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,VARS); COUNT := COUNT+1 ;
WITH LCP@ DO
BEGIN NAME := ID; NEXT := NXT; KLASS := VARS;
EXTRNL := FALSE;
IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
END;
ENTERID(LCP);
NXT := LCP;
INSYMBOL;
END
ELSE ERROR(2);
(*CODE FOR ORIGIN*)
IF SY = LBRACK THEN BEGIN
INSYMBOL;
IF SY <> ORIGINSY THEN ERROR(415)
ELSE BEGIN LCP@.VKIND := ORIGINED;
IF STANDARD THEN
WARNING(504) END;
LONGONLY := TRUE;
INSYMBOL;
LONGONLY := FALSE;
IF SY <> INT4CONST THEN ERROR(416)
ELSE
WITH VAL.VALP@ DO
IF (MACHINE = M6809)
AND ( (LINTVAL(.4.) <> 0)
OR (LINTVAL(.3.) <> 0))
THEN ERROR (203)
ELSE LCP@.VADDR := LINTVAL;
INSYMBOL;
IF SY <> RBRACK THEN ERROR(417);
INSYMBOL
END;
(*END OF ORIGIN CODE *)
IF NOT (SY IN FSYS + (.COMMA,COLON.) + TYPEDELS) THEN
BEGIN ERROR(6); SKIP(FSYS+(.COMMA,COLON,SEMICOLON.)+TYPEDELS) END
; TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
TYP(FSYS + (.SEMICOLON.) + TYPEDELS,LSP,LSIZE);
WHILE NXT <> NIL DO
WITH NXT@ DO
BEGIN IDTYPE := LSP;
IF VKIND <> ORIGINED THEN (*NO LOCAL ALLOC FOR ORIGIN*)
BEGIN LOCN := LOCN - LSIZE;
IF LSIZE > 1 THEN LOCN := ALIGN(LOCN);
VADDR(.1.) := LOCN END ;
IF (LOCN < MINADDR) OR (LOCN > MAXADDR) THEN
BEGIN ERROR(504) ; (*LOCAL DATA AREA TOO LARGE*)
LOCN := 0 ;
END;
(*CODE TO CHECK IF FILE WAS MENTIONED IN FILE HEADER*)
(*ALSO TO CHAIN FILE DECL'S TOGETHER FOR LATER OPENS, ETC*)
IF LSP <> NIL THEN IF LSP@.FORM = FILES THEN
BEGIN (*MARK AS DEFINED ON LIST OF EXTERNAL FILES*)
IF (LEVEL = 0) AND (FEXTFILEP <> NIL) THEN
BEGIN KFILE := FEXTFILEP;
WHILE KFILE <> NIL DO BEGIN
IF KFILE@.FILENAME = NAME THEN
BEGIN EXTRNL := TRUE;
KFILE@.DEF := TRUE
END;
KFILE := KFILE@.NEXTFILE
END
END;
TNEXT:=NEXT;
NEXT := LOCFILELIST; (*ADD TO LOCAL FILE LIST*)
LOCFILELIST := NXT;
NXT := TNEXT ;
END
ELSE NXT := NEXT
ELSE NXT := NEXT
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + (.IDENT.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.IDENT.)) END
END
ELSE ERROR(14)
UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS);
END (* VARDECLARATION *) ;
(* -------------------------------------------------------------------------
PROCEDURE PROCDECLARATION
------------------------------------------------------------------------- *
)
PROCEDURE PROCDECLARATION(FSY: SYMBOL);
VAR OLDLEV: LEVRANGE; LCP,LCP1: CTP; LSP: STP;
FORW, NEWDEF: BOOLEAN; OLDTOP: DISPRANGE;
LLC: ADDRRANGE;
OLDLABEL: LABELRNG;
MARKP: @INTEGER;
(* -------------------------------------------------------------------------
PROCEDURE PARAMETERLIST
------------------------------------------------------------------------- *
)
PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP);
VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
LLC,LEN : ADDRRANGE; COUNT : INTEGER;
BEGIN LCP1 := NIL; PARMLEN := 0;
IF NOT (SY IN FSY + (.LPARENT.)) THEN
BEGIN ERROR(7); SKIP(FSYS + FSY + (.LPARENT.)) END;
IF SY = LPARENT THEN
BEGIN IF FORW THEN ERROR(119);
INSYMBOL;
IF NOT (SY IN (.IDENT,VARSY,PROCSY,FUNCSY.)) THEN
BEGIN ERROR(7); SKIP(FSYS + (.IDENT,RPARENT.)) END;
WHILE SY IN (.IDENT,VARSY,PROCSY,FUNCSY.) DO
BEGIN
IF SY = PROCSY THEN
BEGIN ERROR(398);
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,PROC,DECLARED,FORMAL);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP1;
PFLEV := LEVEL;
(* BEWARE OF PARAMETER PROCEDURES *)
KLASS:=PROC;PFDECKIND:=DECLARED;PFKIND:=FORMAL
END;
ENTERID(LCP);
LCP1 := LCP;
PARMLEN := PARMLEN + ADDRSIZE;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + (.COMMA,SEMICOLON,RPARENT.)) THEN
BEGIN ERROR(7);
SKIP(FSYS+(.COMMA,SEMICOLON,RPARENT.)) END
UNTIL SY <> COMMA
END
ELSE
BEGIN
IF SY = FUNCSY THEN
BEGIN ERROR(398); LCP2 := NIL;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,FUNC,DECLARED,FORMAL);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP2
; PFLEV := LEVEL (* BEWARE PARAM FUNCS *);
KLASS:=FUNC;PFDECKIND:=DECLARED;
PFKIND:=FORMAL
END;
ENTERID(LCP);
LCP2 := LCP;
PARMLEN := PARMLEN + ADDRSIZE;
INSYMBOL;
END;
IF NOT (SY IN (.COMMA,COLON.) + FSYS) THEN
BEGIN ERROR(7);
SKIP(FSYS+(.COMMA,SEMICOLON,RPARENT.))
END
UNTIL SY <> COMMA;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN SEARCHID((.TYPES.),LCP);
LSP := LCP@.IDTYPE;
IF LSP <> NIL THEN
IF NOT(LSP@.FORM IN
(.SCALAR,SUBRANGE,POINTER.))
THEN BEGIN ERROR(120); LSP := NIL END;
LCP3 := LCP2;
WHILE LCP2 <> NIL DO
BEGIN LCP2@.IDTYPE := LSP; LCP := LCP2;
LCP2 := LCP2@.NEXT
END;
LCP@.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + (.SEMICOLON,RPARENT.)) THEN
BEGIN ERROR(7);
SKIP(FSYS+(.SEMICOLON,RPARENT.)) END
END
ELSE ERROR(5)
END
ELSE
BEGIN
IF SY = VARSY THEN
BEGIN LKIND := FORMAL; INSYMBOL END
ELSE LKIND := ACTUAL;
LCP2 := NIL;
COUNT := 0;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,VARS);
WITH LCP@ DO
BEGIN NAME:=ID; IDTYPE:=NIL; KLASS:=VARS;
VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL
; END;
ENTERID(LCP);
LCP2 := LCP; COUNT := COUNT+1;
INSYMBOL;
END;
IF NOT (SY IN (.COMMA,COLON.) + FSYS) THEN
BEGIN ERROR(7);
SKIP(FSYS+(.COMMA,SEMICOLON,RPARENT.))
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN SEARCHID((.TYPES.),LCP); LEN := ADDRSIZE
; LSP := LCP@.IDTYPE;
IF LSP <> NIL THEN
IF (LKIND=ACTUAL) THEN BEGIN
LEN := LSP@.SIZE ;
IF LSP@.FORM = FILES
THEN ERROR(121); END;
(*IF LEN > 1 THEN PARMLEN := ALIGN(PARMLEN)
;*) (*IF COUNT > 1 THEN LEN := ALIGN(LEN);*)
LEN := ALIGN(LEN);
(*THE ABOVE IS SLIGHTLY LESS EFFICIENT
THAN ABSOLUTELY NECESSARY (BYTE SIZE
OBJECTS TAKE A WHOLE WORD ON WORD-ALIGNED
MACHINES) *)
PARMLEN := PARMLEN + COUNT * LEN;
LCP3 := LCP2 ;
LLC := PARMLEN;
WHILE LCP2 <> NIL DO
BEGIN LCP := LCP2;
WITH LCP2@ DO
BEGIN IDTYPE := LSP;
VADDR(.1.) := LLC;
LLC:=LLC - LEN;
END;
LCP2 := LCP2@.NEXT
END;
LCP@.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + (.SEMICOLON,RPARENT.)) THEN
BEGIN ERROR(7);
SKIP(FSYS+(.SEMICOLON,RPARENT.)) END
END
ELSE ERROR(5);
END;
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + (.IDENT,VARSY,PROCSY,FUNCSY.)) THEN
BEGIN ERROR(7); SKIP(FSYS + (.IDENT,RPARENT.)) END
END
END (* WHILE *) ;
IF SY = RPARENT THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSY + FSYS) THEN
BEGIN ERROR(6); SKIP(FSY + FSYS) END
END
ELSE ERROR(4);
LCP3 := NIL;
(* REVERSE POINTERS *)
WHILE LCP1 <> NIL DO
WITH LCP1@ DO
BEGIN LCP2 := NEXT; NEXT := LCP3;
LCP3 := LCP1; LCP1 := LCP2
END;
FPAR := LCP3
END (* IF SY = LPAREN *)
ELSE FPAR := NIL ;
END (* PARAMETERLIST *) ;
BEGIN (* **START** PROCDECLARATION *)
LLC := LOCN;
LOCN := 0;
LCP := UPRCPTR ; (* TO INITIALIZE LCP IN CASE (. *)
IF SY = IDENT THEN
BEGIN SEARCHSECTION(DISPLAY(.TOP.).FNAME,LCP);
(* DECIDE WHETHER FORW. *)
FORW := FALSE;
IF LCP <> NIL THEN
IF (LCP@.KLASS <> PROC) AND (LCP@.KLASS <> FUNC) THEN
LCP := NIL
ELSE IF LCP@.PFDECKIND <> BUILTIN THEN
BEGIN
IF LCP@.KLASS = PROC THEN
FORW:=LCP@.FORWDECL AND(FSY=PROCSY)AND(LCP@.PFKIND=ACTUAL)
ELSE
IF LCP@.KLASS = FUNC THEN
FORW:=LCP@.FORWDECL AND(FSY=FUNCSY)AND(LCP@.PFKIND=ACTUAL);
IF NOT FORW THEN ERROR(160)
END;
IF NOT FORW THEN
BEGIN
NEWDEF := LCP = NIL;
(*NEWDEF = FALSE IF REDEFINING BUILTIN PROC/FUNC*)
IF NEWDEF THEN
IF FSY = PROCSY THEN NEW(LCP,PROC,DECLARED,ACTUAL)
ELSE NEW(LCP,FUNC,DECLARED,ACTUAL);
WITH LCP@ DO
BEGIN NAME := ID ; IDTYPE := NIL;
(*EXTERN := FALSE;*) PFLEV := LEVEL;
PFDECKIND := DECLARED; PFKIND := ACTUAL;
PROCLAB := PROCLAB+1; PFNAME := PROCLAB;
IF FSY = PROCSY THEN KLASS := PROC
ELSE KLASS := FUNC
END;
IF NEWDEF THEN ENTERID(LCP)
END
ELSE BEGIN (*TAKE OFF LIST OF UNDECL'D FORWARD PROC/FUNCS*)
IF FWDLIST <> NIL THEN
IF FWDLIST@.PF = LCP THEN
FWDLIST := FWDLIST@.NEXTPF
ELSE BEGIN KFWD :=FWDLIST;
WHILE KFWD@.NEXTPF <> NIL DO
IF KFWD@.NEXTPF@.PF = LCP
THEN KFWD@.NEXTPF:=
KFWD@.NEXTPF@.NEXTPF
ELSE KFWD := KFWD@.NEXTPF;
END;
END;
INSYMBOL
END
ELSE ERROR(2);
OLDLEV := LEVEL; OLDTOP := TOP;
(* OLDLABEL := INTLABEL ; INTLABEL := 0 ; UNIQUE LABELS *)
IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251);
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY(.TOP.) DO
BEGIN
IF FORW THEN FNAME := LCP@.NEXT
ELSE FNAME := NIL;
FLABEL := NIL;
OCCUR := BLCK
END
END
ELSE ERROR(250);
IF FSY = PROCSY THEN
BEGIN PARAMETERLIST((.SEMICOLON.),LCP1);
IF NOT FORW THEN LCP@.NEXT := LCP1;
END
ELSE
BEGIN PARAMETERLIST((.SEMICOLON,COLON.),LCP1);
IF NOT FORW THEN LCP@.NEXT := LCP1;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN IF FORW THEN ERROR(122);
SEARCHID((.TYPES.),LCP1);
LSP := LCP1@.IDTYPE;
LCP@.IDTYPE := LSP;
IF (LSP <> NIL) AND STANDARD THEN
IF NOT (LSP@.FORM IN (.SCALAR,SUBRANGE,POINTER,POWER.)
) THEN WARNING(509);
INSYMBOL
END
ELSE BEGIN ERROR(2);
LCP@.IDTYPE := NIL;
SKIP(FSYS + (.SEMICOLON.))
END
END
ELSE
IF NOT FORW THEN ERROR(123)
END;
IF FORW THEN
PARMLEN := LCP@.PFADDR
ELSE
BEGIN
LCP1 := LCP@.NEXT;
WHILE LCP1 <> NIL DO
BEGIN
WITH LCP1@ DO
IF KLASS = VARS THEN VADDR(.1.) := PARMLEN - VADDR(.1.);
LCP1 := LCP1@.NEXT
END;
LCP@.PFADDR := PARMLEN
END;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
IF SY = FORWARDSY THEN
BEGIN
IF FORW THEN ERROR(161)
ELSE BEGIN LCP@.FORWDECL := TRUE;
(*PUT ON LIST OF FORWARD PROC/FUNCS*)
KFWD := FWDLIST;
NEW(FWDLIST);
FWDLIST@.NEXTPF := KFWD;
FWDLIST@.PF := LCP END;
INSYMBOL;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
IF NOT (SY IN FSYS+(.PERIOD.)) THEN
BEGIN ERROR(6); SKIP(FSYS+(.PERIOD.)) END
END
ELSE
BEGIN LCP@.FORWDECL := FALSE; MARK (MARKP);
REPEAT BLOCK(FSYS,SEMICOLON,LCP);
GENLI(77(* RET *),LEVEL,ALIGN(PARMLEN));
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN (.BEGINSY,PROCSY,FUNCSY.)) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE IF NOT(SUBPROG AND (LEVEL=1)) THEN ERROR(14)
UNTIL SY IN (.BEGINSY,PROCSY,FUNCSY,PERIOD.);
RELEASE (MARKP); (* RELEASE LOCAL ENTRIES FROM RUNTIME HEAP *)
END;
LEVEL := OLDLEV; TOP := OLDTOP; LOCN := LLC;
(*INTLABEL := OLDLABEL ; SEE ABOVE: TO MAKE LABELS UNIQ ONLY INTRA-PROC
*) END (* PROCDECLARATION *) ;
(* -------------------------------------------------------------------------
PROCEDURE BODY
------------------------------------------------------------------------- *
)
PROCEDURE BODY(FSYS: SETOFSYS);
CONST CIXMAX = 1000;
VAR
SEGSIZE: LABELRNG;
KLOCFILELIST: CTP;
KFILE: EXTFILEP; (* TEMP PTR INTO CHAIN OF EXTERNAL FILES *)
STDFILE:BOOLEAN;
LLCP:CTP;
CSTPTR: CSP;
(* ALLOWS REFERENCING OF NONINTEGER CONSTANTS BY AN INDEX
(INSTEAD OF A POINTER), WHICH CAN BE STORED IN THE P2-FIELD
OF THE INSTRUCTION RECORD UNTIL WRITEOUT.
--> PROCEDURE LOAD, PROCEDURE WRITEOUT, NOT NEEDED IN P_COMP*)
STATUS, ENTNAME, K: INTEGER;
LCMIN, LLC1: ADDRRANGE; LCP: CTP;
LLP: LBP; PROCNAME : ALPHA ;
FUNCTION GETTYPE(OPERAND: STP): CHAR;
BEGIN (* THE FOLLOWING COME IN FREQUENCY ORDER *)
IF OPERAND = NIL THEN
BEGIN
IF ERRORCOUNT = 0 THEN ERROR(500);
GETTYPE := 'I'
END (*THEN*)
ELSE IF (OPERAND = INT2PTR)
OR ((OPERAND@.FORM = SCALAR) AND (OPERAND@.SIZE = INT2SIZE
)) THEN
GETTYPE := 'I'
ELSE IF OPERAND@.FORM = POINTER THEN
GETTYPE := 'A'
ELSE IF OPERAND = CHARPTR THEN
GETTYPE := 'C'
ELSE IF OPERAND = BOOLPTR THEN
GETTYPE := 'B'
ELSE IF (OPERAND = INT1PTR)
OR ((OPERAND@.FORM = SCALAR) AND (OPERAND@.SIZE = INT1SIZE
)) THEN
GETTYPE := 'H'
ELSE IF OPERAND@.FORM = SUBRANGE THEN
GETTYPE := GETTYPE(OPERAND@.RANGETYPE)
ELSE IF OPERAND = INT4PTR THEN
GETTYPE := 'J'
ELSE IF OPERAND@.FORM = STRINGS THEN
GETTYPE := 'S'
ELSE IF OPERAND@.FORM > STRINGS THEN
GETTYPE := 'V'
ELSE IF OPERAND@.FORM = POWER THEN
GETTYPE := 'P'
ELSE IF OPERAND = REALPTR THEN
GETTYPE := 'R'
ELSE
GETTYPE := 'I' (* DEFAULT TO INTEGER TYPE *)
END (* GETTYPE *) ;
(* -------------------------------------------------------------------------
CODE GENERATION PROCEDURES
------------------------------------------------------------------------- *
)
PROCEDURE GEN (FOP:MNRANGE);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5);
IC := IC + 1
END (*THEN*)
END; (*GEN*)
PROCEDURE GENT (FOP:MNRANGE; OPTYPE:CHAR);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3);
IC := IC + 1
END (*THEN*)
END; (*GENT*)
PROCEDURE GEN2T (FOP:MNRANGE; OPTYPE1:CHAR; OPTYPE2:CHAR);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE1:3, OPTYPE2:3);
IC := IC + 1
END (*THEN*)
END; (*GEN2T*)
PROCEDURE GENTI (FOP:MNRANGE; OPTYPE:CHAR; OPERAND:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
IF (FOP <> 45(*LDC*)) OR (OPTYPE <> 'C') THEN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3, ' ', OPERAND)
ELSE BEGIN
WRITE(PCODE, MN(.FOP.):5, OPTYPE:3, ' ''', CHR(OPERAND)
); IF CHR(OPERAND)='''' THEN WRITE(PCODE,'''');
WRITELN(PCODE,'''') END;
IC := IC + 1
END (*THEN*)
END; (*GENTI*)
PROCEDURE GENTJ (FOP: MNRANGE; OPTYPE: CHAR; OPERAND: LNGINT);
BEGIN (*GENTJ*)
IF PRCODE THEN
BEGIN
WRITE (PCODE,MN(.FOP.):5,OPTYPE:3,' ');
WRITELONG (PCODE,OPERAND);
WRITELN (PCODE,' ')
END (*THEN*)
END; (*GENTJ*)
PROCEDURE GENT2I(FOP:MNRANGE; OPTYPE:CHAR; OPERAND1:INTEGER;
OPERAND2:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3, ' ', OPERAND1, ' ',
OPERAND2);
IC := IC + 1
END (*THEN*)
END; (*GENT2I*)
PROCEDURE GENT2J (FOP: MNRANGE; OPTYPE: CHAR;
OPERAND1,OPERAND2: LNGINT);
BEGIN (*GENT2J*)
IF PRCODE THEN
BEGIN
WRITE (PCODE,MN(.FOP.):5,OPTYPE:3,' ');
WRITELONG (PCODE,OPERAND1);
WRITE (PCODE,' ');
WRITELONG (PCODE,OPERAND2);
WRITELN (PCODE);
IC := IC + 1
END (*THEN*)
END; (*GENT2J*)
PROCEDURE GEN2TI(FOP:MNRANGE; OPTYPE1:CHAR; OPTYPE2:CHAR;
OPERAND:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE1:3, OPTYPE2:3, ' ',
OPERAND);
IC := IC + 1
END (*THEN*)
END; (*GEN2TI*)
PROCEDURE GENI (FOP:MNRANGE; OPERAND:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, ' ', OPERAND);
IC := IC + 1
END (*THEN*)
END; (*GENI*)
PROCEDURE GENTLI(FOP:MNRANGE; OPTYPE:CHAR; LEVEL:LEVRANGE;
OPERAND:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3, LEVEL:3, ' ', OPERAND)
; IC := IC + 1
END (*THEN*)
END; (*GENTLI*)
PROCEDURE GENTL2I(FOP:MNRANGE; OPTYPE:CHAR; LEVEL:LEVRANGE;
OPERAND1,OPERAND2:INTEGER);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3, LEVEL:3, ' ',
OPERAND1,OPERAND2);
IC := IC + 1
END (*THEN*)
END; (*GENTL2I*)
PROCEDURE GENTL (FOP:MNRANGE; OPTYPE:CHAR; LAB:LABELRNG);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3, LAB:4);
IC := IC + 1
END (*THEN*)
END; (*GENTL*)
PROCEDURE GENENT(ENTNM:INTEGER; FOP:MNRANGE; LEVEL:LEVRANGE;
LAB:LABELRNG; NAME:ALPHA);
BEGIN
IF PRCODE THEN
BEGIN
IF ENTNM = 0 THEN WRITE(PCODE,' ')
ELSE WRITE(PCODE,'$',ENTNM:3);
WRITELN(PCODE,MN(.FOP.):5,LEVEL:3,' ',
LAB:4,' ''OPTIONS'' ''',NAME,'''');
IC := IC + 1
END (*THEN*)
END; (*GENENT*)
PROCEDURE GENTV (FOP:MNRANGE; OPTYPE:CHAR; LVP:CSP);
VAR I,J,K:INTEGER;
TCHAR:CHAR;
BEGIN
IF PRCODE THEN
BEGIN
IF OPTYPE = 'R' THEN (*OUTPUT REAL VALUE*)
WRITELN(PCODE, MN(.FOP.):5, OPTYPE:3, ' ', LVP@.RVAL
) ELSE IF OPTYPE = 'S' THEN (*OUTPUT STRING VALUE*)
WITH LVP@ DO
BEGIN WRITE(PCODE, MN(.FOP.):5, OPTYPE:3,' ''');
FOR I := 1 TO SLNGTH DO BEGIN
TCHAR:=SVAL@(.I.);
WRITE(PCODE,TCHAR);
IF TCHAR='''' THEN WRITE(PCODE,TCHAR);
END;
WRITELN(PCODE,'''')
END
ELSE IF OPTYPE = 'P' THEN (*OUTPUT SET VALUE*)
BEGIN WRITE(PCODE, MN(.FOP.):5, OPTYPE:3,' ');
FOR I := 0 TO 7 DO
BEGIN J := 0 ; K := SETRANGE-I*8 ;
FOR K := K DOWNTO K-7 DO
BEGIN J := J*2 ;
IF K IN LVP@.PVAL THEN J := J+1 ;
END ;
IF I > 0 THEN WRITE(PCODE,',') ;
WRITE(PCODE, J:4) ;
END (* FOR I := 0 TO 7 *) ;
WRITELN(PCODE)
END;
IC := IC + 1
END (*THEN*)
END; (*GENTV*)
PROCEDURE GENDEF(L1: LABELRNG; L2: ADDRRANGE ) ;
BEGIN
IF PRCODE THEN
WRITELN(PCODE,'L', L1:3,MN(.17(* DEF *).):5, L2:7);
END (* GENDEF *) ;
PROCEDURE GENKOUNT(PORK:BOOLEAN);
BEGIN (* GENKOUNT *)
IF (KOUNTERS OR (PORK AND PKOUNTERS)) AND PRCODE THEN
BEGIN
IF LABELEDKOUNT THEN
BEGIN
WRITELN(PCODE, MN(. 50 (*LSC*).):5, KOUNT);
LABELEDKOUNT := FALSE;
END
ELSE
WRITELN(PCODE, MN(. 40 (*ISC*).):5);
IC := IC + 1;
END;
KOUNT := KOUNT + 1;
PRINTKOUNT := TRUE;
END (* GENKOUNT *);
(* -------------------------------------------------------------------------
PROCEDURE LOAD
------------------------------------------------------------------------- *
)
PROCEDURE LOAD;
VAR TIPE:CHAR;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
TIPE:=GETTYPE(TYPTR);
CASE KIND OF
CST: IF (TYPTR@.FORM = SCALAR) AND (TYPTR <> REALPTR) THEN
IF TYPTR = BOOLPTR THEN GENTI(45(*LDC*),'B',CVAL.IVA
L) ELSE
IF TIPE = 'C' THEN
GENTI(45(*LDC*),'C',CVAL.IVAL)
ELSE IF TIPE = 'I' THEN
GENTI (45(*LDC*),'I',CVAL.IVAL) (* INTEGER *)
ELSE IF TIPE = 'H' THEN
GENTI (45(*LDC*),'H',CVAL.IVAL) (* SHORT INT
*) ELSE GENTJ (45(*LDC*),'J',CVAL.VALP@.LINTVAL)
ELSE
IF TYPTR = NILPTR THEN GENTJ(45(*LDC*),'A',LONGZERO)
ELSE
BEGIN
CSTPTR := CVAL.VALP;
IF TYPTR = REALPTR THEN
GENTV(45(*LDC*),'R',CSTPTR)
ELSE IF TYPTR@.FORM = STRINGS THEN
GENTV(45(*LDC*),'S',CSTPTR)
ELSE GENTV(45(*LDC*),'P',CSTPTR)
END;
VARBL: BEGIN
CASE ACCESS OF
DRCT: IF TIPE = 'V'
THEN GENTL2I(48(*LOD*),TIPE,VLEVEL,
DPLMT,TYPTR@.SIZE)
ELSE GENTLI(48(*LOD*),TIPE,VLEVEL,DPLMT)
; INDRCT: IF TIPE = 'V'
THEN GENT2I(35(*IND*),TIPE,
IDPLMT,TYPTR@.SIZE)
ELSE GENTI (35(*IND*),TIPE,IDPLMT)
END END;
FILEPTR: BEGIN
GENI(112 (* MST *), 0 (* BUILTIN *));
IF ACCESS = DRCT THEN
BEGIN ACCESS := INDRCT;
GENLI(44(*LDA*),VLEVEL,DPLMT);
END;
GENTI(116 (*ARG*), 'A', 0);
GEN(65(*PEE*));
IF TIPE = 'V'
THEN GENT2I(35(*IND*),TIPE,0,TYPTR@.SIZE
) ELSE GENTI (35(*IND*),TIPE,0)
END;
EXPR:
END;
KIND := EXPR
END
END (* LOAD *) ;
(* -------------------------------------------------------------------------
PROCEDURE STORE
------------------------------------------------------------------------- *
)
PROCEDURE STORE(VAR FATTR: ATTR);
VAR TIPE:CHAR;
BEGIN
WITH FATTR DO
IF TYPTR <> NIL THEN
BEGIN TIPE := GETTYPE(TYPTR);
CASE ACCESS OF
DRCT: IF (TIPE = 'V') OR (TIPE = 'S')
THEN GENTL2I(96(*STR*),TIPE,VLEVEL,DPLMT,TYPTR@.SIZE)
ELSE GENTLI (96(*STR*),TIPE,VLEVEL,DPLMT);
INDRCT: IF IDPLMT <> 0 THEN ERROR(400)
ELSE IF (TIPE = 'V') OR (TIPE = 'S')
THEN GENTI(94(*STO*),TIPE,TYPTR@.SIZE)
ELSE GENT (94(*STO*),TIPE)
END END
END (* STORE *) ;
(* -------------------------------------------------------------------------
PROCEDURE LOADADDRESS
------------------------------------------------------------------------- *
)
PROCEDURE LOADADDRESS;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
CASE KIND OF
CST: IF CHARARRAY(TYPTR) THEN
BEGIN
CSTPTR := CVAL.VALP ;
GENTV(43(*LCA*),'S',CSTPTR);
END
ELSE ERROR(400);
VARBL: CASE ACCESS OF
DRCT: GENLI(44(*LDA*),VLEVEL,DPLMT);
INDRCT: IF IDPLMT <> 0 THEN
GENTI(34(*INC*),'A',IDPLMT)
END;
FILEPTR: IF ACCESS = DRCT
THEN GENTLI(48(*LOD*),'A',VLEVEL,DPLMT)
ELSE GENTI (35(*IND*),'A',0);
EXPR: ERROR(400)
END;
KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0
END
END (* LOADADDRESS *) ;
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE CHKBNDS (LHSP,RHSP,ERR) *)
(* *)
(* THIS PROCEDURE FIRST CHECKS TO MAKE SURE THAT THE TYPES *)
(* POINTED TO BY 'RHSP' AND 'LHSP' ARE ASSIGNMENT *)
(* COMPATABLE (IE. THEIR RANGES INTERSECT SOMEWHERE). IF *)
(* THEY ARE NOT, THE ERROR INDICATED BY 'ERR' IS GENERATED. *)
(* IF THEY ARE, AND DEBUGGING IS ON, A CHK INSTRUCTION IS *)
(* GENERATED TO CHECK AT RUNTIME IF THE VALUE ON THE TOP OF *)
(* THE STACK IS WITHIN THE RANGE INDICATED BY 'LHSP'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE CHKBNDS (LHSP,RHSP: STP; ERR: INTEGER);
VAR
LHSMIN,LHSMAX,
RHSMIN,RHSMAX,
LMIN,LMAX: LNGINT;
IMIN,IMAX: INTEGER;
K: CHAR;
BEGIN (*CHKBNDS*)
IF (LHSP <> NIL) AND (RHSP <> NIL) THEN
IF (LHSP <> BOOLPTR) AND (LHSP <> INT4PTR)
AND (LHSP <> REALPTR) AND (LHSP@.FORM < POINTER) THEN
BEGIN
GETBOUNDS (LHSP,LHSMIN,LHSMAX);
GETBOUNDS (RHSP,RHSMIN,RHSMAX);
IF COMPLONGS(LHSMIN,RHSMIN) = LNGGREATER
THEN LMIN := LHSMIN
ELSE LMIN := RHSMIN;
IF COMPLONGS(LHSMAX,RHSMAX) = LNGLESS
THEN LMAX := LHSMAX
ELSE LMAX := RHSMAX;
IF COMPLONGS(LMIN,LMAX) = LNGGREATER
THEN ERROR(ERR)
ELSE
IF DEBUG THEN
BEGIN (* GENERATE THE CHK INSTRUCTION *)
K := GETTYPE (RHSP);
IF K = 'J'
THEN GENT2J (6 (*CHK*),K,LMIN,LMAX)
ELSE BEGIN
IMIN := MAKESHORT(LMIN);
IMAX := MAKESHORT(LMAX);
GENT2I (6 (*CHK*),K,IMIN,IMAX)
END (*ELSE*)
END (*THEN*)
END (*THEN*)
END; (*CHKBNDS*)
(* -------------------------------------------------------------------------
PROCEDURE PUTLABEL
------------------------------------------------------------------------- *
)
PROCEDURE PUTLABEL(LABNUM: LABELRNG);
BEGIN
IF PRCODE THEN
BEGIN
WRITELN(PCODE, 'L', LABNUM:3,' LAB');
LABELEDKOUNT := TRUE;
END (*THEN*)
END (* PUTLABEL *);
(* -------------------------------------------------------------------------
PROCEDURE STATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE STATEMENT(FSYS: SETOFSYS);
VAR LCP: CTP; LLP: LBP;
FOUND, INLOOP: BOOLEAN;
TTOP: DISPRANGE ;
(* -------------------------------------------------------------------------
PROCEDURE EXPRESSION
------------------------------------------------------------------------- *
)
PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD;
(*$E------------------------------------------------------------------*)
(* PROCEDURE CNVRTTOLHS *)
(* *)
(* CNVRTTOLHS STANDS FOR CONVERT TO LEFT HAND SIDE. *)
(* IF THE TYPE OF THE RIGHT HAND SIDE IS NOT THE SAME AS THE LEFT *)
(* HAND SIDE THE A CONVERT INSTRUCTION IS GENERATED TO CONVERT THE *)
(* RIGHT TO THE SAME SIDE AS THE LEFT. *)
(*--------------------------------------------------------------------*)
PROCEDURE CNVRTTOLHS (LEFTSIDE: STP; VAR RIGHTSIDE: STP);
VAR
LEFTKIND,
RIGHTKIND: CHAR; (* INTERNAL TYPE OF OPERANDS *)
BEGIN
IF LEFTSIDE <> NIL THEN
IF LEFTSIDE@.FORM = SUBRANGE THEN
LEFTSIDE := LEFTSIDE@.RANGETYPE;
LEFTKIND := GETTYPE (LEFTSIDE);
RIGHTKIND := GETTYPE (RIGHTSIDE);
IF LEFTKIND <> RIGHTKIND THEN
BEGIN
GEN2T (13 (*CVT*), RIGHTKIND, LEFTKIND);
RIGHTSIDE := LEFTSIDE;
END;
END (* CNVRTTOLHS *);
(*$E------------------------------------------------------------------------
PROCEDURE SELECTOR
------------------------------------------------------------------------- *
)
PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
VAR
LATTR: ATTR;
LCP: CTP;
LMIN,
LMAX: INTEGER;
K: CHAR;
I: INTEGER;
LNGMIN,
LNGMAX: LNGINT;
BEGIN
WITH FCP@, GATTR DO
BEGIN TYPTR := IDTYPE; KIND := VARBL;
CASE KLASS OF
TYPES: ;
KONST: ;
VARS:
IF VKIND = ACTUAL THEN
BEGIN ACCESS := DRCT; VLEVEL := VLEV;
DPLMT := VADDR(.1.)
END
ELSE (*VKIND = FORMAL OR ORIGINED*)
BEGIN
IF VKIND = ORIGINED
THEN GENTJ(45 (*LDC*), 'A', VADDR)
ELSE GENTLI(48 (*LOD*), 'A', VLEV, VADDR(.1.));
ACCESS := INDRCT; IDPLMT := 0
END;
FIELD:
WITH DISPLAY(.DISX.) DO
IF OCCUR = CREC THEN
BEGIN ACCESS := DRCT; VLEVEL := CLEV;
DPLMT := CDSPL + FLDADDR
END
ELSE
BEGIN
GENTLI(48(*LOD*),'A',LEVEL,VDSPL) ;
ACCESS := INDRCT; IDPLMT := FLDADDR
END;
PROC: ;
FUNC:
IF PFDECKIND = BUILTIN THEN ERROR(150)
ELSE
IF PFKIND = FORMAL THEN ERROR(151)
ELSE
IF (FPROCP <> FCP) THEN ERROR(177)
ELSE
BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1;
DPLMT := PFADDR;
END
END (* CASE *) ;
END (* WITH *);
IF NOT (SY IN SELECTSYS + FSYS) THEN
BEGIN ERROR(59); SKIP(SELECTSYS + FSYS) END;
WHILE SY IN SELECTSYS DO
BEGIN
(* (. *) IF SY = LBRACK THEN
BEGIN
IF GATTR.TYPTR = NIL THEN
BEGIN
ERROR(138);
INSYMBOL;
SKIP((.RBRACK.)+SELECTSYS+FSYS)
END
ELSE
BEGIN
IF GATTR.TYPTR@.FORM = ARRAYS THEN
REPEAT LATTR := GATTR;
WITH LATTR DO
IF TYPTR <> NIL THEN
IF TYPTR@.FORM <> ARRAYS THEN
BEGIN ERROR(138); TYPTR := NIL END;
LOADADDRESS;
INSYMBOL; EXPRESSION(FSYS + (.COMMA,RBRACK.));
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM <> SCALAR THEN ERROR(113);
IF LATTR.TYPTR <> NIL THEN
WITH LATTR.TYPTR@ DO
BEGIN
IF COMPTYPES(INXTYPE,GATTR.TYPTR) THEN
BEGIN
IF INXTYPE <> NIL THEN
BEGIN
CHKBNDS (INXTYPE, GATTR.TYPTR, 139);
K := GETTYPE (GATTR.TYPTR);
IF K <> 'I' THEN
GEN2T (13 (*CVT*), K, 'I');
GETBOUNDS (INXTYPE, LNGMIN, LNGMAX);
LMIN := MAKESHORT (LNGMIN);
IF LMIN > 0 THEN
GENTI (16 (*DEC*), 'I', LMIN)
ELSE IF LMIN < 0 THEN
GENTI (34 (*INC*), 'I', ABS (LMIN
)); END
END
ELSE ERROR(139);
WITH GATTR DO
BEGIN TYPTR := AELTYPE; KIND := VARBL;
ACCESS := INDRCT; IDPLMT := 0 ;
IF GATTR.TYPTR <> NIL THEN
BEGIN LMIN := TYPTR@.SIZE ;
GENI(41(*IXA*),LMIN)
END (* TYPTR <> NIL *) ;
END (* WITH GATTR DO *) ;
END
UNTIL SY <> COMMA
ELSE IF GATTR.TYPTR@.FORM = STRINGS THEN
BEGIN
LOADADDRESS;
INSYMBOL;
EXPRESSION(FSYS + (.RBRACK.));
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF COMPTYPES(GATTR.TYPTR,INT2PTR)
THEN CNVRTTOLHS (INT2PTR,GATTR.TYPTR)
ELSE ERROR (139);
WITH GATTR DO
BEGIN
TYPTR := CHARPTR;
KIND := VARBL;
ACCESS:= INDRCT;
IDPLMT:= ALIGNMENT - 1;
END;
GENI(41(*IXA*),1);
END
ELSE
BEGIN
ERROR(138);
INSYMBOL;
SKIP((. RBRACK .)+SELECTSYS+FSYS)
END
END; (* IF GATTR.TYPTR = NIL *)
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
END (* IF SY = LBRACK *)
ELSE
(* . *) IF SY = PERIOD THEN
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR <> NIL THEN
IF TYPTR@.FORM <> RECORDS THEN
BEGIN ERROR(140); TYPTR := NIL END;
INSYMBOL;
IF SY = IDENT THEN
BEGIN
IF TYPTR <> NIL THEN
BEGIN SEARCHSECTION(TYPTR@.FSTFLD,LCP);
IF LCP = NIL THEN
BEGIN ERROR(152); TYPTR := NIL END
ELSE
WITH LCP@ DO
BEGIN TYPTR := IDTYPE;
CASE ACCESS OF
DRCT: DPLMT := DPLMT + FLDADDR;
INDRCT: IDPLMT := IDPLMT + FLDADDR
END
END
END;
INSYMBOL
END (* SY = IDENT *)
ELSE ERROR(2)
END (* WITH GATTR *)
END (* IF SY = PERIOD *)
ELSE
(* @ *) BEGIN
IF GATTR.TYPTR <> NIL THEN
WITH GATTR,TYPTR@ DO
IF (FORM = POINTER) THEN
BEGIN
LOAD ;
IF DEBUG THEN GENT2I (6 (*CHK*), 'A', 0, 0);
TYPTR := ELTYPE;
WITH GATTR DO
BEGIN KIND := VARBL;
ACCESS := INDRCT;
IDPLMT := 0
END
END
ELSE IF FORM = FILES THEN BEGIN
TYPTR:=FILTYPE;
GATTR.KIND := FILEPTR
END
ELSE ERROR(141);
INSYMBOL
END;
IF NOT (SY IN FSYS + SELECTSYS) THEN
BEGIN ERROR(6); SKIP(FSYS + SELECTSYS) END ;
END (* WHILE *) ;
END (* SELECTOR *) ;
(* -------------------------------------------------------------------------
PROCEDURE CALL
------------------------------------------------------------------------- *
)
PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
VAR LKEY: STDNAMES;
(* -------------------------------------------------------------------------
PROCEDURE VARIABLE
------------------------------------------------------------------------- *
)
PROCEDURE VARIABLE(FSYS: SETOFSYS);
VAR LCP: CTP;
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID((.VARS,FIELD.),LCP); INSYMBOL END
ELSE BEGIN ERROR(2); LCP := UVARPTR END;
SELECTOR(FSYS,LCP)
END (* VARIABLE *) ;
(* -------------------------------------------------------------------------
STANDARD PROCEDURE CALL HANDLERS
------------------------------------------------------------------------- *
)
PROCEDURE IFNOTINTEGERTHENERROR (ERR: INTEGER);
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF INTTYPE(GATTR.TYPTR) THEN
BEGIN
IF GATTR.TYPTR <> INT2PTR THEN
GEN2T(13 (*CVT*), GETTYPE(GATTR.TYPTR), 'I');
GENTI(116 (*ARG*), 'I', SYSTEM);
END
ELSE
ERROR(ERR);
END (* IFNOTINTEGERTHENERROR *);
PROCEDURE RWSETUP(DEFAULTFILE: CTP; VAR ACTUAL:CTP;
RD: BOOLEAN; VAR TEXTF: BOOLEAN; DELAY:BOOLEAN);
(* TO SET UP FILE ADDRESS PARAMETER FOR READ/WRITE *)
VAR LCP: CTP; SAVED: BOOLEAN; TEMPSY: SYMBOL;
BEGIN SAVED := TRUE ;
IF SY = IDENT THEN
BEGIN SEARCHID((.VARS,FIELD,FUNC,KONST.),LCP) ;
IF LCP@.IDTYPE <> NIL THEN
IF LCP@.IDTYPE@.FORM = FILES THEN SAVED := FALSE;
END (*SY = IDENT*) ;
IF SAVED THEN BEGIN IF DEFAULTFILE <> NIL THEN LCP := DEFAULTFILE
ELSE BEGIN IF RD
THEN ERROR(175)
ELSE ERROR(176)
; LCP := UVARPTR
END;
TEMPSY := SY; SY := COMMA
END
ELSE INSYMBOL ;
TEXTF := LCP@.IDTYPE = TEXTPTR;
IF TEXTF OR NOT DELAY THEN BEGIN
GENI(112 (*MST*),0 (*BUILTIN CALL*));
SELECTOR(FSYS+(.COMMA,RPARENT.),LCP) ;
LOADADDRESS; (*GET FILE ADR*)
GENTI(116 (*ARG*), 'A', 0);
END;
ACTUAL := LCP;
IF SAVED THEN SY := TEMPSY;
END (* RWSETUP *) ;
PROCEDURE GETPUTPAGE;
VAR MKEY: MNRANGE;
TFILE: CTP;
TEXTF,PARAMS,RD: BOOLEAN;
BEGIN
IF SY = LPARENT THEN BEGIN PARAMS := TRUE; INSYMBOL END
ELSE PARAMS := FALSE;
IF LKEY = XGET THEN BEGIN TFILE := STDINPUT(*GET*);
RD := TRUE END
ELSE BEGIN TFILE := STDOUTPUT(*PUT,PAGE*);RD := FALSE E
ND; RWSETUP(TFILE,TFILE,RD,TEXTF,FALSE); (*DEFAULT IS IN 'TFILE'*)
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM <> FILES THEN ERROR(116);
IF LKEY = XGET THEN MKEY := 31(*GET *)
ELSE IF LKEY = XPUT THEN MKEY := 68(*PUT *)
ELSE MKEY :=64(*PAGE*);
GEN(MKEY(* GET,PUT *)) ;
IF PARAMS THEN IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (* GETPUTPAGE *) ;
PROCEDURE CHECKFORCHAR;
BEGIN
IF GATTR.TYPTR = CHARPTR THEN
BEGIN
GEN2T(13 (*CVT*), 'C', 'S');
GATTR.TYPTR := SINGLECHARSTRING;
END;
END (* CHECKFORCHAR *);
PROCEDURE RESETREWRITE;
VAR MKEY: MNRANGE;
TFILE: CTP;
TEXTF,PARAMS,RD: BOOLEAN;
BEGIN
IF SY = LPARENT THEN BEGIN PARAMS := TRUE; INSYMBOL END
ELSE PARAMS := FALSE;
IF LKEY = XRESET THEN BEGIN TFILE := STDINPUT(*RST*);
RD := TRUE END
ELSE BEGIN TFILE := STDOUTPUT(*RWT*);RD := FALSE END
; RWSETUP(TFILE,TFILE,RD,TEXTF,FALSE); (*DEFAULT IS IN 'TFILE'*)
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM <> FILES THEN ERROR(116);
IF SY = COMMA THEN BEGIN
IF STANDARD THEN WARNING(508);
LOADADDRESS; (*OF FILE DESCRIPTOR FOR 'AFI'*)
INSYMBOL;
EXPRESSION(FSYS + (.RPARENT.)); LOAD;
CHECKFORCHAR;
IF GATTR.TYPTR <> NIL THEN
IF (GATTR.TYPTR@.FORM <> STRINGS) THEN
ERROR(116)
ELSE
GENT2I(116 (*ARG*), 'S', 0, GATTR.TYPTR@.SIZE);
(*IF NOT CHARARRAY(GATTR.TYPTR) THEN ERROR(116); *)
GEN(2 (* AFI *))
END;
IF LKEY = XRESET THEN MKEY := 80(*RST*)
(*AFI LEAVES DESCRIPTOR ON STK*)
ELSE MKEY := 81(*RWT*);
GEN(MKEY (* RST,RWT *)) ;
IF PARAMS THEN IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (* RESETREWRITE *) ;
PROCEDURE READ1;
VAR PARAMS,TEXTF: BOOLEAN;
K:CHAR; FSP:STP;
ACTUALFILE: CTP;
BEGIN
IF SY = LPARENT THEN BEGIN PARAMS := TRUE; INSYMBOL END
ELSE PARAMS := FALSE;
RWSETUP(STDINPUT,ACTUALFILE,TRUE,TEXTF,TRUE); (*DEFAULT IS 'INPUT'*
) IF PARAMS THEN
BEGIN
IF ACTUALFILE@.IDTYPE <> NIL THEN
FSP := ACTUALFILE@.IDTYPE@.FILTYPE
ELSE
FSP := NIL;
K := GETTYPE(FSP);
IF (SY = RPARENT) AND (LKEY = XREAD) THEN ERROR(116);
(*'6' IS 'READ'; IT'S REQ'D TO HAVE AT LEAST
ONE PARAM; CAREFUL IF PROC #'S CHANGE *)
IF SY = COMMA THEN INSYMBOL;
IF SY = IDENT THEN
REPEAT VARIABLE(FSYS + (.COMMA,RPARENT.));
LOADADDRESS;
IF TEXTF THEN BEGIN
GENTI(116 (*ARG*), 'A', 0);
IF GATTR.TYPTR <> NIL THEN
IF CHARARRAY(GATTR.TYPTR) THEN
BEGIN
GENTI(45(*LDC*),'I',GATTR.TYPTR@.SIZE DIV CHARSIZE);
GENTI(116 (*ARG*), 'I', 0);
GEN (114 (*RDV*));
END
ELSE
IF GATTR.TYPTR@.FORM = STRINGS THEN
BEGIN
GENTI(45(*LDC*),'I',GATTR.TYPTR@.SIZE(*STRSZ*));
GENTI(116 (*ARG*), 'I', 0);
GEN(76 (*RDS*))
END
ELSE
BEGIN
K := GETTYPE (GATTR.TYPTR);
IF K = 'J' THEN
GEN(73 (*RDJ*))
ELSE
IF K = 'H' THEN
GEN(117 (*RDH*))
ELSE
IF K = 'I' THEN
GEN(72 (*RDI*))
ELSE
IF K = 'R' THEN
GEN(75 (*RDR*))
ELSE
IF K = 'C' THEN
GEN(70 (*RDC*))
ELSE
IF K = 'B' THEN
GEN(69 (*RDB*))
ELSE ERROR(116) ;
END ;
END ELSE (*NONTEXT FILE*)
IF COMPTYPES(FSP,GATTR.TYPTR) THEN
BEGIN
GENI (112(*MST*),0);
WITH ACTUALFILE@ DO IF VKIND = ACTUAL
THEN GENLI (44 (*LDA*),VLEV,VADDR(.1.))
ELSE GENTLI(48 (*LOD*),'A',VLEV,VADDR(.1.));
GENTI(116 (*ARG*), 'A', 0);
GEN (65 (*PEE*));
IF K = 'V' THEN BEGIN
GENT2I(35 (*IND*),K,0,FSP@.SIZE);
GENTI (94 (*STO*),K,FSP@.SIZE);
END
ELSE BEGIN
GENTI(35 (*IND*),K,0);
GENT (94 (*STO*),K);
END;
GENI (112(*MST*),0);
WITH ACTUALFILE@ DO IF VKIND = ACTUAL
THEN GENLI (44 (*LDA*),VLEV,VADDR(.1.))
ELSE GENTLI(48 (*LOD*),'A',VLEV,VADDR(.1.));
GENTI(116 (*ARG*), 'A', 0);
GEN(31(*GET*));
END
ELSE ERROR(127);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST ;
IF TEXTF THEN
IF LKEY = XREADLN THEN GEN(78(*RLN*)) ELSE GEN(111(*EIO*));
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END
ELSE IF LKEY = XREADLN THEN GEN(78 (*RLN*)) ELSE ERROR(9);
END (* READ1 *) ;
PROCEDURE WRITE1;
VAR LSP: STP; DEFAULT : BOOLEAN;
PARAMS,TEXTF: BOOLEAN;
K:CHAR; FSP:STP;
ACTUALFILE: CTP;
BEGIN
IF SY = LPARENT THEN BEGIN PARAMS := TRUE; INSYMBOL END
ELSE PARAMS := FALSE;
RWSETUP(STDOUTPUT,ACTUALFILE,FALSE,TEXTF,TRUE);
(*DEFAULT IS 'OUTPUT'*)
IF PARAMS THEN
BEGIN
IF ACTUALFILE@.IDTYPE <> NIL THEN
FSP := ACTUALFILE@.IDTYPE@.FILTYPE
ELSE
FSP := NIL;
K := GETTYPE(FSP);
TEST := FALSE ;
IF (SY = RPARENT) THEN
BEGIN TEST := TRUE ;
IF LKEY = XWRITE THEN ERROR(116) ; END ;
(*'7' IS 'WRITE'; IT'S REQ'D TO HAVE AT LEAST
ONE PARAM; CAREFUL IF PROC #'S CHANGE *)
IF SY = COMMA THEN INSYMBOL ;
IF NOT TEST THEN
REPEAT IF TEXTF THEN BEGIN
EXPRESSION(FSYS+(.COMMA,COLON,RPARENT.)) ;
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
BEGIN
K := GETTYPE(LSP);
LOAD;
IF (K = 'S') OR (K = 'V') THEN
GENT2I(116 (*ARG*), K, 0, LSP@.SIZE)
ELSE
GENTI(116 (*ARG*), K, 0);
END;
IF SY = COLON THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + (.COMMA,COLON,RPARENT.));
LOAD; DEFAULT := FALSE;
IFNOTINTEGERTHENERROR (116)
END
ELSE DEFAULT := TRUE;
IF SY = COLON THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + (.COMMA,RPARENT.));
IF LSP <> REALPTR THEN ERROR(124);
LOAD; ERROR(398);
IFNOTINTEGERTHENERROR (116)
END
ELSE
IF LSP = INT4PTR THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*),'I',12);
GENTI(116(*ARG*),'I',SYSTEM)
END; (*THEN*)
GEN(105 (*WRJ*))
END (*THEN*)
ELSE IF LSP = INT1PTR THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*),'I',5);
GENTI(116(*ARG*),'I',SYSTEM)
END; (*THEN*)
GEN(118 (*WRH*))
END (*THEN*)
ELSE IF LSP = INT2PTR THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*), 'I', 7);
GENTI(116 (*ARG*), 'I', SYSTEM);
END;
GEN(104 (*WRI*))
END
ELSE
IF LSP = REALPTR THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*), 'I', 14);
GENTI(116 (*ARG*), 'I', 0);
END;
GEN(107 (*WRR*))
END
ELSE
IF LSP = CHARPTR THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*), 'I', 1);
GENTI(116 (*ARG*), 'I', 0);
END;
GEN(102 (*WRC*))
END
ELSE
IF LSP = BOOLPTR THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*), 'I', 5);
GENTI(116 (*ARG*), 'I', 0);
END;
GEN(101 (*WRB*))
END
ELSE
IF LSP <> NIL THEN
BEGIN
IF LSP@.FORM = SCALAR THEN ERROR(398)
ELSE
IF CHARARRAY(LSP) THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*), 'I', LSP@.SIZE);
GENTI(116 (*ARG*), 'I', 0);
END;
GENTI(45(*LDC*),'I',LSP@.SIZE); (*VAR SIZE
*) GENTI(116 (*ARG*), 'I', 0);
GEN (115 (*WRV*))
END
ELSE
IF LSP@.FORM = STRINGS THEN
BEGIN
IF DEFAULT THEN
BEGIN
GENTI(45 (*LDC*), 'I', 0);
GENTI(116 (*ARG*), 'I', 0);
END;
GEN(108 (*WRS*))
END
ELSE ERROR(116)
END;
END ELSE (*NONTEXT FILE*)
BEGIN WITH ACTUALFILE@ DO IF VKIND = ACTUAL
THEN GENTLI(48 (*LOD*),'A',VLEV,VADDR(.1.))
ELSE BEGIN
GENTLI(48 (*LOD*),'A',VLEV,VADDR(.1.))
; GENTI (35 (*IND*),'A',0);
END;
EXPRESSION(FSYS+(.COMMA,COLON,RPARENT.)) ;
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN LOAD;
IF NOT COMPTYPES(FSP,LSP) THEN ERROR(127);
IF K = 'V'
THEN GENTI (94 (*STO*),K,FSP@.SIZE)
ELSE GENT (94 (*STO*),K);
GENI (112(*MST*),0);
WITH ACTUALFILE@ DO IF VKIND = ACTUAL
THEN GENLI (44 (*LDA*),VLEV,VADDR(.1.))
ELSE GENTLI(48 (*LOD*),'A',VLEV,VADDR(.1.));
GENTI(116 (*ARG*), 'A', 0);
GENTI(116 (*ARG*), 'A', 0);
GEN(68(*PUT*));
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL;
UNTIL TEST;
IF TEXTF THEN
IF LKEY = XWRITELN THEN GEN(100 (*WLN*)) ELSE GEN(111(*EIO*));
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (*SY = LPARENT*)
ELSE IF LKEY = XWRITELN THEN GEN(100 (*WLN*)) ELSE ERROR(9);
END (* WRITE1 *) ;
(* PROCEDURE PACK1;
VAR LSP,LSP1: STP;
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
ERROR(398); VARIABLE(FSYS + (.COMMA,RPARENT.));
LSP := NIL; LSP1 := NIL;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR@ DO
IF FORM = ARRAYS THEN
BEGIN LSP := INXTYPE; LSP1 := AELTYPE END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
EXPRESSION(FSYS + (.COMMA,RPARENT.));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM <> SCALAR THEN ERROR(116)
ELSE
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
VARIABLE(FSYS + (.RPARENT.));
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR@ DO
IF FORM = ARRAYS THEN
BEGIN
IF NOT COMPTYPES(AELTYPE,LSP1)
OR NOT COMPTYPES(INXTYPE,LSP) THEN
ERROR(116)
END
ELSE ERROR(116);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END;*) (* PACK *)
(* PROCEDURE UNPACK1;
VAR LSP,LSP1: STP;
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
ERROR(398); VARIABLE(FSYS + (.COMMA,RPARENT.));
LSP := NIL; LSP1 := NIL;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR@ DO
IF FORM = ARRAYS THEN
BEGIN LSP := INXTYPE; LSP1 := AELTYPE END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
VARIABLE(FSYS + (.COMMA,RPARENT.));
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR@ DO
IF FORM = ARRAYS THEN
BEGIN
IF NOT COMPTYPES(AELTYPE,LSP1)
OR NOT COMPTYPES(INXTYPE,LSP) THEN
ERROR(116)
END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
EXPRESSION(FSYS + (.RPARENT.));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM <> SCALAR THEN ERROR(116)
ELSE
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END;*) (* UNPACK *)
PROCEDURE NEWDISPOSE;
VAR LSP,LSP1: STP; VARTS: INTEGER;
LSIZE: ADDRRANGE; LVAL: VALU;
FOUND: BOOLEAN;
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
GENI(112 (*MST*),0 (*BUILTIN CALL*));
VARIABLE(FSYS + (.COMMA,RPARENT.)); LOADADDRESS;
LSP := NIL; VARTS := 0; LSIZE := 0;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR@ DO
IF FORM = POINTER THEN
BEGIN
IF ELTYPE <> NIL THEN
BEGIN LSIZE := ELTYPE@.SIZE;
IF ELTYPE@.FORM = RECORDS THEN LSP := ELTYPE@.RECVAR
END
END
ELSE ERROR(116);
WHILE SY = COMMA DO
BEGIN FOUND := FALSE;
INSYMBOL;CONSTANT(FSYS + (.COMMA,RPARENT.),LSP1,LVAL);
VARTS := VARTS + 1;
(* CHECK TO INSERT HERE: IS CONSTANT IN TAGFIELDTYPE RANGE *)
IF LSP = NIL THEN ERROR(158)
ELSE
IF LSP@.FORM <> TAGFLD THEN ERROR(162)
ELSE
IF LSP@.TAGFIELDP <> NIL THEN
IF CHARARRAY(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159)
ELSE
IF COMPTYPES(LSP@.TAGFIELDP@.IDTYPE,LSP1) THEN
BEGIN
LSP1 := LSP@.FSTVAR;
LSIZE := LSP@.SIZE; LSP := NIL;
WHILE NOT FOUND AND (LSP1 <> NIL) DO
WITH LSP1@ DO
IF VARVAL.IVAL = LVAL.IVAL THEN
BEGIN LSIZE := SIZE; LSP := SUBVAR;
FOUND := TRUE
END
ELSE LSP1 := NXTVAR;
END
ELSE ERROR(116);
END (* WHILE *) ;
IF LKEY = XNEW THEN GENI(60(* NEW *),LSIZE)
ELSE GENI(19(* DIS *),LSIZE);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (* NEW *) ;
PROCEDURE MARK1;
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
GENI(112 (*MST*),0 (*BUILTIN CALL*));
VARIABLE(FSYS+(.RPARENT.));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM = POINTER THEN
BEGIN
LOADADDRESS;
GENTI(116 (*ARG*), 'A', 0);
GEN(58 (*MRK*));
END
ELSE ERROR(125);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END(* MARK1 *);
PROCEDURE RELEASE1;
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
GENI(112 (*MST*),0 (*BUILTIN CALL*));
VARIABLE(FSYS+(.RPARENT.));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM = POINTER THEN
BEGIN
LOAD;
GENTI(116 (*ARG*), 'A', 0);
GEN(79 (*RLS*));
END
ELSE ERROR(125);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (* RELEASE1 *);
PROCEDURE HALT1 ;
(* *THIS PROCEDURE IS TO FACILITATE COMMUNICATION WITH THE OUTSIDE
* WORLD AND PROVIDE BREAK POINTS IN THE PASCAL PROGRAM.
* 'HALT(I, R)' RETURNS THE INTEGER CONSTANT I TO THE OPERATING
* SYSTEM. THIS PARAMETER IS INTENDED TO BE USED AS A
* 'FUNCTION NUMBER' *)
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
GENI(112 (*MST*),0 (*BUILTIN CALL*));
EXPRESSION(FSYS+(.RPARENT,COMMA.)) ;
LOAD;
IFNOTINTEGERTHENERROR (116);
GENI(26 (*EXI*), 1) ;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END; (* HALT1 *)
PROCEDURE ABS1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF INTTYPE(GATTR.TYPTR) OR (GATTR.TYPTR = REALPTR)
THEN GENT(0 (*AB*),GETTYPE(GATTR.TYPTR))
ELSE BEGIN ERROR(125); GATTR.TYPTR := INT4PTR END
END (* ABS *) ;
PROCEDURE SQR1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF INTTYPE(GATTR.TYPTR) OR (GATTR.TYPTR = REALPTR) THEN
GENT(92 (*SQR*), GETTYPE(GATTR.TYPTR))
ELSE
BEGIN
ERROR(125);
GATTR.TYPTR := INT4PTR;
END;
END (* SQR *);
(* PROCEDURE ROUND1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> REALPTR THEN ERROR(125);
GENT(110 RND ,'R');
GATTR.TYPTR := INT4PTR
END;*)
(* PROCEDURE TRUNC1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> REALPTR THEN ERROR(125);
GENT(97 TRC ,'R');
GATTR.TYPTR := INT4PTR
END;*) (* TRUNC *)
PROCEDURE ODD1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF (NOT INTTYPE(GATTR.TYPTR))
THEN ERROR(125)
ELSE GENT(63(* ODD *),GETTYPE(GATTR.TYPTR));
GATTR.TYPTR := BOOLPTR
END (* ODD *) ;
PROCEDURE ORD1;
VAR K:CHAR;
BEGIN
WITH GATTR DO
IF TYPTR = NIL
THEN TYPTR := INT2PTR
ELSE
IF TYPTR@.FORM <> SCALAR
THEN BEGIN
ERROR(125);
TYPTR := INT2PTR
END (*THEN*)
ELSE
IF INTTYPE(TYPTR) OR (TYPTR = REALPTR)
THEN BEGIN
ERROR(125);
TYPTR := INT2PTR
END (*THEN*)
ELSE
BEGIN
K := GETTYPE(TYPTR);
IF (K = 'C') OR (K = 'B')
THEN GEN2T(13 (*CVT*),K,'H');
CASE TYPTR@.SIZE OF
1: TYPTR := INT1PTR;
2: TYPTR := INT2PTR;
4: TYPTR := INT4PTR
END (*CASE*)
END (*ELSE*)
END (* ORD1 *) ;
PROCEDURE CHR1;
VAR K: CHAR;
BEGIN
IF GATTR.TYPTR <> NIL THEN
BEGIN
IF INTTYPE(GATTR.TYPTR)
THEN K := GETTYPE(GATTR.TYPTR)
ELSE BEGIN
ERROR(125);
K := 'I'
END; (*ELSE*)
IF DEBUG THEN
IF K = 'J'
THEN GENT2J(6 (*CHK*),K,LONGZERO,LONGORDMAXCHAR)
ELSE GENT2I(6 (*CHK*),K,0,ORDMAXCHAR);
GEN2T(13 (*CVT*),K,'C');
GATTR.TYPTR := CHARPTR
END (*THEN*)
END (* CHR *) ;
PROCEDURE PREDSUCC;
BEGIN (* ERROR(398); *) (* TRANSLATES INTO 'DEC' AND 'INC' *)
IF GATTR.TYPTR <> NIL THEN
IF (GATTR.TYPTR = REALPTR) OR (GATTR.TYPTR@.FORM <> SCALAR) THE
N ERROR(125) ;
IF LKEY = XPRED THEN GENTI(16(*DEC*),GETTYPE(GATTR.TYPTR),1)
ELSE IF LKEY = XSUCC THEN
GENTI(34(*INC*),GETTYPE(GATTR.TYPTR),1)
END (* PREDSUCC *) ;
PROCEDURE EOF1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM <> FILES THEN ERROR(125);
GENTI(116 (*ARG*), 'A', 0);
IF LKEY = XEOF THEN GEN(23(*EOF*))
ELSE GEN(24(*EOL*));
GATTR.TYPTR := BOOLPTR
END (* EOF1 *) ;
(* PROCEDURE SINCOSEXPLOG;
VAR MKEY: MNRANGE;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> REALPTR THEN ERROR(125);
CASE LKEY OF
XSIN: MKEY := 88 SIN ;
XCOS: MKEY := 8 COS ;
XEXP: MKEY := 27 EXP ;
XSQRT: MKEY := 93 SQT ;
XLN: MKEY := 49 LOG ;
XARCTAN: MKEY := 5 ATN
END ;
GEN(MKEY) ;
END;*) (* SINCOSEXPLOG *)
PROCEDURE ERRORIFNOTSTRING;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM = STRINGS THEN
GENT2I(116 (*ARG*), 'S', SYSTEM, GATTR.TYPTR@.SIZE)
ELSE
ERROR(125);
END (* ERRORIFNOTSTRING *);
PROCEDURE STRCONCAT;
BEGIN
ERRORIFNOTSTRING;
IF SY <> COMMA THEN
ERROR(20)
ELSE
WHILE SY = COMMA DO
BEGIN
INSYMBOL;
EXPRESSION(FSYS + (. RPARENT, COMMA .));
LOAD;
CHECKFORCHAR;
ERRORIFNOTSTRING;
GEN(83 (*SCON*));
END;
END (* STRCONCAT *);
PROCEDURE STRDELETEORCOPY(OPKIND: STDNAMES);
VAR
STRPTR: STP;
BEGIN
ERRORIFNOTSTRING;
STRPTR := GATTR.TYPTR;
IF SY = COMMA THEN
INSYMBOL
ELSE
ERROR(20);
EXPRESSION(FSYS + (. COMMA .));
LOAD;
IFNOTINTEGERTHENERROR (125);
IF SY = COMMA THEN
INSYMBOL
ELSE
ERROR(20);
EXPRESSION(FSYS + (. RPARENT .));
LOAD;
IFNOTINTEGERTHENERROR (125);
IF OPKIND = XDELETE THEN
GEN(85 (*SDEL*))
ELSE
GEN(84 (*SCOP*));
GATTR.TYPTR := STRPTR;
END (* STRDELETEORCOPY *);
PROCEDURE STRINSERT;
VAR
STRPTR: STP;
BEGIN
CHECKFORCHAR;
ERRORIFNOTSTRING;
IF SY = COMMA THEN
INSYMBOL
ELSE
ERROR(20);
EXPRESSION (FSYS + (.RPARENT, COMMA.));
LOAD;
ERRORIFNOTSTRING;
STRPTR := GATTR.TYPTR;
IF SY = COMMA THEN
INSYMBOL
ELSE
ERROR(20);
EXPRESSION (FSYS + (. RPARENT .));
LOAD;
IFNOTINTEGERTHENERROR (125);
GEN(89 (*SINS*));
GATTR.TYPTR := STRPTR;
END (* STRINSERT *);
PROCEDURE STRPOS;
BEGIN
ERRORIFNOTSTRING;
IF SY = COMMA THEN
INSYMBOL
ELSE
ERROR(20);
EXPRESSION (FSYS + (. RPARENT .));
LOAD;
CHECKFORCHAR;
ERRORIFNOTSTRING;
GEN(91 (*SPOS*));
GATTR.TYPTR := INT2PTR;
END (* STRPOS *);
PROCEDURE STRLENGTH;
BEGIN
ERRORIFNOTSTRING;
GEN(90 (*SLEN*));
GATTR.TYPTR := INT2PTR;
END (* STRLENGTH *);
(* -------------------------------------------------------------------------
PROCEDURE CALLNONSTANDARD
------------------------------------------------------------------------- *
)
PROCEDURE CALLNONSTANDARD;
VAR NXT,LCP: CTP; LSP: STP; LKIND: IDKIND; LB: BOOLEAN;
LLC: ADDRRANGE; K: CHAR;
BEGIN
GENI(112 (*MST*),1 (*USER CALL*));
WITH FCP@ DO
BEGIN NXT := NEXT; LKIND := PFKIND;
IF (KLASS = FUNC) AND (IDTYPE <> NIL) THEN
GENTI(4 (*AST*),GETTYPE(IDTYPE),IDTYPE@.SIZ
E); (*AST ALLOCATES SPACE ON RUNTIME STK FOR FUNCTION RESULT*)
END;
IF SY = LPARENT THEN
BEGIN LLC := LOCN;
REPEAT LB := FALSE; (*DECIDE IF PROC/FUNC MUST BE PASSED*)
IF LKIND = ACTUAL THEN
BEGIN
IF NXT = NIL THEN ERROR(126)
ELSE LB := NXT@.KLASS IN (.PROC,FUNC.)
END ELSE ERROR(398);
(*FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
IN THIS IMPLEMENTATION, PARAMETER PROC/FUNCS ARE THEREFORE
NOT ALLOWED TO HAVE PROC/FUNC PARAMETERS *)
INSYMBOL;
IF LB THEN (* PASS FUNCTION OR PROCEDURE *)
BEGIN ERROR(398);
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + (.COMMA,RPARENT.)) END
ELSE
BEGIN
IF NXT@.KLASS = PROC THEN SEARCHID((.PROC.),LCP)
ELSE
BEGIN SEARCHID((.FUNC.),LCP);
IF NOT COMPTYPES(LCP@.IDTYPE,NXT@.IDTYPE) THEN
ERROR(128)
END;
INSYMBOL;
IF NOT (SY IN FSYS + (.COMMA,RPARENT.)) THEN
BEGIN ERROR(6); SKIP(FSYS + (.COMMA,RPARENT.)) EN
D END
END (* IF LB *)
ELSE
BEGIN EXPRESSION(FSYS + (.COMMA,RPARENT.));
IF GATTR.TYPTR <> NIL THEN
IF LKIND = ACTUAL THEN
BEGIN
IF NXT <> NIL THEN
BEGIN LSP := NXT@.IDTYPE;
IF LSP <> NIL THEN
BEGIN
IF (NXT@.VKIND = ACTUAL) THEN
IF LSP@.FORM <= POWER THEN
BEGIN
LOAD;
IF COMPTYPES (LSP, GATTR.TYPTR) T
HEN CHKBNDS (LSP, GATTR.TYPTR, 142
);
IF INTTYPE (GATTR.TYPTR) THEN
CNVRTTOLHS (LSP, GATTR.TYPTR);
END
ELSE
BEGIN
LOAD; (*****LOADADDRESS;*****)
IF LSP@.FORM = STRINGS THEN
GEN2TI(13(*CVT*),'S','U',LSP@.SIZE(*STRSZ
*)) (*CONVERTS NORMALIZED STRING TO
FULL SIZE STRING FOR PARAM PASS*)
ELSE IF CHARARRAY(LSP) AND
(GATTR.TYPTR@.FORM=STRINGS) THEN
BEGIN
GEN2TI(13(*CVT*),'S','V',LSP@.SIZ
E); GATTR.TYPTR := LSP
END
END
ELSE
IF (GATTR.KIND = VARBL) OR
(GATTR.KIND = FILEPTR) THEN
BEGIN LOADADDRESS;
IF GATTR.TYPTR@.SIZE <> LSP@.SIZE THE
N ERROR(142) ;
END
ELSE ERROR(154);
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN
ERROR(142);
WITH GATTR DO
IF (KIND = VARBL) OR (KIND = FILEPTR)
THEN
K := 'A'
ELSE
K := GETTYPE(LSP);
IF (K = 'S') OR (K = 'V') THEN
GENT2I(116 (*ARG*), K, 1, LSP@.SIZE)
ELSE
GENTI(116 (*ARG*), K, 1);
END
END
END
ELSE (* LKIND = FORMAL *)
BEGIN (* PASS FORMAL PARAM *)
END
END;
IF (LKIND = ACTUAL) AND (NXT <> NIL) THEN NXT := NXT@.NEXT
UNTIL SY <> COMMA;
LOCN := LLC;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (* IF LPARENT *);
IF LKIND = ACTUAL THEN
BEGIN IF NXT <> NIL THEN ERROR(126);
GENTL(11(*CUP*),'$',FCP@.PFNAME);
KOUNT := KOUNT - 1;
LABELEDKOUNT := TRUE;
GENKOUNT (FALSE);
END;
IF (FCP@.KLASS = FUNC) AND (FCP@.IDTYPE <> NIL) THEN
WITH FCP@.IDTYPE@ DO
IF (FORM = STRINGS) THEN GEN2TI(13 (*CVT*),'U','S',SIZE);
(*NORMALIZE STRING FUNCTION RESULT*
) GATTR.TYPTR := FCP@.IDTYPE ;
END (* CALLNONSTANDARD *) ;
BEGIN (* **START** CALL *)
IF FCP@.PFDECKIND = BUILTIN THEN
BEGIN
LKEY := FCP@.KEY;
IF FCP@.KLASS = PROC THEN
CASE LKEY OF
XNEW,
XDISPOSE: NEWDISPOSE;
XGET,
XPUT,
XPAGE: GETPUTPAGE;
XRESET,
XREWRITE: RESETREWRITE;
XREAD,
XREADLN: READ1;
XWRITE,
XWRITELN: WRITE1;
XPACK: (*PACK1; *)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END;
XUNPACK: (*UNPACK1; *)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END;
XRELEASE: RELEASE1;
XMARK: MARK1;
XHALT: HALT1
END
ELSE
BEGIN IF LKEY IN (.XROUND,XTRUNC,XEOF,XEOLN,XSIN,XCOS,
XEXP,XSQRT,XLN,XARCTAN,XCONCAT,XCOPY,
XDELETE,XINSERT,XPOS,XLENGTH,XPOSITION.)
THEN GENI (112 (* MST *), 0);
IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
IF LKEY IN (.XCONCAT, XCOPY, XDELETE, XINSERT, XPOS .)
THEN
EXPRESSION (FSYS + (. COMMA .))
ELSE
EXPRESSION (FSYS + (.RPARENT .));
IF (LKEY = XEOF) OR (LKEY = XEOLN) THEN
LOADADDRESS ELSE LOAD;
CASE LKEY OF
XROUND: (*ROUND1; *)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END;
XABS: ABS1;
XSQR: SQR1;
XTRUNC: (*TRUNC1; *)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END;
XODD: ODD1;
XORD: ORD1;
XCHR: CHR1;
XPRED,
XSUCC: PREDSUCC;
XCLOCK: (*CLOCK; *)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END;
XEOF,
XEOLN: EOF1;
XSIN,
XCOS,
XEXP,
XSQRT,
XLN,
XARCTAN: (*SINCOSEXPLOG; *)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END;
XCONCAT: STRCONCAT;
XCOPY,
XDELETE: STRDELETEORCOPY(LKEY);
XINSERT: STRINSERT;
XPOS: STRPOS;
XLENGTH: STRLENGTH;
XPOSITION: (*STRING FUNCTIONS*)
BEGIN
ERROR (398);
SKIP (FSYS + (.RPARENT.))
END
END (* CASE LKEY OF *) ;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END;
END (* STANDARD PROCEDURES AND FUNCTIONS *)
ELSE CALLNONSTANDARD
END (* CALL *) ;
PROCEDURE CONVERTTOLIKEINTEGERS (VAR LEFTSIDE, RIGHTSIDE: STP);
VAR
LEFTKIND,
RIGHTKIND,
RESULTKIND: CHAR;
RESULTTYPE: STP;
FUNCTION MAX (ARG1, ARG2: CHAR): CHAR;
BEGIN (*MAX*)
IF ARG1 > ARG2 THEN
MAX := ARG1
ELSE
MAX := ARG2;
END (*MAX*);
BEGIN (* CONVERTTOLIKEINTEGERS *)
LEFTKIND := GETTYPE (LEFTSIDE);
RIGHTKIND := GETTYPE (RIGHTSIDE);
RESULTKIND := MAX (ARITHMETICSIZE, MAX (LEFTKIND, RIGHTKIND
));
IF RESULTKIND = 'H' THEN
RESULTTYPE := INT1PTR
ELSE IF RESULTKIND = 'I' THEN
RESULTTYPE := INT2PTR
ELSE
RESULTTYPE := INT4PTR;
IF LEFTKIND < RESULTKIND THEN
BEGIN
GEN2T (14 (*CVB*), LEFTKIND, RESULTKIND);
LEFTSIDE := RESULTTYPE;
END;
IF RIGHTKIND < RESULTKIND THEN
BEGIN
GEN2T (13 (*CVT*), RIGHTKIND, RESULTKIND);
RIGHTSIDE := RESULTTYPE;
END;
END (* CONVERTTOLIKEINTEGERS *);
PROCEDURE ILLEGALOPERANDS;
BEGIN (* ILLEGALOPERANDS *)
ERROR (134);
GATTR.TYPTR := NIL;
END (* ILLEGALOPERANDS *);
FUNCTION COMPATABLESETS (TYP1, TYP2: STP): BOOLEAN;
BEGIN (* COMPATABLESETS *)
COMPATABLESETS := FALSE;
IF TYP1 <> NIL THEN
COMPATABLESETS := (TYP1@.FORM = POWER)
AND COMPTYPES (TYP1, TYP2);
END (* COMPATABLESETS *);
(*$E------------------------------------------------------------------*)
(* *)
(* PROCEDURE CONSTFACTOR (TYP,VAL) *)
(* *)
(* THIS PROCEDURE HANDLES A FACTOR WHICH IS A CONSTANT. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE CONSTFACTOR (TYP: STP; VAL: VALU);
BEGIN (*CONSTFACTOR*)
WITH GATTR DO
BEGIN
KIND := CST;
IF INTTYPE(TYP) AND (ARITHMETICSIZE > GETTYPE(TYP))
THEN
IF ARITHMETICSIZE = 'J'
THEN
BEGIN (*CONVERT UP TO A LONG INTEGER*)
NEW (CVAL.VALP,LINT);
MAKELONG (VAL.IVAL,CVAL.VALP@.LINTVAL);
TYPTR := INT4PTR
END (*THEN*)
ELSE
BEGIN
TYPTR := INT2PTR;
CVAL.IVAL := VAL.IVAL
END (*ELSE*)
ELSE
BEGIN
TYPTR := TYP;
CVAL := VAL
END (*ELSE*)
END (*WITH*)
END; (*CONSTFACTOR*)
PROCEDURE TERM(FSYS: SETOFSYS);
VAR
LATTR: ATTR;
LOP: OPERATOR;
INTEGERS: BOOLEAN;
PROCEDURE FACTOR(FSYS: SETOFSYS);
VAR LCP: CTP; VARPART: BOOLEAN;
C : CHAR;
CSTPART: SETCONST; LSP: STP; I: 0..64;
RNGTYPE: STP;
CSTVAL,CSTVAL2: INTEGER;
RANGED,CONSTEL: BOOLEAN;
BEGIN (* **START** FACTOR *)
IF NOT (SY IN FACBEGSYS) THEN
BEGIN ERROR(58); SKIP(FSYS + FACBEGSYS);
GATTR.TYPTR := NIL
END;
WHILE SY IN FACBEGSYS DO
BEGIN
CASE SY OF
(* ID *) IDENT:
BEGIN SEARCHID((.KONST,VARS,FIELD,FUNC.),LCP);
INSYMBOL;
IF LCP@.KLASS = FUNC THEN
BEGIN CALL(FSYS,LCP);
WITH GATTR DO
BEGIN KIND := EXPR;
IF TYPTR <> NIL THEN
IF TYPTR@.FORM=SUBRANGE THEN
TYPTR := TYPTR@.RANGETYPE
END
END
ELSE
IF LCP@.KLASS = KONST THEN
WITH LCP@ DO
CONSTFACTOR (IDTYPE,VALUES)
ELSE
BEGIN SELECTOR(FSYS,LCP);
IF GATTR.TYPTR<>NIL THEN
(* ELIM.SUBR.TYPES TO SIMPLIFY LATER TESTS *)
WITH GATTR,TYPTR@ DO
IF FORM = SUBRANGE THEN
TYPTR := RANGETYPE
END
END;
(* CST *) INT1CONST:
BEGIN
CONSTFACTOR (INT1PTR,VAL);
INSYMBOL
END; (*INT1CONST*)
INT2CONST:
BEGIN
CONSTFACTOR (INT2PTR,VAL);
INSYMBOL
END; (*INT2CONST*)
INT4CONST:
BEGIN
CONSTFACTOR (INT4PTR,VAL);
INSYMBOL
END; (*INT4CONST*)
REALCONST:
BEGIN
WITH GATTR DO
BEGIN TYPTR := REALPTR; KIND := CST;
(* CVAL := VAL ; *) CVAL.VALP := VAL.VALP ;
END;
INSYMBOL
END;
(* STRG *) STRINGCONST:
BEGIN
WITH GATTR DO
BEGIN
IF LNGTH = 1 THEN TYPTR := CHARPTR
ELSE
BEGIN NEW(LSP,STRINGS);
WITH LSP@ DO
BEGIN FORM:=STRINGS;
SIZE := LNGTH+ALIGNMENT
END;
TYPTR := LSP
END;
KIND := CST ; CVAL := VAL ;
END;
INSYMBOL
END;
(* ( *) LPARENT:
BEGIN INSYMBOL; EXPRESSION(FSYS + (.RPARENT.));
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END;
(* NOT *) NOTSY:
BEGIN INSYMBOL; FACTOR(FSYS);
LOAD; GEN(62(* NOT *));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN
BEGIN ERROR(135); GATTR.TYPTR := NIL END;
END;
(* (. *) LBRACK:
BEGIN INSYMBOL; CSTPART := (. .); VARPART := FALSE;
CONSTEL := FALSE;
RANGED := FALSE;
NEW(LSP,POWER);
WITH LSP@ DO
BEGIN ELSET:=NIL;SIZE:=SETSIZE;FORM:=POWER END;
IF SY = RBRACK THEN
BEGIN
WITH GATTR DO
BEGIN TYPTR := LSP; KIND := CST END;
INSYMBOL
END
ELSE
BEGIN
REPEAT
(*CF <--------------------- *)
EXPRESSION(FSYS + (. COMMA, RANGE, RBRACK .));
WITH GATTR DO
BEGIN
IF TYPTR <> NIL THEN
IF TYPTR@.FORM <> SCALAR THEN
BEGIN ERROR(136); TYPTR := NIL END
ELSE
IF COMPTYPES(LSP@.ELSET,TYPTR) THEN
BEGIN
IF KIND = CST THEN
BEGIN
IF COMPTYPES(TYPTR,CHARPTR) THEN
CSTVAL := ASCII(. CHR(CVAL.IVAL) .) - 32
ELSE
CSTVAL := CVAL.IVAL;
IF ((CSTVAL < 0) OR (CSTVAL > SETRANGE)) THEN
ERROR(304)
ELSE
IF RANGED THEN
IF TYPTR <> RNGTYPE THEN
ERROR(137)
ELSE
IF NOT CONSTEL THEN
CSTPART := CSTPART + (. CSTVAL .)
ELSE
IF CSTVAL < CSTVAL2 THEN
CSTPART := CSTPART - (. CSTVAL2 .)
ELSE
FOR I := CSTVAL2 + 1 TO CSTVAL DO
CSTPART := CSTPART + (. I .)
ELSE
CSTPART := CSTPART + (. CSTVAL .);
CONSTEL := TRUE;
IF SY = RANGE THEN (* RANGE GIVEN *)
BEGIN
RNGTYPE := TYPTR;
CSTVAL2 := CSTVAL
END
END
ELSE
BEGIN
LOAD;
IF RANGED AND CONSTEL THEN ERROR(398);
IF NOT COMPTYPES(TYPTR,INT2PTR) THEN
BEGIN
C := GETTYPE(TYPTR);
IF C <> 'I' THEN
BEGIN
GEN2T(13 (*CVT*),C,'I');
IF C = 'C' THEN GENTI(16(*DEC*), 'I', 32)
END
END (*THEN*)
ELSE CNVRTTOLHS (INT2PTR,TYPTR);
IF DEBUG THEN GENT2I(6 (*CHK*),'I',0,SETRANGE);
GEN(87(*SGS*));
IF VARPART THEN GEN(99(*UNI*))
ELSE VARPART := TRUE;
CONSTEL := FALSE
END;
LSP@.ELSET := TYPTR;
TYPTR := LSP
END
ELSE
ERROR(137);
RANGED := ((SY = RANGE) AND (NOT RANGED));
IF (RANGED AND (NOT CONSTEL)) THEN ERROR(398);
TEST := ((SY <> COMMA) AND (NOT RANGED));
IF NOT TEST THEN INSYMBOL
END (* WITH GATTR DO *)
(*CF ---------------------> *)
UNTIL TEST;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
END;
CNSTVALPTR@.PVAL := CSTPART ;
IF VARPART THEN
BEGIN
IF CSTPART <> (. .) THEN
BEGIN
(* NEW(LVP,PSET); LVP@.PVAL := CSTPART;*)
CSTPTR := (* LVP *) CNSTVALPTR ;
GENTV(45(* LDC *),'P',CSTPTR);
GEN(99(* UNI *)); GATTR.KIND := EXPR
END
END
ELSE
BEGIN (* NEW(LVP,PSET); LVP@.PVAL := CSTPART; *)
(* LVP@.CCLASS := PSET; *)
GATTR.CVAL.VALP := (* LVP *) CNSTVALPTR ;
END
END
END (* CASE *) ;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS + FACBEGSYS) END
END (* WHILE *)
END (* FACTOR *) ;
BEGIN (* **START** TERM *)
FACTOR(FSYS + (.MULOP.));
WHILE SY = MULOP DO
BEGIN LOAD; LATTR := GATTR; LOP := OP;
INSYMBOL; FACTOR(FSYS + (.MULOP.)); LOAD;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
BEGIN
INTEGERS := INTTYPE (LATTR.TYPTR)
AND INTTYPE (GATTR.TYPTR);
IF INTEGERS THEN
CONVERTTOLIKEINTEGERS (LATTR.TYPTR, GATTR.TYPTR);
CASE LOP OF
MUL:
BEGIN
IF INTEGERS THEN
GENT (57 (*MP*), GETTYPE (GATTR.TYPTR))
ELSE IF COMPATABLESETS (LATTR.TYPTR,
GATTR.TYPTR)
THEN
GEN (38 (*INT*))
ELSE
ILLEGALOPERANDS;
END (* MUL *);
RDIV:
BEGIN
ERROR (398);
GATTR.TYPTR := NIL;
END (*RDIV*);
IDIV:
BEGIN
IF INTEGERS THEN
GENT (20 (*DV*), GETTYPE (GATTR.TYPTR))
ELSE
ILLEGALOPERANDS;
END (*IDIV*);
IMOD:
BEGIN
IF INTEGERS THEN
GENT (54 (*MOD*), GETTYPE (GATTR.TYPTR))
ELSE
ILLEGALOPERANDS;
END (*IMOD*);
ANDOP:
BEGIN
IF (LATTR.TYPTR = BOOLPTR)
AND (GATTR.TYPTR = BOOLPTR)
THEN
GEN (3 (*AND*))
ELSE
ILLEGALOPERANDS;
END (*ANDOP*);
END (* CASE LOP OF *);
END (* IF (LATTR.TYPTR <> NIL) ... *)
ELSE
GATTR.TYPTR := NIL
END (* WHILE *)
END (* TERM *) ;
(* -------------------------------------------------------------------------
PROCEDURE EXPRESSION
------------------------------------------------------------------------- *
)
PROCEDURE EXPRESSION;
VAR LATTR: ATTR; KOP: MNRANGE;
C : CHAR;
LOP: OPERATOR; TYPIND: CHAR; LSIZE: ADDRRANGE;
PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
VAR
LATTR: ATTR;
LOP: OPERATOR;
SIGNED: BOOLEAN;
INTEGERS: BOOLEAN;
BEGIN (* SIMPLEEXPRESSION *)
SIGNED := FALSE;
IF (SY = ADDOP) AND ((OP = PLUS) OR (OP = MINUS)) THEN
BEGIN
SIGNED := OP = MINUS;
INSYMBOL;
END;
TERM (FSYS + (. ADDOP .));
IF SIGNED THEN
BEGIN
LOAD;
IF INTTYPE (GATTR.TYPTR) THEN
GENT (61 (*NG*), GETTYPE (GATTR.TYPTR))
ELSE
ILLEGALOPERANDS;
END;
WHILE SY = ADDOP DO
BEGIN
LOAD;
LATTR := GATTR;
LOP := OP;
INSYMBOL;
TERM (FSYS + (. ADDOP .));
LOAD;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
BEGIN
INTEGERS := INTTYPE (LATTR.TYPTR)
AND INTTYPE (GATTR.TYPTR);
IF INTEGERS THEN
CONVERTTOLIKEINTEGERS (LATTR.TYPTR, GATTR.TYPTR);
CASE LOP OF
PLUS:
BEGIN
IF INTEGERS THEN
GENT (1 (*AD*), GETTYPE (GATTR.TYPTR))
ELSE IF COMPATABLESETS (LATTR.TYPTR,
GATTR.TYPTR)
THEN
GEN (99 (*UNI*))
ELSE
ILLEGALOPERANDS;
END (* PLUS *);
MINUS:
BEGIN
IF INTEGERS THEN
GENT (82 (*SB*), GETTYPE (GATTR.TYPTR))
ELSE IF COMPATABLESETS (LATTR.TYPTR,
GATTR.TYPTR)
THEN
GEN (18 (*DIF*))
ELSE
ILLEGALOPERANDS;
END (* MINUS *);
OROP:
BEGIN
IF (LATTR.TYPTR = BOOLPTR)
AND (GATTR.TYPTR = BOOLPTR)
THEN
GEN (39 (*IOR*))
ELSE
ILLEGALOPERANDS;
END (*OROP*);
END (*CASE LOP OF*);
END (* IF (LATTR.TYPTR <> NIL) ... *)
ELSE
GATTR.TYPTR := NIL;
END (* WHILE SY = ADDOP *);
END (* SIMPLEEXPRESSION *) ;
BEGIN (* **START** EXPRESSION *)
SIMPLEEXPRESSION(FSYS + (.RELOP.));
IF SY = RELOP THEN
BEGIN
IF GATTR.TYPTR <> NIL THEN
LOAD; (*******)
(******IF GATTR.TYPTR@.FORM <= POWER THEN LOAD
ELSE LOADADDRESS; ******)
LATTR := GATTR; LOP := OP;
IF LOP = INOP THEN
BEGIN
IF NOT COMPTYPES(GATTR.TYPTR,INT2PTR) THEN
BEGIN C := GETTYPE(LATTR.TYPTR);
IF C <> 'I' THEN GEN2T(13 (*CVT*), C, 'I');
IF C = 'C' THEN GENTI(16(*DEC*), 'I', 32)
END (*THEN*)
ELSE CNVRTTOLHS (INT2PTR,GATTR.TYPTR);
IF DEBUG THEN GENT2I(6(* CHK *),'I',0,SETRANGE) ;
END ;
INSYMBOL; SIMPLEEXPRESSION(FSYS);
IF GATTR.TYPTR <> NIL THEN
LOAD; (*******)
(****** IF GATTR.TYPTR@.FORM <= POWER THEN LOAD
ELSE LOADADDRESS; ******)
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
(* IN *) IF LOP = INOP THEN
IF GATTR.TYPTR@.FORM = POWER THEN
BEGIN
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR@.ELSET) THEN
GEN(36(* INN *))
ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END
END
ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END
ELSE
BEGIN
IF LATTR.TYPTR <> GATTR.TYPTR THEN
IF INTTYPE (LATTR.TYPTR) AND INTTYPE (GATTR.TYPTR) THE
N CONVERTTOLIKEINTEGERS (LATTR.TYPTR, GATTR.TYPTR)
ELSE IF CHARARRAY(LATTR.TYPTR) AND
(GATTR.TYPTR@.FORM = STRINGS) THEN
BEGIN GEN2TI(13(* CVT *),'S','V',LATTR.TYPTR@.SIZ
E); GATTR.TYPTR := LATTR.TYPTR
END
ELSE IF CHARARRAY(GATTR.TYPTR) AND
(LATTR.TYPTR@.FORM = STRINGS) THEN
BEGIN GEN2TI(14(* CVB *),'S','V',GATTR.TYPTR@.SIZ
E); LATTR.TYPTR := GATTR.TYPTR
END;
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LSIZE := LATTR.TYPTR@.SIZE;
CASE LATTR.TYPTR@.FORM OF
SCALAR:
TYPIND := GETTYPE (LATTR.TYPTR);
POINTER:
BEGIN
IF LOP IN (.LTOP,LEOP,GTOP,GEOP.)
THEN ERROR(131);
TYPIND := 'A'
END;
POWER:
BEGIN IF LOP IN (.LTOP,GTOP.) THEN ERROR(132);
TYPIND := 'P'
END;
STRINGS:
TYPIND := 'S';
ARRAYS:
BEGIN
IF NOT CHARARRAY(LATTR.TYPTR)
AND(LOP IN(.LTOP,LEOP,GTOP,GEOP.))
THEN ERROR(131);
TYPIND := 'V'
END;
RECORDS:
BEGIN
IF LOP IN (.LTOP,LEOP,GTOP,GEOP.)
THEN ERROR(131);
TYPIND := 'V'
END;
FILES:
BEGIN ERROR(133); TYPIND := 'F' END;
SUBRANGE: ;
TAGFLD: ;
VARIANT:
END;
CASE LOP OF
(* < *) LTOP: KOP := 47(* LES *);
(* <= *) LEOP: KOP := 46(* LEQ *);
(* > *) GTOP: KOP := 32(* GRT *);
(* >= *) GEOP: KOP := 30(* GEQ *);
(* <> *) NEOP: KOP := 59(* NEQ *);
(* = *) EQOP: KOP := 25(* EQU *)
END;
IF (TYPIND = 'V') OR (TYPIND = 'S')
THEN GENTI(KOP, TYPIND,LSIZE)
ELSE GENT (KOP, TYPIND)
END
ELSE ERROR(129)
END;
GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR
END (* SY = RELOP *)
END (* EXPRESSION *) ;
(* -------------------------------------------------------------------------
PROCEDURE ASSIGNMENT
------------------------------------------------------------------------- *
)
PROCEDURE ASSIGNMENT(FCP: CTP);
VAR LATTR: ATTR;
BEGIN
SELECTOR(FSYS+(.BECOMES.), FCP) ;
IF SY = BECOMES THEN
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
IF (ACCESS<>DRCT) OR (TYPTR@.FORM>STRINGS)
OR (KIND=FILEPTR) THEN
BEGIN
LOADADDRESS ;
END ;
LATTR := GATTR;
INSYMBOL; EXPRESSION(FSYS);
IF GATTR.TYPTR <> NIL THEN
IF (GATTR.TYPTR@.FORM <= STRINGS)
OR (GATTR.KIND <> VARBL) (*******)
THEN LOAD
ELSE LOADADDRESS;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
BEGIN
(* IF COMPTYPES(REALPTR,LATTR.TYPTR)AND(GATTR.TYPTR=INT2PTR)TH
EN BEGIN GEN2T(13( CVT ),'I','R');
GATTR.TYPTR := REALPTR
END
ELSE *) IF (GATTR.TYPTR@.FORM=STRINGS) AND CHARARRAY(LATTR.TYP
TR) THEN BEGIN GEN2TI(13(* CVT *),'S','V',LATTR.TYPTR@.SIZE);
GATTR.TYPTR := LATTR.TYPTR
END
ELSE IF (LATTR.TYPTR@.FORM = STRINGS)
AND (GATTR.TYPTR = CHARPTR)
THEN
BEGIN
GEN2T(13 (*CVT*), 'C', 'S');
GATTR.TYPTR := LATTR.TYPTR
END;
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN
CHKBNDS (LATTR.TYPTR, GATTR.TYPTR, 129);
IF INTTYPE (GATTR.TYPTR) THEN
CNVRTTOLHS (LATTR.TYPTR, GATTR.TYPTR);
CASE LATTR.TYPTR@.FORM OF
SCALAR,
SUBRANGE,
POINTER,
POWER,
STRINGS: STORE(LATTR);
ARRAYS,
RECORDS: BEGIN IF GATTR.KIND = VARBL (*******)
THEN GENI (55(*MOV*),LATTR.TYPTR@.SIZE)
ELSE GENTI(94(*STO*),'V',LATTR.TYPTR@.SIZE
); END ;
FILES: ERROR(146);
TAGFLD: ;
VARIANT:
END (* CASE LATTR... *)
END
ELSE ERROR(129)
END
END (* SY = BECOMES *)
ELSE ERROR(51)
END (* ASSIGNMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE GOTOSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE GOTOSTATEMENT;
VAR LLP: LBP; FOUND: BOOLEAN; TTOP,TTOP1: DISPRANGE;
BEGIN
IF (SY = INT2CONST) OR (SY = IDENT) THEN
BEGIN (* ALPHA LABELS ALLOWED *)
FOUND := FALSE; TTOP := TOP;
WHILE DISPLAY(.TTOP.).OCCUR <> BLCK DO TTOP := TTOP - 1;
TTOP1 := TTOP;
REPEAT
LLP := DISPLAY(.TTOP.).FLABEL;
WHILE (LLP <> NIL) AND NOT FOUND DO
WITH LLP@ DO
IF SAMELABEL(SY, LLP) THEN
BEGIN FOUND := TRUE;
IF TTOP = TTOP1 THEN
BEGIN
IF LABNO = 0 THEN
GENLABEL(LABNO);
GENTL(98 (*UJP*), 'L', LABNO);
END
ELSE (* GOTO LEADS OUT OF PROCEDURE *) ERROR(398)
END
ELSE LLP := NEXTLAB;
IF TTOP > 0 THEN TTOP := TTOP - 1
UNTIL FOUND OR (TTOP <= 0);
IF NOT FOUND THEN ERROR(167);
INSYMBOL
END
ELSE ERROR(404)
END (* GOTOSTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE COMPOUNDSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE COMPOUNDSTATEMENT;
BEGIN
REPEAT
REPEAT STATEMENT(FSYS + (.SEMICOLON,ENDSY.))
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = ENDSY THEN
BEGIN
BLEV := UPRED(BLEV);
EBLOCK := TRUE;
INSYMBOL
END
ELSE
ERROR(13)
END (* COMPOUNDSTATEMENET *) ;
(* -------------------------------------------------------------------------
PROCEDURE IFSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE IFSTATEMENT;
VAR LCIX1,LCIX2: LABELRNG;
BEGIN EXPRESSION(FSYS + (.THENSY.));
GENLABEL(LCIX1);
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144);
GENTL(29(* FJP *),'L',LCIX1);
IF SY = THENSY THEN INSYMBOL ELSE ERROR(52);
STATEMENT(FSYS + (.ELSESY.));
IF SY = ELSESY THEN
BEGIN GENLABEL(LCIX2); GENTL(98(* UJP *),'L',LCIX2);
PUTLABEL(LCIX1);
INSYMBOL; STATEMENT(FSYS);
PUTLABEL(LCIX2)
END
ELSE PUTLABEL(LCIX1)
END (* IFSTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE CASESTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE CASESTATEMENT;
(* CHANGED TO ACCEPT OTHERWISE CLAUSE *
) (* CODE GEN'D IS: *
) (* LOAD CASE INDEX VALUE *
) (* XJP LBND *
) (* UJP LOTHERWZ *
) (* LCIX1A: <CODE FOR FIRST ALT> *
) (* UJP LFINISH *
) (* LCIX1B: <CODE FOR NEXT ALT> *
) (* UJP LFINISH *
) (* . *
) (* . *
) (* . *
) (* LCIX1I: <CODE FOR LAST ALT> *
) (* UJP LFINISH *
) (* LOTHERWZ:<CODE FOR OTHERWISE> *
) (* UJP LFINISH *
) (* LBND: DEF 'LEAST ALTERNATE VAL' *
) (* UBND: DEF 'BIG ALTERNATE VAL' *
) (* LCIX: VJP LOTHERWZ *
) (* VJP LCIX1I *
) (* . *
) (* . *
) (* . *
) (* LFINISH: . . . *
) (*(WHERE VJP IS UJP WITHOUT SHORT DISP)*
)
TYPE CIP = @CASEINFO;
CASEINFO = PACKED
RECORD NEXT: CIP;
CSSTART: LABELRNG;
CSLAB: INTEGER
END;
VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU;
LMIN, LMAX: ADDRRANGE ;
LOTHERWZ, LFINISH, LCIX, LCIX1, UBND, LBND: LABELRNG ;
C: CHAR;
OTHERWZ, FOUND: BOOLEAN;
BEGIN EXPRESSION(FSYS + (.OFSY,COMMA,COLON.));
LOAD ;
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
IF (LSP@.FORM <> SCALAR) OR (LSP = REALPTR) THEN
BEGIN ERROR(144); LSP := NIL END
ELSE IF COMPTYPES(LSP,INT2PTR) THEN
CNVRTTOLHS (INT2PTR, LSP)
ELSE
BEGIN
C := GETTYPE (LSP);
IF C <> 'I' THEN GEN2T (13 (*CVT*), C, 'I');
END;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
FSTPTR := NIL ; GENLABEL(LBND) ; GENLABEL(UBND) ;
GENLABEL(LCIX) ; GENLABEL(LOTHERWZ); GENLABEL(LFINISH);
(* WE MUST HAVE: LCIX = UBND+1 = LBND+2 FOR THE 'XJP' TO WORK *)
GENTL(109(* XJP *),'L', LBND) ;
GENTL(98 (* UJP *),'L', LOTHERWZ) ;
(*'XJP' WILL FALL THRU TO 'UJP' IF EXPR NOT IN RANGE OF ALTS*)
OTHERWZ := FALSE;
REPEAT
LPT3 := NIL; GENLABEL(LCIX1);
IF NOT(SY IN (.SEMICOLON,ENDSY.)) THEN
BEGIN
IF SY <> OTHERWZSY THEN
BEGIN
REPEAT CONSTANT(FSYS + (.COMMA,COLON.),LSP1,LVAL);
IF LSP <> NIL THEN
BEGIN
IF LSP = CHARPTR THEN LVAL.IVAL := ASCII(.CHR(LVAL.IVAL).);
IF COMPTYPES(LSP,LSP1) THEN
BEGIN LPT1 := FSTPTR; LPT2 := NIL;
FOUND := FALSE;
WHILE NOT FOUND AND (LPT1 <> NIL) DO
WITH LPT1@ DO
BEGIN
IF CSLAB <= LVAL.IVAL THEN
BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156);
FOUND := TRUE
END
ELSE BEGIN LPT2 := LPT1; LPT1 := NEXT END
END;
NEW(LPT3);
WITH LPT3@ DO
BEGIN NEXT := LPT1; CSLAB := LVAL.IVAL;
CSSTART := LCIX1
END;
IF LPT2 = NIL THEN FSTPTR := LPT3
ELSE LPT2@.NEXT := LPT3
END
ELSE ERROR(147);
END (* LSP <> NIL *) ;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
PUTLABEL(LCIX1)
END
ELSE BEGIN OTHERWZ := TRUE;
IF STANDARD THEN WARNING(506);
INSYMBOL;
PUTLABEL(LOTHERWZ)
END;
REPEAT STATEMENT(FSYS + (.SEMICOLON.))
UNTIL NOT (SY IN STATBEGSYS);
IF (LPT3 <> NIL) OR OTHERWZ THEN
GENTL(98(* UJP *),'L',LFINISH);
END ;
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST OR OTHERWZ;
IF FSTPTR <> NIL THEN
BEGIN LMAX := FSTPTR@.CSLAB;
(* REVERSE POINTERS *)
LPT1 := FSTPTR; FSTPTR := NIL;
REPEAT LPT2 := LPT1@.NEXT; LPT1@.NEXT := FSTPTR;
FSTPTR := LPT1; LPT1 := LPT2
UNTIL LPT1 = NIL;
LMIN := FSTPTR@.CSLAB;
GENDEF(LBND,LMIN);
GENDEF(UBND,LMAX);
PUTLABEL(LCIX);
IF LMAX - LMIN < CIXMAX THEN
BEGIN
REPEAT
WITH FSTPTR@ DO
BEGIN
WHILE CSLAB > LMIN DO
BEGIN GENTL(113(* VJP *),'L',LOTHERWZ);
LMIN:=LMIN+1 END;
GENTL(113(* VJP *),'L',CSSTART);
FSTPTR := NEXT; LMIN := LMIN + 1
END
UNTIL FSTPTR = NIL;
IF NOT OTHERWZ THEN BEGIN PUTLABEL(LOTHERWZ);
GENI (112(*MST*),SYSTEM);
GENTI(45 (*LDC*),'I',1);
GENTI(116(*ARG*),'I',SYSTEM);
GENI (26 (*EXI*), 0) END;
PUTLABEL(LFINISH) ;
END
ELSE ERROR(157)
END;
IF SY = ENDSY THEN
BEGIN
BLEV := UPRED(BLEV);
EBLOCK := TRUE;
INSYMBOL
END
ELSE
ERROR(13)
END (* CASESTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE REPEATSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE REPEATSTATEMENT;
VAR LADDR: LABELRNG;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
REPEAT
REPEAT STATEMENT(FSYS + (.SEMICOLON,UNTILSY.))
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = UNTILSY THEN
BEGIN
BLEV := UPRED(BLEV);
EBLOCK := TRUE;
GENKOUNT(FALSE);
INSYMBOL;
EXPRESSION(FSYS);
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN
ERROR(144);
GENTL(29 (* FJP *), 'L', LADDR)
END
ELSE ERROR(53)
END (* REPEATSTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE WHILESTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE WHILESTATEMENT;
VAR LADDR, LCIX: LABELRNG;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
EXPRESSION(FSYS + (.DOSY.)); GENLABEL(LCIX);
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144);
GENTL(29(* FJP *),'L',LCIX);
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS); GENTL(98(* UJP *),'L',LADDR); PUTLABEL(LCIX)
END (* WHILESTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE FORSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE FORSTATEMENT;
VAR LATTR: ATTR; K: CHAR; LSY: SYMBOL;
LCIX, LADDR: LABELRNG ; LLC : ADDRRANGE ;
INDEXVARSIZE: INTEGER;
LCP: CTP;
BEGIN
INDEXVARSIZE := 0;
IF SY = IDENT
THEN SEARCHID((.VARS.),LCP)
ELSE BEGIN
ERROR (2);
LCP := UVARPTR
END; (*ELSE*)
WITH LCP@,LATTR DO
BEGIN
TYPTR := IDTYPE;
KIND := VARBL;
IF VKIND = ACTUAL
THEN BEGIN
ACCESS := DRCT;
VLEVEL := VLEV;
DPLMT := VADDR(.1.)
END (*THEN*)
ELSE BEGIN
ERROR (155);
TYPTR := NIL
END (*ELSE*)
END; (*WITH*)
IF LATTR.TYPTR <> NIL THEN
IF (LATTR.TYPTR@.FORM > SUBRANGE) OR (LATTR.TYPTR = REALPTR) THE
N BEGIN
ERROR (143);
LATTR.TYPTR := NIL
END; (*THEN*)
K := GETTYPE(LATTR.TYPTR);
IF SY = IDENT
THEN INSYMBOL
ELSE SKIP(FSYS + (.BECOMES,TOSY,DOWNTOSY,DOSY.));
IF SY = BECOMES THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + (.TOSY,DOWNTOSY,DOSY.));
IF (GATTR.TYPTR <> NIL) AND (LATTR.TYPTR <> NIL) THEN
IF GATTR.TYPTR@.FORM <> SCALAR THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN
LOAD;
CHKBNDS (LATTR.TYPTR, GATTR.TYPTR, 145);
IF INTTYPE (GATTR.TYPTR) THEN
CNVRTTOLHS (LATTR.TYPTR, GATTR.TYPTR);
STORE (LATTR);
END
ELSE ERROR(145)
END
ELSE
BEGIN ERROR(51); SKIP(FSYS + (.TOSY,DOWNTOSY,DOSY.)) END;
IF SY IN (.TOSY,DOWNTOSY.) THEN
BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS + (.DOSY.));
IF (GATTR.TYPTR <> NIL) AND (LATTR.TYPTR <> NIL) THEN
IF GATTR.TYPTR@.FORM <> SCALAR THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN
LOAD;
CHKBNDS (LATTR.TYPTR, GATTR.TYPTR, 145);
IF INTTYPE (GATTR.TYPTR) THEN
CNVRTTOLHS (LATTR.TYPTR, GATTR.TYPTR);
INDEXVARSIZE := LATTR.TYPTR@.SIZE;
LOCN := LOCN - INDEXVARSIZE;
IF INDEXVARSIZE > 1 THEN LOCN := ALIGN(LOCN);
LLC := LOCN ;
GENTLI(96(* STR *),K,LEVEL,LLC);
GATTR := LATTR; LOAD;
GENTLI(48(* LOD *),K,LEVEL,LLC);
IF LOCN < LCMIN THEN LCMIN := LOCN;
IF LSY = TOSY THEN GENT(46(* LEQ *),K)
ELSE GENT(30(* GEQ *),K);
END
ELSE ERROR(145)
END
ELSE BEGIN ERROR(55); SKIP(FSYS + (.DOSY.)) END;
GENLABEL(LADDR) ; GENLABEL(LCIX); GENTL(29(* FJP *),'L',LCIX);
PUTLABEL(LADDR) ; (* BEGINNING OF THE FOR 'LOOP' *)
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS);
GATTR := LATTR ; LOAD ;
GENTLI(48(* LOD *),K,LEVEL,LLC) ;
GENT(59(* NEQ *),K) ; GENTL(29(* FJP *),'L',LCIX) ;
GATTR := LATTR; LOAD;
IF LSY = TOSY THEN GENTI(34(* INC *),K,1)
ELSE GENTI(16(* DEC *),K,1);
CHKBNDS (LATTR.TYPTR, GATTR.TYPTR, 145);
STORE(LATTR); GENTL(98(* UJP *),'L',LADDR); PUTLABEL(LCIX);
LOCN := LLC + INDEXVARSIZE ;
END (* FORSTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE WITHSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE WITHSTATEMENT;
VAR LCP: CTP; LCNT: DISPRANGE; LLC: ADDRRANGE;
BEGIN LCNT := TOP ; LLC := LOCN ;
REPEAT
IF SY = IDENT
THEN BEGIN SEARCHID((.VARS,FIELD.),LCP); INSYMBOL END
ELSE BEGIN ERROR(2); LCP := UVARPTR END;
SELECTOR(FSYS + (.COMMA,DOSY.),LCP);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR@.FORM = RECORDS THEN
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY(.TOP.) DO BEGIN
FNAME := GATTR.TYPTR@.FSTFLD;
FLABEL := NIL
END;
IF GATTR.ACCESS = DRCT THEN
WITH DISPLAY(.TOP.) DO
BEGIN OCCUR := CREC;
CLEV := GATTR.VLEVEL;
CDSPL := GATTR.DPLMT
END
ELSE
BEGIN LOADADDRESS;
LOCN := LOCN - ADDRSIZE;
LOCN := ALIGN(LOCN);
GENTLI(96(* STR *),'A',LEVEL,LOCN);
WITH DISPLAY(.TOP.) DO
BEGIN OCCUR := VREC; VDSPL := LOCN END;
IF LOCN < LCMIN THEN LCMIN := LOCN
END
END
ELSE ERROR(250)
ELSE ERROR(140);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS);
TOP := LCNT ; LOCN := LLC ;
END (* WITHSTATEMENT *) ;
(* -------------------------------------------------------------------------
PROCEDURE EXITSTATEMENT
------------------------------------------------------------------------- *
)
PROCEDURE EXITSTATEMENT; (*TAKES LABEL OR NULL. IF NULL *
) VAR FOUND: BOOLEAN; (*THEN EXIT CURRENT LOOP CONSTRUCT*
) LPTR: LOOPPTR; (*(WHILE,REPEAT,OR FOR) IF LABEL *
) (*THEN EXIT LOOP WITH THAT LABEL *
) (*'LOOPENTRY' AND 'LOOPEXIT' KEEP *
) (*A STACK OF THE CURRENT EXIT LABS*
) (*EITHER USE THE TOP ITEM OR SCAN *
) (*BACK UNTIL FIND ONE POINTING TO *
) (*TO SPECIFIED ACTUAL LABEL *
) BEGIN
IF STANDARD THEN WARNING(505);
IF (SY = INT2CONST) OR (SY = IDENT) THEN
BEGIN FOUND := FALSE;
LPTR := LOOPLISTPTR;
WHILE NOT FOUND AND (LPTR <> NIL) DO
IF SAMELABEL(SY,LPTR@.ASSOCLAB) THEN
BEGIN
FOUND := TRUE;
IF LPTR@.LABNO = 0 THEN
GENLABEL(LPTR@.LABNO);
GENTL(98 (*UJP*), 'L', LPTR@.LABNO);
LPTR@.USED := TRUE;
END
ELSE LPTR := LPTR@.NEXTLOOP;
IF NOT FOUND THEN ERROR(411);
INSYMBOL
END
ELSE BEGIN
IF NOT (SY IN (.SEMICOLON,ENDSY,ELSESY,UNTILSY.)) THEN ERROR(41
0) ELSE IF LOOPLISTPTR <> NIL THEN
BEGIN
IF LOOPLISTPTR@.LABNO = 0 THEN
GENLABEL(LOOPLISTPTR@.LABNO);
GENTL(98 (*UJP*), 'L', LOOPLISTPTR@.LABNO);
LOOPLISTPTR@.USED := TRUE;
END
ELSE ERROR(412)
END
END; (*EXITSTATEMENT*)
PROCEDURE LOOPENTRY; (*DEFINE AN EXIT LABEL FOR THIS LOOP STMNT *)
VAR
LPTR: LOOPPTR;
BEGIN
NEW(LPTR); (*CREATE NEW LOOP EXIT LABEL*)
WITH LPTR@ DO BEGIN
LABNO := 0;
ASSOCLAB:= LLP; (*POINT TO ACTUAL LABEL OF LOOP IF ANY*)
(*THIS CODE ASSUMES THAT LLP IS NIL IF
THE CURRENT STATEMENT IS NOT LABELLED*)
NEXTLOOP:= LOOPLISTPTR; (*PUT ON STACK OF LOOP EXIT LABELS*)
USED := FALSE (*NOT REFERENCED YET*)
END;
LOOPLISTPTR := LPTR
END; (*LOOPENTRY*)
PROCEDURE LOOPEXIT; (*PROCESS AND REMOVE THE EXIT
LABEL FOR THIS LOOP*)
BEGIN WITH LOOPLISTPTR@ DO BEGIN
IF USED THEN PUTLABEL(LABNO); (*INSERT EXIT LABEL INTO OBJECT
IF IT WAS REFERENCED*)
LOOPLISTPTR := NEXTLOOP (*REMOVE FROM STACK*)
END
END; (*LOOPEXIT*)
BEGIN (* *START** STATEMENT *)
LLP := NIL; (*NEEDED FOR EXIT LOOPS*)
IF (SY = INT2CONST) OR (SY = IDENT) THEN (* LABEL *)
BEGIN TTOP := TOP ;
WHILE DISPLAY(.TTOP.).OCCUR <> BLCK DO TTOP := TTOP-1 ;
LLP := DISPLAY(.TTOP.).FLABEL;
FOUND := FALSE;
WHILE NOT FOUND AND (LLP <> NIL) DO
WITH LLP@ DO
IF SAMELABEL(SY, LLP) THEN
BEGIN
IF DEFINED THEN ERROR(165);
IF LABNO = 0 THEN
GENLABEL(LABNO);
PUTLABEL(LABNO);
DEFINED := TRUE;
FOUND := TRUE;
END
ELSE LLP := NEXTLAB;
IF SY = INT2CONST THEN BEGIN
IF NOT FOUND THEN ERROR(167);
INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
END
ELSE IF FOUND THEN (* ALPHA LABEL *)
BEGIN INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5) END;
END;
IF NOT (SY IN FSYS + (.IDENT.)) THEN
BEGIN ERROR(6); SKIP(FSYS) END;
IF SY IN STATBEGSYS + (.IDENT.) THEN
BEGIN
IF SY IN LOOPBEGSYS THEN BEGIN LOOPENTRY; (*SET UP EXIT LABEL*)
INLOOP := TRUE END
ELSE INLOOP := FALSE;
CASE SY OF
IDENT: BEGIN SEARCHID((.VARS,FIELD,FUNC,PROC.),LCP);
GENKOUNT(FALSE); INSYMBOL;
IF LCP@.KLASS = PROC THEN CALL(FSYS,LCP)
ELSE ASSIGNMENT(LCP)
END;
BEGINSY: BEGIN
BLEV := USUCC(BLEV);
SBLOCK := TRUE;
INSYMBOL;
COMPOUNDSTATEMENT
END;
GOTOSY: BEGIN GENKOUNT(FALSE); INSYMBOL; GOTOSTATEMENT END;
IFSY: BEGIN GENKOUNT(FALSE); INSYMBOL; IFSTATEMENT END;
CASESY: BEGIN
BLEV := USUCC(BLEV);
SBLOCK := TRUE;
GENKOUNT(FALSE);
INSYMBOL;
CASESTATEMENT
END;
WHILESY: BEGIN GENKOUNT(FALSE); INSYMBOL; WHILESTATEMENT END;
REPEATSY: BEGIN
BLEV := USUCC(BLEV);
SBLOCK := TRUE;
INSYMBOL;
REPEATSTATEMENT
END;
(* GENKOUNT(FALSE) WHEN 'UNTIL' ENCOUNTERED *)
FORSY: BEGIN GENKOUNT(FALSE); INSYMBOL; FORSTATEMENT END;
EXITSY: BEGIN GENKOUNT(FALSE); INSYMBOL; EXITSTATEMENT END;
WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END
END;
IF INLOOP THEN LOOPEXIT;
IF NOT (SY IN (.SEMICOLON,ENDSY,ELSESY,UNTILSY.)) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
END (* STATEMENT *) ;
BEGIN (***START** BODY *)
IF FPROCP <> NIL THEN
BEGIN ENTNAME := FPROCP@.PFNAME; PROCNAME := FPROCP@.NAME END
ELSE
BEGIN ENTNAME := 0; PROCNAME := PROGNAME; PARMLEN := 0 END;
GENLABEL(SEGSIZE) ;
GENENT(ENTNAME,21(* ENT *),LEVEL,SEGSIZE,PROCNAME) ;
LABELEDKOUNT := TRUE;
GENKOUNT(TRUE);
PRINTKOUNT := FALSE;
MINKOUNT := KOUNT;
LCMIN := LOCN;
(*OPEN LOCAL FILES*)
KLOCFILELIST := LOCFILELIST;
WHILE KLOCFILELIST <> NIL DO BEGIN
WITH KLOCFILELIST@ DO BEGIN
GENI(112 (*MST*), 0);
GENLI(44(*LDA*),VLEV,VADDR(.1.));(*PUSH ADDR(FILE PTR
)*) GENTI(116 (*ARG*), 'A', 0);
(*GET POSITION IN PROGRAM HEADER LIST*)
K := 0;
IF (LEVEL = 0) AND (FEXTFILEP <> NIL) THEN
BEGIN KFILE := FEXTFILEP;
WHILE KFILE <> NIL DO BEGIN
IF KFILE@.FILENAME = NAME THEN
K := KFILE@.POS;
KFILE := KFILE@.NEXTFILE
END
END;
GENTI(45(*LDC*),'I',K); (*PUSH FILE POSITION*)
GENTI(116 (*ARG*), 'I', 0);
(*BUILD FILE STATUS*)
IF IDTYPE = TEXTPTR THEN STATUS := 4 ELSE STATUS := 0
; IF NOT EXTRNL THEN STATUS := STATUS + 8;
STDFILE := FALSE;
IF KLOCFILELIST = STDINPUT THEN
BEGIN STDFILE := TRUE;
STATUS := STATUS + 2 END
ELSE IF KLOCFILELIST = STDOUTPUT THEN
BEGIN STDFILE := TRUE;
STATUS := STATUS + 1 END;
GENTI(45(*LDC*),'I',STATUS); (*PUSH FILE STATUS*)
GENTI(116 (*ARG*), 'I', 0);
GENTI(45(*LDC*),'I',IDTYPE@.FILTYPE@.SIZE);
(*PUSH COMPONENT SIZE*)
GENTI(116 (*ARG*), 'I', 0);
GEN(33(*IFD*)) ;
IF STDFILE THEN BEGIN
GENI(112 (*MST*), 0);
(*PUSH ADDR(FILE PTR)*)
GENLI(44(*LDA*),VLEV,VADDR(.1.));
GENTI(116 (*ARG*), 'A', 0);
IF KLOCFILELIST = STDINPUT THEN K := 80(*RST*)
ELSE K := 81(*RWT*);
GEN(K (*RST,RWT*))
END;
KLOCFILELIST := (*KLOCFILELIST@.*)NEXT END
END;
LOOPLISTPTR := NIL;
REPEAT
REPEAT STATEMENT(FSYS + (.SEMICOLON,ENDSY.))
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = ENDSY THEN
BEGIN
EBLOCK := TRUE;
BLEV := UPRED(BLEV);
INSYMBOL
END
ELSE
ERROR(13);
(*CLOSE LOCAL FILES*)
KLOCFILELIST := LOCFILELIST;
WHILE KLOCFILELIST <> NIL DO BEGIN
WITH KLOCFILELIST@ DO BEGIN
GENI(112 (*MST*), 0);
GENLI(44(*LDA*),VLEV,VADDR(.1.));(*PUSH ADDR(FILE PTR
)*) GENTI(116 (*ARG*), 'A', 0);
GEN(7(*CLO*)) END;
KLOCFILELIST := KLOCFILELIST@.NEXT END;
LLP := DISPLAY(.TOP.).FLABEL; (* TEST FOR UNDEFINED LABELS *)
WHILE LLP <> NIL DO
WITH LLP@ DO
BEGIN
IF NOT DEFINED THEN
BEGIN
IF PAGEPOS > PAGEEND THEN NEWPAGE;
ERRORCOUNT := ERRORCOUNT + 1;
WRITE(LISTING, ERRMES:11,LASTERR:6,'** 168 ');
IF ALF THEN WRITELN(LISTING,LABNAME)
ELSE WRITELN(LISTING,LABVAL:0);
LASTERR := LINECOUNT;
PAGEPOS := PAGEPOS + 1
END;
LLP := LLP@.NEXTLAB
END;
K := ALIGN (ABS(LCMIN));
GENDEF(SEGSIZE,K) ; (* ASSURE EVEN ADDR *)
IF K > STKSIZES(.LEVEL.) THEN STKSIZES(.LEVEL.) := K;
IF FPROCP = NIL THEN GEN(95(* STP *));
OLDIC := OLDIC+ IC ; IC := 0 ; (* RESET IC FOR NEXT PROC *)
END (* BODY *) ;
BEGIN (* **START** BLOCK *)
FWDLIST := NIL;
LOCFILELIST:= GLOBFILELIST; GLOBFILELIST := NIL;
DP := TRUE;
REPEAT
IF SY = LABELSY THEN
BEGIN INSYMBOL; LABELDECLARATION END;
IF SY = CONSTSY THEN
BEGIN INSYMBOL; CONSTDECLARATION END;
IF SY = TYPESY THEN
BEGIN INSYMBOL; TYPEDECLARATION END;
IF SY = VARSY THEN
BEGIN INSYMBOL; VARDECLARATION END;
WHILE SY IN (.PROCSY,FUNCSY.) DO
BEGIN LSY := SY; INSYMBOL; PROCDECLARATION(LSY) END;
IF NOT(SY IN FSYS + (.PERIOD.)) THEN
BEGIN ERROR(18); SKIP(FSYS + (.PERIOD.)) END;
IF STANDARD AND (SY <> BEGINSY) THEN WARNING(502) (* UNORDERED DECL'S *
) UNTIL SY IN STATBEGSYS+(.PERIOD.);
(* EXPECTING DECL'S TO BE FINISHED HERE; CHECK UNRESOLVED
FWD TYPE DEFINITIONS (CODE MOVED HERE FROM 'TYPEDECL' *)
WHILE FWPTR <> NIL DO
BEGIN
IF PAGEPOS > PAGEEND THEN NEWPAGE;
ERRORCOUNT := ERRORCOUNT + 1;
WRITELN(LISTING,ERRMES:11,LASTERR:6,'** 117 TYPE-ID ',FWPTR@.NAME
); PAGEPOS := PAGEPOS + 1;
LASTERR := LINECOUNT;
FWPTR := FWPTR@.NEXT
END;
(* CHECK FOR AND FLAG UNRESOLVED FORWARD PROC/FUNCS *)
(* IF IN MAIN BODY THEY ARE ASSUMED TO BE EXTERNAL *)
WHILE FWDLIST <> NIL DO
BEGIN WITH FWDLIST@.PF@ DO
BEGIN
IF LEVEL = 0 THEN
BEGIN (* IN MAIN BODY *)
GENDEF1(PFNAME,NAME);
IF PAGEPOS > PAGEEND THEN NEWPAGE;
PAGEPOS := PAGEPOS + 1;
WRITELN(LISTING, STARS:7,NAME,' ASSUMED EXTERNAL')
END
ELSE
BEGIN
IF PAGEPOS > PAGEEND THEN NEWPAGE;
ERRORCOUNT := ERRORCOUNT + 1;
WRITE(LISTING, ERRMES:11,LASTERR:6);
WRITELN(LISTING,'** 117 PROC/FUNC ',NAME);
LASTERR := LINECOUNT;
PAGEPOS := PAGEPOS + 1;
END;
END;
FWDLIST := FWDLIST@.NEXTPF
END;
DP := FALSE;
IF NOT (SUBPROG AND (LEVEL = 0)) THEN
BEGIN
IF SY = BEGINSY THEN
BEGIN
PRINTKOUNT := TRUE;
SBLOCK := TRUE;
BLEV := 'B';
MLEV := 'A';
INSYMBOL
END
ELSE
ERROR(17);
REPEAT BODY(FSYS + (.CASESY.));
IF (SY <> FSY) AND NOT ((SY = PERIOD) AND (LEVEL = 1) AND SUBPROG)
THEN BEGIN ERROR(6); SKIP(FSYS + (.FSY.) + (.PERIOD.)) END
UNTIL (SY = FSY) OR (SY = PERIOD) OR (SY IN BLOCKBEGSYS);
END
END (* BLOCK *) ;
(* -------------------------------------------------------------------------
PROCEDURE PROGRAMME
------------------------------------------------------------------------- *
)
PROCEDURE PROGRAMME(FSYS: SETOFSYS);
VAR EXTFP:EXTFILEP;
LCP: CTP;
I, FILEPOS: INTEGER;
BEGIN
IF (SY = PROGSY) OR (SY = SUBPROGSY) THEN
BEGIN IF SY = SUBPROGSY THEN BEGIN SUBPROG:=TRUE;
IF STANDARD THEN WARNING(507)
END
ELSE SUBPROG:=FALSE;
INSYMBOL; IF SY <> IDENT THEN ERROR(2); PROGNAME:=ID; INSYMBOL;
IF NOT (SY IN (.LPARENT,SEMICOLON.)) THEN ERROR(14);
IF SY = LPARENT THEN
BEGIN
FILEPOS := 0;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN
IF (ID <> 'INPUT ')
AND (ID <> 'OUTPUT ') THEN
BEGIN NEW(EXTFP);
FILEPOS := FILEPOS + 1;
WITH EXTFP@ DO
BEGIN FILENAME := ID;
NEXTFILE := FEXTFILEP ;
POS := FILEPOS;
DEF := FALSE
END;
FEXTFILEP := EXTFP;
END
ELSE
BEGIN NEW(LCP,VARS);
WITH LCP@ DO
BEGIN NAME := ID; IDTYPE := TEXTPTR;
KLASS := VARS; VKIND := ACTUAL; VLEV := 0;
EXTRNL := TRUE;
LOCN := LOCN - 2 * ADDRSIZE; VADDR(.1.) := LOCN;
NEXT := GLOBFILELIST; GLOBFILELIST := LCP;
END;
IF ID = 'INPUT ' THEN STDINPUT := LCP
ELSE STDOUTPUT := LCP;
ENTERID(LCP)
END;
INSYMBOL;
IF NOT ( SY IN (.COMMA,RPARENT.) ) THEN ERROR(20)
END
ELSE ERROR(2)
UNTIL SY <> COMMA;
IF SY <> RPARENT THEN ERROR(4);
INSYMBOL
END;
IF SY <> SEMICOLON THEN ERROR(14)
ELSE INSYMBOL;
END;
WRITE(PCODE,'HP');
IF ADDRSIZE = 4 THEN
WRITE(PCODE,'20')
ELSE
WRITE(PCODE,'09');
WRITE (PCODE,' ''',PROGNAME,'''');
IF SUBPROG THEN
WRITE(PCODE,'S ':3)
ELSE
WRITE(PCODE,'M ':3);
OUTHEX (PCODE,JUMPBASE);
WRITE (PCODE,JUMPENTRIES:6,' ');
OUTHEX (PCODE,HEAPSTART);
WRITE (PCODE,' ');
OUTHEX (PCODE,STACKSTART);
WRITELN (PCODE,' ');
(*REPEAT*) BLOCK(FSYS,PERIOD,NIL);
IF SY <> PERIOD THEN ERROR(21)
(*UNTIL SY = PERIOD*) ;
WRITELN (PCODE,' END');
IF LIST THEN WRITELINE;
IF ERRINX > 0 THEN PRINTERROR ;
WHILE FEXTFILEP <> NIL DO
BEGIN
IF NOT FEXTFILEP@.DEF THEN
BEGIN
IF PAGEPOS > PAGEEND THEN NEWPAGE;
ERRORCOUNT := ERRORCOUNT + 1;
WRITE(LISTING, ERRMES:11, LASTERR:6);
WRITELN(LISTING,'** 172 FILE ',FEXTFILEP@.FILENAME);
LASTERR := LINECOUNT;
PAGEPOS := PAGEPOS + 1;
END; (* IF NOT FEXTFILEP@.DEF ... *)
FEXTFILEP := FEXTFILEP@.NEXTFILE
END; (* WHILE FEXTFILEP <> NIL *)
END (* PROGRAMME *) ;
(* -------------------------------------------------------------------------
INITIALIZATION PROCEDURES
------------------------------------------------------------------------- *
)
PROCEDURE ENTERSTDTYPES;
BEGIN (* TYPE UNDERLYING: *)
(* +++++++++++++++++ *)
NEW (INT1PTR,SCALAR); (*SHORTINT*)
WITH INT1PTR@ DO
BEGIN
SIZE := INT1SIZE;
FORM := SCALAR
END; (*WITH*)
NEW(INT2PTR,SCALAR); (* INTEGER *)
WITH INT2PTR@ DO
BEGIN SIZE := INT2SIZE;
FORM := SCALAR; END;
NEW (INT4PTR,SCALAR); (*LONGINT*)
WITH INT4PTR@ DO
BEGIN
SIZE := INT4SIZE;
FORM := SCALAR
END; (*WITH*)
NEW(REALPTR,SCALAR); (* REAL *)
WITH REALPTR@ DO
BEGIN SIZE := REALSIZE;
FORM := SCALAR; END;
NEW(CHARPTR,SCALAR); (* CHAR *)
WITH CHARPTR@ DO
BEGIN SIZE := CHARSIZE;
FORM := SCALAR; END;
NEW(BOOLPTR,SCALAR); (* BOOLEAN *)
WITH BOOLPTR@ DO
BEGIN SIZE := BOOLSIZE;
FORM := SCALAR; END;
NEW(NILPTR,POINTER); (* NIL *)
WITH NILPTR@ DO
BEGIN ELTYPE := NIL; SIZE := ADDRSIZE;
FORM := POINTER END;
NEW(TEXTPTR,FILES); (* TEXT *)
WITH TEXTPTR@ DO
BEGIN FILTYPE := CHARPTR; SIZE := 2*ADDRSIZE;
FORM := FILES END;
NEW(SINGLECHARSTRING, STRINGS);
WITH SINGLECHARSTRING@ DO
BEGIN
FORM := STRINGS;
SIZE := 4;
END;
END (* ENTERSTDTYPES *) ;
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE ENTSTDNAMES *)
(* *)
(* THIS PROCEDURE ENTERS THE STANDARD NAMES INTO THE HEAP. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE ENTSTDNAMES;
VAR
NA: ARRAY (.STDNAMES.) OF ALPHA; (*THE NAMES*)
CP,
CPLAST: CTP; (*PTRS TO NAMES*)
N: STDNAMES;
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE ENTERPROC (PROCNAME,PROCTYPE) *)
(* *)
(* THIS PROCEDURE ENTERS THE PROCEDURE OR FUNCTION WHOSE *)
(* NAME IS 'PROCNAME' AND TYPE IS 'PROCTYPE' INTO THE HEAP. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE ENTERPROC (PROCNAME: STDNAMES; PROCTYPE: IDCLASS);
VAR
CP: CTP; (*PTR TO NAME*)
BEGIN (*ENTERPROC*)
NEW (CP,PROC); (*GET A NEW RECORD*)
WITH CP@ DO (*SET UP THE RECORD*)
BEGIN
NAME := NA(.PROCNAME.);
IDTYPE := NIL;
NEXT := NIL;
KEY := PROCNAME;
KLASS := PROCTYPE;
PFDECKIN := BUILTIN
END; (*WITH*)
ENTERID (CP) (*ENTER THE NAME*)
END; (*ENTERPROC*)
(*--------------------------------------------------------------------*)
(* *)
(* PROCEDURE ENTERTYPE (TYPENAME,TYPEPTR) *)
(* *)
(* THIS PROCEDURE ENTERS THE TYPE WHOSE NAME IS 'TYPENAME' *)
(* AND POINTER IS 'TYPEPTR'. *)
(* *)
(*--------------------------------------------------------------------*)
PROCEDURE ENTERTYPE (TYPENAME: STDNAMES; TYPEPTR: STP);
VAR
CP: CTP; (*PTR TO THE NAME*)
BEGIN (*ENTERTYPE*)
NEW (CP,TYPES); (*GET A NEW RECORD*)
WITH CP@ DO (*SET UP THE RECORD*)
BEGIN
NAME := NA(.TYPENAME.);
IDTYPE := TYPEPTR;
KLASS := TYPES
END; (*WITH*)
ENTERID (CP) (*ENTER THE NAME*)
END; (*ENTERTYPES*)
(*--------------------------------------------------------------------*)
(* *)
(* ENTSTDNAMES STARTS HERE *)
(* *)
(*--------------------------------------------------------------------*)
BEGIN (*ENTSTDNAMES*)
(*FIRST INITIALIZE THE ARRAY OF NAMES*)
(*CONSTANTS*)
NA(.XTRUE .) := 'TRUE '; NA(.XMAXINT .) := 'MAXINT ';
NA(.XNIL .) := 'NIL '; NA(.XFALSE .) := 'FALSE ';
(*TYPES*)
NA(.XCHAR .) := 'CHAR '; NA(.XBOOLEAN .) := 'BOOLEAN ';
NA(.XINTEGER .) := 'INTEGER '; NA(.XREAL .) := 'REAL ';
NA(.XTEXT .) := 'TEXT ';
(*FUNCTIONS*)
NA(.XPOSITION.) := 'POSITION'; NA(.XCOPY .) := 'COPY ';
NA(.XEOF .) := 'EOF '; NA(.XLENGTH .) := 'LENGTH ';
NA(.XORD .) := 'ORD '; NA(.XSQR .) := 'SQR ';
NA(.XTRUNC .) := 'TRUNC '; NA(.XARCTAN .) := 'ARCTAN ';
NA(.XCLOCK .) := 'CLOCK '; NA(.XDELETE .) := 'DELETE ';
NA(.XEXP .) := 'EXP '; NA(.XINSERT .) := 'INSERT ';
NA(.XSUCC .) := 'SUCC '; NA(.XABS .) := 'ABS ';
NA(.XCHR .) := 'CHR '; NA(.XCONCAT .) := 'CONCAT ';
NA(.XCOS .) := 'COS '; NA(.XEOLN .) := 'EOLN ';
NA(.XLN .) := 'LN '; NA(.XODD .) := 'ODD ';
NA(.XPOS .) := 'POS '; NA(.XPRED .) := 'PRED ';
NA(.XROUND .) := 'ROUND '; NA(.XSIN .) := 'SIN ';
NA(.XSQRT .) := 'SQRT ';
(*PROCEDURES*)
NA(.XGET .) := 'GET '; NA(.XREWRITE .) := 'REWRITE ';
NA(.XUNPACK .) := 'UNPACK '; NA(.XREADLN .) := 'READLN ';
NA(.XWRITELN .) := 'WRITELN '; NA(.XPAGE .) := 'PAGE ';
NA(.XPUT .) := 'PUT '; NA(.XRELEASE .) := 'RELEASE ';
NA(.XWRITE .) := 'WRITE '; NA(.XDISPOSE .) := 'DISPOSE ';
NA(.XHALT .) := 'HALT '; NA(.XMARK .) := 'MARK ';
NA(.XNEW .) := 'NEW '; NA(.XPACK .) := 'PACK ';
NA(.XREAD .) := 'READ '; NA(.XRESET .) := 'RESET ';
(* NOW PUT THE STUFF IN THE HEAP IN SUCH AN ORDER AS TO KEEP THE *)
(* TREE AS BALANCED AS POSSIBLE. *)
FOR N := XODD TO XDELETE DO
ENTERPROC (N,FUNC);
ENTERPROC (XREWRITE,PROC);
ENTERTYPE (XTEXT,TEXTPTR);
FOR N := XPUT TO XUNPACK DO
ENTERPROC (N,PROC);
ENTERTYPE (XCHAR,CHARPTR);
(* ENTERTYPE (XREAL,REALPTR); COMMENTED UNTIL REALS ARE REAL*)
NEW (CP,KONST); (*MAXINT*)
WITH CP@ DO
BEGIN
NAME := NA(.XMAXINT.);
IDTYPE := INT4PTR;
NEXT := NIL;
NEW (VALUES.VALP,LINT);
VALUES.VALP@.LINTVAL := LINT4MAX;
KLASS := KONST
END; (*WITH*)
ENTERID (CP);
FOR N := XPOS TO XSQRT DO
ENTERPROC (N,FUNC);
FOR N := XDISPOSE TO XWRITE DO
ENTERPROC (N,PROC);
ENTERTYPE (XINTEGER,INT4PTR);
CPLAST := NIL;
FOR N := XFALSE TO XTRUE DO
BEGIN
NEW (CP,KONST);
WITH CP@ DO
BEGIN
NAME := NA(.N.);
IDTYPE := BOOLPTR;
NEXT := CPLAST;
IF N = XFALSE
THEN VALUES.IVAL := 0
ELSE VALUES.IVAL := 1;
KLASS := KONST
END; (*WITH*)
ENTERID (CP);
CPLAST := CP
END; (*FOR*)
BOOLPTR@.FCONST := CPLAST;
NEW (CP,KONST); (*NIL*)
WITH CP@ DO
BEGIN
NAME := NA(.XNIL.);
IDTYPE := NILPTR;
NEXT := NIL;
VALUES.IVAL := 0;
KLASS := KONST
END; (*WITH*)
ENTERID (CP);
ENTERTYPE (XBOOLEAN,BOOLPTR);
FOR N := XGET TO XWRITELN DO
ENTERPROC (N,PROC);
FOR N := XABS TO XTRUNC DO
ENTERPROC (N,FUNC);
(* NOW UP THE DISPLAY TO ALLOW REDEFINITION OF STD NAMES *)
(* AT A GLOBAL LEVEL. *)
TOP := TOP + 1;
WITH DISPLAY(.TOP.) DO
BEGIN
FNAME := NIL;
FLABEL := NIL;
OCCUR := BLCK
END (*WITH*)
END; (*ENTSTDNAMES*)
PROCEDURE ENTERUNDECL;
BEGIN
NEW(UTYPPTR,TYPES);
WITH UTYPPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL; KLASS := TYPES END;
NEW(UCSTPTR,KONST);
WITH UCSTPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL; NEXT := NIL;
VALUES.IVAL := 0; KLASS := KONST
END;
NEW(ULABPTR,LABELS);
WITH ULABPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL;
NEXT := NIL; KLASS := LABELS
END;
NEW(UVARPTR,VARS);
WITH UVARPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL; VKIND := ACTUAL;
EXTRNL := FALSE;
NEXT := NIL; VLEV := 0; VADDR := LONGZERO; KLASS := VARS
END;
NEW(UFLDPTR,FIELD);
WITH UFLDPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
KLASS := FIELD
END;
NEW(UPRCPTR,PROC,DECLARED,ACTUAL);
WITH UPRCPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL; FORWDECL := FALSE;
NEXT := NIL; (*EXTERN := FALSE;*) PFLEV := 0;
PFNAME := 1;
KLASS := PROC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END;
NEW(UFCTPTR,FUNC,DECLARED,ACTUAL);
WITH UFCTPTR@ DO
BEGIN NAME := BLANKID; IDTYPE := NIL; NEXT := NIL;
FORWDECL := FALSE; (*EXTERN := FALSE;*) PFLEV := 0;
PFNAME := 1;
KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END
END (* ENTERUNDECL *) ;
PROCEDURE INITSCALARS;
VAR I: INTEGER;
BEGIN FOR I := 1 TO IDLNGTH DO BLANKID(.I.) := ' ';
FWPTR := NIL;
NEW(CNSTVALPTR) ;
NEW(CNSTSTRPTR) ;
CNSTVALPTR@.SVAL:=CNSTSTRPTR;
LIST := TRUE; DEBUG := FALSE ;
PLIST := TRUE; PRCODE := TRUE;
DP := TRUE; STANDARD := FALSE;
PRTERR := TRUE;
ERRORS := FALSE; ERRORCOUNT :=0 ;
WARNINGS := FALSE; WARNCOUNT :=0 ;
ERRINX := 0;
(* DEFAULTS FOR 32 BIT ADDRESSES, AND WORD (16 BITS) ALIGNED MACHINE *)
ADDRSIZE := 2 * MACHINE;
ALIGNMENT := MACHINE;
ASSIGN := FALSE ;
FEXTFILEP := NIL;
GLOBFILELIST := NIL;
STDINPUT := NIL; STDOUTPUT := NIL;
LOCN := 0; (* ADR. OF THE FIRST VARIABLE OF 'MAIN BLOCK' *)
PKOUNTERS:=FALSE; KOUNTERS:=FALSE; PRINTKOUNT := FALSE;
LABELEDKOUNT := TRUE; KOUNT := 1;
OLDIC := 0; IC := 0;
EOL := FALSE; CH := ' '; LINEBUF(.0.) := ' ';
DOUBLECHAR := FALSE;
GLOBTESTP := NIL;
INTLABEL := 0; PROCLAB := 0;
ARITHMETICSIZE := 'J';
LONGZERO(.1.) := 0; LONGZERO(.2.) := 0;
LONGZERO(.3.) := 0; LONGZERO(.4.) := 0;
MAKELONG (-128,LINT1MIN);
MAKELONG (127,LINT1MAX);
MAKELONG (-32767 - 1,LINT2MIN);
MAKELONG (32767,LINT2MAX);
LINT4MIN := LONGZERO;
LINT4MIN(.4.) := 128;
LINT4MAX(.1.) := 255; LINT4MAX(.2.) := 255;
LINT4MAX(.3.) := 255; LINT4MAX(.4.) := 127;
MAKELONG (ORDMAXCHAR,LONGORDMAXCHAR);
(*SET UP THE DEFAULT JUMP TABLE ADDRESS, JUMP TABLE SIZE,
HEAP START ADDRESS, AND STACK START (TOP) ADDRESS *)
JUMPENTRIES := 10;
JUMPBASE := LONGZERO;
JUMPBASE(.2.) := 48;
HEAPSTART := LINT4MAX;
HEAPSTART(.4.) := 255;
STACKSTART := LONGZERO;
STACKSTART(.1.) := 254;
STACKSTART(.2.) := 127;
FOR I := 0 TO MAXLEVEL DO STKSIZES(.I.) := 0;
LONGONLY := FALSE;
TOP := 0;
LEVEL := 0;
WITH DISPLAY(. 0 .) DO
BEGIN
FNAME := NIL;
FLABEL := NIL;
OCCUR := BLCK
END;
LASTERR := 0;
LINECOUNT := 0;
PAGENUM := 0;
PAGELEN := PAGEDEFAULT;
PAGEPOS := STARTPAGE;
LINEWIDTH := WIDTHDEFAULT;
PAGEEND := ENDOFPAGE;
BLEV := 'A';
HEADER := 'MOTOROLA PASCAL JUL 25, 1980 ';
STARS := '**** ';
ERRMES := '**ERROR--';
EOFMESSAGE := '**** ERROR, END OF FILE ENCOUNTERED';
END (* INITSCALARS *) ;
PROCEDURE INITSETS;
BEGIN
CONSTBEGSYS := (.ADDOP,INT1CONST,INT2CONST,INT4CONST,REALCONST,
STRINGCONST,IDENT.);
SIMPTYPEBEGSYS := (.LPARENT.) + CONSTBEGSYS;
TYPEBEGSYS := (.ARROW,PACKEDSY,STRINGSY,ARRAYSY,RECORDSY,SETSY,FILESY
.) +SIMPTYPEBEGSYS;
TYPEDELS := (.STRINGSY,ARRAYSY,RECORDSY,SETSY,FILESY.);
BLOCKBEGSYS := (.LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,
BEGINSY.);
SELECTSYS := (.ARROW,PERIOD,LBRACK.);
FACBEGSYS := (.INT1CONST,INT2CONST,INT4CONST,REALCONST,STRINGCONST,
IDENT,LPARENT,LBRACK,NOTSY.);
STATBEGSYS := (.BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,
CASESY,EXITSY.);
LOOPBEGSYS := (.WHILESY,FORSY,REPEATSY.);
END (* INITSETS *) ;
PROCEDURE INITTABLES;
PROCEDURE RESWORDS;
BEGIN
RW(. 1.):= 'IF '; RW(. 2.):= 'DO '; RW(. 3.):= 'OF ';
RW(. 4.):= 'TO '; RW(. 5.):= 'IN '; RW(. 6.):= 'OR ';
RW(. 7.):= 'END '; RW(. 8.):= 'FOR '; RW(. 9.):= 'VAR ';
RW(.10.):= 'DIV '; RW(.11.):= 'MOD '; RW(.12.):= 'SET ';
RW(.13.):= 'AND '; RW(.14.):= 'NOT '; RW(.15.):= 'THEN ';
RW(.16.):= 'ELSE '; RW(.17.):= 'WITH '; RW(.18.):= 'GOTO ';
RW(.19.):= 'CASE '; RW(.20.):= 'TYPE '; RW(.21.):= 'EXIT ';
RW(.22.):= 'FILE '; RW(.23.):= 'BEGIN ';
RW(.24.):= 'UNTIL '; RW(.25.):= 'WHILE '; RW(.26.):= 'ARRAY ';
RW(.27.):= 'CONST '; RW(.28.):= 'LABEL ';
RW(.29.):= 'REPEAT '; RW(.30.):= 'RECORD '; RW(.31.):= 'DOWNTO ';
RW(.32.):= 'PACKED '; RW(.33.):= 'ORIGIN '; RW(.34.):= 'STRING ';
RW(.35.):= 'FORWARD ';
RW(.36.):= 'PROGRAM '; RW(.37.):= 'FUNCTION'; RW(.38.):= 'PROCEDUR';
RW(.39.):= 'OTHERWIS'; RW(.40.):= 'SUBPROGR';
FRW(.1.) := 1; FRW(.2.) := 1; FRW(.3.) := 7; FRW(.4.) := 15;
FRW(.5.) := 23; FRW(.6.) := 29; FRW(.7.) := 35; FRW(.8.) := 37;
FRW(.9.) := NEXTRESWD; FRW(.10.) := NEXTRESWD;
FRW(.11.) := NEXTRESWD; FRW(.12.) := NEXTRESWD; FRW(.13.):= NEXTRESWD;
END (* RESWORDS *) ;
PROCEDURE SYMBOLS;
VAR C: CHAR;
BEGIN
RSY(.1.) := IFSY; RSY(.2.) := DOSY; RSY(.3.) := OFSY;
RSY(.4.) := TOSY; RSY(.5.) := RELOP; RSY(.6.) := ADDOP;
RSY(.7.) := ENDSY; RSY(.8.) := FORSY; RSY(.9.) := VARSY;
RSY(.10.) := MULOP; RSY(.11.) := MULOP; RSY(.12.) := SETSY;
RSY(.13.) := MULOP; RSY(.14.) := NOTSY; RSY(.15.) := THENSY;
RSY(.16.) := ELSESY; RSY(.17.) := WITHSY; RSY(.18.) := GOTOSY;
RSY(.19.) := CASESY; RSY(.20.) := TYPESY; RSY(.21.) := EXITSY;
RSY(.22.) := FILESY;
RSY(.23.) := BEGINSY; RSY(.24.) := UNTILSY; RSY(.25.) := WHILESY;
RSY(.26.) := ARRAYSY; RSY(.27.) := CONSTSY; RSY(.28.) := LABELSY;
RSY(.29.) := REPEATSY; RSY(.30.) := RECORDSY; RSY(.31.) := DOWNTOSY;
RSY(.32.) := PACKEDSY; RSY(.33.) := ORIGINSY; RSY(.34.) := STRINGSY;
RSY(.35.) := FORWARDSY;
RSY(.36.) := PROGSY; RSY(.37.) := FUNCSY; RSY(.38.) := PROCSY;
RSY(.39.) := OTHERWZSY;RSY(.40.) := SUBPROGSY;
(*PP*)FOR C := CHR(0) TO CHR(ORDMAXBASECHAR) DO SSY(.C.) := OTHERSY;
(*POSSIBLE PORTABILITY PROBLEM WITH "127"*)
SSY(.'+'.) := ADDOP; SSY(.'-'.) := ADDOP; SSY(.'*'.) := MULOP;
SSY(.'/'.) := MULOP; SSY(.'('.) := LPARENT; SSY(.')'.) := RPARENT;
SSY(.'='.) := RELOP; SSY(.','.) := COMMA; SSY(.'.'.) := PERIOD;
SSY(.':'.) := COLON;
SSY(.'Æ'.) := LBRACK; SSY(.'Å'.) := RBRACK; SSY(.'!'.) := ARROW;
SSY(.'!'.) := ADDOP ; SSY(.'&'.) := MULOP ;
SSY(.'ü'.) := NOTSY; SSY(.'<'.) := RELOP; SSY(.'>'.) := RELOP;
SSY(.'@'.) := ARROW; SSY(.';'.) := SEMICOLON;
END (* SYMBOLS *) ;
PROCEDURE RATORS;
VAR I: INTEGER; C: CHAR;
BEGIN
FOR I := 1 TO LASTRESWD (* NR OF RES WORDS *) DO ROP(.I.) := NOOP;
ROP(.5.) := INOP; ROP(.10.) := IDIV; ROP(.11.) := IMOD;
ROP(.6.) := OROP; ROP(.13.) := ANDOP;
(*PP*)FOR C := CHR(0) TO CHR(ORDMAXBASECHAR) DO SOP(.C.) := NOOP;
(*POSSIBLE PORTABILITY PROBLEM WITH "127"*)
SOP(.'+'.) := PLUS; SOP(.'-'.) := MINUS; SOP(.'*'.) := MUL;
SOP(.'='.) := EQOP; SOP(.'/'.) := RDIV;
SOP(.'<'.) := LTOP; SOP(.'>'.) := GTOP;
SOP(.'ø'.) := OROP; SOP(.'&'.) := ANDOP;
(*PP*)SOP(.'Æ'.) := NOOP; SOP(.'Å'.) := NOOP;
(* INITIALIZE CHARACTER TABLE FOR INSYMBOL *)
(*PP*)FOR C := CHR(0) TO CHR(ORDMAXBASECHAR) DO CHTAB(.C.) := ILLEGALCHAR;
(*POSSIBLE PORTABILITY PROBLEM WITH "127"*)
FOR C := 'a' TO 'z' DO CHTAB(.C.) := ATOZ;
FOR C := 'A' TO 'Z' DO CHTAB(.C.) := ATOZ;
FOR C := '0' TO '9' DO CHTAB(.C.) := NUMBER;
CHTAB(.'_'.) := ATOZ; CHTAB(. '$' .) := ATOZ;
CHTAB(.'*'.) := MISCCHAR; CHTAB(.'+'.) := MISCCHAR;
CHTAB(.'-'.) := MISCCHAR; CHTAB(.'='.) := MISCCHAR;
CHTAB(.'/'.) := MISCCHAR; CHTAB(.')'.) := MISCCHAR;
CHTAB(.'&'.) := MISCCHAR; CHTAB(.'@'.) := MISCCHAR;
CHTAB(.','.) := MISCCHAR; CHTAB(.';'.) := MISCCHAR;
(*PP*)CHTAB(.'Æ'.) := MISCCHAR; CHTAB(.'Å'.) := MISCCHAR;
(*PP*)CHTAB(.'æ'.) := CMNTBRACK; CHTAB(.'!'.) := MISCCHAR;
CHTAB(.':'.) := COLONCHAR;
CHTAB(.'.'.) := PERIODCHAR; CHTAB(.''''.):= STRQUOTE;
CHTAB(.'<'.) := LPOINTY; CHTAB(.'>'.) := RPOINTY;
CHTAB(.'('.) := LPARN;
CHTAB(.' '.) := BLANKCHAR; CHTAB(.CHR(9).) := BLANKCHAR; (* TAB CHAR
*)
(* INITIALIZE ASCII TABLE FOR CASESTATEMENT, ETC. *)
(*PP*)FOR C := CHR(0) TO CHR(ORDMAXBASECHAR) DO ASCII(.C.) := 95 (*UNDERLINE*
); (*POSSIBLE PORTABILITY PROBLEM WITH "127"*)
ASCII(.'a'.):= 97; ASCII(.'b'.):= 98; ASCII(.'c'.):= 99; ASCII(.'d'.):=10
0; ASCII(.'e'.):=101; ASCII(.'f'.):=102; ASCII(.'g'.):=103; ASCII(.'h'.):=10
4; ASCII(.'i'.):=105; ASCII(.'j'.):=106; ASCII(.'k'.):=107; ASCII(.'l'.):=01
8; ASCII(.'m'.):=109; ASCII(.'n'.):=110; ASCII(.'o'.):=111; ASCII(.'p'.):=11
2; ASCII(.'q'.):=113; ASCII(.'r'.):=114; ASCII(.'s'.):=115; ASCII(.'t'.):=11
6; ASCII(.'u'.):=117; ASCII(.'v'.):=118; ASCII(.'w'.):=119; ASCII(.'x'.):=12
0; ASCII(.'y'.):=121; ASCII(.'z'.):=122; ASCII(.'A'.):= 65; ASCII(.'B'.):= 6
6; ASCII(.'C'.):= 67; ASCII(.'D'.):= 68; ASCII(.'E'.):= 69; ASCII(.'F'.):= 7
0; ASCII(.'G'.):= 71; ASCII(.'H'.):= 72; ASCII(.'I'.):= 73; ASCII(.'J'.):= 7
4; ASCII(.'K'.):= 75; ASCII(.'L'.):= 76; ASCII(.'M'.):= 77; ASCII(.'N'.):= 7
8; ASCII(.'O'.):= 79; ASCII(.'P'.):= 80; ASCII(.'Q'.):= 81; ASCII(.'R'.):= 8
2; ASCII(.'S'.):= 83; ASCII(.'T'.):= 84; ASCII(.'U'.):= 85; ASCII(.'V'.):= 8
6; ASCII(.'W'.):= 87; ASCII(.'X'.):= 88; ASCII(.'Y'.):= 89; ASCII(.'Z'.):= 9
0; ASCII(.'0'.):= 48; ASCII(.'1'.):= 49; ASCII(.'2'.):= 50; ASCII(.'3'.):= 5
1; ASCII(.'4'.):= 52; ASCII(.'5'.):= 53; ASCII(.'6'.):= 54; ASCII(.'7'.):= 5
5; ASCII(.'8'.):= 56; ASCII(.'9'.):= 57;
ASCII(.' '.) := 32; ASCII(.'*'.) := 42; ASCII(.'>'.) := 62;
ASCII(.'!'.) := 33; ASCII(.'+'.) := 43; ASCII(.'?'.) := 63;
ASCII(.'"'.) := 34; ASCII(.','.) := 44; ASCII(.'@'.) := 64;
ASCII(.'#'.) := 35; ASCII(.'-'.) := 45; ASCII(.'Æ'.) := 91;
ASCII(.'$'.) := 36; ASCII(.'.'.) := 46; ASCII(.'Ø'.) := 92;
ASCII(.'%'.) := 37; ASCII(.'/'.) := 47; ASCII(.'Å'.) := 93;
ASCII(.'&'.) := 38; ASCII(.':'.) := 58; ASCII(.'!'.) := 94;
ASCII(.''''.):= 39; ASCII(.';'.) := 59; ASCII(.'_'.) := 95;
ASCII(.'('.) := 40; ASCII(.'<'.) := 60; ASCII(.'`'.) := 96;
ASCII(.')'.) := 41; ASCII(.'='.) := 61;
(* POTENTIAL PORTABILITY PROBLEM WITH THE FOLLOWING CHARACTERS ON A
EBCDIC MACHINE *)
ASCII(.'æ'.) := 123; ASCII(.'ø'.) := 124; ASCII(.'å'.) := 125
; ASCII(.'^'.) := 126;
END (* RATORS *) ;
PROCEDURE INSTRMNEMONICS;
BEGIN
MN(. 0.) :='AB ';MN(. 1.) :='AD ';MN(. 2.) :='AFI ';MN(. 3.) :='AND ';
MN(. 4.) :='AST ';MN(. 5.) :='ATN ';MN(. 6.) :='CHK ';MN(. 7.) :='CLO ';
MN(. 8.) :='COS ';MN(. 9.) :='CSP ';MN(.10.) :='CSPF';MN(.11.) :='CUP ';
MN(.12.) :='CUPF';MN(.13.) :='CVT ';MN(.14.) :='CVB ';MN(.15.) :='DAS ';
MN(.16.) :='DEC ';MN(.17.) :='DEF ';MN(.18.) :='DIF ';MN(.19.) :='DIS ';
MN(.20.) :='DV ';MN(.21.) :='ENT ';MN(.22.) :='ENTB';MN(.23.) :='EOF ';
MN(.24.) :='EOL ';MN(.25.) :='EQU ';MN(.26.) :='EXIT';MN(.27.) :='EXP ';
MN(.28.) :='EXT ';MN(.29.) :='FJP ';MN(.30.) :='GEQ ';MN(.31.) :='GET ';
MN(.32.) :='GRT ';MN(.33.) :='IFD ';MN(.34.) :='INC ';MN(.35.) :='IND ';
MN(.36.) :='INN ';MN(.37.) :='INS ';MN(.38.) :='INT ';MN(.39.) :='IOR ';
MN(.40.) :='ISC ';MN(.41.) :='IXA ';MN(.42.) :='LAB ';MN(.43.) :='LCA ';
MN(.44.) :='LDA ';MN(.45.) :='LDC ';MN(.46.) :='LEQ ';MN(.47.) :='LES ';
MN(.48.) :='LOD ';MN(.49.) :='LOG ';MN(.50.) :='LSC ';MN(.51.) :='LSPA';
MN(.52.) :='LTA ';MN(.53.) :='LUPA';MN(.54.) :='MOD ';MN(.55.) :='MOV ';
MN(.56.) :='MOVV';MN(.57.) :='MP ';MN(.58.) :='MRK ';MN(.59.) :='NEQ ';
MN(.60.) :='NEW ';MN(.61.) :='NG ';MN(.62.) :='NOT ';MN(.63.) :='ODD ';
MN(.64.) :='PAG ';MN(.65.) :='PEE ';MN(.66.) :='POS ';MN(.67.) :='POK ';
MN(.68.) :='PUT ';MN(.69.) :='RDB ';MN(.70.) :='RDC ';MN(.71.) :='RDE ';
MN(.72.) :='RDI ';MN(.73.) :='RDJ ';MN(.74.) :='RDQ ';MN(.75.) :='RDR ';
MN(.76.) :='RDS ';MN(.77.) :='RET ';MN(.78.) :='RLN ';MN(.79.) :='RLS ';
MN(.80.) :='RST ';MN(.81.) :='RWT ';MN(.82.) :='SB ';MN(.83.) :='SCON';
MN(.84.) :='SCOP';MN(.85.) :='SDEL';MN(.86.) :='SEE ';MN(.87.) :='SGS ';
MN(.88.) :='SIN ';MN(.89.) :='SINS';MN(.90.) :='SLEN';MN(.91.) :='SPOS';
MN(.92.) :='SQR ';MN(.93.) :='SQT ';MN(.94.) :='STO ';MN(.95.) :='STP ';
MN(.96.) :='STR ';MN(.97.) :='TRC ';MN(.98.) :='UJP ';MN(.99.) :='UNI ';
MN(.100.):='WLN ';MN(.101.):='WRB ';MN(.102.):='WRC ';MN(.103.):='WRE ';
MN(.104.):='WRI ';MN(.105.):='WRJ ';MN(.106.):='WRQ ';MN(.107.):='WRR ';
MN(.108.):='WRS ';MN(.109.):='XJP ';MN(.110.):='RND ';MN(.111.):='EIO ';
MN(.112.):='MST ';MN(.113.):='VJP ';MN(.114.):='RDV ';MN(.115.):='WRV ';
MN(.116.):='ARG ';MN(.117.):='RDH ';MN(.118.):='WRH ';
(*IF MN GETS BIGGER CHANGE TYPE "MNRANGE"*)
END (* INSTRMNEMONICS *) ;
PROCEDURE UPPERCASE; (* FOR INSYMBOL TO CONVERT TO UPPERCASE
INTERNAL FORM OF IDENTIFIERS *)
VAR C: CHAR;
BEGIN
(*PP*) FOR C := CHR(0) TO CHR(ORDMAXBASECHAR) DO UPPER(.C.) := C;
(*PP*) FOR C := 'a' TO 'z' DO UPPER(.C.) := CHR(ORD(C)-ORD('a')+ORD('A'))
; END;
BEGIN (* INITTABLES *)
RESWORDS;
SYMBOLS;
RATORS;
INSTRMNEMONICS;
UPPERCASE;
END (* INITTABLES *) ;
BEGIN (* **START** PASCALCOMPILER *)
WRITELN(OUTPUT,' MOTOROLA PASCAL COMPILER VERSION ', VERSION);
WRITELN(OUTPUT,' COPYRIGHTED 1980 BY MOTOROLA, INC.');
INITSCALARS; (* INITIALIZE GLOBAL SCALARS *)
INITSETS; (* INITIALIZE GLOBAL SETS *)
INITTABLES; (* INITIALIZE GLOBAL TABLES *)
ENTERSTDTYPES; (* INITIALIZE HEAP WITH STANDARD TYPES *)
ENTSTDNAMES; (* INITIALIZE HEAP WITH STANDARD NAMES *)
ENTERUNDECL; (* INITIALIZE HEAP WITH UNDECLARED DEFAULTS *)
RESET(SOURCE);
REWRITE(PCODE);
REWRITE(LISTING);
NEWPAGE;
WRITELN(PCODE,'.',HEADER);
READLINE;
INSYMBOL; (* GET FIRST SYMBOL *)
PROGRAMME(BLOCKBEGSYS + STATBEGSYS - (. CASESY .));
(* SUMMERIZE COMPILATION *)
IF PAGEEND - PAGEPOS < 9 THEN NEWPAGE;
WRITELN(LISTING,' ');
WRITELN(LISTING,' ');
WRITE(LISTING, STARS:15);
IF ERRORCOUNT = 0 THEN
WRITE(LISTING,'NO')
ELSE
WRITE(LISTING,ERRORCOUNT:0);
WRITE(LISTING,'ERROR(S) AND ':14);
IF WARNCOUNT = 0 THEN
WRITE(LISTING,'NO')
ELSE
WRITE(LISTING,WARNCOUNT:0);
WRITELN(LISTING,'WARNING(S) DETECTED':20);
WRITELN(LISTING,' ');
IF (ERRORCOUNT <> 0) OR (WARNCOUNT <> 0) THEN
BEGIN
WRITELN(LISTING, STARS:15,'LAST ERROR LINE WAS ', LASTERR:0);
WRITELN(LISTING,' ')
END;
WRITE(LISTING, STARS:15,LINECOUNT:0,'LINES ':7);
WRITELN(LISTING, PROCLAB:0,'PROCEDURES':11);
WRITELN(LISTING,' ');
WRITELN(LISTING, STARS:15,OLDIC:0, 'PCODE INSTRUCTIONS':19);
WRITELN(OUTPUT,' ');
WRITE(OUTPUT, STARS:6);
IF ERRORCOUNT = 0 THEN
WRITE(OUTPUT,'NO')
ELSE
WRITE(OUTPUT,ERRORCOUNT:0);
WRITELN(OUTPUT,'ERROR(S) DETECTED IN COMPILATION ****':38)
END.
▶EOF◀