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=INDRCT) 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
COMPTYPES(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 CHECKNEEDED(LATTR.TYPTR,GATTR.TYPTR)
THEN CHECKBNDS(LATTR.TYPTR);
STORE(LATTR)
END;
POINTER: BEGIN
IF PTRCHECKS AND INITCHECKS 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; LLAB: INTEGER;
BEGIN
IF SY = INTCONST THEN
BEGIN
FOUND := FALSE;
TTOP := TOP;
WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP - 1; (*PUG*)
TTOP1 := TTOP; (*PUG*)
REPEAT
LLP := DISPLAY[TTOP].FLABEL; (*PUG*)
WHILE (LLP <> NIL) AND NOT FOUND DO
WITH LLP^ DO
IF LABVAL = VAL.IVAL THEN
BEGIN FOUND := TRUE;
IF TTOP = TTOP1 THEN BEGIN
GENUJPXJP(57(*UJP*),LABNAME); GENLABEL(LLAB);
PUTLABEL (LLAB) END
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 BEGIN
BEGINLEVEL := BEGINLEVEL - 1; INSYMBOL END
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;
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
IF (LSP^.FORM > SUBRANGE) OR (LSP = REALPTR) THEN
BEGIN ERROR(144); LSP := NIL END;
GENLABEL(LCIX);
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);
GEN1T(51(*LDC*),LMIN,INTPTR); GEN0(21(*SBI*)); GENLABEL(LCIX);
GENUJPXJP(44(*XJP*),LCIX); PUTLABEL(LCIX);
REPEAT
WITH FSTPTR^ DO
BEGIN
IF PRCODE THEN BEGIN
WHILE CSLAB > LMIN DO
BEGIN GENLABEL(LCIX);
WRITELN(PRR,LCIX:5,' GOTO 99998');
LMIN := LMIN+1; IC := IC + 1
END;
GENLABEL(LCIX);
WRITELN (PRR, LCIX:5, ' GOTO ', CSSTART:1);
LMIN := LMIN + 1; IC := IC + 1 END;
FSTPTR := NEXT
END
UNTIL FSTPTR = NIL;
PUTLABEL(LADDR)
END
ELSE ERROR(157)
END;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END (*CASESTATEMENT*) ;
PROCEDURE PUTLINENO;
(* Prints the line numbers of corresponding source code *)
(* lines preceding blocks of Fortran code generated. *)
BEGIN
IF LASTLINENO <> LINECOUNT THEN BEGIN
WRITELN (PRR, ' ':6, 'LINENO = ', LINECOUNT:1);
IC := IC + 1;
LASTLINENO := LINECOUNT;
END
END (* PUTLINENO *);
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;
PUTLINENO;
EXPRESSION(FSYS); GENFJP(LADDR)
END
ELSE ERROR(53)
END (*REPEATSTATEMENT*) ;
PROCEDURE WHILESTATEMENT;
VAR LADDR, LCIX: INTEGER;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
WRITELN (PRR, ' ':6, 'LINENO = ', LINECOUNT:1); IC := IC + 1;
EXPRESSION(FSYS + [DOSY]); GENLABEL(LCIX); GENFJP(LCIX);
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS); GENUJPXJP(57(*UJP*),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 > SUBRANGE 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 > SUBRANGE THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LOAD;
GEN2T(56(*STR*),0,LC,GATTR.TYPTR);
GENLABEL(LADDR); PUTLABEL(LADDR);
GATTR := LATTR; LOAD;
GEN2T(54(*LOD*),0,LC,GATTR.TYPTR);
LC := LC + GATTR.TYPTR^.SIZE;
IF LC > LCMAX THEN LCMAX := LC;
IF LSY = TOSY THEN GEN1 (52 (*LEQ*), 1)
ELSE GEN1 (48 (*GEQ*), 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*)
FILELOAD := TRUE; (* indicates file address has been loaded *)
(* this value is set to FALSE initially by those procedures *)
(* which require the use of a file variable. It is used to *)
(* tell procedure SELECTOR whether the address of a file *)
(* variable must be loaded onto the stack at that time. *)
IF SY = INTCONST THEN (*LABEL*)
BEGIN LLP := DISPLAY[LEVEL].FLABEL; (*PUG*)
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
PUTLINENO;
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 BEGINLEVEL := BEGINLEVEL + 1;
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 BEGIN (* generate code for subroutine *)
ENTNAME := FPROCP^.PFNAME;
IF PRCODE THEN BEGIN
WRITELN (PRR);
WRITELN (PRR, ' ':6, 'SUBROUTINE P', ENTNAME:1);
IC := IC + 2
END
END
ELSE BEGIN (* generate code for MAIN program *)
GENLABEL (ENTNAME);
IF PRCODE THEN BEGIN
WRITELN (PRR);
WRITELN (PRR, ' ':6, 'SUBROUTINE P$MAI', 'N');
IC := IC + 2
END
END;
IF FORTFUNC <> NIL THEN (* look for fortran functions at *)
(* this level *)
WHILE ((FORTFUNC <> NIL) AND (FORTFUNC^.PFLEV = LEVEL)) DO
BEGIN
IF PRCODE THEN
BEGIN
IF FORTFUNC^.IDTYPE = INTPTR THEN
WRITELN (PRR, ' ':6, 'INTEGER*4 ', FORTFUNC^.NAME:6)
ELSE IF FORTFUNC^.IDTYPE = REALPTR THEN
WRITELN (PRR, ' ':6, 'REAL ', FORTFUNC^.NAME:6);
IC := IC + 1
END;
FORTFUNC := FORTFUNC^.NEXTFFUNC
END;
IF PRCODE THEN GENCREG; (* generate definitions (creg) *)
TOPNEW := 5; TOPMAX := 5;
GENLABEL(SEGSIZE); GENLABEL(STACKTOP);
IF PRCODE THEN BEGIN
IF TRACEOPT THEN BEGIN
WRITE (PRR, ' ':6, 'CALL T$TRAC(1,''');
IF FPROCP <> NIL THEN
WRITE (PRR, FPROCP^.NAME:8)
ELSE
WRITE (PRR, 'OUTER BLOCK');
WRITELN (PRR, '.'')'); IC := IC + 1
END;
WRITELN(PRR,' ':6, 'GOTO ',SEGSIZE:1);
WRITELN (PRR, '99998 CALL P$UJC'); IC := IC + 2 END;
PUTLABEL(STACKTOP);
IF PRCODE THEN BEGIN WRITELN(PRR,' ':6, 'CALL',' P$ENT(1,SG1SIZ)');
WRITELN(PRR,' ':6, 'CALL',' P$ENT(2,SG2SIZ)'); IC := IC + 2 END;
TMPTR := DISPLAY[TOP].FFILE;
WHILE TMPTR <> NIL DO (* initialize all files for this level *)
BEGIN IC := IC + 2;
IF TMPTR^.FLEV <= 1 THEN GEN1(37(*LAO*),TMPTR^.FADDR)
ELSE GEN2(50(*LDA*),LEVEL-TMPTR^.FLEV,TMPTR^.FADDR);
GEN0(65(*INF*));
TMPTR := TMPTR^.LNK
END;
IF FPROCP <> NIL THEN (*COPY MULTIPLE VALUES INTO LOACAL CELLS*)
BEGIN LLC1 := LCAFTERMARKSTACK;
LCP := FPROCP^.NEXT;
WHILE LCP <> NIL DO
WITH LCP^ DO
BEGIN
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
IF (VKIND=ACTUAL) AND (IDTYPE^.FORM>POWER) THEN
BEGIN
GEN2(50(*LDA*),0,VADDR);
GEN2T(54(*LOD*),0,LLC1,NILPTR);
GEN1(40(*MOV*),IDTYPE^.SIZE);
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 BEGIN
BEGINLEVEL := BEGINLEVEL - 1; INSYMBOL END
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+20)
END;
LLP := NEXTLAB
END;
TMPTR := DISPLAY[TOP].FFILE;
WHILE TMPTR <> NIL DO
(* go down open-file list, producing code to close each file *)
BEGIN
IF TMPTR^.FLEV <= 1 THEN GEN1(37(*LAO*),TMPTR^.FADDR)
ELSE GEN2(50(*LDA*),LEVEL-TMPTR^.FLEV,TMPTR^.FADDR);
IF TMPTR^.TYP THEN GEN0(63(*P$CLS*))
ELSE BEGIN IC := IC + 1;
WRITE(PRR, ' ':6, 'CALL', MN[64], '(', TMPTR^.AFLG:1, ',''');
FOR I := 1 TO 8 DO WRITE(PRR, TMPTR^.FNAME[I]);
WRITELN(PRR, ';'')')
END;
TMPTR := TMPTR^.LNK
END;
DISPLAY[TOP].FFILE := NIL;
IF FPROCP <> NIL THEN (* generate return from routine *)
BEGIN
IF FPROCP^.IDTYPE = NIL THEN GEN1(42(*RET*),0)
ELSE GEN1(42(*RET*), 1);
ALIGN(PARMPTR,LCMAX);
IF PRCODE THEN BEGIN
IF TRACEOPT THEN BEGIN
WRITELN (PRR, ' ':6, 'CALL T$TRAC(2,0)');
IC := IC + 1
END;
WRITELN (PRR, ' ':6, 'RETURN');
PUTLABEL(SEGSIZE);
WRITELN(PRR,' ':6, 'SG1SIZ = ',LCMAX:1);
WRITELN(PRR,' ':6, 'SG2SIZ = ',TOPMAX:1);
WRITELN(PRR,' ':6, 'GOTO ',STACKTOP:1);
WRITELN (PRR, ' ':6, 'END'); IC := IC + 5
END
END
ELSE
BEGIN GEN1(42(*RET*),0);
ALIGN(PARMPTR,LCMAX);
IF PRCODE THEN
BEGIN
IF TRACEOPT THEN BEGIN
WRITELN (PRR, ' ':6, 'CALL T$TRAC(2,0)');
IC := IC + 1
END;
WRITELN (PRR, ' ':6, 'RETURN');
PUTLABEL(SEGSIZE);
WRITELN(PRR,' ':6, 'SG1SIZ = ',LCMAX:1);
WRITELN(PRR,' ':6, 'SG2SIZ = ',TOPMAX:1);
WRITELN(PRR,' ':6, 'GOTO ',STACKTOP:1);
WRITELN(PRR,' ':6, 'END'); IC := IC + 5
END;
SAVEID := ID;
WHILE FEXTFILEP <> NIL DO
BEGIN FILDEC := TRUE;
WITH FEXTFILEP^ DO
BEGIN ID := FILENAME; PRTERR := FALSE;
SEARCHID([VARS],LLCP);
IF LLCP = NIL THEN FILDEC := FALSE
ELSE IF LLCP^.IDTYPE = NIL THEN FILDEC := FALSE
ELSE IF LLCP^.IDTYPE^.FORM <> FILES THEN FILDEC := FALSE;
IF NOT FILDEC THEN
BEGIN WRITELN(OUTPUT);
WRITELN(OUTPUT,' ***** ','UNDECLARED ','EXTERNAL ',
'FILE',FEXTFILEP^.FILENAME:9);
WRITE(OUTPUT,' ':CHCNT+20)
END
END;
FEXTFILEP := FEXTFILEP^.NEXTFILE
END;
ID := SAVEID
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 BEGIN
BEGINLEVEL := BEGINLEVEL + 1; INSYMBOL END
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);
(* parses program heading, calls BLOCK repeatedly *)
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
IF ID = 'INPUT ' THEN INPFLG := TRUE
ELSE IF ID = 'OUTPUT ' THEN OUTFLG := TRUE
ELSE IF ID = 'PRR ' THEN PRRFLG := TRUE
ELSE IF ID = 'KEYBOARD' THEN KBDFLG := TRUE
ELSE BEGIN NEW(EXTFP);
EXTFP^.FILENAME := ID;
EXTFP^.NEXTFILE := FEXTFILEP;
FEXTFILEP := EXTFP
END;
INSYMBOL;
IF NOT (SY IN [COMMA,RPARENT]) THEN ERROR(20)
END
ELSE ERROR(2)
UNTIL SY <> COMMA;
IF SY <> RPARENT THEN ERROR(4);
INSYMBOL
END;
IF SY <> SEMICOLON THEN ERROR(14)
ELSE INSYMBOL;
END;
REPEAT BLOCK(FSYS,PERIOD,NIL);
IF SY <> PERIOD THEN ERROR(21)
UNTIL (SY = PERIOD) OR EOF(INPUT);
IF LIST THEN WRITELN(OUTPUT); (*PUG*)
IF ERRINX > 0 THEN (*PUG*)
BEGIN LIST := FALSE; ENDOFLINE END (*PUG*)
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] := 'PAGE '; NA[18] := 'ABS ';
NA[19] := 'SQR '; NA[20] := 'TRUNC '; NA[21] := 'ODD ';
NA[22] := 'ORD '; NA[23] := 'CHR '; NA[24] := 'PRED ';
NA[25] := 'SUCC '; NA[26] := 'EOF '; NA[27] := 'EOLN ';
NA[28] := 'SIN '; NA[29] := 'COS '; NA[30] := 'EXP ';
NA[31] := 'SQRT '; NA[32] := 'LN '; NA[33] := 'ARCTAN ';
NA[34] := 'KEYBOARD'; NA[35] := 'PRR '; NA[36] := 'MARK ';
NA[37] := 'TIME '; NA[38] := 'DATE ';
END (*STDNAMES*) ;
PROCEDURE ENTERSTDTYPES;
(* allocates a STRUCTURE node which details structure form *)
(* for each standard type *)
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+1; 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);
NEW(CP,TYPES); (*TEXT*)
WITH CP^ DO
BEGIN NAME := 'TEXT '; IDTYPE := TEXTPTR; 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);
NEW(CP,KONST); (*MAXINT*)
WITH CP^ DO
BEGIN NAME := 'MAXINT '; IDTYPE := INTPTR; KLASS := KONST;
VALUES.IVAL := MAXINT; NEXT := NIL
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*2;
(* note that two locations are reserved for each textfile *)
END;
ENTERID(CP)
END;
FOR I := 34 TO 35 DO
BEGIN NEW(CP,VARS); (*KEYBOARD,PRR FILES*)
WITH CP^ DO
BEGIN NAME := NA[I]; IDTYPE := TEXTPTR; KLASS := VARS;
VKIND := ACTUAL; NEXT := NIL; VLEV := 1;
VADDR := LCAFTERMARKSTACK+(I-32)*CHARMAX*2;
END;
ENTERID(CP)
END;
FOR I := 37 TO 38 DO (*TIME,DATE*)
BEGIN NEW(CP,PROC,STANDARD);
WITH CP^ DO
BEGIN NAME := NA[I]; IDTYPE := NIL;
NEXT := NIL; KEY := I - 22; KLASS := PROC;
PFDECKIND := STANDARD
END;
ENTERID(CP)
END;
FOR I := 5 TO 17 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 (*WRITELN,READLN*)
END; (*PAGE*)
ENTERID(CP)
END;
NEW(CP,PROC,STANDARD);
WITH CP^ DO
BEGIN NAME:=NA[36]; IDTYPE:=NIL;
NEXT:= NIL; KEY:=14;
KLASS:=PROC; PFDECKIND:= STANDARD
END; ENTERID(CP);
FOR I := 18 TO 27 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 - 17;
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 := 28 TO 33 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; EXTDECL := TRUE; PFLEV := 0; PFNAME := I - 13;
FORTDECL := FALSE;
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;
FORTDECL := FALSE;
NEXT := NIL; EXTDECL := 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;
FORTDECL := FALSE;
FORWDECL := FALSE; EXTDECL := FALSE; PFLEV := 0; GENLABEL(PFNAME);
KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END
END (*ENTERUNDECL*) ;
PROCEDURE INITSCALARS;
VAR I: INTEGER;
BEGIN
TRACEOPT := FALSE; (* compiler options defaults *)
PRTABLES := FALSE;
LIST := TRUE;
PRCODE := TRUE;
COMPCODE := FALSE;
RANGECHECKS := TRUE;
INITCHECKS := FALSE;
PTRCHECKS := TRUE;
INPFLG := FALSE; OUTFLG := FALSE; (* file flags *)
KBDFLG := FALSE; PRRFLG := FALSE;
STRGINDEX := 0;
SETINDEX := 0;
BEGINLEVEL := 0; LINENUMBER := 0; PAGENUMBER := 0;
LASTLINENO := 0;
DP := TRUE; PRTERR := TRUE; ERRINX := 0;
FWPTR := NIL;
INTLABEL := 0; FEXTFILEP := NIL;
LC := LCAFTERMARKSTACK+FILEBUFFER*CHARMAX;
(* NOTE IN THE ABOVE RESERVATION OF BUFFER STORE FOR 4 TEXT FILES *)
IC := 1; EOL := TRUE; LINECOUNT := 0;
CH := ' '; CHCNT := 0;
ERRSET1 := [ ];
ERRSET2 := [ ];
ERRLASTLIN := 0;
GLOBTESTP := NIL;
FORTFUNC := NIL; LASTFFUNC := NIL;
FOR I := 1 TO 8 DO
BEGIN THEDATE[I] := ' '; THETIME[I] := ' ' END;
DATE(THEDATE); TIME(THETIME)
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] := 'EXTERN '; RW[33] := 'FORWARD ';
RW[34] := 'PROGRAM '; RW[35] := 'FORTRAN ';
RW[36] := 'FUNCTION'; RW[37] := 'PROCEDUR';
FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 22;
FRW[6] := 28; FRW[7] := 33; FRW[8] := 36; FRW[9] := 38;
END (*RESWORDS*) ;
PROCEDURE ERRMSGS;
VAR I : 1..400;
BEGIN
FOR I := 1 TO 400 DO
EM[I] := ' ';
EM[1] := 'error in simple type ';
EM[2] := 'identifier expected ';
EM[3] := '''program'' expected ';
EM[4] := ''')'' expected ';
EM[5] := ''':'' expected ';
EM[6] := 'illegal symbol ';
EM[7] := 'error in parameter list ';
EM[8] := '''of'' expected ';
EM[9] := '''('' expected ';
EM[10] := 'error in type ';
EM[11] := '''['' expected ';
EM[12] := ''']'' expected ';
EM[13] := '''end'' expected ';
EM[14] := ''';'' expected ';
EM[15] := 'integer expected ';
EM[16] := '''='' expected ';
EM[17] := '''begin'' expected ';
EM[18] := 'error in declaration part ';
EM[19] := 'error in field-list ';
EM[20] := ''','' expected ';
EM[21] := '''*'' expected ';
EM[50] := 'error in constant ';
EM[51] := ''':='' expected ';
EM[52] := '''then'' expected ';
EM[53] := '''until'' expected ';
EM[54] := '''do'' expected ';
EM[55] := '''to''/''downto'' expected ';
EM[56] := '''if'' expected ';
EM[57] := '''file'' expected ';
EM[58] := 'error in factor ';
EM[59] := 'error in variable ';
EM[60] := ''':'' or ''/'' expected ';
EM[101] := 'identifier declared twice ';
EM[102] := 'low bound exceeds highbound ';
EM[103] := 'identifier is not of appropriate class ';
EM[104] := 'identifier not declared ';
EM[105] := 'sign not allowed ';
EM[106] := 'number expected ';
EM[107] := 'incompatible subrange types ';
EM[108] := 'file not allowed here ';
EM[109] := 'type must not be real ';
EM[110] := 'tagfield type must be scalar or subrange ';
EM[111] := 'incompatible with tagfield type ';
EM[112] := 'index type must not be real ';
EM[113] := 'index type must be scalar or subrange ';
EM[114] := 'base type must not be real ';
EM[115] := 'base type must be scalar or subrange ';
EM[116] := 'error in type of standard procedure parameter ';
EM[117] := 'unsatisfied forward reference ';
EM[118] := 'forward reference type id in variable decln ';
EM[119] := 'fwd declared; repetition of param list illegal ';
EM[120] := 'func result type must be scalar, subrange or ptr ';
EM[121] := 'file value parameter not allowed ';
EM[122] := 'fwd declared function; cannot repeat result type ';
EM[123] := 'missing result type in function declaration ';
EM[124] := 'F-format for real only ';
EM[125] := 'error in type of standard function parameter ';
EM[126] := 'number of params does not agree with declaration ';
EM[127] := 'illegal parameter substitution ';
EM[128] := 'result type of param func does not agree with decl';
EM[129] := 'type conflict of operands ';
EM[130] := 'expression is not of set type ';
EM[131] := 'tests on equality allowed only ';
EM[132] := 'strict inclusion not allowed ';
EM[133] := 'file comparison not allowed ';
EM[134] := 'illegal type of operand(s) ';
EM[135] := 'type of operand must be Boolean ';
EM[136] := 'set element type must be scalar or subrange ';
EM[137] := 'set element types not compatible ';
EM[138] := 'type of variable is not array ';
EM[139] := 'index type is not compatible with declaration ';
EM[140] := 'type of variable is not record ';
EM[141] := 'type of variable must be file or pointer ';
EM[142] := 'illegal parameter substitution ';
EM[143] := 'illegal type of loop control variable ';
EM[144] := 'illegal type of expression ';
EM[145] := 'type conflict ';
EM[146] := 'assignment of files not allowed ';
EM[147] := 'label type incompatible with selecting expr ';
EM[148] := 'subrange bounds must be scalar ';
EM[149] := 'index type must not be integer ';
EM[150] := 'assignment to standard function is not allowed ';
EM[151] := 'assignment to formal function is not allowed ';
EM[152] := 'no such field in this record ';
EM[153] := 'type error in read ';
EM[154] := 'actual parameter must be a variable ';
EM[155] := 'control variable can''t be formal or non local ';
EM[156] := 'multidefined case label ';
EM[157] := 'too many cases in case statement ';
EM[158] := 'missing corresponding variant declaration ';
EM[159] := 'real or string tagfields not allowed ';
EM[160] := 'previous declaration was not forward ';
EM[161] := 'again forward declared ';
EM[162] := 'parameter size must be constant ';
EM[163] := 'missing variant in declaration ';
EM[164] := 'substitution of standard proc/func not allowed ';
EM[165] := 'multidefined label ';
EM[166] := 'multideclared label ';
EM[167] := 'undeclared label ';
EM[168] := 'undefined label ';
EM[169] := 'error in base set ';
EM[170] := 'value parameter expected ';
EM[171] := 'standard file was redeclared ';
EM[172] := 'undeclared external file ';
EM[173] := 'Fortran procedure or function expected ';
EM[174] := 'Pascal procedure or function expected ';
EM[175] := 'missing file ''input'' in program heading ';
EM[176] := 'missing file ''output'' in program heading ';
EM[177] := 'assgt to function identifier not allowed here ';
EM[178] := 'multidefined record variant ';
EM[179] := 'X-opt of actual proc/func does not match decl ';
EM[180] := 'control variable must not be formal ';
EM[181] := 'constant part of address out of range ';
EM[182] := 'file must be file of char ';
EM[183] := 'pathname linkage not allowed for temporary files ';
EM[201] := 'error in real constant: digit expected ';
EM[202] := 'string constant must not exceed source line ';
EM[203] := 'integer constant exceeds range ';
EM[204] := '8 or 9 in octal number ';
EM[205] := 'string constant length must not be zero ';
EM[206] := 'integer part of real constant exceeds range ';
EM[250] := 'too many nested scopes of identifiers ';
EM[251] := 'too many nested procedures and/or functions ';
EM[252] := 'too many forward references of procedure entries ';
EM[253] := 'procedure too long ';
EM[254] := 'too many long constants in this procedure ';
EM[255] := 'too many errors on this source line ';
EM[256] := 'too many external references ';
EM[257] := 'too many externals ';
EM[258] := 'too many local files ';
EM[259] := 'expression too complicated ';
EM[260] := 'too many exit labels ';
EM[261] := 'pathname too long ';
EM[300] := 'division by zero ';
EM[301] := 'no case provided for this value ';
EM[302] := 'index expression out of bounds ';
EM[303] := 'value to be assigned is out of bounds ';
EM[304] := 'element expression out of range ';
EM[350] := 'unknown -- see procedure selector ';
EM[351] := 'unknown -- see recog of string const in insymbol ';
EM[352] := 'unknown -- see procedure gentypindicator ';
EM[353] := 'unknown -- see procedure store ';
EM[354] := 'reading of packed arrays not implemented ';
EM[355] := 'unknown -- see procedure loadaddress ';
EM[356] := 'unknown -- see procedure loadaddress ';
EM[397] := 'fortran func result type must be integer or real ';
EM[398] := 'implementation restriction ';
EM[399] := 'miscellaneous ';
EM[400] := 'not implemented in this version '
END; (* error messages *)
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] := EXTERNSY; RSY[33] := FORWARDSY;
RSY[34] := PROGSY; RSY[35] := FORTRANSY;
RSY[36] := FUNCSY; RSY[37] := 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['{'] := LCURBRK; SSY['}'] := RCURBRK;
SSY['<'] := RELOP; SSY['>'] := RELOP; SSY['"'] := DQUOTE;
SSY[';'] := SEMICOLON;
END (*SYMBOLS*) ;
PROCEDURE RATORS;
VAR I: INTEGER; CH: CHAR;
BEGIN
FOR I := 1 TO 37 (*NR OF RES WORDS*) DO ROP[I] := NOOP;
ROP[5] := INOP; ROP[10] := IDIV; ROP[11] := IMOD;
ROP[6] := OROP; ROP[13] := ANDOP;
FOR CH := CHR(ORDMINCHAR) TO CHR(ORDMAXCHAR) DO SOP[CH] := NOOP;
SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
SOP['='] := EQOP;
SOP['<'] := LTOP; SOP['>'] := GTOP;
END (*RATORS*) ;
PROCEDURE PROCMNEMONICS;
(* Standard procedure names *)
BEGIN
SNA[ 1]:=' P$GET';SNA[ 2]:=' P$PUT';SNA[ 3]:=' P$RDI';SNA[ 4]:=' P$RDR';
SNA[ 5]:=' P$RDC';SNA[ 6]:=' P$WRI';SNA[ 7]:=' P$WRO';SNA[ 8]:=' P$WRR';
SNA[ 9]:=' P$WRC';SNA[10]:=' P$WRS';SNA[11]:=' P$PAK';SNA[12]:=' P$NEW';
SNA[13]:=' P$RST';SNA[14]:=' P$ELN';SNA[15]:=' P$SIN';SNA[16]:=' P$COS';
SNA[17]:=' P$EXP';SNA[18]:=' P$SQT';SNA[19]:=' P$LOG';SNA[20]:=' P$ATN';
SNA[21]:=' P$RLN';SNA[22]:=' P$WLN';SNA[23]:=' P$SAV';SNA[24]:=' P$RES';
SNA[25]:=' P$RWR';SNA[26]:=' P$PAG';SNA[27]:=' P$BRD';SNA[28]:=' P$BWR';
SNA[29]:=' P$DAT'
END (*PROCMNEMONICS*) ;
PROCEDURE INSTRMNEMONICS;
(* Interpreter instruction mnemonics (calls) *)
BEGIN
MN[0] :=' P$ABI'; MN[1] :=' P$ABR'; MN[2] :=' P$ADI'; MN[3] :=' P$ADR';
MN[4] :=' P$AND'; MN[5] :=' P$DIF'; MN[6] :=' P$DVI'; MN[7] :=' P$DVR';
MN[8] :=' P$EOF'; MN[9] :=' P$FLO'; MN[10]:=' P$FLT'; MN[11]:=' P$INN';
MN[12]:=' P$INT'; MN[13]:=' P$IOR'; MN[14]:=' P$MOD'; MN[15]:=' P$MPI';
MN[16]:=' P$MPR'; MN[17]:=' P$NGI'; MN[18]:=' P$NGR'; MN[19]:=' P$NOT';
MN[20]:=' P$ODD'; MN[21]:=' P$SBI'; MN[22]:=' P$SBR'; MN[23]:=' P$SGS';
MN[24]:=' P$SQI'; MN[25]:=' P$SQR'; MN[26]:=' P$STO'; MN[27]:=' P$TRC';
MN[28]:=' P$UNI'; MN[29]:=' P$STP'; MN[30]:=' P$CSP'; MN[31]:=' P$DEC';
MN[32]:=' P$ENT'; MN[33]:=' P$FJP'; MN[34]:=' P$INC'; MN[35]:=' P$IND';
MN[36]:=' P$IXA'; MN[37]:=' P$LAO'; MN[38]:=' P$LCA'; MN[39]:=' P$LDO';
MN[40]:=' P$MOV'; MN[41]:=' P$MST'; MN[42]:=' P$RET'; MN[43]:=' P$SRO';
MN[44]:=' P$XJP'; MN[45]:=' P$CHK'; MN[46]:=' P$CUP'; MN[47]:=' P$EQU';
MN[48]:=' P$GEQ'; MN[49]:=' P$GRT'; MN[50]:=' P$LDA'; MN[51]:=' P$LDC';
MN[52]:=' P$LEQ'; MN[53]:=' P$LES'; MN[54]:=' P$LOD'; MN[55]:=' P$NEQ';
MN[56]:=' P$STR'; MN[57]:=' P$UJP'; MN[58]:=' '; MN[59]:=' P$MTS';
MN[60]:=' P$UJC'; MN[61]:=' P$LPC'; MN[62]:=' P$SPC'; MN[63]:=' P$CLS';
MN[64]:=' P$REM'; MN[65]:=' P$INF';
END (*INSTRMNEMONICS*) ;
PROCEDURE CHARTYPES;
VAR C : CHAR;
BEGIN
FOR C := CHR (ORDMINCHAR) TO CHR (ORDMAXCHAR) DO CHARTP[C] := ILLEGAL;
FOR C := 'A' TO 'Z' DO CHARTP [C] := LETTER;
FOR C := 'a' TO 'z' DO CHARTP [C] := LETTER;
FOR C := '0' TO '9' DO CHARTP [C] := NUMBER;
CHARTP['_'] := LETTER ; 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;
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] := -8; CDX[ 6] := -1; CDX[ 7] := -1;
CDX[ 8] := 0; CDX[ 9] := 0; CDX[10] := 0; CDX[11] := -8;
CDX[12] := -8; 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] := +7;
CDX[24] := 0; CDX[25] := 0; CDX[26] := -2; CDX[27] := 0;
CDX[28] := -8; 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] := +6;
CDX[60] := 0; CDX[61] := -1; CDX[62] := -3; CDX[63] := -1;
CDX[64] := -1; CDX[65] := -1;
PDX[ 1] := -1; PDX[ 2] := -1; PDX[ 3] := -1; PDX[ 4] := -1;
PDX[ 5] := -1; PDX[ 6] := -2; PDX[ 7] := -3; PDX[ 8] := -3;
PDX[ 9] := -2; PDX[10] := -3; 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; PDX[24] := -1;
PDX[25] := -1; PDX[26] := -1; PDX[27] := -1; PDX[28] := -1;
PDX[29] := -2;
END;
BEGIN (*INITTABLES*)
RESWORDS; SYMBOLS; RATORS;
INSTRMNEMONICS; PROCMNEMONICS;
CHARTYPES; INITDX;
ERRMSGS
END (*INITTABLES*) ;
BEGIN (* main body of compiler *)
(*INITIALIZE*)
(************)
INITSCALARS; INITSETS; INITTABLES;
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
LEVEL := 0; TOP := 0;
(* level 0 contains the standard names and standard types *)
(* in the symbol table *)
IF PRCODE THEN BEGIN
WRITELN (PRR, ' ':6, 'CALL MAIN');
WRITELN (PRR, ' ':6, 'END');
IC := IC + 2
END;
WITH DISPLAY [0] DO BEGIN
FNAME := NIL; FLABEL := NIL; OCCUR := BLCK
END;
ENTERSTDTYPES; STDNAMES; ENTSTDNAMES; ENTERUNDECL;
(* initialize for first level of user symbol table entries *)
TOP := 1; LEVEL := 1;
WITH DISPLAY [1] DO BEGIN
FNAME := NIL; FLABEL := NIL; FFILE := NIL; OCCUR := BLCK
END;
(* COMPILE *)
(***********)
INSYMBOL;
PROGRAMME (BLOCKBEGSYS + STATBEGSYS - [CASESY]);
PRINTERRMSGS;
IF PRCODE THEN BEGIN
WRITELN (PRR, ' ':6, 'SUBROUTINE MAIN');
WRITELN (PRR, ' ':6, 'INTEGER*4 STRGS (',
((MAXSTRGINDEX+1) DIV 4):4, '), SETS (400)');
PUTCOMDEFS;
IF SETINDEX > 0 THEN BEGIN
WRITELN(PRR);
WRITELN(PRR,' ':6, 'DATA SETS /');
FOR I := 0 TO SETINDEX-1 DO BEGIN
WRITE(PRR,' +:');
IF 31 IN SETTABLE [I] THEN K := 2 ELSE K := 0;
IF 30 IN SETTABLE [I] THEN K := K + 1;
WRITE(PRR,K:1);
J := 29;
WHILE J > -1 DO BEGIN
K := 0;
IF J IN SETTABLE[I] THEN K := K + 4;
IF (J-1) IN SETTABLE[I] THEN K := K + 2;
IF (J-2) IN SETTABLE[I] THEN K := K + 1;
WRITE(PRR,K:1);
J := J - 3
END;
WRITELN(PRR,',')
END;
IF (MAXSETINDEX - SETINDEX + 1) > 0 THEN
WRITELN (PRR, ' ':5, '+', (MAXSETINDEX-SETINDEX+1):1, '*0/')
END;
IF STRGINDEX > 0 THEN BEGIN
WRITELN(PRR);
WRITELN(PRR,' ':6, 'DATA STRGS /');
K := STRGINDEX - 32; I := 0;
WHILE I < K DO BEGIN
WRITE (PRR, ' ':5, '+32H');
FOR J := I TO I + 31 DO
WRITE (PRR, STRGTABLE [J]);
I := I + 32; WRITELN (PRR, ',')
END;
IF (STRGINDEX - I) > 0 THEN BEGIN
WRITE (PRR, ' ':5, '+', (STRGINDEX - I):1, 'H');
FOR J := I TO STRGINDEX - 1 DO
WRITE (PRR, STRGTABLE [J])
END;
IF (MAXSTRGINDEX - STRGINDEX + 1) > 0 THEN
WRITE (PRR, ',', ((MAXSTRGINDEX-STRGINDEX+1) DIV 4):1, '*0');
WRITELN (PRR, '/')
END;
WRITELN (PRR);
WRITELN (PRR, ' ':6, 'CALL MOVE2S(LOC(STRGS), LOC(STRTBL), ',
STRGINDEX DIV 2:1, ')');
WRITELN (PRR, ' ':6, 'CALL MOVE2S(LOC(SETS), LOC(SETTBL), ',
SETINDEX * 2:1, ')');
IF INPFLG THEN K := 1 ELSE K := 0;
WRITELN (PRR, ' ':6, 'CALL P$INIT(', K:1, ')');
WRITELN (PRR, ' ':6, 'CALL P$MST(0)');
WRITELN (PRR, ' ':6, 'CALL P$CUP(0)');
WRITELN (PRR, ' ':6, 'CALL P$MAIN');
IF COMPCODE THEN
BEGIN
ID := 'ERRKTR ';
SEARCHID([VARS],LCP);
WRITELN(PRR, ' ':6, 'CALL P$LAO(', LCP^.VADDR:1, ')');
WRITELN(PRR, ' ':6, 'CALL P$FMS('' errors in pascal program.'')')
END;
WRITELN (PRR, ' ':6, 'CALL P$STP');
WRITELN (PRR, ' ':6, 'END');
END
END.