SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD) LOGICAL*1 GTOK, NGETCH INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ LOGICAL*1 C, DEFN(200), TOKEN(100), T, PTOKEN(100) CALL SKPBLK(FD) C = GTOK(PTOKEN, 100, FD) IF(.NOT.(C .EQ. 40))GOTO 23000 T = 40 GOTO 23001 23000 CONTINUE T = 32 CALL PBSTR(PTOKEN) 23001 CONTINUE CALL SKPBLK(FD) IF(.NOT.(GTOK(TOKEN, TOKSIZ, FD) .NE. -9))GOTO 23002 CALL BADERR(22Hnon-alphanumeric name.) 23002 CONTINUE CALL SKPBLK(FD) C = GTOK(PTOKEN, 100, FD) IF(.NOT.(T .EQ. 32))GOTO 23004 CALL PBSTR(PTOKEN) I = 1 23006 CONTINUE C = NGETCH(C, FD) IF(.NOT.(I .GT. DEFSIZ))GOTO 23009 CALL BADERR(20Hdefinition too long.) 23009 CONTINUE DEFN(I) = C I = I + 1 23007 IF(.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. -1))GOTO 23006 23008 CONTINUE IF(.NOT.(C .EQ. 35))GOTO 23011 CALL PUTBAK(C) 23011 CONTINUE GOTO 23005 23004 CONTINUE IF(.NOT.(T .EQ. 40))GOTO 23013 IF(.NOT.(C .NE. 44))GOTO 23015 CALL BADERR(24Hmissing comma in define.) 23015 CONTINUE NLPAR = 0 I = 1 23017 IF(.NOT.(NLPAR .GE. 0))GOTO 23019 IF(.NOT.(I .GT. DEFSIZ))GOTO 23020 CALL BADERR(20Hdefinition too long.) GOTO 23021 23020 CONTINUE IF(.NOT.(NGETCH(DEFN(I), FD) .EQ. -1))GOTO 23022 CALL BADERR(20Hmissing right paren.) GOTO 23023 23022 CONTINUE IF(.NOT.(DEFN(I) .EQ. 40))GOTO 23024 NLPAR = NLPAR + 1 GOTO 23025 23024 CONTINUE IF(.NOT.(DEFN(I) .EQ. 41))GOTO 23026 NLPAR = NLPAR - 1 23026 CONTINUE 23025 CONTINUE 23023 CONTINUE 23021 CONTINUE 23018 I = I + 1 GOTO 23017 23019 CONTINUE GOTO 23014 23013 CONTINUE CALL BADERR(19Hgetdef is confused.) 23014 CONTINUE 23005 CONTINUE DEFN(I-1) = 0 RETURN END SUBROUTINE INSTAL(NAME, DEFN) LOGICAL*1 NAME(100), DEFN(200) INTEGER NLEN, DLEN, LENGTH, C, HSHFCN COMMON /CLOOK/ LASTP, LASTT, HSHPTR(37), TABPTR(2,625), TABLE(6250 *) INTEGER LASTP INTEGER LASTT INTEGER HSHPTR INTEGER TABPTR LOGICAL*1 TABLE NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF(.NOT.(LASTT + NLEN + DLEN .GT. 6250 .OR. LASTP .GE. 625))GOTO 2 *3028 CALL PUTLIN(NAME, 3) CALL REMARK(24H : too many definitions.) GOTO 23029 23028 CONTINUE LASTP = LASTP + 1 TABPTR(2, LASTP) = LASTT + 1 C = HSHFCN(NAME, 37) TABPTR(1, LASTP) = HSHPTR(C) HSHPTR(C) = LASTP CALL SCOPY(NAME, 1, TABLE, LASTT + 1) CALL SCOPY(DEFN, 1, TABLE, LASTT + NLEN + 1) LASTT = LASTT + NLEN + DLEN 23029 CONTINUE RETURN END INTEGER FUNCTION LOOKUP(NAME, DEFN) LOGICAL*1 NAME(100), DEFN(200) INTEGER C, HSHFCN, I, J, K COMMON /CLOOK/ LASTP, LASTT, HSHPTR(37), TABPTR(2,625), TABLE(6250 *) INTEGER LASTP INTEGER LASTT INTEGER HSHPTR INTEGER TABPTR LOGICAL*1 TABLE C = HSHFCN(NAME, 37) LOOKUP = 0 I=HSHPTR(C) 23030 IF(.NOT.(I .GT. 0))GOTO 23032 J = TABPTR(2, I) K=1 23033 IF(.NOT.(NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 0))GOTO 23035 J = J + 1 23034 K=K+1 GOTO 23033 23035 CONTINUE IF(.NOT.(NAME(K) .EQ. TABLE(J)))GOTO 23036 CALL SCOPY(TABLE, J+1, DEFN, 1) LOOKUP = 1 GOTO 23032 23036 CONTINUE 23031 I=TABPTR(1,I) GOTO 23030 23032 CONTINUE RETURN END INTEGER FUNCTION HSHFCN(STRNG, N) LOGICAL*1 STRNG(100) INTEGER N, I, LENGTH, I1, I2 I = LENGTH(STRNG) I = MAX0(I, 1) I1 = STRNG(1) I2 = STRNG(I) HSHFCN = MOD(I1+I2, N) + 1 RETURN END SUBROUTINE TBINIT COMMON /CLOOK/ LASTP, LASTT, HSHPTR(37), TABPTR(2,625), TABLE(6250 *) INTEGER LASTP INTEGER LASTT INTEGER HSHPTR INTEGER TABPTR LOGICAL*1 TABLE LASTP = 0 LASTT = 0 I=1 23038 IF(.NOT.(I.LE.37))GOTO 23040 HSHPTR(I) = 0 23039 I=I+1 GOTO 23038 23040 CONTINUE RETURN END SUBROUTINE DOCODE(LAB) INTEGER LABGEN INTEGER LAB LOGICAL*1 GNBTOK LOGICAL*1 LEXSTR(100) COMMON /CGOTO/ XFER INTEGER XFER 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 23041 CALL OUTSTR(LEXSTR) GOTO 23042 23041 CONTINUE CALL PBSTR(LEXSTR) CALL OUTNUM(LAB) 23042 CONTINUE CALL OUTCH(32) CALL EATUP CALL OUTDON RETURN END SUBROUTINE DOSTAT(LAB) INTEGER LAB CALL OUTCON(LAB) CALL OUTCON(LAB+1) RETURN END SUBROUTINE BADERR(MSG) LOGICAL*1 MSG(100) CALL SYNERR(MSG) CALL R4EXIT(0) END SUBROUTINE SYNERR(MSG) LOGICAL*1 LC(10), MSG(100) INTEGER ITOC INTEGER I, JUNK COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES 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 23043 I = LEVEL GOTO 23044 23043 CONTINUE I = 1 23044 CONTINUE JUNK = ITOC (LINECT(I), LC, 10) CALL PUTLIN(LC, 3) I = FNAMP-1 23045 IF(.NOT.(I.GT.1))GOTO 23047 IF(.NOT.(FNAMES(I-1) .EQ. 0))GOTO 23048 CALL PUTLIN(IN, 3) CALL PUTLIN(FNAMES(I), 3) GOTO 23047 23048 CONTINUE 23046 I=I-1 GOTO 23045 23047 CONTINUE CALL PUTCH(58, 3) CALL PUTCH(32, 3) CALL REMARK (MSG) RETURN END SUBROUTINE FORCOD(LAB) LOGICAL*1 GETTOK, GNBTOK LOGICAL*1 T, TOKEN(100) INTEGER LENGTH, LABGEN INTEGER I, J, LAB, NLPAR COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP LOGICAL*1 FORSTK LOGICAL*1 IFNOT(9) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/40/,IFNOT(4)/46/,IFNOT(5 *)/110/,IFNOT(6)/111/,IFNOT(7)/116/,IFNOT(8)/46/,IFNOT(9)/0/ LAB = LABGEN(3) CALL OUTCON(0) IF(.NOT.(GNBTOK(TOKEN, 100) .NE. 40))GOTO 23050 CALL SYNERR(19Hmissing left paren.) RETURN 23050 CONTINUE IF(.NOT.(GNBTOK(TOKEN, 100) .NE. 59))GOTO 23052 CALL PBSTR(TOKEN) CALL OUTTAB CALL EATUP CALL OUTDON 23052 CONTINUE IF(.NOT.(GNBTOK(TOKEN, 100) .EQ. 59))GOTO 23054 CALL OUTCON(LAB) GOTO 23055 23054 CONTINUE CALL PBSTR(TOKEN) CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(IFNOT) CALL OUTCH(40) NLPAR = 0 23056 IF(.NOT.(NLPAR .GE. 0))GOTO 23057 T = GETTOK(TOKEN, 100) IF(.NOT.(T .EQ. 59))GOTO 23058 GOTO 23057 23058 CONTINUE IF(.NOT.(T .EQ. 40))GOTO 23060 NLPAR = NLPAR + 1 GOTO 23061 23060 CONTINUE IF(.NOT.(T .EQ. 41))GOTO 23062 NLPAR = NLPAR - 1 23062 CONTINUE 23061 CONTINUE IF(.NOT.(T .EQ. -1))GOTO 23064 CALL PBSTR(TOKEN) RETURN 23064 CONTINUE IF(.NOT.(T .NE. 10 .AND. T .NE. 95))GOTO 23066 CALL OUTSTR(TOKEN) 23066 CONTINUE GOTO 23056 23057 CONTINUE CALL OUTCH(41) CALL OUTCH(41) CALL OUTGO(LAB+2) IF(.NOT.(NLPAR .LT. 0))GOTO 23068 CALL SYNERR(19Hinvalid for clause.) 23068 CONTINUE 23055 CONTINUE FORDEP = FORDEP + 1 J = 1 I = 1 23070 IF(.NOT.(I .LT. FORDEP))GOTO 23072 J = J + LENGTH(FORSTK(J)) + 1 23071 I = I + 1 GOTO 23070 23072 CONTINUE FORSTK(J) = 0 NLPAR = 0 T = GNBTOK(TOKEN, 100) CALL PBSTR(TOKEN) 23073 IF(.NOT.(NLPAR .GE. 0))GOTO 23074 T = GETTOK(TOKEN, 100) IF(.NOT.(T .EQ. 40))GOTO 23075 NLPAR = NLPAR + 1 GOTO 23076 23075 CONTINUE IF(.NOT.(T .EQ. 41))GOTO 23077 NLPAR = NLPAR - 1 23077 CONTINUE 23076 CONTINUE IF(.NOT.(T .EQ. -1))GOTO 23079 CALL PBSTR(TOKEN) GOTO 23074 23079 CONTINUE IF(.NOT.(NLPAR .GE. 0 .AND. T .NE. 10 .AND. T .NE. 95))GOTO 23081 IF(.NOT.(J + LENGTH(TOKEN) .GE. 200))GOTO 23083 CALL BADERR(20Hfor clause too long.) 23083 CONTINUE CALL SCOPY(TOKEN, 1, FORSTK, J) J = J + LENGTH(TOKEN) 23081 CONTINUE GOTO 23073 23074 CONTINUE LAB = LAB + 1 RETURN END SUBROUTINE FORS(LAB) INTEGER LENGTH INTEGER I, J, LAB COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CGOTO/ XFER INTEGER XFER XFER = 0 CALL OUTNUM(LAB) J = 1 I = 1 23085 IF(.NOT.(I .LT. FORDEP))GOTO 23087 J = J + LENGTH(FORSTK(J)) + 1 23086 I = I + 1 GOTO 23085 23087 CONTINUE IF(.NOT.(LENGTH(FORSTK(J)) .GT. 0))GOTO 23088 CALL OUTTAB CALL OUTSTR(FORSTK(J)) CALL OUTDON 23088 CONTINUE CALL OUTGO(LAB-1) CALL OUTCON(LAB+1) FORDEP = FORDEP - 1 RETURN END SUBROUTINE BALPAR LOGICAL*1 GETTOK, GNBTOK LOGICAL*1 T, TOKEN(100) INTEGER NLPAR IF(.NOT.(GNBTOK(TOKEN, 100) .NE. 40))GOTO 23090 CALL SYNERR(19Hmissing left paren.) RETURN 23090 CONTINUE CALL OUTSTR(TOKEN) NLPAR = 1 23092 CONTINUE T = GETTOK(TOKEN, 100) IF(.NOT.(T.EQ.59 .OR. T.EQ.123 .OR. T.EQ.125 .OR. T.EQ.-1))GOTO 23 *095 CALL PBSTR(TOKEN) GOTO 23094 23095 CONTINUE IF(.NOT.(T .EQ. 10))GOTO 23097 TOKEN(1) = 0 GOTO 23098 23097 CONTINUE IF(.NOT.(T .EQ. 40))GOTO 23099 NLPAR = NLPAR + 1 GOTO 23100 23099 CONTINUE IF(.NOT.(T .EQ. 41))GOTO 23101 NLPAR = NLPAR - 1 23101 CONTINUE 23100 CONTINUE 23098 CONTINUE CALL OUTSTR(TOKEN) 23093 IF(.NOT.(NLPAR .LE. 0))GOTO 23092 23094 CONTINUE IF(.NOT.(NLPAR .NE. 0))GOTO 23103 CALL SYNERR(33Hmissing parenthesis in condition.) 23103 CONTINUE RETURN END SUBROUTINE ELSEIF(LAB) INTEGER LAB CALL OUTGO(LAB+1) CALL OUTCON(LAB) RETURN END SUBROUTINE IFCODE(LAB) INTEGER LABGEN INTEGER LAB COMMON /CGOTO/ XFER INTEGER XFER XFER = 0 LAB = LABGEN(2) CALL IFGO(LAB) RETURN END SUBROUTINE IFGO(LAB) INTEGER LAB LOGICAL*1 IFNOT(9) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/40/,IFNOT(4)/46/,IFNOT(5 *)/110/,IFNOT(6)/111/,IFNOT(7)/116/,IFNOT(8)/46/,IFNOT(9)/0/ CALL OUTTAB CALL OUTSTR(IFNOT) CALL BALPAR CALL OUTCH(41) CALL OUTGO(LAB) RETURN END LOGICAL*1 FUNCTION GETTOK(TOKEN, TOKSIZ) INTEGER EQUAL, OPEN, LENGTH INTEGER I, TOKSIZ, F, LEN LOGICAL*1 T LOGICAL*1 DEFTOK, NGETCH LOGICAL*1 GETCH LOGICAL*1 NAME(40), TOKEN(100) COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CFNAME/ FCNAME(40) LOGICAL*1 FCNAME 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/ 23105 IF(.NOT.(LEVEL .GT. 0))GOTO 23107 F = INFILE(LEVEL) GETTOK = DEFTOK(TOKEN, TOKSIZ, F) 23108 IF(.NOT.(GETTOK .NE. -1))GOTO 23110 IF(.NOT.(EQUAL(TOKEN, FNCN) .EQ. 1))GOTO 23111 CALL SKPBLK(INFILE(LEVEL)) T = DEFTOK(FCNAME, 40, F) CALL PBSTR(FCNAME) IF(.NOT.(T .NE. -9))GOTO 23113 CALL SYNERR(22Hmissing function name.) 23113 CONTINUE CALL PUTBAK(32) RETURN 23111 CONTINUE IF(.NOT.(EQUAL(TOKEN, INCL) .EQ. 0))GOTO 23115 RETURN 23115 CONTINUE 23112 CONTINUE CALL SKPBLK(INFILE(LEVEL)) T = DEFTOK(NAME, 40, INFILE(LEVEL)) IF(.NOT.(T .EQ. 39 .OR. T .EQ. 34))GOTO 23117 LEN = LENGTH(NAME) - 1 I=1 23119 IF(.NOT.(I .LT. LEN))GOTO 23121 NAME(I) = NAME(I+1) 23120 I=I+1 GOTO 23119 23121 CONTINUE NAME(I) = 0 23117 CONTINUE I = LENGTH(NAME) + 1 IF(.NOT.(LEVEL .GE. 3))GOTO 23122 CALL SYNERR(27Hincludes nested too deeply.) GOTO 23123 23122 CONTINUE INFILE(LEVEL+1) = OPEN(NAME, 1) LINECT(LEVEL+1) = 1 IF(.NOT.(INFILE(LEVEL+1) .EQ. -3))GOTO 23124 CALL SYNERR(19Hcan't open include.) GOTO 23125 23124 CONTINUE LEVEL = LEVEL + 1 IF(.NOT.(FNAMP + I .LE. 120))GOTO 23126 CALL SCOPY(NAME, 1, FNAMES, FNAMP) FNAMP = FNAMP + I 23126 CONTINUE F = INFILE(LEVEL) 23125 CONTINUE 23123 CONTINUE 23109 GETTOK = DEFTOK(TOKEN, TOKSIZ, F) GOTO 23108 23110 CONTINUE IF(.NOT.(LEVEL .GT. 1))GOTO 23128 CALL CLOSE(INFILE(LEVEL)) FNAMP = FNAMP - 1 23130 IF(.NOT.(FNAMP .GT. 1))GOTO 23132 IF(.NOT.(FNAMES(FNAMP-1) .EQ. 0))GOTO 23133 GOTO 23132 23133 CONTINUE 23131 FNAMP = FNAMP - 1 GOTO 23130 23132 CONTINUE 23128 CONTINUE 23106 LEVEL = LEVEL - 1 GOTO 23105 23107 CONTINUE TOKEN(1) = -1 TOKEN(2) = 0 GETTOK = -1 RETURN END LOGICAL*1 FUNCTION GNBTOK(TOKEN, TOKSIZ) INTEGER TOKSIZ LOGICAL*1 TOKEN(100), GETTOK COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES CALL SKPBLK(INFILE(LEVEL)) GNBTOK = GETTOK(TOKEN, TOKSIZ) RETURN END LOGICAL*1 FUNCTION GTOK(LEXSTR, TOKSIZ, FD) LOGICAL*1 NGETCH, TYPE INTEGER FD, I, B, N, TOKSIZ, ITOC LOGICAL*1 C, LEXSTR(100) COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES C = NGETCH(LEXSTR(1), FD) IF(.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23135 LEXSTR(1) = 32 23137 IF(.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23138 C = NGETCH(C, FD) GOTO 23137 23138 CONTINUE IF(.NOT.(C .EQ. 35))GOTO 23139 23141 IF(.NOT.(NGETCH(C, FD) .NE. 10))GOTO 23142 GOTO 23141 23142 CONTINUE 23139 CONTINUE IF(.NOT.(C .NE. 10))GOTO 23143 CALL PUTBAK(C) GOTO 23144 23143 CONTINUE LEXSTR(1) = 10 23144 CONTINUE LEXSTR(2) = 0 GTOK = LEXSTR(1) RETURN 23135 CONTINUE I = 1 GTOK = TYPE(C) IF(.NOT.(GTOK .EQ. 1))GOTO 23145 I = 1 23147 IF(.NOT.(I .LT. TOKSIZ - 2))GOTO 23149 GTOK = TYPE(NGETCH(LEXSTR(I+1), FD)) IF(.NOT.(GTOK .NE. 1 .AND. GTOK .NE. 2 .AND. GTOK .NE. 95 .AND. GT *OK .NE. 46))GOTO 23150 GOTO 23149 23150 CONTINUE 23148 I = I + 1 GOTO 23147 23149 CONTINUE CALL PUTBAK(LEXSTR(I+1)) GTOK = -9 GOTO 23146 23145 CONTINUE IF(.NOT.(GTOK .EQ. 2))GOTO 23152 B = C - 48 I = 1 23154 IF(.NOT.(I .LT. TOKSIZ - 2))GOTO 23156 IF(.NOT.(TYPE(NGETCH(LEXSTR(I+1), FD)) .NE. 2))GOTO 23157 GOTO 23156 23157 CONTINUE B = 10*B + LEXSTR(I+1) - 48 23155 I = I + 1 GOTO 23154 23156 CONTINUE IF(.NOT.(LEXSTR(I+1) .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO *23159 N = 0 23161 CONTINUE C = NGETCH(LEXSTR(1), FD) IF(.NOT.(C .GE. 97 .AND. C .LE. 122))GOTO 23164 C = C - 97 + 57 + 1 GOTO 23165 23164 CONTINUE IF(.NOT.(C .GE. 65 .AND. C .LE. 90))GOTO 23166 C = C - 65 + 57 + 1 23166 CONTINUE 23165 CONTINUE IF(.NOT.(C .LT. 48 .OR. C .GE. 48 + B))GOTO 23168 GOTO 23163 23168 CONTINUE 23162 N = B*N + C - 48 GOTO 23161 23163 CONTINUE CALL PUTBAK(LEXSTR(1)) I = ITOC(N, LEXSTR, TOKSIZ) GOTO 23160 23159 CONTINUE CALL PUTBAK(LEXSTR(I+1)) 23160 CONTINUE GTOK = 2 GOTO 23153 23152 CONTINUE IF(.NOT.(C .EQ. 91))GOTO 23170 LEXSTR(1) = 123 GTOK = 123 GOTO 23171 23170 CONTINUE IF(.NOT.(C .EQ. 93))GOTO 23172 LEXSTR(1) = 125 GTOK = 125 GOTO 23173 23172 CONTINUE IF(.NOT.(C .EQ. 36))GOTO 23174 IF(.NOT.(NGETCH(LEXSTR(2), FD) .EQ. 40))GOTO 23176 LEXSTR(1) = -10 GTOK = -10 GOTO 23177 23176 CONTINUE IF(.NOT.(LEXSTR(2) .EQ. 41))GOTO 23178 LEXSTR(1) = -11 GTOK = -11 GOTO 23179 23178 CONTINUE CALL PUTBAK(LEXSTR(2)) 23179 CONTINUE 23177 CONTINUE GOTO 23175 23174 CONTINUE IF(.NOT.(C .EQ. 39 .OR. C .EQ. 34))GOTO 23180 I = 2 23182 IF(.NOT.(NGETCH(LEXSTR(I), FD) .NE. LEXSTR(1)))GOTO 23184 IF(.NOT.(LEXSTR(I) .EQ. 95))GOTO 23185 IF(.NOT.(NGETCH(C, FD) .EQ. 10))GOTO 23187 23189 IF(.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23190 C = NGETCH(C, FD) GOTO 23189 23190 CONTINUE LEXSTR(I) = C GOTO 23188 23187 CONTINUE CALL PUTBAK(C) 23188 CONTINUE 23185 CONTINUE IF(.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ-1))GOTO 23191 CALL SYNERR(14Hmissing quote.) LEXSTR(I) = LEXSTR(1) CALL PUTBAK(10) GOTO 23184 23191 CONTINUE 23183 I = I + 1 GOTO 23182 23184 CONTINUE GOTO 23181 23180 CONTINUE IF(.NOT.(C .EQ. 35))GOTO 23193 23195 IF(.NOT.(NGETCH(LEXSTR(1), FD) .NE. 10))GOTO 23196 GOTO 23195 23196 CONTINUE GTOK = 10 GOTO 23194 23193 CONTINUE IF(.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 33 .OR. C .EQ. 33 . *OR. C .EQ. 94 .OR. C .EQ. 61 .OR. C .EQ. 38 .OR. C .EQ. 124))GOTO *23197 CALL RELATE(LEXSTR, I, FD) 23197 CONTINUE 23194 CONTINUE 23181 CONTINUE 23175 CONTINUE 23173 CONTINUE 23171 CONTINUE 23153 CONTINUE 23146 CONTINUE IF(.NOT.(I .GE. TOKSIZ-1))GOTO 23199 CALL SYNERR(15Htoken too long.) 23199 CONTINUE LEXSTR(I+1) = 0 IF(.NOT.(LEXSTR(1) .EQ. 10))GOTO 23201 LINECT(LEVEL) = LINECT(LEVEL) + 1 23201 CONTINUE RETURN END INTEGER FUNCTION LEX(LEXSTR) LOGICAL*1 GNBTOK, DEFTOK LOGICAL*1 LEXSTR(100) INTEGER EQUAL 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) LOGICAL*1 SSWTCH(7) LOGICAL*1 SCASE(5) LOGICAL*1 SDEFLT(8) 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/ DATA SSWTCH(1)/115/,SSWTCH(2)/119/,SSWTCH(3)/105/,SSWTCH(4)/116/,S *SWTCH(5)/99/,SSWTCH(6)/104/,SSWTCH(7)/0/ DATA SCASE(1)/99/,SCASE(2)/97/,SCASE(3)/115/,SCASE(4)/101/,SCASE(5 *)/0/ DATA SDEFLT(1)/100/,SDEFLT(2)/101/,SDEFLT(3)/102/,SDEFLT(4)/97/,SD *EFLT(5)/117/,SDEFLT(6)/108/,SDEFLT(7)/116/,SDEFLT(8)/0/ LEX = GNBTOK(LEXSTR, 100) 23203 IF(.NOT.(LEX .EQ. 10))GOTO 23205 23204 LEX = GNBTOK(LEXSTR, 100) GOTO 23203 23205 CONTINUE IF(.NOT.(LEX .EQ. -1 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LEX . *EQ. 125))GOTO 23206 RETURN 23206 CONTINUE IF(.NOT.(LEX .EQ. 2))GOTO 23208 LEX = -9 GOTO 23209 23208 CONTINUE IF(.NOT.(LEX .EQ. 37))GOTO 23210 LEX = -27 GOTO 23211 23210 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SIF) .EQ. 1))GOTO 23212 LEX = -19 GOTO 23213 23212 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SELSE) .EQ. 1))GOTO 23214 LEX = -11 GOTO 23215 23214 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SWHILE) .EQ. 1))GOTO 23216 LEX = -15 GOTO 23217 23216 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SDO) .EQ. 1))GOTO 23218 LEX = -10 GOTO 23219 23218 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SBREAK) .EQ. 1))GOTO 23220 LEX = -8 GOTO 23221 23220 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SNEXT) .EQ. 1))GOTO 23222 LEX = -13 GOTO 23223 23222 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SFOR) .EQ. 1))GOTO 23224 LEX = -16 GOTO 23225 23224 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SREPT) .EQ. 1))GOTO 23226 LEX = -17 GOTO 23227 23226 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SUNTIL) .EQ. 1))GOTO 23228 LEX = -18 GOTO 23229 23228 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SRET) .EQ. 1))GOTO 23230 LEX = -20 GOTO 23231 23230 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SSTR) .EQ. 1))GOTO 23232 LEX = -23 GOTO 23233 23232 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SSWTCH) .EQ. 1))GOTO 23234 LEX = -24 GOTO 23235 23234 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SCASE) .EQ. 1))GOTO 23236 LEX = -25 GOTO 23237 23236 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SDEFLT) .EQ. 1))GOTO 23238 LEX = -26 GOTO 23239 23238 CONTINUE LEX = -14 23239 CONTINUE 23237 CONTINUE 23235 CONTINUE 23233 CONTINUE 23231 CONTINUE 23229 CONTINUE 23227 CONTINUE 23225 CONTINUE 23223 CONTINUE 23221 CONTINUE 23219 CONTINUE 23217 CONTINUE 23215 CONTINUE 23213 CONTINUE 23211 CONTINUE 23209 CONTINUE RETURN END LOGICAL*1 FUNCTION NGETCH(C, FD) LOGICAL*1 GETCH LOGICAL*1 C INTEGER FD COMMON /CDEFIO/ BP, BUF(300) INTEGER BP LOGICAL*1 BUF IF(.NOT.(BP .GT. 0))GOTO 23240 C = BUF(BP) BP = BP - 1 GOTO 23241 23240 CONTINUE C = GETCH(C, FD) 23241 CONTINUE NGETCH = C RETURN END SUBROUTINE PBSTR(IN) LOGICAL*1 IN(100) INTEGER LENGTH INTEGER I I = LENGTH(IN) 23242 IF(.NOT.(I .GT. 0))GOTO 23244 CALL PUTBAK(IN(I)) 23243 I = I - 1 GOTO 23242 23244 CONTINUE RETURN END SUBROUTINE PUTBAK(C) LOGICAL*1 C COMMON /CDEFIO/ BP, BUF(300) INTEGER BP LOGICAL*1 BUF BP = BP + 1 IF(.NOT.(BP .GT. 300))GOTO 23245 CALL BADERR(32Htoo many characters pushed back.) 23245 CONTINUE BUF(BP) = C RETURN END SUBROUTINE RELATE(TOKEN, LAST, FD) LOGICAL*1 NGETCH LOGICAL*1 TOKEN(100) INTEGER LENGTH INTEGER FD, LAST IF(.NOT.(NGETCH(TOKEN(2), FD) .NE. 61))GOTO 23247 CALL PUTBAK(TOKEN(2)) TOKEN(3) = 116 GOTO 23248 23247 CONTINUE TOKEN(3) = 101 23248 CONTINUE TOKEN(4) = 46 TOKEN(5) = 0 TOKEN(6) = 0 IF(.NOT.(TOKEN(1) .EQ. 62))GOTO 23249 TOKEN(2) = 103 GOTO 23250 23249 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 60))GOTO 23251 TOKEN(2) = 108 GOTO 23252 23251 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 33 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) .EQ *. 94))GOTO 23253 IF(.NOT.(TOKEN(2) .NE. 61))GOTO 23255 TOKEN(3) = 111 TOKEN(4) = 116 TOKEN(5) = 46 23255 CONTINUE TOKEN(2) = 110 GOTO 23254 23253 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 61))GOTO 23257 IF(.NOT.(TOKEN(2) .NE. 61))GOTO 23259 TOKEN(2) = 0 LAST = 1 RETURN 23259 CONTINUE TOKEN(2) = 101 TOKEN(3) = 113 GOTO 23258 23257 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 38))GOTO 23261 TOKEN(2) = 97 TOKEN(3) = 110 TOKEN(4) = 100 TOKEN(5) = 46 GOTO 23262 23261 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 124))GOTO 23263 TOKEN(2) = 111 TOKEN(3) = 114 GOTO 23264 23263 CONTINUE TOKEN(2) = 0 23264 CONTINUE 23262 CONTINUE 23258 CONTINUE 23254 CONTINUE 23252 CONTINUE 23250 CONTINUE TOKEN(1) = 46 LAST = LENGTH(TOKEN) RETURN END SUBROUTINE MAIN INTEGER GETARG, OPEN LOGICAL*1 BUF(40) INTEGER I COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES LOGICAL*1 DEFNS(8) 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/ CALL INITKW IF(.NOT.(DEFNS(1) .NE. 0))GOTO 23265 CALL GETDIR(1, 6, BUF) CALL CONCAT(BUF, DEFNS, BUF) INFILE(1) = OPEN(BUF, 1) IF(.NOT.(INFILE(1) .EQ. -3))GOTO 23267 CALL REMARK (37Hcan't open standard definitions file.) GOTO 23268 23267 CONTINUE CALL PARSE CALL CLOSE (INFILE(1)) 23268 CONTINUE 23265 CONTINUE I=1 23269 IF(.NOT.(GETARG(I, BUF, 40) .NE. -1))GOTO 23271 IF(.NOT.(BUF(1) .EQ. 63 .AND. BUF(2) .EQ. 0))GOTO 23272 CALL ERROR (33Husage: rat4 [file ...] >outfile.) GOTO 23273 23272 CONTINUE IF(.NOT.(BUF(1) .EQ. 45 .AND. BUF(2) .EQ. 0))GOTO 23274 INFILE(1) = 1 GOTO 23275 23274 CONTINUE INFILE(1) = OPEN(BUF, 1) IF(.NOT.(INFILE(1) .EQ. -3))GOTO 23276 CALL CANT(BUF) 23276 CONTINUE 23275 CONTINUE 23273 CONTINUE CALL PARSE IF(.NOT.(INFILE(1) .NE. 1))GOTO 23278 CALL CLOSE(INFILE(1)) 23278 CONTINUE 23270 I=I+1 GOTO 23269 23271 CONTINUE IF(.NOT.(I .EQ. 1))GOTO 23280 INFILE(1) = 1 CALL PARSE 23280 CONTINUE RETURN END SUBROUTINE EATUP LOGICAL*1 GETTOK LOGICAL*1 PTOKEN(100), T, TOKEN(100) INTEGER NLPAR NLPAR = 0 23282 CONTINUE T = GETTOK(TOKEN, 100) IF(.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23285 GOTO 23284 23285 CONTINUE IF(.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23287 CALL PBSTR(TOKEN) GOTO 23284 23287 CONTINUE IF(.NOT.(T .EQ. -1))GOTO 23289 CALL SYNERR(15Hunexpected EOF.) CALL PBSTR(TOKEN) GOTO 23284 23289 CONTINUE IF(.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 .O *R. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. T *.EQ. 61 .OR. T .EQ. 95 ))GOTO 23291 23293 IF(.NOT.(GETTOK(PTOKEN, 100) .EQ. 10))GOTO 23294 GOTO 23293 23294 CONTINUE CALL PBSTR(PTOKEN) IF(.NOT.(T .EQ. 95))GOTO 23295 TOKEN(1) = 0 23295 CONTINUE 23291 CONTINUE IF(.NOT.(T .EQ. 40))GOTO 23297 NLPAR = NLPAR + 1 GOTO 23298 23297 CONTINUE IF(.NOT.(T .EQ. 41))GOTO 23299 NLPAR = NLPAR - 1 23299 CONTINUE 23298 CONTINUE CALL OUTSTR(TOKEN) 23283 IF(.NOT.(NLPAR .LT. 0))GOTO 23282 23284 CONTINUE IF(.NOT.(NLPAR .NE. 0))GOTO 23301 CALL SYNERR(23Hunbalanced parentheses.) 23301 CONTINUE RETURN END SUBROUTINE LABELC(LEXSTR) LOGICAL*1 LEXSTR(100) INTEGER LENGTH COMMON /CGOTO/ XFER INTEGER XFER XFER = 0 IF(.NOT.(LENGTH(LEXSTR) .EQ. 5))GOTO 23303 IF(.NOT.(LEXSTR(1) .EQ. 50 .AND. LEXSTR(2) .EQ. 51))GOTO 23305 CALL SYNERR(33Hwarning: possible label conflict.) 23305 CONTINUE 23303 CONTINUE CALL OUTSTR(LEXSTR) CALL OUTTAB RETURN END SUBROUTINE OTHERC(LEXSTR) LOGICAL*1 LEXSTR(100) COMMON /CGOTO/ XFER INTEGER XFER XFER = 0 CALL OUTTAB CALL OUTSTR(LEXSTR) CALL EATUP CALL OUTDON RETURN END SUBROUTINE OUTCH(C) LOGICAL*1 C INTEGER I COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF IF(.NOT.(OUTP .GE. 72))GOTO 23307 CALL OUTDON I = 1 23309 IF(.NOT.(I .LT. 6))GOTO 23311 OUTBUF(I) = 32 23310 I = I + 1 GOTO 23309 23311 CONTINUE OUTBUF(6) = 42 OUTP = 6 23307 CONTINUE OUTP = OUTP + 1 OUTBUF(OUTP) = C RETURN END SUBROUTINE OUTCON(N) INTEGER N COMMON /CGOTO/ XFER INTEGER XFER COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF 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 23312 RETURN 23312 CONTINUE IF(.NOT.(N .GT. 0))GOTO 23314 CALL OUTNUM(N) 23314 CONTINUE CALL OUTTAB CALL OUTSTR(CONTIN) CALL OUTDON RETURN END SUBROUTINE OUTDON INTEGER ALLBLK COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF OUTBUF(OUTP+1) = 10 OUTBUF(OUTP+2) = 0 IF(.NOT.(ALLBLK(OUTBUF) .EQ. 0))GOTO 23316 CALL PUTLIN(OUTBUF, 2) 23316 CONTINUE OUTP = 0 RETURN END SUBROUTINE OUTGO(N) INTEGER N COMMON /CGOTO/ XFER INTEGER XFER LOGICAL*1 GOTO(6) DATA GOTO(1)/103/,GOTO(2)/111/,GOTO(3)/116/,GOTO(4)/111/,GOTO(5)/3 *2/,GOTO(6)/0/ IF(.NOT.(XFER .EQ. 1))GOTO 23318 RETURN 23318 CONTINUE CALL OUTTAB CALL OUTSTR(GOTO) CALL OUTNUM(N) CALL OUTDON RETURN END SUBROUTINE OUTNUM(N) LOGICAL*1 CHARS(10) INTEGER I, M M = IABS(N) I = 0 23320 CONTINUE I = I + 1 CHARS(I) = MOD(M, 10) + 48 M = M / 10 23321 IF(.NOT.(M .EQ. 0 .OR. I .GE. 10))GOTO 23320 23322 CONTINUE IF(.NOT.(N .LT. 0))GOTO 23323 CALL OUTCH(45) 23323 CONTINUE 23325 IF(.NOT.(I .GT. 0))GOTO 23327 CALL OUTCH(CHARS(I)) 23326 I = I - 1 GOTO 23325 23327 CONTINUE RETURN END SUBROUTINE OUTSTR(STR) LOGICAL*1 C, STR(100) INTEGER I, J I = 1 23328 IF(.NOT.(STR(I) .NE. 0))GOTO 23330 C = STR(I) IF(.NOT.(C .NE. 39 .AND. C .NE. 34))GOTO 23331 IF(.NOT.(C .GE. 97 .AND. C .LE. 122))GOTO 23333 C = C - 97 + 65 23333 CONTINUE CALL OUTCH(C) GOTO 23332 23331 CONTINUE I = I + 1 J = I 23335 IF(.NOT.(STR(J) .NE. C))GOTO 23337 23336 J = J + 1 GOTO 23335 23337 CONTINUE CALL OUTNUM(J-I) CALL OUTCH(72) 23338 IF(.NOT.(I .LT. J))GOTO 23340 CALL OUTCH(STR(I)) 23339 I = I + 1 GOTO 23338 23340 CONTINUE 23332 CONTINUE 23329 I = I + 1 GOTO 23328 23330 CONTINUE RETURN END SUBROUTINE OUTTAB COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF 23341 IF(.NOT.(OUTP .LT. 6))GOTO 23342 CALL OUTCH(32) GOTO 23341 23342 CONTINUE RETURN END INTEGER FUNCTION ALLBLK(BUF) LOGICAL*1 BUF(100) INTEGER I ALLBLK = 1 I=1 23343 IF(.NOT.(BUF(I) .NE. 10 .AND. BUF(I) .NE. 0))GOTO 23345 IF(.NOT.(BUF(I) .NE. 32))GOTO 23346 ALLBLK = 0 GOTO 23345 23346 CONTINUE 23344 I=I+1 GOTO 23343 23345 CONTINUE RETURN END SUBROUTINE INITKW LOGICAL*1 DEFT(2), INCT(2), SUBT(2), IFT(2), ART(2), IFDFT(2), IFN *DT(2) COMMON /CLABEL/ LABEL INTEGER LABEL LOGICAL*1 DEFNAM(7) LOGICAL*1 INCNAM(5) LOGICAL*1 SUBNAM(7) LOGICAL*1 IFNAM(7) LOGICAL*1 ARNAM(6) LOGICAL*1 IFDFNM(6) LOGICAL*1 IFNDNM(9) DATA DEFNAM(1)/100/,DEFNAM(2)/101/,DEFNAM(3)/102/,DEFNAM(4)/105/,D *EFNAM(5)/110/,DEFNAM(6)/101/,DEFNAM(7)/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 IFDFNM(1)/105/,IFDFNM(2)/102/,IFDFNM(3)/100/,IFDFNM(4)/101/,I *FDFNM(5)/102/,IFDFNM(6)/0/ DATA IFNDNM(1)/105/,IFNDNM(2)/102/,IFNDNM(3)/110/,IFNDNM(4)/111/,I *FNDNM(5)/116/,IFNDNM(6)/100/,IFNDNM(7)/101/,IFNDNM(8)/102/,IFNDNM( *9)/0/ DATA DEFT(1), DEFT(2) /-4, 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/ DATA IFDFT(1), IFDFT(2) /-15, 0/ DATA IFNDT(1), IFNDT(2) /-16, 0/ CALL TBINIT CALL ULSTAL(DEFNAM, DEFT) CALL ULSTAL(INCNAM, INCT) CALL ULSTAL(SUBNAM, SUBT) CALL ULSTAL(IFNAM, IFT) CALL ULSTAL(ARNAM, ART) CALL ULSTAL(IFDFNM, IFDFT) CALL ULSTAL(IFNDNM, IFNDT) LABEL = 23000 RETURN END SUBROUTINE INIT INTEGER I COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CDEFIO/ BP, BUF(300) INTEGER BP LOGICAL*1 BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CLOOK/ LASTP, LASTT, HSHPTR(37), TABPTR(2,625), TABLE(6250 *) INTEGER LASTP INTEGER LASTT INTEGER HSHPTR INTEGER TABPTR LOGICAL*1 TABLE COMMON /CFNAME/ FCNAME(40) LOGICAL*1 FCNAME COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CSBUF/ SBP, SBUF(500) INTEGER SBP LOGICAL*1 SBUF COMMON /CSWTCH/ SWTOP, SWLAST, SWSTAK(1000) INTEGER SWTOP INTEGER SWLAST INTEGER SWSTAK OUTP = 0 LEVEL = 1 LINECT(1) = 1 SBP = 1 FNAMP = 2 FNAMES(1) = 0 BP = 0 FORDEP = 0 FCNAME(1) = 0 SWTOP = 0 SWLAST = 1 RETURN END SUBROUTINE PARSE LOGICAL*1 LEXSTR(100) INTEGER LEX INTEGER LAB, LABVAL(100), LEXTYP(100), SP, TOKEN, I COMMON /CGOTO/ XFER INTEGER XFER COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP LOGICAL*1 FORSTK COMMON /CFNAME/ FCNAME(40) LOGICAL*1 FCNAME COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES COMMON /CSBUF/ SBP, SBUF(500) INTEGER SBP LOGICAL*1 SBUF COMMON /CLABEL/ LABEL INTEGER LABEL COMMON /CLOOK/ LASTP, LASTT, HSHPTR(37), TABPTR(2,625), TABLE(6250 *) INTEGER LASTP INTEGER LASTT INTEGER HSHPTR INTEGER TABPTR LOGICAL*1 TABLE COMMON /CDEFIO/ BP, BUF(300) INTEGER BP LOGICAL*1 BUF COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF CALL INIT SP = 1 LEXTYP(1) = -1 TOKEN = LEX(LEXSTR) 23348 IF(.NOT.(TOKEN .NE. -1))GOTO 23350 IF(.NOT.(TOKEN .EQ. -19))GOTO 23351 CALL IFCODE(LAB) GOTO 23352 23351 CONTINUE IF(.NOT.(TOKEN .EQ. -10))GOTO 23353 CALL DOCODE(LAB) GOTO 23354 23353 CONTINUE IF(.NOT.(TOKEN .EQ. -15))GOTO 23355 CALL WHILEC(LAB) GOTO 23356 23355 CONTINUE IF(.NOT.(TOKEN .EQ. -16))GOTO 23357 CALL FORCOD(LAB) GOTO 23358 23357 CONTINUE IF(.NOT.(TOKEN .EQ. -17))GOTO 23359 CALL REPCOD(LAB) GOTO 23360 23359 CONTINUE IF(.NOT.(TOKEN .EQ. -24))GOTO 23361 CALL SWCODE(LAB) GOTO 23362 23361 CONTINUE IF(.NOT.(TOKEN .EQ. -25 .OR. TOKEN .EQ. -26))GOTO 23363 I = SP 23365 IF(.NOT.(I .GT. 0))GOTO 23367 IF(.NOT.(LEXTYP(I) .EQ. -24))GOTO 23368 GOTO 23367 23368 CONTINUE 23366 I = I - 1 GOTO 23365 23367 CONTINUE IF(.NOT.(I .EQ. 0))GOTO 23370 CALL SYNERR(24Hillegal case or default.) GOTO 23371 23370 CONTINUE CALL CASCOD(LABVAL(I), TOKEN) 23371 CONTINUE GOTO 23364 23363 CONTINUE IF(.NOT.(TOKEN .EQ. -9))GOTO 23372 CALL LABELC(LEXSTR) GOTO 23373 23372 CONTINUE IF(.NOT.(TOKEN .EQ. -11))GOTO 23374 IF(.NOT.(LEXTYP(SP) .EQ. -19))GOTO 23376 CALL ELSEIF(LABVAL(SP)) GOTO 23377 23376 CONTINUE CALL SYNERR(13Hillegal else.) 23377 CONTINUE GOTO 23375 23374 CONTINUE IF(.NOT.(TOKEN .EQ. -27))GOTO 23378 CALL LITRAL 23378 CONTINUE 23375 CONTINUE 23373 CONTINUE 23364 CONTINUE 23362 CONTINUE 23360 CONTINUE 23358 CONTINUE 23356 CONTINUE 23354 CONTINUE 23352 CONTINUE IF(.NOT.(TOKEN .EQ. -19 .OR. TOKEN .EQ. -11 .OR. TOKEN .EQ. -15 .O *R. TOKEN .EQ. -16 .OR. TOKEN .EQ. -17 .OR. TOKEN .EQ. -24 .OR. TOK *EN .EQ. -10 .OR. TOKEN .EQ. -9 .OR. TOKEN .EQ. 123))GOTO 23380 SP = SP + 1 IF(.NOT.(SP .GT. 100))GOTO 23382 CALL BADERR(25Hstack overflow in parser.) 23382 CONTINUE LEXTYP(SP) = TOKEN LABVAL(SP) = LAB GOTO 23381 23380 CONTINUE IF(.NOT.(TOKEN .NE. -25 .AND. TOKEN .NE. -26))GOTO 23384 IF(.NOT.(TOKEN .EQ. 125))GOTO 23386 IF(.NOT.(LEXTYP(SP) .EQ. 123))GOTO 23388 SP = SP - 1 GOTO 23389 23388 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -24))GOTO 23390 CALL SWEND(LABVAL(SP)) SP = SP - 1 GOTO 23391 23390 CONTINUE CALL SYNERR(20Hillegal right brace.) 23391 CONTINUE 23389 CONTINUE GOTO 23387 23386 CONTINUE IF(.NOT.(TOKEN .EQ. -14))GOTO 23392 CALL OTHERC(LEXSTR) GOTO 23393 23392 CONTINUE IF(.NOT.(TOKEN .EQ. -8 .OR. TOKEN .EQ. -13))GOTO 23394 CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN) GOTO 23395 23394 CONTINUE IF(.NOT.(TOKEN .EQ. -20))GOTO 23396 CALL RETCOD GOTO 23397 23396 CONTINUE IF(.NOT.(TOKEN .EQ. -23))GOTO 23398 CALL STRDCL 23398 CONTINUE 23397 CONTINUE 23395 CONTINUE 23393 CONTINUE 23387 CONTINUE TOKEN = LEX(LEXSTR) CALL PBSTR(LEXSTR) CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN) 23384 CONTINUE 23381 CONTINUE 23349 TOKEN = LEX(LEXSTR) GOTO 23348 23350 CONTINUE IF(.NOT.(SP .NE. 1))GOTO 23400 CALL SYNERR(15Hunexpected EOF.) 23400 CONTINUE RETURN END SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN 23402 IF(.NOT.(SP .GT. 1))GOTO 23404 IF(.NOT.(LEXTYP(SP) .EQ. 123 .OR. LEXTYP(SP) .EQ. -24))GOTO 23405 GOTO 23404 23405 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -19 .AND. TOKEN .EQ. -11))GOTO 23407 GOTO 23404 23407 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -19))GOTO 23409 CALL OUTCON(LABVAL(SP)) GOTO 23410 23409 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -11))GOTO 23411 IF(.NOT.(SP .GT. 2))GOTO 23413 SP = SP - 1 23413 CONTINUE CALL OUTCON(LABVAL(SP)+1) GOTO 23412 23411 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -10))GOTO 23415 CALL DOSTAT(LABVAL(SP)) GOTO 23416 23415 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -15))GOTO 23417 CALL WHILES(LABVAL(SP)) GOTO 23418 23417 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -16))GOTO 23419 CALL FORS(LABVAL(SP)) GOTO 23420 23419 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. -17))GOTO 23421 CALL UNTILS(LABVAL(SP), TOKEN) 23421 CONTINUE 23420 CONTINUE 23418 CONTINUE 23416 CONTINUE 23412 CONTINUE 23410 CONTINUE 23403 SP = SP - 1 GOTO 23402 23404 CONTINUE RETURN END SUBROUTINE ULSTAL(NAME, DEFN) LOGICAL*1 NAME(100), DEFN(100) CALL INSTAL(NAME, DEFN) CALL UPPER(NAME) CALL INSTAL(NAME, DEFN) RETURN END SUBROUTINE REPCOD(LAB) INTEGER LABGEN INTEGER LAB CALL OUTCON(0) LAB = LABGEN(3) CALL OUTCON(LAB) LAB = LAB + 1 RETURN END SUBROUTINE UNTILS(LAB, TOKEN) LOGICAL*1 PTOKEN(100) INTEGER LEX INTEGER JUNK, LAB, TOKEN COMMON /CGOTO/ XFER INTEGER XFER XFER = 0 CALL OUTNUM(LAB) IF(.NOT.(TOKEN .EQ. -18))GOTO 23423 JUNK = LEX(PTOKEN) CALL IFGO(LAB-1) GOTO 23424 23423 CONTINUE CALL OUTGO(LAB-1) 23424 CONTINUE CALL OUTCON(LAB+1) RETURN END SUBROUTINE RETCOD LOGICAL*1 TOKEN(100), GNBTOK, T COMMON /CFNAME/ FCNAME(40) LOGICAL*1 FCNAME COMMON /CGOTO/ XFER INTEGER XFER 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 23425 CALL PBSTR(TOKEN) CALL OUTTAB CALL OUTSTR(FCNAME) CALL OUTCH(61) CALL EATUP CALL OUTDON GOTO 23426 23425 CONTINUE IF(.NOT.(T .EQ. 125))GOTO 23427 CALL PBSTR(TOKEN) 23427 CONTINUE 23426 CONTINUE CALL OUTTAB CALL OUTSTR(SRET) CALL OUTDON XFER = 1 RETURN END SUBROUTINE STRDCL LOGICAL*1 T, TOKEN(100), GNBTOK, ESC INTEGER I, J, K, N, LEN INTEGER LENGTH, CTOI, LEX, ELENTH LOGICAL*1 DCHAR(100) COMMON /CSBUF/ SBP, SBUF(500) INTEGER SBP LOGICAL*1 SBUF 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 23429 CALL SYNERR(21Hmissing string token.) 23429 CONTINUE CALL OUTTAB CALL PBSTR(CHAR) 23431 CONTINUE T = GNBTOK(DCHAR, 100) IF(.NOT.(T .EQ. 47))GOTO 23434 GOTO 23433 23434 CONTINUE CALL OUTSTR (DCHAR) 23432 GOTO 23431 23433 CONTINUE CALL OUTCH(32) CALL OUTSTR(TOKEN) CALL ADDSTR(TOKEN, SBUF, SBP, 500) CALL ADDCHR(0, SBUF, SBP, 500) IF(.NOT.(GNBTOK(TOKEN, 100) .NE. 40))GOTO 23436 LEN = ELENTH(TOKEN) + 1 IF(.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34))GOTO 23438 LEN = LEN - 2 23438 CONTINUE GOTO 23437 23436 CONTINUE T = GNBTOK(TOKEN, 100) I = 1 LEN = CTOI(TOKEN, I) IF(.NOT.(TOKEN(I) .NE. 0))GOTO 23440 CALL SYNERR(20Hinvalid string size.) 23440 CONTINUE IF(.NOT.(GNBTOK(TOKEN, 100) .NE. 41))GOTO 23442 CALL SYNERR(20Hmissing right paren.) GOTO 23443 23442 CONTINUE T = GNBTOK(TOKEN, 100) 23443 CONTINUE 23437 CONTINUE CALL OUTCH(40) CALL OUTNUM(LEN) CALL OUTCH(41) CALL OUTDON IF(.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34))GOTO 23444 LEN = LENGTH(TOKEN) TOKEN(LEN) = 0 CALL ADDSTR(TOKEN(2), SBUF, SBP, 500) GOTO 23445 23444 CONTINUE CALL ADDSTR(TOKEN, SBUF, SBP, 500) 23445 CONTINUE CALL ADDCHR(0, SBUF, SBP, 500) T = LEX(TOKEN) CALL PBSTR(TOKEN) IF(.NOT.(T .NE. -23))GOTO 23446 I = 1 23448 IF(.NOT.(I .LT. SBP))GOTO 23450 CALL OUTTAB CALL OUTSTR(DAT) K = 1 J = I + LENGTH(SBUF(I)) + 1 23451 CONTINUE IF(.NOT.(K .GT. 1))GOTO 23454 CALL OUTCH(44) 23454 CONTINUE CALL OUTSTR(SBUF(I)) CALL OUTCH(40) CALL OUTNUM(K) CALL OUTCH(41) CALL OUTCH(47) IF(.NOT.(SBUF(J) .EQ. 0))GOTO 23456 GOTO 23453 23456 CONTINUE N = ESC(SBUF, J) CALL OUTNUM (N) CALL OUTCH(47) K = K + 1 23452 J = J + 1 GOTO 23451 23453 CONTINUE CALL PBSTR(EOSS) 23458 CONTINUE T = GNBTOK(TOKEN, 100) CALL OUTSTR(TOKEN) 23459 IF(.NOT.(T .EQ. 47))GOTO 23458 23460 CONTINUE CALL OUTDON 23449 I = J + 1 GOTO 23448 23450 CONTINUE SBP = 1 23446 CONTINUE RETURN END SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ LOGICAL*1 C, BUF(100) IF(.NOT.(BP .GT. MAXSIZ))GOTO 23461 CALL BADERR(16Hbuffer overflow.) 23461 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 23463 IF(.NOT.(S(I) .NE. 0))GOTO 23465 CALL ADDCHR(S(I), BUF, BP, MAXSIZ) 23464 I=I+1 GOTO 23463 23465 CONTINUE RETURN END INTEGER FUNCTION ALLDIG(STR) LOGICAL*1 TYPE LOGICAL*1 STR(100) INTEGER I ALLDIG = 0 IF(.NOT.(STR(1) .EQ. 0))GOTO 23466 RETURN 23466 CONTINUE I = 1 23468 IF(.NOT.(STR(I) .NE. 0))GOTO 23470 IF(.NOT.(TYPE(STR(I)) .NE. 2))GOTO 23471 RETURN 23471 CONTINUE 23469 I = I + 1 GOTO 23468 23470 CONTINUE ALLDIG = 1 RETURN END INTEGER FUNCTION LABGEN(N) INTEGER N COMMON /CLABEL/ LABEL INTEGER LABEL LABGEN = LABEL LABEL = LABEL + N RETURN END SUBROUTINE SKPBLK(FD) INTEGER FD LOGICAL*1 C, NGETCH C = NGETCH(C, FD) 23473 IF(.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23475 23474 C = NGETCH(C, FD) GOTO 23473 23475 CONTINUE CALL PUTBAK(C) RETURN END SUBROUTINE CASCOD(LAB, TOKEN) INTEGER LAB, TOKEN INTEGER T, L, LB, UB, I, J LOGICAL*1 TOK(100) INTEGER CASLAB, LABGEN, GNBTOK COMMON /CSWTCH/ SWTOP, SWLAST, SWSTAK(1000) INTEGER SWTOP INTEGER SWLAST INTEGER SWSTAK COMMON /CGOTO/ XFER INTEGER XFER IF(.NOT.(SWTOP .LE. 0))GOTO 23476 CALL SYNERR(24Hillegal case or default.) RETURN 23476 CONTINUE CALL OUTGO(LAB+1) XFER = 1 L = LABGEN(1) IF(.NOT.(TOKEN .EQ. -25))GOTO 23478 23480 IF(.NOT.(CASLAB(LB, T) .NE. -1))GOTO 23481 UB = LB IF(.NOT.(T .EQ. 45))GOTO 23482 JUNK = CASLAB(UB, T) 23482 CONTINUE IF(.NOT.(LB .GT. UB))GOTO 23484 CALL SYNERR(28Hillegal range in case label.) UB = LB 23484 CONTINUE IF(.NOT.(SWLAST + 3 .GT. 1000))GOTO 23486 CALL BADERR(22Hswitch table overflow.) 23486 CONTINUE I = SWTOP + 3 23488 IF(.NOT.(I .LT. SWLAST))GOTO 23490 IF(.NOT.(LB .LE. SWSTAK(I)))GOTO 23491 GOTO 23490 23491 CONTINUE IF(.NOT.(LB .LE. SWSTAK(I+1)))GOTO 23493 CALL SYNERR(21Hduplicate case label.) 23493 CONTINUE 23492 CONTINUE 23489 I = I + 3 GOTO 23488 23490 CONTINUE IF(.NOT.(I .LT. SWLAST .AND. UB .GE. SWSTAK(I)))GOTO 23495 CALL SYNERR(21Hduplicate case label.) 23495 CONTINUE J = SWLAST 23497 IF(.NOT.(J .GT. I))GOTO 23499 SWSTAK(J+2) = SWSTAK(J-1) 23498 J = J - 1 GOTO 23497 23499 CONTINUE SWSTAK(I) = LB SWSTAK(I+1) = UB SWSTAK(I+2) = L SWSTAK(SWTOP+1) = SWSTAK(SWTOP+1) + 1 SWLAST = SWLAST + 3 IF(.NOT.(T .EQ. 58))GOTO 23500 GOTO 23481 23500 CONTINUE IF(.NOT.(T .NE. 44))GOTO 23502 CALL SYNERR(20Hillegal case syntax.) 23502 CONTINUE 23501 CONTINUE GOTO 23480 23481 CONTINUE GOTO 23479 23478 CONTINUE T = GNBTOK(TOK, 100) IF(.NOT.(SWSTAK(SWTOP+2) .NE. 0))GOTO 23504 CALL ERROR(38Hmultiple defaults in switch statement.) GOTO 23505 23504 CONTINUE SWSTAK(SWTOP+2) = L 23505 CONTINUE 23479 CONTINUE IF(.NOT.(T .EQ. -1))GOTO 23506 CALL SYNERR(15Hunexpected EOF.) GOTO 23507 23506 CONTINUE IF(.NOT.(T .NE. 58))GOTO 23508 CALL ERROR(39Hmissing colon in case or default label.) 23508 CONTINUE 23507 CONTINUE XFER = 0 CALL OUTCON(L) RETURN END INTEGER FUNCTION CASLAB(N, T) INTEGER N, T LOGICAL*1 TOK(100) INTEGER I, S INTEGER GNBTOK, CTOI T = GNBTOK(TOK, 100) 23510 IF(.NOT.(T .EQ. 10))GOTO 23511 T = GNBTOK(TOK, 100) GOTO 23510 23511 CONTINUE IF(.NOT.(T .EQ. -1))GOTO 23512 CASLAB=(T) RETURN 23512 CONTINUE IF(.NOT.(T .EQ. 45))GOTO 23514 S = -1 GOTO 23515 23514 CONTINUE S = +1 23515 CONTINUE IF(.NOT.(T .EQ. 45 .OR. T .EQ. 43))GOTO 23516 T = GNBTOK(TOK, 100) 23516 CONTINUE IF(.NOT.(T .NE. 2))GOTO 23518 CALL SYNERR(19Hinvalid case label.) N = 0 GOTO 23519 23518 CONTINUE I = 1 N = S*CTOI(TOK, I) 23519 CONTINUE T = GNBTOK(TOK, 100) 23520 IF(.NOT.(T .EQ. 10))GOTO 23521 T = GNBTOK(TOK, 100) GOTO 23520 23521 CONTINUE RETURN END SUBROUTINE SWCODE(LAB) INTEGER LAB LOGICAL*1 TOK(100) INTEGER LABGEN, GNBTOK COMMON /CSWTCH/ SWTOP, SWLAST, SWSTAK(1000) INTEGER SWTOP INTEGER SWLAST INTEGER SWSTAK COMMON /CGOTO/ XFER INTEGER XFER LAB = LABGEN(2) IF(.NOT.(SWLAST + 3 .GT. 1000))GOTO 23522 CALL BADERR(22Hswitch table overflow.) 23522 CONTINUE SWSTAK(SWLAST) = SWTOP SWSTAK(SWLAST+1) = 0 SWSTAK(SWLAST+2) = 0 SWTOP = SWLAST SWLAST = SWLAST + 3 XFER = 0 CALL OUTTAB CALL SWVAR(LAB) CALL OUTCH(61) CALL BALPAR CALL OUTDON CALL OUTGO(LAB) XFER = 1 23524 IF(.NOT.(GNBTOK(TOK, 100) .EQ. 10))GOTO 23525 GOTO 23524 23525 CONTINUE IF(.NOT.(TOK(1) .NE. 123))GOTO 23526 CALL SYNERR(39Hmissing left brace in switch statement.) CALL PBSTR(TOK) 23526 CONTINUE RETURN END SUBROUTINE SWEND(LAB) INTEGER LAB INTEGER LB, UB, N, I, J COMMON /CSWTCH/ SWTOP, SWLAST, SWSTAK(1000) INTEGER SWTOP INTEGER SWLAST INTEGER SWSTAK COMMON /CGOTO/ XFER INTEGER XFER LOGICAL*1 SIF(4) LOGICAL*1 SLT(10) LOGICAL*1 SGT(5) LOGICAL*1 SGOTO(6) LOGICAL*1 SEQ(5) LOGICAL*1 SGE(5) LOGICAL*1 SLE(5) LOGICAL*1 SAND(6) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/40/,SIF(4)/0/ DATA SLT(1)/46/,SLT(2)/108/,SLT(3)/116/,SLT(4)/46/,SLT(5)/49/,SLT( *6)/46/,SLT(7)/111/,SLT(8)/114/,SLT(9)/46/,SLT(10)/0/ DATA SGT(1)/46/,SGT(2)/103/,SGT(3)/116/,SGT(4)/46/,SGT(5)/0/ DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/40/,SGOTO(6)/0/ DATA SEQ(1)/46/,SEQ(2)/101/,SEQ(3)/113/,SEQ(4)/46/,SEQ(5)/0/ DATA SGE(1)/46/,SGE(2)/103/,SGE(3)/101/,SGE(4)/46/,SGE(5)/0/ DATA SLE(1)/46/,SLE(2)/108/,SLE(3)/101/,SLE(4)/46/,SLE(5)/0/ DATA SAND(1)/46/,SAND(2)/97/,SAND(3)/110/,SAND(4)/100/,SAND(5)/46/ *,SAND(6)/0/ LB = SWSTAK(SWTOP+3) UB = SWSTAK(SWLAST-2) N = SWSTAK(SWTOP+1) CALL OUTGO(LAB+1) IF(.NOT.(SWSTAK(SWTOP+2) .EQ. 0))GOTO 23528 SWSTAK(SWTOP+2) = LAB + 1 23528 CONTINUE XFER = 0 CALL OUTCON(LAB) IF(.NOT.(N .GE. 3 .AND. UB - LB + 1 .LT. 2*N))GOTO 23530 IF(.NOT.(LB .NE. 1))GOTO 23532 CALL OUTTAB CALL SWVAR(LAB) CALL OUTCH(61) CALL SWVAR(LAB) IF(.NOT.(LB .LT. 1))GOTO 23534 CALL OUTCH(43) 23534 CONTINUE CALL OUTNUM(-LB + 1) CALL OUTDON 23532 CONTINUE CALL OUTTAB CALL OUTSTR(SIF) CALL SWVAR(LAB) CALL OUTSTR(SLT) CALL SWVAR(LAB) CALL OUTSTR(SGT) CALL OUTNUM(UB - LB + 1) CALL OUTCH(41) CALL OUTGO(SWSTAK(SWTOP+2)) CALL OUTTAB CALL OUTSTR(SGOTO) J = LB I = SWTOP + 3 23536 IF(.NOT.(I .LT. SWLAST))GOTO 23538 23539 IF(.NOT.(J .LT. SWSTAK(I)))GOTO 23541 CALL OUTNUM(SWSTAK(SWTOP+2)) CALL OUTCH(44) 23540 J = J + 1 GOTO 23539 23541 CONTINUE J = SWSTAK(I+1) - SWSTAK(I) 23542 IF(.NOT.(J .GE. 0))GOTO 23544 CALL OUTNUM(SWSTAK(I+2)) 23543 J = J - 1 GOTO 23542 23544 CONTINUE J = SWSTAK(I+1) + 1 IF(.NOT.(I .LT. SWLAST - 3))GOTO 23545 CALL OUTCH(44) 23545 CONTINUE 23537 I = I + 3 GOTO 23536 23538 CONTINUE CALL OUTCH(41) CALL OUTCH(44) CALL SWVAR(LAB) CALL OUTDON GOTO 23531 23530 CONTINUE IF(.NOT.(N .GT. 0))GOTO 23547 I = SWTOP + 3 23549 IF(.NOT.(I .LT. SWLAST))GOTO 23551 CALL OUTTAB CALL OUTSTR(SIF) CALL SWVAR(LAB) IF(.NOT.(SWSTAK(I) .EQ. SWSTAK(I+1)))GOTO 23552 CALL OUTSTR(SEQ) CALL OUTNUM(SWSTAK(I)) GOTO 23553 23552 CONTINUE CALL OUTSTR(SGE) CALL OUTNUM(SWSTAK(I)) CALL OUTSTR(SAND) CALL SWVAR(LAB) CALL OUTSTR(SLE) CALL OUTNUM(SWSTAK(I+1)) 23553 CONTINUE CALL OUTCH(41) CALL OUTGO(SWSTAK(I+2)) 23550 I = I + 3 GOTO 23549 23551 CONTINUE IF(.NOT.(LAB + 1 .NE. SWSTAK(SWTOP+2)))GOTO 23554 CALL OUTGO(SWSTAK(SWTOP+2)) 23554 CONTINUE 23547 CONTINUE 23531 CONTINUE CALL OUTCON(LAB+1) SWLAST = SWTOP SWTOP = SWSTAK(SWTOP) RETURN END SUBROUTINE SWVAR(LAB) INTEGER LAB CALL OUTCH(73) CALL OUTNUM(LAB) RETURN END SUBROUTINE WHILEC(LAB) INTEGER LABGEN INTEGER LAB 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 SUBROUTINE LITRAL INTEGER GETLIN, INDEX INTEGER I COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP LOGICAL*1 OUTBUF COMMON /CLINE/ LEVEL, LINECT(3), INFILE(3), FNAMP, FNAMES(120) INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP LOGICAL*1 FNAMES IF(.NOT.(OUTP .GT. 0))GOTO 23556 CALL OUTDON 23556 CONTINUE I = GETLIN (OUTBUF, INFILE(LEVEL)) 23558 IF(.NOT.( GETLIN (OUTBUF, INFILE(LEVEL)) .NE. -1 ))GOTO 23559 I = 1 CALL SKIPBL (OUTBUF, I) IF(.NOT.(OUTBUF(I) .EQ. 37))GOTO 23560 GOTO 23559 23560 CONTINUE CALL PUTLIN (OUTBUF, 2) LINECT(LEVEL) = LINECT(LEVEL) + 1 GOTO 23558 23559 CONTINUE OUTP = 0 RETURN END SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN INTEGER I, N, ALLDIG, CTOI LOGICAL*1 T, PTOKEN(100), GNBTOK COMMON /CGOTO/ XFER INTEGER XFER N = 0 T = GNBTOK(PTOKEN, 100) IF(.NOT.(ALLDIG(PTOKEN) .EQ. 1))GOTO 23562 I = 1 N = CTOI(PTOKEN, I) - 1 GOTO 23563 23562 CONTINUE IF(.NOT.(T .NE. 59))GOTO 23564 CALL PBSTR(PTOKEN) 23564 CONTINUE 23563 CONTINUE I = SP 23566 IF(.NOT.(I .GT. 0))GOTO 23568 IF(.NOT.(LEXTYP(I) .EQ. -15 .OR. LEXTYP(I) .EQ. -10 .OR. LEXTYP(I) * .EQ. -16 .OR. LEXTYP(I) .EQ. -17))GOTO 23569 IF(.NOT.(N .GT. 0))GOTO 23571 N = N - 1 GOTO 23567 23571 CONTINUE IF(.NOT.(TOKEN .EQ. -8))GOTO 23573 CALL OUTGO(LABVAL(I)+1) GOTO 23574 23573 CONTINUE CALL OUTGO(LABVAL(I)) 23574 CONTINUE 23572 CONTINUE XFER = 1 RETURN 23569 CONTINUE 23567 I = I - 1 GOTO 23566 23568 CONTINUE IF(.NOT.(TOKEN .EQ. -8))GOTO 23575 CALL SYNERR(14Hillegal break.) GOTO 23576 23575 CONTINUE CALL SYNERR(13Hillegal next.) 23576 CONTINUE RETURN END LOGICAL*1 FUNCTION DEFTOK(TOKEN, TOKSIZ, FD) LOGICAL*1 TOKEN(100) INTEGER TOKSIZ, FD LOGICAL*1 GTOK INTEGER LOOKUP, PUSH, IFPARM LOGICAL*1 T, C, DEFN(200), BALP(3), MDEFN(200) INTEGER AP, ARGSTK(100), CALLST(50), NLB, PLEV(50), IFL COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST DATA BALP/40, 41, 0/ CP = 0 AP = 1 EP = 1 T=GTOK(TOKEN,TOKSIZ,FD) 23577 IF(.NOT.(T .NE. -1))GOTO 23579 IF(.NOT.(T .EQ. -9))GOTO 23580 IF(.NOT.(LOOKUP(TOKEN, DEFN) .EQ. 0))GOTO 23582 IF(.NOT.(CP .EQ. 0))GOTO 23584 GOTO 23579 23584 CONTINUE CALL PUTTOK(TOKEN) 23585 CONTINUE GOTO 23583 23582 CONTINUE IF(.NOT.(DEFN(1) .EQ. -4))GOTO 23586 CALL GETDEF(TOKEN, TOKSIZ, DEFN, 200, FD) CALL INSTAL(TOKEN, DEFN) GOTO 23587 23586 CONTINUE IF(.NOT.(DEFN(1) .EQ. -15 .OR. DEFN(1) .EQ. -16))GOTO 23588 C = DEFN(1) CALL GETDEF(TOKEN, TOKSIZ, DEFN, 200, FD) IFL = LOOKUP(TOKEN, MDEFN) IF(.NOT.((IFL .EQ. 1 .AND. C .EQ. -15) .OR. (IFL .EQ. 0 .AND. C .E *Q. -16)))GOTO 23590 CALL PBSTR(DEFN) 23590 CONTINUE GOTO 23589 23588 CONTINUE CP = CP + 1 IF(.NOT.(CP .GT. 50))GOTO 23592 CALL BADERR(20Hcall stack overflow.) 23592 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 = GTOK(TOKEN, TOKSIZ, FD) CALL PBSTR(TOKEN) IF(.NOT.(T .NE. 40))GOTO 23594 CALL PBSTR(BALP) GOTO 23595 23594 CONTINUE IF(.NOT.(IFPARM(DEFN) .EQ. 0))GOTO 23596 CALL PBSTR(BALP) 23596 CONTINUE 23595 CONTINUE PLEV(CP) = 0 23589 CONTINUE 23587 CONTINUE 23583 CONTINUE GOTO 23581 23580 CONTINUE IF(.NOT.(T .EQ. -10))GOTO 23598 NLB = 1 23600 CONTINUE T = GTOK(TOKEN, TOKSIZ, FD) IF(.NOT.(T .EQ. -10))GOTO 23603 NLB = NLB + 1 GOTO 23604 23603 CONTINUE IF(.NOT.(T .EQ. -11))GOTO 23605 NLB = NLB - 1 IF(.NOT.(NLB .EQ. 0))GOTO 23607 GOTO 23602 23607 CONTINUE GOTO 23606 23605 CONTINUE IF(.NOT.(T .EQ. -1))GOTO 23609 CALL BADERR(14HEOF in string.) 23609 CONTINUE 23606 CONTINUE 23604 CONTINUE CALL PUTTOK(TOKEN) 23601 GOTO 23600 23602 CONTINUE GOTO 23599 23598 CONTINUE IF(.NOT.(CP .EQ. 0))GOTO 23611 GOTO 23579 23611 CONTINUE IF(.NOT.(T .EQ. 40))GOTO 23613 IF(.NOT.(PLEV(CP) .GT. 0))GOTO 23615 CALL PUTTOK(TOKEN) 23615 CONTINUE PLEV(CP) = PLEV(CP) + 1 GOTO 23614 23613 CONTINUE IF(.NOT.(T .EQ. 41))GOTO 23617 PLEV(CP) = PLEV(CP) - 1 IF(.NOT.(PLEV(CP) .GT. 0))GOTO 23619 CALL PUTTOK(TOKEN) GOTO 23620 23619 CONTINUE CALL PUTCHR(0) CALL EVALR(ARGSTK, CALLST(CP), AP-1) AP = CALLST(CP) EP = ARGSTK(AP) CP = CP - 1 23620 CONTINUE GOTO 23618 23617 CONTINUE IF(.NOT.(T .EQ. 44 .AND. PLEV(CP) .EQ. 1))GOTO 23621 CALL PUTCHR(0) AP = PUSH(EP, ARGSTK, AP) GOTO 23622 23621 CONTINUE CALL PUTTOK(TOKEN) 23622 CONTINUE 23618 CONTINUE 23614 CONTINUE 23612 CONTINUE 23599 CONTINUE 23581 CONTINUE 23578 T=GTOK(TOKEN,TOKSIZ,FD) GOTO 23577 23579 CONTINUE DEFTOK = T IF(.NOT.(T .EQ. -9))GOTO 23623 CALL FOLD(TOKEN) 23623 CONTINUE RETURN END SUBROUTINE DOARTH(ARGSTK,I,J) INTEGER CTOI INTEGER ARGSTK(100), I, J, K, L LOGICAL*1 OP COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST K = ARGSTK(I+2) L = ARGSTK(I+4) OP = EVALST(ARGSTK(I+3)) IF(.NOT.(OP .EQ. 43))GOTO 23625 CALL PBNUM(CTOI(EVALST,K)+CTOI(EVALST,L)) GOTO 23626 23625 CONTINUE IF(.NOT.(OP .EQ. 45))GOTO 23627 CALL PBNUM(CTOI(EVALST,K)-CTOI(EVALST,L)) GOTO 23628 23627 CONTINUE IF(.NOT.(OP .EQ. 42 ))GOTO 23629 CALL PBNUM(CTOI(EVALST,K)*CTOI(EVALST,L)) GOTO 23630 23629 CONTINUE IF(.NOT.(OP .EQ. 47 ))GOTO 23631 CALL PBNUM(CTOI(EVALST,K)/CTOI(EVALST,L)) GOTO 23632 23631 CONTINUE CALL REMARK(11Harith error) 23632 CONTINUE 23630 CONTINUE 23628 CONTINUE 23626 CONTINUE RETURN END SUBROUTINE DOIF(ARGSTK, I, J) INTEGER EQUAL INTEGER A2, A3, A4, A5, ARGSTK(100), I, J COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST IF(.NOT.(J - I .LT. 5))GOTO 23633 RETURN 23633 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 23635 CALL PBSTR(EVALST(A4)) GOTO 23636 23635 CONTINUE CALL PBSTR(EVALST(A5)) 23636 CONTINUE RETURN END SUBROUTINE DOINCR(ARGSTK, I, J) INTEGER CTOI INTEGER ARGSTK(100), I, J, K COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST K = ARGSTK(I+2) CALL PBNUM(CTOI(EVALST, K)+1) RETURN END SUBROUTINE DOSUB(ARGSTK, I, J) INTEGER CTOI, LENGTH INTEGER AP, ARGSTK(100), FC, I, J, K, NC COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST IF(.NOT.(J - I .LT. 3))GOTO 23637 RETURN 23637 CONTINUE IF(.NOT.(J - I .LT. 4))GOTO 23639 NC = 100 GOTO 23640 23639 CONTINUE K = ARGSTK(I+4) NC = CTOI(EVALST, K) 23640 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 23 *641 K = FC + MIN0(NC, LENGTH(EVALST(FC))) - 1 23643 IF(.NOT.(K .GE. FC))GOTO 23645 CALL PUTBAK(EVALST(K)) 23644 K = K - 1 GOTO 23643 23645 CONTINUE 23641 CONTINUE RETURN END SUBROUTINE EVALR(ARGSTK, I, J) INTEGER INDEX, LENGTH INTEGER ARGNO, ARGSTK(100), I, J, K, M, N, T, TD COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST LOGICAL*1 DIGITS(11) DATA DIGITS(1) /48/ DATA DIGITS(2) /49/ DATA DIGITS(3) /50/ DATA DIGITS(4) /51/ DATA DIGITS(5) /52/ DATA DIGITS(6) /53/ DATA DIGITS(7) /54/ DATA DIGITS(8) /55/ DATA DIGITS(9) /56/ DATA DIGITS(10) /57/ DATA DIGITS(11) /0/ T = ARGSTK(I) TD = EVALST(T) IF(.NOT.(TD .EQ. -12))GOTO 23646 CALL DOINCR(ARGSTK, I, J) GOTO 23647 23646 CONTINUE IF(.NOT.(TD .EQ. -13))GOTO 23648 CALL DOSUB(ARGSTK, I, J) GOTO 23649 23648 CONTINUE IF(.NOT.(TD .EQ. -11))GOTO 23650 CALL DOIF(ARGSTK, I, J) GOTO 23651 23650 CONTINUE IF(.NOT.(TD .EQ. -14))GOTO 23652 CALL DOARTH(ARGSTK, I, J) GOTO 23653 23652 CONTINUE K = T+LENGTH(EVALST(T))-1 23654 IF(.NOT.(K .GT. T))GOTO 23656 IF(.NOT.(EVALST(K-1) .NE. 36))GOTO 23657 CALL PUTBAK(EVALST(K)) GOTO 23658 23657 CONTINUE ARGNO = INDEX(DIGITS, EVALST(K)) - 1 IF(.NOT.(ARGNO .GE. 0 .AND. ARGNO .LT. J-I))GOTO 23659 N = I + ARGNO + 1 M = ARGSTK(N) CALL PBSTR(EVALST(M)) 23659 CONTINUE K = K - 1 23658 CONTINUE 23655 K = K - 1 GOTO 23654 23656 CONTINUE IF(.NOT.(K .EQ. T))GOTO 23661 CALL PUTBAK(EVALST(K)) 23661 CONTINUE 23653 CONTINUE 23651 CONTINUE 23649 CONTINUE 23647 CONTINUE RETURN END INTEGER FUNCTION IFPARM(STRNG) LOGICAL*1 STRNG(100), C INTEGER I, INDEX, TYPE C = STRNG(1) IF(.NOT.(C .EQ. -12 .OR. C .EQ. -13 .OR. C .EQ. -11 .OR. C .EQ. -1 *4 .OR. C .EQ. -15))GOTO 23663 IFPARM = 1 GOTO 23664 23663 CONTINUE IFPARM = 0 I=1 23665 IF(.NOT.(INDEX(STRNG(I), 36) .GT. 0))GOTO 23667 I = I + INDEX(STRNG(I), 36) IF(.NOT.(TYPE(STRNG(I)) .EQ. 2))GOTO 23668 IF(.NOT.(TYPE(STRNG(I+1)) .NE. 2))GOTO 23670 IFPARM = 1 GOTO 23667 23670 CONTINUE 23668 CONTINUE 23666 GOTO 23665 23667 CONTINUE 23664 CONTINUE RETURN END SUBROUTINE PBNUM(N) INTEGER MOD INTEGER M, N, NUM LOGICAL*1 DIGITS(11) DATA DIGITS(1) /48/ DATA DIGITS(2) /49/ DATA DIGITS(3) /50/ DATA DIGITS(4) /51/ DATA DIGITS(5) /52/ DATA DIGITS(6) /53/ DATA DIGITS(7) /54/ DATA DIGITS(8) /55/ DATA DIGITS(9) /56/ DATA DIGITS(10) /57/ DATA DIGITS(11) /0/ NUM = IABS(N) 23672 CONTINUE M = MOD(NUM, 10) CALL PUTBAK(DIGITS(M+1)) NUM = NUM / 10 23673 IF(.NOT.(NUM .EQ. 0))GOTO 23672 23674 CONTINUE IF(.NOT.(N .LT. 0))GOTO 23675 CALL PUTBAK(45) 23675 CONTINUE RETURN END INTEGER FUNCTION PUSH(EP, ARGSTK, AP) INTEGER AP, ARGSTK(100), EP IF(.NOT.(AP .GT. 100))GOTO 23677 CALL BADERR(19Harg stack overflow.) 23677 CONTINUE ARGSTK(AP) = EP PUSH = AP + 1 RETURN END SUBROUTINE PUTCHR(C) LOGICAL*1 C COMMON /CMACRO/ CP, EP, EVALST(500) INTEGER CP INTEGER EP LOGICAL*1 EVALST IF(.NOT.(EP .GT. 500))GOTO 23679 CALL BADERR(26Hevaluation stack overflow.) 23679 CONTINUE EVALST(EP) = C EP = EP + 1 RETURN END SUBROUTINE PUTTOK(STR) LOGICAL*1 STR(100) INTEGER I I = 1 23681 IF(.NOT.(STR(I) .NE. 0))GOTO 23683 CALL PUTCHR(STR(I)) 23682 I = I + 1 GOTO 23681 23683 CONTINUE RETURN END INTEGER FUNCTION ELENTH(BUF) LOGICAL*1 BUF(100), C LOGICAL*1 ESC INTEGER I, N N = 0 I=1 23684 IF(.NOT.(BUF(I) .NE. 0))GOTO 23686 C = ESC(BUF, I) N = N + 1 23685 I=I+1 GOTO 23684 23686 CONTINUE ELENTH = N RETURN END