(*$L- ZPAS7, SEPT 22, 78 *) (****************************************************************** * * * * * STEP-WISE DEVELOPMENT OF A PASCAL COMPILER * * ****************************************** * * * * * * STEP 5: SYNTAX ANALYSIS INCLUDING ERROR * * HANDLING; CHECKS BASED ON DECLARA- * * 10/7/73 TIONS; ADDRESS AND CODE GENERATION * * FOR A HYPOTHETICAL STACK COMPUTER * * * * * * AUTHOR: URS AMMANN * * FACHGRUPPE COMPUTERWISSENSCHAFTEN * * EIDG. TECHNISCHE HOCHSCHULE * * CH-8006 ZUERICH * * * * * * MODIFICATION OF STEP 5 OF PASCAL COMPILER * * ***************************************** * * * * 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. * * * * AUTHOR OF CHANGES: KESAV NORI * * COMPUTER GROUP * * T.I.F.R. * * HOMI BHABHA ROAD * * BOMBAY - 400005 * * INDIA * * * * THESE CHANGES WERE COMPLETED AT ETH, ZURICH * * ON 20/5/74. * * * * * * +++++++++++++++++++++++++++++++++++++++++++ * * * * * * * * THE COMPILER IS NOW CHANGED TO: * * ******************************* * * * * * * -PRODUCE THE INTERMEDIATE CODE IN AN ASSEMBLER * * READABLE FORM WITH NO EXTRA SPACES BETWEEN VARIOUS * * FIELDS, 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 'EXIT(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. * * * * -'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. ERROR NO. "260" IS USED TO * * FLAG DECLARATION OF LARGE DIMENSIONED ARRAYS, OR * * OTHER DATA STRUCTURES, WHICH RESULT IN OUT-OF-RANGE * * ADDRESSES, 11-FEB-78. * * * * -TO BE COMPATIBLE WITH THE PASCAL-6000 THE FILE NAME * * AS WELL AS THE ARGUMENT LIST MAY BE OMITTED FOR * * CERTAIN I/O RELATED OPERATIONS, IN WHICH CASE THE * * APPROPRIATE DEFAULT FILE WILL BE USED FOR THAT * * OPERATION. FOR EXAMPLE STATEMENTS SUCH AS "WRITELN", * * "WRITELN()" OR "WRITELN(OUTPUT)" WILL HAVE SIMILAR * * EFFECT. LIKEWISE "EOF(INPUT)", "EOF()" OR "EOF" WILL * * TRANSLATE INTO IDENTICAL EXPRESSIONS, 23-MAY-78. * * * * * * * * * * S. HAZEGHI * * * * COMPUTATION RESEARCH GROUP * * STANFORD LINEAR ACCELERATOR CENTER * * STANFORD, CA. 94305. * * * * * * * ******************************************************************) PROGRAM PASCALCOMPILER(INPUT,OUTPUT); CONST DISPLIMIT = 16; MAXLEVEL = 8; MAXADDR = 32000 ; INTSIZE = 2; (* REALSIZE = 8; *) CHARSIZE = 2; (* BOOLSIZE = 2; *) SETSIZE =8; PTRSIZE = 2; (* LCAFTMST = 0; FPSAVEAREA = 0 ; RUNCHKAREA = 0 ; (* DSPLYAREA = 0 ; FNCRSLT = 0 ; LCAFTFNCRSLT = 8 ; (* FIRSTFILEBUF = 0 ; (* = LCAFTMST+RUNCHKAREA+DSPLYAREA *) LASTFILBUF = 8 ; (* LAST FILE BUFFER / FIRST PROG. VARIABLE *) STRGLNGTH = 48; MAXINT = 32767 ; ORDMAXCHAR = 63 ; REALLNGTH = 11 ; (* SHOULD BE LESS THAN STRGLGTH *) DIGMAX = 10 ; (* REALLNGHT-1*) (* IDLNGTH = 8 ; *) SETRANGE = 63 ; ## ## LINELGTH = 81 ; (* MAXPROC = 99 ; *) BLANKID = ' ' ; TYPE (*DESCRIBING:*) (*************) (*BASIC SYMBOLS*) (***************) SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP, LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW, COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,FUNCSY,PROGSY, PROCSY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY, BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY, GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY, THENSY,OTHERSY); OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP, NEOP,EQOP,INOP,NOOP); SETOFSYS = SET OF SYMBOL; (*CONSTANTS*) (***********) CSTCLASS = (REEL,PSET,STRG); CSP = @ CONSTANT; CONSTANT = RECORD CASE "CCLASS:" CSTCLASS OF REEL: (RVAL: PACKED ARRAY [0..REALLNGTH] OF CHAR); PSET: (PVAL: SET OF 0..SETRANGE); STRG: (SLNGTH: 0..STRGLNGTH; SVAL: PACKED ARRAY [1..STRGLNGTH] OF CHAR) END; VALU = RECORD CASE "INTVAL:" BOOLEAN OF (*INTVAL NEVER SET NORE TESTED*) TRUE: (IVAL: INTEGER); FALSE: (VALP: CSP) END; (*DATA STRUCTURES*) (*****************) LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR; " ALNRNG = 1..8 ;" LABELRNG = 0..1000 ; STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES, TAGFLD,VARIANT); DECLKIND = (STANDARD,DECLARED); STP = @ STRUCTURE; CTP = @ IDENTIFIER; STRUCTURE = PACKED RECORD (* MARKED: BOOLEAN; TO BE USED WITH 'T+', FOR TEST PHASE ONLY*) SIZE: ADDRRANGE; CASE FORM: STRUCTFORM OF SCALAR: (CASE SCALKIND: DECLKIND OF DECLARED: (FCONST: CTP)); SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU); POINTER: (ELTYPE: STP); POWER: (ELSET: STP); 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,KONST,VARS,FIELD,PROC,FUNC); SETOFIDS = SET OF IDCLASS; IDKIND = (ACTUAL,FORMAL); ALPHA = PACKED ARRAY [0..7] OF CHAR; IDENTIFIER = PACKED RECORD NAME: ALPHA; LLINK, RLINK: CTP; IDTYPE: STP; NEXT: CTP; CASE KLASS: IDCLASS OF KONST: (VALUES: VALU); VARS: (VKIND: IDKIND; VLEV: LEVRANGE; VADDR: ADDRRANGE); FIELD: (FLDADDR: ADDRRANGE); PROC, FUNC: (CASE PFDECKIND: DECLKIND OF STANDARD: (KEY: 1..15); DECLARED: (PFLEV: LEVRANGE; PFNAME: LABELRNG; PLEN : 0..250 ; CASE PFKIND: IDKIND OF ACTUAL: (FORWDECL, EXTERN: BOOLEAN))) END; DISPRANGE = 0..DISPLIMIT; WHERE = (BLCK,CREC,VREC,REC); (*EXPRESSIONS*) (*************) ATTRKIND = (CST,VARBL,EXPR); VACCESS = (DRCT,INDRCT,INXD); ATTR = RECORD TYPTR : STP; CASE KIND: ATTRKIND OF CST: (CVAL: VALU); VARBL: (CASE ACCESS: VACCESS OF DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE); INDRCT: (IDPLMT: ADDRRANGE)) END; TESTP = @ TESTPOINTER; TESTPOINTER = PACKED RECORD ELT1,ELT2 : STP; LASTTESTP : TESTP END; (*LABELS*) (********) LBP = @ LABL; LABL = RECORD NEXTLAB: LBP; DEFINED: BOOLEAN; LABVAL, LABNAME: INTEGER END; EXTFILEP = @FILEREC; FILEREC = RECORD FILENAME:ALPHA; NEXTFILE:EXTFILEP; END; (*-------------------------------------------------------------------------*) VAR (*PRD, PRR: TEXT; *) (*RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL: **********) SY: SYMBOL; (*LAST SYMBOL*) OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*) " KK: 1..IDLNGTH; " (*NR OF CHARS IN LAST IDENTIFIER*) CH: CHAR; (*LAST CHARACTER READ*) EOL: BOOLEAN; (*END OF LINE FLAG*) (*COUNTERS:*) (***********) CHCNT: -1..LINELGTH; (*CHARACTER COUNTER*) LC,IC,OLDIC: ADDRRANGE ; (*DATA LOCATION AND INSTRUCTION COUNTER*) LINECNT (* ,MXDATASZE *) : INTEGER; ERRORCOUNT",CTIME":INTEGER ; (*TOTAL ERROR COUNT*) GATTR: ATTR; (*DESCRIBES THE EXPR CURRENTLY COMPILED*) VAL: VALU; (*VALUE OF LAST CONSTANT*) LNGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*) ID: ALPHA ; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)*) (*SWITCHES:*) (***********) DP, (*DECLARATION PART*) PRTERR, (*TO ALLOW FORWARD REF. IN PTR. VARIABLES *) ASSIGN, (*DECLARATION BY SUPPRESSING ERROR MSG*) LIST,PRCODE, (* PRTABLES,PRTIC, *) (* MARGIN, *) DEBUG,PACKSTRNG : BOOLEAN ; (*OUTPUT OPTIONS FOR -- SOURCE PROGRAM LISTING -- PRINTING SYMBOLIC CODE -- DISPLAYING IDENT AND STRUCT TABLES --> SET INPUT MARGIN AT 72 COLS. --> PRINT INST_CNTR, PROCEDURE OPTION*) (*POINTERS:*) (***********) INTPTR,REALPTR,CHARPTR,ALFAPTR, BOOLPTR,NILPTR,TEXTPTR: STP; (*POINTERS TO ENTRIES OF STANDARD IDS*) UTYPPTR,UCSTPTR,UVARPTR, UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*) FWPTR: CTP; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*) FEXTFILEP: EXTFILEP; (*HEAD OF CHAIN OF EXTERNAL FILES*) GLOBTESTP: TESTP; (*LAST TESTPOINTER*) CNSTVALPTR : CSP ; (* POINTERS TO CURRENT STRING/REAL CNST *) (*BOOKKEEPING OF DECLARATION LEVELS:*) (************************************) LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*) DISX, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*) TOP: DISPRANGE; (*TOP OF DISPLAY*) DISPLAY: (*WHERE: MEANS:*) ARRAY [DISPRANGE] OF PACKED RECORD (*=BLCK: ID IS VARIABLE ID*) FNAME: CTP; FLABEL: LBP; (*=CREC: ID IS FIELD ID IN RECORD WITH*) CASE OCCUR: WHERE OF (* CONSTANT ADDRESS*) CREC: (CLEV: LEVRANGE; (*=VREC: ID IS FIELD ID IN RECORD WITH*) CDSPL: ADDRRANGE);(* VARIABLE ADDRESS*) VREC: (VDSPL: ADDRRANGE) END; (* --> PROCEDURE WITHSTATEMENT*) (*ERROR MESSAGES:*) (*****************) ERRINX: 0..10; (*NR OF ERRORS IN CURRENT SOURCE LINE*) ERRLIST: ARRAY [1..10] OF PACKED RECORD POS: 0..LINELGTH; NMR: 1..400 END; (*EXPRESSION COMPILATION:*) (*************************) (*STRUCTURED CONSTANTS:*) (***********************) "NUMERIC," ALPHANUMERIC : SET OF CHAR ; (*VALID ALPHA-NUMERICS*) LINEBUF: ARRAY[0..LINELGTH] OF CHAR ; (*CURRENT LINE BUFFER*) "STOPCH: CHAR ; " (*TO FLAG END OF LINEBUF*) (* SEQFLD: ARRAY [0..7] OF CHAR ; (*SEQUENCE FIELD OF INPUT LINE, $M+ ONLY*) CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS, STATBEGSYS,TYPEDELS: SETOFSYS; NXTFILBUF : ADDRRANGE ; RW: ARRAY [0..35(*NR. OF RES. WORDS*)] OF ALPHA; FRW: ARRAY [0..9] OF 1..36 (*NR. OF RES. WORDS + 1*); RSY: ARRAY [0..35(*NR. OF RES. WORDS*)] OF SYMBOL; SSY: ARRAY [CHAR] OF SYMBOL; ROP: ARRAY [0..35(*NR. OF RES. WORDS*)] OF OPERATOR; SOP: ARRAY [CHAR] OF OPERATOR; NA: ARRAY [0..42] OF ALPHA; " MN: ARRAY [0..63] OF PACKED ARRAY [0..2] OF CHAR; SNA: ARRAY [0..30] OF PACKED ARRAY [0..2] OF CHAR; " CALL_CNT : ARRAY[0.. 99 (* MAXPROC *) ] OF INTEGER ; INTLABEL,PROCLAB: LABELRNG ; MXINT10: INTEGER; " ASCII : ARRAY [CHAR] OF 32..95 ; " (*-------------------------------------------------------------------------*) PROCEDURE PRINTERROR ; VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER; BEGIN IF NOT LIST THEN BEGIN WRITELN(OUTPUT) ; WRITELN(OUTPUT,LINECNT:4, ' ':11, LINEBUF:CHCNT) ; END ; (*OUTPUT ERROR MESSAGES*) WRITE(OUTPUT,'****', ' ':11) ; LASTPOS := 0; FREEPOS := 1; FOR K := 1 TO ERRINX DO BEGIN WITH ERRLIST[K] DO BEGIN CURRPOS := POS; CURRNMR := NMR END; IF CURRPOS = LASTPOS THEN WRITE(OUTPUT,',') ELSE BEGIN WHILE FREEPOS < CURRPOS DO BEGIN WRITE(OUTPUT,' '); FREEPOS := FREEPOS + 1 END; WRITE(OUTPUT,'@'); LASTPOS := CURRPOS END; IF CURRNMR < 10 THEN F := 1 ELSE IF CURRNMR < 100 THEN F := 2 ELSE F := 3; WRITE(OUTPUT,CURRNMR:F); FREEPOS := FREEPOS + F + 1 END; WRITELN(OUTPUT); ERRINX := 0 ; PRCODE := FALSE ; END (*PRINTERROR*) ; PROCEDURE ENDOFLINE ; VAR I: 0..7 ; BEGIN LINECNT := LINECNT+1 ; IF LIST THEN BEGIN WRITE(OUTPUT,LINECNT: 4) ; IF DP THEN WRITE(OUTPUT,LC:6) ELSE WRITE(OUTPUT,IC:6); WRITE(OUTPUT,LEVEL:3,') ') ; WRITELN(OUTPUT, LINEBUF:"80"CHCNT) ; END ELSE BEGIN WRITE(OUTPUT,'+') ; IF (LINECNT MOD 25) = 0 THEN BEGIN WRITE(OUTPUT, LINECNT:4) ; IF (LINECNT MOD 50) = 0 THEN WRITELN(OUTPUT) ; END ; END ; IF ERRINX > 0 THEN PRINTERROR ; CHCNT := 0 ; END (*ENDOFLINE*) ; PROCEDURE ERROR(FERRNR: INTEGER); BEGIN 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 INSYMBOL; (*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LNGTH*) LABEL 1,2,3,4; VAR I,K: INTEGER; "LVP: CSP;" TEST: BOOLEAN; DIGITS: PACKED ARRAY [0..REALLNGTH] OF CHAR; "STRING: PACKED ARRAY [0..STRGLNGTH] OF CHAR;" PROCEDURE SKIPBLNK; (* SKIP BLANKS, ENDOFLINE, AND (OPTIONAL) MARGIN, SKIPS AT LEAST ONE CHAR *) BEGIN REPEAT IF EOL THEN BEGIN IF EOF(INPUT) THEN BEGIN WRITELN(OUTPUT,'**** EOF ENCOUNTERED') ; EXIT(ERRORCOUNT+1) ; END ; ENDOFLINE ; READ(INPUT,LINEBUF) ; END ; CHCNT := CHCNT-1 ; REPEAT CHCNT := CHCNT+1 ; UNTIL LINEBUF[CHCNT] <> ' ' ; (* NOTE THAT LINEBUF[ENDOFLINE] <> ' ' *) " IF MARGIN THEN EOL := CHCNT >= 72 ELSE EOL := CHCNT >= 80 ; " EOL := (ORD(LINEBUF[CHCNT]) > 127) "OR (CHCNT >= LINELGTH)" ; UNTIL NOT EOL ; CH := LINEBUF[CHCNT] ; CHCNT := CHCNT+1 ; END (*SKIPBLNK*) ; PROCEDURE NEXTCH; BEGIN IF EOL THEN BEGIN IF EOF(INPUT) THEN BEGIN WRITELN(OUTPUT,'**** EOF ENCOUNTERED') ; EXIT(ERRORCOUNT+1) ; END ; ENDOFLINE ; READ(INPUT, LINEBUF) ; ## ## " LINEBUF[LINELGTH] := CHR(64) ; " END ; CH := LINEBUF[CHCNT] ; CHCNT := CHCNT+1 ; EOL := (ORD(LINEBUF[CHCNT]) > 127) "OR (CHCNT >= LINELGTH) "; END (*NEXTCH*) ; PROCEDURE OPTIONS; BEGIN REPEAT NEXTCH; IF CH <> '*' THEN BEGIN " IF CH = 'T' THEN BEGIN NEXTCH; (* PRTABLES := CH = '+' *) END ELSE " IF CH = 'L' THEN BEGIN NEXTCH; LIST := CH = '+'; END ELSE IF CH = 'C' THEN BEGIN NEXTCH; PRCODE := CH = '+' END ELSE " IF CH='M' THEN BEGIN NEXTCH ; (* MARGIN := CH <> '-' *) END ELSE " IF CH = 'D' THEN BEGIN NEXTCH ; DEBUG := CH <> '-' END ; NEXTCH END UNTIL CH <> ',' END (*OPTIONS*) ; BEGIN (*INSYMBOL*) 1: " REPEAT WHILE (CH = ' ') AND NOT EOL DO NEXTCH; TEST := EOL; IF TEST THEN NEXTCH UNTIL NOT TEST; " IF CH = ' ' THEN SKIPBLNK ; ## #IF ORD(CH) > 63 THEN GOTO 4; CASE CH OF 'A','B','C','D','E','F','G','H','I', 'J','K','L','M','N','O','P','Q','R', 'S','T','U','V','W','X','Y','Z': BEGIN K := 0 ; ID := BLANKID ; REPEAT IF K < 8 (* IDLNGTH *) THEN BEGIN ID[K] := CH; K := K+1 END ; NEXTCH UNTIL NOT(CH IN ALPHANUMERIC) ; "IF K >= KK THEN KK := K ELSE REPEAT ID[KK] := ' '; KK := KK - 1 UNTIL KK = K; " FOR I := FRW[K] TO FRW[K+1] - 1 DO IF RW[I] = ID THEN BEGIN SY := RSY[I]; OP := ROP[I]; GOTO 2 END; SY := IDENT; OP := NOOP; 2: END; '0','1','2','3','4','5','6','7','8','9': BEGIN OP := NOOP; I := 0; REPEAT I := I+1; IF I <= DIGMAX THEN DIGITS[I] := CH; NEXTCH UNTIL (CH < '0') OR (CH > '9') ; IF (CH = '.') OR (CH = 'E') THEN BEGIN K := I; IF CH = '.' THEN BEGIN K := K+1; IF K <= DIGMAX THEN DIGITS[K] := CH; NEXTCH; IF CH = '.' THEN BEGIN CH := ':'; GOTO 3 END; IF (CH < '0') OR (CH > '9') THEN ERROR(201) ELSE REPEAT K := K + 1; IF K <= DIGMAX THEN DIGITS[K] := CH; NEXTCH UNTIL (CH < '0') OR (CH > '9') END; IF CH = 'E' THEN BEGIN K := K+1; IF K <= DIGMAX THEN DIGITS[K] := CH; NEXTCH; IF (CH = '+') OR (CH ='-') THEN BEGIN K := K+1; IF K <= DIGMAX THEN DIGITS[K] := CH; NEXTCH END; IF (CH < '0') OR (CH > '9') THEN ERROR(201) ELSE REPEAT K := K+1; IF K <= DIGMAX THEN DIGITS[K] := CH; NEXTCH UNTIL (CH < '0') OR (CH > '9') END; "NEW(LVP,REEL);" SY:= REALCONST; "LVP@.CCLASS := REEL;" WITH "LVP@" CNSTVALPTR@ DO BEGIN "FOR I := 1 TO REALLNGTH DO RVAL[I] := ' ';" IF K <= DIGMAX THEN BEGIN DIGITS[0] := '+' ; RVAL := DIGITS ; FOR I := K+1 TO REALLNGTH DO RVAL[I] := ' ' ; " FOR I := 2 TO K+1 DO RVAL[I] := DIGITS[I-1] " END ELSE BEGIN ERROR(203); RVAL[1] := '0' ; RVAL[2] := '.'; RVAL[3] := '0' END END; VAL.VALP := "LVP" CNSTVALPTR END ELSE 3: BEGIN IF I > DIGMAX THEN BEGIN ERROR(203); VAL.IVAL := 0 END ELSE WITH VAL DO BEGIN IVAL := 0; FOR K := 1 TO I DO BEGIN IF IVAL <= MXINT10 THEN IVAL := IVAL*10 + (ORD(DIGITS[K])-ORD('0')) ELSE BEGIN ERROR(203); IVAL := 0 END END; SY := INTCONST END END END; '''': WITH CNSTVALPTR@ DO BEGIN LNGTH := 0; SY := STRINGCONST; OP := NOOP; REPEAT REPEAT NEXTCH; LNGTH := LNGTH + 1; IF LNGTH <= STRGLNGTH THEN SVAL[LNGTH] := CH UNTIL (EOL) OR (CH = ''''); IF EOL THEN ERROR(202) ELSE NEXTCH UNTIL CH <> ''''; LNGTH := LNGTH - 1; (*NOW LNGTH = NR OF CHARS IN STRING*) IF LNGTH = 1 THEN VAL.IVAL := ORD(SVAL[1]) ELSE BEGIN "NEW(LVP,STRG);" "LVP@.CCLASS:=STRG;" IF LNGTH > STRGLNGTH THEN BEGIN ERROR(398); LNGTH := STRGLNGTH END; " WITH LVP@ DO BEGIN SLNGTH := LNGTH; FOR I := 1 TO LNGTH DO SVAL[I] := STRING[I] END; " VAL.VALP := "LVP" CNSTVALPTR ; SLNGTH := LNGTH ; END END; ':': BEGIN OP := NOOP; NEXTCH; IF CH = '=' THEN BEGIN SY := BECOMES; NEXTCH END ELSE SY := COLON END; '.': BEGIN OP := NOOP; NEXTCH; IF CH = '.' THEN BEGIN SY := COLON; NEXTCH END ELSE SY := PERIOD END; '<': BEGIN NEXTCH; SY := RELOP; IF CH = '=' THEN BEGIN OP := LEOP; NEXTCH END ELSE IF CH = '>' THEN BEGIN OP := NEOP; NEXTCH END ELSE OP := LTOP END; '>': BEGIN NEXTCH; SY := RELOP; IF CH = '=' THEN BEGIN OP := GEOP; NEXTCH END ELSE OP := GTOP END; '(': BEGIN NEXTCH; IF CH = '*' THEN BEGIN NEXTCH; IF CH = '$' THEN OPTIONS; REPEAT WHILE CH <> '*' DO NEXTCH; NEXTCH UNTIL CH = ')'; NEXTCH; GOTO 1 END ; IF CH = '/' THEN BEGIN SY := LBRACK ; OP := NOOP ; NEXTCH END ELSE BEGIN SY := LPARENT; OP := NOOP END END; '*','+','-', '=','/',')','&', '[',']',',',';','@' : BEGIN SY := SSY[CH]; OP := SOP[CH]; IF CH = '/' THEN BEGIN NEXTCH ; IF CH =')' THEN BEGIN SY := RBRACK ; OP := NOOP ; NEXTCH ; END END ELSE NEXTCH END; '"': BEGIN REPEAT NEXTCH UNTIL CH = '"' ; NEXTCH ; GOTO 1 ; END ; ' ','#': BEGIN NEXTCH ; GOTO 1 END ; ## ## '$','_','%'",'!','?','|','^'": 4: BEGIN SY := OTHERSY; OP := NOOP; ERROR(6 "398") ; NEXTCH END END (*CASE*) END (*INSYMBOL*) ; 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(FCP: CTP; VAR FCP1: CTP); (*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S --> PROCEDURE PROCEDUREDECLARATION --> PROCEDURE SELECTOR*) LABEL 1; BEGIN WHILE FCP <> NIL DO IF FCP@.NAME = ID THEN GOTO 1 ELSE IF FCP@.NAME < ID THEN FCP := FCP@.RLINK ELSE FCP := FCP@.LLINK; 1: FCP1 := FCP END (*SEARCHSECTION*) ; PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP); LABEL 1; VAR LCP: CTP; BEGIN FOR DISX := TOP DOWNTO 0 DO BEGIN LCP := DISPLAY[DISX].FNAME; WHILE LCP <> NIL DO IF LCP@.NAME = ID THEN IF LCP@.KLASS IN FIDCLS THEN GOTO 1 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; (*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION --> PROCEDURE SIMPLETYPE*) IF 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 LCP := UFCTPTR; END; 1: FCP := LCP END (*SEARCHID*) ; PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER); (*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*) (*ASSUME (FSP <> NIL) AND (FSP@.FORM <= SUBRANGE) AND (FSP <> INTPTR) AND NOT COMPTYPES(REALPTR,FSP)*) BEGIN WITH FSP@ DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END ELSE BEGIN FMIN := 0; IF FSP = CHARPTR THEN FMAX := ORDMAXCHAR ELSE IF (FORM = SCALAR) AND ("FSP@."FCONST <> NIL) THEN FMAX := FSP@.FCONST@.VALUES.IVAL ELSE FMAX := 0 END END (*GETBOUNDS*) ; """PROCEDURE PRINTTABLES(FB: BOOLEAN); (*PRINT DATA STRUCTURE AND NAME TABLE*) VAR I, LIM: DISPRANGE; PROCEDURE MARKER; (*MARK DATA STRUCTURE ENTRIES TO AVOID MULTIPLE PRINTOUT*) VAR I: INTEGER; PROCEDURE MARKCTP(FP: CTP); FORWARD; PROCEDURE MARKSTP(FP: STP); (*MARK DATA STRUCTURES, PREVENT CYCLES*) BEGIN IF FP <> NIL THEN WITH FP@ DO BEGIN MARKED := TRUE; CASE FORM OF SCALAR: ; SUBRANGE: MARKSTP(RANGETYPE); POINTER: (*DON'T MARK ELTYPE: CYCLE POSSIBLE; WILL BE MARKED ANYWAY, IF FP = TRUE*) ; POWER: MARKSTP(ELSET) ; ARRAYS: BEGIN MARKSTP(AELTYPE); MARKSTP(INXTYPE) END; RECORDS: BEGIN MARKCTP(FSTFLD); MARKSTP(RECVAR) END; FILES: MARKSTP(FILTYPE); TAGFLD: MARKSTP(FSTVAR); VARIANT: BEGIN MARKSTP(NXTVAR); MARKSTP(SUBVAR) END END (*CASE*) END (*WITH*) END (*MARKSTP*); PROCEDURE MARKCTP; BEGIN IF FP <> NIL THEN WITH FP@ DO BEGIN MARKCTP(LLINK); MARKCTP(RLINK); MARKSTP(IDTYPE) END END (*MARKCTP*); BEGIN (*MARK*) FOR I := TOP DOWNTO LIM DO MARKCTP(DISPLAY[I].FNAME) END (*MARK*); PROCEDURE FOLLOWCTP(FP: CTP); FORWARD; PROCEDURE FOLLOWSTP(FP: STP); BEGIN IF FP <> NIL THEN WITH FP@ DO IF MARKED THEN BEGIN MARKED := FALSE; WRITE(OUTPUT,' ':4,ORD(FP):6,SIZE:10); CASE FORM OF SCALAR: BEGIN WRITE(OUTPUT,'SCALAR':10); IF SCALKIND = STANDARD THEN WRITE(OUTPUT,'STANDARD ':10) ELSE WRITE(OUTPUT,'DECLARED ':10, ORD(FCONST):8); WRITELN(OUTPUT) END; SUBRANGE:BEGIN WRITE(OUTPUT,'SUBRANGE ':10,' ':4,ORD(RANGETYPE):6); IF RANGETYPE <> REALPTR THEN WRITE(OUTPUT,MIN.IVAL,MAX.IVAL) ELSE IF (MIN.VALP <> NIL) AND (MAX.VALP <> NIL) THEN WRITE(OUTPUT,' ',MIN.VALP@.RVAL:9, ' ',MAX.VALP@.RVAL:9); WRITELN(OUTPUT); FOLLOWSTP(RANGETYPE); END; POINTER: WRITELN(OUTPUT,'POINTER':10,' ':4,ORD(ELTYPE):6); POWER: BEGIN WRITELN(OUTPUT,'SET':10,' ':4,ORD(ELSET):6); FOLLOWSTP(ELSET) END; ARRAYS: BEGIN WRITELN(OUTPUT,'ARRAY':10,' ':4,ORD(AELTYPE):6,' ':4, ORD(INXTYPE):6); FOLLOWSTP(AELTYPE); FOLLOWSTP(INXTYPE) END; RECORDS: BEGIN WRITELN(OUTPUT,'RECORD':10,' ':4,ORD(FSTFLD):6,' ':4, ORD(RECVAR):6); FOLLOWCTP(FSTFLD); FOLLOWSTP(RECVAR) END; FILES: BEGIN WRITE(OUTPUT,'FILE':10,' ':4,ORD(FILTYPE):6); FOLLOWSTP(FILTYPE) END; TAGFLD: BEGIN WRITELN(OUTPUT,'TAGFLD':10,' ':4,ORD(TAGFIELDP):6, ' ':4,ORD(FSTVAR):6); FOLLOWSTP(FSTVAR) END; VARIANT: BEGIN WRITELN(OUTPUT,'VARIANT':10,' ':4,ORD(NXTVAR):6, ' ':4,ORD(SUBVAR):6,VARVAL.IVAL); FOLLOWSTP(NXTVAR); FOLLOWSTP(SUBVAR) END END (*CASE*) END (*IF MARKED*) END (*FOLLOWSTP*); PROCEDURE FOLLOWCTP; VAR I: INTEGER; BEGIN IF FP <> NIL THEN WITH FP@ DO BEGIN WRITE(OUTPUT,' ':4,ORD(FP):6,' ',NAME:9,' ':4,ORD(LLINK):6, ' ':4,ORD(RLINK):6,' ':4,ORD(IDTYPE):6); CASE KLASS OF TYPES: WRITE(OUTPUT,'TYPE':10); KONST: BEGIN WRITE(OUTPUT,'CONSTANT ':10,' ':4,ORD(NEXT):6); IF IDTYPE <> NIL THEN IF IDTYPE = REALPTR THEN BEGIN IF VALUES.VALP <> NIL THEN WRITE(OUTPUT,' ',VALUES.VALP@.RVAL:9) END ELSE IF IDTYPE@.FORM = ARRAYS THEN (*STRINGCONST*) BEGIN IF VALUES.VALP <> NIL THEN BEGIN WRITE(OUTPUT,' '); WITH VALUES.VALP@ DO FOR I := 1 TO SLNGTH DO WRITE(OUTPUT,SVAL[I]) END END ELSE WRITE(OUTPUT,VALUES.IVAL) END; VARS: BEGIN WRITE(OUTPUT,'VARIABLE ':10); IF VKIND = ACTUAL THEN WRITE(OUTPUT,'ACTUAL':10) ELSE WRITE(OUTPUT,'FORMAL':10); WRITE(OUTPUT,' ':4,ORD(NEXT):6,VLEV,' ':4,VADDR:6 ); END; FIELD: WRITE(OUTPUT,'FIELD':10,' ':4,ORD(NEXT):6,' ':4,FLDADDR:6); PROC, FUNC: BEGIN IF KLASS = PROC THEN WRITE(OUTPUT,'PROCEDURE':10) ELSE WRITE(OUTPUT,'FUNCTION ':10); IF PFDECKIND = STANDARD THEN WRITE(OUTPUT,'STANDARD ':10, KEY:10) ELSE BEGIN WRITE(OUTPUT,'DECLARED ':10, ORD(NEXT):8); WRITE(OUTPUT,PFLEV,' ':4,PFNAME:6); IF PFKIND = ACTUAL THEN BEGIN WRITE(OUTPUT,'ACTUAL':10); IF FORWDECL THEN WRITE(OUTPUT,'FORWARD':10) ELSE WRITE(OUTPUT,'NOTFORWARD':10); IF EXTERN THEN WRITE(OUTPUT,'EXTERN':10) ELSE WRITE(OUTPUT,'NOT EXTERN':10); END ELSE WRITE(OUTPUT,'FORMAL':10) END END END (*CASE*); WRITELN(OUTPUT); FOLLOWCTP(LLINK); FOLLOWCTP(RLINK); FOLLOWSTP(IDTYPE) END (*WITH*) END (*FOLLOWCTP*); BEGIN (*PRINTTABLES*) WRITELN(OUTPUT); WRITELN(OUTPUT); WRITELN(OUTPUT); IF FB THEN LIM := 0 ELSE BEGIN LIM := TOP; WRITE(OUTPUT,' LOCAL') END; WRITELN(OUTPUT,' TABLES '); WRITELN(OUTPUT); MARKER; FOR I := TOP DOWNTO LIM DO FOLLOWCTP(DISPLAY[I].FNAME); WRITELN(OUTPUT); IF NOT EOL THEN WRITE(OUTPUT,' ':CHCNT+16) END (*PRINTTABLES*); """ PROCEDURE GENLABEL(VAR NXTLAB: INTEGER); BEGIN INTLABEL := INTLABEL + 1; NXTLAB := INTLABEL END (*GENLABEL*); PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP); VAR LSY: SYMBOL; TEST: BOOLEAN; SEGSIZE, PARMLEN: INTEGER ; PROCEDURE SKIP(FSYS: SETOFSYS); (*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*) BEGIN WHILE NOT(SY IN FSYS) DO BEGIN INSYMBOL END ; END (*SKIP*) ; PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU); VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG); LVP: CSP; I: 0..REALLNGTH; 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,ARRAYS); WITH LSP@ DO BEGIN AELTYPE := CHARPTR; INXTYPE := NIL; SIZE := LNGTH*CHARSIZE; FORM := ARRAYS END ; LVP := VAL.VALP ; NEW(VAL.VALP, STRG) ; VAL.VALP@ := LVP@ ; (* COPY STRING CONST TO HEAP AREA *) 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 LSP = INTPTR THEN BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END 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 = INTCONST THEN BEGIN IF SIGN = NEG THEN VAL.IVAL := -VAL.IVAL; LSP := INTPTR; FVALU.IVAL := VAL.IVAL; INSYMBOL END ELSE IF SY = REALCONST THEN BEGIN WITH VAL.VALP@ DO IF SIGN = NEG THEN RVAL[0] := '-' ELSE RVAL[0] := '+' ; LVP := VAL.VALP ; NEW(VAL.VALP, REEL) ; VAL.VALP@.RVAL := LVP@.RVAL ; LSP := REALPTR; FVALU.VALP := VAL.VALP; 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*) ; FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN; (*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND 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 := FALSE; (* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE NOT RECOGNIZED TO BE COMPATIBLE*) 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); ARRAYS: COMPTYPES := COMPTYPES(FSP1@.AELTYPE,FSP2@.AELTYPE) AND (FSP1@.SIZE = FSP2@.SIZE); (*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST BE COMPATIBLE. -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST BE THE SAME*) RECORDS: BEGIN NXT1 := FSP1@.FSTFLD; NXT2 := FSP2@.FSTFLD; COMP:=TRUE; WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO BEGIN COMP:=COMP AND COMPTYPES(NXT1@.IDTYPE,NXT2@.IDTYPE); NXT1 := NXT1@.NEXT; NXT2 := NXT2@.NEXT END; COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL) AND(FSP1@.RECVAR = NIL)AND(FSP2@.RECVAR = NIL) END; (*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE IFF NO VARIANTS OCCUR*) FILES: COMPTYPES := COMPTYPES(FSP1@.FILTYPE,FSP2@.FILTYPE) 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 STRING(FSP: STP) : BOOLEAN; BEGIN STRING := FALSE; IF FSP <> NIL THEN IF FSP@.FORM = ARRAYS THEN STRING := COMPTYPES(FSP@.AELTYPE,CHARPTR) END (*STRING*) ; PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE); VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP; LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER; PROCEDURE SIMPLETYPE(FSYS:SETOFSYS; VAR FSP:STP"; VAR FSIZE:ADDRRANGE"); VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE; LCNT: INTEGER; LVALU: VALU; BEGIN FSIZE := 1; IF NOT (SY IN SIMPTYPEBEGSYS) THEN BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END; IF SY IN SIMPTYPEBEGSYS THEN BEGIN IF SY = LPARENT THEN BEGIN TTOP := TOP; (*DECL. CONSTS LOCAL TO INNERMOST BLOCK*) WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1; NEW(LSP,SCALAR,DECLARED); WITH LSP@ DO BEGIN SIZE := INTSIZE; FORM := SCALAR; SCALKIND := DECLARED 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 SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE BEGIN IF SY = IDENT THEN BEGIN SEARCHID([TYPES,KONST],LCP); INSYMBOL; IF LCP@.KLASS = KONST THEN BEGIN NEW(LSP,SUBRANGE); WITH LSP@, LCP@ DO BEGIN RANGETYPE := IDTYPE; FORM := SUBRANGE; IF STRING(RANGETYPE) THEN BEGIN ERROR(148); RANGETYPE := NIL END; MIN := VALUES; SIZE := IDTYPE@.SIZE END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); CONSTANT(FSYS,LSP1,LVALU); LSP@.MAX := LVALU; IF LSP@.RANGETYPE <> LSP1 THEN ERROR(107) END ELSE BEGIN LSP := LCP@.IDTYPE; " IF LSP <> NIL THEN FSIZE := LSP@.SIZE " END END (*SY = IDENT*) ELSE BEGIN NEW(LSP,SUBRANGE); LSP@.FORM := SUBRANGE; CONSTANT(FSYS + [COLON],LSP1,LVALU); IF STRING(LSP1) THEN BEGIN ERROR(148); LSP1 := NIL END; WITH LSP@ DO BEGIN RANGETYPE:=LSP1; MIN:=LVALU; SIZE:=INTSIZE; IF LSP1 <> NIL THEN SIZE := LSP1@.SIZE ; END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); CONSTANT(FSYS,LSP1,LVALU); LSP@.MAX := LVALU; IF LSP@.RANGETYPE <> LSP1 THEN ERROR(107) END; IF LSP <> NIL THEN WITH LSP@ DO IF FORM = SUBRANGE THEN IF RANGETYPE <> NIL THEN IF RANGETYPE = REALPTR THEN ERROR(398) ELSE IF MIN.IVAL > MAX.IVAL THEN ERROR(102) END; FSP := LSP; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE FSP := NIL END (*SIMPLETYPE*) ; PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP); VAR LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP; MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU; BEGIN NXT1 := NIL; LSP := NIL; IF NOT (SY IN FSYS+[IDENT,CASESY]) THEN BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END; WHILE SY = IDENT DO BEGIN NXT := NXT1; REPEAT IF SY = IDENT THEN BEGIN NEW(LCP,FIELD); WITH LCP@ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT; KLASS := FIELD END; NXT := LCP; ENTERID(LCP); INSYMBOL END ELSE ERROR(2); IF NOT (SY IN [COMMA,COLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE); WHILE NXT <> NXT1 DO WITH NXT@ DO BEGIN IDTYPE := LSP; FLDADDR := DISPL; NXT := NEXT; DISPL := DISPL + LSIZE END; NXT1 := LCP; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN [IDENT,CASESY,ENDSY]) THEN (* IGNOR EXTRA ; *) BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END END END (*WHILE*); NXT := NIL; WHILE NXT1 <> NIL DO WITH NXT1@ DO BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END; IF SY = CASESY THEN BEGIN NEW(LSP,TAGFLD); WITH LSP@ DO BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM:=TAGFLD END; FRECVAR := LSP; INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,FIELD); WITH LCP@ DO BEGIN NAME := ID; IDTYPE := NIL; KLASS:=FIELD; NEXT := NIL ; (*FLDADDR WILL BE SET WHEN TYPE IS KNOWN*) END; PRTERR := FALSE ; SEARCHID([TYPES],LCP1) ; PRTERR := TRUE ; IF LCP1 = NIL THEN BEGIN (*EXPLICIT TAG FIELD *) ENTERID(LCP); INSYMBOL ; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END ; END (* IF LCP1 = NIL *) ELSE (* NO EXPLICT TAG FIELD *) LCP@.NAME := BLANKID ; BEGIN SEARCHID([TYPES],LCP1); LSP1 := LCP1@.IDTYPE; IF LSP1 <> NIL THEN WITH LSP1@ DO BEGIN IF LCP@.NAME <> BLANKID THEN BEGIN LCP@.FLDADDR := DISPL ; DISPL := DISPL + SIZE; END (* LCP@.NAME <> ' ' *) ; IF (FORM <= SUBRANGE) OR STRING(LSP1) THEN BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109) ELSE IF STRING(LSP1) THEN ERROR(398); LCP@.IDTYPE := LSP1; LSP@.TAGFIELDP := LCP; END ELSE ERROR(110); END (* WITH LSP1@ DO *) ; INSYMBOL; END END ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END; LSP@.SIZE := DISPL; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; REPEAT LSP2 := NIL; REPEAT CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU); IF LSP@.TAGFIELDP <> NIL THEN IF NOT COMPTYPES(LSP@.TAGFIELDP@.IDTYPE,LSP3)THEN ERROR(111); NEW(LSP3,VARIANT); WITH LSP3@ DO BEGIN NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU; FORM := VARIANT END; LSP1 := LSP3; LSP2 := LSP3; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2); IF DISPL > MAXSIZE THEN MAXSIZE := DISPL; WHILE LSP3 <> NIL DO BEGIN LSP4 := LSP3@.SUBVAR; LSP3@.SUBVAR := LSP2; LSP3@.SIZE := DISPL; LSP3 := LSP4 END; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END END ELSE ERROR(4); TEST := SY <> SEMICOLON; IF NOT TEST THEN BEGIN DISPL := MINSIZE; INSYMBOL ; TEST := SY = ENDSY ; (* IGNORE EXTRA ;*) END UNTIL TEST; DISPL := MAXSIZE; LSP@.FSTVAR := LSP1; END ELSE FRECVAR := NIL END (*FIELDLIST*) ; BEGIN (*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 := PTRSIZE; FORM:=POINTER END; INSYMBOL; IF SY = IDENT THEN BEGIN PRTERR := FALSE; (*NO ERROR IF SEARCH NOT SUCCESSFUL*) SEARCHID([TYPES],LCP); PRTERR := TRUE; IF LCP = NIL THEN (*FORWARD REFERENCED TYPE ID*) BEGIN NEW(LCP,TYPES); WITH LCP@ DO BEGIN NAME := ID; IDTYPE := LSP; NEXT := FWPTR; KLASS := TYPES END; FWPTR := LCP END ELSE BEGIN IF LCP@.IDTYPE <> NIL THEN IF LCP@.IDTYPE@.FORM = FILES THEN ERROR(108) ELSE LSP@.ELTYPE := LCP@.IDTYPE END; INSYMBOL; END ELSE ERROR(2); END ELSE BEGIN IF SY = PACKEDSY THEN BEGIN INSYMBOL; IF NOT (SY IN TYPEDELS) THEN BEGIN ERROR(10); SKIP(FSYS + TYPEDELS) END END; (*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",LSIZE"); IF LSP2 <> NIL THEN IF LSP2@.FORM <= SUBRANGE THEN BEGIN IF LSP2 = REALPTR THEN BEGIN ERROR(109); LSP2 := NIL END ELSE IF LSP2 = INTPTR 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,LMIN,LMAX); 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 := 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 ERROR(398); INSYMBOL ; SKIP(FSYS); LSP:= NIL END;" BEGIN INSYMBOL ; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8) ; SIMPLETYPE(FSYS,LSP1",LSIZE") ; IF LSP1 = NIL THEN ERROR(398) ELSE IF LSP1 <> CHARPTR THEN ERROR(398) ; LSP := TEXTPTR ; 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; VAR LLP: LBP; REDEF: BOOLEAN; LBNAME: LABELRNG ; BEGIN REPEAT IF SY = INTCONST THEN WITH DISPLAY[TOP] DO BEGIN LLP := FLABEL; REDEF := FALSE; WHILE (LLP <> NIL) AND NOT REDEF DO IF LLP@.LABVAL <> VAL.IVAL THEN LLP := LLP@.NEXTLAB ELSE BEGIN REDEF := TRUE; ERROR(166) END; IF NOT REDEF THEN BEGIN NEW(LLP); WITH LLP@ DO BEGIN LABVAL := VAL.IVAL; GENLABEL(LBNAME); DEFINED := FALSE; NEXTLAB := FLABEL; LABNAME := LBNAME END; FLABEL := LLP END; INSYMBOL END ELSE ERROR(15); 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; VAR LCP: CTP; LSP: STP; LVALU: VALU; BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END; WHILE SY = IDENT DO BEGIN NEW(LCP,KONST); WITH LCP@ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; KLASS:=KONST END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); CONSTANT(FSYS + [SEMICOLON],LSP,LVALU); ENTERID(LCP); LCP@.IDTYPE := LSP; LCP@.VALUES := LVALU; IF 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; 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; IF FWPTR <> NIL THEN BEGIN ERROR(117); WRITELN(OUTPUT); REPEAT WRITELN(OUTPUT,' TYPE-ID ',FWPTR@.NAME); FWPTR := FWPTR@.NEXT UNTIL FWPTR = NIL; IF NOT EOL THEN WRITE(OUTPUT,' ': CHCNT+16) END END (*TYPEDECLARATION*) ; PROCEDURE VARDECLARATION; VAR LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE; COUNT: 0..100 ; 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; IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL END; ENTERID(LCP); NXT := LCP; INSYMBOL; END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE); IF LSP = TEXTPTR THEN BEGIN NXTFILBUF := NXTFILBUF+COUNT ; COUNT := 1 ; IF NXTFILBUF > LASTFILBUF THEN ERROR(258) ; END ; WHILE NXT <> NIL DO WITH NXT@ DO BEGIN IDTYPE := LSP; IF LSP = TEXTPTR THEN (* TEXT FILE DECLARATION *) BEGIN VADDR := NXTFILBUF-COUNT ; VLEV := 1 ; COUNT := COUNT+1 ; END ELSE (* OTHER VARIABLE DECLARATION *) BEGIN VADDR := LC ; LC := LC+LSIZE END ; IF (LC > MAXADDR) OR (LC <= 0) THEN BEGIN ERROR(260) ; (* LOCAL DATA AREA TOO LARGE *) LC := 0 ; END ; 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); IF FWPTR <> NIL THEN BEGIN ERROR(117); WRITELN(OUTPUT); REPEAT WRITELN(OUTPUT,' TYPE-ID ',FWPTR@.NAME); FWPTR := FWPTR@.NEXT UNTIL FWPTR = NIL; IF NOT EOL THEN WRITE(OUTPUT,' ': CHCNT+16) END END (*VARDECLARATION*) ; PROCEDURE PROCDECLARATION(FSY: SYMBOL); VAR OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP; FORW: BOOLEAN; OLDTOP: DISPRANGE; PARCNT: INTEGER; LLC,LCM: ADDRRANGE; LBNAME, OLDLABEL: INTEGER; MARKP: @INTEGER; 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 := LC ; IF NOT (SY IN FSY + [LPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END; IF SY = LPARENT THEN BEGIN IF FORW THEN ERROR(119); INSYMBOL; IF NOT (SY IN [IDENT,VARSY,PROCSY,FUNCSY]) THEN BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END; WHILE SY IN [IDENT,VARSY,PROCSY,FUNCSY] DO BEGIN IF SY = PROCSY THEN BEGIN ERROR(398); REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,PROC,DECLARED,FORMAL); WITH LCP@ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP1; PFLEV := LEVEL (*BEWARE OF PARAMETER PROCEDURES*); KLASS:=PROC;PFDECKIND:=DECLARED;PFKIND:=FORMAL END; ENTERID(LCP); LCP1 := LCP; LC := LC + PTRSIZE; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,SEMICOLON,RPARENT]) THEN BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])END UNTIL SY <> COMMA END ELSE BEGIN IF SY = FUNCSY THEN BEGIN ERROR(398); LCP2 := NIL; REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,FUNC,DECLARED,FORMAL); WITH LCP@ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP2; PFLEV := LEVEL (*BEWARE PARAM FUNCS*); KLASS:=FUNC;PFDECKIND:=DECLARED; PFKIND:=FORMAL END; ENTERID(LCP); LCP2 := LCP; LC := LC + PTRSIZE; INSYMBOL; END; IF NOT (SY IN [COMMA,COLON] + FSYS) THEN BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT]) END UNTIL SY <> COMMA; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP := LCP@.IDTYPE; IF LSP <> NIL THEN IF NOT(LSP@.FORM IN[SCALAR,SUBRANGE,POINTER]) THEN BEGIN ERROR(120); LSP := NIL END; LCP3 := LCP2; WHILE LCP2 <> NIL DO BEGIN LCP2@.IDTYPE := LSP; LCP := LCP2; LCP2 := LCP2@.NEXT END; LCP@.NEXT := LCP1; LCP1 := LCP3; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN BEGIN ERROR(7);SKIP(FSYS+[SEMICOLON,RPARENT])END END ELSE ERROR(5) END ELSE BEGIN IF SY = VARSY THEN BEGIN LKIND := FORMAL; INSYMBOL END ELSE LKIND := ACTUAL; LCP2 := NIL; COUNT := 0; REPEAT IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP@ DO BEGIN NAME:=ID; IDTYPE:=NIL; KLASS:=VARS; VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL; END; ENTERID(LCP); LCP2 := LCP; COUNT := COUNT+1; INSYMBOL; END; IF NOT (SY IN [COMMA,COLON] + FSYS) THEN BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LEN := PTRSIZE ; LSP := LCP@.IDTYPE; IF LSP <> NIL THEN IF (LKIND=ACTUAL) THEN IF LSP@.FORM <= POWER THEN LEN := LSP@.SIZE ELSE IF LSP@.FORM = FILES THEN ERROR(121) ; LC := LC+COUNT*LEN ; LCP3 := LCP2 ; LLC := LC ; WHILE LCP2 <> NIL DO BEGIN LCP := LCP2; WITH LCP2@ DO BEGIN IDTYPE := LSP; LLC := LLC-LEN; VADDR := LLC; END; LCP2 := LCP2@.NEXT END; LCP@.NEXT := LCP1; LCP1 := LCP3; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN BEGIN ERROR(7);SKIP(FSYS+[SEMICOLON,RPARENT])END END ELSE ERROR(5); END; END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT,VARSY,PROCSY,FUNCSY]) THEN BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END END END (*WHILE*) ; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSY + FSYS) THEN BEGIN ERROR(6); SKIP(FSY + FSYS) END END ELSE ERROR(4); LCP3 := NIL; PARMLEN := LC ; (* SET PARM AREA LEN FOR THE Z VERSION *) (*REVERSE POINTERS AND RESERVE LOCAL CELLS FOR COPIES OF MULTIPLE VALUES*) WHILE LCP1 <> NIL DO WITH LCP1@ DO BEGIN LCP2 := NEXT; NEXT := LCP3; IF KLASS = VARS THEN IF IDTYPE <> NIL THEN IF (VKIND = ACTUAL) AND (IDTYPE@.FORM > POWER) THEN " (IDTYPE@.FORM > POWER)) THEN " BEGIN VADDR := LC; LC := LC + IDTYPE@.SIZE END; LCP3 := LCP1; LCP1 := LCP2 END; FPAR := LCP3 END (* IF SY = LPAREN *) ELSE FPAR := NIL ; END (*PARAMETERLIST*) ; BEGIN (*PROCDECLARATION*) LLC := LC; IF FSY = PROCSY THEN LC := 0 (* LCAFTMST (* ADR. OF THE FIRST VARIABLE *) ELSE (* FSY = FUNCSY *) LC := 8 (* LCAFTFNCRSLT *) ; LCP := UPRCPTR ; (* TO INITIALIZE LCP IN CASE [ *) IF SY = IDENT THEN BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); (*DECIDE WHETHER FORW.*) IF LCP <> NIL THEN BEGIN IF LCP@.KLASS = PROC THEN FORW := LCP@.FORWDECL AND(FSY = PROCSY)AND(LCP@.PFKIND = ACTUAL) ELSE IF LCP@.KLASS = FUNC THEN FORW:=LCP@.FORWDECL AND(FSY=FUNCSY)AND(LCP@.PFKIND=ACTUAL) ELSE FORW := FALSE; IF NOT FORW THEN ERROR(160) END ELSE FORW := FALSE; IF NOT FORW THEN BEGIN 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; PROCLAB := PROCLAB+1 ; PFDECKIND := DECLARED; PFKIND := ACTUAL; PFNAME := PROCLAB ; IF FSY = PROCSY THEN KLASS := PROC ELSE KLASS := FUNC END; ENTERID(LCP) END ELSE BEGIN LCP1 := LCP@.NEXT; WHILE LCP1 <> NIL DO BEGIN WITH LCP1@ DO IF KLASS = VARS THEN IF IDTYPE <> NIL THEN BEGIN LCM := VADDR + IDTYPE@.SIZE; IF LCM > LC THEN LC := LCM END; LCP1 := LCP1@.NEXT END END; INSYMBOL END ELSE ERROR(2); OLDLEV := LEVEL; OLDTOP := TOP; OLDLABEL := INTLABEL ; INTLABEL := 0 ; 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 BEGIN LCP@.NEXT := LCP1; LCP@.PLEN := PARMLEN END ; END ELSE BEGIN PARAMETERLIST([SEMICOLON,COLON],LCP1); IF NOT FORW THEN BEGIN LCP@.NEXT := LCP1; LCP@.PLEN := PARMLEN END ; 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 THEN BEGIN IF NOT (LSP@.FORM IN [SCALAR,SUBRANGE,POINTER,POWER]) THEN BEGIN ERROR(120); LCP@.IDTYPE := NIL END; END (* WITH LSP@ DO *) ; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END END ELSE IF NOT FORW THEN ERROR(123) END; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF SY = FORWARDSY THEN BEGIN IF FORW THEN ERROR(161) ELSE LCP@.FORWDECL := TRUE; INSYMBOL; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE BEGIN LCP@.FORWDECL := FALSE; MARK(MARKP); (* MARK HEAP *) REPEAT BLOCK(FSYS,SEMICOLON,LCP); IF SY = SEMICOLON THEN BEGIN "IF PRTABLES THEN PRINTTABLES(FALSE);" INSYMBOL; IF NOT (SY IN [BEGINSY,PROCSY,FUNCSY]) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE ERROR(14) UNTIL SY IN [BEGINSY,PROCSY,FUNCSY]; RELEASE(MARKP); (* RETURN LOCAL ENTRIES ON RUNTIME HEAP *) END; LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; INTLABEL := OLDLABEL ; END (*PROCDECLARATION*) ; PROCEDURE BODY(FSYS: SETOFSYS); (* CONST CIXMAX = 1000; *) TYPE OPRANGE = 0..63; VAR LLCP:CTP; SAVEID:ALPHA; CSTPTR: CSP; (*ALLOWS REFERENCING OF NONINTEGER CONSTANTS BY AN INDEX (INSTEAD OF A POINTER), WHICH CAN BE STORED IN THE P2-FIELD OF THE INSTRUCTION RECORD UNTIL WRITEOUT. --> PROCEDURE LOAD, PROCEDURE WRITEOUT*) (*NOT NEEDED IN P_COMP.*) I, ENTNAME : INTEGER; LCMAX,LLC1: ADDRRANGE; LCP: CTP; LLP: LBP; PROCNAME : ALPHA ; PROCEDURE PUTIC; BEGIN IF (IC MOD 20 = 0) THEN "IF PRTIC THEN " WRITELN(PRR,"MN[31]:4"CHR(31):2, ' ', IC:1) ; END; " FUNCTION FLDW(NUM : INTEGER) : INTEGER ; VAR FW: 0..20 ; BEGIN FW := 0 ; IF NUM < 0 THEN FW := 1 ; NUM := ABS(NUM) ; REPEAT NUM := NUM DIV 10 ; FW := FW+1 ; UNTIL NUM = 0 ; FLDW := FW END (*FLDW*); " FUNCTION GETTYPE(OPERAND: STP): INTEGER ; BEGIN GETTYPE := ORD('I') ; (* ASSUME INTEGER TYPE *) IF OPERAND = NIL THEN BEGIN IF ERRORCOUNT = 0 THEN ERROR(500) END ELSE IF OPERAND@.FORM > POWER THEN GETTYPE := ORD('A') ELSE IF OPERAND@.FORM = POWER THEN GETTYPE := ORD('S') ELSE IF OPERAND@.FORM = POINTER THEN GETTYPE := ORD('A') ELSE IF OPERAND = REALPTR THEN GETTYPE := ORD('R') ELSE IF OPERAND = BOOLPTR THEN GETTYPE := ORD('B') " ELSE BEGIN IF OPERAND@.SIZE = CHARSIZE THEN GETTYPE := ORD('C') END " END (*GETTYPE*) ; FUNCTION PROCTYPE(FPROCP: CTP): INTEGER ; BEGIN PROCTYPE := ORD('P') ; IF FPROCP <> NIL THEN IF FPROCP@.IDTYPE <> NIL THEN WITH FPROCP@ DO BEGIN IF IDTYPE@.FORM = POWER THEN PROCTYPE := ORD('S') ELSE IF IDTYPE = REALPTR THEN PROCTYPE := ORD('R') ELSE IF IDTYPE = BOOLPTR THEN PROCTYPE := ORD('B') ELSE IF IDTYPE@.FORM = POINTER THEN PROCTYPE := ORD('A') " ELSE IF (IDTYPE = CHARPTR) OR ((IDTYPE@.FORM = SUBRANGE) AND (IDTYPE@.RANGETYPE = CHARPTR)) IDTYPE@.SIZE = 1 THEN PROCTYPE := ORD('C') " ELSE PROCTYPE := ORD('I') ; END END (*PROCTYPE*) ; PROCEDURE GEN0(FOP: OPRANGE); BEGIN IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR,"MN[FOP]:4"CHR(FOP):2) END; IC := IC + 1 END (*GEN0*) ; PROCEDURE GEN1(FOP: OPRANGE; FP2: INTEGER); VAR K: INTEGER; BEGIN IF PRCODE THEN BEGIN PUTIC; WRITE(PRR,"MN[FOP]:4"CHR(FOP):2); IF FOP = 30 THEN (*CSP*) WRITELN(PRR,"SNA[FP2]:4"CHR(FP2):2) ELSE IF (FOP = 38) OR (FOP = 37) THEN (*LCA*) (*LSA*) BEGIN WRITE(PRR,'''':2); WITH CSTPTR@ DO FOR K := 1 TO SLNGTH DO BEGIN WRITE(PRR,SVAL[K]); IF SVAL[K] = '''' THEN WRITE(PRR,'''') END ; WRITELN(PRR,'''') END ELSE IF FOP IN [26, 41, 42] THEN (*STO,RET,MST*) WRITELN(PRR,CHR(FP2):2) ELSE WRITELN(PRR, ' ', FP2:1"5") END; IC := IC + 1 END (*GEN1*) ; PROCEDURE GEN2(FOP: OPRANGE; FP1,FP2: INTEGER); VAR I, J, K : INTEGER; "FIRSTMEM : BOOLEAN ;" BEGIN IF PRCODE THEN BEGIN PUTIC; WRITE(PRR,"MN[FOP]:4"CHR(FOP):2,' '); CASE FOP OF 22,23,35,39,43: (*DEC,INC,IND,LDO,SRO*) WRITELN(PRR,CHR(FP1),',',FP2:1"6#FW(FP2)") ; 50: (*LDA*) WRITELN(PRR,FP1:1"#FW(FP1)",',',FP2:1"6#FW(FP2)"); 47,48,49,52,53,55: (*EQU..NEQ*) BEGIN WRITE(PRR,CHR(FP1)); IF FP1 = ORD('M') THEN WRITE(PRR,',',FP2:1"6#FW(FP2)"); WRITELN(PRR) END; 51: (*LDC*) CASE FP1 OF 0: WRITELN(PRR,'C,''',CHR(FP2)":1,''''") ; 1: WRITELN(PRR,'I,',FP2:1"6#FW(FP2)"); 2: BEGIN WRITELN(PRR,'R,',CSTPTR@.RVAL); " WITH CSTPTR@ DO FOR K := 1 TO REALLNGTH DO IF RVAL[K] <> ' ' THEN WRITE(PRR,RVAL[K]); WRITELN(PRR) " END; 3: WRITELN(PRR,'B,',FP2:1); 4: WRITELN(PRR,'N'); 5: BEGIN WRITE(PRR,'S,('); WITH CSTPTR@ DO 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 PVAL THEN J := J+1 ; END ; IF I > 0 THEN WRITE(PRR,',') ; WRITE(PRR, J: 1"4#FW(J)" ) ; END (* FOR I := 0 TO 7 *) ; WRITELN(PRR,')') ; END END END; END; IC := IC + 1 END (*GEN2*) ; PROCEDURE GEN3(FOP: OPRANGE; FP0,FP1,FP2: INTEGER); BEGIN IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR, "MN[FOP]:4"CHR(FOP):2, CHR(FP0):2,',',FP1:1"6,#FW(FP1)", ',',FP2:1"6,#FW(FP2)") ; END; IC := IC + 1 END (*GEN3*) ; PROCEDURE LOAD; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN BEGIN CASE KIND OF CST: IF (TYPTR@.FORM = SCALAR) AND (TYPTR <> REALPTR) THEN IF TYPTR = BOOLPTR THEN GEN2(51(*LDC*),3,CVAL.IVAL) ELSE IF TYPTR = CHARPTR THEN GEN2(51(*LDC*),0,CVAL.IVAL) ELSE GEN2(51(*LDC*),1,CVAL.IVAL) (*INTEGER*) ELSE IF TYPTR = NILPTR THEN GEN2(51(*LDC*),4,0) ELSE BEGIN CSTPTR := CVAL.VALP; IF TYPTR = REALPTR THEN GEN2(51(*LDC*),2,0) ELSE GEN2(51(*LDC*),5,0) END; VARBL: CASE ACCESS OF DRCT: GEN3(54(*LOD*),GETTYPE(TYPTR), " LEVEL-" VLEVEL,DPLMT); INDRCT: GEN2(35(*IND*),GETTYPE(TYPTR),IDPLMT); INXD: ERROR(400) END; EXPR: END; KIND := EXPR END END (*LOAD*) ; PROCEDURE STORE(VAR FATTR: ATTR); BEGIN WITH FATTR DO IF TYPTR <> NIL THEN CASE ACCESS OF DRCT: GEN3(56(*STR*),GETTYPE(TYPTR),VLEVEL,DPLMT); INDRCT: IF IDPLMT <> 0 THEN ERROR(400) ELSE GEN1(26(*STO*),GETTYPE(TYPTR)); INXD: ERROR(400) END END (*STORE*) ; PROCEDURE LOADADDRESS; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN BEGIN CASE KIND OF CST: IF STRING(TYPTR) THEN BEGIN CSTPTR := CVAL.VALP ; IF PACKSTRNG THEN GEN1(37 (*LSA*),0) ELSE GEN1(38(*LCA*),0) ; END ELSE ERROR(400); VARBL: CASE ACCESS OF DRCT: GEN2(50(*LDA*),VLEVEL,DPLMT); INDRCT: IF IDPLMT <> 0 THEN GEN2(23(*INC*),ORD('A'),IDPLMT); INXD: ERROR(400) END; EXPR: ERROR(400) END; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0 END END (*LOADADDRESS*) ; PROCEDURE GENFJP(FADDR: INTEGER); BEGIN LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144); IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR,"MN[33]:4"CHR(33):2,' L',FADDR:1"3#FW(FADDR)") END; IC := IC + 1 END (*GENFJP*) ; PROCEDURE GENUJPFJP(FOP: OPRANGE; FP2: INTEGER); BEGIN IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR,"MN[FOP]:4"CHR(FOP):2,' L',FP2:1"3#FW(FP2)") END; IC := IC + 1 END (*GENUJPFJP*); " PROCEDURE MKNAME(VAR ALB: ALPHA; NLB: INTEGER ) ; VAR I, J: INTEGER ; BEGIN I := 0 ; WHILE (I < 5) AND (ALB[I] <> ' ') DO BEGIN IF ALB[I] = '_' THEN ALB[I] := '$' ; I := I+1 END ; FOR J := 7 DOWNTO I DO BEGIN ALB[J] := CHR( ORD('0')+ NLB MOD 10 ) ; NLB := NLB DIV 10 ; END ; END (*MKNAME*) ; " PROCEDURE GENCUP(FP0,FP1,FP2: INTEGER); BEGIN (*GENCUP*) IF PRCODE THEN BEGIN PUTIC ; CALL_CNT[FP2] := CALL_CNT[FP2]+1 ; WRITELN(PRR,"MN[46]:4"CHR(46):2,CHR(FP0):2,',',FP1:1"2#FW(FP1)", ',$',FP2:1"3#FW(FP2)" "TEMPNAME:8,PROCNAME:10"); END ; IC := IC + 1 END (*GENCUP*); PROCEDURE GENENT(FP0,FP1,FP2: INTEGER;PROCNAME: ALPHA); VAR "TEMPNAME : ALPHA ;" TEMPLEN : 0..99 ; BEGIN (*GENENT*) IF PRCODE THEN BEGIN PUTIC ; IF FPROCP <> NIL THEN BEGIN "MKNAME(TEMPNAME,FP2) ;" TEMPLEN := FPROCP@.PLEN END ELSE TEMPLEN := LASTFILBUF ; WRITELN(PRR, '$'"TEMPNAME:8",FP2:3"#FW(FP2)", "MN[32]:4"CHR(32):2, CHR(FP0):2,',',LEVEL:1"#FW(LEVEL)", ',L', FP1:1"3#FW(FP1)", ',', TEMPLEN:2, PROCNAME:10, DEBUG:2) ; END ; IC := IC + 1 END (*GENENT*); PROCEDURE GENDEF(L1, L2: ADDRRANGE ) ; BEGIN IF PRCODE THEN WRITELN(PRR, 'L', L1:1"3#FW(L1)", "MN[63(*DEF*)]:4"CHR(63):2, L2:6); END (*GENDEF*) ; PROCEDURE CHKBNDS(FSP: STP); VAR LMIN,LMAX: INTEGER; BEGIN IF FSP <> NIL THEN IF FSP <> BOOLPTR THEN IF FSP <> INTPTR THEN IF FSP <> REALPTR THEN IF FSP@.FORM <= POINTER THEN BEGIN GETBOUNDS(FSP,LMIN,LMAX); IF LMAX-LMIN <= 0 THEN IF ASSIGN THEN GEN3(45(*CHK*),ORD('A'),-1,0) ELSE (* ACCESS *) GEN3(45(*CHK*),ORD('A'),0,0) ELSE GEN3(45(*CHK*),ORD('I'),LMIN,LMAX) ; END END (*CHKBNDS*); PROCEDURE PUTLABEL(LABNAME: INTEGER); BEGIN IF PRCODE THEN WRITELN(PRR, 'L', LABNAME:1"3#FW(LABNAME)","' LAB'"'L':2) END (*PUTLABEL*); PROCEDURE STATEMENT(FSYS: SETOFSYS); LABEL 1; VAR LCP: CTP; LLP: LBP; TTOP : DISPRANGE ; PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD; PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER; BEGIN WITH FCP@, GATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; CASE KLASS OF VARS: IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN GEN3(54(*LOD*),ORD('A'),VLEV,VADDR); 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 GEN3(54(*LOD*),ORD('A'), LEVEL,VDSPL) ; ACCESS := INDRCT; IDPLMT := FLDADDR END; FUNC: IF PFDECKIND = STANDARD THEN ERROR(150) ELSE IF PFLEV = 0 THEN ERROR(150) (*EXTERNAL FCT*) ELSE IF PFKIND = FORMAL THEN ERROR(151) ELSE IF (FPROCP <> FCP) THEN ERROR(177) ELSE BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1; DPLMT := 0 ;(* FNCRSLT RELAT. ADDR. OF FCT. RESULT*) 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 REPEAT LATTR := GATTR; WITH LATTR DO IF TYPTR <> NIL THEN IF TYPTR@.FORM <> ARRAYS THEN BEGIN ERROR(138); TYPTR := NIL END; LOADADDRESS; INSYMBOL; EXPRESSION(FSYS + [COMMA,RBRACK]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR@.FORM <> SCALAR THEN ERROR(113); IF LATTR.TYPTR <> NIL THEN WITH LATTR.TYPTR@ DO BEGIN IF COMPTYPES(INXTYPE,GATTR.TYPTR) THEN BEGIN IF INXTYPE <> NIL THEN BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); IF DEBUG THEN GEN3(45(*CHK*),ORD('J'),LMIN,LMAX) ; IF LMIN > 0 THEN GEN2(22(*DEC*),GETTYPE(GATTR.TYPTR),LMIN) ELSE IF LMIN < 0 THEN GEN2(23(*INC*),GETTYPE(GATTR.TYPTR),-LMIN) (*OR SIMPLY GEN1(31,LMIN)*) END END ELSE ERROR(139); WITH GATTR DO BEGIN TYPTR := AELTYPE; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0 ; IF GATTR.TYPTR <> NIL THEN BEGIN LMIN := TYPTR@.SIZE ; GEN1(36(*IXA*),LMIN) END (*TYPTR <> NIL*) ; END (*WITH GATTR DO*) ; END UNTIL SY <> COMMA; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END (*IF SY = LBRACK*) ELSE (*.*) IF SY = PERIOD THEN BEGIN WITH GATTR DO BEGIN IF TYPTR <> NIL THEN IF TYPTR@.FORM <> RECORDS THEN BEGIN ERROR(140); TYPTR := NIL END; INSYMBOL; IF SY = IDENT THEN BEGIN IF TYPTR <> NIL THEN BEGIN SEARCHSECTION(TYPTR@.FSTFLD,LCP); IF LCP = NIL THEN BEGIN ERROR(152); TYPTR := NIL END ELSE WITH LCP@ DO BEGIN TYPTR := IDTYPE; CASE ACCESS OF DRCT: DPLMT := DPLMT + FLDADDR; INDRCT: IDPLMT := IDPLMT + FLDADDR; INXD: ERROR(400) 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 CHKBNDS(GATTR.TYPTR) ; TYPTR := ELTYPE ; WITH GATTR DO BEGIN KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0 END END ELSE IF FORM = FILES THEN TYPTR := FILTYPE 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(FSYS: SETOFSYS; FCP: CTP); VAR LKEY: 1..15; MATCHPAR : BOOLEAN ; 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*) ; PROCEDURE RWSETUP(DFILE: ALPHA) ; (* TO SET UP FILE ADDRESS PARAMETER FOR READ/WRITE *) VAR LCP : CTP ; SAVED : BOOLEAN ; TEMPID : ALPHA ; TEMPSY : SYMBOL ; BEGIN SAVED := TRUE ; IF SY = IDENT THEN BEGIN SEARCHID([VARS,FIELD,FUNC,KONST],LCP) ; IF LCP@.IDTYPE <> NIL THEN WITH LCP@.IDTYPE@ DO IF FORM = FILES THEN IF FILTYPE = CHARPTR THEN SAVED := FALSE ELSE ERROR(398) ; END (* SY = IDENT *) ; IF SAVED THEN (* USE IMPLIED FILE NAME *) BEGIN TEMPSY := SY ; TEMPID := ID ; SY := COMMA ; ID := DFILE ; SEARCHID([VARS],LCP) ; END (* IF SAVED *) ELSE INSYMBOL ; SELECTOR(FSYS+[COMMA,RPARENT],LCP) ; LOADADDRESS ; (* GET FILE ADR *) " GEN1(30(*CSP*),29(*SIO*)) ; " IF SAVED THEN BEGIN ID := TEMPID ; SY := TEMPSY END ; END (*RWSETUP*) ; PROCEDURE GETPUTRESETREWRITE; BEGIN "VARIABLE(FSYS + [RPARENT]); LOADADDRESS; " IF ODD(LKEY) (*GET, RESET*) THEN RWSETUP(NA[37] (*INPUT*)) ELSE (*PUT, REWRITE*) RWSETUP(NA[38] (*OUTPUT*) ) ; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR@.FORM <> FILES THEN ERROR(116); GEN1(30(*CSP*),LKEY(*GET,PUT,RES,REW*)) ; GEN1(30(*CSP*),30(*EIO*)) ; END (*GETPUTRESETREWRITE*) ; PROCEDURE READ1; " VAR LCP:CTP; LLEV:LEVRANGE; LADDR:ADDRRANGE; " BEGIN (* LLEV := 1 ; LADDR := FIRSTFILEBUF ; (*ASSUME 'INPUT'*) " IF SY = IDENT THEN " RWSETUP(NA[37] (*'INPUT'*)) ; " ELSE BEGIN ERROR(2) ; INSYMBOL END ; " IF SY = COMMA THEN INSYMBOL; IF LKEY = 5 (*READ*) THEN IF SY <> IDENT THEN ERROR(2) ; IF SY = IDENT THEN REPEAT VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF STRING(GATTR.TYPTR) THEN BEGIN GEN2(51(*LDC*),1,GATTR.TYPTR@.SIZE DIV CHARSIZE) ; GEN1(30(*CSP*),27(*RDS*)) END ELSE BEGIN IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),24(*RDI*)) ELSE IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),14(*RDR*)) ELSE IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),5(*RDC*)) ELSE IF COMPTYPES(BOOLPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),"12(*RDB*)" 24(*RDI*)) ELSE ERROR(116) ; END ; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST ; IF LKEY = 11 THEN BEGIN GEN1(30(*CSP*),23(*RLN*)) END ; GEN1(30(*CSP*),30(*EIO*)) ; END (*READ*) ; PROCEDURE WRITE1; VAR LSP: STP; DEFAULT : BOOLEAN; LLKEY: 1..15; LEN:ADDRRANGE; BEGIN LLKEY := LKEY; TEST := FALSE ; PACKSTRNG := TRUE ; RWSETUP(NA[38] (*'OUTPUT '*) ) ; " IF SY = RPARENT THEN BEGIN TEST := TRUE ; IF LLKEY = 6 THEN ERROR(116) ; END ; IF SY = COMMA THEN INSYMBOL ; IF NOT TEST THEN " IF SY = COMMA THEN BEGIN INSYMBOL; IF NOT (SY IN CONSTBEGSYS) THEN ERROR(6) END ; IF SY IN CONSTBEGSYS THEN REPEAT EXPRESSION(FSYS+[COMMA,COLON,RPARENT]) ; LSP := GATTR.TYPTR; IF LSP <> NIL THEN IF LSP@.FORM <= SUBRANGE THEN LOAD ELSE LOADADDRESS; IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,COLON,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(116); LOAD; DEFAULT := FALSE END ELSE DEFAULT := TRUE; IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(116); IF LSP <> REALPTR THEN ERROR(124); LOAD; ERROR(398); END ELSE IF LSP = INTPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,12); GEN1(30(*CSP*),6(*WRI*)) END ELSE IF LSP = REALPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,14); GEN1(30(*CSP*),8(*WRR*)) END ELSE IF LSP = CHARPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,1); GEN1(30(*CSP*),9(*WRC*)) END ELSE IF LSP = BOOLPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,5); GEN1(30(*CSP*),"13(*WRB*)" 6(*WRI*)) END ELSE IF LSP <> NIL THEN BEGIN IF LSP@.FORM = SCALAR THEN ERROR(398) ELSE IF STRING(LSP) THEN BEGIN LEN := LSP@.SIZE DIV CHARSIZE; IF DEFAULT THEN GEN2(51(*LDC*),1,LEN); GEN2(51(*LDC*),1,LEN); GEN1(30(*CSP*),10(*WRS*)) END ELSE ERROR(116) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL ; UNTIL TEST; IF LLKEY = 12 THEN (*WRITELN*) BEGIN GEN1(30(*CSP*),22(*WLN*)) END ; GEN1(30(*CSP*),30(*EIO*)) ; PACKSTRNG := FALSE ; END (*WRITE1*) ; PROCEDURE PACK1; VAR LSP,LSP1: STP; BEGIN 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) END (*PACK*) ; PROCEDURE UNPACK1; VAR LSP,LSP1: STP; BEGIN 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); END (*UNPACK*) ; PROCEDURE NEW1; LABEL 1; VAR LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER; LSIZE,LSZ: ADDRRANGE; LVAL: VALU; BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; LSP := NIL; VARTS := 0; LSIZE := 0; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR@ DO IF FORM = POINTER THEN BEGIN IF ELTYPE <> NIL THEN BEGIN LSIZE := ELTYPE@.SIZE; IF ELTYPE@.FORM = RECORDS THEN LSP := ELTYPE@.RECVAR END END ELSE ERROR(116); WHILE SY = COMMA DO BEGIN INSYMBOL;CONSTANT(FSYS + [COMMA,RPARENT],LSP1,LVAL); VARTS := VARTS + 1; (*CHECK TO INSERT HERE: IS CONSTANT IN TAGFIELDTYPE RANGE*) IF LSP = NIL THEN ERROR(158) ELSE IF LSP@.FORM <> TAGFLD THEN ERROR(162) ELSE IF LSP@.TAGFIELDP <> NIL THEN IF STRING(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159) ELSE IF COMPTYPES(LSP@.TAGFIELDP@.IDTYPE,LSP1) THEN BEGIN LSP1 := LSP@.FSTVAR; WHILE LSP1 <> NIL DO WITH LSP1@ DO IF VARVAL.IVAL = LVAL.IVAL THEN BEGIN LSIZE := SIZE; LSP := SUBVAR; GOTO 1 END ELSE LSP1 := NXTVAR; LSIZE := LSP@.SIZE; LSP := NIL; END ELSE ERROR(116); 1: END (*WHILE*) ; GEN1(58(*NEW*),LSIZE); END (*NEW*) ; PROCEDURE MARK1; BEGIN VARIABLE(FSYS+[RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR@.FORM = POINTER THEN BEGIN LOADADDRESS; GEN0(59(*SAV*)) END ELSE ERROR(125) END(*MARK*); PROCEDURE RELEASE1; BEGIN VARIABLE(FSYS+[RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR@.FORM = POINTER THEN BEGIN LOAD; GEN0(60(*RST*)) END ELSE ERROR(125) END (*RELEASE*); PROCEDURE TRAPEXIT ; (*THIS PROCEDURE IS TO FACILITATE COMMUNICATION WITH THE OUTSIDE WORLD (* AND PROVIDE BREAK POINTS IN THE PASCAL PROGRAM. (* 'TRAP(I, R)' RETURNS THE INTEGER CONSTANT I AS WELL AS A POINTER (* TO THE SECOND PARAMETER 'R' (I.E. ADDRESS OF R) TO THE OPERATING (* SYSTEM. THE FIRST PARAMETER IS INTENDED TO BE USED AS A (* 'FUNCTION NUMBER' AND THE SECOND ONE AS THE 'VAR' TYPE ARGUMENT (* WHICH MAY BE INSPECTED AND MODIFIED, TO THAT FUNCTION *) BEGIN " EXPRESSION(FSYS+[RPARENT,COMMA]) ; " IF GATTR.TYPTR <> INTPTR THEN ERROR(116) ; IF LKEY = 14 THEN (*TRAP*) BEGIN IF SY <> COMMA THEN ERROR(6) ELSE BEGIN INSYMBOL ; EXPRESSION(FSYS+[RPARENT]) ; WITH GATTR DO IF TYPTR <> NIL THEN BEGIN IF KIND <> VARBL THEN IF TYPTR@.FORM <= POWER THEN BEGIN LOAD ; KIND := VARBL ; ACCESS := DRCT ; VLEVEL := LEVEL ; DPLMT := LC ; STORE(GATTR) ; END ; LOADADDRESS ; END ; END (*WITH*) ; " GEN1(30(*CSP*),28(*TRP*)) ; " END ; GEN1(30(*CSP*),LKEY+14 (*TRAP*) (*XIT*)) ; END (* TRAPEXIT *) ; PROCEDURE ABS1; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR = INTPTR THEN GEN0(0(*ABI*)) ELSE IF GATTR.TYPTR = REALPTR THEN GEN0(1(*ABR*)) ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END (*ABS*) ; PROCEDURE SQR1; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR = INTPTR THEN GEN0(24(*SQI*)) ELSE IF GATTR.TYPTR = REALPTR THEN GEN0(25(*SQR*)) ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END (*SQR*) ; PROCEDURE TRUNC1; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); GEN0(27(*TRC*)); GATTR.TYPTR := INTPTR END (*TRUNC*) ; PROCEDURE ODD1; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GEN0(20(*ODD*)); GATTR.TYPTR := BOOLPTR END (*ODD*) ; PROCEDURE ORD1; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR@.FORM >= POWER THEN ERROR(125); " GEN0(61(*ORD*)) ; " GATTR.TYPTR := INTPTR END (*ORD1*) ; PROCEDURE CHR1; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); " GEN0(62(*CHR*)) ; " GATTR.TYPTR := CHARPTR END (*CHR*) ; PROCEDURE PREDSUCCTIM; BEGIN (*ERROR(398);*) (*TRANSLATES INTO 'DEC' AND 'INC'*) IF GATTR.TYPTR <> NIL THEN IF LKEY = 24 THEN BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(116) ; GEN1(30(*CSP*),21(*CLK*)) ; END ELSE IF (GATTR.TYPTR = REALPTR) OR (GATTR.TYPTR@.FORM <> SCALAR) THEN ERROR(125) ELSE GEN2(LKEY(*DEC,INC*),ORD('I'),1) ; (* LKEY HAPPENS TO BE THE OPCODE AS WELL *) END (*PREDSUCCTIM*) ; PROCEDURE EOFEOLN; BEGIN RWSETUP(NA[37] (*'INPUT '*) ) ; " GEN1(30(*CSP*),29(*SIO*)) ; " (* LKEY HAPPENS TO BE THE CSP NUMBER AS WELL ! *) GEN1(30(*CSP*), LKEY(*EOF*)(*ELN*)) ; GEN1(30(*CSP*),30(*EIO*)) ; GATTR.TYPTR := BOOLPTR END (*EOFEOLN*) ; PROCEDURE MATH; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)) ; GATTR.TYPTR := REALPTR ; END ; IF GATTR.TYPTR <> REALPTR THEN ERROR(116) ELSE GEN1(30(*CSP*), LKEY-12(*SIN..ATAN*)) ; END (*MATH*) ; PROCEDURE CALLNONSTANDARD; VAR NXT,LCP: CTP; LSP: STP; LKIND: IDKIND; LB, SAVEPFLG: BOOLEAN; LOCPAR, LLC: ADDRRANGE; BEGIN LOCPAR := 0; SAVEPFLG := PACKSTRNG ; PACKSTRNG := FALSE ; WITH FCP@ DO BEGIN NXT := NEXT; LKIND := PFKIND; IF NOT EXTERN THEN GEN1( 41(*MST*),PROCTYPE(FCP) ) ; END; IF SY = LPARENT THEN BEGIN LLC := LC; REPEAT LB := FALSE; (*DECIDE WHETHER PROC/FUNC MUST BE PASSED*) IF LKIND = ACTUAL THEN BEGIN IF NXT = NIL THEN ERROR(126) ELSE LB := NXT@.KLASS IN [PROC,FUNC] END ELSE ERROR(398); (*FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING. IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION PARAMETERS*) INSYMBOL; IF LB THEN (*PASS FUNCTION OR PROCEDURE*) BEGIN ERROR(398); IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [COMMA,RPARENT]) END ELSE BEGIN IF NXT@.KLASS = PROC THEN SEARCHID([PROC],LCP) ELSE BEGIN SEARCHID([FUNC],LCP); IF NOT COMPTYPES(LCP@.IDTYPE,NXT@.IDTYPE) THEN ERROR(128) END; INSYMBOL; IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END 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 DEBUG THEN BEGIN ASSIGN := TRUE ; CHKBNDS(LSP) ; ASSIGN := FALSE ; END ; IF COMPTYPES(REALPTR,LSP) AND (GATTR.TYPTR = INTPTR) THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; LOCPAR := LOCPAR+ 1 (*LSP@.SIZE*) ; END ELSE BEGIN LOADADDRESS; LOCPAR := LOCPAR+ 1 (*PTRSIZE*); END ELSE IF GATTR.KIND = VARBL THEN BEGIN LOADADDRESS; LOCPAR := LOCPAR + 1 (*PTRSIZE*); IF GATTR.TYPTR@.SIZE <> LSP@.SIZE THEN ERROR(142) ; END ELSE ERROR(154); IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(142) END END END ELSE (*LKIND = FORMAL*) BEGIN (*PASS FORMAL PARAM*) END END; IF (LKIND = ACTUAL) AND (NXT <> NIL) THEN NXT := NXT@.NEXT UNTIL SY <> COMMA; LC := LLC; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*IF LPARENT*); LOCPAR := LOCPAR*2 ; IF LKIND = ACTUAL THEN BEGIN IF NXT <> NIL THEN ERROR(126); WITH FCP@ DO " IF EXTERN THEN GEN1(30(*CSP*),PFNAME) ELSE " BEGIN GENCUP((*CUP*)PROCTYPE(FCP),LOCPAR,PFNAME",NAME"); END ; END; GATTR.TYPTR := FCP@.IDTYPE ; PACKSTRNG := SAVEPFLG ; END (*CALLNONSTANDARD*) ; BEGIN (*CALL*) IF FCP@.PFDECKIND = STANDARD THEN BEGIN "IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);" LKEY := FCP@.KEY; IF SY = LPARENT THEN BEGIN INSYMBOL ; MATCHPAR := TRUE ; IF SY = RPARENT THEN IF NOT (LKEY IN [1,2,3,4,11,12,25,26]) THEN ERROR(7) ; (*GET,PUT,RESET,REWRITE,RDLN,WRITELN,EOF,ELN*) END ELSE BEGIN IF NOT (LKEY IN [1,2,3,4,11,12,25,26]) THEN ERROR(6) ; (*GET,PUT,RESET,REWRITE,RDLN,WRITELN,EOF,ELN*) "IF SY =RPARENT THEN ERROR(6) ;" MATCHPAR := FALSE ; END ; " IF FCP@.KLASS = PROC THEN " IF LKEY IN [14..24, 27..32 (*TRAP,EXIT,ABS..MATH*)] THEN BEGIN EXPRESSION(FSYS+[RPARENT]) ; LOAD END ; CASE LKEY OF 1,2, 3,4: GETPUTRESETREWRITE; 5,11: READ1; 6,12: WRITE1; 7: PACK1; 8: UNPACK1; 9: NEW1; 10: RELEASE1; 13: MARK1; 14,15: TRAPEXIT ; " END ELSE BEGIN EXPRESSION(FSYS + [RPARENT]); IF LKEY <= 9 THEN LOAD ELSE LOADADDRESS; CASE LKEY OF " 16: ABS1; 17: SQR1; 18: TRUNC1; 19: ODD1; 20: ORD1; 21: CHR1; 22,23,24 :PREDSUCCTIM; 25,26 :EOFEOLN ; 27,28,29, 30,31,32 :MATH ; END (*CASE LKEY OF*) ; " IF LKEY IN [16..24, 27..32] THEN GATTR.BTYPE := GATTR.TYPTR ; " IF MATCHPAR THEN IF SY = RPARENT THEN INSYMBOL ELSE " IF NOT (LKEY IN [1,2,3,4,11,12,25,26]) THEN " ERROR(4) ; END (*STANDARD PROCEDURES AND FUNCTIONS*) ELSE CALLNONSTANDARD END (*CALL*) ; PROCEDURE EXPRESSION; VAR LATTR: ATTR; LOP: OPERATOR; TYPIND: CHAR; LSIZE: ADDRRANGE; PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN; PROCEDURE TERM(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; PROCEDURE FACTOR(FSYS: SETOFSYS); VAR LCP: CTP; LVP: CSP; VARPART: BOOLEAN; CSTPART: SET OF 0..SETRANGE; LSP: STP; I: 0..64 ; BEGIN 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 GATTR, LCP@ DO BEGIN TYPTR := IDTYPE; KIND := CST; CVAL := VALUES END ELSE BEGIN SELECTOR(FSYS,LCP); IF GATTR.TYPTR<>NIL THEN(*ELIM.SUBR.TYPES TO*) WITH GATTR,TYPTR@ DO(*SIMPLIFY LATER TESTS*) IF FORM = SUBRANGE THEN TYPTR := RANGETYPE END END; (*CST*) INTCONST: BEGIN WITH GATTR DO BEGIN TYPTR := INTPTR; KIND := CST; "CVAL := VAL ;" CVAL.IVAL := VAL.IVAL END; INSYMBOL END; 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,ARRAYS); WITH LSP@ DO BEGIN AELTYPE := CHARPTR; FORM:=ARRAYS; INXTYPE := NIL; SIZE := LNGTH*CHARSIZE 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; GEN0(19(*NOT*)); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> BOOLPTR THEN BEGIN ERROR(135); GATTR.TYPTR := NIL END; END; (*[*) LBRACK: BEGIN INSYMBOL; CSTPART := [ ]; VARPART := FALSE; NEW(LSP,POWER); WITH LSP@ DO BEGIN ELSET:=NIL;SIZE:=SETSIZE;FORM:=POWER END; IF SY = RBRACK THEN BEGIN WITH GATTR DO BEGIN TYPTR := LSP; KIND := CST END; INSYMBOL END ELSE BEGIN REPEAT EXPRESSION(FSYS + [COMMA,COLON,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 (CVAL.IVAL < 0) THEN ERROR(304) ELSE " IF TYPTR = CHARPTR THEN CSTPART := CSTPART+ [ASCII[CHR(CVAL.IVAL)]-32] ELSE " CSTPART :=CSTPART+[CVAL.IVAL]; IF SY = COLON THEN (*RANGE GIVEN*) BEGIN INSYMBOL ; LATTR := GATTR ; EXPRESSION(FSYS+[COMMA,RBRACK]) ; IF TYPTR <> LATTR.TYPTR THEN ERROR(137) ELSE FOR I := LATTR.CVAL.IVAL TO CVAL.IVAL DO " IF TYPTR = CHARPTR THEN CSTPART := CSTPART+