(*$C+,T+,L+*) (********************************************** * * * * * PORTABLE PASCAL COMPILER * * ************************ * * * * PASCAL P3 * * * * * * AUTHORS: * * URS AMMANN * * KESAV NORI * * CHRISTIAN JACOBI * * * * ADDRESS: * * * * INSTITUT FUER INFORMATIK * * EIDG. TECHNISCHE HOCHSCHULE * * CH-8096 ZUERICH * * * * * * LAST CHANGES COMPLETED IN MAY 76 * * * * * **********************************************) PROGRAM PASCALCOMPILER(INPUT,OUTPUT,PRR); CONST DISPLIMIT = 20; MAXLEVEL = 10; INTSIZE = 1; REALSIZE = 1; CHARSIZE = 1; BOOLSIZE = 1; SETSIZE =1; PTRSIZE = 1; STRGLGTH = 16; MAXINT = 140737488355327; LCAFTERMARKSTACK = 4; (* 3*PTRSIZE+MAX OF STANDARD SCALAR SIZES AND PTRSIZE *) FILEBUFFER = 4; SETHIGH = 58; SETLOW = 0; ORDMINCHAR = 0; ORDMAXCHAR = 63; MAXADDR = MAXINT; 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; CHTP = (LETTER,NUMBER,SPECIAL,ILLEGAL); (*CONSTANTS*) (***********) CSTCLASS = (REEL,PSET,STRG); CSP = ' CONSTANT; CONSTANT = RECORD CASE CCLASS: CSTCLASS OF REEL: (RVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR); PSET: (PVAL: SET OF 0..58); STRG: (SLGTH: 0..STRGLGTH; SVAL: PACKED ARRAY [1..STRGLGTH] 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; STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES, TAGFLD,VARIANT); DECLKIND = (STANDARD,DECLARED); STP = ' STRUCTURE; CTP = ' IDENTIFIER; STRUCTURE = PACKED RECORD MARKED: BOOLEAN; (*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 [1..8] 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: INTEGER; 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*) VAL: VALU; (*VALUE OF LAST CONSTANT*) LGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*) ID: ALPHA; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)*) KK: 1..8; (*NR OF CHARS IN LAST IDENTIFIER*) CH: CHAR; (*LAST CHARACTER*) EOL: BOOLEAN; (*END OF LINE FLAG*) (*COUNTERS:*) (***********) CHCNT: INTEGER; (*CHARACTER COUNTER*) LC,IC: ADDRRANGE; (*DATA LOCATION AND INSTRUCTION COUNTER*) LINECOUNT: INTEGER; (*SWITCHES:*) (***********) DP, (*DECLARATION PART*) PRTERR, (*TO ALLOW FORWARD REFERENCES IN POINTER TYPE DECLARATION BY SUPPRESSING ERROR MESSAGE*) LIST,PRCODE,PRTABLES: BOOLEAN; (*OUTPUT OPTIONS FOR -- SOURCE PROGRAM LISTING -- PRINTING SYMBOLIC CODE -- DISPLAYING IDENT AND STRUCT TABLES --> PROCEDURE OPTION*) DEBUG: BOOLEAN; (*POINTERS:*) (***********) INTPTR,REALPTR,CHARPTR, 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*) (*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: INTEGER; NMR: 1..400 END; (*EXPRESSION COMPILATION:*) (*************************) GATTR: ATTR; (*DESCRIBES THE EXPR CURRENTLY COMPILED*) (*STRUCTURED CONSTANTS:*) (***********************) CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS, STATBEGSYS,TYPEDELS: SETOFSYS; CHARTP : ARRAY[CHAR] OF CHTP; RW: ARRAY [1..35(*NR. OF RES. WORDS*)] OF ALPHA; FRW: ARRAY [1..9] OF 1..36(*NR. OF RES. WORDS + 1*); RSY: ARRAY [1..35(*NR. OF RES. WORDS*)] OF SYMBOL; SSY: ARRAY [CHAR] OF SYMBOL; ROP: ARRAY [1..35(*NR. OF RES. WORDS*)] OF OPERATOR; SOP: ARRAY [CHAR] OF OPERATOR; NA: ARRAY [1..35] OF ALPHA; MN: ARRAY [0..57] OF PACKED ARRAY [1..4] OF CHAR; SNA: ARRAY [1..23] OF PACKED ARRAY [1..4] OF CHAR; ORDINT: ARRAY[CHAR] OF INTEGER; INTLABEL,MXINT10,DIGMAX: INTEGER; (*-------------------------------------------------------------------------*) PROCEDURE ENDOFLINE; VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER; BEGIN IF ERRINX > 0 THEN (*OUTPUT ERROR MESSAGES*) BEGIN WRITE(OUTPUT,# **** #:15); 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 END; IF LIST AND (NOT EOF(INPUT)) THEN BEGIN LINECOUNT := LINECOUNT + 1; WRITE(OUTPUT,LINECOUNT:6,# #:2); IF DP THEN WRITE(OUTPUT,LC:7) ELSE WRITE(OUTPUT,IC:7); WRITE(OUTPUT,# #) END; 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 END (*ERROR*) ; PROCEDURE INSYMBOL; (*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH*) LABEL 1,2,3; VAR I,K: INTEGER; DIGIT: PACKED ARRAY [1..STRGLGTH] OF CHAR; STRING: PACKED ARRAY [1..STRGLGTH] OF CHAR; LVP: CSP;TEST: BOOLEAN; PROCEDURE NEXTCH; BEGIN IF EOL THEN BEGIN IF LIST THEN WRITELN(OUTPUT); ENDOFLINE END; IF NOT EOF(INPUT) THEN BEGIN EOL := EOLN(INPUT); READ(INPUT,CH); IF LIST THEN WRITE(OUTPUT,CH); CHCNT := CHCNT + 1 END ELSE BEGIN WRITELN(OUTPUT,# EOF #,#ENCOUNTERED#); TEST := FALSE END END; 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 = #+#; IF NOT LIST THEN WRITELN(OUTPUT) END ELSE IF CH = #D# THEN BEGIN NEXTCH; DEBUG := CH = #+# END ELSE IF CH = #C# THEN BEGIN NEXTCH; PRCODE := 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 CHARTP[CH] = ILLEGAL THEN BEGIN SY := OTHERSY; OP := NOOP; ERROR(399); NEXTCH END ELSE 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; REPEAT IF K < 8 THEN BEGIN K := K + 1; ID[K] := CH END ; NEXTCH UNTIL CHARTP[CH] IN [SPECIAL,ILLEGAL]; 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 DIGIT[I] := CH; NEXTCH UNTIL CHARTP[CH] <> NUMBER; IF (CH = #.#) OR (CH = #E#) THEN BEGIN K := I; IF CH = #.# THEN BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH; IF CH = #.# THEN BEGIN CH := #:#; GOTO 3 END; IF CHARTP[CH] <> NUMBER THEN ERROR(201) ELSE REPEAT K := K + 1; IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH UNTIL CHARTP[CH] <> NUMBER END; IF CH = #E# THEN BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH; IF (CH = #+#) OR (CH =#-#) THEN BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH END; IF CHARTP[CH] <> NUMBER THEN ERROR(201) ELSE REPEAT K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH UNTIL CHARTP[CH] <> NUMBER END; NEW(LVP,REEL); SY:= REALCONST; LVP'.CCLASS := REEL; WITH LVP' DO BEGIN FOR I := 1 TO STRGLGTH DO RVAL[I] := # #; IF K <= DIGMAX THEN FOR I := 2 TO K + 1 DO RVAL[I] := DIGIT[I-1] ELSE BEGIN ERROR(203); RVAL[2] := #0#; RVAL[3] := #.#; RVAL[4] := #0# END END; VAL.VALP := LVP 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+ORDINT[DIGIT[K]] ELSE BEGIN ERROR(203); IVAL := 0 END END; SY := INTCONST END END END; ####: BEGIN LGTH := 0; SY := STRINGCONST; OP := NOOP; REPEAT REPEAT NEXTCH; LGTH := LGTH + 1; IF LGTH <= STRGLGTH THEN STRING[LGTH] := CH UNTIL (EOL) OR (CH = ####); IF EOL THEN ERROR(202) ELSE NEXTCH UNTIL CH <> ####; LGTH := LGTH - 1; (*NOW LGTH = NR OF CHARS IN STRING*) IF LGTH = 1 THEN VAL.IVAL := ORD(STRING[1]) ELSE BEGIN NEW(LVP,STRG); LVP'.CCLASS:=STRG; IF LGTH > STRGLGTH THEN BEGIN ERROR(399); LGTH := STRGLGTH END; WITH LVP' DO BEGIN SLGTH := LGTH; FOR I := 1 TO LGTH DO SVAL[I] := STRING[I] END; VAL.VALP := LVP 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; SY := LPARENT; OP := NOOP END; #*#,#+#,#-#, #=#,#/#,#)#, #[#,#]#,#,#,#;#,#'#,#$#: BEGIN SY := SSY[CH]; OP := SOP[CH]; NEXTCH END; #@#,#\#,#"#,#_#,#?#, #&#,#!#,#^#: BEGIN SY := OTHERSY; OP := NOOP; ERROR(399); NEXTCH END; # #: SY := OTHERSY 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<>INTPTR AND FSP<>REALPTR*) BEGIN FMIN := 0; FMAX := 0; IF FSP <> NIL THEN WITH FSP' DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END ELSE IF FSP = CHARPTR THEN BEGIN FMIN := ORDMINCHAR; FMAX := ORDMAXCHAR END ELSE IF FCONST <> NIL THEN FMAX := FCONST'.VALUES.IVAL 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,# #:4,ORD(FCONST):6); 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 SLGTH 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,# #:4,ORD(NEXT):6); 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; PROCEDURE SKIP(FSYS: SETOFSYS); (*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*) BEGIN IF NOT EOF(INPUT) THEN BEGIN WHILE NOT(SY IN FSYS) AND (NOT EOF(INPUT)) DO INSYMBOL; IF NOT (SY IN FSYS) THEN 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: 2..STRGLGTH; 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 = STRINGCONSTSY THEN BEGIN IF LGTH = 1 THEN LSP := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS); WITH LSP' DO BEGIN AELTYPE := CHARPTR; INXTYPE := NIL; SIZE := LGTH*CHARSIZE; FORM := ARRAYS END END; FVALU := VAL; 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[1] = #-# THEN LVP'.RVAL[1] := #+# ELSE LVP'.RVAL[1] := #-#; FOR I := 2 TO STRGLGTH 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 := VAL; INSYMBOL END ELSE IF SY = REALCONST THEN BEGIN IF SIGN = NEG THEN VAL.VALP'.RVAL[1] := #-#; LSP := REALPTR; FVALU := VAL; 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 EQUALBOUNDS(FSP1,FSP2: STP): BOOLEAN; VAR LMIN1,LMIN2,LMAX1,LMAX2: INTEGER; BEGIN IF (FSP1=NIL) OR (FSP2=NIL) THEN EQUALBOUNDS := TRUE ELSE BEGIN GETBOUNDS(FSP1,LMIN1,LMAX1); GETBOUNDS(FSP1,LMIN2,LMAX2); EQUALBOUNDS := (LMIN1=LMIN2) AND (LMAX1=LMAX2) END END (*EQUALBOUNDS*) ; 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: BEGIN COMP := COMPTYPES(FSP1'.AELTYPE,FSP2'.AELTYPE) AND COMPTYPES(FSP1'.INXTYPE,FSP2'.INXTYPE); COMPTYPES := COMP AND EQUALBOUNDS(FSP1'.INXTYPE,FSP2'.INXTYPE) END; 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 IF COMPTYPES(FSP'.AELTYPE,CHARPTR) THEN STRING := TRUE 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 := INTSIZE 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 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(399) 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]) THEN 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 := DISPL END; ENTERID(LCP); INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP1); LSP1 := LCP1'.IDTYPE; IF LSP1 <> NIL THEN BEGIN DISPL := DISPL + LSP1'.SIZE; IF (LSP1'.FORM <= SUBRANGE) OR STRING(LSP1) THEN BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109) ELSE IF STRING(LSP1) THEN ERROR(399); LCP'.IDTYPE := LSP1; LSP'.TAGFIELDP := LCP; END ELSE ERROR(110); END; INSYMBOL; END ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) 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; IF NOT (SY IN [SEMICOLON,ENDSY]) THEN BEGIN 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; LSP4 := LSP1; WHILE LSP4 <> NIL DO WITH LSP4' DO BEGIN IF VARVAL.IVAL = LVALU.IVAL THEN ERROR(178); LSP4 := NXTVAR 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); END; TEST := SY <> SEMICOLON; IF NOT TEST THEN BEGIN DISPL := MINSIZE; INSYMBOL 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); LSP1'.SIZE := 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 INSYMBOL; ERROR(399); SKIP(FSYS); LSP := NIL 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: INTEGER; 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; BEGIN NXT := NIL; REPEAT REPEAT IF SY = IDENT THEN BEGIN NEW(LCP,VARS); 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); WHILE NXT <> NIL DO WITH NXT' DO BEGIN IDTYPE := LSP; VADDR := LC; LC := LC + LSIZE; 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: 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; 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(399); 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(399); 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); LSP := LCP'.IDTYPE; IF LSP <> NIL THEN IF (LKIND=ACTUAL)AND(LSP'.FORM=FILES) THEN ERROR(121); LCP3 := LCP2; LEN := PTRSIZE; IF LSP <> NIL THEN IF (LKIND = ACTUAL)AND(LSP'.SIZE <= PTRSIZE) THEN LEN := LSP'.SIZE; LC := LC+COUNT*LEN; 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; (*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'.SIZE > PTRSIZE) THEN BEGIN VADDR := LC; LC := LC + IDTYPE'.SIZE END; LCP3 := LCP1; LCP1 := LCP2 END; FPAR := LCP3 END ELSE FPAR := NIL END (*PARAMETERLIST*) ; BEGIN (*PROCDECLARATION*) LLC := LC; LC := LCAFTERMARKSTACK; FORW := FALSE; 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; 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; GENLABEL(LBNAME); PFDECKIND := DECLARED; PFKIND := ACTUAL; PFNAME := LBNAME; 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 BEGIN ERROR(2); LCP := UFCTPTR END; OLDLEV := LEVEL; OLDTOP := TOP; 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 THEN IF NOT (LSP'.FORM IN [SCALAR,SUBRANGE,POINTER]) THEN BEGIN ERROR(120); LCP'.IDTYPE := NIL END; 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; NEW(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]) OR EOF(INPUT); RELEASE(MARKP); (* RETURN LOCAL ENTRIES ON RUNTIME HEAP *) END; LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; END (*PROCDECLARATION*) ; PROCEDURE BODY(FSYS: SETOFSYS); CONST CSTOCCMAX=65; CIXMAX=1000; TYPE OPRANGE = 0..63; VAR LLCP:CTP; SAVEID:ALPHA; CSTPTR: ARRAY [1..CSTOCCMAX] OF CSP; CSTPTRIX: 0..CSTOCCMAX; (*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*) I, ENTNAME, SEGSIZE: INTEGER; LCMAX,LLC1: ADDRRANGE; LCP: CTP; LLP: LBP; PROCEDURE PUTIC; BEGIN IF IC MOD 10 = 0 THEN WRITELN(PRR,#I#,IC:5) END; PROCEDURE GEN0(FOP: OPRANGE); BEGIN IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR,MN[FOP]:4) 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); IF FOP = 30 THEN WRITELN(PRR,SNA[FP2]:12) ELSE IF FOP = 38 THEN BEGIN WRITE(PRR,####); WITH CSTPTR[FP2]' DO BEGIN FOR K := 1 TO SLGTH DO WRITE(PRR,SVAL[K]:1); FOR K := SLGTH+1 TO STRGLGTH DO WRITE(PRR,# #); END; WRITELN(PRR,####) END ELSE IF FOP = 42 THEN WRITELN(PRR,CHR(FP2)) ELSE WRITELN(PRR,FP2:12) END; IC := IC + 1 END (*GEN1*) ; PROCEDURE GEN2(FOP: OPRANGE; FP1,FP2: INTEGER); VAR K : INTEGER; BEGIN IF PRCODE THEN BEGIN PUTIC; WRITE(PRR,MN[FOP]:4); CASE FOP OF 45,50,54,56: WRITELN(PRR,# #,FP1:3,FP2:8); 47,48,49,52,53,55: BEGIN WRITE(PRR,CHR(FP1)); IF CHR(FP1) = #M# THEN WRITE(PRR,FP2:11); WRITELN(PRR) END; 51: CASE FP1 OF 1: WRITELN(PRR,#I #,FP2); 2: BEGIN WRITE(PRR,#R #); WITH CSTPTR[FP2]' DO FOR K := 1 TO STRGLGTH DO WRITE(PRR,RVAL[K]); WRITELN(PRR) END; 3: WRITELN(PRR,#B #,FP2); 4: WRITELN(PRR,#N#); 5: BEGIN WRITE(PRR,#(#); WITH CSTPTR[FP2]' DO FOR K := 0 TO 58 DO IF K IN PVAL THEN WRITE(PRR,K:3); WRITELN(PRR,#)#) END END END; END; IC := IC + 1 END (*GEN2*) ; 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 GEN2(51(*LDC*),1,CVAL.IVAL) ELSE IF TYPTR = NILPTR THEN GEN2(51(*LDC*),4,0) ELSE IF CSTPTRIX >= CSTOCCMAX THEN ERROR(254) ELSE BEGIN CSTPTRIX := CSTPTRIX + 1; CSTPTR[CSTPTRIX] := CVAL.VALP; IF TYPTR = REALPTR THEN GEN2(51(*LDC*),2,CSTPTRIX) ELSE GEN2(51(*LDC*),5,CSTPTRIX) END; VARBL: CASE ACCESS OF DRCT: IF VLEVEL <= 1 THEN GEN1(39(*LDO*),DPLMT) ELSE GEN2(54(*LOD*),LEVEL-VLEVEL,DPLMT); INDRCT: GEN1(35(*IND*),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: IF VLEVEL <= 1 THEN GEN1(43(*SRO*),DPLMT) ELSE GEN2(56(*STR*),LEVEL-VLEVEL,DPLMT); INDRCT: IF IDPLMT <> 0 THEN ERROR(400) ELSE GEN0(26(*STO*)); 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 IF CSTPTRIX >= CSTOCCMAX THEN ERROR(254) ELSE BEGIN CSTPTRIX := CSTPTRIX + 1; CSTPTR[CSTPTRIX] := CVAL.VALP; GEN1(38(*LCA*),CSTPTRIX) END ELSE ERROR(400); VARBL: CASE ACCESS OF DRCT: IF VLEVEL <= 1 THEN GEN1(37(*LAO*),DPLMT) ELSE GEN2(50(*LDA*),LEVEL-VLEVEL,DPLMT); INDRCT: IF IDPLMT <> 0 THEN GEN1(34(*INC*),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,# L#:8,FADDR:4) END; IC := IC + 1 END (*GENFJP*) ; PROCEDURE GENUJPENT(FOP: OPRANGE; FP2: INTEGER); BEGIN IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR, MN[FOP]:4, # L#:8,FP2:4) END; IC := IC + 1 END (*GENUJPENT*); PROCEDURE GENCUP(FP1, FP2: INTEGER); BEGIN IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR, MN[46]:4, FP1:4, # L#:4, FP2:4) END; IC := IC + 1 END (*GENCUP*); PROCEDURE CHECKBNDS(FSP: STP); VAR LMIN,LMAX: INTEGER; BEGIN IF FSP <> NIL THEN IF FSP <> INTPTR THEN IF FSP <> REALPTR THEN IF FSP'.FORM <= SUBRANGE THEN BEGIN GETBOUNDS(FSP,LMIN,LMAX); GEN2(45(*CHK*),LMIN,LMAX) END END (*CHECKBNDS*); PROCEDURE PUTLABEL(LABNAME: INTEGER); BEGIN IF PRCODE THEN WRITELN(PRR, #L#, LABNAME:4) END (*PUTLABEL*); PROCEDURE STATEMENT(FSYS: SETOFSYS); LABEL 1; VAR LCP: CTP; LLP: LBP; 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 GEN2(54(*LOD*),LEVEL-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 IF LEVEL = 1 THEN GEN1(39(*LDO*),VDSPL) ELSE GEN2(54(*LOD*),0,VDSPL); ACCESS := INDRCT; IDPLMT := FLDADDR END; FUNC: IF PFDECKIND = STANDARD THEN BEGIN ERROR(150); TYPTR := NIL END ELSE BEGIN IF PFKIND = FORMAL THEN ERROR(151) ELSE IF (PFLEV+1<>LEVEL)OR(FPROCP<>FCP) THEN ERROR(177); BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1; DPLMT := 0 (*IMPL. RELAT. ADDR. OF FCT. RESULT*) END 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 GEN2(45(*CHK*),LMIN,LMAX); IF LMIN > 0 THEN GEN1(31(*DEC*),LMIN) ELSE IF LMIN < 0 THEN GEN1(34(*INC*),-LMIN) (*OR SIMPLY GEN1(31,LMIN)*) END END ELSE ERROR(139); WITH GATTR DO BEGIN TYPTR := AELTYPE; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0 END; IF GATTR.TYPTR <> NIL THEN GEN1(36(*IXA*),GATTR.TYPTR'.SIZE) 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 TYPTR := ELTYPE; LOAD; 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; 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 GETPUTRESETREWRITE; BEGIN VARIABLE(FSYS + [RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <> FILES THEN ERROR(116); IF LKEY <= 2 THEN GEN1(30(*CSP*),LKEY(*GET,PUT*)) ELSE ERROR(399) END (*GETPUTRESETREWRITE*) ; PROCEDURE READ; VAR LCP:CTP; LLEV:LEVRANGE; LADDR:ADDRRANGE; LSP : STP; BEGIN LLEV := 1; LADDR := LCAFTERMARKSTACK; IF SY = LPARENT THEN BEGIN INSYMBOL; VARIABLE(FSYS + [COMMA,RPARENT]); LSP := GATTR.TYPTR; TEST := FALSE; IF LSP <> NIL THEN IF LSP'.FORM = FILES THEN WITH GATTR, LSP' DO BEGIN IF FILTYPE = CHARPTR THEN BEGIN LLEV := VLEVEL; LADDR := DPLMT END ELSE ERROR(399); IF SY = RPARENT THEN BEGIN IF LKEY = 8 THEN ERROR(116); TEST := TRUE END ELSE IF SY <> COMMA THEN BEGIN ERROR(116); SKIP(FSYS + [COMMA,RPARENT]) END; IF SY = COMMA THEN BEGIN INSYMBOL; VARIABLE(FSYS + [COMMA,RPARENT]) END ELSE TEST := TRUE END; IF NOT TEST THEN REPEAT LOADADDRESS; GEN2(50(*LDA*),LEVEL-LLEV,LADDR); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <= SUBRANGE THEN IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),3(*RDI*)) ELSE IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),4(*RDR*)) ELSE IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN GEN1(30(*CSP*),5(*RDC*)) ELSE ERROR(399) ELSE ERROR(116); TEST := SY <> COMMA; IF NOT TEST THEN BEGIN INSYMBOL; VARIABLE(FSYS + [COMMA,RPARENT]) END UNTIL TEST; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE IF LKEY = 5 THEN ERROR(116); IF LKEY = 11 THEN BEGIN GEN2(50(*LDA*),LEVEL - LLEV, LADDR); GEN1(30(*CSP*),21(*RLN*)) END END (*READ*) ; PROCEDURE WRITE; VAR LSP: STP; DEFAULT : BOOLEAN; LLKEY: 1..15; LCP:CTP; LLEV:LEVRANGE; LADDR,LEN:ADDRRANGE; BEGIN LLKEY := LKEY; LLEV := 1; LADDR := LCAFTERMARKSTACK + CHARSIZE; IF SY = LPARENT THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,COLON,RPARENT]); LSP := GATTR.TYPTR; TEST := FALSE; IF LSP <> NIL THEN IF LSP'.FORM = FILES THEN WITH GATTR, LSP' DO BEGIN IF FILTYPE = CHARPTR THEN BEGIN LLEV := VLEVEL; LADDR := DPLMT END ELSE ERROR(399); IF SY = RPARENT THEN BEGIN IF LLKEY = 10 THEN ERROR(116); TEST := TRUE END ELSE IF SY <> COMMA THEN BEGIN ERROR(116); SKIP(FSYS+[COMMA,RPARENT]) END; IF SY = COMMA THEN BEGIN INSYMBOL; EXPRESSION(FSYS+[COMMA,COLON,RPARENT]) END ELSE TEST := TRUE END; IF NOT TEST THEN REPEAT 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(399); END ELSE IF LSP = INTPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,10); GEN2(50(*LDA*),LEVEL-LLEV,LADDR); GEN1(30(*CSP*),6(*WRI*)) END ELSE IF LSP = REALPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,20); GEN2(50(*LDA*),LEVEL-LLEV,LADDR); GEN1(30(*CSP*),8(*WRR*)) END ELSE IF LSP = CHARPTR THEN BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,1); GEN2(50(*LDA*),LEVEL-LLEV,LADDR); GEN1(30(*CSP*),9(*WRC*)) END ELSE IF LSP <> NIL THEN BEGIN IF LSP'.FORM = SCALAR THEN ERROR(399) ELSE IF STRING(LSP) THEN BEGIN LEN := LSP'.SIZE DIV CHARSIZE; IF DEFAULT THEN GEN2(51(*LDC*),1,LEN); GEN2(51(*LDC*),1,LEN); GEN2(50(*LDA*),LEVEL-LLEV,LADDR); GEN1(30(*CSP*),10(*WRS*)) END ELSE ERROR(116) END; TEST := SY <> COMMA; IF NOT TEST THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,COLON,RPARENT]) END UNTIL TEST; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE IF LKEY = 6 THEN ERROR(116); IF LLKEY = 12 THEN (*WRITELN*) BEGIN GEN2(50(*LDA*),LEVEL-LLEV,LADDR); GEN1(30(*CSP*),22(*WLN*)) END END (*WRITE*) ; PROCEDURE PACK; VAR LSP,LSP1: STP; BEGIN ERROR(399); 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 UNPACK; VAR LSP,LSP1: STP; BEGIN ERROR(399); 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 NEW; 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*) ; GEN2(51(*LDC*),1,LSIZE); GEN1(30(*CSP*),12(*NEW*)); END (*NEW*) ; PROCEDURE MARK; BEGIN VARIABLE(FSYS+[RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM = POINTER THEN BEGIN LOADADDRESS; GEN1(30(*CSP*),23(*SAV*)) END ELSE ERROR(125) END(*MARK*); PROCEDURE RELEASE; BEGIN VARIABLE(FSYS+[RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM = POINTER THEN BEGIN LOAD; GEN1(30(*CSP*),13(*RST*)) END ELSE ERROR(125) END (*RELEASE*); PROCEDURE ABS; 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 SQR; 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 TRUNC; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); GEN0(27(*TRC*)); GATTR.TYPTR := INTPTR END (*TRUNC*) ; PROCEDURE ODD; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GEN0(20(*ODD*)); GATTR.TYPTR := BOOLPTR END (*ODD*) ; PROCEDURE ORD; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM >= POWER THEN ERROR(125); GATTR.TYPTR := INTPTR END (*ORD*) ; PROCEDURE CHR; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GATTR.TYPTR := CHARPTR END (*CHR*) ; PROCEDURE PREDSUCC; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <> SCALAR THEN ERROR(125); IF LKEY = 7 THEN GEN1(31(*DEC*),1) ELSE GEN1(34(*INC*),1) END (*PREDSUCC*) ; PROCEDURE EOF; BEGIN IF SY = LPARENT THEN BEGIN INSYMBOL; VARIABLE(FSYS + [RPARENT]); IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE WITH GATTR DO BEGIN TYPTR := TEXTPTR; KIND := VARBL; ACCESS := DRCT; VLEVEL := 1; DPLMT := LCAFTERMARKSTACK END; LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <> FILES THEN ERROR(125); IF LKEY = 9 THEN GEN0(8(*EOF*)) ELSE GEN1(30(*CSP*),14(*ELN*)); GATTR.TYPTR := BOOLPTR END (*EOF*) ; PROCEDURE CALLNONSTANDARD; VAR NXT,LCP: CTP; LSP: STP; LKIND: IDKIND; LB: BOOLEAN; LOCPAR, LLC: ADDRRANGE; BEGIN LOCPAR := 0; WITH FCP' DO BEGIN NXT := NEXT; LKIND := PFKIND; IF NOT EXTERN THEN GEN1(41(*MST*),LEVEL-PFLEV) 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(399); (*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(399); 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'.SIZE <= PTRSIZE THEN BEGIN LOAD; IF DEBUG THEN CHECKBNDS(LSP); IF COMPTYPES(REALPTR,LSP) AND (GATTR.TYPTR = INTPTR) THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; LOCPAR := LOCPAR + LSP'.SIZE END ELSE BEGIN IF (GATTR.KIND = EXPR) OR (GATTR.KIND = CST) THEN BEGIN LOAD; IF COMPTYPES(REALPTR,LSP) AND (GATTR.TYPTR = INTPTR) THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; GEN2(56(*STR*),0,LC); GEN2(50(*LDA*),0,LC); LC := LC + GATTR.TYPTR'.SIZE; IF LCMAX < LC THEN LCMAX := LC END ELSE IF COMPTYPES(REALPTR,LSP) AND (GATTR.TYPTR = INTPTR) THEN BEGIN LOAD; GEN0(10(*FLT*)); GEN2(56(*STR*),0,LC); GEN2(50(*LDA*),0,LC); LC := LC + GATTR.TYPTR'.SIZE; IF LCMAX < LC THEN LCMAX := LC END ELSE LOADADDRESS; LOCPAR := LOCPAR + PTRSIZE END ELSE IF GATTR.KIND = VARBL THEN BEGIN LOADADDRESS; LOCPAR := LOCPAR + PTRSIZE 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*); IF LKIND = ACTUAL THEN BEGIN IF NXT <> NIL THEN ERROR(126); WITH FCP' DO BEGIN IF EXTERN THEN GEN1(30(*CSP*),PFNAME) ELSE GENCUP(LOCPAR, PFNAME); END END; GATTR.TYPTR := FCP'.IDTYPE END (*CALLNONSTANDARD*) ; BEGIN (*CALL*) IF FCP'.PFDECKIND = STANDARD THEN BEGIN LKEY := FCP'.KEY; IF FCP'.KLASS = PROC THEN BEGIN IF NOT(LKEY IN [5,6,11,12]) THEN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); CASE LKEY OF 1,2, 3,4: GETPUTRESETREWRITE; 5,11: READ; 6,12: WRITE; 7: PACK; 8: UNPACK; 9: NEW; 10: RELEASE; 13: MARK END; IF NOT(LKEY IN [5,6,11,12]) THEN IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE BEGIN IF LKEY <= 8 THEN BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); EXPRESSION(FSYS+[RPARENT]); LOAD END; CASE LKEY OF 1: ABS; 2: SQR; 3: TRUNC; 4: ODD; 5: ORD; 6: CHR; 7,8: PREDSUCC; 9,10: EOF END; IF LKEY <= 8 THEN IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END; 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..58; LSP: STP; 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 := CST; 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 END; INSYMBOL END; REALCONST: BEGIN WITH GATTR DO BEGIN TYPTR := REALPTR; KIND := CST; CVAL := VAL END; INSYMBOL END; STRINGCONST: BEGIN WITH GATTR DO BEGIN IF LGTH = 1 THEN TYPTR := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS); WITH LSP' DO BEGIN AELTYPE := CHARPTR; FORM:=ARRAYS; INXTYPE := NIL; SIZE := LGTH*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,RBRACK]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <> SCALAR THEN BEGIN ERROR(136); GATTR.TYPTR := NIL END ELSE IF COMPTYPES(LSP'.ELSET,GATTR.TYPTR) THEN BEGIN IF GATTR.KIND = CST THEN IF (GATTR.CVAL.IVAL < SETLOW) OR (GATTR.CVAL.IVAL > SETHIGH) THEN ERROR(304) ELSE CSTPART := CSTPART+[GATTR.CVAL.IVAL] ELSE BEGIN LOAD; GEN0(23(*SGS*)); IF VARPART THEN GEN0(28(*UNI*)) ELSE VARPART := TRUE END; LSP'.ELSET := GATTR.TYPTR; GATTR.TYPTR := LSP END ELSE ERROR(137); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END; IF VARPART THEN BEGIN IF CSTPART <> [ ] THEN BEGIN NEW(LVP,PSET); LVP'.PVAL := CSTPART; LVP'.CCLASS := PSET; IF CSTPTRIX = CSTOCCMAX THEN ERROR(254) ELSE BEGIN CSTPTRIX := CSTPTRIX + 1; CSTPTR[CSTPTRIX] := LVP; GEN2(51(*LDC*),5,CSTPTRIX); GEN0(28(*UNI*)); GATTR.KIND := EXPR END END END ELSE BEGIN NEW(LVP,PSET); LVP'.PVAL := CSTPART; LVP'.CCLASS := PSET; GATTR.CVAL.VALP := LVP END END END (*CASE*) ; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS + FACBEGSYS) END END (*WHILE*) END (*FACTOR*) ; BEGIN (*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 CASE LOP OF (***) MUL: IF (LATTR.TYPTR=INTPTR)AND(GATTR.TYPTR=INTPTR) THEN GEN0(15(*MPI*)) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GEN0(9(*FLO*)); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND(GATTR.TYPTR=REALPTR)THEN GEN0(16(*MPR*)) ELSE IF(LATTR.TYPTR'.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)THEN GEN0(12(*INT*)) ELSE BEGIN ERROR(134);GATTR.TYPTR:=NIL END END; (*/*) RDIV: BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF LATTR.TYPTR = INTPTR THEN BEGIN GEN0(9(*FLO*)); LATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR=REALPTR)THEN GEN0(7(*DVR*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; (*DIV*) IDIV: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN0(6(*DVI*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END; (*MOD*) IMOD: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN0(14(*MOD*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END; (*AND*) ANDOP:IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) THEN GEN0(4(*AND*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END (*CASE*) ELSE GATTR.TYPTR := NIL END (*WHILE*) END (*TERM*) ; BEGIN (*SIMPLEEXPRESSION*) SIGNED := FALSE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN SIGNED := OP = MINUS; INSYMBOL END; TERM(FSYS + [ADDOP]); IF SIGNED THEN BEGIN LOAD; IF GATTR.TYPTR = INTPTR THEN GEN0(17(*NGI*)) ELSE IF GATTR.TYPTR = REALPTR THEN GEN0(18(*NGR*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END 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 CASE LOP OF (*+*) PLUS: IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN GEN0(2(*ADI*)) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GEN0(9(*FLO*)); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR) THEN GEN0(3(*ADR*)) ELSE IF(LATTR.TYPTR'.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN GEN0(28(*UNI*)) ELSE BEGIN ERROR(134);GATTR.TYPTR:=NIL END END; (*-*) MINUS: IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN GEN0(21(*SBI*)) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GEN0(9(*FLO*)); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR) THEN GEN0(22(*SBR*)) ELSE IF (LATTR.TYPTR'.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN GEN0(5(*DIF*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; (*OR*) OROP: IF(LATTR.TYPTR=BOOLPTR)AND(GATTR.TYPTR=BOOLPTR)THEN GEN0(13(*IOR*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END (*CASE*) ELSE GATTR.TYPTR := NIL END (*WHILE*) END (*SIMPLEEXPRESSION*) ; BEGIN (*EXPRESSION*) SIMPLEEXPRESSION(FSYS + [RELOP]); IF SY = RELOP THEN BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <= POWER THEN LOAD ELSE LOADADDRESS; LATTR := GATTR; LOP := OP; INSYMBOL; SIMPLEEXPRESSION(FSYS); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <= POWER THEN LOAD ELSE LOADADDRESS; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN IF LOP = INOP THEN IF GATTR.TYPTR'.FORM = POWER THEN IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR'.ELSET) THEN GEN0(11(*INN*)) ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END ELSE BEGIN IF LATTR.TYPTR <> GATTR.TYPTR THEN IF LATTR.TYPTR = INTPTR THEN BEGIN GEN0(9(*FLO*)); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LSIZE := LATTR.TYPTR'.SIZE; CASE LATTR.TYPTR'.FORM OF SCALAR: IF LATTR.TYPTR = REALPTR THEN TYPIND := #R# ELSE IF LATTR.TYPTR = BOOLPTR THEN TYPIND := #B# ELSE TYPIND := #I#; 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 := #S# END; ARRAYS: BEGIN IF NOT STRING(LATTR.TYPTR) AND(LOP IN[LTOP,LEOP,GTOP,GEOP])THEN ERROR(131); TYPIND := #M# END; RECORDS: BEGIN IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131); TYPIND := #M# END; FILES: BEGIN ERROR(133); TYPIND := #F# END END; CASE LOP OF LTOP: GEN2(53(*LES*),ORD(TYPIND),LSIZE); LEOP: GEN2(52(*LEQ*),ORD(TYPIND),LSIZE); GTOP: GEN2(49(*GRT*),ORD(TYPIND),LSIZE); GEOP: GEN2(48(*GEQ*),ORD(TYPIND),LSIZE); NEOP: GEN2(55(*NEQ*),ORD(TYPIND),LSIZE); EQOP: GEN2(47(*EQU*),ORD(TYPIND),LSIZE) END END ELSE ERROR(129) END; GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR END (*SY = RELOP*) END (*EXPRESSION*) ; PROCEDURE ASSIGNMENT(FCP: CTP); VAR LATTR: ATTR; BEGIN SELECTOR(FSYS + [BECOMES],FCP); IF SY = BECOMES THEN BEGIN IF GATTR.TYPTR <> NIL THEN IF (GATTR.ACCESS<>DRCT) OR (GATTR.TYPTR'.FORM>POWER) THEN LOADADDRESS; LATTR := GATTR; INSYMBOL; EXPRESSION(FSYS); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <= POWER THEN LOAD ELSE LOADADDRESS; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN BEGIN IF COMPTYPES(REALPTR,LATTR.TYPTR)AND(GATTR.TYPTR=INTPTR)THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN CASE LATTR.TYPTR'.FORM OF SCALAR, SUBRANGE: BEGIN IF DEBUG THEN CHECKBNDS(LATTR.TYPTR); STORE(LATTR) END; POINTER, POWER: STORE(LATTR); ARRAYS, RECORDS: GEN1(40(*MOV*),LATTR.TYPTR'.SIZE); FILES: ERROR(146) END ELSE ERROR(129) END END (*SY = BECOMES*) ELSE ERROR(51) END (*ASSIGNMENT*) ; PROCEDURE GOTOSTATEMENT; VAR LLP: LBP; FOUND: BOOLEAN; TTOP,TTOP1: DISPRANGE; BEGIN IF SY = INTCONST THEN BEGIN FOUND := FALSE; TTOP := TOP; REPEAT WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP - 1; TTOP1 := TTOP; LLP := DISPLAY[TTOP].FLABEL; WHILE (LLP <> NIL) AND NOT FOUND DO WITH LLP' DO IF LABVAL = VAL.IVAL THEN BEGIN FOUND := TRUE; IF TTOP = TTOP1 THEN GENUJPENT(57(*UJP*),LABNAME) ELSE (*GOTO LEADS OUT OF PROCEDURE*) ERROR(399) END ELSE LLP := NEXTLAB; TTOP := TTOP - 1 UNTIL FOUND OR (TTOP = 0); IF NOT FOUND THEN ERROR(167); INSYMBOL END ELSE ERROR(15) END (*GOTOSTATEMENT*) ; 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 INSYMBOL ELSE ERROR(13) END (*COMPOUNDSTATEMENET*) ; PROCEDURE IFSTATEMENT; VAR LCIX1,LCIX2: INTEGER; BEGIN EXPRESSION(FSYS + [THENSY]); GENLABEL(LCIX1); GENFJP(LCIX1); IF SY = THENSY THEN INSYMBOL ELSE ERROR(52); STATEMENT(FSYS + [ELSESY]); IF SY = ELSESY THEN BEGIN GENLABEL(LCIX2); GENUJPENT(57(*UJP*),LCIX2); PUTLABEL(LCIX1); INSYMBOL; STATEMENT(FSYS); PUTLABEL(LCIX2) END ELSE PUTLABEL(LCIX1) END (*IFSTATEMENT*) ; PROCEDURE CASESTATEMENT; LABEL 1; TYPE CIP = 'CASEINFO; CASEINFO = PACKED RECORD NEXT: CIP; CSSTART: INTEGER; CSLAB: INTEGER END; VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU; LADDR, LCIX, LCIX1, LMIN, LMAX: INTEGER; BEGIN EXPRESSION(FSYS + [OFSY,COMMA,COLON]); LOAD; GENLABEL(LCIX); GENUJPENT(57(*UJP*),LCIX); LSP := GATTR.TYPTR; IF LSP <> NIL THEN IF (LSP'.FORM <> SCALAR) OR (LSP = REALPTR) THEN BEGIN ERROR(144); LSP := NIL END; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); FSTPTR := NIL; GENLABEL(LADDR); REPEAT LPT3 := NIL; GENLABEL(LCIX1); IF NOT(SY IN [SEMICOLON,ENDSY]) THEN BEGIN REPEAT CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL); IF LSP <> NIL THEN IF COMPTYPES(LSP,LSP1) THEN BEGIN LPT1 := FSTPTR; LPT2 := NIL; WHILE LPT1 <> NIL DO WITH LPT1' DO BEGIN IF CSLAB <= LVAL.IVAL THEN BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156); GOTO 1 END; LPT2 := LPT1; LPT1 := NEXT END; 1: 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); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); PUTLABEL(LCIX1); REPEAT STATEMENT(FSYS + [SEMICOLON]) UNTIL NOT (SY IN STATBEGSYS); IF LPT3 <> NIL THEN GENUJPENT(57(*UJP*),LADDR); END; TEST := SY <> SEMICOLON; IF NOT TEST THEN INSYMBOL UNTIL TEST; PUTLABEL(LCIX); 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; IF LMAX - LMIN < CIXMAX THEN BEGIN GEN2(45(*CHK*),LMIN,LMAX); GEN2(51(*LDC*),1,LMIN); GEN0(21(*SBI*)); GENLABEL(LCIX); GENUJPENT(44(*XJP*),LCIX); PUTLABEL(LCIX); REPEAT WITH FSTPTR' DO BEGIN WHILE CSLAB > LMIN DO BEGIN GEN2(45(*ERROR CHK*),1,0); LMIN := LMIN+1 END; GENUJPENT(57(*UJP*),CSSTART); FSTPTR := NEXT; LMIN := LMIN + 1 END UNTIL FSTPTR = NIL; PUTLABEL(LADDR) END ELSE ERROR(157) END; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END (*CASESTATEMENT*) ; PROCEDURE REPEATSTATEMENT; VAR LADDR: INTEGER; BEGIN GENLABEL(LADDR); PUTLABEL(LADDR); REPEAT STATEMENT(FSYS + [SEMICOLON,UNTILSY]); IF SY IN STATBEGSYS THEN ERROR(14) UNTIL NOT(SY IN STATBEGSYS); WHILE SY = SEMICOLON DO BEGIN INSYMBOL; REPEAT STATEMENT(FSYS + [SEMICOLON,UNTILSY]); IF SY IN STATBEGSYS THEN ERROR(14) UNTIL NOT (SY IN STATBEGSYS); END; IF SY = UNTILSY THEN BEGIN INSYMBOL; EXPRESSION(FSYS); GENFJP(LADDR) END ELSE ERROR(53) END (*REPEATSTATEMENT*) ; PROCEDURE WHILESTATEMENT; VAR LADDR, LCIX: INTEGER; BEGIN GENLABEL(LADDR); PUTLABEL(LADDR); EXPRESSION(FSYS + [DOSY]); GENLABEL(LCIX); GENFJP(LCIX); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); GENUJPENT(57(*UJP*),LADDR); PUTLABEL(LCIX) END (*WHILESTATEMENT*) ; PROCEDURE FORSTATEMENT; VAR LATTR: ATTR; LSP: STP; LSY: SYMBOL; LCIX, LADDR: INTEGER; BEGIN WITH LATTR DO BEGIN TYPTR := NIL; KIND := VARBL; ACCESS := DRCT; VLEVEL := LEVEL; DPLMT := 0 END; IF SY = IDENT THEN BEGIN SEARCHID([VARS],LCP); WITH LCP', LATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN ERROR(155); TYPTR := NIL END END; IF LATTR.TYPTR <> NIL THEN IF (LATTR.TYPTR'.FORM > SUBRANGE) OR COMPTYPES(REALPTR,LATTR.TYPTR) THEN BEGIN ERROR(143); LATTR.TYPTR := NIL END; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]) END; IF SY = BECOMES THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR'.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LOAD; 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 THEN IF GATTR.TYPTR'.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LOAD; GEN2(56(*STR*),0,LC); GENLABEL(LADDR); PUTLABEL(LADDR); GATTR := LATTR; LOAD; GEN2(54(*LOD*),0,LC); LC := LC + INTSIZE; IF LC > LCMAX THEN LCMAX := LC; IF LSY = TOSY THEN GEN2(52(*LEQ*),ORD(#I#),1) ELSE GEN2(48(*GEQ*),ORD(#I#),1); END ELSE ERROR(145) END ELSE BEGIN ERROR(55); SKIP(FSYS + [DOSY]) END; GENLABEL(LCIX); GENUJPENT(33(*FJP*),LCIX); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); GATTR := LATTR; LOAD; IF LSY = TOSY THEN GEN1(34(*INC*),1) ELSE GEN1(31(*DEC*),1); STORE(LATTR); GENUJPENT(57(*UJP*),LADDR); PUTLABEL(LCIX); LC := LC - INTSIZE END (*FORSTATEMENT*) ; PROCEDURE WITHSTATEMENT; VAR LCP: CTP; LCNT1,LCNT2: DISPRANGE; BEGIN LCNT1 := 0; LCNT2 := 0; 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; LCNT1 := LCNT1 + 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; GEN2(56(*STR*),0,LC); WITH DISPLAY[TOP] DO BEGIN OCCUR := VREC; VDSPL := LC END; LC := LC + PTRSIZE; LCNT2 := LCNT2 + PTRSIZE; IF LC > LCMAX THEN LCMAX := LC 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 := TOP - LCNT1; LC := LC - LCNT2; END (*WITHSTATEMENT*) ; BEGIN (*STATEMENT*) IF SY = INTCONST THEN (*LABEL*) BEGIN LLP := DISPLAY[TOP].FLABEL; WHILE LLP <> NIL DO WITH LLP' DO IF LABVAL = VAL.IVAL THEN BEGIN IF DEFINED THEN ERROR(165); PUTLABEL(LABNAME); DEFINED := TRUE; GOTO 1 END ELSE LLP := NEXTLAB; ERROR(167); 1: 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 CASE SY OF IDENT: BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL; IF LCP'.KLASS = PROC THEN CALL(FSYS,LCP) ELSE ASSIGNMENT(LCP) END; BEGINSY: BEGIN INSYMBOL; COMPOUNDSTATEMENT END; GOTOSY: BEGIN INSYMBOL; GOTOSTATEMENT END; IFSY: BEGIN INSYMBOL; IFSTATEMENT END; CASESY: BEGIN INSYMBOL; CASESTATEMENT END; WHILESY: BEGIN INSYMBOL; WHILESTATEMENT END; REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END; FORSY: BEGIN INSYMBOL; FORSTATEMENT END; WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END END; IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY]) THEN BEGIN ERROR(6); SKIP(FSYS) END END END (*STATEMENT*) ; BEGIN (*BODY*) IF FPROCP <> NIL THEN ENTNAME := FPROCP'.PFNAME ELSE GENLABEL(ENTNAME); CSTPTRIX := 0; PUTLABEL(ENTNAME); GENLABEL(SEGSIZE); GENUJPENT(32(*ENT*),SEGSIZE); IF FPROCP <> NIL THEN (*COPY MULTIPLE VALUES INTO LOACAL CELLS*) BEGIN LLC1 := LCAFTERMARKSTACK; LCP := FPROCP'.NEXT; WHILE LCP <> NIL DO WITH LCP' DO BEGIN IF KLASS = VARS THEN IF IDTYPE <> NIL THEN IF IDTYPE'.FORM > POWER THEN BEGIN IF VKIND = ACTUAL THEN BEGIN GEN2(50(*LDA*),0,VADDR); GEN2(54(*LOD*),0,LLC1); GEN1(40(*MOV*),IDTYPE'.SIZE); END; LLC1 := LLC1 + PTRSIZE END ELSE LLC1 := LLC1 + IDTYPE'.SIZE; LCP := LCP'.NEXT; END; END; LCMAX := LC; 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 INSYMBOL ELSE ERROR(13); LLP := DISPLAY[TOP].FLABEL; (*TEST FOR UNDEFINED LABELS*) WHILE LLP <> NIL DO WITH LLP' DO BEGIN IF NOT DEFINED THEN BEGIN ERROR(168); WRITELN(OUTPUT); WRITELN(OUTPUT,# LABEL #,LABVAL); WRITE(OUTPUT,# #:CHCNT+16) END; LLP := NEXTLAB END; IF FPROCP <> NIL THEN BEGIN IF FPROCP'.IDTYPE = NIL THEN GEN1(42(*RET*),ORD(#P#)) ELSE WITH FPROCP' DO IF IDTYPE = REALPTR THEN GEN1(42(*RET*),ORD(#R#)) ELSE IF IDTYPE = BOOLPTR THEN GEN1(42(*RET*),ORD(#B#)) ELSE IF IDTYPE'.FORM = POINTER THEN GEN1(42(*RET*),ORD(#A#)) ELSE IF (IDTYPE = CHARPTR) OR ((IDTYPE'.FORM = SUBRANGE) AND (IDTYPE'.RANGETYPE = CHARPTR)) THEN GEN1(42(*RET*),ORD(#C#)) ELSE GEN1(42(*RET*),ORD(#I#)); IF PRCODE THEN WRITELN(PRR,#L#,SEGSIZE:4,#=#,LCMAX) END ELSE BEGIN GEN1(42(*RET*),ORD(#P#)); LCMAX := LCMAX - 1; IF PRCODE THEN WRITELN(PRR,#L#,SEGSIZE:4,#=#,LCMAX); IF PRCODE THEN WRITELN(PRR,#Q#); IC := 0; (*GENERATE CALL OF MAIN PROGRAM; NOTE THAT THIS CALL MUST BE LOADED AT ABSOLUTE ADDRESS ZERO*) GEN1(41(*MST*),0); GENCUP(0,ENTNAME); GEN0(29(*STP*)); IF PRCODE THEN WRITELN(PRR,#Q#); SAVEID := ID; WHILE FEXTFILEP <> NIL DO BEGIN WITH FEXTFILEP' DO IF NOT ((FILENAME = #INPUT #) OR (FILENAME = #OUTPUT #) OR (FILENAME = #PRD #) OR (FILENAME = #PRR #)) THEN BEGIN ID := FILENAME; SEARCHID([VARS],LLCP); IF LLCP'.IDTYPE<>NIL THEN IF LLCP'.IDTYPE'.FORM<>FILES THEN BEGIN WRITELN(OUTPUT); WRITELN(OUTPUT,# #:8,#UNDECLARED #,#EXTERNAL #, #FILE#,FEXTFILEP'.FILENAME:8); WRITE(OUTPUT,# #:CHCNT+16) END END; FEXTFILEP := FEXTFILEP'.NEXTFILE END; ID := SAVEID; IF PRTABLES THEN BEGIN WRITELN(OUTPUT); PRINTTABLES(TRUE) END END; END (*BODY*) ; BEGIN (*BLOCK*) 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 SY <> BEGINSY THEN BEGIN ERROR(18); SKIP(FSYS) END UNTIL (SY IN STATBEGSYS) OR EOF(INPUT); DP := FALSE; IF SY = BEGINSY THEN INSYMBOL ELSE ERROR(17); REPEAT BODY(FSYS + [CASESY]); IF SY <> FSY THEN BEGIN ERROR(6); SKIP(FSYS) END UNTIL ((SY = FSY) OR (SY IN BLOCKBEGSYS)) OR EOF(INPUT); END (*BLOCK*) ; PROCEDURE PROGRAMME(FSYS:SETOFSYS); VAR EXTFP:EXTFILEP; BEGIN IF SY = PROGSY THEN BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2); INSYMBOL; IF NOT (SY IN [LPARENT,SEMICOLON]) THEN ERROR(14); IF SY = LPARENT THEN BEGIN REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(EXTFP); WITH EXTFP' DO BEGIN FILENAME := ID; NEXTFILE := FEXTFILEP END; FEXTFILEP := EXTFP; 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; REPEAT BLOCK(FSYS,PERIOD,NIL); IF SY <> PERIOD THEN ERROR(21) UNTIL (SY = PERIOD) OR EOF(INPUT); IF ERRINX <> 0 THEN INSYMBOL END (*PROGRAMME*) ; PROCEDURE STDNAMES; BEGIN NA[ 1] := #FALSE #; NA[ 2] := #TRUE #; NA[ 3] := #INPUT #; NA[ 4] := #OUTPUT #; NA[ 5] := #GET #; NA[ 6] := #PUT #; NA[ 7] := #RESET #; NA[ 8] := #REWRITE #; NA[ 9] := #READ #; NA[10] := #WRITE #; NA[11] := #PACK #; NA[12] := #UNPACK #; NA[13] := #NEW #; NA[14] := #RELEASE #; NA[15] := #READLN #; NA[16] := #WRITELN #; NA[17] := #ABS #; NA[18] := #SQR #; NA[19] := #TRUNC #; NA[20] := #ODD #; NA[21] := #ORD #; NA[22] := #CHR #; NA[23] := #PRED #; NA[24] := #SUCC #; NA[25] := #EOF #; NA[26] := #EOLN #; NA[27] := #SIN #; NA[28] := #COS #; NA[29] := #EXP #; NA[30] := #SQRT #; NA[31] := #LN #; NA[32] := #ARCTAN #; NA[33] := #PRD #; NA[34] := #PRR #; NA[35] := #MARK #; END (*STDNAMES*) ; PROCEDURE ENTERSTDTYPES; VAR SP: STP; BEGIN (*TYPE UNDERLIEING:*) (*******************) NEW(INTPTR); (*INTEGER*) WITH INTPTR' DO BEGIN SIZE := INTSIZE; FORM := SCALAR; SCALKIND := STANDARD END; NEW(REALPTR,SCALAR,STANDARD); (*REAL*) WITH REALPTR' DO BEGIN SIZE := REALSIZE; FORM := SCALAR; SCALKIND := STANDARD END; NEW(CHARPTR,SCALAR,STANDARD); (*CHAR*) WITH CHARPTR' DO BEGIN SIZE := CHARSIZE; FORM := SCALAR; SCALKIND := STANDARD END; NEW(BOOLPTR,SCALAR,DECLARED); (*BOOLEAN*) WITH BOOLPTR' DO BEGIN SIZE := BOOLSIZE; FORM := SCALAR; SCALKIND := DECLARED END; NEW(NILPTR,POINTER); (*NIL*) WITH NILPTR' DO BEGIN ELTYPE := NIL; SIZE := PTRSIZE; FORM := POINTER END; NEW(TEXTPTR,FILES); (*TEXT*) WITH TEXTPTR' DO BEGIN FILTYPE := CHARPTR; SIZE := CHARSIZE; FORM := FILES END END (*ENTERSTDTYPES*) ; PROCEDURE ENTSTDNAMES; VAR CP,CP1: CTP; I: INTEGER; BEGIN (*NAME:*) (*******) NEW(CP,TYPES); (*INTEGER*) WITH CP' DO BEGIN NAME := #INTEGER #; IDTYPE := INTPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); (*REAL*) WITH CP' DO BEGIN NAME := #REAL #; IDTYPE := REALPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); (*CHAR*) WITH CP' DO BEGIN NAME := #CHAR #; IDTYPE := CHARPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); (*BOOLEAN*) WITH CP' DO BEGIN NAME := #BOOLEAN #; IDTYPE := BOOLPTR; KLASS := TYPES END; ENTERID(CP); CP1 := NIL; FOR I := 1 TO 2 DO BEGIN NEW(CP,KONST); (*FALSE,TRUE*) WITH CP' DO BEGIN NAME := NA[I]; IDTYPE := BOOLPTR; NEXT := CP1; VALUES.IVAL := I - 1; KLASS := KONST END; ENTERID(CP); CP1 := CP END; BOOLPTR'.FCONST := CP; NEW(CP,KONST); (*NIL*) WITH CP' DO BEGIN NAME := #NIL #; IDTYPE := NILPTR; NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST END; ENTERID(CP); FOR I := 3 TO 4 DO BEGIN NEW(CP,VARS); (*INPUT,OUTPUT*) WITH CP' DO BEGIN NAME := NA[I]; IDTYPE := TEXTPTR; KLASS := VARS; VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := LCAFTERMARKSTACK + (I-3)*CHARSIZE END; ENTERID(CP) END; FOR I:=33 TO 34 DO BEGIN NEW(CP,VARS); (*PRD,PRR FILES*) WITH CP' DO BEGIN NAME := NA[I]; IDTYPE := TEXTPTR; KLASS := VARS; VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := LCAFTERMARKSTACK + (I-31)*CHARSIZE END; ENTERID(CP) END; FOR I := 5 TO 16 DO BEGIN NEW(CP,PROC,STANDARD); (*GET,PUT,RESET*) WITH CP' DO (*REWRITE,READ*) BEGIN NAME := NA[I]; IDTYPE := NIL; (*WRITE,PACK*) NEXT := NIL; KEY := I - 4; (*UNPACK,PACK*) KLASS := PROC; PFDECKIND := STANDARD END; ENTERID(CP) END; NEW(CP,PROC,STANDARD); WITH CP' DO BEGIN NAME:=NA[35]; IDTYPE:=NIL; NEXT:= NIL; KEY:=13; KLASS:=PROC; PFDECKIND:= STANDARD END; ENTERID(CP); FOR I := 17 TO 26 DO BEGIN NEW(CP,FUNC,STANDARD); (*ABS,SQR,TRUNC*) WITH CP' DO (*ODD,ORD,CHR*) BEGIN NAME := NA[I]; IDTYPE := NIL; (*PRED,SUCC,EOF*) NEXT := NIL; KEY := I - 16; KLASS := FUNC; PFDECKIND := STANDARD END; ENTERID(CP) END; NEW(CP,VARS); (*PARAMETER OF PREDECLARED FUNCTIONS*) WITH CP' DO BEGIN NAME := # #; IDTYPE := REALPTR; KLASS := VARS; VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0 END; FOR I := 27 TO 32 DO BEGIN NEW(CP1,FUNC,DECLARED,ACTUAL); (*SIN,COS,EXP*) WITH CP1' DO (*SQRT,LN,ARCTAN*) BEGIN NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP; FORWDECL := FALSE; EXTERN := TRUE; PFLEV := 0; PFNAME := I - 12; KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL END; ENTERID(CP1) END END (*ENTSTDNAMES*) ; PROCEDURE ENTERUNDECL; BEGIN NEW(UTYPPTR,TYPES); WITH UTYPPTR' DO BEGIN NAME := # #; IDTYPE := NIL; KLASS := TYPES END; NEW(UCSTPTR,KONST); WITH UCSTPTR' DO BEGIN NAME := # #; IDTYPE := NIL; NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST END; NEW(UVARPTR,VARS); WITH UVARPTR' DO BEGIN NAME := # #; IDTYPE := NIL; VKIND := ACTUAL; NEXT := NIL; VLEV := 0; VADDR := 0; KLASS := VARS END; NEW(UFLDPTR,FIELD); WITH UFLDPTR' DO BEGIN NAME := # #; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0; KLASS := FIELD END; NEW(UPRCPTR,PROC,DECLARED,ACTUAL); WITH UPRCPTR' DO BEGIN NAME := # #; IDTYPE := NIL; FORWDECL := FALSE; NEXT := NIL; EXTERN := FALSE; PFLEV := 0; GENLABEL(PFNAME); KLASS := PROC; PFDECKIND := DECLARED; PFKIND := ACTUAL END; NEW(UFCTPTR,FUNC,DECLARED,ACTUAL); WITH UFCTPTR' DO BEGIN NAME := # #; IDTYPE := NIL; NEXT := NIL; FORWDECL := FALSE; EXTERN := FALSE; PFLEV := 0; GENLABEL(PFNAME); KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL END END (*ENTERUNDECL*) ; PROCEDURE INITSCALARS; BEGIN FWPTR := NIL; PRTABLES := FALSE; LIST := TRUE; PRCODE := FALSE; DEBUG := TRUE; DP := TRUE; PRTERR := TRUE; ERRINX := 0; INTLABEL := 0; KK := 8; FEXTFILEP := NIL; LC := LCAFTERMARKSTACK + FILEBUFFER*CHARSIZE; (* NOTE IN THE ABOVE RESERVATION OF BUFFER STORE FOR 2 TEXT FILES *) IC := 3; EOL := TRUE; LINECOUNT := 0; CH := # #; CHCNT := 0; GLOBTESTP := NIL; MXINT10 := MAXINT DIV 10; DIGMAX := STRGLGTH - 1; LINELIMIT(OUTPUT,1000000); LINELIMIT(PRR,1000000); END (*INITSCALARS*) ; PROCEDURE INITSETS; BEGIN CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT]; SIMPTYPEBEGSYS := [LPARENT] + CONSTBEGSYS; TYPEBEGSYS:=[ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY]+SIMPTYPEBEGSYS; TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY]; BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY, BEGINSY]; SELECTSYS := [ARROW,PERIOD,LBRACK]; FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY]; STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY, CASESY]; 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] := #FILE #; RW[22] := #BEGIN #; RW[23] := #UNTIL #; RW[24] := #WHILE #; RW[25] := #ARRAY #; RW[26] := #CONST #; RW[27] := #LABEL #; RW[28] := #REPEAT #; RW[29] := #RECORD #; RW[30] := #DOWNTO #; RW[31] := #PACKED #; RW[32] := #FORWARD #; RW[33] := #PROGRAM #; RW[34] := #FUNCTION#; RW[35] := #PROCEDUR#; FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 22; FRW[6] := 28; FRW[7] := 32; FRW[8] := 34; FRW[9] := 36; END (*RESWORDS*) ; PROCEDURE SYMBOLS; BEGIN RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY; RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY; RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY; RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY; RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY; RSY[19] := CASESY; RSY[20] := TYPESY; RSY[21] := FILESY; RSY[22] := BEGINSY; RSY[23] := UNTILSY; RSY[24] := WHILESY; RSY[25] := ARRAYSY; RSY[26] := CONSTSY; RSY[27] := LABELSY; RSY[28] := REPEATSY; RSY[29] := RECORDSY; RSY[30] := DOWNTOSY; RSY[31] := PACKEDSY; RSY[32] := FORWARDSY; RSY[33] := PROGSY; RSY[34] := FUNCSY; RSY[35] := PROCSY; SSY[#+#] := ADDOP; SSY[#-#] := ADDOP; SSY[#*#] := MULOP; SSY[#/#] := MULOP; SSY[#(#] := LPARENT; SSY[#)#] := RPARENT; SSY[#$#] := OTHERSY; SSY[#=#] := RELOP; SSY[# #] := OTHERSY; SSY[#,#] := COMMA; SSY[#.#] := PERIOD; SSY[####] := OTHERSY; SSY[#[#] := LBRACK; SSY[#]#] := RBRACK; SSY[#:#] := COLON; SSY[#'#] := ARROW; SSY[#<#] := RELOP; SSY[#>#] := RELOP; SSY[#;#] := SEMICOLON; END (*SYMBOLS*) ; PROCEDURE RATORS; VAR I: INTEGER; CH: CHAR; BEGIN FOR I := 1 TO 35 (*NR OF RES WORDS*) DO ROP[I] := NOOP; ROP[5] := INOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[6] := OROP; ROP[13] := ANDOP; FOR CH := #+# TO #;# DO SOP[CH] := NOOP; SOP[#+#] := PLUS; SOP[#-#] := MINUS; SOP[#*#] := MUL; SOP[#/#] := RDIV; SOP[#=#] := EQOP; SOP[#<#] := LTOP; SOP[#>#] := GTOP; END (*RATORS*) ; PROCEDURE PROCMNEMONICS; BEGIN SNA[ 1] :=# GET#; SNA[ 2] :=# PUT#; SNA[ 3] :=# RDI#; SNA[ 4] :=# RDR#; SNA[ 5] :=# RDC#; SNA[ 6] :=# WRI#; SNA[ 7] :=# WRO#; SNA[ 8] :=# WRR#; SNA[ 9] :=# WRC#; SNA[10] :=# WRS#; SNA[11] :=# PAK#; SNA[12] :=# NEW#; SNA[13] :=# RST#; SNA[14] :=# ELN#; SNA[15] :=# SIN#; SNA[16] :=# COS#; SNA[17] :=# EXP#; SNA[18] :=# SQT#; SNA[19] :=# LOG#; SNA[20] :=# ATN#; SNA[21] :=# RLN#; SNA[22] :=# WLN#; SNA[23] :=# SAV#; END (*PROCMNEMONICS*) ; PROCEDURE INSTRMNEMONICS; BEGIN MN[0] :=# ABI#; MN[1] :=# ABR#; MN[2] :=# ADI#; MN[3] :=# ADR#; MN[4] :=# AND#; MN[5] :=# DIF#; MN[6] :=# DVI#; MN[7] :=# DVR#; MN[8] :=# EOF#; MN[9] :=# FLO#; MN[10] :=# FLT#; MN[11] :=# INN#; MN[12] :=# INT#; MN[13] :=# IOR#; MN[14] :=# MOD#; MN[15] :=# MPI#; MN[16] :=# MPR#; MN[17] :=# NGI#; MN[18] :=# NGR#; MN[19] :=# NOT#; MN[20] :=# ODD#; MN[21] :=# SBI#; MN[22] :=# SBR#; MN[23] :=# SGS#; MN[24] :=# SQI#; MN[25] :=# SQR#; MN[26] :=# STO#; MN[27] :=# TRC#; MN[28] :=# UNI#; MN[29] :=# STP#; MN[30] :=# CSP#; MN[31] :=# DEC#; MN[32] :=# ENT#; MN[33] :=# FJP#; MN[34] :=# INC#; MN[35] :=# IND#; MN[36] :=# IXA#; MN[37] :=# LAO#; MN[38] :=# LCA#; MN[39] :=# LDO#; MN[40] :=# MOV#; MN[41] :=# MST#; MN[42] :=# RET#; MN[43] :=# SRO#; MN[44] :=# XJP#; MN[45] :=# CHK#; MN[46] :=# CUP#; MN[47] :=# EQU#; MN[48] :=# GEQ#; MN[49] :=# GRT#; MN[50] :=# LDA#; MN[51] :=# LDC#; MN[52] :=# LEQ#; MN[53] :=# LES#; MN[54] :=# LOD#; MN[55] :=# NEQ#; MN[56] :=# STR#; MN[57] :=# UJP#; END (*INSTRMNEMONICS*) ; PROCEDURE CHARTYPES; VAR I : INTEGER; BEGIN FOR I := 0 TO 63 DO CHARTP[CHR(I)] := ILLEGAL; CHARTP[#A#] := LETTER ; CHARTP[#B#] := LETTER ; CHARTP[#C#] := LETTER ; CHARTP[#D#] := LETTER ; CHARTP[#E#] := LETTER ; CHARTP[#F#] := LETTER ; CHARTP[#G#] := LETTER ; CHARTP[#H#] := LETTER ; CHARTP[#I#] := LETTER ; CHARTP[#J#] := LETTER ; CHARTP[#K#] := LETTER ; CHARTP[#L#] := LETTER ; CHARTP[#M#] := LETTER ; CHARTP[#N#] := LETTER ; CHARTP[#O#] := LETTER ; CHARTP[#P#] := LETTER ; CHARTP[#Q#] := LETTER ; CHARTP[#R#] := LETTER ; CHARTP[#S#] := LETTER ; CHARTP[#T#] := LETTER ; CHARTP[#U#] := LETTER ; CHARTP[#V#] := LETTER ; CHARTP[#W#] := LETTER ; CHARTP[#X#] := LETTER ; CHARTP[#Y#] := LETTER ; CHARTP[#Z#] := LETTER ; CHARTP[#0#] := NUMBER ; CHARTP[#1#] := NUMBER ; CHARTP[#2#] := NUMBER ; CHARTP[#3#] := NUMBER ; CHARTP[#4#] := NUMBER ; CHARTP[#5#] := NUMBER ; CHARTP[#6#] := NUMBER ; CHARTP[#7#] := NUMBER ; CHARTP[#8#] := NUMBER ; CHARTP[#9#] := NUMBER ; CHARTP[#+#] := SPECIAL; CHARTP[#-#] := SPECIAL; CHARTP[#*#] := SPECIAL; CHARTP[#/#] := SPECIAL; CHARTP[#(#] := SPECIAL; CHARTP[#)#] := SPECIAL; CHARTP[#$#] := SPECIAL; CHARTP[#=#] := SPECIAL; CHARTP[# #] := SPECIAL; CHARTP[#,#] := SPECIAL; CHARTP[#.#] := SPECIAL; CHARTP[####] := SPECIAL; CHARTP[#[#] := SPECIAL; CHARTP[#]#] := SPECIAL; CHARTP[#:#] := SPECIAL; CHARTP[#'#] := SPECIAL; CHARTP[#;#] := SPECIAL; CHARTP[#<#] := SPECIAL; CHARTP[#>#] := SPECIAL; ORDINT[#0#] := 0; ORDINT[#1#] := 1; ORDINT[#2#] := 2; ORDINT[#3#] := 3; ORDINT[#4#] := 4; ORDINT[#5#] := 5; ORDINT[#6#] := 6; ORDINT[#7#] := 7; ORDINT[#8#] := 8; ORDINT[#9#] := 9; END; BEGIN (*INITTABLES*) RESWORDS; SYMBOLS; RATORS; INSTRMNEMONICS; PROCMNEMONICS; CHARTYPES; END (*INITTABLES*) ; BEGIN (*INITIALIZE*) (************) INITSCALARS; INITSETS; INITTABLES; (*ENTER STANDARD NAMES AND STANDARD TYPES:*) (******************************************) LEVEL := 0; TOP := 0; WITH DISPLAY[0] DO BEGIN FNAME := NIL; FLABEL := NIL; OCCUR := BLCK END; ENTERSTDTYPES; STDNAMES; ENTSTDNAMES; ENTERUNDECL; TOP := 1; LEVEL := 1; WITH DISPLAY[1] DO BEGIN FNAME := NIL; FLABEL := NIL; OCCUR := BLCK END; (*COMPILE:*) (**********) INSYMBOL; PROGRAMME(BLOCKBEGSYS+STATBEGSYS-[CASESY]); END.