'HEAD' PROCESS VERB LIST C EDIT DATE 31JAN79 07:33 C SOURCE FILE PVERBLFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 3 'OUTFILE' PVERBLFTM.FR N OVERLAY OLPVR C C THE BASIC VERB LIST PROCESSING LOOP -- THE TRANSFERS C DECK HAS BEEN INCLUDED TO SIMPLIFY CONTROL TRANSFER. C SUBROUTINE PVERBL 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' LEVELSAJH.IN, 'INCLUDE' PSHCOMFTM.IN, 'INCLUDE' STKDFA.IN, 'INCLUDE' STKDFD.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' CPAREAJH.IN, 'INCLUDE' BLDPOAJH.IN, 'INCLUDE' RMCODES.IN, 'INCLUDE' IOCONFTM.IN, INTEGER TS EXTERNAL OLLCO, OLSLL, OLIO, OLLAB, OLRBR, OLPV2 'EJECT' LOGICF = 1 LEVELB = LLEVEL NESTX = 1 1 'DO' PX = 1 OPX = 2 DEFMOD = STDMD CALL SET (0, NAMEX, 260) // 20*13 OSTACK (1) = 1026 RELPAS = .FALSE. FNLX = 0 CMPFLG = 0 CALL REGMAN (CLRSTA, 0, 0) CALL BLDPO IF (IOFLAG .NE. 0) GO TO 90 OPX = OPX - 1 IF (OPX .LT. 2) OPX = 2 C CALL OVLOD (OLPV2) GO TO (99, ^ 10, ^ // , 20, ^ // ; 30, ^ // . 40, ^ // : 99, ^ // 'FOR' 50, ^ // 'DO' 50, ^ // 'WHILE' 60, ^ // 'RBR' 199, ^ // 'LBR' 70, ^ // 'RETURN' 80 ^ // $ ), NEXTOP 5 IF (OPX .GT. 2) ^ CALL FAULTP (60) 'END' 99 CALL FATAL (6) 199 CALL FAULTP (8) CALL SCAN (RBRACE, NINE, FOR) GO TO 5 'EJECT' C RETURN TRANSFER 10 'IF' (STOAC .NE. 0) STOAC = 0 'IF' (IAND (OSTACK (OPX - 1), 63) .EQ. FOR) C CALL OVLOD (OLSLL) CALL SETLL 'ENDIF' 'ELSE' CALL PVR2 (2, TS) // SUBROUTINE CALL 'ENDIF' GO TO 5 C RELATION CONTROL 20 CALL PVR2 (2, TS) // SUBROUTINE CALL 'IF' (NESTX .NE. 1) C CALL OVLOD (OLLCO) CALL LCOMP (3) // CLOSE SIDE 'ELSE' CALL FAULTP (63) // EXTRA ; 'ENDIF' GO TO 5 C TRANSFER 30 'IF' (NAMEX (OPX) .EQ. 0) CALL PVR2 (1, TS) // LOOK FOR ERRORS IF (TS .NE. 0) GO TO 1 // ERRORS RETURN 'ENDIF' IF (CFLAG .NE. 0) CALL FAULTP (64) NEXTX = OPX CALL GENT (2) // GENERATE JMP 'IF' (NESTX .NE. 1) C CALL OVLOD (OLLCO) CALL LCOMP (3) // CLOSE SIDE 'ENDIF' GO TO 5 'EJECT' C CONDITIONAL OR LABEL 40 'IF' (CMPFLG .NE. 0) C CALL OVLOD (OLLCO) CALL LCOMP (2) // CONDITIONAL STATEMENT 'ELSE' C CALL OVLOD (OLLAB) CALL LABEL 'ENDIF' GO TO 5 C SET WHILE, 'DO', 'WHILE' 50 CALL PVR2 (3, TS) GO TO 5 C GEN EXIT ('RBR') 60 CALL PVR2 (2, TS) // SUBROUTINE CALL C CALL OVLOD (OLRBR) CALL PRBR GO TO 5 C DO RETURN 70 IF (NAMEX (OPX) .NE. 0) CALL FAULTP (50) CALL BLDPO // GET RETURN VALUE IF THERE IS ONE C CALL OVLOD (OLPV2) CALL PVR2 (4, TS) // RETURN CODE 'IF' (TS .NE. 0) C CALL OVLOD (OLLCO) CALL LCOMP (3) // CLOSE SIDE IF PERIOD 'ENDIF' IF (NEXTOP .EQ. RBRACE) GO TO 60 GO TO 5 C DO CRUTCH 80 CALL CRUSYM GO TO 5 C I/O PROCESSING 90 IOFLAG = 0 C CALL OVLOD (OLIO) CALL IO GO TO 5 END 'OUTFILE' PVERB2FTM.FR N OVERLAY OLPV2 SUBROUTINE PVR2 (INDEX, FLAG) INTEGER INDEX, FLAG 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' WFLAGSJHP.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' CODE1FTM.IN, 'INCLUDE' LEVELSAJH.IN, 'INCLUDE' STKDFA.IN, 'INCLUDE' STKDFB.IN, 'INCLUDE' STKDFC.IN, 'INCLUDE' CPAREAJH.IN, 'INCLUDE' SRCDFSFTM.IN, 'INCLUDE' BRACEFTM.IN, 'INCLUDE' BLDPOAJH.IN, 'INCLUDE' FAULTSFTM.IN, 'INCLUDE' OPINXJHP.IN, 'INCLUDE' RMCODES.IN, INTEGER TS FLAG = 0 GO TO (100, 10, 50, 70), INDEX 'EJECT' C LOGIC EXIT -- INCLUDES HALT AND FAULT 12 100 LEVELB = LLEVEL 'IF' (NESTX .NE. 1) EXFLT = 0 'DOLOOP' I = 2, NESTX EXFLT = EXFLT + 3 - CNLSID (I-1) 'END' CALL SET (59, SOURCE, EXFLT) // ; CALL SET (46, SOURCE (EXFLT+1), 4) // . SRCEND = EXFLT + 3 CALL FAULTP (25) J = 1 FLAG = 1 'ELSE' 'IF' (BRACEX .GT. 1) EXFLT = BRACEX - 1 CALL SET (96, SOURCE, EXFLT) // 'RBR' CALL SET (46, SOURCE (BRACEX), 4) // . SRCEND = EXFLT + 4 CALL FAULTP (12) J = 1 FLAG = 1 'ELSE' CALL WRBLOK J = SRCEND 'ENDIF' 'ENDIF' RETURN C RETURN TRANSFER 10 'IF' (NAMEX (OPX) .NE. 0 .AND. STOAC .EQ. 0) 'IF' (LOCFLG (OPX) .NE. 0) IF (SUBX (OPX) .NE. 0) ^ CALL FAULTP (31) CALL BLDBLK (BIAS (OPX), WF6) CALL BLDBLK (NAMEX (OPX), WF7) 'ELSE' IF (CFLAG .NE. 0) ^ CALL FAULTP (64) CALL GENT (1) // GENERATE JSR 'ENDIF' 'ENDIF' NEXTX = OPX STOAC = 0 RETURN 'EJECT' C SET WHILE, 'DO', 'WHILE' 50 LOOPF (LSX) = NEXTOP 'IF' (NEXTOP .EQ. DOOP) CALL DEFTL (TLI) CALL REGMAN (CLRACV, 0, 0) CALL SET (0, FLSAVE, 6) WHSTRT (LSX) = TLI TLI = TLI + 1 WHLOW (LSX) = - (NESTX + 1) BSTACK (BRACEX) = 0 'IF' (BRACEX .EQ. 9) CALL FAULTP (59) 'ELSE' BRACEX = BRACEX + 1 'ENDIF' 'ENDIF' LSX = LSX + 1 RETURN C DO RETURN 70 OPX = OPX - 1 NEXTX = OPX 'IF' (NAMEX (NEXTX) .NE. 0) C RETURN A VALUE CALL MSTAK (NEXTX, NEXTX+2) CALL SETUP (LDAINX, NEXTX) CALL GEN (-1, NEXTX, -2) CALL GEN (COM + 1, NEXTX, NEXTX) CALL GEN (-1, -2, -2) 'ENDIF' 'DO' 'WHILE' (NEXTOP .EQ. COMMA) CALL ADVAN IF (NAMEX (OPX) .NE. 0) CALL FAULTP (67) 'END' C FIND PROCEDURE BRACE 'FOR' (TS = BRACEX - 1; TS .GT. 0; TS = TS - 1) 'IF' (BSTACK (TS) .GT. 0) C GENERATE EXIT CODE 'IF' (NEXTOP .EQ. PERIOD) CALL BLDBLK (96, WF4) // RTS IF (NESTX .NE. 1) FLAG = 1 'ELSE' 'IF' (NEXTOP .NE. RBRACE .OR. TS .NE. BRACEX - 1) CALL FAULTP (67) 'ENDIF' STOAC = 1 RETURN 'ENDIF' 'ELSE' 'END' CALL FAULTP (67) 'ENDIF' STOAC = 0 RETURN END 'OUTFILE' GENTAJH.FR SUBROUTINE GENT (FUNC) 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' WFLAGSJHP.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' GENCMB.IN, 'INCLUDE' STKDFA.IN, 'INCLUDE' STKDFB.IN, 'INCLUDE' STKDFC.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' BRACEFTM.IN, 'INCLUDE' OPINXJHP.IN, 'INCLUDE' RMCODES.IN, 'INCLUDE' REGSJHP.IN, 'INCLUDE' LABCOMFTM.IN, 'INCLUDE' CODE1FTM.IN, INTEGER FUNC INTEGER TS, RET, OPTS, JMPX, JMPWF, JMPOP, JMPB LOGICAL NLTEST JMPX = NAMEX (OPX) JMPB = BIAS (OPX) JMPOP = 108 // NOMINAL JMP@ GO TO (10, 30), FUNC 'EJECT' C GENERATE JSR 10 'IF' (SUBX (OPX) .NE. 0 .OR. NLTEST (JMPX, PBIT)) IF (JMPX .EQ. NULLX .OR. NLTEST (JMPX, PBIT)) JMPOP = 76 C 'LOC' A [I + K] -> CT1 CALL REGMAN (CTFREE, TS, 2) // WILL NEED 2 CT WORDS STATUS (TS) = -1 TS = TS + 1 // USE +1 FOR ADDRESS LOCFLG (OPX) = 1 // NEED THE ADDRESS RET=1 //**ICLMOD** ASSIGN 11 TO RET GO TO 15 11 TS = TS - 1 STATUS (TS) = 0 CALL BLDOP (169, WF5, JMPOP, NULLX, WF7) // LDAIM JMP@ CALL BLDOP (133, WF5, 1, REGS (TS), WF7) // STAZP JMPB = 1 JMPX = REGS (TS) 'ENDIF' CALL GENER (SAVCAL) CALL BLDOP (32, WF8, JMPB, JMPX, WF7) // JSR CALL SET (0, FLSAVE, 6) CALL REGMAN (CLRACV, 0, 0) RETURN 15 TOPX = OPX + 1 CALL CLRSTK (TOPX) NAMEX (TOPX) = REGS (TS) MODE (TOPX) = DPMODE STATUS (TS) = -1 CALL SETUP (STAINX, TOPX) MODE (OPX) = DPMODE CALL SETUP (LDAINX, OPX) OPTS = NEXTOP NEXTOP = COMMA CALL GEN (ARROW, OPX, TOPX) IF (ACTHI .NE. 0) STATUS (ACTHI) = 0 IF (ACTLO .NE. 0) STATUS (ACTLO) = 0 ACTHI = 0 ACTLO = 0 STATUS (TS) = 0 NEXTOP = OPTS GOTO (11,32),RET //**ICLMOD** GO TO RET 'EJECT' C GENERATE JMP 30 'IF' (SUBX (OPX) .EQ. 0) JMPWF = WF7 'IF' (NLTEST (JMPX, PBIT)) IF (JMPB .NE. 0) GO TO 31 // USE SUBSCRIPTED CODE FOR P[K] 'ELSE' JMPOP = 76 // JMP C LOOK FOR LOCAL JUMP 'IF' (SPARFL .NE. 0) 'DOLOOP' LLX = 1, 10 'IF' (LOCNLX (LLX) .EQ. JMPX) C DEFINED LOCAL JMPWF = WF9 JMPX = LOCTLI (LLX) 'BREAK' 'ENDIF' 'IF' (LOCNLX (LLX) .EQ. 0) C NO IN LIST YET, MAYBE LATER C SET USE BIT IF IT TURNS OUT EXTERNAL CALL NLSET (JMPX, USEBIT) TL (TLI) = -JMPX JMPWF = WF9 JMPX = TLI TLI = TLI + 1 'BREAK' 'ENDIF' 'END' 'ENDIF' 'ENDIF' CALL BLDOP (JMPOP, WF8, JMPB, JMPX, JMPWF) 'ELSE' 'IF' (JMPX .EQ. NULLX) IF (SUBXM (OPX) .EQ. SPMODE) CALL FAULTP (42) 'IF' (NLTEST (JMPX, PBIT)) NAMEX (OPX) = SUBX (OPX) MODE (OPX) = SUBXM (OPX) SUBX (OPX) = 0 GO TO 31 'ENDIF' CALL REGMAN (SAVREG, AREG, TS) JMPX = SUBX (OPX) 'ELSE' C A [I + K] -> CTX 31 CALL REGMAN (CTFREE, TS, 1) RET=2 //**ICLMOD** ASSIGN 32 TO RET GO TO 15 32 JMPX = REGS (TS) JMPB = 0 'ENDIF' CALL BLDOP (JMPOP, WF8, JMPB, JMPX, WF7) // JMP @ 'ENDIF' RETURN END