|
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: 313344 (0x4c800)
Types: TextFile
Names: »hjpasc«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »hjpasc«
(*$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; *
* NEW GLOBALS WARNINGS:BOOLEAN AND WARNCOUNT: *
* 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 (* DESCRIBIN
(* +++++++++
(* BASIC SYM
(* +++++++++
SYMBOL = (IDENT,INT1CONST,INT2CONST,INT4CONST,REALCONST,STRINGCONST
MULOP,ADDOP,RELOP,LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEM
PERIOD,ARROW,COLON,RANGE,BECOMES,LABELSY,CONSTSY,TYPESY,V
FUNCSY,PROGSY,PROCSY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILE
FORWARDSY,BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITH
GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
THENSY,OTHERSY,OTHERWZSY,EXITSY,ORIGINSY,STRINGSY,SUBPROG
OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP
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 C
PSET: (PVAL: SETCONST );
STRG: (SLNGTH: 0..STRGLNGTH;
SVAL: ^STRCONST)
END;
VALU = RECORD CASE (*INTVAL:*) BOOLEAN OF (*INTVAL NEVER SET NOR TE
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 IMPORTA
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=IDLNG
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: LABELR
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);
(* EXPRESSIO
(* +++++++++
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;
(* LABE
(* ++++
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 LAB
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 SCANNE
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 COU
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 COMP
VAL: VALU; (* VALUE OF LAST CONSTANT *)
LNGTH: INTEGER; (* LENGTH OF LAST STRING CONSTANT *)
ID, BLANKID, PROGNAME: ALPHA; (* LAST IDENTIFIER (POSSIBLY TRUNCAT
(* SWITCHES: *)
(* +++++++++ *)
LONGONLY, (*LONG INTEGER ONLY ALLOWED IN INSYM
SUBPROG,
DP, (* DECLARATION PART *)
PRTERR, (* TO ALLOW FORWARD REF IN PTR VARIA
ASSIGN, (* DECLARATION BY SUPPRESSING ERROR
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 O
STANDARD: BOOLEAN; (* PRINT WARNINGS IF NON STANDARD OP
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 S
UTYPPTR,UCSTPTR,UVARPTR,
UFLDPTR,UPRCPTR,UFCTPTR, (* POINTERS TO ENTRIES FOR UNDECLARED
ULABPTR,FWPTR:CTP; (* HEAD OF CHAIN OF FORW DECL TYPE IDS
STDINPUT,STDOUTPUT: CTP; (* POINTERS TO DEFAULT FILES FOR READ,
GLOBFILELIST: CTP;
FEXTFILEP: EXTFILEP; (* HEAD OF CHAIN OF EXTERNAL FILES *)
GLOBTESTP: TESTP; (* LAST TESTPOINTER *)
CNSTVALPTR : CSP ; (* POINTERS TO CURRENT STRING/REAL CNS
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 SEAR
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 W
CASE OCCUR: WHERE OF (* CONSTANT ADDRESS *)
CREC: (CLEV: LEVRANGE; (* =VREC: ID IS FIELD ID IN RECORD W
CDSPL: ADDRRANGE);(* VARIABLE ADDRESS *)
VREC: (VDSPL: ADDRRANGE)
END; (* --> PROCEDURE WITHSTATEMENT *)
(* ERROR MESSAGES: *)
(* +++++++++++++++ *)
ERRINX: 0..10; (* NR OF ERRORS IN CURRENT SOURCE LI
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,FACBEGSY
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 PROBL
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 T
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 OPE
SY := RSYÆIÅ;
OP := ROPÆIÅ
END (*THEN*)
ELSE BEGIN (*ISN'T A RESERVED WORD - SHOW IT IS AN IDEN
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: DIGITS
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 CHARA
NEXTCH; (*GET THE NEXT CHARAC
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 KNO
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 NUM
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 + LONGV
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 TH
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 DIG
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
ELSE NEXTCH (*GET NEXT CHARACTER*)
UNTIL CH <> ''''; (*TO CHECK FOR DOUBLE QUO
LNGTH := LNGTH - 1;
IF LNGTH = 1
THEN VAL.IVAL := ORD(SVAL^Æ1Å) (*HAVE A SINGLE CHAR
ELSE
BEGIN (*CHECK ON LENGTH OF STRI
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 CH
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 FRO
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 (SYMBOLGOT
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 = INT
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: LNGIN
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 H
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 = INT4CON
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
BE COMPATIBLE.
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS M
BE THE SAME *)
RECORDS:
BEGIN NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP:=
WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
BEGIN COMP:=COMP AND COMPTYPES(NXT1^.IDTYPE,NXT2^.ID
NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND(FSP1^.RECVAR = NIL)AND(FSP2^.RECVAR =
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' BOUNDA
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 BL
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 SU
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 REGU
LSP1 := INT2PTR;
LSP2 := INT2PTR
END (*THEN*)
ELSE
BEGIN
NEW(CVAL,LINT);
IF LSP1 = INT4PTR
THEN BEGIN
MAKELONG (VAL2.IVAL,LVA
VAL2.VALP := CVAL;
LSP2 := INT4PTR
END (*THEN*)
ELSE BEGIN
MAKELONG (VAL1.IVAL,LVA
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^.LIN
VAL2.VALP^.LIN
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,CASE
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 EXTR
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 KNO
END;
PRTERR := FALSE ; SEARCHID(ÆTYPESÅ,LCP1) ; PRTERR := T
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(10
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
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 SUCCESSF
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 EN
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 TA
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 E
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 FILE
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 := ORIGI
IF STANDARD THEN
WARNING(504) E
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
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,
IF LSP <> NIL THEN IF LSP^.FORM = FILES THEN
BEGIN (*MARK AS DEFINED ON LIST OF EXTERNAL FILE
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 := LCP
PFLEV := LEVEL;
(* BEWARE OF PARAMETER PROCEDURES *)
KLASS:=PROC;PFDECKIND:=DECLARED;PFKIND:=FO
END;
ENTERID(LCP);
LCP1 := LCP;
PARMLEN := PARMLEN + ADDRSIZE;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + ÆCOMMA,SEMICOLON,RPARENTÅ)
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 :=
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 EN
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Å)
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 :=
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 := ADD
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(PAR
(*IF COUNT > 1 THEN LEN := ALIGN(LEN
LEN := ALIGN(LEN);
(*THE ABOVE IS SLIGHTLY LESS EFFICIEN
THAN ABSOLUTELY NECESSARY (BYTE SIZE
OBJECTS TAKE A WHOLE WORD ON WORD-AL
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Å)
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Å)
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=ACTUA
ELSE
IF LCP^.KLASS = FUNC THEN
FORW:=LCP^.FORWDECL AND(FSY=FUNCSY)AND(LCP^.PFKIND=ACTUA
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,PO
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
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-FIEL
OF THE INSTRUCTION RECORD UNTIL WRITEOUT.
--> PROCEDURE LOAD, PROCEDURE WRITEOUT, NOT NEEDED IN P_CO
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 = INT
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 = INT
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(OPE
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, ' ', OPE
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^
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)
IF TYPTR = BOOLPTR THEN GENTI(45(*LDC*),'B',CVA
ELSE
IF TIPE = 'C' THEN
GENTI(45(*LDC*),'C',CVAL.IVAL)
ELSE IF TIPE = 'I' THEN
GENTI (45(*LDC*),'I',CVAL.IVAL) (* INTEG
ELSE IF TIPE = 'H' THEN
GENTI (45(*LDC*),'H',CVAL.IVAL) (* SHORT
ELSE GENTJ (45(*LDC*),'J',CVAL.VALP^.LINTVAL)
ELSE
IF TYPTR = NILPTR THEN GENTJ(45(*LDC*),'A',LONG
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,D
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^
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^.
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(11
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,
K := GETTYPE (GATTR.TYPTR);
IF K <> 'I' THEN
GEN2T (13 (*CVT*), K, 'I');
GETBOUNDS (INXTYPE, LNGMIN, LNG
LMIN := MAKESHORT (LNGMIN);
IF LMIN > 0 THEN
GENTI (16 (*DEC*), 'I', LMIN
ELSE IF LMIN < 0 THEN
GENTI (34 (*INC*), 'I', ABS
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 + FLDAD
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:BOOLEA
(* 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 := DEFAULT
ELSE BEGIN IF RD
THEN ERROR
ELSE ERROR
LCP := UVARP
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 := FA
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 := FALS
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 'IN
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 LE
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 L
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,RPAREN
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
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(
ELSE BEGIN
GENTLI(48 (*LOD*),'A',VLEV,VADDR(
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^.RE
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 RAN
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(
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 OUT
* WORLD AND PROVIDE BREAK POINTS IN THE PASCAL PROGRAM.
* 'HALT(I, R)' RETURNS THE INTEGER CONSTANT I TO THE OPERAT
* 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
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
(*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/FU
AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PAS
IN THIS IMPLEMENTATION, PARAMETER PROC/FUNCS ARE THERE
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Å) E
ELSE
BEGIN
IF NXT^.KLASS = PROC THEN SEARCHID(ÆPROCÅ,LC
ELSE
BEGIN SEARCHID(ÆFUNCÅ,LCP);
IF NOT COMPTYPES(LCP^.IDTYPE,NXT^.IDTYPE)
ERROR(128)
END;
INSYMBOL;
IF NOT (SY IN FSYS + ÆCOMMA,RPARENTÅ) THEN
BEGIN ERROR(6); SKIP(FSYS + ÆCOMMA,RPARENT.
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.TYP
CHKBNDS (LSP, GATTR.TYPTR
IF INTTYPE (GATTR.TYPTR) THE
CNVRTTOLHS (LSP, GATTR.TY
END
ELSE
BEGIN
LOAD; (*****LOADADDRESS;*****)
IF LSP^.FORM = STRINGS THEN
GEN2TI(13(*CVT*),'S','U',LSP^.SIZE(*
(*CONVERTS NORMALIZED STRING
FULL SIZE STRING FOR PARAM P
ELSE IF CHARARRAY(LSP) AND
(GATTR.TYPTR^.FORM=STRINGS) T
BEGIN
GEN2TI(13(*CVT*),'S','V',LSP
GATTR.TYPTR := LSP
END
END
ELSE
IF (GATTR.KIND = VARBL) OR
(GATTR.KIND = FILEPTR) THEN
BEGIN LOADADDRESS;
IF GATTR.TYPTR^.SIZE <> LSP^.SIZ
ERROR(142) ;
END
ELSE ERROR(154);
IF NOT COMPTYPES(LSP,GATTR.TYPTR) TH
ERROR(142);
WITH GATTR DO
IF (KIND = VARBL) OR (KIND = FILE
THEN
K := 'A'
ELSE
K := GETTYPE(LSP);
IF (K = 'S') OR (K = 'V') THEN
GENT2I(116 (*ARG*), K, 1, LSP^.SI
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^.
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 RE
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,XPOSITIO
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 LO
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: ST
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, RIGH
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 INTEG
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 := FAL
CONSTEL := FALSE;
RANGED := FALSE;
NEW(LSP,POWER);
WITH LSP^ DO
BEGIN ELSET:=NIL;SIZE:=SETSIZE;FORM:=POWER E
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',
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.TYP
CASE LOP OF
MUL:
BEGIN
IF INTEGERS THEN
GENT (57 (*MP*), GETTYPE (GATTR.TYPT
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.TYPT
ELSE
ILLEGALOPERANDS;
END (*IDIV*);
IMOD:
BEGIN
IF INTEGERS THEN
GENT (54 (*MOD*), GETTYPE (GATTR.TYP
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.TY
CASE LOP OF
PLUS:
BEGIN
IF INTEGERS THEN
GENT (1 (*AD*), GETTYPE (GATTR.TYPT
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.TYP
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, '
IF C = 'C' THEN GENTI(16(*DEC*), 'I', 3
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
CONVERTTOLIKEINTEGERS (LATTR.TYPTR, GATTR.TYPT
ELSE IF CHARARRAY(LATTR.TYPTR) AND
(GATTR.TYPTR^.FORM = STRINGS) THEN
BEGIN GEN2TI(13(* CVT *),'S','V',LATTR.TYPTR
GATTR.TYPTR := LATTR.TYPTR
END
ELSE IF CHARARRAY(GATTR.TYPTR) AND
(LATTR.TYPTR^.FORM = STRINGS) THEN
BEGIN GEN2TI(14(* CVB *),'S','V',GATTR.TYPTR
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=INT2P
BEGIN GEN2T(13( CVT ),'I','R');
GATTR.TYPTR := REALPTR
END
ELSE *) IF (GATTR.TYPTR^.FORM=STRINGS) AND CHARARRAY(LATT
THEN BEGIN GEN2TI(13(* CVT *),'S','V',LATTR.TYPTR^.S
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^.SIZ
ELSE GENTI(94(*STO*),'V',LATTR.TYPTR^
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 CLAU
(* 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 VA
(* UBND: DEF 'BIG ALTERNATE VA
(* LCIX: VJP LOTHERWZ
(* VJP LCIX1I
(* .
(* .
(* .
(* LFINISH: . . .
(*(WHERE VJP IS UJP WITHOUT SHORT D
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 WO
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.IVA
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
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',LCI
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 NUL
VAR FOUND: BOOLEAN; (*THEN EXIT CURRENT LOOP CONST
LPTR: LOOPPTR; (*(WHILE,REPEAT,OR FOR) IF LAB
(*THEN EXIT LOOP WITH THAT LAB
(*'LOOPENTRY' AND 'LOOPEXIT' K
(*A STACK OF THE CURRENT EXIT
(*EITHER USE THE TOP ITEM OR S
(*BACK UNTIL FIND ONE POINTING
(*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 ERR
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 STM
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 AN
(*THIS CODE ASSUMES THAT LLP IS NIL IF
THE CURRENT STATEMENT IS NOT LABELLED*)
NEXTLOOP:= LOOPLISTPTR; (*PUT ON STACK OF LOOP EXIT LABE
USED := FALSE (*NOT REFERENCED YET*)
END;
LOOPLISTPTR := LPTR
END; (*LOOPENTRY*)
PROCEDURE LOOPEXIT; (*PROCESS AND REMOVE THE EX
LABEL FOR THIS LOOP*)
BEGIN WITH LOOPLISTPTR^ DO BEGIN
IF USED THEN PUTLABEL(LABNO); (*INSERT EXIT LABEL INTO O
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;
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 LAB
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
IFSY: BEGIN GENKOUNT(FALSE); INSYMBOL; IFSTATEMENT
CASESY: BEGIN
BLEV := USUCC(BLEV);
SBLOCK := TRUE;
GENKOUNT(FALSE);
INSYMBOL;
CASESTATEMENT
END;
WHILESY: BEGIN GENKOUNT(FALSE); INSYMBOL; WHILESTATEMENT
REPEATSY: BEGIN
BLEV := USUCC(BLEV);
SBLOCK := TRUE;
INSYMBOL;
REPEATSTATEMENT
END;
(* GENKOUNT(FALSE) WHEN 'UNTIL' ENCOUNTERED
FORSY: BEGIN GENKOUNT(FALSE); INSYMBOL; FORSTATEMENT
EXITSY: BEGIN GENKOUNT(FALSE); INSYMBOL; EXITSTATEMENT
WITHSY: BEGIN INSYMBOL; WITHSTATEMENT
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(FIL
GENTI(116 (*ARG*), 'A', 0);
(*GET POSITION IN PROGRAM HEADER LI
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 POSIT
GENTI(116 (*ARG*), 'I', 0);
(*BUILD FILE STATUS
IF IDTYPE = TEXTPTR THEN STATUS := 4 ELSE STATUS
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 STATU
GENTI(116 (*ARG*), 'I', 0);
GENTI(45(*LDC*),'I',IDTYPE^.FILTYPE^.SIZE);
(*PUSH COMPONENT SI
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(*RS
ELSE K := 81(*RW
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(FIL
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 DEC
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^
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 EXTERNA
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 SUBPRO
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Å :=
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,F
+SIMPTYPEBEGSYS;
TYPEDELS := ÆSTRINGSY,ARRAYSY,RECORDSY,SETSY,FILESYÅ;
BLOCKBEGSYS := ÆLABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,
BEGINSYÅ;
SELECTSYS := ÆARROW,PERIOD,LBRACKÅ;
FACBEGSYS := ÆINT1CONST,INT2CONST,INT4CONST,REALCONST,STRINGCO
IDENT,LPARENT,LBRACK,NOTSYÅ;
STATBEGSYS := ÆBEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHS
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Å:= NEXTRE
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Å := ADDO
RSYÆ7Å := ENDSY; RSYÆ8Å := FORSY; RSYÆ9Å := VARS
RSYÆ10Å := MULOP; RSYÆ11Å := MULOP; RSYÆ12Å := SETS
RSYÆ13Å := MULOP; RSYÆ14Å := NOTSY; RSYÆ15Å := THEN
RSYÆ16Å := ELSESY; RSYÆ17Å := WITHSY; RSYÆ18Å := GOTO
RSYÆ19Å := CASESY; RSYÆ20Å := TYPESY; RSYÆ21Å := EXIT
RSYÆ22Å := FILESY;
RSYÆ23Å := BEGINSY; RSYÆ24Å := UNTILSY; RSYÆ25Å := WHIL
RSYÆ26Å := ARRAYSY; RSYÆ27Å := CONSTSY; RSYÆ28Å := LABE
RSYÆ29Å := REPEATSY; RSYÆ30Å := RECORDSY; RSYÆ31Å := DOWN
RSYÆ32Å := PACKEDSY; RSYÆ33Å := ORIGINSY; RSYÆ34Å := STRI
RSYÆ35Å := FORWARDSY;
RSYÆ36Å := PROGSY; RSYÆ37Å := FUNCSY; RSYÆ38Å := PROC
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Æ')'Å := RPAREN
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Å := ILLEGALCHA
(*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
(* INITIALIZE ASCII TABLE FOR CASESTATEMENT, ETC. *)
(*PP*)FOR C := CHR(0) TO CHR(ORDMAXBASECHAR) DO ASCIIÆCÅ := 95 (*UNDER
(*POSSIBLE PORTABILITY PROBLEM WITH "127"*)
ASCIIÆ'a'Å:= 97; ASCIIÆ'b'Å:= 98; ASCIIÆ'c'Å:= 99; ASCIIÆ'd'.
ASCIIÆ'e'Å:=101; ASCIIÆ'f'Å:=102; ASCIIÆ'g'Å:=103; ASCIIÆ'h'.
ASCIIÆ'i'Å:=105; ASCIIÆ'j'Å:=106; ASCIIÆ'k'Å:=107; ASCIIÆ'l'.
ASCIIÆ'm'Å:=109; ASCIIÆ'n'Å:=110; ASCIIÆ'o'Å:=111; ASCIIÆ'p'.
ASCIIÆ'q'Å:=113; ASCIIÆ'r'Å:=114; ASCIIÆ's'Å:=115; ASCIIÆ't'.
ASCIIÆ'u'Å:=117; ASCIIÆ'v'Å:=118; ASCIIÆ'w'Å:=119; ASCIIÆ'x'.
ASCIIÆ'y'Å:=121; ASCIIÆ'z'Å:=122; ASCIIÆ'A'Å:= 65; ASCIIÆ'B'.
ASCIIÆ'C'Å:= 67; ASCIIÆ'D'Å:= 68; ASCIIÆ'E'Å:= 69; ASCIIÆ'F'.
ASCIIÆ'G'Å:= 71; ASCIIÆ'H'Å:= 72; ASCIIÆ'I'Å:= 73; ASCIIÆ'J'.
ASCIIÆ'K'Å:= 75; ASCIIÆ'L'Å:= 76; ASCIIÆ'M'Å:= 77; ASCIIÆ'N'.
ASCIIÆ'O'Å:= 79; ASCIIÆ'P'Å:= 80; ASCIIÆ'Q'Å:= 81; ASCIIÆ'R'.
ASCIIÆ'S'Å:= 83; ASCIIÆ'T'Å:= 84; ASCIIÆ'U'Å:= 85; ASCIIÆ'V'.
ASCIIÆ'W'Å:= 87; ASCIIÆ'X'Å:= 88; ASCIIÆ'Y'Å:= 89; ASCIIÆ'Z'.
ASCIIÆ'0'Å:= 48; ASCIIÆ'1'Å:= 49; ASCIIÆ'2'Å:= 50; ASCIIÆ'3'.
ASCIIÆ'4'Å:= 52; ASCIIÆ'5'Å:= 53; ASCIIÆ'6'Å:= 54; ASCIIÆ'7'.
ASCIIÆ'8'Å:= 56; ASCIIÆ'9'Å:= 57;
ASCIIÆ' 'Å := 32; ASCIIÆ'*'Å := 42; ASCIIÆ'>'Å :
ASCIIÆ'!'Å := 33; ASCIIÆ'+'Å := 43; ASCIIÆ'?'Å :
ASCIIÆ'"'Å := 34; ASCIIÆ','Å := 44; ASCIIÆ'^'Å :
ASCIIÆ'#'Å := 35; ASCIIÆ'-'Å := 45; ASCIIÆ''Å :=
ASCIIÆ'$'Å := 36; ASCIIÆ'.'Å := 46; ASCIIÆ''Å :=
ASCIIÆ'%'Å := 37; ASCIIÆ'/'Å := 47; ASCIIÆ''Å :=
ASCIIÆ'&'Å := 38; ASCIIÆ':'Å := 58; ASCIIÆ'!'Å :
ASCIIÆ''''Å:= 39; ASCIIÆ';'Å := 59; ASCIIÆ'_'Å :
ASCIIÆ'('Å := 40; ASCIIÆ'<'Å := 60; ASCIIÆ''Å :=
ASCIIÆ')'Å := 41; ASCIIÆ'='Å := 61;
(* POTENTIAL PORTABILITY PROBLEM WITH THE FOLLOWING CHARACTERS ON A
EBCDIC MACHINE *)
ASCIIÆ''Å := 123; ASCIIÆ''Å := 124; ASCIIÆ''Å := 1
ASCIIÆ'-,'Å := 126;
END (* RATORS *) ;
PROCEDURE INSTRMNEMONICS;
BEGIN
MNÆ 0Å :='AB ';MNÆ 1Å :='AD ';MNÆ 2Å :='AFI ';MNÆ 3Å :='AN
MNÆ 4Å :='AST ';MNÆ 5Å :='ATN ';MNÆ 6Å :='CHK ';MNÆ 7Å :='CL
MNÆ 8Å :='COS ';MNÆ 9Å :='CSP ';MNÆ10Å :='CSPF';MNÆ11Å :='CU
MNÆ12Å :='CUPF';MNÆ13Å :='CVT ';MNÆ14Å :='CVB ';MNÆ15Å :='DA
MNÆ16Å :='DEC ';MNÆ17Å :='DEF ';MNÆ18Å :='DIF ';MNÆ19Å :='DI
MNÆ20Å :='DV ';MNÆ21Å :='ENT ';MNÆ22Å :='ENTB';MNÆ23Å :='EO
MNÆ24Å :='EOL ';MNÆ25Å :='EQU ';MNÆ26Å :='EXIT';MNÆ27Å :='EX
MNÆ28Å :='EXT ';MNÆ29Å :='FJP ';MNÆ30Å :='GEQ ';MNÆ31Å :='GE
MNÆ32Å :='GRT ';MNÆ33Å :='IFD ';MNÆ34Å :='INC ';MNÆ35Å :='IN
MNÆ36Å :='INN ';MNÆ37Å :='INS ';MNÆ38Å :='INT ';MNÆ39Å :='IO
MNÆ40Å :='ISC ';MNÆ41Å :='IXA ';MNÆ42Å :='LAB ';MNÆ43Å :='LC
MNÆ44Å :='LDA ';MNÆ45Å :='LDC ';MNÆ46Å :='LEQ ';MNÆ47Å :='LE
MNÆ48Å :='LOD ';MNÆ49Å :='LOG ';MNÆ50Å :='LSC ';MNÆ51Å :='LS
MNÆ52Å :='LTA ';MNÆ53Å :='LUPA';MNÆ54Å :='MOD ';MNÆ55Å :='MO
MNÆ56Å :='MOVV';MNÆ57Å :='MP ';MNÆ58Å :='MRK ';MNÆ59Å :='NE
MNÆ60Å :='NEW ';MNÆ61Å :='NG ';MNÆ62Å :='NOT ';MNÆ63Å :='OD
MNÆ64Å :='PAG ';MNÆ65Å :='PEE ';MNÆ66Å :='POS ';MNÆ67Å :='PO
MNÆ68Å :='PUT ';MNÆ69Å :='RDB ';MNÆ70Å :='RDC ';MNÆ71Å :='RD
MNÆ72Å :='RDI ';MNÆ73Å :='RDJ ';MNÆ74Å :='RDQ ';MNÆ75Å :='RD
MNÆ76Å :='RDS ';MNÆ77Å :='RET ';MNÆ78Å :='RLN ';MNÆ79Å :='RL
MNÆ80Å :='RST ';MNÆ81Å :='RWT ';MNÆ82Å :='SB ';MNÆ83Å :='SC
MNÆ84Å :='SCOP';MNÆ85Å :='SDEL';MNÆ86Å :='SEE ';MNÆ87Å :='SG
MNÆ88Å :='SIN ';MNÆ89Å :='SINS';MNÆ90Å :='SLEN';MNÆ91Å :='SP
MNÆ92Å :='SQR ';MNÆ93Å :='SQT ';MNÆ94Å :='STO ';MNÆ95Å :='ST
MNÆ96Å :='STR ';MNÆ97Å :='TRC ';MNÆ98Å :='UJP ';MNÆ99Å :='UN
MNÆ100Å:='WLN ';MNÆ101Å:='WRB ';MNÆ102Å:='WRC ';MNÆ103Å:='WR
MNÆ104Å:='WRI ';MNÆ105Å:='WRJ ';MNÆ106Å:='WRQ ';MNÆ107Å:='WR
MNÆ108Å:='WRS ';MNÆ109Å:='XJP ';MNÆ110Å:='RND ';MNÆ111Å:='EI
MNÆ112Å:='MST ';MNÆ113Å:='VJP ';MNÆ114Å:='RDV ';MNÆ115Å:='WR
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(
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◀