'HEAD' CONTROL CARD PROCESSING C EDIT DATE 14DEC78 13:29 C SOURCE FILE CONTFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 13 'OUTFILE' PCONTFTM.FR N OVERLAY OLCTL SUBROUTINE PCONT 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' BLDPOAJH.IN, 'INCLUDE' LCFUNCAJH.IN, 'INCLUDE' SRCDFSFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' CTRLAJH.IN, 'INCLUDE' SRCXDFFTM.IN, 'INCLUDE' STKDFA.IN, 'INCLUDE' STKDFB.IN, 'INCLUDE' PRTCOMFTM.IN, 'INCLUDE' WFLAGSJHP.IN, INTEGER TS, HPTR, CHAR, LCITS, LFTS, NEWLCV INTEGER FNLXTS, CONLST (17), CTS, XSEMI, CNAME (16) LOGICAL CZERO (18) INTEGER GCHAR, SNMLST, NLOPS // EXTERNAL FUNCTIONS DATA CZERO /.FALSE., .TRUE., .TRUE., .FALSE., .TRUE., .FALSE., ^ .TRUE., .FALSE., .TRUE., .TRUE., .FALSE., .FALSE.,^ .TRUE., .FALSE., .FALSE., .FALSE., .TRUE., .TRUE./ C TABLE REPRESENTS: COMP ZERO (6), COMP NEG (6), COMP POS (6) DATA XSEMI /59/ DATA CONLST /'RUPRLIUSEJORIFEVHEENLOTISYDADSSHCO'/ DATA CNAME /16*0/ 'EJECT' FNLXTS = FNLX LFTS = LISTF LISTF = 0 // TURN OFF LIST FLAG CALL SET (XSEMI, SOURCE (SRCEND), 3) SRCEND = SRCEND + 3 J = J + 2 CALL FNZS 'IF' (PSYMB .NE. MINUS) NEGFLG = -1 'ELSE' NEGFLG = 0 CALL FNZS 'ENDIF' CALL CTNAME 'IF' (PSYMB .NE. COLON) IF (SKIP .LT. 0) GO TO 99 'DOLOOP' TS = 1, 17 'IF' (NAME (1) .EQ. CONLST (TS)) GO TO ^ (10, ^ // ''RU NAT 15, ^ // ''PR INT 20, ^ // ''LI ST 25, ^ // ''US E 30, ^ // ''EJ ECT 35, ^ // ''OR G 40, ^ // ''IF 45, ^ // ''EV EN 50, ^ // ''HE AD 55, ^ // ''EN D 60, ^ // ''LO C 65, ^ // ''TI TLE 70, ^ // ''SY MBOLS 75, ^ // ''DA TE 80, ^ // ''DS TACK 85, ^ // ''SH ORT 90),^ // ''CO MPILE TS 'ENDIF' 'END' CTLERR = 71 'ELSE' 'IF' (SKIP .LT. 0) NK = NK + 1 'DOLOOP' NI = 1, NK IF (NAME (NI) .NE. SKNAME (NI)) GO TO 99 'END' SKIP = 0 // NAME FOUND, RESUME COMPILATION 'ENDIF' 'ENDIF' 'EJECT' 99 FNLX = FNLXTS LISTF = LFTS IF (PRINTF .NE. 0) PRINTF = 1 LCTS = LC J = SRCEND RETURN 'EJECT' C RUNAT 10 'IF' (LCI .NE. CODE) C CALL FINAL LIT POOL LCTAB (CODE) = LC - LDLCVO LDLCVO = 0 CALL RLCI (CODE) C BSTACK = PAKLCI (TS) 'ENDIF' IF (NEGFLG .EQ. 0) GO TO 99 ORGFLG = 1 CALL CTNUM ORGFLG = 0 TS = NAMEX (OPX + 1) 'IF' (TS .NE. 0) 'IF' (NLOPS (NLXLCI, TS) .EQ. ABSLC) LCTAB (ABSLC) = NLOPS (NAMLOC, TS) + BIAS (OPX + 1) LDLCVO = LCTAB (ABSLC) - LC CALL RLCI (ABSLC) C BSTACK = PAKLCI (TS) GO TO 99 // CONTROL EXIT 'ENDIF' 'ENDIF' CTLERR = 11 GO TO 99 C PRINT 15 PRINTF = NEGFLG GO TO 99 C LIST 20 LFTS = NEGFLG GO TO 99 'EJECT' C USE 25 USFLGS = ISHFT (USFLGS, 1) + PRINTF 'DOLOOP' NI = 1, 30 CALL FNZS 'IF' (PSYMB .NE. SEMIC) 'IF' (PSYMB .NE. EOCC) CALL PCHAR (CNAME, NI, SYMBOL) 'END' 'ELSE' GO TO 26 'ENDIF' 'ENDIF' IF (PI .EQ. 7) GO TO 26 P CALL DEVICE (CNAME) // DEFAULT DEVICE SPECIFICATION CALL OPENF (PI+1, CNAME, TS) IF (TS .NE. 1) GO TO 26 PI = PI + 1 FLINCT (PI) = 0 PSYMB = 0 CALL CTNUM PRINTF = IAND (NUMBER, PRINTF) GO TO 99 26 CTLERR = 74 GO TO 99 'EJECT' C EJECT 30 IF (LCOUNT .GE. 2) CALL NPAGE GO TO 99 C ORG 35 ORGFLG = 1 CALL CTNUM ORGFLG = 0 TS = NAMEX (OPX+1) 'IF' (TS .NE. 0) 'IF' (NLOPS (DFINED, TS) .NE. 0) CTS = NLOPS (NLXLCI, TS) NEWLCV = NLOPS (NAMLOC, TS) + BIAS (OPX+1) 'IF' (CTS .EQ. LCI) MAXLCV = NEWLCV CALL SETLCI GO TO 99 'ENDIF' 'IF' (LOGICF .NE. 0) C VERB LIST ORG 'IF' (CTS .EQ. ABSLC .OR. CTS .EQ. 1) // 1 IS CODE LCI CODE = CTS LCTAB (CODE) = NEWLCV CALL RBOTH (CODE) GO TO 99 'ENDIF' 'ENDIF' 'ENDIF' 'ENDIF' CTLERR = 73 GO TO 99 'EJECT' C IF 40 OP = -1 CALL CTNUM TS = NUMBER IF (OP .LT. EQUAL .OR. OP .GT. LESSEQ) OP = NEQUAL CTS = OP - EQUAL + 1 C READY FOR ZERO CASE, CHECK FOR POS OR NEG IF (TS .LT. 0) CTS = CTS + 6 // NEG IF (TS .GT. 0) CTS = CTS + 12 // POS SKIP = 0 'IF' (NEXTOP .NE. SEMIC) C FORM ''IF, R: L. IF (CZERO (CTS)) GO TO 99 // NO SKIP SKIP = -32767 CALL FNZS CALL CTNAME CALL MOVE (NAME, SKNAME, 8) GO TO 99 'ENDIF' C FORM ''IF, R IF (CZERO (CTS)) SKIP = -2 GO TO 99 C EVEN 45 CONTINUE C**** IF (LODLCI .NE. LCI) CALL DFTEMP CALL CTNUM TS = NUMBER - 1 + LC MAXLCV = (TS/NUMBER)*NUMBER CALL SETLCI GO TO 99 C HEAD 50 CALL SET (XBBL, UHEAD, 15) 'DOLOOP' HPTR = 1, 30 CHAR = GCHAR (RECORD, HPTR + 7) 'IF' (CHAR .NE. EOCC) CALL PCHAR (UHEAD, HPTR, CHAR) 'END' 'ENDIF' IF (TTL (1) .NE. XBBL) GO TO 99 C TITLE 65 CALL FNZS CALL CTNAME CALL MOVE (NAME, TTL, 8) GO TO 99 'EJECT' C END 55 CONEND = .TRUE. CALL FNZS 'IF' (PSYMB .LT. COMMA) CALL RDNAME (-1) NLX = SNMLST (TS) IF (NLOPS (DFINED, NLX) .NE. 0) TNAME = NLX 'ENDIF' IF (ENDOK) GO TO 99 CALL FATAL (80) C LOC 60 CONTINUE CALL CTNUM LBIAS = NUMBER LOCPRT = NEGFLG GO TO 99 C SYMBOLS 70 SYMFLG = NEGFLG GO TO 99 C DATE 75 CALL FNZS CALL RDNAME (-1) LCITS = LCI CALL RLCI (DATALC) FNLX = SNMLST (NAME) CALL NDEFN CALL NLSET (NLX, STRBIT) CALL QQDATE (CNAME) 'DOLOOP' TS = 1, 9 CALL BLDBLK (GCHAR (CNAME, TS), WF1) 'END' CALL RLCI (LCITS) GO TO 99 C DSTACK 80 DUMFLG = NEGFLG GO TO 99 C SHORT 85 SNLPRT = NEGFLG GO TO 99 'EJECT' C COMPILE 90 COMPFL (1) = 0 COMPFL (2) = 0 'DO' CALL FNZS TS = SYMBOL - XA 'WHILE' (TS .GE. 0) 'IF' (TS .GE. 16) COMPFL (2) = IOR (COMPFL (2), ISHFT (1, TS-16)) 'ELSE' COMPFL (1) = IOR (COMPFL (1), ISHFT (1, TS)) 'ENDIF' 'END' GO TO 99 END 'OUTFILE' CTNAMEFTM.FR SUBROUTINE CTNAME 'INCLUDE' CTRLAJH.IN, INTEGER SKIPTS SKIPTS = SKIP SKIP = -1 CALL CTNUM SKIP = SKIPTS RETURN END 'OUTFILE' CTNUMFTM.FR SUBROUTINE CTNUM 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' CTRLAJH.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' STKDFA.IN, 'INCLUDE' STKDFB.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' LEVELSAJH.IN, INTEGER TS INTEGER NLOPS, GCHAR // EXTERNAL FUNCTIONS LOGICAL NLTEST NUMBER = 0 'IF' (PSYMB .NE. SEMIC) CALL PUSH (LEVELB, NLX, OPX) OPX = OPX + 1 LEVELB = CLEVEL 'IF' (SKIP .LT. 0) CALL SET (XBBL, NAME, 9) CALL RDNAME (-1) 'DOLOOP' TS = 1, 17 CALL PCHAR (NAME, TS, GCHAR (NAME, TS+1)) 'END' NAMEX (OPX) = 0 'ELSE' CALL BP // SIDE DOOR FOR ''CONTROL PROCESSING 'ENDIF' CALL POP (LEVELB, NLX, OPX) 'IF' (ORGFLG .EQ. 0) TS = NAMEX (OPX + 1) 'IF' (TS .NE. 0) 'IF' (NLTEST (TS, CBIT) .OR. SKIP .LT. 0) NUMBER = NLOPS (CVALUE, TS) 'ELSE' CTLERR = 11 'ENDIF' 'ENDIF' NAMEX (OPX + 1) = 0 SUBX (OPX + 1) = 0 BIAS (OPX + 1) = 0 'ENDIF' 'ENDIF' RETURN END