'HEAD' BUILD POLISH C EDIT DATE 07FEB79 08:23 C SOURCE FILE BPOLSHAJH.FS C AUTHOR A. J. HOWARD C CLUSTER 12 'OUTFILE' BLDPOAJH.FR C EDIT DATE 07FEB79 08:23 C SOURCE FILE BLDPOAJH.FR C AUTHOR A.J. HOWARD C CLUSTER 11 SUBROUTINE BLDPO 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' CTRLAJH.IN, 'INCLUDE' SRCDFSFTM.IN, EXTERNAL OLCTL 'DO' CALL BP 'WHILE' (NEXTOP .EQ. CONTRL) CALL OVLOD (OLCTL) CTLUSE = 1 CTLERR = 0 CALL PCONT CTLUSE = 0 IF (CTLERR .NE. 0) CALL FAULTP (CTLERR) IF (CONEND) RETURN 'END' RETURN END 'OUTFILE' BPAJH.FR C EDIT DATE 07FEB79 08:23 C SOURCE FILE BPAJH.FR C AUTHOR A. J. HOWARD C CLUSTER 11 SUBROUTINE BP 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' BLDPOAJH.IN, 'INCLUDE' CPAREAJH.IN, 'INCLUDE' GENCOMFTM.IN, 'INCLUDE' LEVELSAJH.IN, 'INCLUDE' LCFUNCAJH.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' REGSJHP.IN, 'INCLUDE' SRCDFSFTM.IN, 'INCLUDE' STKDEFA.IN, 'INCLUDE' STKDEFB.IN, 'INCLUDE' STKDEFC.IN, 'INCLUDE' STKDEFD.IN, 'INCLUDE' BRACEFTM.IN, 'INCLUDE' OPINXJHP.IN, 'INCLUDE' IOCONFTM.IN, 'INCLUDE' RMCODES.IN, INTEGER TS, ISOPX, GACT INTEGER DECODE, NLOPS, ENTNUM INTEGER BPRET // RETURN FOR INTERNAL SUBROUTINES INTEGER COP (2) // TRANSFORM FOR AND, OR INTEGER FSX, FSTACK (5), FOPX LOGICAL NLTEST EXTERNAL OLLCO DATA COP / 31, 33/ DATA FSX / 0/ 'EJECT' C BUILD POLISH SUBROUTINE TO EVALUATE AN EXPRESSION 1 MSEEN = .FALSE. C NEXT PAIR 'DO' SMSEEN = .FALSE. SMODE = 0 OSTACK (OPX) = 0 C RE ADVANCE 2 'DO' CALL ADVAN 25 IF (NEXTOP .EQ. CONTRL) RETURN 'IF' (NEXTOP .EQ. TEMPL) CALL PEEK IF (LOGICF .NE. 0 .OR. PEEKS .NE. LBK) CALL FAULTP (49) TPFLAG = TPLBIT 'NEXT' 'ENDIF' 'IF' (NEXTOP .EQ. ZRL) CALL PEEK IF (LOGICF .NE. 0 .OR. PEEKS .NE. LBRACE) ^ CALL FAULTP (68) ZFLAG = .TRUE. 'NEXT' 'ENDIF' 'IF' (NEXTOP .GE. ST) IOTYPE = NEXTOP 'NEXT' 'ENDIF' 'WHILE' (NEXTOP .GE. SP) SMODE = NEXTOP DEFMOD = SMODE - SP SMSEEN = .TRUE. MSEEN = .TRUE. 'IF' (NAMEX (OPX) .NE. 0) CALL FAULTP (16) 'ENDIF' 'END' 'EJECT' C LOOK FOR UNARY + OR - 'IF' (NAMEX (OPX) .EQ. 0 ^ .AND. ISHFT (OSTACK (OPX-1), -10) .LE. 10) IF (NEXTOP .EQ. PLUS) GOTO 2 IF (NEXTOP .EQ. MINUS) NEXTOP = NEG 'ENDIF' 'IF' (SMODE .NE. 0) SMODE = 0 TS = DEFMOD 'ELSE' NLX = NAMEX (OPX) 'IF' (NLX .EQ. 0) TS = STDMD 'ELSE' 'IF' (NLTEST (NLX, CBIT) ^ .AND. .NOT. NLTEST (NLX, DPBIT) ^ .AND. DEFMOD .NE. DPMODE) TS = DEFMOD 'ELSE' TS = NLOPS (NLMODE, NLX) 'ENDIF' 'ENDIF' 'ENDIF' MODE (OPX) = TS 'IF' (LOCFLG (OPX) .NE. 0) MODE (OPX) = DPMODE 'ENDIF' CALL DUMST ('BP2 ') OPX = OPX + 1 'EJECT' C C TEST LEVEL C 100 LEVEL = DECODE (1, NEXTOP) 'IF' (LEVEL .NE. 2) C NOT OPEN LEVEL ASSIGN 101 TO BPRET GO TO 700 // CALL CHECK CONSTANT LOC 101 GO TO 800 // CALL CHECK SPECIAL LEVELS 102 GO TO 900 // CALL POP STACK 103 'IF' (LEVEL .EQ. 4) C CLOSE LEVEL, GET ACTION TS = DECODE (2, NEXTOP) GO TO ( 3, 9, 9, 200, 300), TS 'ENDIF' C NEXT OP IS OPEN LEVEL 'ELSE' 'IF' (NEXTOP .EQ. LBK) CALL PEEK IF (PEEKS .EQ. RBK) CALL FAULTP (41) 'ENDIF' 'IF' (NEXTOP .EQ. LPAREN) PLEVEL = PLEVEL + 1 STOPS (PLEVEL) = CLX C IS THIS A FUNCTION CALL? 'IF' (NAMEX (OPX-1) .NE. 0) IF (LEVELB .EQ. LLEVEL .OR. LEVELB .EQ. ILEVEL) ^ GO TO 400 CALL FAULTP (4) // ILLEGAL FUNCTION CALL NAMEX (OPX-1) = 0 CALL SCAN (RPAREN, 0, 0) PLEVEL = PLEVEL - 1 GO TO 100 'ENDIF' 'ELSE' 'IF' (NEXTOP .EQ. LOC) OPX = OPX - 1 CALL ADVAN MODE (OPX) = DPMODE LOCFLG (OPX) = 1 GO TO 25 'ENDIF' 'ENDIF' 'ENDIF' C C STACK OPERATOR/OPERAND IF (NEXTOP .EQ. ARROW) LEVEL = 22 OSTACK (OPX-1) = ^ ISHFT (LEVEL, 10) + ISHFT (CFLAG, -3) + NEXTOP 'END' C C BP EXIT C 3 'IF' (IAND (OSTACK (OPX-2), 63) .EQ. LBK) CALL FAULTP (60) OPX = OPX - 1 'ENDIF' IF (FSX .NE. 0) GO TO 410 RETURN 9 CALL FATAL (6) RETURN 'EJECT' C PROCESS RIGHT PAREN 200 'IF' (IAND (OSTACK (OPX-2), 63) .NE. LPAREN) CALL FAULTP (62) 'ELSE' PLEVEL = PLEVEL - 1 IF (IAND (OSTACK (OPX-2), FUNBIT) .NE. 0) GO TO 3 OPX = OPX - 1 ISOPX = OPX + 20 CALL MSTAK (OPX, OPX - 1) NAMEX (OPX) = 0 OSTACK (OPX-1) = OSTACK (OPX) 'DOLOOP' I = 1, NRREGS 'IF' (STATUS (I) .GE. OPX .AND. STATUS (I) .LE. STKSIZ ^ .OR. STATUS (I) .GE. ISOPX) STATUS (I) = STATUS (I) - 1 'ENDIF' 'END' 'ENDIF' C FUNCTION RETURN 250 LEVEL = CFLAG CALL ADVAN CALL DUMST ('BPFR') CFLAG = LEVEL IF (NAMEX (OPX) .NE. 0 .OR. DECODE (1, NEXTOP) .EQ. 2) ^ CALL FAULTP (3) GO TO 100 'EJECT' C PROCESS RIGHT BRACKET 300 'IF' (IAND (OSTACK (OPX-2), 63) .NE. LBK) CALL FAULTP (61) 'ELSE' OPX = OPX - 1 NEXTX = OPX 'IF' (SUBX (OPX) .NE. 0 .OR. BIAS (OPX) .NE. 0 ^ .OR. LOCFLG (OPX) .NE. 0) CALL GENER (SETX) 'IF' (LOGICF .EQ. 0) CALL FAULTP (11) 'ELSE' CALL SETUP (LDAINX, OPX) CALL GEN (COM+1, OPX, OPX) CALL REGMAN (CLRACX, AREG, 0) TS = MODE (OPX) // PRESERVE THE MODE CALL CLRSTK (OPX) NAMEX (OPX) = REGS (AREG) MODE (OPX) = TS STATUS (AREG) = OPX 'ENDIF' 'ENDIF' BIAS (OPX-1) = SBIAS SBIAS = 0 OPTOPX = NAMEX (OPX) 'IF' (OPTOPX .NE. 0) 'IF' (NLTEST (OPTOPX, CBIT)) BIAS (OPX-1) = BIAS (OPX-1) + NLOPS (CVALUE, OPTOPX) 'ELSE' 'IF' (NLTEST (OPTOPX, REGBIT)) TS = NLOPS (REGNUM, OPTOPX) // SUBSCRIPT IS REG 'IF' (STATUS (TS) .NE. 0) STATUS (TS) = STATUS (TS) + 19 'ENDIF' 'ENDIF' SUBX (OPX-1) = OPTOPX SUBXM (OPX-1) = MODE (OPX) NAMEX (OPX) = 0 'ENDIF' 'ENDIF' 'ENDIF' C GET THE LBK OUT OF THE STACK OSTACK (OPX-1) = 0 IF (NAMEX (OPX-1) .EQ. 0) NAMEX (OPX-1) = NULLX NLX = NAMEX (OPX-1) IF (NLTEST (NLX, CBIT + REGBIT)) CALL FAULTP (65) CALL ADVAN CALL DUMST ('BP ]') STOAC = 0 ASSIGN 310 TO BPRET GO TO 700 // CALL CHECK CONSTANT LOC 310 IF (NAMEX (OPX) .NE. 0) CALL FAULTP (32) CUROP = IAND (OSTACK (OPX-2), 63) GO TO 100 'EJECT' C FUNCTION PROCESSING 400 FSX = FSX + 1 FSTACK (FSX) = OPX IF (CUROP .EQ. ARROW) CALL FAULTP (8) CALL PEEK 'IF' (PEEKS .NE. RPAREN) 'DO' C STACK A FUNCTION ( AND GET AN ARGUMENT OSTACK (OPX-1) = 1024 + LPAREN + FUNBIT DEFMOD = STDMD STOAC = 0 GO TO 1 410 NLX = NAMEX (OPX-1) 'IF' (NLTEST (NLX, REGBIT)) TS = NLOPS (REGNUM, NLX) IF (STATUS (TS) .EQ. 0) STATUS (TS) = OPX - 1 CALL GENER (SAVCAL) 'ENDIF' 'WHILE' (NEXTOP .EQ. COMMA) 'END' IF (NEXTOP .NE. RPAREN) CALL FAULTP (60) 'ELSE' PLEVEL = PLEVEL - 1 CALL FNZS 'ENDIF' FOPX = OPX - 1 OPX = FSTACK (FSX) FSX = FSX - 1 'IF' (OPX .LE. FOPX) CALL GENER (SAVCAL) TS = FOPX - OPX + 1 'FOR' (K = FOPX; K .GE. OPX; K = K - 1) TOPX = K + 1 NEXTX = K CALL CLRSTK (TOPX) NAMEX (TOPX) = FLS (TS) MODE (TOPX) = DPMODE MODE (NEXTX) = DPMODE LOCFLG (NEXTX) = 1 NEXTOP = COMMA CALL REGMAN (CLRSTA, 0, 0) CALL SETUP (LDAINX, NEXTX) CALL SETUP (STAINX, TOPX) CALL GEN (ARROW, NEXTX, TOPX) CALL REGMAN (CLRSTA, 0, 0) TS = TS - 1 'END' NAMEX (OPX) = 0 'ENDIF' CALL DUMST ('FUNC') 'EJECT' OPX = OPX - 1 CALL GENT (1) // GENERATE JSR ACTLO = AREG 'IF' (MODE (OPX) .EQ. DPMODE) ACTHI = AREG ACTLO = XREG 'ENDIF' OPX = OPX + 1 CALL GENER (OUT) CALL REGSRC (6, REGS, SPMODE, 0, 0, 0, NZREG) STOAC = 1 GO TO 250 'EJECT' C SUBROUTINE CHECK CONSTANT LOC C IF THE OPERAND IS THE LOCATION OF AN ABSOLUTE NAME +/- C A CONSTANT, CONSIDER IT A COMPILE TIME CONSTANT C = 'LOC' NAME +/- CONSTANT 700 'IF' (LOCFLG (OPX-1) .NE. 0 .AND. SUBX (OPX-1) .EQ. 0) 'IF' (NLOPS (NLXLCI, NAMEX (OPX-1)) .EQ. ABSLC) NLX = NAMEX (OPX-1) NUMBER = NLOPS (NAMLOC, NLX) + BIAS (OPX-1) NAMEX (OPX-1) = ENTNUM (DUMMY) BIAS (OPX-1) = 0 LOCFLG (OPX-1) = 0 'ENDIF' 'ENDIF' GO TO BPRET 'EJECT' C SUBROUTINE CHECK SPECIAL LEVELS C DECIDE IF 'AND' OR 'OR' IS RELATIONAL OR ARITHMETIC 800 'IF' (LEVEL .EQ. 10 .AND. NEXTOP .NE. ARROW) RELLEV = PLEVEL RELPAS = .TRUE. 'ELSE' 'IF' (LEVEL .EQ. 6) C BOOLEAN LEVEL 'IF' (RELPAS .AND. PLEVEL .LE. RELLEV) C RELATIONAL 'AND' OR 'OR' RELCNT = RELCNT + 1 RELPAS = .FALSE. 'ELSE' C ARITHMETIC 'AND' OR 'OR' NEXTOP = COP (NEXTOP - 28) LEVEL = DECODE (1, NEXTOP) 'ENDIF' 'ENDIF' 'ENDIF' GO TO 102 'EJECT' C SUBROUTINE POP STACK 900 'DO' TS = ISHFT (OSTACK (OPX-2), -10) 'WHILE' (TS .GE. LEVEL) OPX = OPX - 1 TOPX = OPX NEXTX = TOPX - 1 OP = IAND (OSTACK (NEXTX), 63) CALL DUMST ('POP ') CALL GENER (SETX) STOAC = 0 TS = DECODE (2, OP) GO TO ( 3, 999, 999, 999, 999, ^ 960, 970, 970, 970, 980, ^ 970, 970, 970, 970, 970, 990), TS C COMPARISON OR I/O 960 'IF' ( (OP .EQ. LESS .OR. OP .EQ. GTR) ^ .AND. OPNXTX .EQ. 0) C EXIT TO CALLER TO PROCESS I/O STATEMENT IOFLAG = 1 GO TO 3 'ENDIF' CALL OVLOD (OLLCO) CALL LCOMP (1) NAMEX (OPX) = 0 'NEXT' C ARITHMETIC 970 CONTINUE CALL CODE2 (TS) CALL DUMST ('POP1') 'NEXT' C RELATIONAL AND/OR 980 NAMEX (OPX) = 0 'NEXT' C CONDITIONAL COMPILATION COMPARE 990 TS = OP OP = MINUS CALL CODE2 (8) // SUBTRACT OP = TS NAMEX (OPX) = 0 'END' GO TO 103 999 CALL FATAL (6) RETURN END 'OUTFILE' NEXPFTM.FR C SUBROUTINE NEXP C C PROCESS A NOUN EXPRESSION C SUBROUTINE NEXP 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' STKDEFA.IN, 'INCLUDE' STKDEFB.IN, 'INCLUDE' NLISTCFTM.IN, INTEGER OPXTS LCTS = LC FNLX = 0 OPXTS = OPX CALL BLDPO IF (CONEND) RETURN OPX = OPX - 1 IF (OPX .NE. OPXTS) ^ CALL FAULTP (60) IF (LCTS .LT. LC .AND. QVALUE .EQ. 0) ^ CALL FAULTP (11) IF (SUBX (OPX) .NE. 0) ^ CALL FAULTP (5) RETURN END 'OUTFILE' DECODEAJH.FR C EDIT DATE 07FEB79 08:24 C SOURCE FILE DECODEAJH.FR C AUTHOR A. J. HOWARD INTEGER FUNCTION DECODE (ITYPE, INDEX) INTEGER ITYPE, INDEX INTEGER TABLE (2, 44), EXCEPT (2, 6, 4) 'INCLUDE' LEVELSAJH.IN, C TABLE (1, INDEX) = OPERATOR LEVEL C TABLE (2, INDEX) = CODE GENERATOR NUMBER C IF THE TABLE ENTRY IS -K: C GET THE ENTRY FROM EXCEPT (1/2, -K, LEVELB) C LEVEL DEFINITIONS DATA TABLE (1, 1) / 0/ // NUMBER DATA TABLE (1, 2) / 4/ // , DATA TABLE (1, 3) / 4/ // ; DATA TABLE (1, 4) / 4/ // . DATA TABLE (1, 5) / 4/ // : DATA TABLE (1, 6) /-6/ // 'FOR' DATA TABLE (1, 7) / 4/ // 'DO' DATA TABLE (1, 8) / 4/ // 'WHILE' DATA TABLE (1, 9) / 4/ // 'RBR' DATA TABLE (1, 10) / 4/ // 'LBR' DATA TABLE (1, 11) / 4/ // 'RETURN' DATA TABLE (1, 12) / 4/ // $ DATA TABLE (1, 13) / 2/ // ( DATA TABLE (1, 14) / 4/ // ) DATA TABLE (1, 15) / 2/ // [ DATA TABLE (1, 16) / 4/ // ] DATA TABLE (1, 17) /-1/ // = DATA TABLE (1, 18) /-1/ // # DATA TABLE (1, 19) /-1/ // > DATA TABLE (1, 20) /-1/ // >= DATA TABLE (1, 21) /-1/ // < DATA TABLE (1, 22) /-1/ // <= DATA TABLE (1, 23) /-2/ // -> DATA TABLE (1, 24) /12/ // + DATA TABLE (1, 25) /12/ // - DATA TABLE (1, 26) /14/ // * DATA TABLE (1, 27) /14/ // / DATA TABLE (1, 28) /14/ // 'MOD' DATA TABLE (1, 29) /-3/ // 'OR' DATA TABLE (1, 30) /-4/ // 'AND' DATA TABLE (1, 31) /16/ // 'OR' DATA TABLE (1, 32) /16/ // 'XOR' DATA TABLE (1, 33) /18/ // 'AND' DATA TABLE (1, 34) /20/ // 'LS' DATA TABLE (1, 35) /20/ // 'RS' DATA TABLE (1, 36) /20/ // 'LC' DATA TABLE (1, 37) /20/ // 'RC' DATA TABLE (1, 38) /20/ // 'ALS' DATA TABLE (1, 39) /20/ // 'ARS' DATA TABLE (1, 40) /14/ // NEG DATA TABLE (1, 41) /-5/ // UPARO DATA TABLE (1, 42) /22/ // 'DEC' DATA TABLE (1, 43) /20/ // 'COM' DATA TABLE (1, 44) / 2/ // 'LOC' C EXCEPTIONAL LEVELS DATA EXCEPT (1, 1, 1) / 4/ DATA EXCEPT (1, 1, 2) /10/ DATA EXCEPT (1, 1, 3) / 4/ DATA EXCEPT (1, 1, 4) /10/ DATA EXCEPT (1, 2, 1) / 4/ DATA EXCEPT (1, 2, 2) /10/ DATA EXCEPT (1, 2, 3) /10/ DATA EXCEPT (1, 2, 4) / 4/ DATA EXCEPT (1, 3, 1) / 6/ DATA EXCEPT (1, 3, 2) / 6/ DATA EXCEPT (1, 3, 3) / 6/ DATA EXCEPT (1, 3, 4) /16/ DATA EXCEPT (1, 4, 1) / 6/ DATA EXCEPT (1, 4, 2) / 6/ DATA EXCEPT (1, 4, 3) / 6/ DATA EXCEPT (1, 4, 4) /18/ DATA EXCEPT (1, 5, 1) / 4/ DATA EXCEPT (1, 5, 2) /22/ DATA EXCEPT (1, 5, 3) / 4/ DATA EXCEPT (1, 5, 4) /22/ DATA EXCEPT (1, 6, 1) / 4/ DATA EXCEPT (1, 6, 2) / 2/ DATA EXCEPT (1, 6, 3) / 2/ DATA EXCEPT (1, 6, 4) / 2/ 'EJECT' C CODE GENERATOR NUMBERS DATA TABLE (2, 1) / 2/ // NUMBER DATA TABLE (2, 2) / 1/ // , DATA TABLE (2, 3) / 1/ // ; DATA TABLE (2, 4) / 1/ // . DATA TABLE (2, 5) / 1/ // : DATA TABLE (2, 6) / 1/ // 'FOR' DATA TABLE (2, 7) / 1/ // 'DO' DATA TABLE (2, 8) / 1/ // 'WHILE' DATA TABLE (2, 9) / 1/ // 'RBR' DATA TABLE (2, 10) / 1/ // 'LBR' DATA TABLE (2, 11) / 1/ // 'RETURN' DATA TABLE (2, 12) / 1/ // $ DATA TABLE (2, 13) / 3/ // ( DATA TABLE (2, 14) / 4/ // ) DATA TABLE (2, 15) / 3/ // [ DATA TABLE (2, 16) / 5/ // ] DATA TABLE (2, 17) /-1/ // = DATA TABLE (2, 18) /-1/ // # DATA TABLE (2, 19) /-1/ // > DATA TABLE (2, 20) /-1/ // >= DATA TABLE (2, 21) /-1/ // < DATA TABLE (2, 22) /-1/ // <= DATA TABLE (2, 23) /-2/ // -> DATA TABLE (2, 24) / 8/ // + DATA TABLE (2, 25) / 8/ // - DATA TABLE (2, 26) / 9/ // * DATA TABLE (2, 27) / 9/ // / DATA TABLE (2, 28) / 9/ // 'MOD' DATA TABLE (2, 29) /10/ // 'OR' DATA TABLE (2, 30) /10/ // 'AND' DATA TABLE (2, 31) / 8/ // 'OR' DATA TABLE (2, 32) / 8/ // 'XOR' DATA TABLE (2, 33) / 8/ // 'AND' DATA TABLE (2, 34) /11/ // 'LS' DATA TABLE (2, 35) /11/ // 'RS' DATA TABLE (2, 36) /11/ // 'LC' DATA TABLE (2, 37) /11/ // 'RC' DATA TABLE (2, 38) /11/ // 'ALS' DATA TABLE (2, 39) /11/ // 'ARS' DATA TABLE (2, 40) /12/ // NEG DATA TABLE (2, 41) /-3/ // UPARO DATA TABLE (2, 42) /14/ // 'DEC' DATA TABLE (2, 43) /15/ // 'COM' DATA TABLE (2, 44) / 3/ // 'LOC' C EXCEPTIONAL OPERATORS DATA EXCEPT (2, 1, 1) / 1/ DATA EXCEPT (2, 1, 2) / 6/ DATA EXCEPT (2, 1, 3) / 1/ DATA EXCEPT (2, 1, 4) /16/ DATA EXCEPT (2, 2, 1) / 1/ DATA EXCEPT (2, 2, 2) / 7/ DATA EXCEPT (2, 2, 3) / 7/ DATA EXCEPT (2, 2, 4) / 1/ DATA EXCEPT (2, 3, 1) / 1/ DATA EXCEPT (2, 3, 2) /13/ DATA EXCEPT (2, 3, 3) / 1/ DATA EXCEPT (2, 3, 4) /13/ DECODE = TABLE (ITYPE, INDEX) 'IF' (DECODE .LT. 0) DECODE = -DECODE DECODE = EXCEPT (ITYPE, DECODE, LEVELB) 'ENDIF' RETURN END