(*$C+,T-,D-,L-*)
(**********************************************
* *
* *
* PORTABLE PASCAL COMPILER *
* ************************ *
* *
* PASCAL P4 *
* *
* *
* 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 = 4;
INTAL = 4;
REALSIZE = 4;
REALAL = 4;
CHARSIZE = 1;
CHARAL = 1;
CHARMAX = 1;
BOOLSIZE = 1;
BOOLAL = 1;
PTRSIZE = 4;
ADRAL = 4;
SETSIZE = 8;
SETAL = 4;
STACKAL = 4;
STACKELSIZE = 8;
STRGLGTH = 16;
SETHIGH = 63;
SETLOW = 0;
ORDMAXCHAR = 63;
ORDMINCHAR = 0;
MAXINT = 2147483647;
LCAFTERMARKSTACK = 24;
FILEAL = CHARAL;
(* STACKELSIZE = MINIMUM SIZE FOR 1 STACKELEMENT
= K*STACKAL
STACKAL = SCM(ALL OTHER AL-CONSTANTS)
CHARMAX = SCM(CHARSIZE,CHARAL)
SCM = SMALLEST COMMON MULTIPLE
LCAFTERMARKSTACK >= 4*PTRSIZE+MAX(X-SIZE)
= K1*STACKELSIZE *)
MAXSTACK = 1;
PARMAL = STACKAL;
PARMSIZE = STACKELSIZE;
RECAL = STACKAL;
FILEBUFFER = 4;
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
(*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:*)
(***********)
PARMPTR,
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..60] OF PACKED ARRAY[1..4] OF CHAR;
SNA: ARRAY [1..23] OF PACKED ARRAY [1..4] OF CHAR;
CDX: ARRAY[0..60] OF -4..+4;
PDX: ARRAY[1..23] OF -7..+7;
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;
' ': 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*) ;
FUNCTION ALIGNQUOT(FSP: STP): INTEGER;
BEGIN
ALIGNQUOT := 1;
IF FSP <> NIL THEN
WITH FSP^ DO
CASE FORM OF
SCALAR: IF FSP=INTPTR THEN ALIGNQUOT := INTAL
ELSE IF FSP=BOOLPTR THEN ALIGNQUOT := BOOLAL
ELSE IF SCALKIND=DECLARED THEN ALIGNQUOT := INTAL
ELSE IF FSP=CHARPTR THEN ALIGNQUOT := CHARAL
ELSE IF FSP=REALPTR THEN ALIGNQUOT := REALAL
ELSE (*PARMPTR*) ALIGNQUOT := PARMAL;
SUBRANGE: ALIGNQUOT := ALIGNQUOT(RANGETYPE);
POINTER: ALIGNQUOT := ADRAL;
POWER: ALIGNQUOT := SETAL;
FILES: ALIGNQUOT := FILEAL;
ARRAYS: ALIGNQUOT := ALIGNQUOT(AELTYPE);
RECORDS: ALIGNQUOT := RECAL;
VARIANT,TAGFLD: ERROR(501)
END
END (*ALIGNQUOT*);
PROCEDURE ALIGN(FSP: STP; VAR FLC: INTEGER);
VAR K,L: INTEGER;
BEGIN
K := ALIGNQUOT(FSP);
L := FLC-1;
FLC := L+K-(K+L) MOD K
END (*ALIGN*);
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 ALIGN(LSP,DISPL);
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 ALIGN(LSP1,DISPL);
LCP^.FLDADDR := DISPL;
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);
ALIGN(LSP,LSIZE);
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 ALIGN(LSP,LC);
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: ADDRRANGE; COUNT,LSIZE: 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;
ALIGN(PARMPTR,LC);
(*LC := LC + SOME SIZE *)
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;
ALIGN(PARMPTR,LC);
(*LC := LC + SOME SIZE*)
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;
LSIZE := PTRSIZE;
IF LSP <> NIL THEN
IF LKIND=ACTUAL THEN
IF LSP^.FORM<=POWER THEN LSIZE := LSP^.SIZE
ELSE IF LSP^.FORM=FILES THEN ERROR(121);
ALIGN(PARMPTR,LSIZE);
LCP3 := LCP2;
ALIGN(PARMPTR,LC);
LC := LC+COUNT*LSIZE;
LLC := LC;
WHILE LCP2 <> NIL DO
BEGIN LCP := LCP2;
WITH LCP2^ DO
BEGIN IDTYPE := LSP;
LLC := LLC-LSIZE;
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^.FORM>POWER) THEN
BEGIN ALIGN(IDTYPE,LC);
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; MARK(MARKP);
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;
STACKTOP, TOPNEW, TOPMAX: INTEGER;
LCMAX,LLC1: ADDRRANGE; LCP: CTP;
LLP: LBP;
PROCEDURE MES(I: INTEGER);
BEGIN TOPNEW := TOPNEW + CDX[I]*MAXSTACK;
IF TOPNEW > TOPMAX THEN TOPMAX := TOPNEW
END;
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; MES(FOP)
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
BEGIN WRITELN(PRR,SNA[FP2]:12);
TOPNEW := TOPNEW + PDX[FP2]*MAXSTACK;
IF TOPNEW > TOPMAX THEN TOPMAX := TOPNEW
END
ELSE
BEGIN
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);
MES(FOP)
END
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');
6: WRITELN(PRR,'C ''':3,CHR(FP2),'''');
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; MES(FOP)
END (*GEN2*) ;
PROCEDURE GENTYPINDICATOR(FSP: STP);
BEGIN
IF FSP<>NIL THEN
WITH FSP^ DO
CASE FORM OF
SCALAR: IF FSP=INTPTR THEN WRITE(PRR,'I')
ELSE
IF FSP=BOOLPTR THEN WRITE(PRR,'B')
ELSE
IF FSP=CHARPTR THEN WRITE(PRR,'C')
ELSE
IF SCALKIND = DECLARED THEN WRITE(PRR,'I')
ELSE WRITE(PRR,'R');
SUBRANGE: GENTYPINDICATOR(RANGETYPE);
POINTER: WRITE(PRR,'A');
POWER: WRITE(PRR,'S');
RECORDS,ARRAYS: WRITE(PRR,'M');
FILES,TAGFLD,VARIANT: ERROR(500)
END
END (*TYPINDICATOR*);
PROCEDURE GEN0T(FOP: OPRANGE; FSP: STP);
BEGIN
IF PRCODE THEN
BEGIN PUTIC;
WRITE(PRR,MN[FOP]:4);
GENTYPINDICATOR(FSP);
WRITELN(PRR);
END;
IC := IC + 1; MES(FOP)
END (*GEN0T*);
PROCEDURE GEN1T(FOP: OPRANGE; FP2: INTEGER; FSP: STP);
BEGIN
IF PRCODE THEN
BEGIN PUTIC;
WRITE(PRR,MN[FOP]:4);
GENTYPINDICATOR(FSP);
WRITELN(PRR,FP2:11)
END;
IC := IC + 1; MES(FOP)
END (*GEN1T*);
PROCEDURE GEN2T(FOP: OPRANGE; FP1,FP2: INTEGER; FSP: STP);
BEGIN
IF PRCODE THEN
BEGIN PUTIC;
WRITE(PRR,MN[FOP]: 4);
GENTYPINDICATOR(FSP);
WRITELN(PRR,FP1:3,FP2:8);
END;
IC := IC + 1; MES(FOP)
END (*GEN2T*);
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*),6,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
GEN1T(39(*LDO*),DPLMT,TYPTR)
ELSE GEN2T(54(*LOD*),LEVEL-VLEVEL,DPLMT,TYPTR);
INDRCT: GEN1T(35(*IND*),IDPLMT,TYPTR);
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 GEN1T(43(*SRO*),DPLMT,TYPTR)
ELSE GEN2T(56(*STR*),LEVEL-VLEVEL,DPLMT,TYPTR);
INDRCT: IF IDPLMT <> 0 THEN ERROR(400)
ELSE GEN0T(26(*STO*),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
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
GEN1T(34(*INC*),IDPLMT,NILPTR);
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; MES(33)
END (*GENFJP*) ;
PROCEDURE GENUJPXJP(FOP: OPRANGE; FP2: INTEGER);
BEGIN
IF PRCODE THEN
BEGIN PUTIC; WRITELN(PRR, MN[FOP]:4, ' L':8,FP2:4) END;
IC := IC + 1; MES(FOP)
END (*GENUJPENT*);
PROCEDURE GENCUPENT(FOP: OPRANGE; FP1,FP2: INTEGER);
BEGIN
IF PRCODE THEN
BEGIN PUTIC;
WRITELN(PRR,MN[FOP]:4,FP1:4,'L':4,FP2:4)
END;
IC := IC + 1; MES(FOP)
END;
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);
GEN2T(45(*CHK*),LMIN,LMAX,FSP)
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; LSIZE,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 GEN2T(54(*LOD*),LEVEL-VLEV,VADDR,NILPTR);
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 GEN1T(39(*LOD*),VDSPL,NILPTR)
ELSE GEN2T(54(*LOD*),0,VDSPL,NILPTR);
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)
ELSE IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN
GEN0T(58(*ORD*),GATTR.TYPTR);
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
GEN2T(45(*CHK*),LMIN,LMAX,INTPTR);
IF LMIN>0 THEN GEN1T(31(*DEC*),LMIN,INTPTR)
ELSE IF LMIN<0 THEN
GEN1T(34(*INC*),-LMIN,INTPTR);
(*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
BEGIN
LSIZE := GATTR.TYPTR^.SIZE;
ALIGN(GATTR.TYPTR,LSIZE);
GEN1(36(*IXA*),LSIZE)
END
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; TYPTR := ELTYPE;
IF DEBUG THEN GEN2T(45(*CHK*),1,MAXADDR,NILPTR);
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 + CHARMAX;
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 CHARMAX;
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);
GEN0T(58(*ORD*),GATTR.TYPTR);
GATTR.TYPTR := INTPTR
END (*ORD*) ;
PROCEDURE CHR;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
GEN0(59(*CHR*));
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 GEN1T(31(*DEC*),1,GATTR.TYPTR)
ELSE GEN1T(34(*INC*),1,GATTR.TYPTR)
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^.FORM <= POWER 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;
ALIGN(PARMPTR,LOCPAR);
END
ELSE
BEGIN
LOADADDRESS;
LOCPAR := LOCPAR+PTRSIZE;
ALIGN(PARMPTR,LOCPAR)
END
ELSE
IF GATTR.KIND = VARBL THEN
BEGIN LOADADDRESS;
LOCPAR := LOCPAR+PTRSIZE;
ALIGN(PARMPTR,LOCPAR);
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 GENCUPENT(46(*CUP*),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 := 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
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;
IF NOT COMPTYPES(GATTR.TYPTR,INTPTR)
THEN GEN0T(58(*ORD*),GATTR.TYPTR);
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;
IF LOP = INOP THEN
IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN
GEN0T(58(*ORD*),GATTR.TYPTR);
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
IF LATTR.TYPTR = CHARPTR THEN TYPIND := 'C'
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: BEGIN
IF DEBUG THEN
GEN2T(45(*CHK*),0,MAXADDR,NILPTR);
STORE(LATTR)
END;
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
GENUJPXJP(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); GENUJPXJP(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);
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
IF (LSP^.FORM <> SCALAR) OR (LSP = REALPTR) THEN
BEGIN ERROR(144); LSP := NIL END
ELSE IF NOT COMPTYPES(LSP,INTPTR) THEN GEN0T(58(*ORD*),LSP);
GENUJPXJP(57(*UJP*),LCIX);
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
GENUJPXJP(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
GEN2T(45(*CHK*),LMIN,LMAX,INTPTR);
GEN2(51(*LDC*),1,LMIN); GEN0(21(*SBI*)); GENLABEL(LCIX);
GENUJPXJP(44(*XJP*),LCIX); PUTLABEL(LCIX);
REPEAT
WITH FSTPTR^ DO
BEGIN
WHILE CSLAB > LMIN DO
BEGIN GEN0(60(*UJC ERROR*));
LMIN := LMIN+1
END;
GENUJPXJP(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); GENUJPXJP(57(*IJP*),LADDR); PUTLABEL(LCIX)
END (*WHILESTATEMENT*) ;
PROCEDURE FORSTATEMENT;
VAR LATTR: ATTR; LSP: STP; LSY: SYMBOL;
LCIX, LADDR: INTEGER;
LLC: ADDRRANGE;
BEGIN LLC := LC;
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;
IF NOT COMPTYPES(LATTR.TYPTR,INTPTR) THEN
GEN0T(58(*ORD*),GATTR.TYPTR);
ALIGN(INTPTR,LC);
GEN2T(56(*STR*),0,LC,INTPTR);
GENLABEL(LADDR); PUTLABEL(LADDR);
GATTR := LATTR; LOAD;
IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN
GEN0T(58(*ORD*),GATTR.TYPTR);
GEN2T(54(*LOD*),0,LC,INTPTR);
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); GENUJPXJP(33(*FJP*),LCIX);
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS);
GATTR := LATTR; LOAD;
IF LSY=TOSY THEN GEN1T(34(*INC*),1,GATTR.TYPTR)
ELSE GEN1T(31(*DEC*),1,GATTR.TYPTR);
STORE(LATTR); GENUJPXJP(57(*UJP*),LADDR); PUTLABEL(LCIX);
LC := LLC;
END (*FORSTATEMENT*) ;
PROCEDURE WITHSTATEMENT;
VAR LCP: CTP; LCNT1: DISPRANGE; LLC: ADDRRANGE;
BEGIN LCNT1 := 0; LLC := LC;
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;
ALIGN(NILPTR,LC);
GEN2T(56(*STR*),0,LC,NILPTR);
WITH DISPLAY[TOP] DO
BEGIN OCCUR := VREC; VDSPL := LC END;
LC := LC+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 := LLC;
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;
TOPNEW := LCAFTERMARKSTACK;
TOPMAX := LCAFTERMARKSTACK;
PUTLABEL(ENTNAME); GENLABEL(SEGSIZE); GENLABEL(STACKTOP);
GENCUPENT(32(*ENT1*),1,SEGSIZE); GENCUPENT(32(*ENT2*),2,STACKTOP);
IF FPROCP <> NIL THEN (*COPY MULTIPLE VALUES INTO LOACAL CELLS*)
BEGIN LLC1 := LCAFTERMARKSTACK;
LCP := FPROCP^.NEXT;
WHILE LCP <> NIL DO
WITH LCP^ DO
BEGIN
ALIGN(PARMPTR,LLC1);
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
IF IDTYPE^.FORM > POWER THEN
BEGIN
IF VKIND = ACTUAL THEN
BEGIN
GEN2(50(*LDA*),0,VADDR);
GEN2T(54(*LOD*),0,LLC1,NILPTR);
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 GEN0T(42(*RET*),FPROCP^.IDTYPE);
ALIGN(PARMPTR,LCMAX);
IF PRCODE THEN
BEGIN WRITELN(PRR,'L',SEGSIZE:4,'=',LCMAX);
WRITELN(PRR,'L',STACKTOP:4,'=',TOPMAX)
END
END
ELSE
BEGIN GEN1(42(*RET*),ORD('P'));
ALIGN(PARMPTR,LCMAX);
IF PRCODE THEN
BEGIN WRITELN(PRR,'L',SEGSIZE:4,'=',LCMAX);
WRITELN(PRR,'L',STACKTOP:4,'=',TOPMAX);
WRITELN(PRR,'Q')
END;
IC := 0;
(*GENERATE CALL OF MAIN PROGRAM; NOTE THAT THIS CALL MUST BE LOADED
AT ABSOLUTE ADDRESS ZERO*)
GEN1(41(*MST*),0); GENCUPENT(46(*CUP*),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,SCALAR,STANDARD); (*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(PARMPTR,SCALAR,STANDARD); (*FOR ALIGNMENT OF PARAMETERS*)
WITH PARMPTR^ DO
BEGIN SIZE := PARMSIZE; FORM := SCALAR; SCALKIND := STANDARD 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)*CHARMAX;
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)*CHARMAX;
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*CHARMAX;
(* 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;
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 I := ORDMINCHAR TO ORDMAXCHAR DO SOP[CHR(I)] := 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'; MN[58] :=' ORD'; MN[59] :=' CHR';
MN[60] :=' UJC';
END (*INSTRMNEMONICS*) ;
PROCEDURE CHARTYPES;
VAR I : INTEGER;
BEGIN
FOR I := ORDMINCHAR TO ORDMAXCHAR 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;
PROCEDURE INITDX;
BEGIN
CDX[ 0] := 0; CDX[ 1] := 0; CDX[ 2] := -1; CDX[ 3] := -1;
CDX[ 4] := -1; CDX[ 5] := -1; CDX[ 6] := -1; CDX[ 7] := -1;
CDX[ 8] := 0; CDX[ 9] := 0; CDX[10] := 0; CDX[11] := -1;
CDX[12] := -1; CDX[13] := -1; CDX[14] := -1; CDX[15] := -1;
CDX[16] := -1; CDX[17] := 0; CDX[18] := 0; CDX[19] := 0;
CDX[20] := 0; CDX[21] := -1; CDX[22] := -1; CDX[23] := 0;
CDX[24] := 0; CDX[25] := 0; CDX[26] := -2; CDX[27] := 0;
CDX[28] := -1; CDX[29] := 0; CDX[30] := 0; CDX[31] := 0;
CDX[32] := 0; CDX[33] := -1; CDX[34] := 0; CDX[35] := 0;
CDX[36] := -1; CDX[37] := +1; CDX[38] := +1; CDX[39] := +1;
CDX[40] := -2; CDX[41] := 0; CDX[42] := 0; CDX[43] := -1;
CDX[44] := -1; CDX[45] := 0; CDX[46] := 0; CDX[47] := -1;
CDX[48] := -1; CDX[49] := -1; CDX[50] := +1; CDX[51] := +1;
CDX[52] := -1; CDX[53] := -1; CDX[54] := +1; CDX[55] := -1;
CDX[56] := -1; CDX[57] := 0; CDX[58] := 0; CDX[59] := 0;
CDX[60] := 0;
PDX[ 1] := -1; PDX[ 2] := -1; PDX[ 3] := -2; PDX[ 4] := -2;
PDX[ 5] := -2; PDX[ 6] := -3; PDX[ 7] := -3; PDX[ 8] := -3;
PDX[ 9] := -3; PDX[10] := -4; PDX[11] := 0; PDX[12] := -2;
PDX[13] := -1; PDX[14] := 0; PDX[15] := 0; PDX[16] := 0;
PDX[17] := 0; PDX[18] := 0; PDX[19] := 0; PDX[20] := 0;
PDX[21] := -1; PDX[22] := -1; PDX[23] := -1;
END;
BEGIN (*INITTABLES*)
RESWORDS; SYMBOLS; RATORS;
INSTRMNEMONICS; PROCMNEMONICS;
CHARTYPES; INITDX;
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.
S2)W=