SUBROUTINE MAIN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I, N INTEGER GETARG, OPEN LOGICAL*1 ARG (40) CALL QUERY (32Husage: ratfor [files] >outfile.) CALL INITKW CALL LODSYM(ARG) N = 1 I = 1 23000 IF (.NOT.(GETARG (I, ARG, 40) .NE. -1))GOTO 23002 N = N + 1 IF (.NOT.(ARG (1) .EQ. 45 .AND. ARG (2) .EQ. 0))GOTO 23003 INFILE (1) = 1 GOTO 23004 23003 CONTINUE INFILE (1) = OPEN (ARG, 1) IF (.NOT.(INFILE (1) .EQ. -3))GOTO 23005 CALL CANT (ARG) 23005 CONTINUE 23004 CONTINUE CALL PARSE IF (.NOT.(INFILE (1) .NE. 1))GOTO 23007 CALL CLOSE (INFILE (1)) 23007 CONTINUE 23001 I = I + 1 GOTO 23000 23002 CONTINUE IF (.NOT.(N .EQ. 1))GOTO 23009 INFILE (1) = 1 CALL PARSE 23009 CONTINUE RETURN END SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ LOGICAL*1 C, BUF(100) IF (.NOT.(BP .GT. MAXSIZ))GOTO 23011 CALL BADERR(16Hbuffer overflow.) 23011 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END SUBROUTINE ADDSTR(S, BUF, BP, MAXSIZ) LOGICAL*1 S(100), BUF(100) INTEGER BP, MAXSIZ INTEGER I I = 1 23013 IF (.NOT.(S(I) .NE. 0))GOTO 23015 CALL ADDCHR(S(I), BUF, BP, MAXSIZ) 23014 I=I+1 GOTO 23013 23015 CONTINUE RETURN END INTEGER FUNCTION ALLDIG (STR) LOGICAL*1 STR (100) LOGICAL*1 TYPE INTEGER I ALLDIG = 0 IF (.NOT.(STR (1) .EQ. 0))GOTO 23016 RETURN 23016 CONTINUE I = 1 23018 IF (.NOT.(STR (I) .NE. 0))GOTO 23020 IF (.NOT.(.NOT.(48.LE.STR (I).AND.STR (I).LE.57)))GOTO 23021 RETURN 23021 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE ALLDIG = 1 RETURN END SUBROUTINE BADERR (MSG) LOGICAL*1 MSG (100) CALL SYNERR (MSG) CALL ENDST(-3) END SUBROUTINE BALPAR LOGICAL*1 T, TOKEN (100) LOGICAL*1 GETTOK, GNBTOK INTEGER NLPAR IF (.NOT.(GNBTOK (TOKEN, 100) .NE. 40))GOTO 23023 CALL SYNERR (19Hmissing left paren.) RETURN 23023 CONTINUE CALL OUTSTR (TOKEN) NLPAR = 1 23025 CONTINUE T = GETTOK (TOKEN, 100) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 123 .OR. T .EQ. 125 .OR. T .EQ. -1 *))GOTO 23028 CALL PBSTR (TOKEN) GOTO 23027 23028 CONTINUE IF (.NOT.(T .EQ. 10))GOTO 23030 TOKEN (1) = 0 GOTO 23031 23030 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23032 NLPAR = NLPAR + 1 GOTO 23033 23032 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23034 NLPAR = NLPAR - 1 23034 CONTINUE 23033 CONTINUE 23031 CONTINUE CALL OUTSTR (TOKEN) 23026 IF (.NOT.(NLPAR .LE. 0))GOTO 23025 23027 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23036 CALL SYNERR (33Hmissing parenthesis in condition.) 23036 CONTINUE RETURN END SUBROUTINE BRKNXT (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN INTEGER I, N INTEGER ALLDIG, CTOI LOGICAL*1 T, PTOKEN (100) LOGICAL*1 GNBTOK COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM N = 0 T = GNBTOK (PTOKEN, 100) IF (.NOT.(ALLDIG (PTOKEN) .EQ. 1))GOTO 23038 I = 1 N = CTOI (PTOKEN, I) - 1 GOTO 23039 23038 CONTINUE IF (.NOT.(T .NE. 59))GOTO 23040 CALL PBSTR (PTOKEN) 23040 CONTINUE 23039 CONTINUE I = SP 23042 IF (.NOT.(I .GT. 0))GOTO 23044 IF (.NOT.(LEXTYP (I) .EQ. -15 .OR. LEXTYP (I) .EQ. -10 .OR. LEXTYP * (I) .EQ. -16 .OR. LEXTYP (I) .EQ. -17))GOTO 23045 IF (.NOT.(N .GT. 0))GOTO 23047 N = N - 1 GOTO 23043 23047 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23049 CALL OUTGO (LABVAL (I) + 1) GOTO 23050 23049 CONTINUE CALL OUTGO (LABVAL (I)) 23050 CONTINUE 23048 CONTINUE XFER = 1 RETURN 23045 CONTINUE 23043 I = I - 1 GOTO 23042 23044 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23051 CALL SYNERR (14Hillegal break.) GOTO 23052 23051 CONTINUE CALL SYNERR (13Hillegal next.) 23052 CONTINUE RETURN END INTEGER FUNCTION CNDGET(TOKEN, TOKSIZ) LOGICAL*1 TOKEN(100) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER VALUE LOGICAL*1 PTOK(3) INTEGER LOOKUP LOGICAL*1 GTOK IF (.NOT.(CSP .GE. 10))GOTO 23053 CALL BADERR(31HConditionals nested too deeply.) 23053 CONTINUE CSP = CSP + 1 CNDSTK (CSP) = CURCND CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. 40))GOTO 23055 CALL BADERR(27Hmissing '(' in conditional.) 23055 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. -9))GOTO 23057 CALL BADERR(26Hinvalid conditional token.) 23057 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(PTOK, 3) .NE. 41))GOTO 23059 CALL BADERR(27Hmissing ')' in conditional.) 23059 CONTINUE IF (.NOT.(LOOKUP(TOKEN, VALUE, DEFTBL) .EQ. 1))GOTO 23061 CNDGET = 1 GOTO 23062 23061 CONTINUE CNDGET = -1 23062 CONTINUE RETURN END LOGICAL*1 FUNCTION CNDLU (TOKEN) LOGICAL*1 TOKEN(100) INTEGER INDEX, EQUAL INTEGER I, J LOGICAL*1 TEMP (9) LOGICAL*1 LETTS(5) LOGICAL*1 CNDTBL(35) DATA LETTS(1)/101/,LETTS(2)/69/,LETTS(3)/105/,LETTS(4)/73/,LETTS(5 *)/0/ DATA CNDTBL(1)/105/,CNDTBL(2)/102/,CNDTBL(3)/100/,CNDTBL(4)/101/,C *NDTBL(5)/102/,CNDTBL(6)/47/,CNDTBL(7)/32/,CNDTBL(8)/105/,CNDTBL(9) */102/,CNDTBL(10)/110/,CNDTBL(11)/111/,CNDTBL(12)/116/,CNDTBL(13)/1 *00/,CNDTBL(14)/101/,CNDTBL(15)/102/,CNDTBL(16)/47/,CNDTBL(17)/32/, *CNDTBL(18)/101/,CNDTBL(19)/108/,CNDTBL(20)/115/,CNDTBL(21)/101/,CN *DTBL(22)/100/,CNDTBL(23)/101/,CNDTBL(24)/102/,CNDTBL(25)/47/,CNDTB *L(26)/32/,CNDTBL(27)/101/,CNDTBL(28)/110/,CNDTBL(29)/100/,CNDTBL(3 *0)/100/,CNDTBL(31)/101/,CNDTBL(32)/102/,CNDTBL(33)/47/,CNDTBL(34)/ *32/,CNDTBL(35)/0/ DATA CNDTBL(7)/-15/,CNDTBL(17)/-16/,CNDTBL(26)/-17/, CNDTBL(34)/-1 *8/ CNDLU = -19 IF (.NOT.(INDEX (LETTS, TOKEN (1)) .GT. 0))GOTO 23063 I=1 23065 IF (.NOT.(CNDTBL(I) .NE. 0))GOTO 23067 J=1 23068 IF (.NOT.(CNDTBL(I) .NE. 47))GOTO 23070 TEMP(J) = CNDTBL(I) 23069 I=I+1 J=J+1 GOTO 23068 23070 CONTINUE TEMP(J) = 0 I = I + 1 J = EQUAL(TOKEN, TEMP) IF (.NOT.(J .EQ. 0))GOTO 23071 CALL UPPER(TEMP) J = EQUAL(TOKEN, TEMP) 23071 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23073 CNDLU = CNDTBL(I) GOTO 23067 23073 CONTINUE 23066 I=I+1 GOTO 23065 23067 CONTINUE 23063 CONTINUE RETURN END LOGICAL*1 FUNCTION DEFTOK (TOKEN, TOKSIZ) LOGICAL*1 TOKEN (100) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T, C, DEFN (250), MDEFN (250) LOGICAL*1 GCTOK INTEGER AP, ARGSTK (100), CALLST (50), NLB, PLEV (50), IFL INTEGER LUDEF, PUSH, IFPARM LOGICAL*1 BALP(3) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ CP = 0 AP = 1 EP = 1 T = GCTOK (TOKEN, TOKSIZ) 23075 IF (.NOT.(T .NE. -1))GOTO 23077 IF (.NOT.(T .EQ. -9))GOTO 23078 IF (.NOT.(LUDEF (TOKEN, DEFN, DEFTBL) .EQ. 0))GOTO 23080 IF (.NOT.(CP .EQ. 0))GOTO 23082 GOTO 23077 23082 CONTINUE CALL PUTTOK (TOKEN) 23083 CONTINUE GOTO 23081 23080 CONTINUE IF (.NOT.(DEFN (1) .EQ. -4))GOTO 23084 CALL GETDEF (TOKEN, TOKSIZ, DEFN, 250) CALL ENTDEF (TOKEN, DEFN, DEFTBL) GOTO 23085 23084 CONTINUE CP = CP + 1 IF (.NOT.(CP .GT. 50))GOTO 23086 CALL BADERR (20Hcall stack overflow.) 23086 CONTINUE CALLST (CP) = AP AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (DEFN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (TOKEN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. 32))GOTO 23088 T = GCTOK (TOKEN, TOKSIZ) CALL PBSTR (TOKEN) IF (.NOT.(T .NE. 40))GOTO 23090 CALL PUTBAK (32) 23090 CONTINUE GOTO 23089 23088 CONTINUE CALL PBSTR (TOKEN) 23089 CONTINUE IF (.NOT.(T .NE. 40))GOTO 23092 CALL PBSTR (BALP) GOTO 23093 23092 CONTINUE IF (.NOT.(IFPARM (DEFN) .EQ. 0))GOTO 23094 CALL PBSTR (BALP) 23094 CONTINUE 23093 CONTINUE PLEV (CP) = 0 23085 CONTINUE 23081 CONTINUE GOTO 23079 23078 CONTINUE IF (.NOT.(T .EQ. -10))GOTO 23096 NLB = 1 23098 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -10))GOTO 23101 NLB = NLB + 1 GOTO 23102 23101 CONTINUE IF (.NOT.(T .EQ. -11))GOTO 23103 NLB = NLB - 1 IF (.NOT.(NLB .EQ. 0))GOTO 23105 GOTO 23100 23105 CONTINUE GOTO 23104 23103 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23107 CALL BADERR (14HEOF in string.) 23107 CONTINUE 23104 CONTINUE 23102 CONTINUE CALL PUTTOK (TOKEN) 23099 GOTO 23098 23100 CONTINUE GOTO 23097 23096 CONTINUE IF (.NOT.(CP .EQ. 0))GOTO 23109 GOTO 23077 23109 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23111 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23113 CALL PUTTOK (TOKEN) 23113 CONTINUE PLEV (CP) = PLEV (CP) + 1 GOTO 23112 23111 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23115 PLEV (CP) = PLEV (CP) - 1 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23117 CALL PUTTOK (TOKEN) GOTO 23118 23117 CONTINUE CALL PUTCHR (0) CALL EVALR (ARGSTK, CALLST (CP), AP - 1) AP = CALLST (CP) EP = ARGSTK (AP) CP = CP - 1 23118 CONTINUE GOTO 23116 23115 CONTINUE IF (.NOT.(T .EQ. 44 .AND. PLEV (CP) .EQ. 1))GOTO 23119 CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) GOTO 23120 23119 CONTINUE CALL PUTTOK (TOKEN) 23120 CONTINUE 23116 CONTINUE 23112 CONTINUE 23110 CONTINUE 23097 CONTINUE 23079 CONTINUE 23076 T = GCTOK (TOKEN, TOKSIZ) GOTO 23075 23077 CONTINUE DEFTOK = T IF (.NOT.(T .EQ. -9))GOTO 23121 CALL FOLD (TOKEN) 23121 CONTINUE RETURN END SUBROUTINE DOARTH (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER K, L INTEGER CTOI LOGICAL*1 OP K = ARGSTK (I + 2) L = ARGSTK (I + 4) OP = EVALST (ARGSTK (I + 3)) IF (.NOT.(OP .EQ. 43))GOTO 23123 CALL PBNUM (CTOI (EVALST, K) + CTOI (EVALST, L)) GOTO 23124 23123 CONTINUE IF (.NOT.(OP .EQ. 45))GOTO 23125 CALL PBNUM (CTOI (EVALST, K) - CTOI (EVALST, L)) GOTO 23126 23125 CONTINUE IF (.NOT.(OP .EQ. 42 ))GOTO 23127 CALL PBNUM (CTOI (EVALST, K) * CTOI (EVALST, L)) GOTO 23128 23127 CONTINUE IF (.NOT.(OP .EQ. 47 ))GOTO 23129 CALL PBNUM (CTOI (EVALST, K) / CTOI (EVALST, L)) GOTO 23130 23129 CONTINUE CALL REMARK (11Harith error) 23130 CONTINUE 23128 CONTINUE 23126 CONTINUE 23124 CONTINUE RETURN END SUBROUTINE DOCODE (LAB) INTEGER LAB INTEGER LABGEN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GNBTOK LOGICAL*1 LEXSTR (100) LOGICAL*1 SDO(3) DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ XFER = 0 CALL OUTTAB CALL OUTSTR (SDO) CALL OUTCH (32) LAB = LABGEN (2) IF (.NOT.(GNBTOK (LEXSTR, 100) .EQ. 2))GOTO 23131 CALL OUTSTR (LEXSTR) GOTO 23132 23131 CONTINUE CALL PBSTR (LEXSTR) CALL OUTNUM (LAB) 23132 CONTINUE CALL OUTCH (32) CALL EATUP CALL OUTDON RETURN END SUBROUTINE DOIF (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER A2, A3, A4, A5 INTEGER EQUAL IF (.NOT.(J - I .LT. 5))GOTO 23133 RETURN 23133 CONTINUE A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) A4 = ARGSTK (I + 4) A5 = ARGSTK (I + 5) IF (.NOT.(EQUAL (EVALST (A2), EVALST (A3)) .EQ. 1))GOTO 23135 CALL PBSTR (EVALST (A4)) GOTO 23136 23135 CONTINUE CALL PBSTR (EVALST (A5)) 23136 CONTINUE RETURN END SUBROUTINE DOINCR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER K INTEGER CTOI K = ARGSTK (I + 2) CALL PBNUM (CTOI (EVALST, K) + 1) RETURN END SUBROUTINE DOMAC (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER A2, A3 IF (.NOT.(J - I .GT. 2))GOTO 23137 A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) CALL ENTDEF (EVALST (A2), EVALST (A3), DEFTBL) 23137 CONTINUE RETURN END SUBROUTINE DOSTAT (LAB) INTEGER LAB CALL OUTCON (LAB) CALL OUTCON (LAB + 1) RETURN END SUBROUTINE DOSUB (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER AP, FC, K, NC INTEGER CTOI, LENGTH IF (.NOT.(J - I .LT. 3))GOTO 23139 RETURN 23139 CONTINUE IF (.NOT.(J - I .LT. 4))GOTO 23141 NC = 100 GOTO 23142 23141 CONTINUE K = ARGSTK (I + 4) NC = CTOI (EVALST, K) 23142 CONTINUE K = ARGSTK (I + 3) AP = ARGSTK (I + 2) FC = AP + CTOI (EVALST, K) - 1 IF (.NOT.(FC .GE. AP .AND. FC .LT. AP + LENGTH (EVALST (AP))))GOTO * 23143 K = FC + MIN0(NC, LENGTH (EVALST (FC))) - 1 23145 IF (.NOT.(K .GE. FC))GOTO 23147 CALL PUTBAK (EVALST (K)) 23146 K = K - 1 GOTO 23145 23147 CONTINUE 23143 CONTINUE RETURN END LOGICAL*1 FUNCTION DOTHER(TOKEN) LOGICAL*1 TOKEN(100), T LOGICAL*1 GETTOK CALL OUTTAB 23148 CONTINUE T = GETTOK(TOKEN, 100) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 125))GOTO 23151 GOTO 23150 23151 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23153 CALL SYNERR(15Hunexpected EOF.) CALL PBSTR(TOKEN) GOTO 23150 23153 CONTINUE IF (.NOT.(T .NE. 10 .AND. T .NE. 95))GOTO 23155 CALL OUTSTR(TOKEN) 23155 CONTINUE 23149 GOTO 23148 23150 CONTINUE CALL OUTDON DOTHER=(T) RETURN END SUBROUTINE EATUP LOGICAL*1 PTOKEN (100), T, TOKEN (100) LOGICAL*1 GETTOK INTEGER NLPAR NLPAR = 0 23157 CONTINUE T = GETTOK (TOKEN, 100) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23160 GOTO 23159 23160 CONTINUE IF (.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23162 CALL PBSTR (TOKEN) GOTO 23159 23162 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23164 CALL SYNERR (15Hunexpected EOF.) CALL PBSTR (TOKEN) GOTO 23159 23164 CONTINUE IF (.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 . *OR. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. T * .EQ. 126 .OR. T .EQ. 33 .OR. T .EQ. 94 .OR. T .EQ. 61 .OR. T .EQ. * 95))GOTO 23166 23168 IF (.NOT.(GETTOK (PTOKEN, 100) .EQ. 10))GOTO 23169 GOTO 23168 23169 CONTINUE CALL PBSTR (PTOKEN) IF (.NOT.(T .EQ. 95))GOTO 23170 TOKEN (1) = 0 23170 CONTINUE 23166 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23172 NLPAR = NLPAR + 1 GOTO 23173 23172 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23174 NLPAR = NLPAR - 1 23174 CONTINUE 23173 CONTINUE CALL OUTSTR (TOKEN) 23158 IF (.NOT.(NLPAR .LT. 0))GOTO 23157 23159 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23176 CALL SYNERR (23Hunbalanced parentheses.) 23176 CONTINUE RETURN END INTEGER FUNCTION ELENTH(BUF) LOGICAL*1 BUF(100), C LOGICAL*1 ESC INTEGER I, N N = 0 I=1 23178 IF (.NOT.(BUF(I) .NE. 0))GOTO 23180 C = ESC(BUF, I) N = N + 1 23179 I=I+1 GOTO 23178 23180 CONTINUE ELENTH = N RETURN END SUBROUTINE ELSEIF (LAB) INTEGER LAB CALL OUTGO (LAB+1) CALL OUTCON (LAB) RETURN END SUBROUTINE ENTDKW LOGICAL*1 DEFT (2), INCT (2), SUBT (2), IFT (2), ART (2), MACT (2) LOGICAL*1 DEFNAM(7) LOGICAL*1 MACNAM(8) LOGICAL*1 INCNAM(5) LOGICAL*1 SUBNAM(7) LOGICAL*1 IFNAM(7) LOGICAL*1 ARNAM(6) DATA DEFNAM(1)/100/,DEFNAM(2)/101/,DEFNAM(3)/102/,DEFNAM(4)/105/,D *EFNAM(5)/110/,DEFNAM(6)/101/,DEFNAM(7)/0/ DATA MACNAM(1)/109/,MACNAM(2)/100/,MACNAM(3)/101/,MACNAM(4)/102/,M *ACNAM(5)/105/,MACNAM(6)/110/,MACNAM(7)/101/,MACNAM(8)/0/ DATA INCNAM(1)/105/,INCNAM(2)/110/,INCNAM(3)/99/,INCNAM(4)/114/,IN *CNAM(5)/0/ DATA SUBNAM(1)/115/,SUBNAM(2)/117/,SUBNAM(3)/98/,SUBNAM(4)/115/,SU *BNAM(5)/116/,SUBNAM(6)/114/,SUBNAM(7)/0/ DATA IFNAM(1)/105/,IFNAM(2)/102/,IFNAM(3)/101/,IFNAM(4)/108/,IFNAM *(5)/115/,IFNAM(6)/101/,IFNAM(7)/0/ DATA ARNAM(1)/97/,ARNAM(2)/114/,ARNAM(3)/105/,ARNAM(4)/116/,ARNAM( *5)/104/,ARNAM(6)/0/ DATA DEFT (1), DEFT (2) /-4, 0/ DATA MACT (1), MACT (2) /-10, 0/ DATA INCT (1), INCT (2) /-12, 0/ DATA SUBT (1), SUBT (2) /-13, 0/ DATA IFT (1), IFT (2) /-11, 0/ DATA ART (1), ART (2) /-14, 0/ CALL ULSTAL (DEFNAM, DEFT) CALL ULSTAL (MACNAM, MACT) CALL ULSTAL (INCNAM, INCT) CALL ULSTAL (SUBNAM, SUBT) CALL ULSTAL (IFNAM, IFT) CALL ULSTAL (ARNAM, ART) RETURN END SUBROUTINE ENTRKW COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER JUNK INTEGER ENTER LOGICAL*1 SIF(3) LOGICAL*1 SELSE(5) LOGICAL*1 SWHILE(6) LOGICAL*1 SDO(3) LOGICAL*1 SBREAK(6) LOGICAL*1 SNEXT(5) LOGICAL*1 SFOR(4) LOGICAL*1 SREPT(7) LOGICAL*1 SUNTIL(6) LOGICAL*1 SRET(7) LOGICAL*1 SSTR(7) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/0/ DATA SELSE(1)/101/,SELSE(2)/108/,SELSE(3)/115/,SELSE(4)/101/,SELSE *(5)/0/ DATA SWHILE(1)/119/,SWHILE(2)/104/,SWHILE(3)/105/,SWHILE(4)/108/,S *WHILE(5)/101/,SWHILE(6)/0/ DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ DATA SBREAK(1)/98/,SBREAK(2)/114/,SBREAK(3)/101/,SBREAK(4)/97/,SBR *EAK(5)/107/,SBREAK(6)/0/ DATA SNEXT(1)/110/,SNEXT(2)/101/,SNEXT(3)/120/,SNEXT(4)/116/,SNEXT *(5)/0/ DATA SFOR(1)/102/,SFOR(2)/111/,SFOR(3)/114/,SFOR(4)/0/ DATA SREPT(1)/114/,SREPT(2)/101/,SREPT(3)/112/,SREPT(4)/101/,SREPT *(5)/97/,SREPT(6)/116/,SREPT(7)/0/ DATA SUNTIL(1)/117/,SUNTIL(2)/110/,SUNTIL(3)/116/,SUNTIL(4)/105/,S *UNTIL(5)/108/,SUNTIL(6)/0/ DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA SSTR(1)/115/,SSTR(2)/116/,SSTR(3)/114/,SSTR(4)/105/,SSTR(5)/1 *10/,SSTR(6)/103/,SSTR(7)/0/ JUNK = ENTER (SIF, -19, RKWTBL) JUNK = ENTER (SELSE, -11, RKWTBL) JUNK = ENTER (SWHILE, -15, RKWTBL) JUNK = ENTER (SDO, -10, RKWTBL) JUNK = ENTER (SBREAK, -8, RKWTBL) JUNK = ENTER (SNEXT, -13, RKWTBL) JUNK = ENTER (SFOR, -16, RKWTBL) JUNK = ENTER (SREPT, -17, RKWTBL) JUNK = ENTER (SUNTIL, -18, RKWTBL) JUNK = ENTER (SRET, -20, RKWTBL) JUNK = ENTER (SSTR, -23, RKWTBL) RETURN END SUBROUTINE EVALR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER ARGNO, K, M, N, T, TD INTEGER INDEX, LENGTH LOGICAL*1 DIGITS(11) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ T = ARGSTK (I) TD = EVALST (T) IF (.NOT.(TD .EQ. -10))GOTO 23181 CALL DOMAC (ARGSTK, I, J) GOTO 23182 23181 CONTINUE IF (.NOT.(TD .EQ. -12))GOTO 23183 CALL DOINCR (ARGSTK, I, J) GOTO 23184 23183 CONTINUE IF (.NOT.(TD .EQ. -13))GOTO 23185 CALL DOSUB (ARGSTK, I, J) GOTO 23186 23185 CONTINUE IF (.NOT.(TD .EQ. -11))GOTO 23187 CALL DOIF (ARGSTK, I, J) GOTO 23188 23187 CONTINUE IF (.NOT.(TD .EQ. -14))GOTO 23189 CALL DOARTH (ARGSTK, I, J) GOTO 23190 23189 CONTINUE K = T + LENGTH (EVALST (T)) - 1 23191 IF (.NOT.(K .GT. T))GOTO 23193 IF (.NOT.(EVALST (K - 1) .NE. 36))GOTO 23194 CALL PUTBAK (EVALST (K)) GOTO 23195 23194 CONTINUE ARGNO = INDEX (DIGITS, EVALST (K)) - 1 IF (.NOT.(ARGNO .GE. 0 .AND. ARGNO .LT. J - I))GOTO 23196 N = I + ARGNO + 1 M = ARGSTK (N) CALL PBSTR (EVALST (M)) 23196 CONTINUE K = K - 1 23195 CONTINUE 23192 K = K - 1 GOTO 23191 23193 CONTINUE IF (.NOT.(K .EQ. T))GOTO 23198 CALL PUTBAK (EVALST (K)) 23198 CONTINUE 23190 CONTINUE 23188 CONTINUE 23186 CONTINUE 23184 CONTINUE 23182 CONTINUE RETURN END SUBROUTINE FCLAUS LOGICAL*1 GNBTOK, DOTHER LOGICAL*1 TOKEN(100), T INTEGER BRACE IF (.NOT.(GNBTOK(TOKEN, 100) .EQ. 123))GOTO 23200 BRACE = 1 GOTO 23201 23200 CONTINUE CALL PBSTR(TOKEN) BRACE = 0 23201 CONTINUE T = DOTHER(TOKEN) IF (.NOT.(BRACE .EQ. 1))GOTO 23202 23204 IF (.NOT.(T .NE. 125 .AND. T .NE. -1))GOTO 23205 T = GNBTOK(TOKEN, 100) CALL PBSTR(TOKEN) T = DOTHER(TOKEN) GOTO 23204 23205 CONTINUE IF (.NOT.(GNBTOK(TOKEN, 100) .NE. 59))GOTO 23206 CALL SYNERR(19Hinvalid for clause.) 23206 CONTINUE 23202 CONTINUE RETURN END SUBROUTINE FINIT COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM OUTP = 0 LEVEL = 1 LINECT (1) = 1 SBP = 1 FNAMP = 2 FNAMES (1) = 0 BP = 0 FORDEP = 0 FCNAME (1) = 0 CSP = 0 CURCND = 1 RETURN END SUBROUTINE FORCOD (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T, TOKEN (100) LOGICAL*1 GETTOK, GNBTOK INTEGER I, J, NLPAR, LEN INTEGER LENGTH, LABGEN LOGICAL*1 IFNOT(10) LOGICAL*1 SEMI(2) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/32/,IFNOT(4)/40/,IFNOT(5 *)/46/,IFNOT(6)/110/,IFNOT(7)/111/,IFNOT(8)/116/,IFNOT(9)/46/,IFNOT *(10)/0/ DATA SEMI(1)/59/,SEMI(2)/0/ LAB = LABGEN (3) CALL OUTCON (0) IF (.NOT.(GNBTOK (TOKEN, 100) .NE. 40))GOTO 23208 CALL SYNERR (19Hmissing left paren.) RETURN 23208 CONTINUE IF (.NOT.(GNBTOK (TOKEN, 100) .NE. 59))GOTO 23210 CALL PBSTR (TOKEN) CALL FCLAUS 23210 CONTINUE IF (.NOT.(GNBTOK (TOKEN, 100) .EQ. 59))GOTO 23212 CALL OUTCON (LAB) GOTO 23213 23212 CONTINUE CALL PBSTR (TOKEN) CALL OUTNUM (LAB) CALL OUTTAB CALL OUTSTR (IFNOT) CALL OUTCH (40) NLPAR = 0 23214 IF (.NOT.(NLPAR .GE. 0))GOTO 23215 T = GETTOK (TOKEN, 100) IF (.NOT.(T .EQ. 59))GOTO 23216 GOTO 23215 23216 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23218 NLPAR = NLPAR + 1 GOTO 23219 23218 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23220 NLPAR = NLPAR - 1 23220 CONTINUE 23219 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23222 CALL PBSTR (TOKEN) RETURN 23222 CONTINUE IF (.NOT.(T .NE. 10 .AND. T .NE. 95))GOTO 23224 CALL OUTSTR (TOKEN) 23224 CONTINUE GOTO 23214 23215 CONTINUE CALL OUTCH (41) CALL OUTCH (41) CALL OUTGO (LAB+2) IF (.NOT.(NLPAR .LT. 0))GOTO 23226 CALL SYNERR (19Hinvalid for clause.) 23226 CONTINUE 23213 CONTINUE FORDEP = FORDEP + 1 LEN = 0 J = 1 I = 1 23228 IF (.NOT.(I .LT. FORDEP))GOTO 23230 J = J + LENGTH (FORSTK (J)) + 1 23229 I = I + 1 GOTO 23228 23230 CONTINUE FORSTK (J) = 0 NLPAR = 0 T = GNBTOK (TOKEN, 100) CALL PBSTR (TOKEN) 23231 IF (.NOT.(NLPAR .GE. 0))GOTO 23232 T = GETTOK (TOKEN, 100) IF (.NOT.(T .EQ. 40))GOTO 23233 NLPAR = NLPAR + 1 GOTO 23234 23233 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23235 NLPAR = NLPAR - 1 23235 CONTINUE 23234 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23237 CALL PBSTR (TOKEN) GOTO 23232 23237 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10 .AND. T .NE. 95))GOTO 23239 IF (.NOT.(J + LENGTH (TOKEN) .GE. 300))GOTO 23241 CALL BADERR (20Hfor clause too long.) 23241 CONTINUE CALL SCOPY (TOKEN, 1, FORSTK, J) J = J + LENGTH (TOKEN) LEN = LEN + LENGTH (TOKEN) GOTO 23240 23239 CONTINUE IF (.NOT.(NLPAR .EQ. -1 .AND. LEN .GT. 0))GOTO 23243 IF (.NOT.(J .LT. 300))GOTO 23245 CALL SCOPY(SEMI, 1, FORSTK, J) GOTO 23246 23245 CONTINUE CALL BADERR(20Hfor clause too long.) 23246 CONTINUE 23243 CONTINUE 23240 CONTINUE GOTO 23231 23232 CONTINUE LAB = LAB + 1 RETURN END SUBROUTINE FORS (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I, J INTEGER LENGTH XFER = 0 CALL OUTNUM (LAB) J = 1 I = 1 23247 IF (.NOT.(I .LT. FORDEP))GOTO 23249 J = J + LENGTH (FORSTK (J)) + 1 23248 I = I + 1 GOTO 23247 23249 CONTINUE IF (.NOT.(LENGTH (FORSTK (J)) .GT. 0))GOTO 23250 CALL PBSTR (FORSTK (J)) CALL FCLAUS 23250 CONTINUE CALL OUTGO (LAB - 1) CALL OUTCON (LAB + 1) FORDEP = FORDEP - 1 RETURN END LOGICAL*1 FUNCTION GCTOK(TOKEN, TOKSIZ) LOGICAL*1 TOKEN(100) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GTOK, CNDLU LOGICAL*1 C INTEGER CNDGET INTEGER NEWCND GCTOK=GTOK(TOKEN,TOKSIZ) 23252 IF (.NOT.(GCTOK .NE. -1))GOTO 23254 C = CNDLU (TOKEN) IF (.NOT.(C .EQ. -19))GOTO 23255 IF (.NOT.(CURCND .EQ. 1))GOTO 23257 GOTO 23254 23257 CONTINUE GOTO 23256 23255 CONTINUE IF (.NOT.(C .EQ. -18))GOTO 23259 IF (.NOT.(CSP .LE. 0))GOTO 23261 CALL BADERR(27HIllegal enddef encountered.) 23261 CONTINUE CURCND = CNDSTK(CSP) CSP = CSP - 1 GOTO 23260 23259 CONTINUE IF (.NOT.(C .EQ. -15))GOTO 23263 NEWCND = CNDGET (TOKEN, TOKSIZ) GOTO 23264 23263 CONTINUE IF (.NOT.(C .EQ. -16))GOTO 23265 NEWCND = - CNDGET (TOKEN, TOKSIZ) GOTO 23266 23265 CONTINUE NEWCND = - CURCND 23266 CONTINUE 23264 CONTINUE CURCND = MIN0(NEWCND, CNDSTK (CSP) ) 23260 CONTINUE 23256 CONTINUE 23253 GCTOK=GTOK(TOKEN,TOKSIZ) GOTO 23252 23254 CONTINUE RETURN END SUBROUTINE GETDEF (TOKEN, TOKSIZ, DEFN, DEFSIZ) LOGICAL*1 TOKEN (100), DEFN (250) INTEGER TOKSIZ, DEFSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C, T, PTOKEN (100) LOGICAL*1 GCTOK, NGETCH INTEGER I, NLPAR CALL SKPBLK C = GCTOK (PTOKEN, 100) IF (.NOT.(C .EQ. 40))GOTO 23267 T = 40 GOTO 23268 23267 CONTINUE T = 32 CALL PBSTR (PTOKEN) 23268 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK (TOKEN, TOKSIZ) .NE. -9))GOTO 23269 CALL BADERR (22Hnon-alphanumeric name.) 23269 CONTINUE CALL SKPBLK C = GCTOK (PTOKEN, 100) IF (.NOT.(T .EQ. 32))GOTO 23271 CALL PBSTR (PTOKEN) I = 1 23273 CONTINUE C = NGETCH (C) IF (.NOT.(I .GT. DEFSIZ))GOTO 23276 CALL BADERR (20Hdefinition too long.) 23276 CONTINUE DEFN (I) = C I = I + 1 23274 IF (.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. -1))GOTO 23273 23275 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23278 CALL PUTBAK (C) 23278 CONTINUE GOTO 23272 23271 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23280 IF (.NOT.(C .NE. 44))GOTO 23282 CALL BADERR (24Hmissing comma in define.) 23282 CONTINUE NLPAR = 0 I = 1 23284 IF (.NOT.(NLPAR .GE. 0))GOTO 23286 IF (.NOT.(I .GT. DEFSIZ))GOTO 23287 CALL BADERR (20Hdefinition too long.) GOTO 23288 23287 CONTINUE IF (.NOT.(NGETCH (DEFN (I)) .EQ. -1))GOTO 23289 CALL BADERR (20Hmissing right paren.) GOTO 23290 23289 CONTINUE IF (.NOT.(DEFN (I) .EQ. 40))GOTO 23291 NLPAR = NLPAR + 1 GOTO 23292 23291 CONTINUE IF (.NOT.(DEFN (I) .EQ. 41))GOTO 23293 NLPAR = NLPAR - 1 23293 CONTINUE 23292 CONTINUE 23290 CONTINUE 23288 CONTINUE 23285 I = I + 1 GOTO 23284 23286 CONTINUE GOTO 23281 23280 CONTINUE CALL BADERR (19Hgetdef is confused.) 23281 CONTINUE 23272 CONTINUE DEFN (I - 1) = 0 RETURN END LOGICAL*1 FUNCTION GETTOK (TOKEN, TOKSIZ) LOGICAL*1 TOKEN (100) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I, LEN INTEGER EQUAL, OPEN, LENGTH LOGICAL*1 NAME (40), T LOGICAL*1 DEFTOK LOGICAL*1 FNCN(9) LOGICAL*1 INCL(8) DATA FNCN(1)/102/,FNCN(2)/117/,FNCN(3)/110/,FNCN(4)/99/,FNCN(5)/11 *6/,FNCN(6)/105/,FNCN(7)/111/,FNCN(8)/110/,FNCN(9)/0/ DATA INCL(1)/105/,INCL(2)/110/,INCL(3)/99/,INCL(4)/108/,INCL(5)/11 *7/,INCL(6)/100/,INCL(7)/101/,INCL(8)/0/ 23295 IF (.NOT.(LEVEL .GT. 0))GOTO 23297 GETTOK = DEFTOK (TOKEN, TOKSIZ) 23298 IF (.NOT.(GETTOK .NE. -1))GOTO 23300 IF (.NOT.(EQUAL (TOKEN, FNCN) .EQ. 1))GOTO 23301 CALL SKPBLK T = DEFTOK (FCNAME, 40) CALL PBSTR (FCNAME) IF (.NOT.(T .NE. -9))GOTO 23303 CALL SYNERR (22Hmissing function name.) 23303 CONTINUE CALL PUTBAK (32) RETURN 23301 CONTINUE IF (.NOT.(EQUAL (TOKEN, INCL) .EQ. 0))GOTO 23305 RETURN 23305 CONTINUE 23302 CONTINUE CALL SKPBLK T = DEFTOK (NAME, 40) IF (.NOT.(T .EQ. 39 .OR. T .EQ. 34))GOTO 23307 LEN = LENGTH (NAME) - 1 I = 1 23309 IF (.NOT.(I .LT. LEN))GOTO 23311 NAME (I) = NAME (I + 1) 23310 I = I + 1 GOTO 23309 23311 CONTINUE NAME (I) = 0 23307 CONTINUE I = LENGTH (NAME) + 1 IF (.NOT.(LEVEL .GE. 4))GOTO 23312 CALL SYNERR (27Hincludes nested too deeply.) GOTO 23313 23312 CONTINUE INFILE (LEVEL + 1) = OPEN (NAME, 1) LINECT (LEVEL + 1) = 1 IF (.NOT.(INFILE (LEVEL + 1) .EQ. -3))GOTO 23314 CALL SYNERR (19Hcan't open include.) GOTO 23315 23314 CONTINUE LEVEL = LEVEL + 1 IF (.NOT.(FNAMP + I .LE. 160))GOTO 23316 CALL SCOPY (NAME, 1, FNAMES, FNAMP) FNAMP = FNAMP + I 23316 CONTINUE 23315 CONTINUE 23313 CONTINUE 23299 GETTOK = DEFTOK (TOKEN, TOKSIZ) GOTO 23298 23300 CONTINUE IF (.NOT.(LEVEL .GT. 1))GOTO 23318 CALL CLOSE (INFILE (LEVEL)) FNAMP = FNAMP - 1 23320 IF (.NOT.(FNAMP .GT. 1))GOTO 23322 IF (.NOT.(FNAMES (FNAMP - 1) .EQ. 0))GOTO 23323 GOTO 23322 23323 CONTINUE 23321 FNAMP = FNAMP - 1 GOTO 23320 23322 CONTINUE 23318 CONTINUE 23296 LEVEL = LEVEL - 1 GOTO 23295 23297 CONTINUE TOKEN (1) = -1 TOKEN (2) = 0 GETTOK = -1 RETURN END LOGICAL*1 FUNCTION GNBTOK (TOKEN, TOKSIZ) LOGICAL*1 TOKEN (100) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GETTOK 23325 CONTINUE CALL SKPBLK GNBTOK = GETTOK (TOKEN, TOKSIZ) 23326 IF (.NOT.(GNBTOK .NE. 32))GOTO 23325 23327 CONTINUE RETURN END LOGICAL*1 FUNCTION GTOK (LEXSTR, TOKSIZ) LOGICAL*1 LEXSTR (100) INTEGER TOKSIZ COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C LOGICAL*1 NGETCH, TYPE, CLOWER INTEGER I, B, N, D INTEGER ITOC, INDEX LOGICAL*1 DIGITS(37) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/97/,DIGITS(12)/98/,DIGITS(13)/99/,DIGITS( *14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/,DIGITS(18 *)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/,DIGITS(22)/ *108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/,DIGITS(26)/11 *2/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/,DIGITS(30)/116/ *,DIGITS(31)/117/,DIGITS(32)/118/,DIGITS(33)/119/,DIGITS(34)/120/,D *IGITS(35)/121/,DIGITS(36)/122/,DIGITS(37)/0/ C = NGETCH (LEXSTR (1)) IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23328 LEXSTR (1) = 32 23330 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23331 C = NGETCH (C) GOTO 23330 23331 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23332 23334 IF (.NOT.(NGETCH (C) .NE. 10))GOTO 23335 GOTO 23334 23335 CONTINUE 23332 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23336 CALL PUTBAK (C) GOTO 23337 23336 CONTINUE LEXSTR (1) = 10 23337 CONTINUE LEXSTR (2) = 0 GTOK = LEXSTR (1) RETURN 23328 CONTINUE I = 1 IF (.NOT.(((65.LE.C.AND.C.LE.90).OR.(97.LE.C.AND.C.LE.122))))GOTO *23338 I = 1 23340 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23342 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(.NOT.((65.LE.C.AND.C.LE.90).OR.(97.LE.C.AND.C.LE.122)) . *AND. .NOT.(48.LE.C.AND.C.LE.57) .AND. C .NE. 95))GOTO 23343 GOTO 23342 23343 CONTINUE 23341 I = I + 1 GOTO 23340 23342 CONTINUE CALL PUTBAK (C) GTOK = -9 GOTO 23339 23338 CONTINUE IF (.NOT.((48.LE.C.AND.C.LE.57)))GOTO 23345 B = C - 48 I = 1 23347 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23349 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(.NOT.(48.LE.C.AND.C.LE.57)))GOTO 23350 GOTO 23349 23350 CONTINUE B = 10 * B + C - 48 23348 I = I + 1 GOTO 23347 23349 CONTINUE IF (.NOT.(C .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO 23352 N = 0 23354 CONTINUE D = INDEX (DIGITS, CLOWER (NGETCH (C))) - 1 IF (.NOT.(D .LT. 0))GOTO 23357 GOTO 23356 23357 CONTINUE N = B * N + D 23355 GOTO 23354 23356 CONTINUE CALL PUTBAK (C) I = ITOC (N, LEXSTR, TOKSIZ) GOTO 23353 23352 CONTINUE CALL PUTBAK (C) 23353 CONTINUE GTOK = 2 GOTO 23346 23345 CONTINUE IF (.NOT.(C .EQ. 91))GOTO 23359 LEXSTR (1) = 123 GTOK = 123 GOTO 23360 23359 CONTINUE IF (.NOT.(C .EQ. 93))GOTO 23361 LEXSTR (1) = 125 GTOK = 125 GOTO 23362 23361 CONTINUE IF (.NOT.(C .EQ. 36))GOTO 23363 IF (.NOT.(NGETCH (LEXSTR (2)) .EQ. 40))GOTO 23365 I = 2 GTOK = -10 GOTO 23366 23365 CONTINUE IF (.NOT.(LEXSTR (2) .EQ. 41))GOTO 23367 I = 2 GTOK = -11 GOTO 23368 23367 CONTINUE CALL PUTBAK (LEXSTR (2)) GTOK = 36 23368 CONTINUE 23366 CONTINUE GOTO 23364 23363 CONTINUE IF (.NOT.(C .EQ. 39 .OR. C .EQ. 34))GOTO 23369 GTOK = C I = 2 23371 IF (.NOT.(NGETCH (LEXSTR (I)) .NE. LEXSTR (1)))GOTO 23373 IF (.NOT.(LEXSTR (I) .EQ. 95))GOTO 23374 IF (.NOT.(NGETCH (C) .EQ. 10))GOTO 23376 23378 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23379 C = NGETCH (C) GOTO 23378 23379 CONTINUE LEXSTR (I) = C GOTO 23377 23376 CONTINUE CALL PUTBAK (C) 23377 CONTINUE 23374 CONTINUE IF (.NOT.(LEXSTR (I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23380 CALL SYNERR (14Hmissing quote.) LEXSTR (I) = LEXSTR (1) CALL PUTBAK (10) GOTO 23373 23380 CONTINUE 23372 I = I + 1 GOTO 23371 23373 CONTINUE GOTO 23370 23369 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23382 23384 IF (.NOT.(NGETCH (LEXSTR (1)) .NE. 10))GOTO 23385 GOTO 23384 23385 CONTINUE GTOK = 10 GOTO 23383 23382 CONTINUE IF (.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 33 .OR. C .EQ. 33 . *OR. C .EQ. 126 .OR. C .EQ. 94 .OR. C .EQ. 61 .OR. C .EQ. 38 .OR. C * .EQ. 124))GOTO 23386 CALL RELATE (LEXSTR, I) GTOK = C GOTO 23387 23386 CONTINUE GTOK = C 23387 CONTINUE 23383 CONTINUE 23370 CONTINUE 23364 CONTINUE 23362 CONTINUE 23360 CONTINUE 23346 CONTINUE 23339 CONTINUE IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23388 CALL SYNERR (15Htoken too long.) 23388 CONTINUE LEXSTR (I + 1) = 0 RETURN END SUBROUTINE IFCODE (LAB) INTEGER LAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER LABGEN XFER = 0 LAB = LABGEN (2) CALL IFGO (LAB) RETURN END SUBROUTINE IFGO (LAB) INTEGER LAB LOGICAL*1 IFNOT(10) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/32/,IFNOT(4)/40/,IFNOT(5 *)/46/,IFNOT(6)/110/,IFNOT(7)/111/,IFNOT(8)/116/,IFNOT(9)/46/,IFNOT *(10)/0/ CALL OUTTAB CALL OUTSTR (IFNOT) CALL BALPAR CALL OUTCH (41) CALL OUTGO (LAB) RETURN END INTEGER FUNCTION IFPARM (STRNG) LOGICAL*1 STRNG (100) LOGICAL*1 C INTEGER I, INDEX, TYPE C = STRNG (1) IF (.NOT.(C .EQ. -12 .OR. C .EQ. -13 .OR. C .EQ. -11 .OR. C .EQ. - *14 .OR. C .EQ. -10))GOTO 23390 IFPARM = 1 GOTO 23391 23390 CONTINUE IFPARM = 0 I = 1 23392 IF (.NOT.(INDEX (STRNG (I), 36) .GT. 0))GOTO 23394 I = I + INDEX (STRNG (I), 36) IF (.NOT.(TYPE (STRNG (I)) .EQ. 2))GOTO 23395 IF (.NOT.(TYPE (STRNG (I + 1)) .NE. 2))GOTO 23397 IFPARM = 1 GOTO 23394 23397 CONTINUE 23395 CONTINUE 23393 GOTO 23392 23394 CONTINUE 23391 CONTINUE RETURN END SUBROUTINE INITKW COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER MKTABL CALL DSINIT (5000) DEFTBL = MKTABL (1) CALL ENTDKW RKWTBL = MKTABL (1) CALL ENTRKW LABEL = 23000 RETURN END SUBROUTINE LABELC (LEXSTR) LOGICAL*1 LEXSTR (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER LENGTH XFER = 0 IF (.NOT.(LENGTH (LEXSTR) .EQ. 5))GOTO 23399 IF (.NOT.(LEXSTR (1) .EQ. 50 .AND. LEXSTR (2) .EQ. 51))GOTO 23401 CALL SYNERR (33Hwarning: possible label conflict.) 23401 CONTINUE 23399 CONTINUE CALL OUTSTR (LEXSTR) CALL OUTTAB RETURN END INTEGER FUNCTION LABGEN (N) INTEGER N COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LABGEN = LABEL LABEL = LABEL + N RETURN END INTEGER FUNCTION LEX (LEXSTR) LOGICAL*1 LEXSTR (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GNBTOK INTEGER LOOKUP LEX = GNBTOK (LEXSTR, 100) 23403 IF (.NOT.(LEX .EQ. 10))GOTO 23405 23404 LEX = GNBTOK (LEXSTR, 100) GOTO 23403 23405 CONTINUE IF (.NOT.(LEX .EQ. -1 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LEX *.EQ. 125))GOTO 23406 RETURN 23406 CONTINUE IF (.NOT.(LEX .EQ. 2))GOTO 23408 LEX = -9 GOTO 23409 23408 CONTINUE IF (.NOT.(LEX .EQ. 37))GOTO 23410 LEX = -27 GOTO 23411 23410 CONTINUE IF (.NOT.(LOOKUP (LEXSTR, LEX, RKWTBL) .EQ. 1))GOTO 23412 GOTO 23413 23412 CONTINUE LEX = -14 23413 CONTINUE 23411 CONTINUE 23409 CONTINUE RETURN END SUBROUTINE LITRAL COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 NGETCH IF (.NOT.(OUTP .GT. 0))GOTO 23414 CALL OUTDON 23414 CONTINUE OUTP = 1 23416 IF (.NOT.(NGETCH (OUTBUF (OUTP)) .NE. 10))GOTO 23418 23417 OUTP = OUTP + 1 GOTO 23416 23418 CONTINUE OUTP = OUTP - 1 CALL OUTDON RETURN END SUBROUTINE LODSYM(FBUF) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER OPEN, LOCCOM LOGICAL*1 FBUF(40), PATH(120) LOGICAL*1 DEFNS(8) LOGICAL*1 SUFFIX(3) DATA DEFNS(1)/115/,DEFNS(2)/121/,DEFNS(3)/109/,DEFNS(4)/98/,DEFNS( *5)/111/,DEFNS(6)/108/,DEFNS(7)/115/,DEFNS(8)/0/ DATA SUFFIX(1)/0/,SUFFIX(2)/10/,SUFFIX(3)/0/ IF (.NOT.(DEFNS(1) .NE. 0))GOTO 23419 CALL IMPATH(PATH) IF (.NOT.(LOCCOM(DEFNS, PATH, SUFFIX, FBUF) .EQ. 12))GOTO 23421 INFILE(1) = OPEN(FBUF, 1) IF (.NOT.(INFILE(1) .EQ. -3))GOTO 23423 CALL REMARK(38Hcannot open standard definitions file.) GOTO 23424 23423 CONTINUE CALL PARSE CALL CLOSE(INFILE(1)) 23424 CONTINUE GOTO 23422 23421 CONTINUE CALL REMARK(40Hcannot locate standard definitions file.) 23422 CONTINUE 23419 CONTINUE RETURN END LOGICAL*1 FUNCTION NGETCH (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 GETCH IF (.NOT.(BP .GT. 0))GOTO 23425 C = BUF(BP) BP = BP - 1 GOTO 23426 23425 CONTINUE C = GETCH(C, INFILE (LEVEL) ) IF (.NOT.(C .EQ. 10))GOTO 23427 LINECT (LEVEL) = LINECT (LEVEL) + 1 23427 CONTINUE 23426 CONTINUE NGETCH=(C) RETURN END SUBROUTINE OTHERC (LEXSTR) LOGICAL*1 LEXSTR (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM XFER = 0 CALL OUTTAB CALL OUTSTR (LEXSTR) CALL EATUP CALL OUTDON RETURN END SUBROUTINE OUTCH (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM INTEGER I IF (.NOT.(OUTP .GE. 72))GOTO 23429 CALL OUTDON I = 1 23431 IF (.NOT.(I .LT. 6))GOTO 23433 OUTBUF (I) = 32 23432 I = I + 1 GOTO 23431 23433 CONTINUE OUTBUF (6) = 42 OUTP = 6 23429 CONTINUE OUTP = OUTP + 1 OUTBUF (OUTP) = C RETURN END SUBROUTINE OUTCON (N) INTEGER N COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 CONTIN(9) DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/,CO *NTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN(9 *)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0))GOTO 23434 RETURN 23434 CONTINUE IF (.NOT.(N .GT. 0))GOTO 23436 CALL OUTNUM (N) 23436 CONTINUE CALL OUTTAB CALL OUTSTR (CONTIN) CALL OUTDON RETURN END SUBROUTINE OUTDON COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM OUTBUF (OUTP + 1) = 10 OUTBUF (OUTP + 2) = 0 CALL PUTLIN (OUTBUF, 2) OUTP = 0 RETURN END SUBROUTINE OUTGO (N) INTEGER N COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 SGOTO(6) DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/0/ IF (.NOT.(XFER .EQ. 1))GOTO 23438 RETURN 23438 CONTINUE CALL OUTTAB CALL OUTSTR (SGOTO) CALL OUTNUM (N) CALL OUTDON RETURN END SUBROUTINE OUTNUM (N) INTEGER N LOGICAL*1 CHARS (20) INTEGER I, M M = IABS (N) I = 0 23440 CONTINUE I = I + 1 CHARS (I) = MOD (M, 10) + 48 M = M / 10 23441 IF (.NOT.(M .EQ. 0 .OR. I .GE. 20))GOTO 23440 23442 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23443 CALL OUTCH (45) 23443 CONTINUE 23445 IF (.NOT.(I .GT. 0))GOTO 23447 CALL OUTCH (CHARS (I)) 23446 I = I - 1 GOTO 23445 23447 CONTINUE RETURN END SUBROUTINE OUTSTR (STR) LOGICAL*1 STR (100) LOGICAL*1 C LOGICAL*1 CUPPER INTEGER I, J I = 1 23448 IF (.NOT.(STR (I) .NE. 0))GOTO 23450 C = STR (I) IF (.NOT.(C .NE. 39 .AND. C .NE. 34))GOTO 23451 CALL OUTCH (CUPPER (C)) GOTO 23452 23451 CONTINUE I = I + 1 J = I 23453 IF (.NOT.(STR (J) .NE. C))GOTO 23455 23454 J = J + 1 GOTO 23453 23455 CONTINUE CALL OUTNUM (J - I) CALL OUTCH (72) 23456 IF (.NOT.(I .LT. J))GOTO 23458 CALL OUTCH (STR (I)) 23457 I = I + 1 GOTO 23456 23458 CONTINUE 23452 CONTINUE 23449 I = I + 1 GOTO 23448 23450 CONTINUE RETURN END SUBROUTINE OUTTAB COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM 23459 IF (.NOT.(OUTP .LT. 6))GOTO 23460 CALL OUTCH (32) GOTO 23459 23460 CONTINUE RETURN END SUBROUTINE PARSE COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 LEXSTR (100) INTEGER LAB, LABVAL (100), LEXTYP (100), SP, TOKEN, I INTEGER LEX CALL FINIT SP = 1 LEXTYP (1) = -1 TOKEN = LEX (LEXSTR) 23461 IF (.NOT.(TOKEN .NE. -1))GOTO 23463 IF (.NOT.(TOKEN .EQ. -19))GOTO 23464 CALL IFCODE (LAB) GOTO 23465 23464 CONTINUE IF (.NOT.(TOKEN .EQ. -10))GOTO 23466 CALL DOCODE (LAB) GOTO 23467 23466 CONTINUE IF (.NOT.(TOKEN .EQ. -15))GOTO 23468 CALL WHILEC (LAB) GOTO 23469 23468 CONTINUE IF (.NOT.(TOKEN .EQ. -16))GOTO 23470 CALL FORCOD (LAB) GOTO 23471 23470 CONTINUE IF (.NOT.(TOKEN .EQ. -17))GOTO 23472 CALL REPCOD (LAB) GOTO 23473 23472 CONTINUE IF (.NOT.(TOKEN .EQ. -9))GOTO 23474 CALL LABELC (LEXSTR) GOTO 23475 23474 CONTINUE IF (.NOT.(TOKEN .EQ. -11))GOTO 23476 IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23478 CALL ELSEIF (LABVAL (SP)) GOTO 23479 23478 CONTINUE CALL SYNERR (13Hillegal else.) 23479 CONTINUE GOTO 23477 23476 CONTINUE IF (.NOT.(TOKEN .EQ. -27))GOTO 23480 CALL LITRAL 23480 CONTINUE 23477 CONTINUE 23475 CONTINUE 23473 CONTINUE 23471 CONTINUE 23469 CONTINUE 23467 CONTINUE 23465 CONTINUE IF (.NOT.(TOKEN .EQ. -19 .OR. TOKEN .EQ. -11 .OR. TOKEN .EQ. -15 . *OR. TOKEN .EQ. -16 .OR. TOKEN .EQ. -17 .OR. TOKEN .EQ. -10 .OR. T *OKEN .EQ. -9 .OR. TOKEN .EQ. 123))GOTO 23482 SP = SP + 1 IF (.NOT.(SP .GT. 100))GOTO 23484 CALL BADERR (25Hstack overflow in parser.) 23484 CONTINUE LEXTYP (SP) = TOKEN LABVAL (SP) = LAB GOTO 23483 23482 CONTINUE IF (.NOT.(TOKEN .NE. -25 .AND. TOKEN .NE. -26))GOTO 23486 IF (.NOT.(TOKEN .EQ. 125))GOTO 23488 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23490 SP = SP - 1 GOTO 23491 23490 CONTINUE CALL SYNERR (20Hillegal right brace.) 23491 CONTINUE GOTO 23489 23488 CONTINUE IF (.NOT.(TOKEN .EQ. -14))GOTO 23492 CALL OTHERC (LEXSTR) GOTO 23493 23492 CONTINUE IF (.NOT.(TOKEN .EQ. -8 .OR. TOKEN .EQ. -13))GOTO 23494 CALL BRKNXT (SP, LEXTYP, LABVAL, TOKEN) GOTO 23495 23494 CONTINUE IF (.NOT.(TOKEN .EQ. -20))GOTO 23496 CALL RETCOD GOTO 23497 23496 CONTINUE IF (.NOT.(TOKEN .EQ. -23))GOTO 23498 CALL STRDCL 23498 CONTINUE 23497 CONTINUE 23495 CONTINUE 23493 CONTINUE 23489 CONTINUE TOKEN = LEX (LEXSTR) CALL PBSTR (LEXSTR) CALL UNSTAK (SP, LEXTYP, LABVAL, TOKEN) 23486 CONTINUE 23483 CONTINUE 23462 TOKEN = LEX (LEXSTR) GOTO 23461 23463 CONTINUE IF (.NOT.(SP .NE. 1))GOTO 23500 CALL SYNERR (15Hunexpected EOF.) 23500 CONTINUE IF (.NOT.(CSP .GT. 0))GOTO 23502 CALL SYNERR(43Hconditional processing still active at EOF.) 23502 CONTINUE RETURN END SUBROUTINE PBNUM (N) INTEGER N INTEGER M, NUM INTEGER MOD, IABS LOGICAL*1 DIGITS(11) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ NUM = IABS(N) 23504 CONTINUE M = MOD (NUM, 10) CALL PUTBAK (DIGITS (M + 1)) NUM = NUM / 10 23505 IF (.NOT.(NUM .EQ. 0))GOTO 23504 23506 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23507 CALL PUTBAK(45) 23507 CONTINUE RETURN END SUBROUTINE PBSTR (IN) LOGICAL*1 IN (100) INTEGER I INTEGER LENGTH I = LENGTH (IN) 23509 IF (.NOT.(I .GT. 0))GOTO 23511 CALL PUTBAK (IN (I)) 23510 I = I - 1 GOTO 23509 23511 CONTINUE RETURN END INTEGER FUNCTION PUSH (EP, ARGSTK, AP) INTEGER AP, ARGSTK (100), EP IF (.NOT.(AP .GT. 100))GOTO 23512 CALL BADERR (19Harg stack overflow.) 23512 CONTINUE ARGSTK (AP) = EP PUSH = AP + 1 RETURN END SUBROUTINE PUTBAK (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM IF (.NOT.(BP .GE. 500))GOTO 23514 CALL BADERR (32Htoo many characters pushed back.) GOTO 23515 23514 CONTINUE BP = BP + 1 BUF (BP) = C 23515 CONTINUE RETURN END SUBROUTINE PUTCHR (C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM IF (.NOT.(EP .GT. 500))GOTO 23516 CALL BADERR (26Hevaluation stack overflow.) 23516 CONTINUE EVALST (EP) = C EP = EP + 1 RETURN END SUBROUTINE PUTTOK (STR) LOGICAL*1 STR (100) INTEGER I I = 1 23518 IF (.NOT.(STR (I) .NE. 0))GOTO 23520 CALL PUTCHR (STR (I)) 23519 I = I + 1 GOTO 23518 23520 CONTINUE RETURN END SUBROUTINE RELATE (TOKEN, LAST) LOGICAL*1 TOKEN (100) INTEGER LAST LOGICAL*1 NGETCH INTEGER LENGTH IF (.NOT.(NGETCH (TOKEN (2)) .NE. 61))GOTO 23521 CALL PUTBAK (TOKEN (2)) TOKEN (3) = 116 GOTO 23522 23521 CONTINUE TOKEN (3) = 101 23522 CONTINUE TOKEN (4) = 46 TOKEN (5) = 0 TOKEN (6) = 0 IF (.NOT.(TOKEN (1) .EQ. 62))GOTO 23523 TOKEN (2) = 103 GOTO 23524 23523 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 60))GOTO 23525 TOKEN (2) = 108 GOTO 23526 23525 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 33 .OR. TOKEN (1) .EQ. 33 .OR. TOKEN (1) *.EQ. 94 .OR. TOKEN (1) .EQ. 126))GOTO 23527 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23529 TOKEN (3) = 111 TOKEN (4) = 116 TOKEN (5) = 46 23529 CONTINUE TOKEN (2) = 110 GOTO 23528 23527 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 61))GOTO 23531 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23533 TOKEN (2) = 0 LAST = 1 RETURN 23533 CONTINUE TOKEN (2) = 101 TOKEN (3) = 113 GOTO 23532 23531 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 38))GOTO 23535 TOKEN (2) = 97 TOKEN (3) = 110 TOKEN (4) = 100 TOKEN (5) = 46 GOTO 23536 23535 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 124))GOTO 23537 TOKEN (2) = 111 TOKEN (3) = 114 GOTO 23538 23537 CONTINUE TOKEN (2) = 0 23538 CONTINUE 23536 CONTINUE 23532 CONTINUE 23528 CONTINUE 23526 CONTINUE 23524 CONTINUE TOKEN (1) = 46 LAST = LENGTH (TOKEN) RETURN END SUBROUTINE REPCOD (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (3) CALL OUTCON (LAB) LAB = LAB + 1 RETURN END SUBROUTINE RETCOD COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 TOKEN (100), T LOGICAL*1 GNBTOK LOGICAL*1 SRET(7) DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ T = GNBTOK (TOKEN, 100) IF (.NOT.(T .NE. 10 .AND. T .NE. 59 .AND. T .NE. 125))GOTO 23539 CALL PBSTR (TOKEN) CALL OUTTAB CALL SCOPY (FCNAME, 1, TOKEN, 1) CALL OUTSTR (TOKEN) CALL OUTCH (61) CALL EATUP CALL OUTDON GOTO 23540 23539 CONTINUE IF (.NOT.(T .EQ. 125))GOTO 23541 CALL PBSTR (TOKEN) 23541 CONTINUE 23540 CONTINUE CALL OUTTAB CALL OUTSTR (SRET) CALL OUTDON XFER = 1 RETURN END SUBROUTINE SKPBLK COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 C LOGICAL*1 NGETCH C = NGETCH (C) 23543 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23545 23544 C = NGETCH (C) GOTO 23543 23545 CONTINUE CALL PUTBAK (C) RETURN END SUBROUTINE STRDCL COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 T, TOKEN (100), DCHAR (100) LOGICAL*1 GNBTOK, ESC INTEGER I, J, K, N, LEN INTEGER LENGTH, CTOI, LEX, ELENTH LOGICAL*1 CHAR(11) LOGICAL*1 DAT(6) LOGICAL*1 EOSS(5) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/47/,C *HAR(11)/0/ DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT( *6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/47/,EOSS(5)/0/ T = GNBTOK (TOKEN, 100) IF (.NOT.(T .NE. -9))GOTO 23546 CALL SYNERR (21Hmissing string token.) 23546 CONTINUE CALL OUTTAB CALL PBSTR (CHAR) 23548 CONTINUE T = GNBTOK (DCHAR, 100) IF (.NOT.(T .EQ. 47))GOTO 23551 GOTO 23550 23551 CONTINUE CALL OUTSTR (DCHAR) 23549 GOTO 23548 23550 CONTINUE CALL OUTCH (32) CALL OUTSTR (TOKEN) CALL ADDSTR (TOKEN, SBUF, SBP, 600) CALL ADDCHR (0, SBUF, SBP, 600) IF (.NOT.(GNBTOK (TOKEN, 100) .NE. 40))GOTO 23553 LEN = ELENTH (TOKEN) + 1 IF (.NOT.(TOKEN (1) .EQ. 39 .OR. TOKEN (1) .EQ. 34))GOTO 23555 LEN = LEN - 2 23555 CONTINUE GOTO 23554 23553 CONTINUE T = GNBTOK (TOKEN, 100) I = 1 LEN = CTOI (TOKEN, I) IF (.NOT.(TOKEN (I) .NE. 0))GOTO 23557 CALL SYNERR (20Hinvalid string size.) 23557 CONTINUE IF (.NOT.(GNBTOK (TOKEN, 100) .NE. 41))GOTO 23559 CALL SYNERR (20Hmissing right paren.) GOTO 23560 23559 CONTINUE T = GNBTOK (TOKEN, 100) 23560 CONTINUE 23554 CONTINUE CALL OUTCH (40) CALL OUTNUM (LEN) CALL OUTCH (41) CALL OUTDON IF (.NOT.(TOKEN (1) .EQ. 39 .OR. TOKEN (1) .EQ. 34))GOTO 23561 LEN = LENGTH (TOKEN) TOKEN (LEN) = 0 CALL ADDSTR (TOKEN (2), SBUF, SBP, 600) GOTO 23562 23561 CONTINUE CALL ADDSTR (TOKEN, SBUF, SBP, 600) 23562 CONTINUE CALL ADDCHR (0, SBUF, SBP, 600) T = LEX (TOKEN) CALL PBSTR (TOKEN) IF (.NOT.(T .NE. -23))GOTO 23563 I = 1 23565 IF (.NOT.(I .LT. SBP))GOTO 23567 CALL OUTTAB CALL OUTSTR (DAT) K = 1 J = I + LENGTH (SBUF (I)) + 1 23568 CONTINUE IF (.NOT.(K .GT. 1))GOTO 23571 CALL OUTCH (44) 23571 CONTINUE CALL OUTSTR (SBUF (I)) CALL OUTCH (40) CALL OUTNUM (K) CALL OUTCH (41) CALL OUTCH (47) IF (.NOT.(SBUF (J) .EQ. 0))GOTO 23573 GOTO 23570 23573 CONTINUE N = ESC (SBUF, J) CALL OUTNUM (N) CALL OUTCH (47) K = K + 1 23569 J = J + 1 GOTO 23568 23570 CONTINUE CALL PBSTR (EOSS) 23575 CONTINUE T = GNBTOK (TOKEN, 100) CALL OUTSTR (TOKEN) 23576 IF (.NOT.(T .EQ. 47))GOTO 23575 23577 CONTINUE CALL OUTDON 23566 I = J + 1 GOTO 23565 23567 CONTINUE SBP = 1 23563 CONTINUE RETURN END SUBROUTINE SYNERR (MSG) LOGICAL*1 MSG (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 LC (20) INTEGER I, JUNK INTEGER ITOC LOGICAL*1 IN(5) LOGICAL*1 ERRMSG(15) DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ DATA ERRMSG(1)/101/,ERRMSG(2)/114/,ERRMSG(3)/114/,ERRMSG(4)/111/,E *RRMSG(5)/114/,ERRMSG(6)/32/,ERRMSG(7)/97/,ERRMSG(8)/116/,ERRMSG(9) */32/,ERRMSG(10)/108/,ERRMSG(11)/105/,ERRMSG(12)/110/,ERRMSG(13)/10 *1/,ERRMSG(14)/32/,ERRMSG(15)/0/ CALL PUTLIN (ERRMSG, 3) IF (.NOT.(LEVEL .GE. 1))GOTO 23578 I = LEVEL GOTO 23579 23578 CONTINUE I = 1 23579 CONTINUE JUNK = ITOC (LINECT (I), LC, 20) CALL PUTLIN (LC, 3) I = FNAMP - 1 23580 IF (.NOT.(I .GT. 1))GOTO 23582 IF (.NOT.(FNAMES (I - 1) .EQ. 0))GOTO 23583 CALL PUTLIN (IN, 3) CALL PUTLIN (FNAMES (I), 3) GOTO 23582 23583 CONTINUE 23581 I = I - 1 GOTO 23580 23582 CONTINUE CALL PUTCH (58, 3) CALL PUTCH (32, 3) CALL REMARK (MSG) RETURN END SUBROUTINE ULSTAL (NAME, DEFN) LOGICAL*1 NAME (100), DEFN (100) COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM CALL ENTDEF (NAME, DEFN, DEFTBL) CALL UPPER (NAME) CALL ENTDEF (NAME, DEFN, DEFTBL) RETURN END SUBROUTINE UNSTAK (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN 23585 IF (.NOT.(SP .GT. 1))GOTO 23587 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23588 GOTO 23587 23588 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19 .AND. TOKEN .EQ. -11))GOTO 23590 GOTO 23587 23590 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23592 CALL OUTCON (LABVAL (SP)) GOTO 23593 23592 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -11))GOTO 23594 IF (.NOT.(SP .GT. 2))GOTO 23596 SP = SP - 1 23596 CONTINUE CALL OUTCON (LABVAL (SP) + 1) GOTO 23595 23594 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -10))GOTO 23598 CALL DOSTAT (LABVAL (SP)) GOTO 23599 23598 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -15))GOTO 23600 CALL WHILES (LABVAL (SP)) GOTO 23601 23600 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -16))GOTO 23602 CALL FORS (LABVAL (SP)) GOTO 23603 23602 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -17))GOTO 23604 CALL UNTILS (LABVAL (SP), TOKEN) 23604 CONTINUE 23603 CONTINUE 23601 CONTINUE 23599 CONTINUE 23595 CONTINUE 23593 CONTINUE 23586 SP = SP - 1 GOTO 23585 23587 CONTINUE RETURN END SUBROUTINE UNTILS (LAB, TOKEN) INTEGER LAB, TOKEN COMMON /CDEFIO/ BP, BUF (500) INTEGER BP LOGICAL*1 BUF COMMON /CFNAME/ FCNAME (40) LOGICAL*1 FCNAME COMMON /CFOR/ FORDEP, FORSTK (300) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 160) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL INTEGER CP INTEGER EP LOGICAL*1 EVALST INTEGER DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CSBUF/ SBP, SBUF (600) INTEGER SBP LOGICAL*1 SBUF COMMON /CKWORD/ RKWTBL INTEGER RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER MEM( 5000) LOGICAL*1 CMEM(10000) EQUIVALENCE (CMEM(1),MEM(1)) COMMON/CDSMEM/MEM LOGICAL*1 PTOKEN (100) INTEGER JUNK INTEGER LEX XFER = 0 CALL OUTNUM (LAB) IF (.NOT.(TOKEN .EQ. -18))GOTO 23606 JUNK = LEX (PTOKEN) CALL IFGO (LAB - 1) GOTO 23607 23606 CONTINUE CALL OUTGO (LAB - 1) 23607 CONTINUE CALL OUTCON (LAB + 1) RETURN END SUBROUTINE WHILEC (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (2) CALL OUTNUM (LAB) CALL IFGO (LAB + 1) RETURN END SUBROUTINE WHILES (LAB) INTEGER LAB CALL OUTGO (LAB) CALL OUTCON (LAB + 1) RETURN END