========== start of info ========== Tue Mar 2 10:33:30 EST 1976 0 0 00 1 1 01 2 2 02 3 3 03 4 4 37 5 5 2D 6 6 2E 7 7 2F bs 8 10 16 tab 9 11 05 10 12 25 11 13 0B 12 14 0C 13 15 0D 14 16 0E 15 17 0F 16 20 10 17 21 11 18 22 12 19 23 13 20 24 3C 21 25 3D 22 26 32 23 27 26 24 30 18 25 31 19 26 32 3F 27 33 27 28 34 1C 29 35 1D 30 36 1E 31 37 1F blnk 32 40 40 ! 33 41 5A " 34 42 7F # 35 43 7B $ 36 44 5B % 37 45 6C & 38 46 50 ' 39 47 7D ( 40 50 4D ) 41 51 5D * 42 52 5C + 43 53 4E , 44 54 6B - 45 55 60 . 46 56 4B / 47 57 61 0 48 60 F0 1 49 61 F1 2 50 62 F2 3 51 63 F3 4 52 64 F4 5 53 65 F5 6 54 66 F6 7 55 67 F7 8 56 70 F8 9 57 71 F9 : 58 72 7A ; 59 73 5E < 60 74 4C = 61 75 7E > 62 76 6E ? 63 77 6F @ 64 100 7C A 65 101 C1 B 66 102 C2 C 67 103 C3 D 68 104 C4 E 69 105 C5 F 70 106 C6 G 71 107 C7 H 72 110 C8 I 73 111 C9 J 74 112 D1 K 75 113 D2 L 76 114 D3 M 77 115 D4 N 78 116 D5 O 79 117 D6 P 80 120 D7 Q 81 121 D8 R 82 122 D9 S 83 123 E2 T 84 124 E3 U 85 125 E4 V 86 126 E5 W 87 127 E6 X 88 130 E7 Y 89 131 E8 Z 90 132 E9 [ 91 133 AD \ 92 134 E0 ] 93 135 BD ~ 94 136 5F _ 95 137 6D ` 96 140 79 a 97 141 81 b 98 142 82 c 99 143 83 d 100 144 84 e 101 145 85 f 102 146 86 g 103 147 87 h 104 150 88 i 105 151 89 j 106 152 91 k 107 153 92 l 108 154 93 m 109 155 94 n 110 156 95 o 111 157 96 p 112 160 97 q 113 161 98 r 114 162 99 s 115 163 A2 t 116 164 A3 u 117 165 A4 v 118 166 A5 w 119 167 A6 x 120 170 A7 y 121 171 A8 z 122 172 A9 { 123 173 C0 | 124 174 4F $@$ 125 175 D0 ^ 126 176 A1 127 177 07 not 94 136 5F ========== ratfor in fortran for bootstrap ========== C C BLOCK DATA - INITIALIZE GLOBAL VARIABLES C BLOCK DATA COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF DATA OUTP /0/ DATA LEVEL /1/ DATA LINECT(1) /1/ DATA INFILE(1) /5/ DATA BP /0/ DATA FORDEP /0/ DATA LASTP /0/ DATA LASTT /0/ DATA SDO(1), SDO(2), SDO(3) /100, 111, 10002/ DATA VDO(1), VDO(2) /10266, 10002/ DATA SIF(1), SIF(2), SIF(3) /105, 102, 10002/ DATA VIF(1), VIF(2) /10261, 10002/ DATA SELSE(1), SELSE(2), SELSE(3), SELSE(4), SELSE(5) /101, 108, * 115, 101, 10002/ DATA VELSE(1), VELSE(2) /10262, 10002/ DATA SWHILE(1), SWHILE(2), SWHILE(3), SWHILE(4), SWHILE(5), SWHIL *E(6) /119, 104, 105, 108, 101, 10002/ DATA VWHILE(1), VWHILE(2) /10263, 10002/ DATA SBREAK(1), SBREAK(2), SBREAK(3), SBREAK(4), SBREAK(5), SBREA *K(6) /98, 114, 101, 97, 107, 10002/ DATA VBREAK(1), VBREAK(2) /10264, 10002/ DATA SNEXT(1), SNEXT(2), SNEXT(3), SNEXT(4), SNEXT(5) /110, 101, * 120, 116, 10002/ DATA VNEXT(1), VNEXT(2) /10265, 10002/ DATA SFOR(1), SFOR(2), SFOR(3), SFOR(4) /102, 111, 114, 10002/ DATA VFOR(1), VFOR(2) /10268, 10002/ DATA SREPT(1), SREPT(2), SREPT(3), SREPT(4), SREPT(5), SREPT(6), * SREPT(7) /114, 101, 112, 101, 97, 116, 10002/ DATA VREPT(1), VREPT(2) /10269, 10002/ DATA SUNTIL(1), SUNTIL(2), SUNTIL(3), SUNTIL(4), SUNTIL(5), SUNTI *L(6) /117, 110, 116, 105, 108, 10002/ DATA VUNTIL(1), VUNTIL(2) /10270, 10002/ DATA EXTBLK /1H /, INTBLK /32/ DATA EXTDIG(1) /1H0/, INTDIG(1) /48/ DATA EXTDIG(2) /1H1/, INTDIG(2) /49/ DATA EXTDIG(3) /1H2/, INTDIG(3) /50/ DATA EXTDIG(4) /1H3/, INTDIG(4) /51/ DATA EXTDIG(5) /1H4/, INTDIG(5) /52/ DATA EXTDIG(6) /1H5/, INTDIG(6) /53/ DATA EXTDIG(7) /1H6/, INTDIG(7) /54/ DATA EXTDIG(8) /1H7/, INTDIG(8) /55/ DATA EXTDIG(9) /1H8/, INTDIG(9) /56/ DATA EXTDIG(10) /1H9/, INTDIG(10) /57/ DATA EXTLET(1) /1HA/, INTLET(1) /97/ DATA EXTLET(2) /1HB/, INTLET(2) /98/ DATA EXTLET(3) /1HC/, INTLET(3) /99/ DATA EXTLET(4) /1HD/, INTLET(4) /100/ DATA EXTLET(5) /1HE/, INTLET(5) /101/ DATA EXTLET(6) /1HF/, INTLET(6) /102/ DATA EXTLET(7) /1HG/, INTLET(7) /103/ DATA EXTLET(8) /1HH/, INTLET(8) /104/ DATA EXTLET(9) /1HI/, INTLET(9) /105/ DATA EXTLET(10) /1HJ/, INTLET(10) /106/ DATA EXTLET(11) /1HK/, INTLET(11) /107/ DATA EXTLET(12) /1HL/, INTLET(12) /108/ DATA EXTLET(13) /1HM/, INTLET(13) /109/ DATA EXTLET(14) /1HN/, INTLET(14) /110/ DATA EXTLET(15) /1HO/, INTLET(15) /111/ DATA EXTLET(16) /1HP/, INTLET(16) /112/ DATA EXTLET(17) /1HQ/, INTLET(17) /113/ DATA EXTLET(18) /1HR/, INTLET(18) /114/ DATA EXTLET(19) /1HS/, INTLET(19) /115/ DATA EXTLET(20) /1HT/, INTLET(20) /116/ DATA EXTLET(21) /1HU/, INTLET(21) /117/ DATA EXTLET(22) /1HV/, INTLET(22) /118/ DATA EXTLET(23) /1HW/, INTLET(23) /119/ DATA EXTLET(24) /1HX/, INTLET(24) /120/ DATA EXTLET(25) /1HY/, INTLET(25) /121/ DATA EXTLET(26) /1HZ/, INTLET(26) /122/ DATA EXTBIG(1) /1HA/, INTBIG(1) /65/ DATA EXTBIG(2) /1HB/, INTBIG(2) /66/ DATA EXTBIG(3) /1HC/, INTBIG(3) /67/ DATA EXTBIG(4) /1HD/, INTBIG(4) /68/ DATA EXTBIG(5) /1HE/, INTBIG(5) /69/ DATA EXTBIG(6) /1HF/, INTBIG(6) /70/ DATA EXTBIG(7) /1HG/, INTBIG(7) /71/ DATA EXTBIG(8) /1HH/, INTBIG(8) /72/ DATA EXTBIG(9) /1HI/, INTBIG(9) /73/ DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/ DATA EXTBIG(11) /1HK/, INTBIG(11) /75/ DATA EXTBIG(12) /1HL/, INTBIG(12) /76/ DATA EXTBIG(13) /1HM/, INTBIG(13) /77/ DATA EXTBIG(14) /1HN/, INTBIG(14) /78/ DATA EXTBIG(15) /1HO/, INTBIG(15) /79/ DATA EXTBIG(16) /1HP/, INTBIG(16) /80/ DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/ DATA EXTBIG(18) /1HR/, INTBIG(18) /82/ DATA EXTBIG(19) /1HS/, INTBIG(19) /83/ DATA EXTBIG(20) /1HT/, INTBIG(20) /84/ DATA EXTBIG(21) /1HU/, INTBIG(21) /85/ DATA EXTBIG(22) /1HV/, INTBIG(22) /86/ DATA EXTBIG(23) /1HW/, INTBIG(23) /87/ DATA EXTBIG(24) /1HX/, INTBIG(24) /88/ DATA EXTBIG(25) /1HY/, INTBIG(25) /89/ DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/ DATA EXTCHR(1) /1H!/, INTCHR(1) /33/ DATA EXTCHR(2) /1H"/, INTCHR(2) /34/ DATA EXTCHR(3) /1H#/, INTCHR(3) /35/ DATA EXTCHR(4) /1H$/, INTCHR(4) /36/ DATA EXTCHR(5) /1H%/, INTCHR(5) /37/ DATA EXTCHR(6) /1H&/, INTCHR(6) /38/ DATA EXTCHR(7) /1H'/, INTCHR(7) /39/ DATA EXTCHR(8) /1H(/, INTCHR(8) /40/ DATA EXTCHR(9) /1H)/, INTCHR(9) /41/ DATA EXTCHR(10) /1H*/, INTCHR(10) /42/ DATA EXTCHR(11) /1H+/, INTCHR(11) /43/ DATA EXTCHR(12) /1H,/, INTCHR(12) /44/ DATA EXTCHR(13) /1H-/, INTCHR(13) /45/ DATA EXTCHR(14) /1H./, INTCHR(14) /46/ DATA EXTCHR(15) /1H//, INTCHR(15) /47/ DATA EXTCHR(16) /1H:/, INTCHR(16) /58/ DATA EXTCHR(17) /1H;/, INTCHR(17) /59/ DATA EXTCHR(18) /1H/, INTCHR(20) /62/ DATA EXTCHR(21) /1H?/, INTCHR(21) /63/ DATA EXTCHR(22) /1H@/, INTCHR(22) /64/ DATA EXTCHR(23) /1H[/, INTCHR(23) /91/ DATA EXTCHR(24) /1H\/, INTCHR(24) /92/ DATA EXTCHR(25) /1H]/, INTCHR(25) /93/ DATA EXTCHR(26) /1H_/, INTCHR(26) /95/ DATA EXTCHR(27) /1H{/, INTCHR(27) /123/ DATA EXTCHR(28) /1H|/, INTCHR(28) /124/ DATA EXTCHR(29) /1H$@$/, INTCHR(29) /125/ DATA EXTCHR(30) /1H/, INTCHR(30) /8/ DATA EXTCHR(31) /1H /, INTCHR(31) /9/ DATA EXTCHR(32) /1H~/, INTCHR(32) /33/ DATA EXTCHR(33) /1H^/, INTCHR(33) /33/ END C C RATFOR - MAIN PROGRAM FOR RATFOR C CALL PARSE STOP END C C ALLDIG - RETURN YES IF STR IS ALL DIGITS C INTEGER FUNCTION ALLDIG(STR) INTEGER TYPE INTEGER STR(100) INTEGER I ALLDIG = 0 IF(.NOT.(STR(1) .EQ. 10002)) GOTO 23000 RETURN 23000 CONTINUE CONTINUE I = 1 23002 IF(.NOT.( STR(I) .NE. 10002)) GOTO 23004 IF(.NOT.(TYPE(STR(I)) .NE. 2)) GOTO 23005 RETURN 23005 CONTINUE 23003 I = I + 1 GOTO 23002 23004 CONTINUE ALLDIG = 1 RETURN END C C BALPAR - COPY BALANCED PAREN STRING C SUBROUTINE BALPAR INTEGER GETTOK INTEGER T, TOKEN(200) INTEGER NLPAR IF(.NOT.(GETTOK(TOKEN, 200) .NE. 40)) GOTO 23007 CALL SYNERR(19HMISSING LEFT PAREN.) RETURN 23007 CONTINUE CALL OUTSTR(TOKEN) NLPAR = 1 CONTINUE 23009 CONTINUE T = GETTOK(TOKEN, 200) IF(.NOT.(T.EQ.59 .OR. T.EQ.123 .OR. T.EQ.125 .OR. T.EQ.10003)) GO *TO 23012 CALL PBSTR(TOKEN) GOTO 23011 23012 CONTINUE IF(.NOT.(T .EQ. 10)) GOTO 23014 TOKEN(1) = 10002 GOTO 23015 23014 CONTINUE IF(.NOT.(T .EQ. 40)) GOTO 23016 NLPAR = NLPAR + 1 GOTO 23017 23016 CONTINUE IF(.NOT.(T .EQ. 41)) GOTO 23018 NLPAR = NLPAR - 1 23018 CONTINUE 23017 CONTINUE 23015 CONTINUE CALL OUTSTR(TOKEN) 23010 IF(.NOT.(NLPAR .LE. 0)) GOTO 23009 23011 CONTINUE IF(.NOT.(NLPAR .NE. 0)) GOTO 23020 CALL SYNERR(33HMISSING PARENTHESIS IN CONDITION.) 23020 CONTINUE RETURN END C C BRKNXT - GENERATE CODE FOR BREAK AND NEXT C SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN) INTEGER I, LABVAL(100), LEXTYP(100), SP, TOKEN CONTINUE I = SP 23022 IF(.NOT.( I .GT. 0)) GOTO 23024 IF(.NOT.(LEXTYP(I) .EQ. 10263 .OR. LEXTYP(I) .EQ. 10266 .OR *. LEXTYP(I) .EQ. 10268 .OR. LEXTYP(I) .EQ. 10269)) GOTO 23025 IF(.NOT.(TOKEN .EQ. 10264)) GOTO 23027 CALL OUTGO(LABVAL(I)+1) GOTO 23028 23027 CONTINUE CALL OUTGO(LABVAL(I)) 23028 CONTINUE RETURN 23025 CONTINUE 23023 I = I - 1 GOTO 23022 23024 CONTINUE IF(.NOT.(TOKEN .EQ. 10264)) GOTO 23029 CALL SYNERR(14HILLEGAL BREAK.) GOTO 23030 23029 CONTINUE CALL SYNERR(13HILLEGAL NEXT.) 23030 CONTINUE RETURN END C C CLOSE - EXCEEDINGLY TEMPORARY VERSION FOR GETTOK C SUBROUTINE CLOSE(FD) INTEGER FD REWIND FD RETURN END C C CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I C INTEGER FUNCTION CTOI(IN, I) INTEGER IN(100) INTEGER INDEX INTEGER D, I INTEGER 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) /10002/ CONTINUE 23031 IF(.NOT.(IN(I) .EQ. 32 .OR. IN(I) .EQ. 9)) GOTO 23032 I = I + 1 GOTO 23031 23032 CONTINUE CONTINUE CTOI = 0 23033 IF(.NOT.( IN(I) .NE. 10002)) GOTO 23035 D = INDEX(DIGITS, IN(I)) IF(.NOT.(D .EQ. 0)) GOTO 23036 GOTO 23035 23036 CONTINUE CTOI = 10 * CTOI + D - 1 23034 I = I + 1 GOTO 23033 23035 CONTINUE RETURN END C C DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS C INTEGER FUNCTION DEFTOK(TOKEN, TOKSIZ, FD) INTEGER GTOK INTEGER FD, TOKSIZ INTEGER DEFN(200), T, TOKEN(TOKSIZ) INTEGER LOOKUP CONTINUE T=GTOK(TOKEN, TOKSIZ, FD) 23038 IF(.NOT.( T.NE.10003)) GOTO 23040 IF(.NOT.(T .NE. 10100)) GOTO 23041 GOTO 23040 23041 CONTINUE IF(.NOT.(LOOKUP(TOKEN, DEFN) .EQ. 0)) GOTO 23043 GOTO 23040 23043 CONTINUE IF(.NOT.(DEFN(1) .EQ. 10010)) GOTO 23045 CALL GETDEF(TOKEN, TOKSIZ, DEFN, 200, FD) CALL INSTAL(TOKEN, DEFN) GOTO 23046 23045 CONTINUE CALL PBSTR(DEFN) 23046 CONTINUE 23039 T=GTOK(TOKEN, TOKSIZ, FD) GOTO 23038 23040 CONTINUE DEFTOK = T IF(.NOT.(DEFTOK .EQ. 10100)) GOTO 23047 CALL FOLD(TOKEN) 23047 CONTINUE RETURN END C C FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE C SUBROUTINE FOLD(TOKEN) INTEGER TOKEN(100) INTEGER I CONTINUE I = 1 23049 IF(.NOT.( TOKEN(I) .NE. 10002)) GOTO 23051 IF(.NOT.(TOKEN(I) .GE. 65 .AND. TOKEN(I) .LE. 90)) GOTO 23052 TOKEN(I) = TOKEN(I) - 65 + 97 23052 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE RETURN END C C DOCODE - GENERATE CODE FOR BEGINNING OF DO C SUBROUTINE DOCODE(LAB) INTEGER LABGEN INTEGER LAB INTEGER DOSTR(4) DATA DOSTR(1), DOSTR(2), DOSTR(3), DOSTR(4)/100, 111, 32, 10002/ CALL OUTTAB CALL OUTSTR(DOSTR) LAB = LABGEN(2) CALL OUTNUM(LAB) CALL EATUP CALL OUTDON RETURN END C C DOSTAT - GENERATE CODE FOR END OF DO STATEMENT C SUBROUTINE DOSTAT(LAB) INTEGER LAB CALL OUTCON(LAB) CALL OUTCON(LAB+1) RETURN END C C EATUP - PROCESS REST OF STATEMENT; INTERPRET CONTINUATIONS C SUBROUTINE EATUP INTEGER GETTOK INTEGER PTOKEN(200), T, TOKEN(200) INTEGER NLPAR NLPAR = 0 CONTINUE 23054 CONTINUE T = GETTOK(TOKEN, 200) IF(.NOT.(T .EQ. 59 .OR. T .EQ. 10)) GOTO 23057 GOTO 23056 23057 CONTINUE IF(.NOT.(T .EQ. 125)) GOTO 23059 CALL PBSTR(TOKEN) GOTO 23056 23059 CONTINUE IF(.NOT.(T .EQ. 123 .OR. T .EQ. 10003)) GOTO 23061 CALL SYNERR(24HUNEXPECTED BRACE OR EOF.) CALL PBSTR(TOKEN) GOTO 23056 23061 CONTINUE IF(.NOT.(T .EQ. 44 .OR. T .EQ. 95)) GOTO 23063 IF(.NOT.(GETTOK(PTOKEN, 200) .NE. 10)) GOTO 23065 CALL PBSTR(PTOKEN) 23065 CONTINUE IF(.NOT.(T .EQ. 95)) GOTO 23067 TOKEN(1) = 10002 23067 CONTINUE GOTO 23064 23063 CONTINUE IF(.NOT.(T .EQ. 40)) GOTO 23069 NLPAR = NLPAR + 1 GOTO 23070 23069 CONTINUE IF(.NOT.(T .EQ. 41)) GOTO 23071 NLPAR = NLPAR - 1 23071 CONTINUE 23070 CONTINUE 23064 CONTINUE CALL OUTSTR(TOKEN) 23055 IF(.NOT.(NLPAR .LT. 0)) GOTO 23054 23056 CONTINUE IF(.NOT.(NLPAR .NE. 0)) GOTO 23073 CALL SYNERR(23HUNBALANCED PARENTHESES.) 23073 CONTINUE RETURN END C C ELSEIF - GENERATE CODE FOR END OF IF BEFORE ELSE C SUBROUTINE ELSEIF(LAB) INTEGER LAB CALL OUTGO(LAB+1) CALL OUTCON(LAB) RETURN END C C EQUAL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, NO IF NOT C INTEGER FUNCTION EQUAL(STR1, STR2) INTEGER STR1(100), STR2(100) INTEGER I CONTINUE I = 1 23075 IF(.NOT.( STR1(I) .EQ. STR2(I))) GOTO 23077 IF(.NOT.(STR1(I) .EQ. 10002)) GOTO 23078 EQUAL = 1 RETURN 23078 CONTINUE 23076 I = I + 1 GOTO 23075 23077 CONTINUE EQUAL = 0 RETURN END C C ERROR - PRINT FATAL ERROR MESSAGE, THEN DIE C SUBROUTINE ERROR(BUF) INTEGER BUF(100) CALL REMARK(BUF) STOP END C C FORCOD - BEGINNING OF FOR STATEMENT C SUBROUTINE FORCOD(LAB) INTEGER GETTOK INTEGER T, TOKEN(200) INTEGER LENGTH, LABGEN INTEGER I, J, LAB, NLPAR COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF INTEGER IFNOT(9) DATA IFNOT(1) /105/ DATA IFNOT(2) /102/ DATA IFNOT(3) /40/ DATA IFNOT(4) /46/ DATA IFNOT(5) /110/ DATA IFNOT(6) /111/ DATA IFNOT(7) /116/ DATA IFNOT(8) /46/ DATA IFNOT(9) /10002/ LAB = LABGEN(3) CALL OUTCON(0) IF(.NOT.(GETTOK(TOKEN, 200) .NE. 40)) GOTO 23080 CALL SYNERR(19HMISSING LEFT PAREN.) RETURN 23080 CONTINUE IF(.NOT.(GETTOK(TOKEN, 200) .NE. 59)) GOTO 23082 CALL PBSTR(TOKEN) CALL OUTTAB CALL EATUP CALL OUTDON 23082 CONTINUE IF(.NOT.(GETTOK(TOKEN, 200) .EQ. 59)) GOTO 23084 CALL OUTCON(LAB) GOTO 23085 23084 CONTINUE CALL PBSTR(TOKEN) CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(IFNOT) CALL OUTCH(40) NLPAR = 0 CONTINUE 23086 IF(.NOT.(NLPAR .GE. 0)) GOTO 23087 T = GETTOK(TOKEN, 200) IF(.NOT.(T .EQ. 59)) GOTO 23088 GOTO 23087 23088 CONTINUE IF(.NOT.(T .EQ. 40)) GOTO 23090 NLPAR = NLPAR + 1 GOTO 23091 23090 CONTINUE IF(.NOT.(T .EQ. 41)) GOTO 23092 NLPAR = NLPAR - 1 23092 CONTINUE 23091 CONTINUE IF(.NOT.(T .NE. 10 .AND. T .NE. 95)) GOTO 23094 CALL OUTSTR(TOKEN) 23094 CONTINUE GOTO 23086 23087 CONTINUE CALL OUTCH(41) CALL OUTCH(41) CALL OUTGO(LAB+2) IF(.NOT.(NLPAR .LT. 0)) GOTO 23096 CALL SYNERR(19HINVALID FOR CLAUSE.) 23096 CONTINUE 23085 CONTINUE FORDEP = FORDEP + 1 J = 1 CONTINUE I = 1 23098 IF(.NOT.( I .LT. FORDEP)) GOTO 23100 J = J + LENGTH(FORSTK(J)) + 1 23099 I = I + 1 GOTO 23098 23100 CONTINUE FORSTK(J) = 10002 NLPAR = 0 CONTINUE 23101 IF(.NOT.(NLPAR .GE. 0)) GOTO 23102 T = GETTOK(TOKEN, 200) IF(.NOT.(T .EQ. 40)) GOTO 23103 NLPAR = NLPAR + 1 GOTO 23104 23103 CONTINUE IF(.NOT.(T .EQ. 41)) GOTO 23105 NLPAR = NLPAR - 1 23105 CONTINUE 23104 CONTINUE IF(.NOT.(NLPAR .GE. 0 .AND. T .NE. 10 .AND. T .NE. 95)) GOTO 231 *07 CALL SCOPY(TOKEN, 1, FORSTK, J) J = J + LENGTH(TOKEN) 23107 CONTINUE GOTO 23101 23102 CONTINUE LAB = LAB + 1 RETURN END C C FORS - PROCESS END OF FOR STATEMENT C SUBROUTINE FORS(LAB) INTEGER LENGTH INTEGER I, J, LAB COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF CALL OUTNUM(LAB) J = 1 CONTINUE I = 1 23109 IF(.NOT.( I .LT. FORDEP)) GOTO 23111 J = J + LENGTH(FORSTK(J)) + 1 23110 I = I + 1 GOTO 23109 23111 CONTINUE IF(.NOT.(LENGTH(FORSTK(J)) .GT. 0)) GOTO 23112 CALL OUTTAB CALL OUTSTR(FORSTK(J)) CALL OUTDON 23112 CONTINUE CALL OUTGO(LAB-1) CALL OUTCON(LAB+1) FORDEP = FORDEP - 1 RETURN END C C GETCH - GET CHARACTERS FROM FILE C INTEGER FUNCTION GETCH(C, F) INTEGER INMAP INTEGER BUF(81), C INTEGER F, I, LASTC DATA LASTC /81/, BUF(81) /10/ IF(.NOT.(BUF(LASTC) .EQ. 10 .OR. LASTC .GE. 81)) GOTO 23114 READ(F, 1, END=10) (BUF(I), I = 1, 80) 1 FORMAT(80 A1) CONTINUE I = 1 23116 IF(.NOT.( I .LE. 80)) GOTO 23118 BUF(I) = INMAP(BUF(I)) 23117 I = I + 1 GOTO 23116 23118 CONTINUE CONTINUE I = 80 23119 IF(.NOT.( I .GT. 0)) GOTO 23121 IF(.NOT.(BUF(I) .NE. 32)) GOTO 23122 GOTO 23121 23122 CONTINUE 23120 I = I - 1 GOTO 23119 23121 CONTINUE BUF(I+1) = 10 LASTC = 0 23114 CONTINUE LASTC = LASTC + 1 C = BUF(LASTC) GETCH = C RETURN 10 C = 10003 GETCH = 10003 RETURN END C C GETDEF (FOR NO ARGUMENTS) - GET NAME AND DEFINITION C SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD) INTEGER GTOK, NGETCH INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ INTEGER C, DEFN(DEFSIZ), TOKEN(TOKSIZ) IF(.NOT.(NGETCH(C, FD) .NE. 40)) GOTO 23124 CALL REMARK(19HMISSING LEFT PAREN.) 23124 CONTINUE IF(.NOT.(GTOK(TOKEN, TOKSIZ, FD) .NE. 10100)) GOTO 23126 CALL REMARK(22HNON-ALPHANUMERIC NAME.) GOTO 23127 23126 CONTINUE IF(.NOT.(NGETCH(C, FD) .NE. 44)) GOTO 23128 CALL REMARK(24HMISSING COMMA IN DEFINE.) 23128 CONTINUE 23127 CONTINUE NLPAR = 0 CONTINUE I = 1 23130 IF(.NOT.( NLPAR .GE. 0)) GOTO 23132 IF(.NOT.(I .GT. DEFSIZ)) GOTO 23133 CALL ERROR(20HDEFINITION TOO LONG.) GOTO 23134 23133 CONTINUE IF(.NOT.(NGETCH(DEFN(I), FD) .EQ. 10003)) GOTO 23135 CALL ERROR(20HMISSING RIGHT PAREN.) GOTO 23136 23135 CONTINUE IF(.NOT.(DEFN(I) .EQ. 40)) GOTO 23137 NLPAR = NLPAR + 1 GOTO 23138 23137 CONTINUE IF(.NOT.(DEFN(I) .EQ. 41)) GOTO 23139 NLPAR = NLPAR - 1 23139 CONTINUE 23138 CONTINUE 23136 CONTINUE 23134 CONTINUE 23131 I = I + 1 GOTO 23130 23132 CONTINUE DEFN(I-1) = 10002 RETURN END C C GETTOK - GET TOKEN. HANDLES FILE INCLUSION AND LINE NUMBERS C INTEGER FUNCTION GETTOK(TOKEN, TOKSIZ) INTEGER EQUAL, OPEN INTEGER JUNK, TOKSIZ INTEGER DEFTOK INTEGER NAME(30), TOKEN(TOKSIZ) COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF INTEGER INCL(8) DATA INCL(1) /105/ DATA INCL(2) /110/ DATA INCL(3) /99/ DATA INCL(4) /108/ DATA INCL(5) /117/ DATA INCL(6) /100/ DATA INCL(7) /101/ DATA INCL(8) /10002/ CONTINUE 23141 IF(.NOT.( LEVEL .GT. 0)) GOTO 23143 CONTINUE GETTOK = DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL)) 23144 IF(.NOT.( GETTOK .NE. 10003)) GOTO 23146 IF(.NOT.(EQUAL(TOKEN, INCL) .EQ. 0)) GOTO 23147 RETURN 23147 CONTINUE JUNK = DEFTOK(NAME, 30, INFILE(LEVEL)) IF(.NOT.(LEVEL .GE. 5)) GOTO 23149 CALL SYNERR(27HINCLUDES NESTED TOO DEEPLY.) GOTO 23150 23149 CONTINUE INFILE(LEVEL+1) = OPEN(NAME, 0) LINECT(LEVEL+1) = 1 IF(.NOT.(INFILE(LEVEL+1) .EQ. 10001)) GOTO 23151 CALL SYNERR(19HCAN'T OPEN INCLUDE.) GOTO 23152 23151 CONTINUE LEVEL = LEVEL + 1 23152 CONTINUE 23150 CONTINUE 23145 GETTOK = DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL)) GOTO 23144 23146 CONTINUE IF(.NOT.(LEVEL .GT. 1)) GOTO 23153 CALL CLOSE(INFILE(LEVEL)) 23153 CONTINUE 23142 LEVEL = LEVEL - 1 GOTO 23141 23143 CONTINUE GETTOK = 10003 RETURN END C C GTOK - GET TOKEN FOR RATFOR C INTEGER FUNCTION GTOK(LEXSTR, TOKSIZ, FD) INTEGER NGETCH, TYPE INTEGER FD, I, TOKSIZ INTEGER C, LEXSTR(TOKSIZ) COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF CONTINUE 23155 IF(.NOT.(NGETCH(C, FD) .NE. 10003)) GOTO 23156 IF(.NOT.(C .NE. 32 .AND. C .NE. 9)) GOTO 23157 GOTO 23156 23157 CONTINUE GOTO 23155 23156 CONTINUE CALL PUTBAK(C) CONTINUE I = 1 23159 IF(.NOT.( I .LT. TOKSIZ-1)) GOTO 23161 GTOK = TYPE(NGETCH(LEXSTR(I), FD)) IF(.NOT.(GTOK .NE. 1 .AND. GTOK .NE. 2)) GOTO 23162 GOTO 23161 23162 CONTINUE 23160 I = I + 1 GOTO 23159 23161 CONTINUE IF(.NOT.(I .GE. TOKSIZ-1)) GOTO 23164 CALL SYNERR(15HTOKEN TOO LONG.) 23164 CONTINUE IF(.NOT.(I .GT. 1)) GOTO 23166 CALL PUTBAK(LEXSTR(I)) LEXSTR(I) = 10002 GTOK = 10100 GOTO 23167 23166 CONTINUE IF(.NOT.(LEXSTR(1) .EQ. 36)) GOTO 23168 IF(.NOT.(NGETCH(LEXSTR(2), FD) .EQ. 40)) GOTO 23170 LEXSTR(1) = 123 GTOK = 123 GOTO 23171 23170 CONTINUE IF(.NOT.(LEXSTR(2) .EQ. 41)) GOTO 23172 LEXSTR(1) = 125 GTOK = 125 GOTO 23173 23172 CONTINUE CALL PUTBAK(LEXSTR(2)) 23173 CONTINUE 23171 CONTINUE GOTO 23169 23168 CONTINUE IF(.NOT.(LEXSTR(1) .EQ. 39 .OR. LEXSTR(1) .EQ. 34)) GOTO 23174 CONTINUE I = 2 23176 IF(.NOT.( NGETCH(LEXSTR(I), FD) .NE. LEXSTR(1))) GOTO 23178 IF(.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ-1)) GOTO 23179 CALL SYNERR(14HMISSING QUOTE.) LEXSTR(I) = LEXSTR(1) CALL PUTBAK(10) GOTO 23178 23179 CONTINUE 23177 I = I + 1 GOTO 23176 23178 CONTINUE GOTO 23175 23174 CONTINUE IF(.NOT.(LEXSTR(1) .EQ. 35)) GOTO 23181 CONTINUE 23183 IF(.NOT.(NGETCH(LEXSTR(1), FD) .NE. 10)) GOTO 23184 GOTO 23183 23184 CONTINUE GTOK = 10 GOTO 23182 23181 CONTINUE IF(.NOT.(LEXSTR(1) .EQ. 62 .OR. LEXSTR(1) .EQ. 60 .OR. LEXSTR(1) *.EQ. 33 .OR. LEXSTR(1) .EQ. 61 .OR. LEXSTR(1) .EQ. 38 .OR. LE *XSTR(1) .EQ. 124)) GOTO 23185 CALL RELATE(LEXSTR, I, FD) 23185 CONTINUE 23182 CONTINUE 23175 CONTINUE 23169 CONTINUE 23167 CONTINUE LEXSTR(I+1) = 10002 IF(.NOT.(LEXSTR(1) .EQ. 10)) GOTO 23187 LINECT(LEVEL) = LINECT(LEVEL) + 1 23187 CONTINUE RETURN END C C IFCODE - GENERATE INITIAL CODE FOR IF C SUBROUTINE IFCODE(LAB) INTEGER LABGEN INTEGER LAB LAB = LABGEN(2) CALL IFGO(LAB) RETURN END C C IFGO - GENERATE "IF(.NOT.(...))GOTO LAB" C SUBROUTINE IFGO(LAB) INTEGER LAB INTEGER IFNOT(9) DATA IFNOT(1) /105/ DATA IFNOT(2) /102/ DATA IFNOT(3) /40/ DATA IFNOT(4) /46/ DATA IFNOT(5) /110/ DATA IFNOT(6) /111/ DATA IFNOT(7) /116/ DATA IFNOT(8) /46/ DATA IFNOT(9) /10002/ CALL OUTTAB CALL OUTSTR(IFNOT) CALL BALPAR CALL OUTCH(41) CALL OUTGO(LAB) RETURN END C C INDEX - FIND CHARACTER C IN STRING STR C INTEGER FUNCTION INDEX(STR, C) INTEGER C, STR(100) CONTINUE INDEX = 1 23189 IF(.NOT.( STR(INDEX) .NE. 10002)) GOTO 23191 IF(.NOT.(STR(INDEX) .EQ. C)) GOTO 23192 RETURN 23192 CONTINUE 23190 INDEX = INDEX + 1 GOTO 23189 23191 CONTINUE INDEX = 0 RETURN END C C INITKW - INSTALL KEYWORD "DEFINE" IN TABLE C SUBROUTINE INITKW INTEGER DEFNAM(7), DEFTYP(2) DATA DEFNAM(1) /100/, DEFNAM(2) /101/, DEFNAM(3) /102/ DATA DEFNAM(4) /105/, DEFNAM(5) /110/, DEFNAM(6) /101/ DATA DEFNAM(7) /10002/ DATA DEFTYP(1), DEFTYP(2) /10010, 10002/ CALL INSTAL(DEFNAM, DEFTYP) RETURN END C C INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII C INTEGER FUNCTION INMAP(INCHAR) INTEGER I, INCHAR COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF IF(.NOT.(INCHAR .EQ. EXTBLK)) GOTO 23194 INMAP = INTBLK RETURN 23194 CONTINUE DO23196I = 1, 10 IF(.NOT.(INCHAR .EQ. EXTDIG(I))) GOTO 23198 INMAP = INTDIG(I) RETURN 23198 CONTINUE 23196 CONTINUE 23197 CONTINUE DO23200I = 1, 26 IF(.NOT.(INCHAR .EQ. EXTLET(I))) GOTO 23202 INMAP = INTLET(I) RETURN 23202 CONTINUE 23200 CONTINUE 23201 CONTINUE DO23204I = 1, 26 IF(.NOT.(INCHAR .EQ. EXTBIG(I))) GOTO 23206 INMAP = INTBIG(I) RETURN 23206 CONTINUE 23204 CONTINUE 23205 CONTINUE DO23208I = 1, 33 IF(.NOT.(INCHAR .EQ. EXTCHR(I))) GOTO 23210 INMAP = INTCHR(I) RETURN 23210 CONTINUE 23208 CONTINUE 23209 CONTINUE INMAP = INCHAR RETURN END C C INSTAL - ADD NAME AND DEFINITION TO TABLE C SUBROUTINE INSTAL(NAME, DEFN) INTEGER DEFN(200), NAME(200) INTEGER LENGTH INTEGER DLEN, NLEN COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF(.NOT.(LASTT + NLEN + DLEN .GT. 1500 .OR. LASTP .GE. 200)) GO *TO 23212 CALL PUTLIN(NAME, 6) CALL REMARK(23H: TOO MANY DEFINITIONS.) 23212 CONTINUE LASTP = LASTP + 1 NAMPTR(LASTP) = LASTT + 1 CALL SCOPY(NAME, 1, TABLE, LASTT + 1) CALL SCOPY(DEFN, 1, TABLE, LASTT + NLEN + 1) LASTT = LASTT + NLEN + DLEN RETURN END C C ITOC - CONVERT INTEGER INT TO CHAR STRING IN STR C INTEGER FUNCTION ITOC(INT, STR, SIZE) INTEGER IABS, MOD INTEGER D, I, INT, INTVAL, J, K, SIZE INTEGER STR(SIZE) INTEGER 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) /10002/ INTVAL = IABS(INT) STR(1) = 10002 I = 1 CONTINUE 23214 CONTINUE I = I + 1 D = MOD(INTVAL, 10) STR(I) = DIGITS(D+1) INTVAL = INTVAL / 10 23215 IF(.NOT.(INTVAL .EQ. 0 .OR. I .GE. SIZE)) GOTO 23214 23216 CONTINUE IF(.NOT.(INT .LT. 0 .AND. I .LT. SIZE)) GOTO 23217 I = I + 1 STR(I) = 45 23217 CONTINUE ITOC = I - 1 CONTINUE J = 1 23219 IF(.NOT.( J .LT. I)) GOTO 23221 K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 23220 J = J + 1 GOTO 23219 23221 CONTINUE RETURN END C C LABELC - OUTPUT STATEMENT NUMBER C SUBROUTINE LABELC(LEXSTR) INTEGER LEXSTR(100) INTEGER LENGTH IF(.NOT.(LENGTH(LEXSTR) .EQ. 5)) GOTO 23222 IF(.NOT.(LEXSTR(1) .EQ. 50 .AND. LEXSTR(2) .EQ. 51)) GOTO 23224 CALL SYNERR(33HWARNING: POSSIBLE LABEL CONFLICT.) 23224 CONTINUE 23222 CONTINUE CALL OUTSTR(LEXSTR) CALL OUTTAB RETURN END C C LABGEN - GENERATE N CONSECUTIVE LABELS, RETURN FIRST ONE C INTEGER FUNCTION LABGEN(N) INTEGER LABEL, N DATA LABEL /23000/ LABGEN = LABEL LABEL = LABEL + N RETURN END C C LENGTH - COMPUTE LENGTH OF STRING C INTEGER FUNCTION LENGTH(STR) INTEGER STR(100) CONTINUE LENGTH = 0 23226 IF(.NOT.( STR(LENGTH+1) .NE. 10002)) GOTO 23228 23227 LENGTH = LENGTH + 1 GOTO 23226 23228 CONTINUE RETURN END C C LEX - RETURN LEXICAL TYPE OF TOKEN C INTEGER FUNCTION LEX(LEXSTR) INTEGER GETTOK INTEGER LEXSTR(200) INTEGER ALLDIG, EQUAL COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF CONTINUE 23229 IF(.NOT.(GETTOK(LEXSTR, 200) .EQ. 10)) GOTO 23230 GOTO 23229 23230 CONTINUE LEX = LEXSTR(1) IF(.NOT.(LEX.EQ.10003 .OR. LEX.EQ.59 .OR. LEX.EQ.123 .OR. LEX.EQ. *125)) GOTO 23231 RETURN 23231 CONTINUE IF(.NOT.(ALLDIG(LEXSTR) .EQ. 1)) GOTO 23233 LEX = 10260 GOTO 23234 23233 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SIF) .EQ. 1)) GOTO 23235 LEX = VIF(1) GOTO 23236 23235 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SELSE) .EQ. 1)) GOTO 23237 LEX = VELSE(1) GOTO 23238 23237 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SWHILE) .EQ. 1)) GOTO 23239 LEX = VWHILE(1) GOTO 23240 23239 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SDO) .EQ. 1)) GOTO 23241 LEX = VDO(1) GOTO 23242 23241 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SBREAK) .EQ. 1)) GOTO 23243 LEX = VBREAK(1) GOTO 23244 23243 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SNEXT) .EQ. 1)) GOTO 23245 LEX = VNEXT(1) GOTO 23246 23245 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SFOR) .EQ. 1)) GOTO 23247 LEX = VFOR(1) GOTO 23248 23247 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SREPT) .EQ. 1)) GOTO 23249 LEX = VREPT(1) GOTO 23250 23249 CONTINUE IF(.NOT.(EQUAL(LEXSTR, SUNTIL) .EQ. 1)) GOTO 23251 LEX = VUNTIL(1) GOTO 23252 23251 CONTINUE LEX = 10267 23252 CONTINUE 23250 CONTINUE 23248 CONTINUE 23246 CONTINUE 23244 CONTINUE 23242 CONTINUE 23240 CONTINUE 23238 CONTINUE 23236 CONTINUE 23234 CONTINUE RETURN END C C LOOKUP - LOCATE NAME, EXTRACT DEFINITION FROM TABLE C INTEGER FUNCTION LOOKUP(NAME, DEFN) INTEGER DEFN(200), NAME(200) INTEGER I, J, K COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF CONTINUE I = LASTP 23253 IF(.NOT.( I .GT. 0)) GOTO 23255 J = NAMPTR(I) CONTINUE K = 1 23256 IF(.NOT.( NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 10002)) GOTO *23258 J = J + 1 23257 K = K + 1 GOTO 23256 23258 CONTINUE IF(.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 23259 CALL SCOPY(TABLE, J+1, DEFN, 1) LOOKUP = 1 RETURN 23259 CONTINUE 23254 I = I - 1 GOTO 23253 23255 CONTINUE LOOKUP = 0 RETURN END C C NGETCH - GET A (POSSIBLY PUSHED BACK) CHARACTER C INTEGER FUNCTION NGETCH(C, FD) INTEGER GETCH INTEGER C INTEGER FD COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF IF(.NOT.(BP .GT. 0)) GOTO 23261 C = BUF(BP) GOTO 23262 23261 CONTINUE BP = 1 BUF(BP) = GETCH(C, FD) 23262 CONTINUE BP = BP - 1 NGETCH = C RETURN END C C OPEN - EXCEEDINGLY TEMPORARY VERSION FOR GETTOK C INTEGER FUNCTION OPEN(NAME, MODE) INTEGER NAME(30) INTEGER CTOI INTEGER I, MODE I = 1 OPEN = CTOI(NAME, I) RETURN END C C OTHERC - OUTPUT ORDINARY FORTRAN STATEMENT C SUBROUTINE OTHERC(LEXSTR) INTEGER LEXSTR(100) CALL OUTTAB CALL OUTSTR(LEXSTR) CALL EATUP CALL OUTDON RETURN END C C OUTCH - PUT ONE CHARACTER INTO OUTPUT BUFFER C SUBROUTINE OUTCH(C) INTEGER C INTEGER I COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF IF(.NOT.(OUTP .GE. 72)) GOTO 23263 CALL OUTDON CONTINUE I = 1 23265 IF(.NOT.( I .LT. 6)) GOTO 23267 OUTBUF(I) = 32 23266 I = I + 1 GOTO 23265 23267 CONTINUE OUTBUF(6) = 42 OUTP = 6 23263 CONTINUE OUTP = OUTP + 1 OUTBUF(OUTP) = C RETURN END C C OUTCON - OUTPUT "N CONTINUE" C SUBROUTINE OUTCON(N) INTEGER N INTEGER CONTIN(9) DATA CONTIN(1) /99/ DATA CONTIN(2) /111/ DATA CONTIN(3) /110/ DATA CONTIN(4) /116/ DATA CONTIN(5) /105/ DATA CONTIN(6) /110/ DATA CONTIN(7) /117/ DATA CONTIN(8) /101/ DATA CONTIN(9) /10002/ IF(.NOT.(N .GT. 0)) GOTO 23268 CALL OUTNUM(N) 23268 CONTINUE CALL OUTTAB CALL OUTSTR(CONTIN) CALL OUTDON RETURN END C C OUTDON - FINISH OFF AN OUTPUT LINE C SUBROUTINE OUTDON COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF OUTBUF(OUTP+1) = 10 OUTBUF(OUTP+2) = 10002 CALL PUTLIN(OUTBUF, 6) OUTP = 0 RETURN END C C OUTGO - OUTPUT "GOTO N" C SUBROUTINE OUTGO(N) INTEGER N INTEGER GOTO(6) DATA GOTO(1) /103/ DATA GOTO(2) /111/ DATA GOTO(3) /116/ DATA GOTO(4) /111/ DATA GOTO(5) /32/ DATA GOTO(6) /10002/ CALL OUTTAB CALL OUTSTR(GOTO) CALL OUTNUM(N) CALL OUTDON RETURN END C C OUTMAP - CONVERT RIGHT ADJ ASCII TO LEFT ADJUSTED EXTERNAL REP C INTEGER FUNCTION OUTMAP(INCHAR) INTEGER I, INCHAR COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF IF(.NOT.(INCHAR .EQ. INTBLK)) GOTO 23270 OUTMAP = EXTBLK RETURN 23270 CONTINUE DO23272I = 1, 10 IF(.NOT.(INCHAR .EQ. INTDIG(I))) GOTO 23274 OUTMAP = EXTDIG(I) RETURN 23274 CONTINUE 23272 CONTINUE 23273 CONTINUE DO23276I = 1, 26 IF(.NOT.(INCHAR .EQ. INTLET(I))) GOTO 23278 OUTMAP = EXTLET(I) RETURN 23278 CONTINUE 23276 CONTINUE 23277 CONTINUE DO23280I = 1, 26 IF(.NOT.(INCHAR .EQ. INTBIG(I))) GOTO 23282 OUTMAP = EXTBIG(I) RETURN 23282 CONTINUE 23280 CONTINUE 23281 CONTINUE DO23284I = 1, 33 IF(.NOT.(INCHAR .EQ. INTCHR(I))) GOTO 23286 OUTMAP = EXTCHR(I) RETURN 23286 CONTINUE 23284 CONTINUE 23285 CONTINUE OUTMAP = INCHAR RETURN END C C OUTNUM - OUTPUT DECIMAL NUMBER C SUBROUTINE OUTNUM(N) INTEGER CHARS(10) INTEGER ITOC INTEGER I, LEN, N LEN = ITOC(N, CHARS, 10) CONTINUE I = 1 23288 IF(.NOT.( I .LE. LEN)) GOTO 23290 CALL OUTCH(CHARS(I)) 23289 I = I + 1 GOTO 23288 23290 CONTINUE RETURN END C C OUTSTR - OUTPUT STRING C SUBROUTINE OUTSTR(STR) INTEGER C, STR(100) INTEGER I, J CONTINUE I = 1 23291 IF(.NOT.( STR(I) .NE. 10002)) GOTO 23293 C = STR(I) IF(.NOT.(C .NE. 39 .AND. C .NE. 34)) GOTO 23294 CALL OUTCH(C) GOTO 23295 23294 CONTINUE I = I + 1 CONTINUE J = I 23296 IF(.NOT.( STR(J) .NE. C)) GOTO 23298 23297 J = J + 1 GOTO 23296 23298 CONTINUE CALL OUTNUM(J-I) CALL OUTCH(104) CONTINUE 23299 IF(.NOT.( I .LT. J)) GOTO 23301 CALL OUTCH(STR(I)) 23300 I = I + 1 GOTO 23299 23301 CONTINUE 23295 CONTINUE 23292 I = I + 1 GOTO 23291 23293 CONTINUE RETURN END C C OUTTAB - GET PAST COLUMN 6 C SUBROUTINE OUTTAB COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF CONTINUE 23302 IF(.NOT.(OUTP .LT. 6)) GOTO 23303 CALL OUTCH(32) GOTO 23302 23303 CONTINUE RETURN END C C PARSE - PARSE RATFOR SOURCE PROGRAM C SUBROUTINE PARSE INTEGER LEXSTR(200) INTEGER LEX INTEGER LAB, LABVAL(100), LEXTYP(100), SP, TOKEN CALL INITKW SP = 1 LEXTYP(1) = 10003 CONTINUE TOKEN = LEX(LEXSTR) 23304 IF(.NOT.( TOKEN .NE. 10003)) GOTO 23306 IF(.NOT.(TOKEN .EQ. 10261)) GOTO 23307 CALL IFCODE(LAB) GOTO 23308 23307 CONTINUE IF(.NOT.(TOKEN .EQ. 10266)) GOTO 23309 CALL DOCODE(LAB) GOTO 23310 23309 CONTINUE IF(.NOT.(TOKEN .EQ. 10263)) GOTO 23311 CALL WHILEC(LAB) GOTO 23312 23311 CONTINUE IF(.NOT.(TOKEN .EQ. 10268)) GOTO 23313 CALL FORCOD(LAB) GOTO 23314 23313 CONTINUE IF(.NOT.(TOKEN .EQ. 10269)) GOTO 23315 CALL REPCOD(LAB) GOTO 23316 23315 CONTINUE IF(.NOT.(TOKEN .EQ. 10260)) GOTO 23317 CALL LABELC(LEXSTR) GOTO 23318 23317 CONTINUE IF(.NOT.(TOKEN .EQ. 10262)) GOTO 23319 IF(.NOT.(LEXTYP(SP) .EQ. 10261)) GOTO 23321 CALL ELSEIF(LABVAL(SP)) GOTO 23322 23321 CONTINUE CALL SYNERR(13HILLEGAL ELSE.) 23322 CONTINUE 23319 CONTINUE 23318 CONTINUE 23316 CONTINUE 23314 CONTINUE 23312 CONTINUE 23310 CONTINUE 23308 CONTINUE IF(.NOT.(TOKEN.EQ.10261 .OR. TOKEN.EQ.10262 .OR. TOKEN.EQ.10263 * .OR. TOKEN.EQ.10268 .OR. TOKEN.EQ.10269 .OR. TOKEN.E *Q.10266 .OR. TOKEN.EQ.10260 .OR. TOKEN.EQ.123)) GOTO 23323 SP = SP + 1 IF(.NOT.(SP .GT. 100)) GOTO 23325 CALL ERROR(25HSTACK OVERFLOW IN PARSER.) 23325 CONTINUE LEXTYP(SP) = TOKEN LABVAL(SP) = LAB GOTO 23324 23323 CONTINUE IF(.NOT.(TOKEN .EQ. 125)) GOTO 23327 IF(.NOT.(LEXTYP(SP) .EQ. 123)) GOTO 23329 SP = SP - 1 GOTO 23330 23329 CONTINUE CALL SYNERR(20HILLEGAL RIGHT BRACE.) 23330 CONTINUE GOTO 23328 23327 CONTINUE IF(.NOT.(TOKEN .EQ. 10267)) GOTO 23331 CALL OTHERC(LEXSTR) GOTO 23332 23331 CONTINUE IF(.NOT.(TOKEN .EQ. 10264 .OR. TOKEN .EQ. 10265)) GOTO 23333 CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN) 23333 CONTINUE 23332 CONTINUE 23328 CONTINUE TOKEN = LEX(LEXSTR) CALL PBSTR(LEXSTR) CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN) 23324 CONTINUE 23305 TOKEN = LEX(LEXSTR) GOTO 23304 23306 CONTINUE IF(.NOT.(SP .NE. 1)) GOTO 23335 CALL SYNERR(15HUNEXPECTED EOF.) 23335 CONTINUE RETURN END C C PBSTR - PUSH STRING BACK ONTO INPUT C SUBROUTINE PBSTR(IN) INTEGER IN(100) INTEGER LENGTH INTEGER I CONTINUE I = LENGTH(IN) 23337 IF(.NOT.( I .GT. 0)) GOTO 23339 CALL PUTBAK(IN(I)) 23338 I = I - 1 GOTO 23337 23339 CONTINUE RETURN END C C PUTBAK - PUSH CHARACTER BACK ONTO INPUT C SUBROUTINE PUTBAK(C) INTEGER C COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF BP = BP + 1 IF(.NOT.(BP .GT. 300)) GOTO 23340 CALL ERROR(32HTOO MANY CHARACTERS PUSHED BACK.) 23340 CONTINUE BUF(BP) = C RETURN END C C PUTCH (INTERIM VERSION) PUT CHARACTERS C SUBROUTINE PUTCH(C, F) INTEGER BUF(81), C INTEGER OUTMAP INTEGER F, I, LASTC DATA LASTC /0/ IF(.NOT.(LASTC .GE. 81 .OR. C .EQ. 10)) GOTO 23342 IF(.NOT.( LASTC .LE. 0 )) GOTO 23344 WRITE(F,2) 2 FORMAT(/) GOTO 23345 23344 CONTINUE WRITE(F, 1) (BUF(I), I = 1, LASTC) 1 FORMAT(80 A1) 23345 CONTINUE LASTC = 0 23342 CONTINUE IF(.NOT.(C .NE. 10)) GOTO 23346 LASTC = LASTC + 1 BUF(LASTC) = OUTMAP(C) 23346 CONTINUE RETURN END C C PUTLIN - PUT OUT LINE BY REPEATED CALLS TO PUTCH C SUBROUTINE PUTLIN(B, F) INTEGER B(100) INTEGER F, I CONTINUE I = 1 23348 IF(.NOT.( B(I) .NE. 10002)) GOTO 23350 CALL PUTCH(B(I), F) 23349 I = I + 1 GOTO 23348 23350 CONTINUE RETURN END C C RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM C SUBROUTINE RELATE(TOKEN, LAST, FD) INTEGER NGETCH INTEGER TOKEN(100) INTEGER LENGTH INTEGER FD, LAST INTEGER DOTGE(5), DOTGT(5), DOTLT(5), DOTLE(5) INTEGER DOTNE(5), DOTNOT(6), DOTEQ(5), DOTAND(6), DOTOR(5) DATA DOTGE(1), DOTGE(2), DOTGE(3), DOTGE(4), DOTGE(5)/ 46, 103, 1 *01, 46, 10002/ DATA DOTGT(1), DOTGT(2), DOTGT(3), DOTGT(4), DOTGT(5)/ 46, 103, 1 *16, 46, 10002/ DATA DOTLE(1), DOTLE(2), DOTLE(3), DOTLE(4), DOTLE(5)/ 46, 108, 1 *01, 46, 10002/ DATA DOTLT(1), DOTLT(2), DOTLT(3), DOTLT(4), DOTLT(5)/ 46, 108, 1 *16, 46, 10002/ DATA DOTNE(1), DOTNE(2), DOTNE(3), DOTNE(4), DOTNE(5)/ 46, 110, 1 *01, 46, 10002/ DATA DOTEQ(1), DOTEQ(2), DOTEQ(3), DOTEQ(4), DOTEQ(5)/ 46, 101, 1 *13, 46, 10002/ DATA DOTOR(1), DOTOR(2), DOTOR(3), DOTOR(4), DOTOR(5)/ 46, 111, 1 *14, 46, 10002/ DATA DOTAND(1), DOTAND(2), DOTAND(3), DOTAND(4), DOTAND(5), DOTAN *D(6) /46, 97, 110, 100, 46, 10002/ DATA DOTNOT(1), DOTNOT(2), DOTNOT(3), DOTNOT(4), DOTNOT(5), DOTNO *T(6) /46, 110, 111, 116, 46, 10002/ IF(.NOT.(NGETCH(TOKEN(2), FD) .NE. 61)) GOTO 23351 CALL PUTBAK(TOKEN(2)) 23351 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 62)) GOTO 23353 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23355 CALL SCOPY(DOTGE, 1, TOKEN, 1) GOTO 23356 23355 CONTINUE CALL SCOPY(DOTGT, 1, TOKEN, 1) 23356 CONTINUE GOTO 23354 23353 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 60)) GOTO 23357 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23359 CALL SCOPY(DOTLE, 1, TOKEN, 1) GOTO 23360 23359 CONTINUE CALL SCOPY(DOTLT, 1, TOKEN, 1) 23360 CONTINUE GOTO 23358 23357 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 33)) GOTO 23361 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23363 CALL SCOPY(DOTNE, 1, TOKEN, 1) GOTO 23364 23363 CONTINUE CALL SCOPY(DOTNOT, 1, TOKEN, 1) 23364 CONTINUE GOTO 23362 23361 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 61)) GOTO 23365 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23367 CALL SCOPY(DOTEQ, 1, TOKEN, 1) GOTO 23368 23367 CONTINUE TOKEN(2) = 10002 23368 CONTINUE GOTO 23366 23365 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 38)) GOTO 23369 CALL SCOPY(DOTAND, 1, TOKEN, 1) GOTO 23370 23369 CONTINUE IF(.NOT.(TOKEN(1) .EQ. 124)) GOTO 23371 CALL SCOPY(DOTOR, 1, TOKEN, 1) GOTO 23372 23371 CONTINUE TOKEN(2) = 10002 23372 CONTINUE 23370 CONTINUE 23366 CONTINUE 23362 CONTINUE 23358 CONTINUE 23354 CONTINUE LAST = LENGTH(TOKEN) RETURN END C C REMARK - PRINT WARNING MESSAGE C SUBROUTINE REMARK(BUF) INTEGER BUF(100), I WRITE(6, 10) (BUF(I), I = 1, 5) 10 FORMAT(5A4) RETURN END C C REPCOD - GENERATE CODE FOR BEGINNING OF REPEAT C SUBROUTINE REPCOD(LAB) INTEGER LABGEN INTEGER LAB CALL OUTCON(0) LAB = LABGEN(3) CALL OUTCON(LAB) LAB = LAB + 1 RETURN END C C SCOPY - COPY STRING AT FROM(I) TO TO(J) C SUBROUTINE SCOPY(FROM, I, TO, J) INTEGER FROM(100), TO(100) INTEGER I, J, K1, K2 K2 = J CONTINUE K1 = I 23373 IF(.NOT.( FROM(K1) .NE. 10002)) GOTO 23375 TO(K2) = FROM(K1) K2 = K2 + 1 23374 K1 = K1 + 1 GOTO 23373 23375 CONTINUE TO(K2) = 10002 RETURN END C C SYNERR - REPORT RATFOR SYNTAX ERROR C SUBROUTINE SYNERR(MSG) INTEGER LC(81), MSG(81) INTEGER ITOC INTEGER I, JUNK COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON /CDEFIO/ BP, BUF(300) INTEGER BP INTEGER BUF COMMON /CFOR/ FORDEP, FORSTK(200) INTEGER FORDEP INTEGER FORSTK COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V *UNTIL INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) INTEGER SFOR(4), SREPT(7), SUNTIL(6) INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) INTEGER VFOR(2), VREPT(2), VUNTIL(2) COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) INTEGER LEVEL INTEGER LINECT INTEGER INFILE COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) INTEGER LASTP INTEGER LASTT INTEGER NAMPTR INTEGER TABLE COMMON /COUTLN/ OUTP, OUTBUF(81) INTEGER OUTP INTEGER OUTBUF CALL REMARK(14HERROR AT LINE.) CONTINUE I = 1 23376 IF(.NOT.( I .LE. LEVEL)) GOTO 23378 CALL PUTCH(32, 6) JUNK = ITOC(LINECT(I), LC, 81) CALL PUTLIN(LC, 6) 23377 I = I + 1 GOTO 23376 23378 CONTINUE CALL PUTCH(58, 6) CALL PUTCH(10, 6) CALL REMARK(MSG) RETURN END C C TYPE - RETURN LETTER, DIGIT OR CHARACTER C INTEGER FUNCTION TYPE(C) INTEGER C IF(.NOT.( C .GE. 48 .AND. C .LE. 57 )) GOTO 23379 TYPE = 2 GOTO 23380 23379 CONTINUE IF(.NOT.( C .GE. 97 .AND. C .LE. 122 )) GOTO 23381 TYPE = 1 GOTO 23382 23381 CONTINUE IF(.NOT.( C .GE. 65 .AND. C .LE. 90 )) GOTO 23383 TYPE = 1 GOTO 23384 23383 CONTINUE TYPE = C 23384 CONTINUE 23382 CONTINUE 23380 CONTINUE RETURN END C C UNSTAK - UNSTACK AT END OF STATEMENT C SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN CONTINUE 23385 IF(.NOT.( SP .GT. 1)) GOTO 23387 IF(.NOT.(LEXTYP(SP) .EQ. 123)) GOTO 23388 GOTO 23387 23388 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10261 .AND. TOKEN .EQ. 10262)) GOTO 233 *90 GOTO 23387 23390 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10261)) GOTO 23392 CALL OUTCON(LABVAL(SP)) GOTO 23393 23392 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10262)) GOTO 23394 IF(.NOT.(SP .GT. 2)) GOTO 23396 SP = SP - 1 23396 CONTINUE CALL OUTCON(LABVAL(SP)+1) GOTO 23395 23394 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10266)) GOTO 23398 CALL DOSTAT(LABVAL(SP)) GOTO 23399 23398 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10263)) GOTO 23400 CALL WHILES(LABVAL(SP)) GOTO 23401 23400 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10268)) GOTO 23402 CALL FORS(LABVAL(SP)) GOTO 23403 23402 CONTINUE IF(.NOT.(LEXTYP(SP) .EQ. 10269)) GOTO 23404 CALL UNTILS(LABVAL(SP), TOKEN) 23404 CONTINUE 23403 CONTINUE 23401 CONTINUE 23399 CONTINUE 23395 CONTINUE 23393 CONTINUE 23386 SP = SP - 1 GOTO 23385 23387 CONTINUE RETURN END C C UNTILS - GENERATE CODE FOR UNTIL OR END OF REPEAT C SUBROUTINE UNTILS(LAB, TOKEN) INTEGER PTOKEN(200) INTEGER LEX INTEGER JUNK, LAB, TOKEN CALL OUTNUM(LAB) IF(.NOT.(TOKEN .EQ. 10270)) GOTO 23406 JUNK = LEX(PTOKEN) CALL IFGO(LAB-1) GOTO 23407 23406 CONTINUE CALL OUTGO(LAB-1) 23407 CONTINUE CALL OUTCON(LAB+1) RETURN END C C WHILEC - GENERATE CODE FOR BEGINNING OF WHILE C SUBROUTINE WHILEC(LAB) INTEGER LABGEN INTEGER LAB CALL OUTCON(0) LAB = LABGEN(2) CALL OUTNUM(LAB) CALL IFGO(LAB+1) RETURN END C C WHILES - GENERATE CODE FOR END OF WHILE C SUBROUTINE WHILES(LAB) INTEGER LAB CALL OUTGO(LAB) CALL OUTCON(LAB+1) RETURN END ========== Ratfor definitions ========== # Because some compilers will not compile logical expressions # of the form (i .ne. -1), we have used positive values for # some symbolic constants where negative values would be # a better choice. (EOS, EOF, and so on are examples.) # These positive values are all greater than 10000. define(ALPHA,10100) define(AMPER,38) # ampersand define(ARB,100) define(ATSIGN,64) define(BACKSLASH,92) define(BACKSPACE,8) define(BANG,33) # exclamation mark define(BAR,124) define(BIGA,65) define(BIGB,66) define(BIGC,67) define(BIGD,68) define(BIGE,69) define(BIGF,70) define(BIGG,71) define(BIGH,72) define(BIGI,73) define(BIGJ,74) define(BIGK,75) define(BIGL,76) define(BIGM,77) define(BIGN,78) define(BIGO,79) define(BIGP,80) define(BIGQ,81) define(BIGR,82) define(BIGS,83) define(BIGT,84) define(BIGU,85) define(BIGV,86) define(BIGW,87) define(BIGX,88) define(BIGY,89) define(BIGZ,90) define(BLANK,32) define(BUFSIZE,300) # pushback buffer for ngetch and putbak define(COLON,58) define(COMMA,44) define(DEFTYPE,10010) define(DIG0,48) define(DIG1,49) define(DIG2,50) define(DIG3,51) define(DIG4,52) define(DIG5,53) define(DIG6,54) define(DIG7,55) define(DIG8,56) define(DIG9,57) define(DIGIT,2) define(DOLLAR,36) define(DQUOTE,34) define(EOF,10003) define(EOS,10002) define(EQUALS,61) define(ERR,10001) define(ERROUT,6) # temporarily same as standard output define(GREATER,62) define(LBRACE,123) define(LBRACK,91) define(LESS,60) define(LETA,97) define(LETB,98) define(LETC,99) define(LETD,100) define(LETE,101) define(LETF,102) define(LETG,103) define(LETH,104) define(LETI,105) define(LETJ,106) define(LETK,107) define(LETL,108) define(LETM,109) define(LETN,110) define(LETO,111) define(LETP,112) define(LETQ,113) define(LETR,114) define(LETS,115) define(LETT,116) define(LETTER,1) define(LETU,117) define(LETV,118) define(LETW,119) define(LETX,120) define(LETY,121) define(LETZ,122) define(LEXBREAK,10264) define(LEXDIGITS,10260) define(LEXDO,10266) define(LEXELSE,10262) define(LEXFOR,10268) define(LEXIF,10261) define(LEXNEXT,10265) define(LEXOTHER,10267) define(LEXREPEAT,10269) define(LEXUNTIL,10270) define(LEXWHILE,10263) define(LPAREN,40) define(MAXCARD,80) # card size define(MAXCHARS,10) # characters for outnum define(MAXDEF,200) # max chars in a defn define(MAXFORSTK,200) # max space for for reinit clauses define(MAXLINE,81) # must be 1 more than MAXCARD define(MAXNAME,30) # file name size in gettok define(MAXPTR,200) # number of defines in lookup define(MAXSTACK,100) # max stack depth for parser define(MAXTBL,1500) # max chars in all definitions define(MAXTOK,200) # max chars in a token define(MINUS,45) define(NCHARS,33) # number of special characters define(NEWLINE,10) define(NFILES,5) # max depth of file inclusion define(NO,0) define(NOT,BANG) # exclamation mark for now; change for ebcdic define(PERCENT,37) define(PERIOD,46) define(PLUS,43) define(QMARK,63) define(RBRACE,125) define(RBRACK,93) define(READONLY,0) define(RPAREN,41) define(SEMICOL,59) define(SHARP,35) define(SLASH,47) define(SQUOTE,39) define(STAR,42) define(STDIN,5) define(STDOUT,6) define(TAB,9) define(UNDERLINE,95) define(YES,1) define(character,integer) define(abs,iabs) ========== commonblocks ========== # common blocks. # these have been lumped into one place to minimize # the operational problems of picking up several small # files in an environment that doesn't support files # by name. The individual routines still name as comments the # actual common blocks they need, but actually include # everything in this batch, with a statement: # include commonblocks common /cchar/ extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(NCHARS), intchr(NCHARS), extblk, intblk integer extdig # external representation of digits integer intdig # internal rep (ascii) integer extlet # external rep of letters (normal case) integer intlet # internal rep (ascii lower case) integer extbig # external rep of upper case, if used integer intbig # internal rep (upper case ascii) integer extchr # external rep of special chars integer intchr # internal rep (ascii) integer extblk # external blank integer intblk # internal blank (ascii) common /cdefio/ bp, buf(BUFSIZE) integer bp # next available character; init = 0 character buf # pushed-back characters common /cfor/ fordep, forstk(MAXFORSTK) integer fordep # current depth of for statements character forstk # stack of reinit strings common /ckeywd/ sdo, sif, selse, swhile, sbreak, snext, sfor, srept, suntil, vdo, vif, velse, vwhile, vbreak, vnext, vfor, vrept, vuntil integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5) integer sfor(4), srept(7), suntil(6) integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2) integer vfor(2), vrept(2), vuntil(2) common /cline/ level, linect(NFILES), infile(NFILES) integer level # level of file inclusion; init = 1 integer linect # line count on input file(level); init = 1 integer infile # file number(level); init infile(1) = STDIN common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL) integer lastp # last used in namptr; init = 0 integer lastt # last used in table; init = 0 integer namptr # name pointers character table # actual text of names and defns common /coutln/ outp, outbuf(MAXLINE) integer outp # last position filled in outbuf; init = 0 character outbuf # output lines collected here ========== Ratfor in ratfor ========== # block data - initialize global variables block data include commonblocks # include coutln # include cline # include cdefio # include cfor # include clook # include ckeywd # include cchar # output character pointer: data outp /0/ # file control: data level /1/ data linect(1) /1/ data infile(1) /STDIN/ # pushback buffer pointer: data bp /0/ # depth of for stack: data fordep /0/ # pointers for table lookup code: data lastp /0/ data lastt /0/ # keywords: data sdo(1), sdo(2), sdo(3) /LETD, LETO, EOS/ data vdo(1), vdo(2) /LEXDO, EOS/ data sif(1), sif(2), sif(3) /LETI, LETF, EOS/ data vif(1), vif(2) /LEXIF, EOS/ data selse(1), selse(2), selse(3), selse(4), selse(5) /LETE, LETL, LETS, LETE, EOS/ data velse(1), velse(2) /LEXELSE, EOS/ data swhile(1), swhile(2), swhile(3), swhile(4), swhile(5), swhile(6) /LETW, LETH, LETI, LETL, LETE, EOS/ data vwhile(1), vwhile(2) /LEXWHILE, EOS/ data sbreak(1), sbreak(2), sbreak(3), sbreak(4), sbreak(5), sbreak(6) /LETB, LETR, LETE, LETA, LETK, EOS/ data vbreak(1), vbreak(2) /LEXBREAK, EOS/ data snext(1), snext(2), snext(3), snext(4), snext(5) /LETN, LETE, LETX, LETT, EOS/ data vnext(1), vnext(2) /LEXNEXT, EOS/ data sfor(1), sfor(2), sfor(3), sfor(4) /LETF, LETO, LETR, EOS/ data vfor(1), vfor(2) /LEXFOR, EOS/ data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6), srept(7) /LETR, LETE, LETP, LETE, LETA, LETT, EOS/ data vrept(1), vrept(2) /LEXREPEAT, EOS/ data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5), suntil(6) /LETU, LETN, LETT, LETI, LETL, EOS/ data vuntil(1), vuntil(2) /LEXUNTIL, EOS/ # character set definitions: data extblk /' '/, intblk /BLANK/ data extdig(1) /'0'/, intdig(1) /DIG0/ data extdig(2) /'1'/, intdig(2) /DIG1/ data extdig(3) /'2'/, intdig(3) /DIG2/ data extdig(4) /'3'/, intdig(4) /DIG3/ data extdig(5) /'4'/, intdig(5) /DIG4/ data extdig(6) /'5'/, intdig(6) /DIG5/ data extdig(7) /'6'/, intdig(7) /DIG6/ data extdig(8) /'7'/, intdig(8) /DIG7/ data extdig(9) /'8'/, intdig(9) /DIG8/ data extdig(10) /'9'/, intdig(10) /DIG9/ # normal case of letters data extlet(1) /'a'/, intlet(1) /LETA/ data extlet(2) /'b'/, intlet(2) /LETB/ data extlet(3) /'c'/, intlet(3) /LETC/ data extlet(4) /'d'/, intlet(4) /LETD/ data extlet(5) /'e'/, intlet(5) /LETE/ data extlet(6) /'f'/, intlet(6) /LETF/ data extlet(7) /'g'/, intlet(7) /LETG/ data extlet(8) /'h'/, intlet(8) /LETH/ data extlet(9) /'i'/, intlet(9) /LETI/ data extlet(10) /'j'/, intlet(10) /LETJ/ data extlet(11) /'k'/, intlet(11) /LETK/ data extlet(12) /'l'/, intlet(12) /LETL/ data extlet(13) /'m'/, intlet(13) /LETM/ data extlet(14) /'n'/, intlet(14) /LETN/ data extlet(15) /'o'/, intlet(15) /LETO/ data extlet(16) /'p'/, intlet(16) /LETP/ data extlet(17) /'q'/, intlet(17) /LETQ/ data extlet(18) /'r'/, intlet(18) /LETR/ data extlet(19) /'s'/, intlet(19) /LETS/ data extlet(20) /'t'/, intlet(20) /LETT/ data extlet(21) /'u'/, intlet(21) /LETU/ data extlet(22) /'v'/, intlet(22) /LETV/ data extlet(23) /'w'/, intlet(23) /LETW/ data extlet(24) /'x'/, intlet(24) /LETX/ data extlet(25) /'y'/, intlet(25) /LETY/ data extlet(26) /'z'/, intlet(26) /LETZ/ # upper case of letters data extbig(1) /'A'/, intbig(1) /BIGA/ data extbig(2) /'B'/, intbig(2) /BIGB/ data extbig(3) /'C'/, intbig(3) /BIGC/ data extbig(4) /'D'/, intbig(4) /BIGD/ data extbig(5) /'E'/, intbig(5) /BIGE/ data extbig(6) /'F'/, intbig(6) /BIGF/ data extbig(7) /'G'/, intbig(7) /BIGG/ data extbig(8) /'H'/, intbig(8) /BIGH/ data extbig(9) /'I'/, intbig(9) /BIGI/ data extbig(10) /'J'/, intbig(10) /BIGJ/ data extbig(11) /'K'/, intbig(11) /BIGK/ data extbig(12) /'L'/, intbig(12) /BIGL/ data extbig(13) /'M'/, intbig(13) /BIGM/ data extbig(14) /'N'/, intbig(14) /BIGN/ data extbig(15) /'O'/, intbig(15) /BIGO/ data extbig(16) /'P'/, intbig(16) /BIGP/ data extbig(17) /'Q'/, intbig(17) /BIGQ/ data extbig(18) /'R'/, intbig(18) /BIGR/ data extbig(19) /'S'/, intbig(19) /BIGS/ data extbig(20) /'T'/, intbig(20) /BIGT/ data extbig(21) /'U'/, intbig(21) /BIGU/ data extbig(22) /'V'/, intbig(22) /BIGV/ data extbig(23) /'W'/, intbig(23) /BIGW/ data extbig(24) /'X'/, intbig(24) /BIGX/ data extbig(25) /'Y'/, intbig(25) /BIGY/ data extbig(26) /'Z'/, intbig(26) /BIGZ/ # special characters. some of these may # change for your machine data extchr(1) /'!'/, intchr(1) /NOT/ # use exclam for not-sign data extchr(2) /'"'/, intchr(2) /DQUOTE/ data extchr(3) /"#"/, intchr(3) /SHARP/ data extchr(4) /'$'/, intchr(4) /DOLLAR/ data extchr(5) /'%'/, intchr(5) /PERCENT/ data extchr(6) /'&'/, intchr(6) /AMPER/ data extchr(7) /"'"/, intchr(7) /SQUOTE/ data extchr(8) /'('/, intchr(8) /LPAREN/ data extchr(9) /')'/, intchr(9) /RPAREN/ data extchr(10) /'*'/, intchr(10) /STAR/ data extchr(11) /'+'/, intchr(11) /PLUS/ data extchr(12) /','/, intchr(12) /COMMA/ data extchr(13) /'-'/, intchr(13) /MINUS/ data extchr(14) /'.'/, intchr(14) /PERIOD/ data extchr(15) /'/'/, intchr(15) /SLASH/ data extchr(16) /':'/, intchr(16) /COLON/ data extchr(17) /';'/, intchr(17) /SEMICOL/ data extchr(18) /'<'/, intchr(18) /LESS/ data extchr(19) /'='/, intchr(19) /EQUALS/ data extchr(20) /'>'/, intchr(20) /GREATER/ data extchr(21) /'?'/, intchr(21) /QMARK/ data extchr(22) /'@'/, intchr(22) /ATSIGN/ data extchr(23) /'['/, intchr(23) /LBRACK/ data extchr(24) /'\'/, intchr(24) /BACKSLASH/ data extchr(25) /']'/, intchr(25) /RBRACK/ data extchr(26) /'_'/, intchr(26) /UNDERLINE/ data extchr(27) /'{'/, intchr(27) /LBRACE/ data extchr(28) /'|'/, intchr(28) /BAR/ data extchr(29) /'$@$'/, intchr(29) /RBRACE/ data extchr(30) /''/, intchr(30) /BACKSPACE/ data extchr(31) /' '/, intchr(31) /TAB/ data extchr(32) /'~'/, intchr(32) /NOT/ # use caret for not-sign data extchr(33) /'^'/, intchr(33) /NOT/ # use tilde for not-sign # NCHARS is last subscript in this array end # ratfor - main program for Ratfor call parse stop end # alldig - return YES if str is all digits integer function alldig(str) character type character str(ARB) integer i alldig = NO if (str(1) == EOS) return for (i = 1; str(i) ~= EOS; i = i + 1) if (type(str(i)) ~= DIGIT) return alldig = YES return end # balpar - copy balanced paren string subroutine balpar character gettok character t, token(MAXTOK) integer nlpar if (gettok(token, MAXTOK) ~= LPAREN) { call synerr("missing left paren.") return $@$ call outstr(token) nlpar = 1 repeat { t = gettok(token, MAXTOK) if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) { call pbstr(token) break $@$ if (t == NEWLINE) # delete newlines token(1) = EOS else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 # else nothing special call outstr(token) $@$ until (nlpar <= 0) if (nlpar ~= 0) call synerr("missing parenthesis in condition.") return end # brknxt - generate code for break and next subroutine brknxt(sp, lextyp, labval, token) integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token for (i = sp; i > 0; i = i - 1) if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) { if (token == LEXBREAK) call outgo(labval(i)+1) else call outgo(labval(i)) return $@$ if (token == LEXBREAK) call synerr("illegal break.") else call synerr("illegal next.") return end # close - exceedingly temporary version for gettok subroutine close(fd) integer fd rewind fd return end # ctoi - convert string at in(i) to integer, increment i integer function ctoi(in, i) character in(ARB) integer index integer d, i # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ while (in(i) == BLANK | in(i) == TAB) i = i + 1 for (ctoi = 0; in(i) ~= EOS; i = i + 1) { d = index(digits, in(i)) if (d == 0) # non-digit break ctoi = 10 * ctoi + d - 1 $@$ return end # deftok - get token; process macro calls and invocations character function deftok(token, toksiz, fd) character gtok integer fd, toksiz character defn(MAXDEF), t, token(toksiz) integer lookup for (t=gtok(token, toksiz, fd); t~=EOF; t=gtok(token, toksiz, fd)) { if (t ~= ALPHA) # non-alpha break if (lookup(token, defn) == NO) # undefined break if (defn(1) == DEFTYPE) { # get definition call getdef(token, toksiz, defn, MAXDEF, fd) call instal(token, defn) $@$ else call pbstr(defn) # push replacement onto input $@$ deftok = t if (deftok == ALPHA) # convert to single case call fold(token) return end # fold - convert alphabetic token to single case subroutine fold(token) character token(ARB) integer i # WARNING - this routine depends heavily on the # fact that letters have been mapped into internal # right-adjusted ascii. god help you if you # have subverted this mechanism. for (i = 1; token(i) ~= EOS; i = i + 1) if (token(i) >= BIGA & token(i) <= BIGZ) token(i) = token(i) - BIGA + LETA return end # docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab # string dostr "do" integer dostr(4) data dostr(1), dostr(2), dostr(3), dostr(4)/LETD, LETO, BLANK, EOS/ call outtab call outstr(dostr) lab = labgen(2) call outnum(lab) call eatup call outdon return end # dostat - generate code for end of do statement subroutine dostat(lab) integer lab call outcon(lab) call outcon(lab+1) return end # eatup - process rest of statement; interpret continuations subroutine eatup character gettok character ptoken(MAXTOK), t, token(MAXTOK) integer nlpar nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE) break if (t == RBRACE) { call pbstr(token) break $@$ if (t == LBRACE | t == EOF) { call synerr("unexpected brace or EOF.") call pbstr(token) break $@$ if (t == COMMA | t == UNDERLINE) { if (gettok(ptoken, MAXTOK) ~= NEWLINE) call pbstr(ptoken) if (t == UNDERLINE) token(1) = EOS $@$ else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 call outstr(token) $@$ until (nlpar < 0) if (nlpar ~= 0) call synerr("unbalanced parentheses.") return end # elseif - generate code for end of if before else subroutine elseif(lab) integer lab call outgo(lab+1) call outcon(lab) return end # equal - compare str1 to str2; return YES if equal, NO if not integer function equal(str1, str2) character str1(ARB), str2(ARB) integer i for (i = 1; str1(i) == str2(i); i = i + 1) if (str1(i) == EOS) { equal = YES return $@$ equal = NO return end # error - print fatal error message, then die subroutine error(buf) integer buf(ARB) call remark(buf) stop end # forcod - beginning of for statement subroutine forcod(lab) character gettok character t, token(MAXTOK) integer length, labgen integer i, j, lab, nlpar include commonblocks # include cfor # string ifnot "if(.not." integer ifnot(9) data ifnot(1) /LETI/ data ifnot(2) /LETF/ data ifnot(3) /LPAREN/ data ifnot(4) /PERIOD/ data ifnot(5) /LETN/ data ifnot(6) /LETO/ data ifnot(7) /LETT/ data ifnot(8) /PERIOD/ data ifnot(9) /EOS/ lab = labgen(3) call outcon(0) if (gettok(token, MAXTOK) ~= LPAREN) { call synerr("missing left paren.") return $@$ if (gettok(token, MAXTOK) ~= SEMICOL) { # real init clause call pbstr(token) call outtab call eatup call outdon $@$ if (gettok(token, MAXTOK) == SEMICOL) # empty condition call outcon(lab) else { # non-empty condition call pbstr(token) call outnum(lab) call outtab call outstr(ifnot) call outch(LPAREN) nlpar = 0 while (nlpar >= 0) { t = gettok(token, MAXTOK) if (t == SEMICOL) break if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t ~= NEWLINE & t ~= UNDERLINE) call outstr(token) $@$ call outch(RPAREN) call outch(RPAREN) call outgo(lab+2) if (nlpar < 0) call synerr("invalid for clause.") $@$ fordep = fordep + 1 # stack reinit clause j = 1 for (i = 1; i < fordep; i = i + 1) # find end j = j + length(forstk(j)) + 1 forstk(j) = EOS # null, in case no reinit nlpar = 0 while (nlpar >= 0) { t = gettok(token, MAXTOK) if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (nlpar >= 0 & t ~= NEWLINE & t ~= UNDERLINE) { call scopy(token, 1, forstk, j) j = j + length(token) $@$ $@$ lab = lab + 1 # label for next's return end # fors - process end of for statement subroutine fors(lab) integer length integer i, j, lab include commonblocks # include cfor call outnum(lab) j = 1 for (i = 1; i < fordep; i = i + 1) j = j + length(forstk(j)) + 1 if (length(forstk(j)) > 0) { call outtab call outstr(forstk(j)) call outdon $@$ call outgo(lab-1) call outcon(lab+1) fordep = fordep - 1 return end # getch - get characters from file integer function getch(c, f) character inmap character buf(MAXLINE), c integer f, i, lastc data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/ # note: MAXLINE = MAXCARD + 1 if (buf(lastc) == NEWLINE | lastc >= MAXLINE) { read(f, 1, end=10) (buf(i), i = 1, MAXCARD) 1 format(MAXCARD a1) for (i = 1; i <= MAXCARD; i = i + 1) buf(i) = inmap(buf(i)) for (i = MAXCARD; i > 0; i = i - 1) if (buf(i) ~= BLANK) break buf(i+1) = NEWLINE lastc = 0 $@$ lastc = lastc + 1 c = buf(lastc) getch = c return 10 c = EOF getch = EOF return end # getdef (for no arguments) - get name and definition subroutine getdef(token, toksiz, defn, defsiz, fd) character gtok, ngetch integer defsiz, fd, i, nlpar, toksiz character c, defn(defsiz), token(toksiz) if (ngetch(c, fd) ~= LPAREN) call remark("missing left paren.") if (gtok(token, toksiz, fd) ~= ALPHA) call remark("non-alphanumeric name.") else if (ngetch(c, fd) ~= COMMA) call remark("missing comma in define.") # else got (name, nlpar = 0 for (i = 1; nlpar >= 0; i = i + 1) if (i > defsiz) call error("definition too long.") else if (ngetch(defn(i), fd) == EOF) call error("missing right paren.") else if (defn(i) == LPAREN) nlpar = nlpar + 1 else if (defn(i) == RPAREN) nlpar = nlpar - 1 # else normal character in defn(i) defn(i-1) = EOS return end # gettok - get token. handles file inclusion and line numbers character function gettok(token, toksiz) integer equal, open integer junk, toksiz character deftok character name(MAXNAME), token(toksiz) include commonblocks # include cline # string incl "include" integer incl(8) data incl(1) /LETI/ data incl(2) /LETN/ data incl(3) /LETC/ data incl(4) /LETL/ data incl(5) /LETU/ data incl(6) /LETD/ data incl(7) /LETE/ data incl(8) /EOS/ for ( ; level > 0; level = level - 1) { for (gettok = deftok(token, toksiz, infile(level)); gettok ~= EOF; gettok = deftok(token, toksiz, infile(level))) { if (equal(token, incl) == NO) return junk = deftok(name, MAXNAME, infile(level)) if (level >= NFILES) call synerr("includes nested too deeply.") else { infile(level+1) = open(name, READONLY) linect(level+1) = 1 if (infile(level+1) == ERR) call synerr("can't open include.") else level = level + 1 $@$ $@$ if (level > 1) call close(infile(level)) $@$ gettok = EOF return end # gtok - get token for Ratfor character function gtok(lexstr, toksiz, fd) character ngetch, type integer fd, i, toksiz character c, lexstr(toksiz) include commonblocks # include cline while (ngetch(c, fd) ~= EOF) if (c ~= BLANK & c ~= TAB) break call putbak(c) for (i = 1; i < toksiz-1; i = i + 1) { gtok = type(ngetch(lexstr(i), fd)) if (gtok ~= LETTER & gtok ~= DIGIT) break $@$ if (i >= toksiz-1) call synerr("token too long.") if (i > 1) { # some alpha seen call putbak(lexstr(i)) # went one too far lexstr(i) = EOS gtok = ALPHA $@$ else if (lexstr(1) == DOLLAR) { # allow $( and $) for { and $@$ if (ngetch(lexstr(2), fd) == LPAREN) { lexstr(1) = LBRACE gtok = LBRACE $@$ else if (lexstr(2) == RPAREN) { lexstr(1) = RBRACE gtok = RBRACE $@$ else call putbak(lexstr(2)) $@$ else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) { for (i = 2; ngetch(lexstr(i), fd) ~= lexstr(1); i = i + 1) if (lexstr(i) == NEWLINE | i >= toksiz-1) { call synerr("missing quote.") lexstr(i) = lexstr(1) call putbak(NEWLINE) break $@$ $@$ else if (lexstr(1) == SHARP) { # strip comments while (ngetch(lexstr(1), fd) ~= NEWLINE) ; gtok = NEWLINE $@$ else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT | lexstr(1) == EQUALS | lexstr(1) == AMPER | lexstr(1) == BAR) call relate(lexstr, i, fd) lexstr(i+1) = EOS if (lexstr(1) == NEWLINE) linect(level) = linect(level) + 1 return end # ifcode - generate initial code for if subroutine ifcode(lab) integer labgen integer lab lab = labgen(2) call ifgo(lab) return end # ifgo - generate "if(.not.(...))goto lab" subroutine ifgo(lab) integer lab # string ifnot "if(.not." integer ifnot(9) data ifnot(1) /LETI/ data ifnot(2) /LETF/ data ifnot(3) /LPAREN/ data ifnot(4) /PERIOD/ data ifnot(5) /LETN/ data ifnot(6) /LETO/ data ifnot(7) /LETT/ data ifnot(8) /PERIOD/ data ifnot(9) /EOS/ call outtab # get to column 7 call outstr(ifnot) # " if(.not. " call balpar # collect and output condition call outch(RPAREN) # " ) " call outgo(lab) # " goto lab " return end # index - find character c in string str integer function index(str, c) character c, str(ARB) for (index = 1; str(index) ~= EOS; index = index + 1) if (str(index) == c) return index = 0 return end # initkw - install keyword "define" in table subroutine initkw # string defnam "define" integer defnam(7), deftyp(2) data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ data defnam(7) /EOS/ data deftyp(1), deftyp(2) /DEFTYPE, EOS/ call instal(defnam, deftyp) return end # inmap - convert left adjusted external rep to right adj ascii integer function inmap(inchar) integer i, inchar include commonblocks # include cchar if (inchar == extblk) { inmap = intblk return $@$ do i = 1, 10 if (inchar == extdig(i)) { inmap = intdig(i) return $@$ do i = 1, 26 if (inchar == extlet(i)) { inmap = intlet(i) return $@$ do i = 1, 26 if (inchar == extbig(i)) { inmap = intbig(i) return $@$ do i = 1, NCHARS if (inchar == extchr(i)) { inmap = intchr(i) return $@$ inmap = inchar return end # instal - add name and definition to table subroutine instal(name, defn) character defn(MAXTOK), name(MAXDEF) integer length integer dlen, nlen include commonblocks # include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { call putlin(name, ERROUT) call remark(": too many definitions.") $@$ lastp = lastp + 1 namptr(lastp) = lastt + 1 call scopy(name, 1, table, lastt + 1) call scopy(defn, 1, table, lastt + nlen + 1) lastt = lastt + nlen + dlen return end # itoc - convert integer int to char string in str integer function itoc(int, str, size) integer abs, mod integer d, i, int, intval, j, k, size character str(size) # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ intval = abs(int) str(1) = EOS i = 1 repeat { # generate digits i = i + 1 d = mod(intval, 10) str(i) = digits(d+1) intval = intval / 10 $@$ until (intval == 0 | i >= size) if (int < 0 & i < size) { # then sign i = i + 1 str(i) = MINUS $@$ itoc = i - 1 for (j = 1; j < i; j = j + 1) { # then reverse k = str(i) str(i) = str(j) str(j) = k i = i - 1 $@$ return end # labelc - output statement number subroutine labelc(lexstr) character lexstr(ARB) integer length if (length(lexstr) == 5) # warn about 23xxx labels if (lexstr(1) == DIG2 & lexstr(2) == DIG3) call synerr("warning: possible label conflict.") call outstr(lexstr) call outtab return end # labgen - generate n consecutive labels, return first one integer function labgen(n) integer label, n data label /23000/ labgen = label label = label + n return end # length - compute length of string integer function length(str) integer str(ARB) for (length = 0; str(length+1) ~= EOS; length = length + 1) ; return end # lex - return lexical type of token integer function lex(lexstr) character gettok character lexstr(MAXTOK) integer alldig, equal include commonblocks # include ckeywd while (gettok(lexstr, MAXTOK) == NEWLINE) ; lex = lexstr(1) if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE) return if (alldig(lexstr) == YES) lex = LEXDIGITS else if (equal(lexstr, sif) == YES) lex = vif(1) else if (equal(lexstr, selse) == YES) lex = velse(1) else if (equal(lexstr, swhile) == YES) lex = vwhile(1) else if (equal(lexstr, sdo) == YES) lex = vdo(1) else if (equal(lexstr, sbreak) == YES) lex = vbreak(1) else if (equal(lexstr, snext) == YES) lex = vnext(1) else if (equal(lexstr, sfor) == YES) lex = vfor(1) else if (equal(lexstr, srept) == YES) lex = vrept(1) else if (equal(lexstr, suntil) == YES) lex = vuntil(1) else lex = LEXOTHER return end # lookup - locate name, extract definition from table integer function lookup(name, defn) character defn(MAXDEF), name(MAXTOK) integer i, j, k include commonblocks # include clook for (i = lastp; i > 0; i = i - 1) { j = namptr(i) for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { # got one call scopy(table, j+1, defn, 1) lookup = YES return $@$ $@$ lookup = NO return end # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd include commonblocks # include cdefio if (bp > 0) c = buf(bp) else { bp = 1 buf(bp) = getch(c, fd) $@$ bp = bp - 1 ngetch = c return end # open - exceedingly temporary version for gettok integer function open(name, mode) character name(MAXNAME) integer ctoi integer i, mode i = 1 open = ctoi(name, i) return end # otherc - output ordinary Fortran statement subroutine otherc(lexstr) character lexstr(ARB) call outtab call outstr(lexstr) call eatup call outdon return end # outch - put one character into output buffer subroutine outch(c) character c integer i include commonblocks # include coutln if (outp >= 72) { # continuation card call outdon for (i = 1; i < 6; i = i + 1) outbuf(i) = BLANK outbuf(6) = STAR outp = 6 $@$ outp = outp + 1 outbuf(outp) = c return end # outcon - output "n continue" subroutine outcon(n) integer n # string contin "continue" integer contin(9) data contin(1) /LETC/ data contin(2) /LETO/ data contin(3) /LETN/ data contin(4) /LETT/ data contin(5) /LETI/ data contin(6) /LETN/ data contin(7) /LETU/ data contin(8) /LETE/ data contin(9) /EOS/ if (n > 0) call outnum(n) call outtab call outstr(contin) call outdon return end # outdon - finish off an output line subroutine outdon include commonblocks # include coutln outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS call putlin(outbuf, STDOUT) outp = 0 return end # outgo - output "goto n" subroutine outgo(n) integer n # string goto "goto" integer goto(6) data goto(1) /LETG/ data goto(2) /LETO/ data goto(3) /LETT/ data goto(4) /LETO/ data goto(5) /BLANK/ data goto(6) /EOS/ call outtab call outstr(goto) call outnum(n) call outdon return end # outmap - convert right adj ascii to left adjusted external rep integer function outmap(inchar) integer i, inchar include commonblocks # include cchar if (inchar == intblk) { outmap = extblk return $@$ do i = 1, 10 if (inchar == intdig(i)) { outmap = extdig(i) return $@$ do i = 1, 26 if (inchar == intlet(i)) { outmap = extlet(i) return $@$ do i = 1, 26 if (inchar == intbig(i)) { outmap = extbig(i) return $@$ do i = 1, NCHARS if (inchar == intchr(i)) { outmap = extchr(i) return $@$ outmap = inchar return end # outnum - output decimal number subroutine outnum(n) character chars(MAXCHARS) integer itoc integer i, len, n len = itoc(n, chars, MAXCHARS) for (i = 1; i <= len; i = i + 1) call outch(chars(i)) return end # outstr - output string subroutine outstr(str) character c, str(ARB) integer i, j for (i = 1; str(i) ~= EOS; i = i + 1) { c = str(i) if (c ~= SQUOTE & c ~= DQUOTE) call outch(c) else { i = i + 1 for (j = i; str(j) ~= c; j = j + 1) # find end ; call outnum(j-i) call outch(LETH) for ( ; i < j; i = i + 1) call outch(str(i)) $@$ $@$ return end # outtab - get past column 6 subroutine outtab include commonblocks # include coutln while (outp < 6) call outch(BLANK) return end # parse - parse Ratfor source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token call initkw # install keywords in table sp = 1 lextyp(1) = EOF for (token = lex(lexstr); token ~= EOF; token = lex(lexstr)) { if (token == LEXIF) call ifcode(lab) else if (token == LEXDO) call docode(lab) else if (token == LEXWHILE) call whilec(lab) else if (token == LEXFOR) call forcod(lab) else if (token == LEXREPEAT) call repcod(lab) else if (token == LEXDIGITS) call labelc(lexstr) else if (token == LEXELSE) { if (lextyp(sp) == LEXIF) call elseif(labval(sp)) else call synerr("illegal else.") $@$ if (token==LEXIF | token==LEXELSE | token==LEXWHILE | token==LEXFOR | token==LEXREPEAT | token==LEXDO | token==LEXDIGITS | token==LBRACE) { sp = sp + 1 # beginning of statement if (sp > MAXSTACK) call error("stack overflow in parser.") lextyp(sp) = token # stack type and value labval(sp) = lab $@$ else { # end of statement - prepare to unstack if (token == RBRACE) { if (lextyp(sp) == LBRACE) sp = sp - 1 else call synerr("illegal right brace.") $@$ else if (token == LEXOTHER) call otherc(lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt(sp, lextyp, labval, token) token = lex(lexstr) # peek at next token call pbstr(lexstr) call unstak(sp, lextyp, labval, token) $@$ $@$ if (sp ~= 1) call synerr("unexpected EOF.") return end # pbstr - push string back onto input subroutine pbstr(in) character in(ARB) integer length integer i for (i = length(in); i > 0; i = i - 1) call putbak(in(i)) return end # putbak - push character back onto input subroutine putbak(c) character c include commonblocks # include cdefio bp = bp + 1 if (bp > BUFSIZE) call error("too many characters pushed back.") buf(bp) = c return end # putch (interim version) put characters subroutine putch(c, f) integer buf(MAXLINE), c integer outmap integer f, i, lastc data lastc /0/ if (lastc >= MAXLINE | c == NEWLINE) { if ( lastc <= 0 ) { write(f,2) 2 format(/) $@$ else { write(f, 1) (buf(i), i = 1, lastc) 1 format(MAXCARD a1) $@$ lastc = 0 $@$ if (c ~= NEWLINE) { lastc = lastc + 1 buf(lastc) = outmap(c) $@$ return end # putlin - put out line by repeated calls to putch subroutine putlin(b, f) character b(ARB) integer f, i for (i = 1; b(i) ~= EOS; i = i + 1) call putch(b(i), f) return end # relate - convert relational shorthands into long form subroutine relate(token, last, fd) character ngetch character token(ARB) integer length integer fd, last # string dotge ".ge." # string dotgt ".gt." # string dotlt ".lt." # string dotle ".le." # string dotne ".ne." # string dotnot ".not." # string doteq ".eq." # string dotand ".and." # string dotor ".or." integer dotge(5), dotgt(5), dotlt(5), dotle(5) integer dotne(5), dotnot(6), doteq(5), dotand(6), dotor(5) data dotge(1), dotge(2), dotge(3), dotge(4), dotge(5)/ PERIOD, LETG, LETE, PERIOD, EOS/ data dotgt(1), dotgt(2), dotgt(3), dotgt(4), dotgt(5)/ PERIOD, LETG, LETT, PERIOD, EOS/ data dotle(1), dotle(2), dotle(3), dotle(4), dotle(5)/ PERIOD, LETL, LETE, PERIOD, EOS/ data dotlt(1), dotlt(2), dotlt(3), dotlt(4), dotlt(5)/ PERIOD, LETL, LETT, PERIOD, EOS/ data dotne(1), dotne(2), dotne(3), dotne(4), dotne(5)/ PERIOD, LETN, LETE, PERIOD, EOS/ data doteq(1), doteq(2), doteq(3), doteq(4), doteq(5)/ PERIOD, LETE, LETQ, PERIOD, EOS/ data dotor(1), dotor(2), dotor(3), dotor(4), dotor(5)/ PERIOD, LETO, LETR, PERIOD, EOS/ data dotand(1), dotand(2), dotand(3), dotand(4), dotand(5), dotand(6) /PERIOD, LETA, LETN, LETD, PERIOD, EOS/ data dotnot(1), dotnot(2), dotnot(3), dotnot(4), dotnot(5), dotnot(6) /PERIOD, LETN, LETO, LETT, PERIOD, EOS/ if (ngetch(token(2), fd) ~= EQUALS) call putbak(token(2)) if (token(1) == GREATER) { if (token(2) == EQUALS) call scopy(dotge, 1, token, 1) else call scopy(dotgt, 1, token, 1) $@$ else if (token(1) == LESS) { if (token(2) == EQUALS) call scopy(dotle, 1, token, 1) else call scopy(dotlt, 1, token, 1) $@$ else if (token(1) == NOT) { if (token(2) == EQUALS) call scopy(dotne, 1, token, 1) else call scopy(dotnot, 1, token, 1) $@$ else if (token(1) == EQUALS) { if (token(2) == EQUALS) call scopy(doteq, 1, token, 1) else token(2) = EOS $@$ else if (token(1) == AMPER) call scopy(dotand, 1, token, 1) else if (token(1) == BAR) call scopy(dotor, 1, token, 1) else # can't happen token(2) = EOS last = length(token) return end # remark - print warning message # this version is intentionally crude, and should be replaced # instantaneously by something tuned for your # specific environment. subroutine remark(buf) integer buf(ARB), i write(ERROUT, 10) (buf(i), i = 1, 5) 10 format(5a4) return end # repcod - generate code for beginning of repeat subroutine repcod(lab) integer labgen integer lab call outcon(0) # in case there was a label lab = labgen(3) call outcon(lab) lab = lab + 1 # label to go on next's return end # scopy - copy string at from(i) to to(j) subroutine scopy(from, i, to, j) character from(ARB), to(ARB) integer i, j, k1, k2 k2 = j for (k1 = i; from(k1) ~= EOS; k1 = k1 + 1) { to(k2) = from(k1) k2 = k2 + 1 $@$ to(k2) = EOS return end # synerr - report Ratfor syntax error subroutine synerr(msg) character lc(MAXLINE), msg(MAXLINE) integer itoc integer i, junk include commonblocks # include cline call remark("error at line.") for (i = 1; i <= level; i = i + 1) { call putch(BLANK, ERROUT) junk = itoc(linect(i), lc, MAXLINE) call putlin(lc, ERROUT) $@$ call putch(COLON, ERROUT) call putch(NEWLINE, ERROUT) call remark(msg) return end # type - return LETTER, DIGIT or character # this one works with ascii alphabet integer function type(c) integer c if( c >= DIG0 & c <= DIG9 ) type = DIGIT else if( c >= LETA & c <= LETZ ) type = LETTER else if( c >= BIGA & c <= BIGZ ) type = LETTER else type = c return end # unstak - unstack at end of statement subroutine unstak(sp, lextyp, labval, token) integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token for ( ; sp > 1; sp = sp - 1) { if (lextyp(sp) == LBRACE) break if (lextyp(sp) == LEXIF & token == LEXELSE) break if (lextyp(sp) == LEXIF) call outcon(labval(sp)) else if (lextyp(sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon(labval(sp)+1) $@$ else if (lextyp(sp) == LEXDO) call dostat(labval(sp)) else if (lextyp(sp) == LEXWHILE) call whiles(labval(sp)) else if (lextyp(sp) == LEXFOR) call fors(labval(sp)) else if (lextyp(sp) == LEXREPEAT) call untils(labval(sp), token) $@$ return end # untils - generate code for until or end of repeat subroutine untils(lab, token) character ptoken(MAXTOK) integer lex integer junk, lab, token call outnum(lab) if (token == LEXUNTIL) { junk = lex(ptoken) call ifgo(lab-1) $@$ else call outgo(lab-1) call outcon(lab+1) return end # whilec - generate code for beginning of while subroutine whilec(lab) integer labgen integer lab call outcon(0) # unlabeled continue, in case there was a label lab = labgen(2) call outnum(lab) call ifgo(lab+1) return end # whiles - generate code for end of while subroutine whiles(lab) integer lab call outgo(lab) call outcon(lab+1) return end ========== miscellaneous support for all programs ========== # cant - print cant open file message subroutine cant(buf) integer buf(MAXLINE) call putlin(buf, ERROUT) call error(" : can't open.") return end # ctoi - convert string at in(i) to integer, increment i integer function ctoi(in, i) character in(ARB) integer index integer d, i # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ while (in(i) == BLANK | in(i) == TAB) i = i + 1 for (ctoi = 0; in(i) ~= EOS; i = i + 1) { d = index(digits, in(i)) if (d == 0) # non-digit break ctoi = 10 * ctoi + d - 1 $@$ return end # equal - compare str1 to str2; return YES if equal, NO if not integer function equal(str1, str2) character str1(ARB), str2(ARB) integer i for (i = 1; str1(i) == str2(i); i = i + 1) if (str1(i) == EOS) { equal = YES return $@$ equal = NO return end # error - print fatal error message, then die subroutine error(buf) integer buf(ARB) call remark(buf) stop end # fcopy - copy file in to file out subroutine fcopy(in, out) character buf(MAXLINE) integer getlin integer in, out while (getlin(buf, in) ~= EOF) call putlin(buf, out) return end # index - find character c in string str integer function index(str, c) character c, str(ARB) for (index = 1; str(index) ~= EOS; index = index + 1) if (str(index) == c) return index = 0 return end define(abs,iabs) # itoc - convert integer int to char string in str integer function itoc(int, str, size) integer abs, mod integer d, i, int, intval, j, k, size character str(size) # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ intval = abs(int) str(1) = EOS i = 1 repeat { # generate digits i = i + 1 d = mod(intval, 10) str(i) = digits(d+1) intval = intval / 10 $@$ until (intval == 0 | i >= size) if (int < 0 & i < size) { # then sign i = i + 1 str(i) = MINUS $@$ itoc = i - 1 for (j = 1; j < i; j = j + 1) { # then reverse k = str(i) str(i) = str(j) str(j) = k i = i - 1 $@$ return end # length - compute length of string integer function length(str) integer str(ARB) for (length = 0; str(length+1) ~= EOS; length = length + 1) ; return end define(MAXCHARS,10) # putdec - put decimal integer n in field width >= w subroutine putdec(n, w) character chars(MAXCHARS) integer itoc integer i, n, nd, w nd = itoc(n, chars, MAXCHARS) for (i = nd + 1; i <= w; i = i + 1) call putc(BLANK) for (i = 1; i <= nd; i = i + 1) call putc(chars(i)) return end # scopy - copy string at from(i) to to(j) subroutine scopy(from, i, to, j) character from(ARB), to(ARB) integer i, j, k1, k2 k2 = j for (k1 = i; from(k1) ~= EOS; k1 = k1 + 1) { to(k2) = from(k1) k2 = k2 + 1 $@$ to(k2) = EOS return end # type - determine type of character character function type(c) character c integer index integer upalf(27) integer lowalf(27) integer digits(11) # string digits "0123456789" data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ # string lowalf "abcdefghijklmnopqrstuvwxyz" data lowalf(01)/LETA/ data lowalf(02)/LETB/ data lowalf(03)/LETC/ data lowalf(04)/LETD/ data lowalf(05)/LETE/ data lowalf(06)/LETF/ data lowalf(07)/LETG/ data lowalf(08)/LETH/ data lowalf(09)/LETI/ data lowalf(10)/LETJ/ data lowalf(11)/LETK/ data lowalf(12)/LETL/ data lowalf(13)/LETM/ data lowalf(14)/LETN/ data lowalf(15)/LETO/ data lowalf(16)/LETP/ data lowalf(17)/LETQ/ data lowalf(18)/LETR/ data lowalf(19)/LETS/ data lowalf(20)/LETT/ data lowalf(21)/LETU/ data lowalf(22)/LETV/ data lowalf(23)/LETW/ data lowalf(24)/LETX/ data lowalf(25)/LETY/ data lowalf(26)/LETZ/ data lowalf(27)/EOS/ # string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" data upalf(01) /BIGA/ data upalf(02) /BIGB/ data upalf(03) /BIGC/ data upalf(04) /BIGD/ data upalf(05) /BIGE/ data upalf(06) /BIGF/ data upalf(07) /BIGG/ data upalf(08) /BIGH/ data upalf(09) /BIGI/ data upalf(10) /BIGJ/ data upalf(11) /BIGK/ data upalf(12) /BIGL/ data upalf(13) /BIGM/ data upalf(14) /BIGN/ data upalf(15) /BIGO/ data upalf(16) /BIGP/ data upalf(17) /BIGQ/ data upalf(18) /BIGR/ data upalf(19) /BIGS/ data upalf(20) /BIGT/ data upalf(21) /BIGU/ data upalf(22) /BIGV/ data upalf(23) /BIGW/ data upalf(24) /BIGX/ data upalf(25) /BIGY/ data upalf(26) /BIGZ/ data upalf(27) /EOS/ if (index(lowalf, c) > 0) type = LETTER else if (index(upalf, c) > 0) type = LETTER else if (index(digits, c) > 0) type = DIGIT else type = c return end ========== programs from chapter 1 ========== # copy - copy input characters to output integer getc integer c while (getc(c) ~= EOF) call putc(c) stop end # charcount - count characters in standard input character getc character c integer nc nc = 0 while (getc(c) ~= EOF) nc = nc + 1 call putdec(nc, 1) call putc(NEWLINE) stop end # linecount - count lines in standard input character getc character c integer nl nl = 0 while (getc(c) ~= EOF) if (c == NEWLINE) nl = nl + 1 call putdec(nl, 1) call putc(NEWLINE) stop end # wordcount - count words in standard input character getc character c integer inword, wc wc = 0 inword = NO while (getc(c) ~= EOF) if (c == BLANK | c == NEWLINE | c == TAB) inword = NO else if (inword == NO) { inword = YES wc = wc + 1 $@$ call putdec(wc, 1) call putc(NEWLINE) stop end # detab - convert tabs to equivalent number of blanks character getc character c integer tabpos integer col, i, tabs(MAXLINE) call settab(tabs) # set initial tab stops col = 1 while (getc(c) ~= EOF) if (c == TAB) repeat { call putc(BLANK) col = col + 1 $@$ until (tabpos(col, tabs) == YES) else if (c == NEWLINE) { call putc(NEWLINE) col = 1 $@$ else { call putc(c) col = col + 1 $@$ stop end # tabpos - return YES if col is a tab stop integer function tabpos(col, tabs) integer col, i, tabs(MAXLINE) if (col > MAXLINE) tabpos = YES else tabpos = tabs(col) return end # settab - set initial tab stops subroutine settab(tabs) integer mod integer i, tabs(MAXLINE) for (i = 1; i <= MAXLINE; i = i + 1) if (mod(i, 8) == 1) tabs(i) = YES else tabs(i) = NO return end #c detab - convert tabs to equivalent number of blanks; Fortran version integer getc integer c integer tabpos integer col, i, tabs(MAXLINE) #c #c set initial tab stops call settab(tabs) col = 1 10 if (getc(c) .eq. EOF) goto 60 if (c .ne. TAB) goto 30 20 call putc(BLANK) col = col + 1 if (tabpos(col, tabs) .ne. YES) goto 20 goto 50 #c else if 30 if (c .ne. NEWLINE) goto 40 call putc(NEWLINE) col = 1 goto 50 #c else 40 call putc(c) col = col + 1 50 goto 10 60 stop end #c tabpos - return YES if col is a tab stop; Fortran version integer function tabpos(col, tabs) integer col, i, tabs(MAXLINE) #c if (col .gt. MAXLINE) tabpos = YES if (col .le. MAXLINE) tabpos = tabs(col) return end #c settab - set initial tab stops; Fortran version subroutine settab(tabs) integer mod integer i, tabs(MAXLINE) #c i = 1 10 if (i .gt. MAXLINE) goto 20 if (mod(i, 8) .eq. 1) tabs(i) = YES if (mod(i, 8) .ne. 1) tabs(i) = NO i = i + 1 goto 10 20 return end /* copy _ copy input characters to output */ copy: procedure options (main); declare getc entry (fixed binary) returns (fixed binary); declare putc entry (fixed binary); declare c fixed binary; do while (getc(c) ~= EOF); call putc(c); end; end copy; /* detab _ convert tabs into equivalent number of blanks */ detab: procedure options (main); declare getc entry (fixed binary) returns (fixed binary); declare putc entry (fixed binary); declare c fixed binary; declare settab entry ((*)fixed binary); declare tabpos entry (fixed bin, (*)fixed bin) returns (fixed bin); declare (col, tabs(MAXLINE)) fixed binary; call settab(tabs); /* set initial tab stops */ col = 1; do while (getc(c) ~= EOF); if c = TAB then do; loop: call putc(BLANK); col = col + 1; if tabpos(col, tabs) ~= YES then goto loop; end; else if c = NEWLINE then do; call putc(NEWLINE); col = 1; end; else do; call putc(c); col = col + 1; end; end; end detab; /* tabpos _ return YES if col is a tab stop */ tabpos: procedure (col, tabs) returns (fixed binary); declare (col, tabs(*)) fixed binary; if col > MAXLINE then return(YES); else return(tabs(col)); end tabpos; /* settab _ set initial tab stops */ settab: procedure (tabs); declare (i, tabs(*)) fixed binary; do i = 1 to MAXLINE; if mod(i, 8) = 1 then tabs(i) = YES; else tabs(i) = NO; end; end settab; ========== smaller programs from chapter 2 ========== # entab - replace blanks by tabs and blanks character getc character c integer tabpos integer col, i, newcol, tabs(MAXLINE) call settab(tabs) col = 1 repeat { newcol = col while (getc(c) == BLANK) { # collect blanks newcol = newcol + 1 if (tabpos(newcol, tabs) == YES) { call putc(TAB) col = newcol $@$ $@$ for ( ; col < newcol; col = col + 1) call putc(BLANK) # output leftover blanks if (c == EOF) break call putc(c) if (c == NEWLINE) col = 1 else col = col + 1 $@$ stop end # tabpos - return YES if col is a tab stop integer function tabpos(col, tabs) integer col, i, tabs(MAXLINE) if (col > MAXLINE) tabpos = YES else tabpos = tabs(col) return end # settab - set initial tab stops subroutine settab(tabs) integer mod integer i, tabs(MAXLINE) for (i = 1; i <= MAXLINE; i = i + 1) if (mod(i, 8) == 1) tabs(i) = YES else tabs(i) = NO return end define(NOSKIP,PLUS) define(SKIP,STAR) # overstrike - convert backspaces into multiple lines character getc character c integer max integer col, newcol col = 1 repeat { newcol = col while (getc(c) == BACKSPACE) # eat up backspaces newcol = max(newcol-1, 1) if (newcol < col) { # start overstrike line call putc(NEWLINE) call putc(NOSKIP) for (col = 1; col < newcol; col = col + 1) call putc(BLANK) $@$ else if (col == 1 & c ~= EOF) # start normal line call putc(SKIP) # else middle of line if (c == EOF) break call putc(c) # normal character if (c == NEWLINE) col = 1 else col = col + 1 $@$ stop end define(RCODE,STAR) define(MAXCHUNK,10) define(THRESH,5) # compress - compress standard input character getc character buf(MAXCHUNK), c, lastc integer nrep, nsave # must have RCODE > MAXCHUNK or RCODE = 0 nsave = 0 for (lastc = getc(lastc); lastc ~= EOF; lastc = c) { for (nrep = 1; getc(c) == lastc; nrep = nrep + 1) if (nrep >= MAXCHUNK) # count repetitions break if (nrep < THRESH) # append short string for ( ; nrep > 0; nrep = nrep - 1) { nsave = nsave + 1 buf(nsave) = lastc if (nsave >= MAXCHUNK) call putbuf(buf, nsave) $@$ else { call putbuf(buf, nsave) call putc(RCODE) call putc(lastc) call putc(nrep) $@$ $@$ call putbuf(buf, nsave) # put last chunk stop end # putbuf - output buf(1) ... buf(nsave), clear nsave subroutine putbuf(buf, nsave) character buf(MAXCHUNK) integer i, nsave if (nsave > 0) { call putc(nsave) for (i = 1; i <= nsave; i = i + 1) call putc(buf(i)) $@$ nsave = 0 return end define(RCODE,STAR) # expand - uncompress standard input character getc character c, code while (getc(code) ~= EOF) if (code == RCODE) { # expand repetition if (getc(c) == EOF) break if (getc(code) == EOF) break for ( ; code > 0; code = code - 1) call putc(c) $@$ else { # expand chunk for ( ; code > 0; code = code - 1) { if (getc(c) == EOF) break call putc(c) $@$ if (c == EOF) break $@$ stop end define(MAXKEY,50) # crypt - encrypt and decrypt character getc, xor character c, key(MAXKEY) integer getarg, mod integer i, keylen keylen = getarg(1, key, MAXKEY) if (keylen == EOF) call error("usage: crypt key.") for (i = 1; getc(c) ~= EOF; i = mod(i, keylen) + 1) call putc(xor(c, key(i))) stop end # xor - exclusive-or of a and b character function xor(a, b) character and, not, or character a, b xor = or(and(a, not(b)), and(not(a), b)) return end ========== translit program from chapter 2 ========== define(MAXARR,100) define(MAXSET,100) define(ESCAPE,ATSIGN) define(DASH,MINUS) define(NOT,BANG) # addset - put c in set(j) if it fits, increment j integer function addset(c, set, j, maxsiz) integer j, maxsiz character c, set(maxsiz) if (j > maxsiz) addset = NO else { set(j) = c j = j + 1 addset = YES $@$ return end # dodash - expand array(i-1)-array(i+1) into set(j)... from valid subroutine dodash(valid, array, i, set, j, maxset) character esc integer addset, index integer i, j, junk, k, limit, maxset character array(ARB), set(maxset), valid(ARB) i = i + 1 j = j - 1 limit = index(valid, esc(array, i)) for (k = index(valid, set(j)); k <= limit; k = k + 1) junk = addset(valid(k), set, j, maxset) return end # esc - map array(i) into escaped character if appropriate character function esc(array, i) character array(ARB) integer i if (array(i) ~= ESCAPE) esc = array(i) else if (array(i+1) == EOS) # \*a not special at end esc = ESCAPE else { i = i + 1 if (array(i) == LETN) esc = NEWLINE else if (array(i) == LETT) esc = TAB else esc = array(i) $@$ return end # filset - expand set at array(i) into set(j), stop at delim subroutine filset(delim, array, i, set, j, maxset) character esc integer addset, index integer i, j, junk, maxset character array(ARB), delim, set(maxset) # string digits "0123456789" integer digits(11) # string lowalf "abcdefghijklmnopqrstuvwxyz" integer lowalf(27) # string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" integer upalf(27) data digits(1)/DIG0/, digits(2)/DIG1/, digits(3)/DIG2/ data digits(4)/DIG3/, digits(5)/DIG4/, digits(6)/DIG5/ data digits(7)/DIG6/, digits(8)/DIG7/, digits(9)/DIG8/ data digits(10)/DIG9/, digits(11)/EOS/ data lowalf(01)/LETA/ data lowalf(02)/LETB/ data lowalf(03)/LETC/ data lowalf(04)/LETD/ data lowalf(05)/LETE/ data lowalf(06)/LETF/ data lowalf(07)/LETG/ data lowalf(08)/LETH/ data lowalf(09)/LETI/ data lowalf(10)/LETJ/ data lowalf(11)/LETK/ data lowalf(12)/LETL/ data lowalf(13)/LETM/ data lowalf(14)/LETN/ data lowalf(15)/LETO/ data lowalf(16)/LETP/ data lowalf(17)/LETQ/ data lowalf(18)/LETR/ data lowalf(19)/LETS/ data lowalf(20)/LETT/ data lowalf(21)/LETU/ data lowalf(22)/LETV/ data lowalf(23)/LETW/ data lowalf(24)/LETX/ data lowalf(25)/LETY/ data lowalf(26)/LETZ/ data lowalf(27)/EOS/ data upalf(01) /BIGA/ data upalf(02) /BIGB/ data upalf(03) /BIGC/ data upalf(04) /BIGD/ data upalf(05) /BIGE/ data upalf(06) /BIGF/ data upalf(07) /BIGG/ data upalf(08) /BIGH/ data upalf(09) /BIGI/ data upalf(10) /BIGJ/ data upalf(11) /BIGK/ data upalf(12) /BIGL/ data upalf(13) /BIGM/ data upalf(14) /BIGN/ data upalf(15) /BIGO/ data upalf(16) /BIGP/ data upalf(17) /BIGQ/ data upalf(18) /BIGR/ data upalf(19) /BIGS/ data upalf(20) /BIGT/ data upalf(21) /BIGU/ data upalf(22) /BIGV/ data upalf(23) /BIGW/ data upalf(24) /BIGX/ data upalf(25) /BIGY/ data upalf(26) /BIGZ/ data upalf(27) /EOS/ for ( ; array(i) ~= delim & array(i) ~= EOS; i = i + 1) if (array(i) == ESCAPE) junk = addset(esc(array, i), set, j, maxset) else if (array(i) ~= DASH) junk = addset(array(i), set, j, maxset) else if (j <= 1 | array(i+1) == EOS) # literal - junk = addset(DASH, set, j, maxset) else if (index(digits, set(j-1)) > 0) call dodash(digits, array, i, set, j, maxset) else if (index(lowalf, set(j-1)) > 0) call dodash(lowalf, array, i, set, j, maxset) else if (index(upalf, set(j-1)) > 0) call dodash(upalf, array, i, set, j, maxset) else junk = addset(DASH, set, j, maxset) return end # makset - make set from array(k) in set integer function makset(array, k, set, size) integer addset integer i, j, k, size character array(ARB), set(size) i = k j = 1 call filset(EOS, array, i, set, j, size) makset = addset(EOS, set, j, size) return end # translit - map characters character getc character arg(MAXARR), c, from(MAXSET), to(MAXSET) integer getarg, length, makset, xindex integer allbut, collap, i, lastto if (getarg(1, arg, MAXARR) == EOF) call error("usage: translit from to.") else if (arg(1) == NOT) { allbut = YES if (makset(arg, 2, from, MAXSET) == NO) call error("from: too large.") $@$ else { allbut = NO if (makset(arg, 1, from, MAXSET) == NO) call error("from: too large.") $@$ if (getarg(2, arg, MAXARR) == EOF) to(1) = EOS else if (makset(arg, 1, to, MAXSET) == NO) call error("to: too large.") lastto = length(to) if (length(from) > lastto | allbut == YES) collap = YES else collap = NO repeat { i = xindex(from, getc(c), allbut, lastto) if (collap == YES & i >= lastto & lastto > 0) { # collapse call putc(to(lastto)) repeat i = xindex(from, getc(c), allbut, lastto) until (i < lastto) $@$ if (c == EOF) break if (i > 0 & lastto > 0) # translate call putc(to(i)) else if (i == 0) # copy call putc(c) # else delete $@$ stop end # xindex - invert condition returned by index integer function xindex(array, c, allbut, lastto) character array(ARB), c integer index integer allbut, lastto if (c == EOF) xindex = 0 else if (allbut == NO) xindex = index(array, c) else if (index(array, c) > 0) xindex = 0 else xindex = lastto + 1 return end ========== smaller programs from chapter 3 ========== define(INFILE1,1) define(INFILE2,2) define(NAMESIZE,50) # compare (simple version) - compare file 1 to file 2 character line1(MAXLINE), line2(MAXLINE) integer equal, getlin integer lineno, m1, m2 lineno = 0 repeat { m1 = getlin(line1, INFILE1) m2 = getlin(line2, INFILE2) if (m1 == EOF | m2 == EOF) break lineno = lineno + 1 if (equal(line1, line2) == NO) call difmsg(lineno, line1, line2) $@$ if (m1 == EOF & m2 ~= EOF) call remark("eof on file 1.") else if (m2 == EOF & m1 ~= EOF) call remark("eof on file 2.") # else they match stop end # difmsg - print line numbers and differing lines subroutine difmsg(lineno, line1, line2) character line1(ARB), line2(ARB) integer lineno call putdec(lineno, 5) call putc(NEWLINE) call putlin(line1, STDOUT) call putlin(line2, STDOUT) return end define(NAMESIZE,50) # compare - compare two files for equality character arg1(MAXLINE), arg2(MAXLINE) character line1(MAXLINE), line2(MAXLINE) integer equal, getarg, getlin, open integer infil1, infil2, lineno, m1, m2 if (getarg(1, arg1, MAXLINE) == EOF | getarg(2, arg2, MAXLINE) == EOF) call error("usage: compare file1 file2.") infil1 = open(arg1, READ) if (infil1 == ERR) call cant(arg1) infil2 = open(arg2, READ) if (infil2 == ERR) call cant(arg2) lineno = 0 repeat { m1 = getlin(line1, infil1) m2 = getlin(line2, infil2) if (m1 == EOF | m2 == EOF) break lineno = lineno + 1 if (equal(line1, line2) == NO) call difmsg(lineno, line1, line2) $@$ if (m1 == EOF & m2 ~= EOF) call remark("eof on file 1.") else if (m2 == EOF & m1 ~= EOF) call remark("eof on file 2.") stop end #difmsg subroutine difmsg(lineno, line1, line2) integer line1(MAXLINE), line2(MAXLINE) integer lineno call putdec(lineno, 5) call putc(NEWLINE) call putlin(line1, STDOUT) call putlin(line2, STDOUT) return end define(NFILES,5) # include - replace include file by contents of file character line(MAXLINE), str(MAXLINE) integer equal, getlin, getwrd, open integer infile(NFILES), len, level, loc # string incl "include" integer incl(8) data incl(1) /LETI/ data incl(2) /LETN/ data incl(3) /LETC/ data incl(4) /LETL/ data incl(5) /LETU/ data incl(6) /LETD/ data incl(7) /LETE/ data incl(8) /EOS/ infile(1) = STDIN for (level = 1; level > 0; level = level - 1) { while (getlin(line, infile(level)) ~= EOF) { loc = 1 len = getwrd(line, loc, str) if (equal(str, incl) == NO) call putlin(line, STDOUT) else { level = level + 1 if (level > NFILES) call error("includes nested too deeply.") len = getwrd(line, loc, str) infile(level) = open(str, READ) if (infile(level) == ERR) call cant(str) $@$ $@$ if (level > 1) call close(infile(level)) $@$ stop end # getwrd - get non-blank word from in(i) into out, increment i integer function getwrd(in, i, out) character in(ARB), out(ARB) integer i, j while (in(i) == BLANK | in(i) == TAB) i = i + 1 j = 1 while (in(i) ~= EOS & in(i) ~= BLANK & in(i) ~= TAB & in(i) ~= NEWLINE) { out(j) = in(i) i = i + 1 j = j + 1 $@$ out(j) = EOS getwrd = j - 1 return end define(NAMESIZE,50) # concat - concatenate named files onto standard output character name(NAMESIZE) integer getarg, open integer fin, i for (i = 1; getarg(i, name, NAMESIZE) ~= EOF; i = i + 1) { fin = open(name, READ) if (fin == ERR) call cant(name) call fcopy(fin, STDOUT) call close(fin) $@$ stop end define(NAMESIZE,50) define(MARGIN1,3) define(MARGIN2,2) define(MARGIN3,2) define(MARGIN4,3) define(BOTTOM,60) define(PAGELEN,66) # print - print files with headings character name(NAMESIZE) integer getarg, open integer fin, i for (i = 1; getarg(i, name, NAMESIZE) ~= EOF; i = i + 1) { fin = open(name, READ) if (fin == ERR) call cant(name) call fprint(name, fin) call close(fin) $@$ stop end # fprint - print file "name" from fin subroutine fprint(name, fin) character line(MAXLINE), name(NAMESIZE) integer getlin, open integer fin, lineno, pageno pageno = 0 lineno = 0 while (getlin(line, fin) ~= EOF) { if (lineno == 0) { call skip(MARGIN1) pageno = pageno + 1 call head(name, pageno) call skip(MARGIN2) lineno = MARGIN1 + MARGIN2 + 1 $@$ call putlin(line, STDOUT) lineno = lineno + 1 if (lineno >= BOTTOM) { call skip(PAGELEN-lineno) lineno = 0 $@$ $@$ if (lineno > 0) call skip(PAGELEN-lineno) return end # skip - output n blank lines subroutine skip(n) integer i, n for (i = 1; i <= n; i = i + 1) call putc(NEWLINE) return end # head - print top of page header subroutine head(name, pageno) character name(NAMESIZE) integer pageno # string page " Page " integer page(7) data page(1) /BLANK/ data page(2) /LETP/ data page(3) /LETA/ data page(4) /LETG/ data page(5) /LETE/ data page(6) /BLANK/ data page(7) /EOS/ call putlin(name, STDOUT) call putlin(page, STDOUT) call putdec(pageno, 1) call putc(NEWLINE) return end define(NAMESIZE,50) define(MARGIN1,3) define(MARGIN2,2) define(MARGIN3,2) define(MARGIN4,3) define(BOTTOM,60) define(PAGELEN,66) # print (default input STDIN) - print files with headings character name(NAMESIZE) integer getarg, open integer fin, i # string null "" integer null(1) data null(1) /EOS/ for (i = 1; getarg(i, name, NAMESIZE) ~= EOF; i = i + 1) { fin = open(name, READ) if (fin == ERR) call cant(name) call fprint(name, fin) call close(fin) $@$ if (i == 1) # no files specified call fprint(null, STDIN) stop end # fprint - print file "name" from fin subroutine fprint(name, fin) integer line(MAXLINE), name(NAMESIZE) integer getlin, open integer fin, lineno, pageno pageno = 0 lineno = 0 while (getlin(line, fin) ~= EOF) { if (lineno == 0) { call skip(MARGIN1) pageno = pageno + 1 call head(name, pageno) call skip(MARGIN2) lineno = MARGIN1 + MARGIN2 + 1 $@$ call putlin(line, STDOUT) lineno = lineno + 1 if (lineno >= BOTTOM) { call skip(PAGELEN-lineno) lineno = 0 $@$ $@$ if (lineno > 0) call skip(PAGELEN-lineno) return end # skip - output n blank lines subroutine skip(n) integer i, n for (i = 1; i <= n; i = i + 1) call putc(NEWLINE) return end # head - print top of page header subroutine head(name, pageno) integer name(NAMESIZE) integer pageno # string page " Page " integer page(7) data page(1) /BLANK/ data page(2) /LETP/ data page(3) /LETA/ data page(4) /LETG/ data page(5) /LETE/ data page(6) /BLANK/ data page(7) /EOS/ call putlin(name, STDOUT) call putlin(page, STDOUT) call putdec(pageno, 1) call putc(NEWLINE) return end define(NAMESIZE,50) # makecopy - copy one file to another character iname(NAMESIZE), oname(NAMESIZE) integer create, getarg, open integer fin, fout if (getarg(1, iname, NAMESIZE) == EOF | getarg(2, oname, NAMESIZE) == EOF) call error("usage: makecopy input output.") fin = open(iname, READ) if (fin == ERR) call cant(iname) fout = create(oname, WRITE) if (fout == ERR) call cant(oname) call fcopy(fin, fout) call close(fin) call close(fout) stop end ========== archive program from chapter 3 ========== define(NAMESIZE,20) define(MAXFILES,5) define(TBL,LETT) define(PRINT,LETP) define(EXTR,LETX) define(UPD,LETU) define(DEL,LETD) common /carch/ fname(NAMESIZE,MAXFILES),fstat(MAXFILES),nfiles,errcnt character fname # file arguments integer fstat # YES if touched, NO otherwise; init = NO integer nfiles # number of file args integer errcnt # error count; init = 0 # acopy - copy size characters from fdi to fdo subroutine acopy(fdi, fdo, size) character getch character c integer fdi, fdo, i, size for (i = 1; i <= size; i = i + 1) { if (getch(c, fdi) == EOF) break call putch(c, fdo) $@$ return end # addfil - add file "name" to archive subroutine addfil(name, fd, errcnt) character head(MAXLINE), name(ARB) integer open integer errcnt, fd, nfd nfd = open(name, READ) if (nfd == ERR) { call putlin(name, ERROUT) call remark(": can't add.") errcnt = errcnt + 1 $@$ if (errcnt == 0) { call makhdr(name, head) call putlin(head, fd) call fcopy(nfd, fd) call close(nfd) $@$ return end # amove - move name1 to name2 subroutine amove(name1, name2) character name1(ARB), name2(ARB) integer create, open integer fd1, fd2 fd1 = open(name1, READ) if (fd1 == ERR) call cant(name1) fd2 = create(name2, WRITE) if (fd2 == ERR) call cant(name2) call fcopy(fd1, fd2) return end # archive - file maintainer character aname(NAMESIZE) integer getarg integer comand(2) if (getarg(1, comand, 2) == EOF | getarg(2, aname, NAMESIZE) == EOF) call help call getfns if (comand(1) == UPD) call update(aname) else if (comand(1) == TBL) call table(aname) else if (comand(1) == EXTR | comand(1) == PRINT) call extrac(aname, comand(1)) else if (comand(1) == DEL) call delete(aname) else call help stop end # block data for archive block data include carch data errcnt /0/ end # delete - delete files from archive subroutine delete(aname) character aname(NAMESIZE), in(MAXLINE) integer create, open integer afd, tfd include carch # string tname "archtemp" integer tname(9) data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/ data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/ data tname(9)/EOS/ if (nfiles <= 0) # protect innocents call error("delete by name only.") afd = open(aname, READWRITE) if (afd == ERR) call cant(aname) tfd = create(tname, READWRITE) if (tfd == ERR) call cant(tname) call replac(afd, tfd, DEL, errcnt) call notfnd call close(afd) call close(tfd) if (errcnt == 0) call amove(tname, aname) else call remark("fatal errors - archive not altered.") call remove(tname) return end # extrac - extract files from archive subroutine extrac(aname, cmd) character aname(NAMESIZE), ename(NAMESIZE), in(MAXLINE) integer create, filarg, gethdr, open integer afd, cmd, efd, size include carch afd = open(aname, READ) if (afd == ERR) call cant(aname) if (cmd == PRINT) efd = STDOUT else efd = ERR while (gethdr(afd, in, ename, size) ~= EOF) if (filarg(ename) == NO) call fskip(afd, size) else { if (efd ~= STDOUT) efd = create(ename, WRITE) if (efd == ERR) { call putlin(ename, ERROUT) call remark(": can't create.") errcnt = errcnt + 1 call fskip(afd, size) $@$ else { call acopy(afd, efd, size) if (efd ~= STDOUT) call close(efd) $@$ $@$ call notfnd return end # filarg - check if name matches argument list integer function filarg(name) character name(ARB) integer equal, getarg integer i include carch if (nfiles <= 0) { filarg = YES return $@$ for (i = 1; i <= nfiles; i = i + 1) if (equal(name, fname(1, i)) == YES) { fstat(i) = YES filarg = YES return $@$ filarg = NO return end # fsize - size of file in characters integer function fsize(name) character getch character c, name(ARB) integer open integer fd fd = open(name, READ) if (fd == ERR) fsize = ERR else { for (fsize = 0; getch(c, fd) ~= EOF; fsize = fsize + 1) ; call close(fd) $@$ return end # fskip - skip n characters on file fd subroutine fskip(fd, n) character getch character c integer fd, i, n for (i = 1; i <= n; i = i + 1) if (getch(c, fd) == EOF) break return end # getfns - get file names into fname, check for duplicates subroutine getfns integer equal, getarg integer i, j include carch errcnt = 0 for (i = 1; i <= MAXFILES; i = i + 1) if (getarg(i+2, fname(1, i), NAMESIZE) == EOF) break nfiles = i - 1 if (i > MAXFILES) if (getarg(i+2, j, 1) ~= EOF) call error("too many file names.") for (i = 1; i <= nfiles; i = i + 1) fstat(i) = NO for (i = 1; i < nfiles; i = i + 1) for (j = i + 1; j <= nfiles; j = j + 1) if (equal(fname(1, i), fname(1, j)) == YES) { call putlin(fname(1, i), ERROUT) call error(": duplicate file name.") $@$ return end # gethdr - get header info from fd integer function gethdr(fd, buf, name, size) character buf(MAXLINE), c, name(NAMESIZE), temp(NAMESIZE) integer ctoi, equal, getlin, getwrd integer fd, i, len, size # string hdr "-h-" integer hdr(4) data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/ if (getlin(buf, fd) == EOF) { gethdr = EOF return $@$ i = 1 len = getwrd(buf, i, temp) if (equal(temp, hdr) == NO) call error("archive not in proper format.") gethdr = YES len = getwrd(buf, i, name) size = ctoi(buf, i) return end # getwrd - get non-blank word from in(i) into out, increment i integer function getwrd(in, i, out) integer in(ARB), out(ARB) integer i, j while (in(i) == BLANK | in(i) == TAB) i = i + 1 j = 1 while (in(i)~=EOS & in(i)~=BLANK & in(i)~=TAB & in(i)~=NEWLINE) { out(j) = in(i) i = i + 1 j = j + 1 $@$ out(j) = EOS getwrd = j - 1 return end # help - diagnostic printout subroutine help call error("usage: archive {dptux$@$ archname [files].") return end define(MAXCHARS,10) # makhdr - make header line for archive member subroutine makhdr(name, head) character head(MAXLINE), name(NAMESIZE) integer fsize, itoc, length integer i # string hdr "-h-" integer hdr(4) data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/ call scopy(hdr, 1, head, 1) i = length(hdr) + 1 head(i) = BLANK call scopy(name, 1, head, i+1) i = length(head) + 1 head(i) = BLANK i = i + 1 + itoc(fsize(name), head(i+1), MAXCHARS) head(i) = NEWLINE head(i+1) = EOS return end # notfnd - print "not found" message subroutine notfnd integer i include carch for (i = 1; i <= nfiles; i = i + 1) if (fstat(i) == NO) { call putlin(fname(1, i), ERROUT) call remark(": not in archive.") errcnt = errcnt + 1 $@$ return end # replac - replace or delete files subroutine replac(afd, tfd, cmd, errcnt) character in(MAXLINE), uname(NAMESIZE) integer filarg, gethdr integer afd, cmd, errcnt, size, tfd while (gethdr(afd, in, uname, size) ~= EOF) if (filarg(uname) == YES) { if (cmd == UPD) # add new one call addfil(uname, tfd, errcnt) call fskip(afd, size) # discard old one $@$ else { call putlin(in, tfd) call acopy(afd, tfd, size) $@$ return end # table - print table of archive contents subroutine table(aname) character aname(NAMESIZE), in(MAXLINE), lname(NAMESIZE) integer filarg, gethdr, open integer afd, size afd = open(aname, READ) if (afd == ERR) call cant(aname) while (gethdr(afd, in, lname, size) ~= EOF) { if (filarg(lname) == YES) call tprint(in) call fskip(afd, size) $@$ call notfnd return end # tprint - print table entry for one member subroutine tprint(buf) character buf(ARB) call putlin(buf, STDOUT) return end # update - update existing files, add new ones at end subroutine update(aname) character aname(NAMESIZE) integer create, getarg, open integer afd, i, tfd include carch # string tname "archtemp" integer tname(9) data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/ data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/ data tname(9)/EOS/ afd = open(aname, READWRITE) if (afd == ERR) # maybe it's a new one afd = create(aname, READWRITE) if (afd == ERR) call cant(aname) tfd = create(tname, READWRITE) if (tfd == ERR) call cant(tname) call replac(afd, tfd, UPD, errcnt) # update existing for (i = 1; i <= nfiles; i = i + 1) # add new ones if (fstat(i) == NO) { call addfil(fname(1, i), tfd, errcnt) fstat(i) = YES $@$ call close(afd) call close(tfd) if (errcnt == 0) call amove(tname, aname) else call remark("fatal errors - archive not altered.") call remove(tname) return end ========== programs from chapter 4 ========== # bubble - bubble sort v(1) ... v(n) increasing subroutine bubble(v, n) integer i, j, k, n, v(n) for (i = n; i > 1; i = i - 1) for (j = 1; j < i; j = j + 1) if (v(j) > v(j+1)) { # compare k = v(j) # exchange v(j) = v(j+1) # v(j+1) = k # $@$ return end # shell - Shell sort v(1)...v(n) increasing subroutine shell(v, n) integer gap, i, j, jg, k, n, v(n) for (gap = n/2; gap > 0; gap = gap/2) for (i = gap + 1; i <= n; i = i + 1) for (j = i - gap; j > 0; j = j - gap) { jg = j + gap if (v(j) <= v(jg)) # compare break k = v(j) # exchange v(j) = v(jg) # v(jg) = k # $@$ return end define(MERGEORDER,7) define(NAMESIZE,20) define(MAXTEXT,400) define(MAXPTR,1000) define(LOGPTR,20) # sort - sort text lines in memory character linbuf(MAXTEXT) integer gtext integer linptr(MAXPTR), nlines if (gtext(linptr, nlines, linbuf, STDIN) == EOF) { call shell(linptr, nlines, linbuf) call ptext(linptr, nlines, linbuf, STDOUT) $@$ else call error("too big to sort.") stop end # shell - Shell sort for character lines subroutine shell(linptr, nlines, linbuf) character linbuf(ARB) integer compar integer gap, i, ig, j, k, linptr(ARB), nlines for (gap = nlines/2; gap > 0; gap = gap/2) for (j = gap + 1; j <= nlines; j = j + 1) for (i = j - gap; i > 0; i = i - gap) { ig = i + gap if (compar(linptr(i), linptr(ig), linbuf) <= 0) break call exchan(linptr(i), linptr(ig), linbuf) $@$ return end # gtext - get text lines into linbuf integer function gtext(linptr, nlines, linbuf, infile) character linbuf(MAXTEXT) integer getlin integer infile, lbp, len, linptr(MAXPTR), nlines nlines = 0 lbp = 1 repeat { len = getlin(linbuf(lbp), infile) if (len == EOF) break nlines = nlines + 1 linptr(nlines) = lbp lbp = lbp + len + 1 # "1" = room for EOS $@$ until (lbp >= MAXTEXT-MAXLINE | nlines >= MAXPTR) gtext = len return end # ptext - output text lines from linbuf subroutine ptext(linptr, nlines, linbuf, outfil) character linbuf(MAXTEXT) integer i, j, linptr(MAXPTR), nlines, outfil for (i = 1; i <= nlines; i = i + 1) { j = linptr(i) call putlin(linbuf(j), outfil) $@$ return end # compar - compare linbuf(lp1) with linbuf(lp2) integer function compar(lp1, lp2, linbuf) character linbuf(ARB) integer i, j, lp1, lp2 i = lp1 j = lp2 while (linbuf(i) == linbuf(j)) { if (linbuf(i) == EOS) { compar = 0 return $@$ i = i + 1 j = j + 1 $@$ if (linbuf(i) < linbuf(j)) compar = -1 else compar = +1 return end # exchan - exchange linbuf(lp1) with linbuf(lp2) subroutine exchan(lp1, lp2, linbuf) character linbuf(ARB) integer k, lp1, lp2 k = lp1 lp1 = lp2 lp2 = k return end # quick - quicksort for character lines subroutine quick(linptr, nlines, linbuf) character linbuf(ARB) integer compar integer i, j, linptr(ARB), lv(LOGPTR), nlines, p, pivlin, uv(LOGPTR) lv(1) = 1 uv(1) = nlines p = 1 while (p > 0) if (lv(p) >= uv(p)) # only one element in this subset p = p - 1 # pop stack else { i = lv(p) - 1 j = uv(p) pivlin = linptr(j) # pivot line while (i < j) { for (i=i+1; compar(linptr(i), pivlin, linbuf) < 0; i=i+1) ; for (j = j - 1; j > i; j = j - 1) if (compar(linptr(j), pivlin, linbuf) <= 0) break if (i < j) # out of order pair call exchan(linptr(i), linptr(j), linbuf) $@$ j = uv(p) # move pivot to position i call exchan(linptr(i), linptr(j), linbuf) if (i-lv(p) < uv(p)-i) { # stack so shorter done first lv(p+1) = lv(p) uv(p+1) = i - 1 lv(p) = i + 1 $@$ else { lv(p+1) = i + 1 uv(p+1) = uv(p) uv(p) = i - 1 $@$ p = p + 1 # push onto stack $@$ return end # sort - external sort of text lines character linbuf(MAXTEXT), name(NAMESIZE) integer gtext, makfil, min, open integer infil(MERGEORDER), linptr(MAXPTR), nlines integer high, lim, low, outfil, t high = 0 repeat { # initial formation of runs t = gtext(linptr, nlines, linbuf, STDIN) call quick(linptr, nlines, linbuf) high = high + 1 outfil = makfil(high) call ptext(linptr, nlines, linbuf, outfil) call close(outfil) $@$ until (t == EOF) for (low = 1; low < high; low = low + MERGEORDER) { # merge lim = min(low+MERGEORDER-1, high) call gopen(infil, low, lim) high = high + 1 outfil = makfil(high) call merge(infil, lim-low+1, outfil) call close(outfil) call gremov(infil, low, lim) $@$ call gname(high, name) # final cleanup outfil = open(name, READ) call fcopy(outfil, STDOUT) call close(outfil) call remove(name) stop end # gname - make unique name for file id n subroutine gname(n, name) character name(NAMESIZE) integer itoc, length integer i, junk, n # string stemp "stemp" integer stemp(6) data stemp(1), stemp(2), stemp(3)/ LETS, LETT, LETE/ data stemp(4), stemp(5), stemp(6)/ LETM, LETP, EOS/ call scopy(stemp, 1, name, 1) i = length(stemp) + 1 junk = itoc(n, name(i), NAMESIZE-i) return end # makfil - make new file for number n integer function makfil(n) character name(NAMESIZE) integer create integer n call gname(n, name) makfil = create(name, READWRITE) if (makfil == ERR) call cant(name) return end # gopen - open group of files low ... lim subroutine gopen(infil, low, lim) character name(NAMESIZE) integer i, infil(MERGEORDER), lim, low integer open for (i = 1; i <= lim-low+1; i = i + 1) { call gname(low+i-1, name) infil(i) = open(name, READ) if (infil(i) == ERR) call cant(name) $@$ return end # gremov - remove group of files low ... lim subroutine gremov(infil, low, lim) character name(NAMESIZE) integer i, infil(MERGEORDER), lim, low for (i = 1; i <= lim-low+1; i = i + 1) { call close(infil(i)) call gname(low+i-1, name) call remove(name) $@$ return end define(MERGETEXT,900) # merge - merge infil(1) ... infil(nfiles) onto outfil subroutine merge(infil, nfiles, outfil) character linbuf(MERGETEXT) integer getlin integer i, inf, lbp, lp1, nf, nfiles, outfil integer infil(MERGEORDER), linptr(MERGEORDER) lbp = 1 nf = 0 for (i = 1; i <= nfiles; i = i + 1) # get one line from each file if (getlin(linbuf(lbp), infil(i)) ~= EOF) { nf = nf + 1 linptr(nf) = lbp lbp = lbp + MAXLINE # room for largest line $@$ call quick(linptr, nf, linbuf) # make initial heap while (nf > 0) { lp1 = linptr(1) call putlin(linbuf(lp1), outfil) inf = lp1 / MAXLINE + 1 # compute file index if (getlin(linbuf(lp1), infil(inf)) == EOF) { linptr(1) = linptr(nf) nf = nf - 1 $@$ call reheap(linptr, nf, linbuf) $@$ return end # reheap - propagate linbuf(linptr(1)) to proper place in heap subroutine reheap(linptr, nf, linbuf) character linbuf(MAXTEXT) integer compar integer i, j, nf, linptr(nf) for (i = 1; 2 * i <= nf; i = j) { j = 2 * i if (j < nf) # find smaller child if (compar(linptr(j), linptr(j+1), linbuf) > 0) j = j + 1 if (compar(linptr(i), linptr(j), linbuf) <= 0) break # proper position found call exchan(linptr(i), linptr(j), linbuf) # percolate $@$ return end ========== other routines from chapter 4 ========== # unique - strip adjacent duplicate lines character buf1(MAXLINE), buf2(MAXLINE) integer equal, getlin integer t t = getlin(buf1, STDIN) while (t ~= EOF) { call putlin(buf1, STDOUT) for (t = getlin(buf2, STDIN); t ~= EOF; t = getlin(buf2, STDIN)) if (equal(buf1, buf2) == NO) break if (t == EOF) break call putlin(buf2, STDOUT) for (t = getlin(buf1, STDIN); t ~= EOF; t = getlin(buf1, STDIN)) if (equal(buf1, buf2) == NO) break $@$ stop end define(FOLD,DOLLAR) # kwic - make keyword in context index character buf(MAXLINE) integer getlin while (getlin(buf, STDIN) ~= EOF) call putrot(buf, STDOUT) stop end # putrot - create lines with keyword at front subroutine putrot(buf, outfil) character type character buf(ARB), t integer i, outfil for (i = 1; buf(i) ~= NEWLINE; i = i + 1) { t = type(buf(i)) if (t == LETTER | t == DIGIT) { # alpha call rotate(buf, i, outfil) # token starts at "i" t = type(buf(i+1)) for ( ; t == LETTER | t == DIGIT; t = type(buf(i+1))) i = i + 1 $@$ $@$ return end # rotate - output rotated line subroutine rotate(buf, n, outfil) character buf(ARB) integer i, n, outfil for (i = n; buf(i) ~= NEWLINE; i = i + 1) call putch(buf(i), outfil) call putch(FOLD, outfil) for (i = 1; i < n; i = i + 1) call putch(buf(i), outfil) call putch(NEWLINE, outfil) return end # type - determine type of character character function type(c) character c integer index # string digits "0123456789" integer digits(11) # string lowalf "abcdefghijklmnopqrstuvwxyz" integer lowalf(27) # string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" integer upalf(27) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ data lowalf(01)/LETA/ data lowalf(02)/LETB/ data lowalf(03)/LETC/ data lowalf(04)/LETD/ data lowalf(05)/LETE/ data lowalf(06)/LETF/ data lowalf(07)/LETG/ data lowalf(08)/LETH/ data lowalf(09)/LETI/ data lowalf(10)/LETJ/ data lowalf(11)/LETK/ data lowalf(12)/LETL/ data lowalf(13)/LETM/ data lowalf(14)/LETN/ data lowalf(15)/LETO/ data lowalf(16)/LETP/ data lowalf(17)/LETQ/ data lowalf(18)/LETR/ data lowalf(19)/LETS/ data lowalf(20)/LETT/ data lowalf(21)/LETU/ data lowalf(22)/LETV/ data lowalf(23)/LETW/ data lowalf(24)/LETX/ data lowalf(25)/LETY/ data lowalf(26)/LETZ/ data lowalf(27)/EOS/ data upalf(01) /BIGA/ data upalf(02) /BIGB/ data upalf(03) /BIGC/ data upalf(04) /BIGD/ data upalf(05) /BIGE/ data upalf(06) /BIGF/ data upalf(07) /BIGG/ data upalf(08) /BIGH/ data upalf(09) /BIGI/ data upalf(10) /BIGJ/ data upalf(11) /BIGK/ data upalf(12) /BIGL/ data upalf(13) /BIGM/ data upalf(14) /BIGN/ data upalf(15) /BIGO/ data upalf(16) /BIGP/ data upalf(17) /BIGQ/ data upalf(18) /BIGR/ data upalf(19) /BIGS/ data upalf(20) /BIGT/ data upalf(21) /BIGU/ data upalf(22) /BIGV/ data upalf(23) /BIGW/ data upalf(24) /BIGX/ data upalf(25) /BIGY/ data upalf(26) /BIGZ/ data upalf(27) /EOS/ if (index(lowalf, c) > 0) type = LETTER else if (index(upalf, c) > 0) type = LETTER else if (index(digits, c) > 0) type = DIGIT else type = c return end define(FOLD,DOLLAR) define(MIDDLE,40) define(MAXOUT,80) # unrot - unrotate lines rotated by kwic character inbuf(MAXLINE), outbuf(MAXOUT) integer getlin, index integer i, j while (getlin(inbuf, STDIN) ~= EOF) { for (i = 1; i < MAXOUT; i = i + 1) # blank line outbuf(i) = BLANK j = MIDDLE for (i = 1; inbuf(i) ~= FOLD & inbuf(i) ~= NEWLINE; i = i + 1) { j = j + 1 # copy up to FOLD if (j >= MAXOUT - 1) j = 1 outbuf(j) = inbuf(i) $@$ if (inbuf(i) == FOLD) { # copy second half, j = MIDDLE # working backwards for (i = index(inbuf, NEWLINE) - 1; i > 0; i = i - 1) { if (inbuf(i) == FOLD) break j = j - 1 if (j <= 0) j = MAXOUT - 2 outbuf(j) = inbuf(i) $@$ $@$ for (i = MAXOUT - 2; i > 0; i = i - 1) if (outbuf(i) ~= BLANK) # delete trailing blanks break outbuf(i+1) = NEWLINE # terminate line properly outbuf(i+2) = EOS call putlin(outbuf, STDOUT) $@$ stop end ========== find program from chapter 5 ========== define(MAXARG,128) define(MAXPAT,128) define(COUNT,1) define(PREVCL,2) define(START,3) define(CLOSIZE,4) define(NOT,BANG) define(BOL,PERCENT) define(ANY,QMARK) define(EOL,DOLLAR) define(CLOSURE,STAR) define(CCL,LBRACK) define(CCLEND,RBRACK) define(NCCL,LETN) define(CHAR,LETA) define(ESCAPE,ATSIGN) # amatch (non-recursive) - look for match starting at lin(from) integer function amatch(lin, from, pat) character lin(MAXLINE), pat(MAXPAT) integer omatch, patsiz integer from, i, j, offset, stack stack = 0 offset = from # next unexamined input character for (j = 1; pat(j) ~= EOS; j = j + patsiz(pat, j)) if (pat(j) == CLOSURE) { # a closure entry stack = j j = j + CLOSIZE # step over CLOSURE for (i = offset; lin(i) ~= EOS; ) # match as many as if (omatch(lin, i, pat, j) == NO) # possible break pat(stack+COUNT) = i - offset pat(stack+START) = offset offset = i # character that made us fail $@$ else if (omatch(lin, offset, pat, j) == NO) { # non-closure for ( ; stack > 0; stack = pat(stack+PREVCL)) if (pat(stack+COUNT) > 0) break if (stack <= 0) { # stack is empty amatch = 0 # return failure return $@$ pat(stack+COUNT) = pat(stack+COUNT) - 1 j = stack + CLOSIZE offset = pat(stack+START) + pat(stack+COUNT) $@$ # else omatch succeeded amatch = offset return # success end # amatch with no metacharacters integer function amatch(lin, from, pat) character lin(MAXLINE), pat(MAXPAT) integer from, i, j i = from for (j = 1; pat(j) ~= EOS; j = j + 1) { if (lin(i) ~= pat(j)) { amatch = 0 return # with no match $@$ i = i + 1 $@$ amatch = i return # successfully end # amatch with some metacharacters integer function amatch(lin, from, pat) character lin(MAXLINE), pat(MAXPAT) integer omatch, patsiz integer from, i, j i = from for (j = 1; pat(j) ~= EOS; j = j + patsiz(pat, j)) if (omatch(lin, i, pat, j) == NO) { amatch = 0 return # with no match $@$ amatch = i return # successfully end # find - find patterns in text character arg(MAXARG), lin(MAXLINE), pat(MAXPAT) integer getarg, getlin, getpat, match if (getarg(1, arg, MAXARG) == EOF) call error("usage: find pattern.") if (getpat(arg, pat) == ERR) call error("illegal pattern.") while (getlin(lin, STDIN) ~= EOF) if (match(lin, pat) == YES) call putlin(lin, STDOUT) stop end # getccl - expand char class at arg(i) into pat(j) integer function getccl(arg, i, pat, j) character arg(MAXARG), pat(MAXPAT) integer addset integer i, j, jstart, junk i = i + 1 # skip over [ if (arg(i) == NOT) { junk = addset(NCCL, pat, j, MAXPAT) i = i + 1 $@$ else junk = addset(CCL, pat, j, MAXPAT) jstart = j junk = addset(0, pat, j, MAXPAT) # leave room for count call filset(CCLEND, arg, i, pat, j, MAXPAT) pat(jstart) = j - jstart - 1 if (arg(i) == CCLEND) getccl = OK else getccl = ERR return end # getpat - convert argument into pattern integer function getpat(arg, pat) integer arg(MAXARG), pat(MAXPAT) integer makpat getpat = makpat(arg, 1, EOS, pat) return end # locate - look for c in char class at pat(offset) integer function locate(c, pat, offset) character c, pat(MAXPAT) integer i, offset # size of class is at pat(offset), characters follow for (i = offset + pat(offset); i > offset; i = i - 1) if (c == pat(i)) { locate = YES return $@$ locate = NO return end # makpat - make pattern from arg(from), terminate at delim integer function makpat(arg, from, delim, pat) character esc character arg(MAXARG), delim, pat(MAXPAT) integer addset, getccl, stclos integer from, i, j, junk, lastcl, lastj, lj j = 1 # pat index lastj = 1 lastcl = 0 for (i = from; arg(i) ~= delim & arg(i) ~= EOS; i = i + 1) { lj = j if (arg(i) == ANY) junk = addset(ANY, pat, j, MAXPAT) else if (arg(i) == BOL & i == from) junk = addset(BOL, pat, j, MAXPAT) else if (arg(i) == EOL & arg(i + 1) == delim) junk = addset(EOL, pat, j, MAXPAT) else if (arg(i) == CCL) { if (getccl(arg, i, pat, j) == ERR) break $@$ else if (arg(i) == CLOSURE & i > from) { lj = lastj if (pat(lj)==BOL | pat(lj)==EOL | pat(lj)==CLOSURE) break lastcl = stclos(pat, j, lastj, lastcl) $@$ else { junk = addset(CHAR, pat, j, MAXPAT) junk = addset(esc(arg, i), pat, j, MAXPAT) $@$ lastj = lj $@$ if (arg(i) ~= delim) # terminated early makpat = ERR else if (addset(EOS, pat, j, MAXPAT) == NO) # no room makpat = ERR else makpat = i return end # match - find match anywhere on line integer function match(lin, pat) character lin(MAXLINE), pat(MAXPAT) integer amatch integer i for (i = 1; lin(i) ~= EOS; i = i + 1) if (amatch(lin, i, pat) > 0) { match = YES return $@$ match = NO return end # omatch - try to match a single pattern at pat(j) integer function omatch(lin, i, pat, j) character lin(MAXLINE), pat(MAXPAT) integer locate integer bump, i, j omatch = NO if (lin(i) == EOS) return bump = -1 if (pat(j) == CHAR) { if (lin(i) == pat(j + 1)) bump = 1 $@$ else if (pat(j) == BOL) { if (i == 1) bump = 0 $@$ else if (pat(j) == ANY) { if (lin(i) ~= NEWLINE) bump = 1 $@$ else if (pat(j) == EOL) { if (lin(i) == NEWLINE) bump = 0 $@$ else if (pat(j) == CCL) { if (locate(lin(i), pat, j + 1) == YES) bump = 1 $@$ else if (pat(j) == NCCL) { if (lin(i) ~= NEWLINE & locate(lin(i), pat, j + 1) == NO) bump = 1 $@$ else call error("in omatch: can't happen.") if (bump >= 0) { i = i + bump omatch = YES $@$ return end # patsiz - returns size of pattern entry at pat(n) integer function patsiz(pat, n) character pat(MAXPAT) integer n if (pat(n) == CHAR) patsiz = 2 else if (pat(n) == BOL | pat(n) == EOL | pat(n) == ANY) patsiz = 1 else if (pat(n) == CCL | pat(n) == NCCL) patsiz = pat(n + 1) + 2 else if (pat(n) == CLOSURE) # optional patsiz = CLOSIZE else call error("in patsiz: can't happen.") return end # stclos - insert closure entry at pat(j) integer function stclos(pat, j, lastj, lastcl) character pat(MAXPAT) integer addset integer j, jp, jt, junk, lastcl, lastj for (jp = j - 1; jp >= lastj; jp = jp - 1) { # make a hole jt = jp + CLOSIZE junk = addset(pat(jp), pat, jt, MAXPAT) $@$ j = j + CLOSIZE stclos = lastj junk = addset(CLOSURE, pat, lastj, MAXPAT) # put closure in it junk = addset(0, pat, lastj, MAXPAT) # COUNT junk = addset(lastcl, pat, lastj, MAXPAT) # PREVCL junk = addset(0, pat, lastj, MAXPAT) # START return end ========== change program from chapter 5 ========== define(MAXPAT,128) define(MAXARG,128) define(ESCAPE,ATSIGN) define(DITTO,(-3)) # catsub - add replacement text to end of new subroutine catsub(lin, from, to, sub, new, k, maxnew) integer addset integer from, i, j, junk, k, maxnew, to character lin(MAXLINE), new(maxnew), sub(MAXPAT) for (i = 1; sub(i) ~= EOS; i = i + 1) if (sub(i) == DITTO) for (j = from; j < to; j = j + 1) junk = addset(lin(j), new, k, maxnew) else junk = addset(sub(i), new, k, maxnew) return end # change - change "from" into "to" character lin(MAXLINE), new(MAXLINE), pat(MAXPAT), sub(MAXPAT) character arg(MAXARG) integer addset, amatch, getarg, getlin, getpat, getsub integer i, junk, k, lastm, m if (getarg(1, arg, MAXARG) == EOF) call error("usage: change from to.") if (getpat(arg, pat) == ERR) call error("illegal from pattern.") if (getarg(2, arg, MAXARG) == EOF) arg(1) = EOS if (getsub(arg, sub) == ERR) call error("illegal to.") while (getlin(lin, STDIN) ~= EOF) { k = 1 lastm = 0 for ( i =1; lin(i) ~= EOS; ) { m = amatch(lin, i, pat) if (m > 0 & lastm ~= m) { # replace matched text call catsub(lin, i, m, sub, new, k, MAXLINE) lastm = m $@$ if (m == 0 | m == i) { # no match or null match junk = addset(lin(i), new, k, MAXLINE) i = i + 1 $@$ else # skip matched text i = m $@$ if (addset(EOS, new, k, MAXLINE) == NO) { k = MAXLINE junk = addset(EOS, new, k, MAXLINE) call remark("line truncated:.") call putlin(new, ERROUT) call putch(NEWLINE, ERROUT) $@$ call putlin(new, STDOUT) $@$ stop end # getsub - get substitution pattern into sub integer function getsub(arg, sub) character arg(MAXARG), sub(MAXPAT) integer maksub getsub = maksub(arg, 1, EOS, sub) return end # maksub - make substitution string in sub integer function maksub(arg, from, delim, sub) character esc character arg(MAXARG), delim, sub(MAXPAT) integer addset integer from, i, j, junk j = 1 for (i = from; arg(i) ~= delim & arg(i) ~= EOS; i = i + 1) if (arg(i) == AND) junk = addset(DITTO, sub, j, MAXPAT) else junk = addset(esc(arg, i), sub, j, MAXPAT) if (arg(i) ~= delim) # missing delimiter maksub = ERR else if (addset(EOS, sub, j, MAXPAT) == NO) # no room maksub = ERR else maksub = i return end ========== edit program from chapter 6 ========== define(MAXPAT,128) define(andif,if) define(GLOBAL,LETG) define(PRINT,LETP) define(MARKED,LETY) define(NOMARK,LETN) define(FORWARD,0) define(BACKWARD,-1) define(EXCLUDE,LETX) define(APPENDCOM,LETA) define(CHANGE,LETC) define(DELCOM,LETD) define(ENTER,LETE) define(PRINTFIL,LETF) define(READCOM,LETR) define(WRITECOM,LETW) define(INSERT,LETI) define(PRINTCUR,EQUALS) define(MOVECOM,LETM) define(QUIT,LETQ) define(SUBSTITUTE,LETS) define(CURLINE,PERIOD) define(LASTLINE,DOLLAR) define(SCAN,SLASH) define(BACKSCAN,BACKSLASH) define(NOSTATUS,1) define(LINE0,1) define(PREV,0) define(NEXT,1) define(MARK,2) define(TEXT,3) define(MAXBUF,1000) common /cbuf/ buf(MAXBUF), lastbf character buf # buffer for pointers plus text integer lastbf # last element used in buf common /clines/ line1, line2, nlines, curln, lastln integer line1 # first line number integer line2 # second line number integer nlines # number of line numbers specified integer curln # current line: value of dot integer lastln # last line: value of $ common /cpat/ pat(MAXPAT) character pat # pattern common /ctxt/ txt(MAXLINE) character txt # text line for matching and output common /cfile/ savfil(MAXLINE) character savfil # remembered file name # append - append lines after "line" integer function append(line, glob) character lin(MAXLINE) integer getlin, inject integer line, glob include clines if (glob == YES) append = ERR else { curln = line for (append = NOSTATUS; append == NOSTATUS; ) if (getlin(lin, STDIN) == EOF) append = EOF else if (lin(1) == PERIOD & lin(2) == NEWLINE) append = OK else if (inject(lin) == ERR) append = ERR $@$ return end # ckglob - if global prefix, mark lines to be affected integer function ckglob(lin, i, status) character lin(MAXLINE) integer defalt, getind, gettxt, match, nextln, optpat integer gflag, i, k, line, status include cbuf include clines include cpat include ctxt if (lin(i) ~= GLOBAL & lin(i) ~= EXCLUDE) status = EOF else { if (lin(i) == GLOBAL) gflag = YES else gflag = NO i = i + 1 if (optpat(lin, i) == ERR | defalt(1, lastln, status) == ERR) status = ERR else { i = i + 1 for (line = line1; line <= line2; line = line + 1) { k = gettxt(line) if (match(txt, pat) == gflag) buf(k+MARK) = YES else buf(k+MARK) = NO $@$ for (line=nextln(line2); line~=line1; line=nextln(line)) { k = getind(line) buf(k+MARK) = NO $@$ status = OK $@$ $@$ ckglob = status return end # ckp - check for "p" after command integer function ckp(lin, i, pflag, status) character lin(MAXLINE) integer i, j, pflag, status j = i if (lin(j) == PRINT) { j = j + 1 pflag = YES $@$ else pflag = NO if (lin(j) == NEWLINE) status = OK else status = ERR ckp = status return end # clrbuf (in memory) - initialize for new file subroutine clrbuf return # nothing to do end # defalt - set defaulted line numbers integer function defalt(def1, def2, status) integer def1, def2, status include clines if (nlines == 0) { line1 = def1 line2 = def2 $@$ if (line1 > line2 | line1 <= 0) status = ERR else status = OK defalt = status return end # delete - delete lines from through to integer function delete(from, to, status) integer getind, nextln, prevln integer from, k1, k2, status, to include clines if (from <= 0) status = ERR else { k1 = getind(prevln(from)) k2 = getind(nextln(to)) lastln = lastln - (to - from + 1) curln = prevln(from) call relink(k1, k2, k1, k2) status = OK $@$ delete = status return end # docmd - handle all commands except globals integer function docmd(lin, i, glob, status) character file(MAXLINE), lin(MAXLINE), sub(MAXPAT) integer append, delete, doprnt, doread, dowrit, move, subst integer ckp, defalt, getfn, getone, getrhs, nextln, optpat, prevln integer gflag, glob, i, line3, pflag, status include cfile include clines include cpat pflag = NO # may be set by d, m, s status = ERR if (lin(i) == APPENDCOM) { if (lin(i + 1) == NEWLINE) status = append(line2, glob) $@$ else if (lin(i) == CHANGE) { if (lin(i + 1) == NEWLINE) andif (defalt(curln, curln, status) == OK) andif (delete(line1, line2, status) == OK) status = append(prevln(line1), glob) $@$ else if (lin(i) == DELCOM) { if (ckp(lin, i + 1, pflag, status) == OK) andif (defalt(curln, curln, status) == OK) andif (delete(line1, line2, status) == OK) andif (nextln(curln) ~= 0) curln = nextln(curln) $@$ else if (lin(i) == INSERT) { if (lin(i + 1) == NEWLINE) status = append(prevln(line2), glob) $@$ else if (lin(i) == PRINTCUR) { if (ckp(lin, i + 1, pflag, status) == OK) { call putdec(line2, 1) call putc(NEWLINE) $@$ $@$ else if (lin(i) == MOVECOM) { i = i + 1 if (getone(lin, i, line3, status) == EOF) status = ERR if (status == OK) andif (ckp(lin, i, pflag, status) == OK) andif (defalt(curln, curln, status) == OK) status = move(line3) $@$ else if (lin(i) == SUBSTITUTE) { i = i + 1 if (optpat(lin, i) == OK) andif (getrhs(lin, i, sub, gflag) == OK) andif (ckp(lin, i + 1, pflag, status) == OK) andif (defalt(curln, curln, status) == OK) status = subst(sub, gflag) $@$ else if (lin(i) == ENTER) { if (nlines == 0) andif (getfn(lin, i, file) == OK) { call scopy(file, 1, savfil, 1) call clrbuf call setbuf status = doread(0, file) $@$ $@$ else if (lin(i) == PRINTFIL) { if (nlines == 0) andif (getfn(lin, i, file) == OK) { call scopy(file, 1, savfil, 1) call putlin(savfil, STDOUT) call putc(NEWLINE) status = OK $@$ $@$ else if (lin(i) == READCOM) { if (getfn(lin, i, file) == OK) status = doread(line2, file) $@$ else if (lin(i) == WRITECOM) { if (getfn(lin, i, file) == OK) andif (defalt(1, lastln, status) == OK) status = dowrit(line1, line2, file) $@$ else if (lin(i) == PRINT) { if (lin(i + 1) == NEWLINE) andif (defalt(curln, curln, status) == OK) status = doprnt(line1, line2) $@$ else if (lin(i) == NEWLINE) { if (nlines == 0) line2 = nextln(curln) status = doprnt(line2, line2) $@$ else if (lin(i) == QUIT) { if (lin(i + 1) == NEWLINE & nlines == 0 & glob == NO) status = EOF $@$ # else status is ERR if (status == OK & pflag == YES) status = doprnt(curln, curln) docmd = status return end # doglob - do command at lin(i) on all marked lines integer function doglob(lin, i, cursav, status) character lin(MAXLINE) integer docmd, getind, getlst, nextln integer count, cursav, i, istart, k, line, status include cbuf include clines status = OK count = 0 line = line1 istart = i repeat { k = getind(line) if (buf(k+MARK) == YES) { buf(k+MARK) = NO curln = line cursav = curln i = istart if (getlst(lin, i, status) == OK) andif (docmd(lin, i, YES, status) == OK) count = 0 $@$ else { line = nextln(line) count = count + 1 $@$ $@$ until (count > lastln | status ~= OK) doglob = status return end # doprnt - print lines from through to integer function doprnt(from, to) integer gettxt integer from, i, j, to include clines include ctxt if (from <= 0) doprnt = ERR else { for (i = from; i <= to; i = i + 1) { j = gettxt(i) call putlin(txt, STDOUT) $@$ curln = to doprnt = OK $@$ return end # doread - read "file" after "line" integer function doread(line, file) character file(MAXLINE), lin(MAXLINE) integer getlin, inject, open integer count, fd, line include clines fd = open(file, READ) if (fd == ERR) doread = ERR else { curln = line doread = OK for (count = 0; getlin(lin, fd) ~= EOF; count = count + 1) { doread = inject(lin) if (doread == ERR) break $@$ call close(fd) call putdec(count, 1) call putc(NEWLINE) $@$ return end # dowrit - write "from" through "to" into file integer function dowrit(from, to, file) character file(MAXLINE) integer create, gettxt integer fd, from, k, line, to include ctxt fd = create(file, WRITE) if (fd == ERR) dowrit = ERR else { for (line = from; line <= to; line = line + 1) { k = gettxt(line) call putlin(txt, fd) $@$ call close(fd) call putdec(to-from+1, 1) call putc(NEWLINE) dowrit = OK $@$ return end # edit - main routine character lin(MAXLINE) integer ckglob, docmd, doglob, doread, getarg, getlin, getlst integer cursav, i, status include cfile include clines include cpat call setbuf pat(1) = EOS savfil(1) = EOS if (getarg(1, savfil, MAXLINE) ~= EOF) if (doread(0, savfil) == ERR) call remark("?.") while (getlin(lin, STDIN) ~= EOF) { i = 1 cursav = curln if (getlst(lin, i, status) == OK) { if (ckglob(lin, i, status) == OK) status = doglob(lin, i, cursav, status) else if (status ~= ERR) status = docmd(lin, i, NO, status) # else error, do nothing $@$ if (status == ERR) { call remark("?.") curln = cursav $@$ else if (status == EOF) break # else OK, loop $@$ call clrbuf stop end # getfn - get file name from lin(i)... integer function getfn(lin, i, file) character lin(MAXLINE), file(MAXLINE) integer i, j, k include cfile getfn = ERR if (lin(i + 1) == BLANK) { j = i + 2 # get new file name call skipbl(lin, j) for (k = 1; lin(j) ~= NEWLINE; k = k + 1) { file(k) = lin(j) j = j + 1 $@$ file(k) = EOS if (k > 1) getfn = OK $@$ else if (lin(i + 1) == NEWLINE & savfil(1) ~= EOS) { call scopy(savfil, 1, file, 1) # or old name getfn = OK $@$ # else error if (getfn == OK & savfil(1) == EOS) call scopy(file, 1, savfil, 1) # save if no old one return end # getind - locate line index in buffer integer function getind(line) integer j, k, line include cbuf k = LINE0 for (j = 0; j < line; j = j + 1) k = buf(k + NEXT) getind = k return end # getlst - collect line numbers (if any) at lin(i), increment i integer function getlst(lin, i, status) character lin(MAXLINE) integer getone, min integer i, num, status include clines line2 = 0 for (nlines = 0; getone(lin, i, num, status) == OK; ) { line1 = line2 line2 = num nlines = nlines + 1 if (lin(i) ~= COMMA & lin(i) ~= SEMICOL) break if (lin(i) == SEMICOL) curln = num i = i + 1 $@$ nlines = min(nlines, 2) if (nlines == 0) line2 = curln if (nlines <= 1) line1 = line2 if (status ~= ERR) status = OK getlst = status return end # getnum - convert one term to line number integer function getnum(lin, i, pnum, status) character lin(MAXLINE) integer ctoi, index, optpat, ptscan integer i, pnum, status include clines include cpat # string digits "0123456789" integer digits(11) data digits(01)/DIG0/ data digits(02)/DIG1/ data digits(03)/DIG2/ data digits(04)/DIG3/ data digits(05)/DIG4/ data digits(06)/DIG5/ data digits(07)/DIG6/ data digits(08)/DIG7/ data digits(09)/DIG8/ data digits(10)/DIG9/ data digits(11)/EOS/ getnum = OK if (index(digits, lin(i)) > 0) { pnum = ctoi(lin, i) i = i - 1 # move back; to be advanced at the end $@$ else if (lin(i) == CURLINE) pnum = curln else if (lin(i) == LASTLINE) pnum = lastln else if (lin(i) == SCAN | lin(i) == BACKSCAN) { if (optpat(lin, i) == ERR) # build the pattern getnum = ERR else if (lin(i) == SCAN) getnum = ptscan(FORWARD, pnum) else getnum = ptscan(BACKWARD, pnum) $@$ else getnum = EOF if (getnum == OK) i = i + 1 # point at next character to be examined status = getnum return end # getone - evaluate one line number expression integer function getone(lin, i, num, status) character lin(MAXLINE) integer getnum integer i, istart, mul, num, pnum, status include clines istart = i num = 0 call skipbl(lin, i) if (getnum(lin, i, num, status) == OK) # first term repeat { # + or - terms call skipbl(lin, i) if (lin(i) ~= PLUS & lin(i) ~= MINUS) { status = EOF break $@$ if (lin(i) == PLUS) mul = +1 else mul = -1 i = i + 1 call skipbl(lin, i) if (getnum(lin, i, pnum, status) == OK) num = num + mul * pnum if (status == EOF) status = ERR $@$ until (status ~= OK) if (num < 0 | num > lastln) status = ERR if (status == ERR) getone = ERR else if (i <= istart) getone = EOF else getone = OK status = getone return end # getrhs - get substitution string for "s" command integer function getrhs(lin, i, sub, gflag) character lin(MAXLINE), sub(MAXPAT) integer maksub integer gflag, i getrhs = ERR if (lin(i) == EOS) return if (lin(i + 1) == EOS) return i = maksub(lin, i + 1, lin(i), sub) if (i == ERR) return if (lin(i + 1) == GLOBAL) { i = i + 1 gflag = YES $@$ else gflag = NO getrhs = OK return end # gettxt (in memory) - locate text for line and make available integer function gettxt(line) integer getind integer line include cbuf include ctxt gettxt = getind(line) call scopy(buf, gettxt + TEXT, txt, 1) return end # inject (in memory) - put text from lin after curln integer function inject(lin) character lin(MAXLINE) integer addset, getind, nextln integer i, junk, k1, k2, k3 include cbuf include clines for (i = 1; lin(i) ~= EOS; ) { k3 = lastbf lastbf = lastbf + TEXT while (lin(i) ~= EOS) { junk = addset(lin(i), buf, lastbf, MAXBUF) i = i + 1 if (lin(i - 1) == NEWLINE) break $@$ if (addset(EOS, buf, lastbf, MAXBUF) == NO) { inject = ERR break $@$ k1 = getind(curln) k2 = getind(nextln(curln)) call relink(k1, k3, k3, k2) call relink(k3, k2, k1, k3) curln = curln + 1 lastln = lastln + 1 inject = OK $@$ return end # move - move line1 through line2 after line3 integer function move(line3) integer getind, nextln, prevln integer k0, k1, k2, k3, k4, k5, line3 include clines if (line1 <= 0 | (line1 <= line3 & line3 <= line2)) move = ERR else { k0 = getind(prevln(line1)) k3 = getind(nextln(line2)) k1 = getind(line1) k2 = getind(line2) call relink(k0, k3, k0, k3) if (line3 > line1) { curln = line3 line3 = line3 - (line2 - line1 + 1) $@$ else curln = line3 + (line2 - line1 + 1) k4 = getind(line3) k5 = getind(nextln(line3)) call relink(k4, k1, k2, k5) call relink(k2, k5, k4, k1) move = OK $@$ return end # nextln - get line after "line" integer function nextln(line) integer line include clines nextln = line + 1 if (nextln > lastln) nextln = 0 return end # optpat - make pattern if specified at lin(i) integer function optpat(lin, i) character lin(MAXLINE) integer makpat integer i include cpat if (lin(i) == EOS) i = ERR else if (lin(i + 1) == EOS) i = ERR else if (lin(i + 1) == lin(i)) # repeated delimiter i = i + 1 # leave existing pattern alone else i = makpat(lin, i + 1, lin(i), pat) if (pat(1) == EOS) i = ERR if (i == ERR) { pat(1) = EOS optpat = ERR $@$ else optpat = OK return end # prevln - get line before "line" integer function prevln(line) integer line include clines prevln = line - 1 if (prevln < 0) prevln = lastln return end # ptscan - scan for next occurrence of pattern integer function ptscan(way, num) integer gettxt, match, nextln, prevln integer k, num, way include clines include cpat include ctxt num = curln repeat { if (way == FORWARD) num = nextln(num) else num = prevln(num) k = gettxt(num) if (match(txt, pat) == YES) { ptscan = OK return $@$ $@$ until (num == curln) ptscan = ERR return end # relink - rewrite two half links subroutine relink(a, x, y, b) integer a, b, x, y include cbuf buf(x + PREV) = a buf(y + NEXT) = b return end # setbuf (in memory) - initialize line storage buffer subroutine setbuf integer addset integer junk include cbuf include clines call relink(LINE0, LINE0, LINE0, LINE0) lastbf = LINE0 + TEXT junk = addset(EOS, buf, lastbf, MAXBUF) curln = 0 lastln = 0 return end # skipbl - skip blanks and tabs at lin(i)... subroutine skipbl(lin, i) character lin(ARB) integer i while (lin(i) == BLANK | lin(i) == TAB) i = i + 1 return end # subst - substitute "sub" for occurrences of pattern integer function subst(sub, gflag) character new(MAXLINE), sub(MAXPAT) integer addset, amatch, gettxt, inject integer gflag, j, junk, k, lastm, line, m, status, subbed include clines include cpat include ctxt subst = ERR if (line1 <= 0) return for (line = line1; line <= line2; line = line + 1) { j = 1 subbed = NO junk = gettxt(line) lastm = 0 for (k = 1; txt(k) ~= EOS; ) { if (gflag == YES | subbed == NO) m = amatch(txt, k, pat) else m = 0 if (m > 0 & lastm ~= m) { # replace matched text subbed = YES call catsub(txt, k, m, sub, new, j, MAXLINE) lastm = m $@$ if (m == 0 | m == k) { # no match or null match junk = addset(txt(k), new, j, MAXLINE) k = k + 1 $@$ else # skip matched text k = m $@$ if (subbed == YES) { if (addset(EOS, new, j, MAXLINE) == NO) { subst = ERR break $@$ call delete(line, line, status) # remembers dot subst = inject(new) if (subst == ERR) break subst = OK $@$ $@$ return end ========== file primitives for scratch file editor ========== define(PREV,0) define(NEXT,1) define(MARK,2) define(SEEKADR,3) define(LENG,4) define(BUFENT,5) define(MAXBUF,1000) define(LINE0,1) common /cbuf/ buf(MAXBUF), lastbf character buf # structure of pointers for all lines: # buf(k+0) PREV previous line # buf(k+1) NEXT next line # buf(k+2) MARK mark for global commands # buf(k+3) SEEKADR where line is on scratch file # buf(k+4) LENG length on scratch integer lastbf # last pointer used in buf common /cscrat/ scr, scrend integer scr # scratch file id integer scrend # end of info on scratch file # clrbuf (scratch file) - dispose of scratch file subroutine clrbuf include cscrat # string scrfil "scratch" integer scrfil(8) data scrfil(1)/LETS/ data scrfil(2)/LETC/ data scrfil(3)/LETR/ data scrfil(4)/LETA/ data scrfil(5)/LETT/ data scrfil(6)/LETC/ data scrfil(7)/LETH/ data scrfil(8)/EOS/ call close(scr) call remove(scrfil) return end # gettxt (scratch file) - locate text for line, copy to txt integer function gettxt(line) integer getbuf, getind integer j, k, line include cbuf include cscrat include ctxt k = getind(line) call seek(buf(k + SEEKADR), scr) call readf(txt, buf(k + LENG), scr) j = buf(k + LENG) + 1 txt(j) = EOS gettxt = k return end # inject (scratch file) - insert lin after curln, write scratch integer function inject(lin) character lin(MAXLINE) integer getind, maklin, nextln integer i, k1, k2, k3 include clines for (i = 1; lin(i) ~= EOS; ) { i = maklin(lin, i, k3) if (i == ERR) { inject = ERR break $@$ k1 = getind(curln) k2 = getind(nextln(curln)) call relink(k1, k3, k3, k2) call relink(k3, k2, k1, k3) curln = curln + 1 lastln = lastln + 1 inject = OK $@$ return end # maklin (scratch file) - make new line entry, copy text to scratch integer function maklin(lin, i, newind) character lin(MAXLINE) integer addset, length integer i, j, junk, newind, txtend include cbuf include cscrat include ctxt maklin = ERR if (lastbf + BUFENT > MAXBUF) return # no room for new line entry txtend = 1 for (j = i; lin(j) ~= EOS; ) { junk = addset(lin(j), txt, txtend, MAXLINE) j = j + 1 if (lin(j - 1) == NEWLINE) break $@$ if (addset(EOS, txt, txtend, MAXLINE) == NO) return call seek(scrend, scr) # add line to end of scratch file buf(lastbf + SEEKADR) = scrend buf(lastbf + LENG) = length(txt) call putlin(txt, scr) scrend = scrend + buf(lastbf + LENG) buf(lastbf + MARK) = NO newind = lastbf lastbf = lastbf + BUFENT maklin = j # next character to be examined in lin return end # setbuf (scratch file) - create scratch file, set up line 0 subroutine setbuf integer create integer k include cbuf include clines include cscrat # string scrfil "scratch" integer scrfil(8) # string null "" integer null(1) data scrfil(1)/LETS/ data scrfil(2)/LETC/ data scrfil(3)/LETR/ data scrfil(4)/LETA/ data scrfil(5)/LETT/ data scrfil(6)/LETC/ data scrfil(7)/LETH/ data scrfil(8)/EOS/ data null(1) /EOS/ scr = create(scrfil, READWRITE) if (scr == ERR) call cant(scrfil) scrend = 0 lastbf = LINE0 call maklin(null, 1, k) # create empty line 0 call relink(k, k, k, k) # establish initial linked list curln = 0 lastln = 0 return end ========== text formatter of chapter 7 ========== define(INSIZE,300) define(MAXOUT,300) define(COMMAND,PERIOD) define(PAGENUM,SHARP) define(PAGEWIDTH,60) define(PAGELEN,66) define(UNKNOWN,0) define(FI,1) define(NF,2) define(BR,3) define(LS,4) define(BP,5) define(SP,6) define(IN,7) define(RM,8) define(TI,9) define(CE,10) define(UL,11) define(HE,12) define(FO,13) define(PL,14) define(HUGE,1000) common /cout/ outp, outw, outwds, outbuf(MAXOUT) integer outp # last char position in outbuf; init = 0 integer outw # width of text currently in outbuf; init = 0 integer outwds # number of words in outbuf; init = 0 character outbuf # lines to be filled collect here common /cpage/ curpag,newpag,lineno,plval,m1val,m2val,m3val,m4val, bottom, header(MAXLINE), footer(MAXLINE) integer curpag # current output page number; init = 0 integer newpag # next output page number; init = 1 integer lineno # next line to be printed; init = 0 integer plval # page length in lines; init = PAGELEN = 66 integer m1val # margin before and including header integer m2val # margin after header integer m3val # margin after last text line integer m4val # bottom margin, including footer integer bottom # last live line on page, = plval-m3val-m4val character header # top of page title; init = NEWLINE character footer # bottom of page title; init = NEWLINE common /cparam/ fill, lsval, inval, rmval, tival, ceval, ulval integer fill # fill if YES; init = YES integer lsval # current line spacing; init = 1 integer inval # current indent; >= 0; init = 0 integer rmval # current right margin; init = PAGEWIDTH = 60 integer tival # current temporary indent; init = 0 integer ceval # number of lines to center; init = 0 integer ulval # number of lines to underline; init = 0 # brk - end current filled line subroutine brk include cout if (outp > 0) { outbuf(outp) = NEWLINE outbuf(outp+1) = EOS call put(outbuf) $@$ outp = 0 outw = 0 outwds = 0 return end # center - center a line by setting tival subroutine center(buf) character buf(ARB) integer max, width include cparam tival = max((rmval+tival-width(buf))/2, 0) return end # comand - perform formatting command subroutine comand(buf) character buf(MAXLINE) integer comtyp, getval, max integer argtyp, ct, spval, val include cpage include cparam ct = comtyp(buf) if (ct == UNKNOWN) # ignore unknown commands return val = getval(buf, argtyp) if (ct == FI) { call brk fill = YES $@$ else if (ct == NF) { call brk fill = NO $@$ else if (ct == BR) call brk else if (ct == LS) call set(lsval, val, argtyp, 1, 1, HUGE) else if (ct == CE) { call brk call set(ceval, val, argtyp, 1, 0, HUGE) $@$ else if (ct == UL) call set(ulval, val, argtyp, 0, 1, HUGE) else if (ct == HE) call gettl(buf, header) else if (ct == FO) call gettl(buf, footer) else if (ct == BP) { if (lineno > 0) call space(HUGE) call set(curpag, val, argtyp, curpag+1, -HUGE, HUGE) newpag = curpag $@$ else if (ct == SP) { call set(spval, val, argtyp, 1, 0, HUGE) call space(spval) $@$ else if (ct == IN) { call set(inval, val, argtyp, 0, 0, rmval-1) tival = inval $@$ else if (ct == RM) call set(rmval, val, argtyp, PAGEWIDTH, tival+1, HUGE) else if (ct == TI) { call brk call set(tival, val, argtyp, 0, 0, rmval) $@$ else if (ct == PL) { call set(plval, val, argtyp, PAGELEN, m1val+m2val+m3val+m4val+1, HUGE) bottom = plval - m3val - m4val $@$ return end # comtyp - decode command type integer function comtyp(buf) character buf(MAXLINE) if (buf(2) == LETF & buf(3) == LETI) comtyp = FI else if (buf(2) == LETN & buf(3) == LETF) comtyp = NF else if (buf(2) == LETB & buf(3) == LETR) comtyp = BR else if (buf(2) == LETL & buf(3) == LETS) comtyp = LS else if (buf(2) == LETB & buf(3) == LETP) comtyp = BP else if (buf(2) == LETS & buf(3) == LETP) comtyp = SP else if (buf(2) == LETI & buf(3) == LETN) comtyp = IN else if (buf(2) == LETR & buf(3) == LETM) comtyp = RM else if (buf(2) == LETT & buf(3) == LETI) comtyp = TI else if (buf(2) == LETC & buf(3) == LETE) comtyp = CE else if (buf(2) == LETU & buf(3) == LETL) comtyp = UL else if (buf(2) == LETH & buf(3) == LETE) comtyp = HE else if (buf(2) == LETF & buf(3) == LETO) comtyp = FO else if (buf(2) == LETP & buf(3) == LETL) comtyp = PL else comtyp = UNKNOWN return end # format - text formatter main program (final version) character inbuf(INSIZE) integer getlin include cpage call init while (getlin(inbuf, STDIN) ~= EOF) if (inbuf(1) == COMMAND) # it's a command call comand(inbuf) else # it's text call text(inbuf) if (lineno > 0) call space(HUGE) # flush last output stop end # gettl - copy title from buf to ttl subroutine gettl(buf, ttl) character buf(MAXLINE), ttl(MAXLINE) integer i i = 1 # skip command name while (buf(i) ~= BLANK & buf(i) ~= TAB & buf(i) ~= NEWLINE) i = i + 1 call skipbl(buf, i) # find argument if (buf(i) == SQUOTE | buf(i) == DQUOTE) # strip quote if found i = i + 1 call scopy(buf, i, ttl, 1) return end # getval - evaluate optional numeric argument integer function getval(buf, argtyp) character buf(MAXLINE) integer ctoi integer argtyp, i i = 1 # skip command name while (buf(i) ~= BLANK & buf(i) ~= TAB & buf(i) ~= NEWLINE) i = i + 1 call skipbl(buf, i) # find argument argtyp = buf(i) if (argtyp == PLUS | argtyp == MINUS) i = i + 1 getval = ctoi(buf, i) return end # getwrd - get non-blank word from in(i) into out, increment i integer function getwrd(in, i, out) integer in(MAXLINE), out(MAXLINE) integer i, j while (in(i) == BLANK | in(i) == TAB) i = i + 1 j = 1 while (in(i)~=EOS & in(i)~=BLANK & in(i)~=TAB & in(i)~=NEWLINE) { out(j) = in(i) i = i + 1 j = j + 1 $@$ out(j) = EOS getwrd = j - 1 return end # init - set parameters to default values subroutine init include cparam include cpage include cout inval = 0 rmval = PAGEWIDTH tival = 0 lsval = 1 fill = YES ceval = 0 ulval = 0 lineno = 0 curpag = 0 newpag = 1 plval = PAGELEN m1val = 3; m2val = 2; m3val = 2; m4val = 3 bottom = plval - m3val - m4val header(1) = NEWLINE; header(2) = EOS # initial titles footer(1) = NEWLINE; footer(2) = EOS outp = 0 outw = 0 outwds = 0 return end # leadbl - delete leading blanks, set tival subroutine leadbl(buf) character buf(MAXLINE) integer max integer i, j include cparam call brk for (i = 1; buf(i) == BLANK; i = i + 1) # find 1st non-blank ; if (buf(i) ~= NEWLINE) tival = i - 1 for (j = 1; buf(i) ~= EOS; j = j + 1) { # move line to left buf(j) = buf(i) i = i + 1 $@$ buf(j) = EOS return end # pfoot - put out page footer subroutine pfoot include cpage call skip(m3val) if (m4val > 0) { call puttl(footer, curpag) call skip(m4val-1) $@$ return end # phead - put out page header subroutine phead include cpage curpag = newpag newpag = newpag + 1 if (m1val > 0) { call skip(m1val-1) call puttl(header, curpag) $@$ call skip(m2val) lineno = m1val + m2val + 1 return end # put - put out line with proper spacing and indenting subroutine put(buf) character buf(MAXLINE) integer min integer i include cpage include cparam if (lineno == 0 | lineno > bottom) call phead for (i = 1; i <= tival; i = i + 1) # indenting call putc(BLANK) tival = inval call putlin(buf, STDOUT) call skip(min(lsval-1, bottom-lineno)) lineno = lineno + lsval if (lineno > bottom) call pfoot return end # puttl - put out title line with optional page number subroutine puttl(buf, pageno) character buf(MAXLINE) integer pageno integer i for (i = 1; buf(i) ~= EOS; i = i + 1) if (buf(i) == PAGENUM) call putdec(pageno, 1) else call putc(buf(i)) return end # putwrd - put a word in outbuf; includes margin justification subroutine putwrd(wrdbuf) character wrdbuf(INSIZE) integer length, width integer last, llval, nextra, w include cout include cparam w = width(wrdbuf) last = length(wrdbuf) + outp + 1 # new end of outbuf llval = rmval - tival if (outp > 0 & (outw+w > llval | last >= MAXOUT)) { # too big last = last - outp # remember end of wrdbuf nextra = llval - outw + 1 call spread(outbuf, outp, nextra, outwds) if (nextra > 0 & outwds > 1) outp = outp + nextra call brk # flush previous line $@$ call scopy(wrdbuf, 1, outbuf, outp+1) outp = last outbuf(outp) = BLANK # blank between words outw = outw + w + 1 # 1 for blank outwds = outwds + 1 return end # set - set parameter and check range subroutine set(param, val, argtyp, defval, minval, maxval) integer max, min integer argtyp, defval, maxval, minval, param, val if (argtyp == NEWLINE) # defaulted param = defval else if (argtyp == PLUS) # relative + param = param + val else if (argtyp == MINUS) # relative - param = param - val else # absolute param = val param = min(param, maxval) param = max(param, minval) return end # skip - output n blank lines subroutine skip(n) integer i, n for (i = 1; i <= n; i = i + 1) { call putc(PERIOD) call putc(NEWLINE) $@$ return end # skipbl - skip blanks and tabs at lin(i)... subroutine skipbl(lin, i) character lin(ARB) integer i while (lin(i) == BLANK | lin(i) == TAB) i = i + 1 return end # space - space n lines or to bottom of page subroutine space(n) integer min integer n include cpage call brk if (lineno > bottom) return if (lineno == 0) call phead call skip(min(n, bottom+1-lineno)) lineno = lineno + n if (lineno > bottom) call pfoot return end # spread - spread words to justify right margin subroutine spread(buf, outp, nextra, outwds) character buf(MAXOUT) integer min integer dir, i, j, nb, ne, nextra, nholes, outp, outwds data dir /0/ if (nextra <= 0 | outwds <= 1) return dir = 1 - dir # reverse previous direction ne = nextra nholes = outwds - 1 i = outp - 1 j = min(MAXOUT-2, i+ne) # leave room for NEWLINE, EOS while (i < j) { buf(j) = buf(i) if (buf(i) == BLANK) { if (dir == 0) nb = (ne-1) / nholes + 1 else nb = ne / nholes ne = ne - nb nholes = nholes - 1 for ( ; nb > 0; nb = nb - 1) { j = j - 1 buf(j) = BLANK $@$ $@$ i = i - 1 j = j - 1 $@$ return end # putwrd - put a word in outbuf subroutine putwrd(wrdbuf) character wrdbuf(INSIZE) integer length, width integer last, llval, w include cout include cparam w = width(wrdbuf) last = length(wrdbuf) + outp + 1 # new end of outbuf llval = rmval - tival if (outp > 0 & (outw+w > llval | last >= MAXOUT)) { # too big last = last - outp # remember end of wrdbuf call brk # flush previous line $@$ call scopy(wrdbuf, 1, outbuf, outp+1) outp = last outbuf(outp) = BLANK # blank between words outw = outw + w + 1 # 1 for blank outwds = outwds + 1 return end # text - process text lines (final version) subroutine text(inbuf) character inbuf(INSIZE), wrdbuf(INSIZE) integer getwrd integer i include cparam if (inbuf(1) == BLANK | inbuf(1) == NEWLINE) call leadbl(inbuf) # move left, set tival if (ulval > 0) { # underlining call underl(inbuf, wrdbuf, INSIZE) ulval = ulval - 1 $@$ if (ceval > 0) { # centering call center(inbuf) call put(inbuf) ceval = ceval - 1 $@$ else if (inbuf(1) == NEWLINE) # all blank line call put(inbuf) else if (fill == NO) # unfilled text call put(inbuf) else # filled text for (i = 1; getwrd(inbuf, i, wrdbuf) > 0; ) call putwrd(wrdbuf) return end # text - process text lines (interim version 1) subroutine text(inbuf) character inbuf(INSIZE) call put(inbuf) return end # text - process text lines (interim version 2) subroutine text(inbuf) character inbuf(INSIZE), wrdbuf(INSIZE) integer getwrd integer i include cparam if (inbuf(1) == BLANK | inbuf(1) == NEWLINE) call leadbl(inbuf) # move left, set tival if (inbuf(1) == NEWLINE) # all blank line call put(inbuf) else if (fill == NO) # unfilled text call put(inbuf) else # filled text for (i = 1; getwrd(inbuf, i, wrdbuf) > 0; ) call putwrd(wrdbuf) return end # underl - underline a line subroutine underl(buf, tbuf, size) integer i, j, size character buf(size), tbuf(size) j = 1 # expand into tbuf for (i = 1; buf(i) ~= NEWLINE & j < size-1; i = i + 1) { tbuf(j) = buf(i) j = j + 1 if (buf(i) ~= BLANK & buf(i) ~= TAB & buf(i) ~= BACKSPACE) { tbuf(j) = BACKSPACE tbuf(j+1) = UNDERLINE j = j + 2 $@$ $@$ tbuf(j) = NEWLINE tbuf(j+1) = EOS call scopy(tbuf, 1, buf, 1) # copy it back to buf return end # width - compute width of character string integer function width(buf) character buf(MAXLINE) integer i width = 0 for (i = 1; buf(i) ~= EOS; i = i + 1) if (buf(i) == BACKSPACE) width = width - 1 else if (buf(i) ~= NEWLINE) width = width + 1 return end ========== macro processors of chapter 8 ========== define(ALPHA,-100) define(MAXTBL,500) define(MAXPTR,50) define(CALLSIZE,20) define(ARGSIZE,100) define(MAXDEF,200) define(MAXTOK,200) define(ARGFLAG,DOLLAR) define(DEFTYPE,-10) define(IFTYPE,-11) define(INCTYPE,-12) define(SUBTYPE,-13) define(EVALSIZE,500) define(BUFSIZE,500) common /cdefio/ bp, buf(BUFSIZE) integer bp # next available character; init = 0 character buf # pushed-back characters common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL) integer lastp # last used in namptr; init = 0 integer lastt # last used in table; init = 0 integer namptr # name pointers character table # actual text of names and defns common /cmacro/ cp, ep, evalst(EVALSIZE) integer cp # current call stack pointer integer ep # next free position in evalst character evalst # evaluation stack # block data for macro block data include cdefio data bp /0/ end # gettok - get alphanumeric string or single non-alpha for define character function gettok(token, toksiz) character ngetc, type integer i, toksiz character token(toksiz) for (i = 1; i < toksiz; i = i + 1) { gettok = type(ngetc(token(i))) if (gettok ~= LETTER & gettok ~= DIGIT) break $@$ if (i >= toksiz) call error("token too long.") if (i > 1) { # some alpha was seen call putbak(token(i)) i = i - 1 gettok = ALPHA $@$ # else single character token token(i+1) = EOS return end # lookup - locate name, extract definition from table integer function lookup(name, defn) character defn(MAXDEF), name(MAXTOK) integer i, j, k include clook for (i = lastp; i > 0; i = i - 1) { j = namptr(i) for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { # got one call scopy(table, j+1, defn, 1) lookup = YES return $@$ $@$ lookup = NO return end # instal - add name and definition to table subroutine instal(name, defn) character defn(MAXTOK), name(MAXDEF) integer length integer dlen, nlen include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { call putlin(name, ERROUT) call remark(": too many definitions.") $@$ lastp = lastp + 1 namptr(lastp) = lastt + 1 call scopy(name, 1, table, lastt + 1) call scopy(defn, 1, table, lastt + nlen + 1) lastt = lastt + nlen + dlen return end #block data block data include clook data lastp /0/ data lastt /0/ end # macro - expand macros with arguments character gettok character defn(MAXDEF), t, token(MAXTOK) integer lookup, push integer ap, argstk(ARGSIZE), callst(CALLSIZE), nlb, plev(CALLSIZE) include cmacro # string balp "()" integer balp(3) # string defnam "define" integer defnam(7) # string incnam "incr" integer incnam(5) # string subnam "substr" integer subnam(7) # string ifnam "ifelse" integer ifnam(7) integer deftyp(2) integer inctyp(2) integer subtyp(2) integer iftyp(2) data balp(1) /LPAREN/, balp(2) /RPAREN/, balp(3) /EOS/ data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ data defnam(7) /EOS/ data incnam(1)/LETI/,incnam(2)/LETN/,incnam(3)/LETC/,incnam(4)/LETR/ data incnam(5) /EOS/ data subnam(1) /LETS/, subnam(2) /LETU/, subnam(3) /LETB/ data subnam(4) /LETS/, subnam(5) /LETT/, subnam(6) /LETR/ data subnam(7) /EOS/ data ifnam(1) /LETI/, ifnam(2) /LETF/, ifnam(3) /LETE/ data ifnam(4) /LETL/, ifnam(5) /LETS/, ifnam(6) /LETE/ data ifnam(7) /EOS/ data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/ data inctyp(1) /INCTYPE/, inctyp(2) /EOS/ data subtyp(1) /SUBTYPE/, subtyp(2) /EOS/ data iftyp(1) /IFTYPE/, iftyp(2) /EOS/ call instal(defnam, deftyp) call instal(incnam, inctyp) call instal(subnam, subtyp) call instal(ifnam, iftyp) cp = 0 ap = 1 ep = 1 for (t=gettok(token, MAXTOK); t ~= EOF; t=gettok(token, MAXTOK)) { if (t == ALPHA) { if (lookup(token, defn) == NO) call puttok(token) else { # defined; put it in eval stack cp = cp + 1 if (cp > CALLSIZE) call error("call stack overflow.") callst(cp) = ap ap = push(ep, argstk, ap) call puttok(defn) # stack definition call putchr(EOS) ap = push(ep, argstk, ap) call puttok(token) # stack name call putchr(EOS) ap = push(ep, argstk, ap) t = gettok(token, MAXTOK) # peek at next call pbstr(token) if (t ~= LPAREN) # add ( ) if not present call pbstr(balp) plev(cp) = 0 $@$ $@$ else if (t == LBRACK) { # strip one level of [ ] nlb = 1 repeat { t = gettok(token, MAXTOK) if (t == LBRACK) nlb = nlb + 1 else if (t == RBRACK) { nlb = nlb - 1 if (nlb == 0) break $@$ else if (t == EOF) call error("EOF in string.") call puttok(token) $@$ $@$ else if (cp == 0) # not in a macro at all call puttok(token) else if (t == LPAREN) { if (plev(cp) > 0) call puttok(token) plev(cp) = plev(cp) + 1 $@$ else if (t == RPAREN) { plev(cp) = plev(cp) - 1 if (plev(cp) > 0) call puttok(token) else { # end of argument list call putchr(EOS) call eval(argstk, callst(cp), ap-1) ap = callst(cp) # pop eval stack ep = argstk(ap) cp = cp - 1 $@$ $@$ else if (t == COMMA & plev(cp) == 1) { # new arg call putchr(EOS) ap = push(ep, argstk, ap) $@$ else call puttok(token) # just stack it $@$ if (cp ~= 0) call error("unexpected EOF.") stop end # push - push ep onto argstk, return new pointer ap integer function push(ep, argstk, ap) integer ap, argstk(ARGSIZE), ep if (ap > ARGSIZE) call error("arg stack overflow.") argstk(ap) = ep push = ap + 1 return end # puttok - put a token either on output or into evaluation stack subroutine puttok(str) character str(MAXTOK) integer i for (i = 1; str(i) ~= EOS; i = i + 1) call putchr(str(i)) return end # putchr - put single char on output or into evaluation stack subroutine putchr(c) character c include cmacro if (cp == 0) call putc(c) else { if (ep > EVALSIZE) call error("evaluation stack overflow.") evalst(ep) = c ep = ep + 1 $@$ return end # eval - expand args i through j: evaluate builtin or push back defn subroutine eval(argstk, i, j) integer index, length integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td include cmacro # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ t = argstk(i) td = evalst(t) if (td == DEFTYPE) call dodef(argstk, i, j) else if (td == INCTYPE) call doincr(argstk, i, j) else if (td == SUBTYPE) call dosub(argstk, i, j) else if (td == IFTYPE) call doif(argstk, i, j) else { for (k = t+length(evalst(t))-1; k > t; k = k - 1) if (evalst(k-1) ~= ARGFLAG) call putbak(evalst(k)) else { argno = index(digits, evalst(k)) - 1 if (argno >= 0 & argno < j-i) { n = i + argno + 1 m = argstk(n) call pbstr(evalst(m)) $@$ k = k - 1 # skip over $ $@$ if (k == t) # do last character call putbak(evalst(k)) $@$ return end # dodef - install definition in table subroutine dodef(argstk, i, j) integer a2, a3, argstk(ARGSIZE), i, j include cmacro if (j - i > 2) { a2 = argstk(i+2) a3 = argstk(i+3) call instal(evalst(a2), evalst(a3)) # subarrays $@$ return end # doincr - increment argument by 1 subroutine doincr(argstk, i, j) integer ctoi integer argstk(ARGSIZE), i, j, k include cmacro k = argstk(i+2) call pbnum(ctoi(evalst, k)+1) return end # pbnum - convert number to string, push back on input subroutine pbnum(n) integer mod integer m, n, num # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ num = n repeat { m = mod(num, 10) call putbak(digits(m+1)) num = num / 10 $@$ until (num == 0) return end # dosub - select substring subroutine dosub(argstk, i, j) integer ctoi, length, max, min integer ap, argstk(ARGSIZE), fc, i, j, k, nc include cmacro if (j - i < 3) return if (j - i < 4) nc = MAXTOK else { k = argstk(i+4) nc = ctoi(evalst, k) # number of characters $@$ k = argstk(i+3) # origin ap = argstk(i+2) # target string fc = ap + ctoi(evalst, k) - 1 # first char of substring if (fc >= ap & fc < ap + length(evalst(ap))) { # subarrays k = fc + min(nc, length(evalst(fc))) - 1 for ( ; k >= fc; k = k - 1) call putbak(evalst(k)) $@$ return end # doif - select one of two arguments subroutine doif(argstk, i, j) integer equal integer a2, a3, a4, a5, argstk(ARGSIZE), i, j include cmacro if (j - i < 5) return a2 = argstk(i+2) a3 = argstk(i+3) a4 = argstk(i+4) a5 = argstk(i+5) if (equal(evalst(a2), evalst(a3)) == YES) # subarrays call pbstr(evalst(a4)) else call pbstr(evalst(a5)) return end # ngetc - get a (possibly pushed back) character character function ngetc(c) character getc character c include cdefio if (bp > 0) c = buf(bp) else { bp = 1 buf(bp) = getc(c) $@$ if (c ~= EOF) bp = bp - 1 ngetc = c return end # pbstr - push string back onto input subroutine pbstr(in) character in(MAXLINE) integer length integer i for (i = length(in); i > 0; i = i - 1) call putbak(in(i)) return end # putbak - push character back onto input subroutine putbak(c) character c include cdefio bp = bp + 1 if (bp > BUFSIZE) call error("too many characters pushed back.") buf(bp) = c return end # define - simple string replacement macro processor character gettok character defn(MAXDEF), t, token(MAXTOK) integer lookup # string defnam "define" integer defnam(7) integer deftyp(2) data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ data defnam(7) /EOS/ data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/ call instal(defnam, deftyp) for (t = gettok(token, MAXTOK); t ~= EOF; t = gettok(token, MAXTOK)) if (t ~= ALPHA) # output non-alpha tokens call putlin(token, STDOUT) else if (lookup(token, defn) == NO) # and undefined call putlin(token, STDOUT) else if (defn(1) == DEFTYPE) { # get definition call getdef(token, MAXTOK, defn, MAXDEF) call instal(token, defn) $@$ else call pbstr(defn) # push replacement onto input stop end # getdef (for no arguments) - get name and definition subroutine getdef(token, toksiz, defn, defsiz) character gettok, ngetc integer defsiz, i, nlpar, toksiz character c, defn(defsiz), token(toksiz) if (ngetc(c) ~= LPAREN) call error("missing left paren.") else if (gettok(token, toksiz) ~= ALPHA) call error("non-alphanumeric name.") else if (ngetc(c) ~= COMMA) call error("missing comma in define.") # else got (name, nlpar = 0 for (i = 1; nlpar >= 0; i = i + 1) if (i > defsiz) call error("definition too long.") else if (ngetc(defn(i)) == EOF) call error("missing right paren.") else if (defn(i) == LPAREN) nlpar = nlpar + 1 else if (defn(i) == RPAREN) nlpar = nlpar - 1 # else normal character in defn(i) defn(i-1) = EOS return end ========== ratfor of chapter 9 ========== define(MAXSTACK,10) define(LEXDIGITS,-260) define(LEXIF,-261) define(LEXELSE,-262) define(LEXWHILE,-263) define(LEXBREAK,-264) define(LEXNEXT,-265) define(LEXDO,-266) define(LEXOTHER,-267) define(ALPHA,-100) define(MAXTOK,10) define(ALPHA,-100) define(MAXTBL,500) define(MAXPTR,50) define(CALLSIZE,20) define(ARGSIZE,100) define(MAXDEF,200) define(MAXTOK,200) define(ARGFLAG,DOLLAR) define(DEFTYPE,-10) define(IFTYPE,-11) define(INCTYPE,-12) define(SUBTYPE,-13) define(EVALSIZE,500) define(BUFSIZE,500) common /cdefio/ bp, buf(BUFSIZE) integer bp # next available character; init = 0 character buf # pushed-back characters common /cline/ linect integer linect # line count on input file; init = 1 common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL) integer lastp # last used in namptr; init = 0 integer lastt # last used in table; init = 0 integer namptr # name pointers character table # actual text of names and defns common /coutln/ outp, outbuf(MAXLINE) integer outp # last position filled in outbuf; init = 0 character outbuf # output lines collected here # alldig - return YES if str is all digits integer function alldig(str) character type character str(ARB) integer i alldig = NO if (str(1) == EOS) return for (i = 1; str(i) ~= EOS; i = i + 1) if (type(str(i)) ~= DIGIT) return alldig = YES return end # balpar - copy balanced paren string subroutine balpar character gettok character t, token(MAXTOK) integer nlpar if (gettok(token, MAXTOK) ~= LPAREN) { call synerr("missing left paren.") return $@$ call outstr(token) nlpar = 1 repeat { t = gettok(token, MAXTOK) if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) { call pbstr(token) break $@$ if (t == NEWLINE) # delete newlines token(1) = EOS else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 # else nothing special call outstr(token) $@$ until (nlpar <= 0) if (nlpar ~= 0) call synerr("missing parenthesis in condition.") return end #block data block data include coutln include cline include cdefio data outp /0/ data linect/1/ data bp /0/ end # brknxt - generate code for break and next subroutine brknxt(sp, lextyp, labval, token) integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token for (i = sp; i > 0; i = i - 1) if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO) { if (token == LEXBREAK) call outgo(labval(i)+1) else call outgo(labval(i)) return $@$ if (token == LEXBREAK) call synerr("illegal break.") else call synerr("illegal next.") return end # docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab # string dostr "do" integer dostr(4) data dostr(1), dostr(2), dostr(3), dostr(4)/LETD, LETO, BLANK, EOS/ call outtab call outstr(dostr) lab = labgen(2) call outnum(lab) call eatup call outdon return end # dostat - generate code for end of do statement subroutine dostat(lab) integer lab call outcon(lab) call outcon(lab+1) return end # eatup - process rest of statement; interpret continuations subroutine eatup character gettok character ptoken(MAXTOK), t, token(MAXTOK) integer nlpar nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE) break if (t == RBRACE) { call pbstr(token) break $@$ if (t == LBRACE | t == EOF) { call synerr("unexpected brace or EOF.") call pbstr(token) break $@$ if (t == COMMA) { if (gettok(ptoken, MAXTOK) ~= NEWLINE) call pbstr(ptoken) $@$ else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 call outstr(token) $@$ until (nlpar < 0) if (nlpar ~= 0) call synerr("unbalanced parentheses.") return end # elseif - generate code for end of if before else subroutine elseif(lab) integer lab call outgo(lab+1) call outcon(lab) return end # gettok - get token for Ratfor character function gettok(lexstr, toksiz) character ngetc, type integer i, toksiz character c, lexstr(toksiz) include cline while (ngetc(c) ~= EOF) if (c ~= BLANK & c ~= TAB) break call putbak(c) for (i = 1; i < toksiz-1; i = i + 1) { gettok = type(ngetc(lexstr(i))) if (gettok ~= LETTER & gettok ~= DIGIT) break $@$ if (i >= toksiz-1) call synerr("token too long.") if (i > 1) { # some alpha seen call putbak(lexstr(i)) # went one too far lexstr(i) = EOS gettok = ALPHA $@$ else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) { for (i = 2; ngetc(lexstr(i)) ~= lexstr(1); i = i + 1) if (lexstr(i) == NEWLINE | i >= toksiz-1) { call synerr("missing quote.") lexstr(i) = lexstr(1) call putbak(NEWLINE) break $@$ $@$ else if (lexstr(1) == SHARP) { # strip comments while (ngetc(lexstr(1)) ~= NEWLINE) ; gettok = NEWLINE $@$ lexstr(i+1) = EOS if (lexstr(1) == NEWLINE) linect = linect + 1 return end # ifcode - generate initial code for if subroutine ifcode(lab) integer labgen integer lab lab = labgen(2) call ifgo(lab) return end # ifgo - generate "if(.not.(...))goto lab" subroutine ifgo(lab) integer lab # string ifnot "if(.not." integer ifnot(9) data ifnot(1) /LETI/ data ifnot(2) /LETF/ data ifnot(3) /LPAREN/ data ifnot(4) /PERIOD/ data ifnot(5) /LETN/ data ifnot(6) /LETO/ data ifnot(7) /LETT/ data ifnot(8) /PERIOD/ data ifnot(9) /EOS/ call outtab # get to column 7 call outstr(ifnot) # " if(.not. " call balpar # collect and output condition call outch(RPAREN) # " ) " call outgo(lab) # " goto lab " return end # initkw - initialize keyword tables subroutine initkw integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5) integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2) data sdo(1),sdo(2),sdo(3) /LETD,LETO,EOS/ data vdo(1),vdo(2) /LEXDO,EOS/ data sif(1),sif(2),sif(3) /LETI,LETF,EOS/ data vif(1),vif(2) /LEXIF,EOS/ data selse(1),selse(2),selse(3),selse(4),selse(5) /LETE, LETL,LETS,LETE,EOS/ data velse(1),velse(2) /LEXELSE,EOS/ data swhile(1),swhile(2),swhile(3),swhile(4),swhile(5), swhile(6) /LETW,LETH,LETI,LETL,LETE,EOS/ data vwhile(1),vwhile(2) /LEXWHILE,EOS/ data sbreak(1),sbreak(2),sbreak(3),sbreak(4),sbreak(5), sbreak(6) /LETB,LETR,LETE,LETA,LETK,EOS/ data vbreak(1),vbreak(2) /LEXBREAK,EOS/ data snext(1),snext(2),snext(3),snext(4),snext(5) /LETN, LETE,LETX,LETT,EOS/ data vnext(1),vnext(2) /LEXNEXT,EOS/ call instal(sdo,vdo) call instal(sif,vif) call instal(selse,velse) call instal(swhile,vwhile) call instal(sbreak,vbreak) call instal(snext,vnext) return end # labelc - output statement number subroutine labelc(lexstr) character lexstr(ARB) integer length if (length(lexstr) == 5) # warn about 23xxx labels if (lexstr(1) == DIG2 & lexstr(2) == DIG3) call synerr("warning: possible label conflict.") call outstr(lexstr) call outtab return end # labgen - generate n consecutive labels, return first one integer function labgen(n) integer label, n data label /23000/ labgen = label label = label + n return end # lex - return lexical type of token integer function lex(lexstr) character gettok character lexstr(MAXTOK) integer alldig, lookup integer ltype(2) while (gettok(lexstr, MAXTOK) == NEWLINE) ; lex = lexstr(1) if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE) return if (alldig(lexstr) == YES) lex = LEXDIGITS else if (lookup(lexstr, ltype) == YES) lex = ltype(1) else lex = LEXOTHER return end # lookup - locate name, extract definition from table integer function lookup(name, defn) character defn(MAXDEF), name(MAXTOK) integer i, j, k include clook for (i = lastp; i > 0; i = i - 1) { j = namptr(i) for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { # got one call scopy(table, j+1, defn, 1) lookup = YES return $@$ $@$ lookup = NO return end # instal - add name and definition to table subroutine instal(name, defn) character defn(MAXTOK), name(MAXDEF) integer length integer dlen, nlen include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { call putlin(name, ERROUT) call remark(": too many definitions.") $@$ lastp = lastp + 1 namptr(lastp) = lastt + 1 call scopy(name, 1, table, lastt + 1) call scopy(defn, 1, table, lastt + nlen + 1) lastt = lastt + nlen + dlen return end #block data block data include clook data lastp /0/ data lastt /0/ end # ngetc - get a (possibly pushed back) character character function ngetc(c) character getc character c include cdefio if (bp > 0) c = buf(bp) else { bp = 1 buf(bp) = getc(c) $@$ if (c ~= EOF) bp = bp - 1 ngetc = c return end # otherc - output ordinary Fortran statement subroutine otherc(lexstr) character lexstr(ARB) call outtab call outstr(lexstr) call eatup call outdon return end # outch - put one character into output buffer subroutine outch(c) character c integer i include coutln if (outp >= 72) { # continuation card call outdon for (i = 1; i < 6; i = i + 1) outbuf(i) = BLANK outbuf(6) = STAR outp = 6 $@$ outp = outp + 1 outbuf(outp) = c return end # outcon - output "n continue" subroutine outcon(n) integer n # string contin "continue" integer contin(9) data contin(1) /LETC/ data contin(2) /LETO/ data contin(3) /LETN/ data contin(4) /LETT/ data contin(5) /LETI/ data contin(6) /LETN/ data contin(7) /LETU/ data contin(8) /LETE/ data contin(9) /EOS/ if (n > 0) call outnum(n) call outtab call outstr(contin) call outdon return end # outdon - finish off an output line subroutine outdon include coutln outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS call putlin(outbuf, STDOUT) outp = 0 return end # outgo - output "goto n" subroutine outgo(n) integer n # string goto "goto" integer goto(6) data goto(1) /LETG/ data goto(2) /LETO/ data goto(3) /LETT/ data goto(4) /LETO/ data goto(5) /BLANK/ data goto(6) /EOS/ call outtab call outstr(goto) call outnum(n) call outdon return end define(MAXCHARS,10) # outnum - output decimal number subroutine outnum(n) character chars(MAXCHARS) integer itoc integer i, len, n len = itoc(n, chars, MAXCHARS) for (i = 1; i <= len; i = i + 1) call outch(chars(i)) return end # outstr - output string subroutine outstr(str) character c, str(ARB) integer i, j for (i = 1; str(i) ~= EOS; i = i + 1) { c = str(i) if (c ~= SQUOTE & c ~= DQUOTE) call outch(c) else { i = i + 1 for (j = i; str(j) ~= c; j = j + 1) # find end ; call outnum(j-i) call outch(LETH) for ( ; i < j; i = i + 1) call outch(str(i)) $@$ $@$ return end # outtab - get past column 6 subroutine outtab include coutln while (outp < 6) call outch(BLANK) return end # parse - parse Ratfor source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token call initkw # install keywords in table sp = 1 lextyp(1) = EOF for (token = lex(lexstr); token ~= EOF; token = lex(lexstr)) { if (token == LEXIF) call ifcode(lab) else if (token == LEXDO) call docode(lab) else if (token == LEXWHILE) call whilec(lab) else if (token == LEXDIGITS) call labelc(lexstr) else if (token == LEXELSE) { if (lextyp(sp) == LEXIF) call elseif(labval(sp)) else call synerr("illegal else.") $@$ if (token==LEXIF | token==LEXELSE | token==LEXWHILE | token==LEXDO | token==LEXDIGITS | token==LBRACE) { sp = sp + 1 # beginning of statement if (sp > MAXSTACK) call error("stack overflow in parser.") lextyp(sp) = token # stack type and value labval(sp) = lab $@$ else { # end of statement - prepare to unstack if (token == RBRACE) { if (lextyp(sp) == LBRACE) sp = sp - 1 else call synerr("illegal right brace.") $@$ else if (token == LEXOTHER) call otherc(lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt(sp, lextyp, labval, token) token = lex(lexstr) # peek at next token call pbstr(lexstr) call unstak(sp, lextyp, labval, token) $@$ $@$ if (sp ~= 1) call synerr("unexpected EOF.") return end # pbstr - push string back onto input subroutine pbstr(in) character in(MAXLINE) integer length integer i for (i = length(in); i > 0; i = i - 1) call putbak(in(i)) return end # putbak - push character back onto input subroutine putbak(c) character c include cdefio bp = bp + 1 if (bp > BUFSIZE) call error("too many characters pushed back.") buf(bp) = c return end # ratfor - main program for Ratfor call parse stop end # synerr - report Ratfor syntax error subroutine synerr(msg) character lc(MAXLINE), msg(MAXLINE) integer itoc integer junk include cline call remark("error at line .") junk = itoc(linect, lc, MAXLINE) call putlin(lc, ERROUT) call putch(COLON, ERROUT) call remark(msg) return end # unstak - unstack at end of statement subroutine unstak(sp, lextyp, labval, token) integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token for ( ; sp > 1; sp = sp - 1) { if (lextyp(sp) == LBRACE) break if (lextyp(sp) == LEXIF & token == LEXELSE) break if (lextyp(sp) == LEXIF) call outcon(labval(sp)) else if (lextyp(sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon(labval(sp)+1) $@$ else if (lextyp(sp) == LEXDO) call dostat(labval(sp)) else if (lextyp(sp) == LEXWHILE) call whiles(labval(sp)) $@$ return end # whilec - generate code for beginning of while subroutine whilec(lab) integer labgen integer lab call outcon(0) # unlabeled continue, in case there was a label lab = labgen(2) call outnum(lab) call ifgo(lab+1) return end # whiles - generate code for end of while subroutine whiles(lab) integer lab call outgo(lab) call outcon(lab+1) return end ========== end of information ==========