========== start of info ========== 10 Tue Mar 2 10:33:30 EST 1976 20 0 0 00 30 1 1 01 40 2 2 02 50 3 3 03 60 4 4 37 70 5 5 2D 80 6 6 2E 90 7 7 2F 100 bs 8 10 16 110 tab 9 11 05 120 10 12 25 130 11 13 0B 140 12 14 0C 150 13 15 0D 160 14 16 0E 170 15 17 0F 180 16 20 10 190 17 21 11 200 18 22 12 210 19 23 13 220 20 24 3C 230 21 25 3D 240 22 26 32 250 23 27 26 260 24 30 18 270 25 31 19 280 26 32 3F 290 27 33 27 300 28 34 1C 310 29 35 1D 320 30 36 1E 330 31 37 1F 340 blnk 32 40 40 350 ] 33 41 5A 360 " 34 42 7F 370 # 35 43 7B 380 $ 36 44 5B 390 % 37 45 6C 400 & 38 46 50 410 ' 39 47 7D 420 ( 40 50 4D 430 ) 41 51 5D 440 * 42 52 5C 450 + 43 53 4E 460 , 44 54 6B 470 - 45 55 60 480 . 46 56 4B 490 / 47 57 61 500 0 48 60 F0 510 1 49 61 F1 520 2 50 62 F2 530 3 51 63 F3 540 4 52 64 F4 550 5 53 65 F5 560 6 54 66 F6 570 7 55 67 F7 580 8 56 70 F8 590 9 57 71 F9 600 : 58 72 7A 610 ; 59 73 5E 620 < 60 74 4C 630 = 61 75 7E 640 > 62 76 6E 650 ? 63 77 6F 660 @ 64 100 7C 670 A 65 101 C1 680 B 66 102 C2 690 C 67 103 C3 700 D 68 104 C4 710 E 69 105 C5 720 F 70 106 C6 730 G 71 107 C7 740 H 72 110 C8 750 I 73 111 C9 760 J 74 112 D1 770 K 75 113 D2 780 L 76 114 D3 790 M 77 115 D4 800 N 78 116 D5 810 O 79 117 D6 820 P 80 120 D7 830 Q 81 121 D8 840 R 82 122 D9 850 S 83 123 E2 860 T 84 124 E3 870 U 85 125 E4 880 V 86 126 E5 890 W 87 127 E6 900 X 88 130 E7 910 Y 89 131 E8 920 Z 90 132 E9 930 Õ 91 133 AD 940 \ 92 134 E0 950 å 93 135 BD 960 ^ 94 136 5F 970 _ 95 137 6D 980 ` 96 140 79 990 a 97 141 81 1000 b 98 142 82 1010 c 99 143 83 1020 d 100 144 84 1030 e 101 145 85 1040 f 102 146 86 1050 g 103 147 87 1060 h 104 150 88 1070 i 105 151 89 1080 j 106 152 91 1090 k 107 153 92 1100 l 108 154 93 1110 m 109 155 94 1120 n 110 156 95 1130 o 111 157 96 1140 p 112 160 97 1150 q 113 161 98 1160 r 114 162 99 1170 s 115 163 A2 1180 t 116 164 A3 1190 u 117 165 A4 1200 v 118 166 A5 1210 w 119 167 A6 1220 x 120 170 A7 1230 y 121 171 A8 1240 z 122 172 A9 1250 { 123 173 C0 1260 ! 124 174 4F 1270 } 125 175 D0 1280 ~ 126 176 A1 1290  127 177 07 1300 not 94 136 5F 1310 ========== ratfor in fortran for bootstrap ========== 1320 C 1330 C BLOCK DATA - INITIALIZE GLOBAL VARIABLES 1340 C 1350 BLOCK DATA 1360 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 1370 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 1380 INTEGER EXTDIG 1390 INTEGER INTDIG 1400 INTEGER EXTLET 1410 INTEGER INTLET 1420 INTEGER EXTBIG 1430 INTEGER INTBIG 1440 INTEGER EXTCHR 1450 INTEGER INTCHR 1460 INTEGER EXTBLK 1470 INTEGER INTBLK 1480 COMMON /CDEFIO/ BP, BUF(300) 1490 INTEGER BP 1500 INTEGER BUF 1510 COMMON /CFOR/ FORDEP, FORSTK(200) 1520 INTEGER FORDEP 1530 INTEGER FORSTK 1540 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 1550 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 1560 *UNTIL 1570 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 1580 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 1590 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 1600 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 1610 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 1620 INTEGER LEVEL 1630 INTEGER LINECT 1640 INTEGER INFILE 1650 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 1660 INTEGER LASTP 1670 INTEGER LASTT 1680 INTEGER NAMPTR 1690 INTEGER TABLE 1700 COMMON /COUTLN/ OUTP, OUTBUF(81) 1710 INTEGER OUTP 1720 INTEGER OUTBUF 1730 DATA OUTP /0/ 1740 DATA LEVEL /1/ 1750 DATA LINECT(1) /1/ 1760 DATA INFILE(1) /5/ 1770 DATA BP /0/ 1780 DATA FORDEP /0/ 1790 DATA LASTP /0/ 1800 DATA LASTT /0/ 1810 DATA SDO(1), SDO(2), SDO(3) /100, 111, 10002/ 1820 DATA VDO(1), VDO(2) /10266, 10002/ 1830 DATA SIF(1), SIF(2), SIF(3) /105, 102, 10002/ 1840 DATA VIF(1), VIF(2) /10261, 10002/ 1850 DATA SELSE(1), SELSE(2), SELSE(3), SELSE(4), SELSE(5) /101, 108, 1860 * 115, 101, 10002/ 1870 DATA VELSE(1), VELSE(2) /10262, 10002/ 1880 DATA SWHILE(1), SWHILE(2), SWHILE(3), SWHILE(4), SWHILE(5), SWHIL 1890 *E(6) /119, 104, 105, 108, 101, 10002/ 1900 DATA VWHILE(1), VWHILE(2) /10263, 10002/ 1910 DATA SBREAK(1), SBREAK(2), SBREAK(3), SBREAK(4), SBREAK(5), SBREA 1920 *K(6) /98, 114, 101, 97, 107, 10002/ 1930 DATA VBREAK(1), VBREAK(2) /10264, 10002/ 1940 DATA SNEXT(1), SNEXT(2), SNEXT(3), SNEXT(4), SNEXT(5) /110, 101, 1950 * 120, 116, 10002/ 1960 DATA VNEXT(1), VNEXT(2) /10265, 10002/ 1970 DATA SFOR(1), SFOR(2), SFOR(3), SFOR(4) /102, 111, 114, 10002/ 1980 DATA VFOR(1), VFOR(2) /10268, 10002/ 1990 DATA SREPT(1), SREPT(2), SREPT(3), SREPT(4), SREPT(5), SREPT(6), 2000 * SREPT(7) /114, 101, 112, 101, 97, 116, 10002/ 2010 DATA VREPT(1), VREPT(2) /10269, 10002/ 2020 DATA SUNTIL(1), SUNTIL(2), SUNTIL(3), SUNTIL(4), SUNTIL(5), SUNTI 2030 *L(6) /117, 110, 116, 105, 108, 10002/ 2040 DATA VUNTIL(1), VUNTIL(2) /10270, 10002/ 2050 DATA EXTBLK /1H /, INTBLK /32/ 2060 DATA EXTDIG(1) /1H0/, INTDIG(1) /48/ 2070 DATA EXTDIG(2) /1H1/, INTDIG(2) /49/ 2080 DATA EXTDIG(3) /1H2/, INTDIG(3) /50/ 2090 DATA EXTDIG(4) /1H3/, INTDIG(4) /51/ 2100 DATA EXTDIG(5) /1H4/, INTDIG(5) /52/ 2110 DATA EXTDIG(6) /1H5/, INTDIG(6) /53/ 2120 DATA EXTDIG(7) /1H6/, INTDIG(7) /54/ 2130 DATA EXTDIG(8) /1H7/, INTDIG(8) /55/ 2140 DATA EXTDIG(9) /1H8/, INTDIG(9) /56/ 2150 DATA EXTDIG(10) /1H9/, INTDIG(10) /57/ 2160 DATA EXTLET(1) /1HA/, INTLET(1) /97/ 2170 DATA EXTLET(2) /1HB/, INTLET(2) /98/ 2180 DATA EXTLET(3) /1HC/, INTLET(3) /99/ 2190 DATA EXTLET(4) /1HD/, INTLET(4) /100/ 2200 DATA EXTLET(5) /1HE/, INTLET(5) /101/ 2210 DATA EXTLET(6) /1HF/, INTLET(6) /102/ 2220 DATA EXTLET(7) /1HG/, INTLET(7) /103/ 2230 DATA EXTLET(8) /1HH/, INTLET(8) /104/ 2240 DATA EXTLET(9) /1HI/, INTLET(9) /105/ 2250 DATA EXTLET(10) /1HJ/, INTLET(10) /106/ 2260 DATA EXTLET(11) /1HK/, INTLET(11) /107/ 2270 DATA EXTLET(12) /1HL/, INTLET(12) /108/ 2280 DATA EXTLET(13) /1HM/, INTLET(13) /109/ 2290 DATA EXTLET(14) /1HN/, INTLET(14) /110/ 2300 DATA EXTLET(15) /1HO/, INTLET(15) /111/ 2310 DATA EXTLET(16) /1HP/, INTLET(16) /112/ 2320 DATA EXTLET(17) /1HQ/, INTLET(17) /113/ 2330 DATA EXTLET(18) /1HR/, INTLET(18) /114/ 2340 DATA EXTLET(19) /1HS/, INTLET(19) /115/ 2350 DATA EXTLET(20) /1HT/, INTLET(20) /116/ 2360 DATA EXTLET(21) /1HU/, INTLET(21) /117/ 2370 DATA EXTLET(22) /1HV/, INTLET(22) /118/ 2380 DATA EXTLET(23) /1HW/, INTLET(23) /119/ 2390 DATA EXTLET(24) /1HX/, INTLET(24) /120/ 2400 DATA EXTLET(25) /1HY/, INTLET(25) /121/ 2410 DATA EXTLET(26) /1HZ/, INTLET(26) /122/ 2420 DATA EXTBIG(1) /1HA/, INTBIG(1) /65/ 2430 DATA EXTBIG(2) /1HB/, INTBIG(2) /66/ 2440 DATA EXTBIG(3) /1HC/, INTBIG(3) /67/ 2450 DATA EXTBIG(4) /1HD/, INTBIG(4) /68/ 2460 DATA EXTBIG(5) /1HE/, INTBIG(5) /69/ 2470 DATA EXTBIG(6) /1HF/, INTBIG(6) /70/ 2480 DATA EXTBIG(7) /1HG/, INTBIG(7) /71/ 2490 DATA EXTBIG(8) /1HH/, INTBIG(8) /72/ 2500 DATA EXTBIG(9) /1HI/, INTBIG(9) /73/ 2510 DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/ 2520 DATA EXTBIG(11) /1HK/, INTBIG(11) /75/ 2530 DATA EXTBIG(12) /1HL/, INTBIG(12) /76/ 2540 DATA EXTBIG(13) /1HM/, INTBIG(13) /77/ 2550 DATA EXTBIG(14) /1HN/, INTBIG(14) /78/ 2560 DATA EXTBIG(15) /1HO/, INTBIG(15) /79/ 2570 DATA EXTBIG(16) /1HP/, INTBIG(16) /80/ 2580 DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/ 2590 DATA EXTBIG(18) /1HR/, INTBIG(18) /82/ 2600 DATA EXTBIG(19) /1HS/, INTBIG(19) /83/ 2610 DATA EXTBIG(20) /1HT/, INTBIG(20) /84/ 2620 DATA EXTBIG(21) /1HU/, INTBIG(21) /85/ 2630 DATA EXTBIG(22) /1HV/, INTBIG(22) /86/ 2640 DATA EXTBIG(23) /1HW/, INTBIG(23) /87/ 2650 DATA EXTBIG(24) /1HX/, INTBIG(24) /88/ 2660 DATA EXTBIG(25) /1HY/, INTBIG(25) /89/ 2670 DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/ 2680 DATA EXTCHR(1) /1H]/, INTCHR(1) /33/ 2690 DATA EXTCHR(2) /1H"/, INTCHR(2) /34/ 2700 DATA EXTCHR(3) /1H#/, INTCHR(3) /35/ 2710 DATA EXTCHR(4) /1H$/, INTCHR(4) /36/ 2720 DATA EXTCHR(5) /1H%/, INTCHR(5) /37/ 2730 DATA EXTCHR(6) /1H&/, INTCHR(6) /38/ 2740 DATA EXTCHR(7) /1H'/, INTCHR(7) /39/ 2750 DATA EXTCHR(8) /1H(/, INTCHR(8) /40/ 2760 DATA EXTCHR(9) /1H)/, INTCHR(9) /41/ 2770 DATA EXTCHR(10) /1H*/, INTCHR(10) /42/ 2780 DATA EXTCHR(11) /1H+/, INTCHR(11) /43/ 2790 DATA EXTCHR(12) /1H,/, INTCHR(12) /44/ 2800 DATA EXTCHR(13) /1H-/, INTCHR(13) /45/ 2810 DATA EXTCHR(14) /1H./, INTCHR(14) /46/ 2820 DATA EXTCHR(15) /1H//, INTCHR(15) /47/ 2830 DATA EXTCHR(16) /1H:/, INTCHR(16) /58/ 2840 DATA EXTCHR(17) /1H;/, INTCHR(17) /59/ 2850 DATA EXTCHR(18) /1H/, INTCHR(20) /62/ 2880 DATA EXTCHR(21) /1H?/, INTCHR(21) /63/ 2890 DATA EXTCHR(22) /1H@/, INTCHR(22) /64/ 2900 DATA EXTCHR(23) /1HÕ/, INTCHR(23) /91/ 2910 DATA EXTCHR(24) /1H\/, INTCHR(24) /92/ 2920 DATA EXTCHR(25) /1Hå/, INTCHR(25) /93/ 2930 DATA EXTCHR(26) /1H_/, INTCHR(26) /95/ 2940 DATA EXTCHR(27) /1H{/, INTCHR(27) /123/ 2950 DATA EXTCHR(28) /1H!/, INTCHR(28) /124/ 2960 DATA EXTCHR(29) /1H}/, INTCHR(29) /125/ 2970 DATA EXTCHR(30) /1H/, INTCHR(30) /8/ 2980 DATA EXTCHR(31) /1H /, INTCHR(31) /9/ 2990 DATA EXTCHR(32) /1H^/, INTCHR(32) /33/ 3000 DATA EXTCHR(33) /1H~/, INTCHR(33) /33/ 3010 END 3020 C 3030 C RATFOR - MAIN PROGRAM FOR RATFOR 3040 C 3050 CALL PARSE 3060 STOP 3070 END 3080 C 3090 C ALLDIG - RETURN YES IF STR IS ALL DIGITS 3100 C 3110 INTEGER FUNCTION ALLDIG(STR) 3120 INTEGER TYPE 3130 INTEGER STR(100) 3140 INTEGER I 3150 ALLDIG = 0 3160 IF(.NOT.(STR(1) .EQ. 10002)) GOTO 23000 3170 RETURN 3180 23000 CONTINUE 3190 CONTINUE 3200 I = 1 3210 23002 IF(.NOT.( STR(I) .NE. 10002)) GOTO 23004 3220 IF(.NOT.(TYPE(STR(I)) .NE. 2)) GOTO 23005 3230 RETURN 3240 23005 CONTINUE 3250 23003 I = I + 1 3260 GOTO 23002 3270 23004 CONTINUE 3280 ALLDIG = 1 3290 RETURN 3300 END 3310 C 3320 C BALPAR - COPY BALANCED PAREN STRING 3330 C 3340 SUBROUTINE BALPAR 3350 INTEGER GETTOK 3360 INTEGER T, TOKEN(200) 3370 INTEGER NLPAR 3380 IF(.NOT.(GETTOK(TOKEN, 200) .NE. 40)) GOTO 23007 3390 CALL SYNERR(19HMISSING LEFT PAREN.) 3400 RETURN 3410 23007 CONTINUE 3420 CALL OUTSTR(TOKEN) 3430 NLPAR = 1 3440 CONTINUE 3450 23009 CONTINUE 3460 T = GETTOK(TOKEN, 200) 3470 IF(.NOT.(T.EQ.59 .OR. T.EQ.123 .OR. T.EQ.125 .OR. T.EQ.10003)) GO 3480 *TO 23012 3490 CALL PBSTR(TOKEN) 3500 GOTO 23011 3510 23012 CONTINUE 3520 IF(.NOT.(T .EQ. 10)) GOTO 23014 3530 TOKEN(1) = 10002 3540 GOTO 23015 3550 23014 CONTINUE 3560 IF(.NOT.(T .EQ. 40)) GOTO 23016 3570 NLPAR = NLPAR + 1 3580 GOTO 23017 3590 23016 CONTINUE 3600 IF(.NOT.(T .EQ. 41)) GOTO 23018 3610 NLPAR = NLPAR - 1 3620 23018 CONTINUE 3630 23017 CONTINUE 3640 23015 CONTINUE 3650 CALL OUTSTR(TOKEN) 3660 23010 IF(.NOT.(NLPAR .LE. 0)) GOTO 23009 3670 23011 CONTINUE 3680 IF(.NOT.(NLPAR .NE. 0)) GOTO 23020 3690 CALL SYNERR(33HMISSING PARENTHESIS IN CONDITION.) 3700 23020 CONTINUE 3710 RETURN 3720 END 3730 C 3740 C BRKNXT - GENERATE CODE FOR BREAK AND NEXT 3750 C 3760 SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN) 3770 INTEGER I, LABVAL(100), LEXTYP(100), SP, TOKEN 3780 CONTINUE 3790 I = SP 3800 23022 IF(.NOT.( I .GT. 0)) GOTO 23024 3810 IF(.NOT.(LEXTYP(I) .EQ. 10263 .OR. LEXTYP(I) .EQ. 10266 .OR 3820 *. LEXTYP(I) .EQ. 10268 .OR. LEXTYP(I) .EQ. 10269)) GOTO 23025 3830 IF(.NOT.(TOKEN .EQ. 10264)) GOTO 23027 3840 CALL OUTGO(LABVAL(I)+1) 3850 GOTO 23028 3860 23027 CONTINUE 3870 CALL OUTGO(LABVAL(I)) 3880 23028 CONTINUE 3890 RETURN 3900 23025 CONTINUE 3910 23023 I = I - 1 3920 GOTO 23022 3930 23024 CONTINUE 3940 IF(.NOT.(TOKEN .EQ. 10264)) GOTO 23029 3950 CALL SYNERR(14HILLEGAL BREAK.) 3960 GOTO 23030 3970 23029 CONTINUE 3980 CALL SYNERR(13HILLEGAL NEXT.) 3990 23030 CONTINUE 4000 RETURN 4010 END 4020 C 4030 C CLOSE - EXCEEDINGLY TEMPORARY VERSION FOR GETTOK 4040 C 4050 SUBROUTINE CLOSE(FD) 4060 INTEGER FD 4070 REWIND FD 4080 RETURN 4090 END 4100 C 4110 C CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I 4120 C 4130 INTEGER FUNCTION CTOI(IN, I) 4140 INTEGER IN(100) 4150 INTEGER INDEX 4160 INTEGER D, I 4170 INTEGER DIGITS(11) 4180 DATA DIGITS(1) /48/ 4190 DATA DIGITS(2) /49/ 4200 DATA DIGITS(3) /50/ 4210 DATA DIGITS(4) /51/ 4220 DATA DIGITS(5) /52/ 4230 DATA DIGITS(6) /53/ 4240 DATA DIGITS(7) /54/ 4250 DATA DIGITS(8) /55/ 4260 DATA DIGITS(9) /56/ 4270 DATA DIGITS(10) /57/ 4280 DATA DIGITS(11) /10002/ 4290 CONTINUE 4300 23031 IF(.NOT.(IN(I) .EQ. 32 .OR. IN(I) .EQ. 9)) GOTO 23032 4310 I = I + 1 4320 GOTO 23031 4330 23032 CONTINUE 4340 CONTINUE 4350 CTOI = 0 4360 23033 IF(.NOT.( IN(I) .NE. 10002)) GOTO 23035 4370 D = INDEX(DIGITS, IN(I)) 4380 IF(.NOT.(D .EQ. 0)) GOTO 23036 4390 GOTO 23035 4400 23036 CONTINUE 4410 CTOI = 10 * CTOI + D - 1 4420 23034 I = I + 1 4430 GOTO 23033 4440 23035 CONTINUE 4450 RETURN 4460 END 4470 C 4480 C DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS 4490 C 4500 INTEGER FUNCTION DEFTOK(TOKEN, TOKSIZ, FD) 4510 INTEGER GTOK 4520 INTEGER FD, TOKSIZ 4530 INTEGER DEFN(200), T, TOKEN(TOKSIZ) 4540 INTEGER LOOKUP 4550 CONTINUE 4560 T=GTOK(TOKEN, TOKSIZ, FD) 4570 23038 IF(.NOT.( T.NE.10003)) GOTO 23040 4580 IF(.NOT.(T .NE. 10100)) GOTO 23041 4590 GOTO 23040 4600 23041 CONTINUE 4610 IF(.NOT.(LOOKUP(TOKEN, DEFN) .EQ. 0)) GOTO 23043 4620 GOTO 23040 4630 23043 CONTINUE 4640 IF(.NOT.(DEFN(1) .EQ. 10010)) GOTO 23045 4650 CALL GETDEF(TOKEN, TOKSIZ, DEFN, 200, FD) 4660 CALL INSTAL(TOKEN, DEFN) 4670 GOTO 23046 4680 23045 CONTINUE 4690 CALL PBSTR(DEFN) 4700 23046 CONTINUE 4710 23039 T=GTOK(TOKEN, TOKSIZ, FD) 4720 GOTO 23038 4730 23040 CONTINUE 4740 DEFTOK = T 4750 IF(.NOT.(DEFTOK .EQ. 10100)) GOTO 23047 4760 CALL FOLD(TOKEN) 4770 23047 CONTINUE 4780 RETURN 4790 END 4800 C 4810 C FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE 4820 C 4830 SUBROUTINE FOLD(TOKEN) 4840 INTEGER TOKEN(100) 4850 INTEGER I 4860 CONTINUE 4870 I = 1 4880 23049 IF(.NOT.( TOKEN(I) .NE. 10002)) GOTO 23051 4890 IF(.NOT.(TOKEN(I) .GE. 65 .AND. TOKEN(I) .LE. 90)) GOTO 23052 4900 TOKEN(I) = TOKEN(I) - 65 + 97 4910 23052 CONTINUE 4920 23050 I = I + 1 4930 GOTO 23049 4940 23051 CONTINUE 4950 RETURN 4960 END 4970 C 4980 C DOCODE - GENERATE CODE FOR BEGINNING OF DO 4990 C 5000 SUBROUTINE DOCODE(LAB) 5010 INTEGER LABGEN 5020 INTEGER LAB 5030 INTEGER DOSTR(4) 5040 DATA DOSTR(1), DOSTR(2), DOSTR(3), DOSTR(4)/100, 111, 32, 10002/ 5050 CALL OUTTAB 5060 CALL OUTSTR(DOSTR) 5070 LAB = LABGEN(2) 5080 CALL OUTNUM(LAB) 5090 CALL EATUP 5100 CALL OUTDON 5110 RETURN 5120 END 5130 C 5140 C DOSTAT - GENERATE CODE FOR END OF DO STATEMENT 5150 C 5160 SUBROUTINE DOSTAT(LAB) 5170 INTEGER LAB 5180 CALL OUTCON(LAB) 5190 CALL OUTCON(LAB+1) 5200 RETURN 5210 END 5220 C 5230 C EATUP - PROCESS REST OF STATEMENT; INTERPRET CONTINUATIONS 5240 C 5250 SUBROUTINE EATUP 5260 INTEGER GETTOK 5270 INTEGER PTOKEN(200), T, TOKEN(200) 5280 INTEGER NLPAR 5290 NLPAR = 0 5300 CONTINUE 5310 23054 CONTINUE 5320 T = GETTOK(TOKEN, 200) 5330 IF(.NOT.(T .EQ. 59 .OR. T .EQ. 10)) GOTO 23057 5340 GOTO 23056 5350 23057 CONTINUE 5360 IF(.NOT.(T .EQ. 125)) GOTO 23059 5370 CALL PBSTR(TOKEN) 5380 GOTO 23056 5390 23059 CONTINUE 5400 IF(.NOT.(T .EQ. 123 .OR. T .EQ. 10003)) GOTO 23061 5410 CALL SYNERR(24HUNEXPECTED BRACE OR EOF.) 5420 CALL PBSTR(TOKEN) 5430 GOTO 23056 5440 23061 CONTINUE 5450 IF(.NOT.(T .EQ. 44 .OR. T .EQ. 95)) GOTO 23063 5460 IF(.NOT.(GETTOK(PTOKEN, 200) .NE. 10)) GOTO 23065 5470 CALL PBSTR(PTOKEN) 5480 23065 CONTINUE 5490 IF(.NOT.(T .EQ. 95)) GOTO 23067 5500 TOKEN(1) = 10002 5510 23067 CONTINUE 5520 GOTO 23064 5530 23063 CONTINUE 5540 IF(.NOT.(T .EQ. 40)) GOTO 23069 5550 NLPAR = NLPAR + 1 5560 GOTO 23070 5570 23069 CONTINUE 5580 IF(.NOT.(T .EQ. 41)) GOTO 23071 5590 NLPAR = NLPAR - 1 5600 23071 CONTINUE 5610 23070 CONTINUE 5620 23064 CONTINUE 5630 CALL OUTSTR(TOKEN) 5640 23055 IF(.NOT.(NLPAR .LT. 0)) GOTO 23054 5650 23056 CONTINUE 5660 IF(.NOT.(NLPAR .NE. 0)) GOTO 23073 5670 CALL SYNERR(23HUNBALANCED PARENTHESES.) 5680 23073 CONTINUE 5690 RETURN 5700 END 5710 C 5720 C ELSEIF - GENERATE CODE FOR END OF IF BEFORE ELSE 5730 C 5740 SUBROUTINE ELSEIF(LAB) 5750 INTEGER LAB 5760 CALL OUTGO(LAB+1) 5770 CALL OUTCON(LAB) 5780 RETURN 5790 END 5800 C 5810 C EQUAL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, NO IF NOT 5820 C 5830 INTEGER FUNCTION EQUAL(STR1, STR2) 5840 INTEGER STR1(100), STR2(100) 5850 INTEGER I 5860 CONTINUE 5870 I = 1 5880 23075 IF(.NOT.( STR1(I) .EQ. STR2(I))) GOTO 23077 5890 IF(.NOT.(STR1(I) .EQ. 10002)) GOTO 23078 5900 EQUAL = 1 5910 RETURN 5920 23078 CONTINUE 5930 23076 I = I + 1 5940 GOTO 23075 5950 23077 CONTINUE 5960 EQUAL = 0 5970 RETURN 5980 END 5990 C 6000 C ERROR - PRINT FATAL ERROR MESSAGE, THEN DIE 6010 C 6020 SUBROUTINE ERROR(BUF) 6030 INTEGER BUF(100) 6040 CALL REMARK(BUF) 6050 STOP 6060 END 6070 C 6080 C FORCOD - BEGINNING OF FOR STATEMENT 6090 C 6100 SUBROUTINE FORCOD(LAB) 6110 INTEGER GETTOK 6120 INTEGER T, TOKEN(200) 6130 INTEGER LENGTH, LABGEN 6140 INTEGER I, J, LAB, NLPAR 6150 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 6160 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 6170 INTEGER EXTDIG 6180 INTEGER INTDIG 6190 INTEGER EXTLET 6200 INTEGER INTLET 6210 INTEGER EXTBIG 6220 INTEGER INTBIG 6230 INTEGER EXTCHR 6240 INTEGER INTCHR 6250 INTEGER EXTBLK 6260 INTEGER INTBLK 6270 COMMON /CDEFIO/ BP, BUF(300) 6280 INTEGER BP 6290 INTEGER BUF 6300 COMMON /CFOR/ FORDEP, FORSTK(200) 6310 INTEGER FORDEP 6320 INTEGER FORSTK 6330 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 6340 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 6350 *UNTIL 6360 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 6370 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 6380 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 6390 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 6400 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 6410 INTEGER LEVEL 6420 INTEGER LINECT 6430 INTEGER INFILE 6440 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 6450 INTEGER LASTP 6460 INTEGER LASTT 6470 INTEGER NAMPTR 6480 INTEGER TABLE 6490 COMMON /COUTLN/ OUTP, OUTBUF(81) 6500 INTEGER OUTP 6510 INTEGER OUTBUF 6520 INTEGER IFNOT(9) 6530 DATA IFNOT(1) /105/ 6540 DATA IFNOT(2) /102/ 6550 DATA IFNOT(3) /40/ 6560 DATA IFNOT(4) /46/ 6570 DATA IFNOT(5) /110/ 6580 DATA IFNOT(6) /111/ 6590 DATA IFNOT(7) /116/ 6600 DATA IFNOT(8) /46/ 6610 DATA IFNOT(9) /10002/ 6620 LAB = LABGEN(3) 6630 CALL OUTCON(0) 6640 IF(.NOT.(GETTOK(TOKEN, 200) .NE. 40)) GOTO 23080 6650 CALL SYNERR(19HMISSING LEFT PAREN.) 6660 RETURN 6670 23080 CONTINUE 6680 IF(.NOT.(GETTOK(TOKEN, 200) .NE. 59)) GOTO 23082 6690 CALL PBSTR(TOKEN) 6700 CALL OUTTAB 6710 CALL EATUP 6720 CALL OUTDON 6730 23082 CONTINUE 6740 IF(.NOT.(GETTOK(TOKEN, 200) .EQ. 59)) GOTO 23084 6750 CALL OUTCON(LAB) 6760 GOTO 23085 6770 23084 CONTINUE 6780 CALL PBSTR(TOKEN) 6790 CALL OUTNUM(LAB) 6800 CALL OUTTAB 6810 CALL OUTSTR(IFNOT) 6820 CALL OUTCH(40) 6830 NLPAR = 0 6840 CONTINUE 6850 23086 IF(.NOT.(NLPAR .GE. 0)) GOTO 23087 6860 T = GETTOK(TOKEN, 200) 6870 IF(.NOT.(T .EQ. 59)) GOTO 23088 6880 GOTO 23087 6890 23088 CONTINUE 6900 IF(.NOT.(T .EQ. 40)) GOTO 23090 6910 NLPAR = NLPAR + 1 6920 GOTO 23091 6930 23090 CONTINUE 6940 IF(.NOT.(T .EQ. 41)) GOTO 23092 6950 NLPAR = NLPAR - 1 6960 23092 CONTINUE 6970 23091 CONTINUE 6980 IF(.NOT.(T .NE. 10 .AND. T .NE. 95)) GOTO 23094 6990 CALL OUTSTR(TOKEN) 7000 23094 CONTINUE 7010 GOTO 23086 7020 23087 CONTINUE 7030 CALL OUTCH(41) 7040 CALL OUTCH(41) 7050 CALL OUTGO(LAB+2) 7060 IF(.NOT.(NLPAR .LT. 0)) GOTO 23096 7070 CALL SYNERR(19HINVALID FOR CLAUSE.) 7080 23096 CONTINUE 7090 23085 CONTINUE 7100 FORDEP = FORDEP + 1 7110 J = 1 7120 CONTINUE 7130 I = 1 7140 23098 IF(.NOT.( I .LT. FORDEP)) GOTO 23100 7150 J = J + LENGTH(FORSTK(J)) + 1 7160 23099 I = I + 1 7170 GOTO 23098 7180 23100 CONTINUE 7190 FORSTK(J) = 10002 7200 NLPAR = 0 7210 CONTINUE 7220 23101 IF(.NOT.(NLPAR .GE. 0)) GOTO 23102 7230 T = GETTOK(TOKEN, 200) 7240 IF(.NOT.(T .EQ. 40)) GOTO 23103 7250 NLPAR = NLPAR + 1 7260 GOTO 23104 7270 23103 CONTINUE 7280 IF(.NOT.(T .EQ. 41)) GOTO 23105 7290 NLPAR = NLPAR - 1 7300 23105 CONTINUE 7310 23104 CONTINUE 7320 IF(.NOT.(NLPAR .GE. 0 .AND. T .NE. 10 .AND. T .NE. 95)) GOTO 231 7330 *07 7340 CALL SCOPY(TOKEN, 1, FORSTK, J) 7350 J = J + LENGTH(TOKEN) 7360 23107 CONTINUE 7370 GOTO 23101 7380 23102 CONTINUE 7390 LAB = LAB + 1 7400 RETURN 7410 END 7420 C 7430 C FORS - PROCESS END OF FOR STATEMENT 7440 C 7450 SUBROUTINE FORS(LAB) 7460 INTEGER LENGTH 7470 INTEGER I, J, LAB 7480 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 7490 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 7500 INTEGER EXTDIG 7510 INTEGER INTDIG 7520 INTEGER EXTLET 7530 INTEGER INTLET 7540 INTEGER EXTBIG 7550 INTEGER INTBIG 7560 INTEGER EXTCHR 7570 INTEGER INTCHR 7580 INTEGER EXTBLK 7590 INTEGER INTBLK 7600 COMMON /CDEFIO/ BP, BUF(300) 7610 INTEGER BP 7620 INTEGER BUF 7630 COMMON /CFOR/ FORDEP, FORSTK(200) 7640 INTEGER FORDEP 7650 INTEGER FORSTK 7660 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 7670 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 7680 *UNTIL 7690 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 7700 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 7710 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 7720 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 7730 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 7740 INTEGER LEVEL 7750 INTEGER LINECT 7760 INTEGER INFILE 7770 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 7780 INTEGER LASTP 7790 INTEGER LASTT 7800 INTEGER NAMPTR 7810 INTEGER TABLE 7820 COMMON /COUTLN/ OUTP, OUTBUF(81) 7830 INTEGER OUTP 7840 INTEGER OUTBUF 7850 CALL OUTNUM(LAB) 7860 J = 1 7870 CONTINUE 7880 I = 1 7890 23109 IF(.NOT.( I .LT. FORDEP)) GOTO 23111 7900 J = J + LENGTH(FORSTK(J)) + 1 7910 23110 I = I + 1 7920 GOTO 23109 7930 23111 CONTINUE 7940 IF(.NOT.(LENGTH(FORSTK(J)) .GT. 0)) GOTO 23112 7950 CALL OUTTAB 7960 CALL OUTSTR(FORSTK(J)) 7970 CALL OUTDON 7980 23112 CONTINUE 7990 CALL OUTGO(LAB-1) 8000 CALL OUTCON(LAB+1) 8010 FORDEP = FORDEP - 1 8020 RETURN 8030 END 8040 C 8050 C GETCH - GET CHARACTERS FROM FILE 8060 C 8070 INTEGER FUNCTION GETCH(C, F) 8080 INTEGER INMAP 8090 INTEGER BUF(81), C 8100 INTEGER F, I, LASTC 8110 DATA LASTC /81/, BUF(81) /10/ 8120 IF(.NOT.(BUF(LASTC) .EQ. 10 .OR. LASTC .GE. 81)) GOTO 23114 8130 READ(F, 1, END=10) (BUF(I), I = 1, 80) 8140 1 FORMAT(80 A1) 8150 CONTINUE 8160 I = 1 8170 23116 IF(.NOT.( I .LE. 80)) GOTO 23118 8180 BUF(I) = INMAP(BUF(I)) 8190 23117 I = I + 1 8200 GOTO 23116 8210 23118 CONTINUE 8220 CONTINUE 8230 I = 80 8240 23119 IF(.NOT.( I .GT. 0)) GOTO 23121 8250 IF(.NOT.(BUF(I) .NE. 32)) GOTO 23122 8260 GOTO 23121 8270 23122 CONTINUE 8280 23120 I = I - 1 8290 GOTO 23119 8300 23121 CONTINUE 8310 BUF(I+1) = 10 8320 LASTC = 0 8330 23114 CONTINUE 8340 LASTC = LASTC + 1 8350 C = BUF(LASTC) 8360 GETCH = C 8370 RETURN 8380 10 C = 10003 8390 GETCH = 10003 8400 RETURN 8410 END 8420 C 8430 C GETDEF (FOR NO ARGUMENTS) - GET NAME AND DEFINITION 8440 C 8450 SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD) 8460 INTEGER GTOK, NGETCH 8470 INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ 8480 INTEGER C, DEFN(DEFSIZ), TOKEN(TOKSIZ) 8490 IF(.NOT.(NGETCH(C, FD) .NE. 40)) GOTO 23124 8500 CALL REMARK(19HMISSING LEFT PAREN.) 8510 23124 CONTINUE 8520 IF(.NOT.(GTOK(TOKEN, TOKSIZ, FD) .NE. 10100)) GOTO 23126 8530 CALL REMARK(22HNON-ALPHANUMERIC NAME.) 8540 GOTO 23127 8550 23126 CONTINUE 8560 IF(.NOT.(NGETCH(C, FD) .NE. 44)) GOTO 23128 8570 CALL REMARK(24HMISSING COMMA IN DEFINE.) 8580 23128 CONTINUE 8590 23127 CONTINUE 8600 NLPAR = 0 8610 CONTINUE 8620 I = 1 8630 23130 IF(.NOT.( NLPAR .GE. 0)) GOTO 23132 8640 IF(.NOT.(I .GT. DEFSIZ)) GOTO 23133 8650 CALL ERROR(20HDEFINITION TOO LONG.) 8660 GOTO 23134 8670 23133 CONTINUE 8680 IF(.NOT.(NGETCH(DEFN(I), FD) .EQ. 10003)) GOTO 23135 8690 CALL ERROR(20HMISSING RIGHT PAREN.) 8700 GOTO 23136 8710 23135 CONTINUE 8720 IF(.NOT.(DEFN(I) .EQ. 40)) GOTO 23137 8730 NLPAR = NLPAR + 1 8740 GOTO 23138 8750 23137 CONTINUE 8760 IF(.NOT.(DEFN(I) .EQ. 41)) GOTO 23139 8770 NLPAR = NLPAR - 1 8780 23139 CONTINUE 8790 23138 CONTINUE 8800 23136 CONTINUE 8810 23134 CONTINUE 8820 23131 I = I + 1 8830 GOTO 23130 8840 23132 CONTINUE 8850 DEFN(I-1) = 10002 8860 RETURN 8870 END 8880 C 8890 C GETTOK - GET TOKEN. HANDLES FILE INCLUSION AND LINE NUMBERS 8900 C 8910 INTEGER FUNCTION GETTOK(TOKEN, TOKSIZ) 8920 INTEGER EQUAL, OPEN 8930 INTEGER JUNK, TOKSIZ 8940 INTEGER DEFTOK 8950 INTEGER NAME(30), TOKEN(TOKSIZ) 8960 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 8970 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 8980 INTEGER EXTDIG 8990 INTEGER INTDIG 9000 INTEGER EXTLET 9010 INTEGER INTLET 9020 INTEGER EXTBIG 9030 INTEGER INTBIG 9040 INTEGER EXTCHR 9050 INTEGER INTCHR 9060 INTEGER EXTBLK 9070 INTEGER INTBLK 9080 COMMON /CDEFIO/ BP, BUF(300) 9090 INTEGER BP 9100 INTEGER BUF 9110 COMMON /CFOR/ FORDEP, FORSTK(200) 9120 INTEGER FORDEP 9130 INTEGER FORSTK 9140 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 9150 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 9160 *UNTIL 9170 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 9180 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 9190 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 9200 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 9210 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 9220 INTEGER LEVEL 9230 INTEGER LINECT 9240 INTEGER INFILE 9250 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 9260 INTEGER LASTP 9270 INTEGER LASTT 9280 INTEGER NAMPTR 9290 INTEGER TABLE 9300 COMMON /COUTLN/ OUTP, OUTBUF(81) 9310 INTEGER OUTP 9320 INTEGER OUTBUF 9330 INTEGER INCL(8) 9340 DATA INCL(1) /105/ 9350 DATA INCL(2) /110/ 9360 DATA INCL(3) /99/ 9370 DATA INCL(4) /108/ 9380 DATA INCL(5) /117/ 9390 DATA INCL(6) /100/ 9400 DATA INCL(7) /101/ 9410 DATA INCL(8) /10002/ 9420 CONTINUE 9430 23141 IF(.NOT.( LEVEL .GT. 0)) GOTO 23143 9440 CONTINUE 9450 GETTOK = DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL)) 9460 23144 IF(.NOT.( GETTOK .NE. 10003)) GOTO 23146 9470 IF(.NOT.(EQUAL(TOKEN, INCL) .EQ. 0)) GOTO 23147 9480 RETURN 9490 23147 CONTINUE 9500 JUNK = DEFTOK(NAME, 30, INFILE(LEVEL)) 9510 IF(.NOT.(LEVEL .GE. 5)) GOTO 23149 9520 CALL SYNERR(27HINCLUDES NESTED TOO DEEPLY.) 9530 GOTO 23150 9540 23149 CONTINUE 9550 INFILE(LEVEL+1) = OPEN(NAME, 0) 9560 LINECT(LEVEL+1) = 1 9570 IF(.NOT.(INFILE(LEVEL+1) .EQ. 10001)) GOTO 23151 9580 CALL SYNERR(19HCAN'T OPEN INCLUDE.) 9590 GOTO 23152 9600 23151 CONTINUE 9610 LEVEL = LEVEL + 1 9620 23152 CONTINUE 9630 23150 CONTINUE 9640 23145 GETTOK = DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL)) 9650 GOTO 23144 9660 23146 CONTINUE 9670 IF(.NOT.(LEVEL .GT. 1)) GOTO 23153 9680 CALL CLOSE(INFILE(LEVEL)) 9690 23153 CONTINUE 9700 23142 LEVEL = LEVEL - 1 9710 GOTO 23141 9720 23143 CONTINUE 9730 GETTOK = 10003 9740 RETURN 9750 END 9760 C 9770 C GTOK - GET TOKEN FOR RATFOR 9780 C 9790 INTEGER FUNCTION GTOK(LEXSTR, TOKSIZ, FD) 9800 INTEGER NGETCH, TYPE 9810 INTEGER FD, I, TOKSIZ 9820 INTEGER C, LEXSTR(TOKSIZ) 9830 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 9840 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 9850 INTEGER EXTDIG 9860 INTEGER INTDIG 9870 INTEGER EXTLET 9880 INTEGER INTLET 9890 INTEGER EXTBIG 9900 INTEGER INTBIG 9910 INTEGER EXTCHR 9920 INTEGER INTCHR 9930 INTEGER EXTBLK 9940 INTEGER INTBLK 9950 COMMON /CDEFIO/ BP, BUF(300) 9960 INTEGER BP 9970 INTEGER BUF 9980 COMMON /CFOR/ FORDEP, FORSTK(200) 9990 INTEGER FORDEP 10000 INTEGER FORSTK 10010 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 10020 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 10030 *UNTIL 10040 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 10050 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 10060 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 10070 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 10080 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 10090 INTEGER LEVEL 10100 INTEGER LINECT 10110 INTEGER INFILE 10120 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 10130 INTEGER LASTP 10140 INTEGER LASTT 10150 INTEGER NAMPTR 10160 INTEGER TABLE 10170 COMMON /COUTLN/ OUTP, OUTBUF(81) 10180 INTEGER OUTP 10190 INTEGER OUTBUF 10200 CONTINUE 10210 23155 IF(.NOT.(NGETCH(C, FD) .NE. 10003)) GOTO 23156 10220 IF(.NOT.(C .NE. 32 .AND. C .NE. 9)) GOTO 23157 10230 GOTO 23156 10240 23157 CONTINUE 10250 GOTO 23155 10260 23156 CONTINUE 10270 CALL PUTBAK(C) 10280 CONTINUE 10290 I = 1 10300 23159 IF(.NOT.( I .LT. TOKSIZ-1)) GOTO 23161 10310 GTOK = TYPE(NGETCH(LEXSTR(I), FD)) 10320 IF(.NOT.(GTOK .NE. 1 .AND. GTOK .NE. 2)) GOTO 23162 10330 GOTO 23161 10340 23162 CONTINUE 10350 23160 I = I + 1 10360 GOTO 23159 10370 23161 CONTINUE 10380 IF(.NOT.(I .GE. TOKSIZ-1)) GOTO 23164 10390 CALL SYNERR(15HTOKEN TOO LONG.) 10400 23164 CONTINUE 10410 IF(.NOT.(I .GT. 1)) GOTO 23166 10420 CALL PUTBAK(LEXSTR(I)) 10430 LEXSTR(I) = 10002 10440 GTOK = 10100 10450 GOTO 23167 10460 23166 CONTINUE 10470 IF(.NOT.(LEXSTR(1) .EQ. 36)) GOTO 23168 10480 IF(.NOT.(NGETCH(LEXSTR(2), FD) .EQ. 40)) GOTO 23170 10490 LEXSTR(1) = 123 10500 GTOK = 123 10510 GOTO 23171 10520 23170 CONTINUE 10530 IF(.NOT.(LEXSTR(2) .EQ. 41)) GOTO 23172 10540 LEXSTR(1) = 125 10550 GTOK = 125 10560 GOTO 23173 10570 23172 CONTINUE 10580 CALL PUTBAK(LEXSTR(2)) 10590 23173 CONTINUE 10600 23171 CONTINUE 10610 GOTO 23169 10620 23168 CONTINUE 10630 IF(.NOT.(LEXSTR(1) .EQ. 39 .OR. LEXSTR(1) .EQ. 34)) GOTO 23174 10640 CONTINUE 10650 I = 2 10660 23176 IF(.NOT.( NGETCH(LEXSTR(I), FD) .NE. LEXSTR(1))) GOTO 23178 10670 IF(.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ-1)) GOTO 23179 10680 CALL SYNERR(14HMISSING QUOTE.) 10690 LEXSTR(I) = LEXSTR(1) 10700 CALL PUTBAK(10) 10710 GOTO 23178 10720 23179 CONTINUE 10730 23177 I = I + 1 10740 GOTO 23176 10750 23178 CONTINUE 10760 GOTO 23175 10770 23174 CONTINUE 10780 IF(.NOT.(LEXSTR(1) .EQ. 35)) GOTO 23181 10790 CONTINUE 10800 23183 IF(.NOT.(NGETCH(LEXSTR(1), FD) .NE. 10)) GOTO 23184 10810 GOTO 23183 10820 23184 CONTINUE 10830 GTOK = 10 10840 GOTO 23182 10850 23181 CONTINUE 10860 IF(.NOT.(LEXSTR(1) .EQ. 62 .OR. LEXSTR(1) .EQ. 60 .OR. LEXSTR(1) 10870 *.EQ. 33 .OR. LEXSTR(1) .EQ. 61 .OR. LEXSTR(1) .EQ. 38 .OR. LE 10880 *XSTR(1) .EQ. 124)) GOTO 23185 10890 CALL RELATE(LEXSTR, I, FD) 10900 23185 CONTINUE 10910 23182 CONTINUE 10920 23175 CONTINUE 10930 23169 CONTINUE 10940 23167 CONTINUE 10950 LEXSTR(I+1) = 10002 10960 IF(.NOT.(LEXSTR(1) .EQ. 10)) GOTO 23187 10970 LINECT(LEVEL) = LINECT(LEVEL) + 1 10980 23187 CONTINUE 10990 RETURN 11000 END 11010 C 11020 C IFCODE - GENERATE INITIAL CODE FOR IF 11030 C 11040 SUBROUTINE IFCODE(LAB) 11050 INTEGER LABGEN 11060 INTEGER LAB 11070 LAB = LABGEN(2) 11080 CALL IFGO(LAB) 11090 RETURN 11100 END 11110 C 11120 C IFGO - GENERATE "IF(.NOT.(...))GOTO LAB" 11130 C 11140 SUBROUTINE IFGO(LAB) 11150 INTEGER LAB 11160 INTEGER IFNOT(9) 11170 DATA IFNOT(1) /105/ 11180 DATA IFNOT(2) /102/ 11190 DATA IFNOT(3) /40/ 11200 DATA IFNOT(4) /46/ 11210 DATA IFNOT(5) /110/ 11220 DATA IFNOT(6) /111/ 11230 DATA IFNOT(7) /116/ 11240 DATA IFNOT(8) /46/ 11250 DATA IFNOT(9) /10002/ 11260 CALL OUTTAB 11270 CALL OUTSTR(IFNOT) 11280 CALL BALPAR 11290 CALL OUTCH(41) 11300 CALL OUTGO(LAB) 11310 RETURN 11320 END 11330 C 11340 C INDEX - FIND CHARACTER C IN STRING STR 11350 C 11360 INTEGER FUNCTION INDEX(STR, C) 11370 INTEGER C, STR(100) 11380 CONTINUE 11390 INDEX = 1 11400 23189 IF(.NOT.( STR(INDEX) .NE. 10002)) GOTO 23191 11410 IF(.NOT.(STR(INDEX) .EQ. C)) GOTO 23192 11420 RETURN 11430 23192 CONTINUE 11440 23190 INDEX = INDEX + 1 11450 GOTO 23189 11460 23191 CONTINUE 11470 INDEX = 0 11480 RETURN 11490 END 11500 C 11510 C INITKW - INSTALL KEYWORD "DEFINE" IN TABLE 11520 C 11530 SUBROUTINE INITKW 11540 INTEGER DEFNAM(7), DEFTYP(2) 11550 DATA DEFNAM(1) /100/, DEFNAM(2) /101/, DEFNAM(3) /102/ 11560 DATA DEFNAM(4) /105/, DEFNAM(5) /110/, DEFNAM(6) /101/ 11570 DATA DEFNAM(7) /10002/ 11580 DATA DEFTYP(1), DEFTYP(2) /10010, 10002/ 11590 CALL INSTAL(DEFNAM, DEFTYP) 11600 RETURN 11610 END 11620 C 11630 C INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII 11640 C 11650 INTEGER FUNCTION INMAP(INCHAR) 11660 INTEGER I, INCHAR 11670 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 11680 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 11690 INTEGER EXTDIG 11700 INTEGER INTDIG 11710 INTEGER EXTLET 11720 INTEGER INTLET 11730 INTEGER EXTBIG 11740 INTEGER INTBIG 11750 INTEGER EXTCHR 11760 INTEGER INTCHR 11770 INTEGER EXTBLK 11780 INTEGER INTBLK 11790 COMMON /CDEFIO/ BP, BUF(300) 11800 INTEGER BP 11810 INTEGER BUF 11820 COMMON /CFOR/ FORDEP, FORSTK(200) 11830 INTEGER FORDEP 11840 INTEGER FORSTK 11850 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 11860 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 11870 *UNTIL 11880 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 11890 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 11900 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 11910 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 11920 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 11930 INTEGER LEVEL 11940 INTEGER LINECT 11950 INTEGER INFILE 11960 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 11970 INTEGER LASTP 11980 INTEGER LASTT 11990 INTEGER NAMPTR 12000 INTEGER TABLE 12010 COMMON /COUTLN/ OUTP, OUTBUF(81) 12020 INTEGER OUTP 12030 INTEGER OUTBUF 12040 IF(.NOT.(INCHAR .EQ. EXTBLK)) GOTO 23194 12050 INMAP = INTBLK 12060 RETURN 12070 23194 CONTINUE 12080 DO23196I = 1, 10 12090 IF(.NOT.(INCHAR .EQ. EXTDIG(I))) GOTO 23198 12100 INMAP = INTDIG(I) 12110 RETURN 12120 23198 CONTINUE 12130 23196 CONTINUE 12140 23197 CONTINUE 12150 DO23200I = 1, 26 12160 IF(.NOT.(INCHAR .EQ. EXTLET(I))) GOTO 23202 12170 INMAP = INTLET(I) 12180 RETURN 12190 23202 CONTINUE 12200 23200 CONTINUE 12210 23201 CONTINUE 12220 DO23204I = 1, 26 12230 IF(.NOT.(INCHAR .EQ. EXTBIG(I))) GOTO 23206 12240 INMAP = INTBIG(I) 12250 RETURN 12260 23206 CONTINUE 12270 23204 CONTINUE 12280 23205 CONTINUE 12290 DO23208I = 1, 33 12300 IF(.NOT.(INCHAR .EQ. EXTCHR(I))) GOTO 23210 12310 INMAP = INTCHR(I) 12320 RETURN 12330 23210 CONTINUE 12340 23208 CONTINUE 12350 23209 CONTINUE 12360 INMAP = INCHAR 12370 RETURN 12380 END 12390 C 12400 C INSTAL - ADD NAME AND DEFINITION TO TABLE 12410 C 12420 SUBROUTINE INSTAL(NAME, DEFN) 12430 INTEGER DEFN(200), NAME(200) 12440 INTEGER LENGTH 12450 INTEGER DLEN, NLEN 12460 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 12470 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 12480 INTEGER EXTDIG 12490 INTEGER INTDIG 12500 INTEGER EXTLET 12510 INTEGER INTLET 12520 INTEGER EXTBIG 12530 INTEGER INTBIG 12540 INTEGER EXTCHR 12550 INTEGER INTCHR 12560 INTEGER EXTBLK 12570 INTEGER INTBLK 12580 COMMON /CDEFIO/ BP, BUF(300) 12590 INTEGER BP 12600 INTEGER BUF 12610 COMMON /CFOR/ FORDEP, FORSTK(200) 12620 INTEGER FORDEP 12630 INTEGER FORSTK 12640 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 12650 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 12660 *UNTIL 12670 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 12680 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 12690 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 12700 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 12710 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 12720 INTEGER LEVEL 12730 INTEGER LINECT 12740 INTEGER INFILE 12750 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 12760 INTEGER LASTP 12770 INTEGER LASTT 12780 INTEGER NAMPTR 12790 INTEGER TABLE 12800 COMMON /COUTLN/ OUTP, OUTBUF(81) 12810 INTEGER OUTP 12820 INTEGER OUTBUF 12830 NLEN = LENGTH(NAME) + 1 12840 DLEN = LENGTH(DEFN) + 1 12850 IF(.NOT.(LASTT + NLEN + DLEN .GT. 1500 .OR. LASTP .GE. 200)) GO 12860 *TO 23212 12870 CALL PUTLIN(NAME, 6) 12880 CALL REMARK(23H: TOO MANY DEFINITIONS.) 12890 23212 CONTINUE 12900 LASTP = LASTP + 1 12910 NAMPTR(LASTP) = LASTT + 1 12920 CALL SCOPY(NAME, 1, TABLE, LASTT + 1) 12930 CALL SCOPY(DEFN, 1, TABLE, LASTT + NLEN + 1) 12940 LASTT = LASTT + NLEN + DLEN 12950 RETURN 12960 END 12970 C 12980 C ITOC - CONVERT INTEGER INT TO CHAR STRING IN STR 12990 C 13000 INTEGER FUNCTION ITOC(INT, STR, SIZE) 13010 INTEGER IABS, MOD 13020 INTEGER D, I, INT, INTVAL, J, K, SIZE 13030 INTEGER STR(SIZE) 13040 INTEGER DIGITS(11) 13050 DATA DIGITS(1) /48/ 13060 DATA DIGITS(2) /49/ 13070 DATA DIGITS(3) /50/ 13080 DATA DIGITS(4) /51/ 13090 DATA DIGITS(5) /52/ 13100 DATA DIGITS(6) /53/ 13110 DATA DIGITS(7) /54/ 13120 DATA DIGITS(8) /55/ 13130 DATA DIGITS(9) /56/ 13140 DATA DIGITS(10) /57/ 13150 DATA DIGITS(11) /10002/ 13160 INTVAL = IABS(INT) 13170 STR(1) = 10002 13180 I = 1 13190 CONTINUE 13200 23214 CONTINUE 13210 I = I + 1 13220 D = MOD(INTVAL, 10) 13230 STR(I) = DIGITS(D+1) 13240 INTVAL = INTVAL / 10 13250 23215 IF(.NOT.(INTVAL .EQ. 0 .OR. I .GE. SIZE)) GOTO 23214 13260 23216 CONTINUE 13270 IF(.NOT.(INT .LT. 0 .AND. I .LT. SIZE)) GOTO 23217 13280 I = I + 1 13290 STR(I) = 45 13300 23217 CONTINUE 13310 ITOC = I - 1 13320 CONTINUE 13330 J = 1 13340 23219 IF(.NOT.( J .LT. I)) GOTO 23221 13350 K = STR(I) 13360 STR(I) = STR(J) 13370 STR(J) = K 13380 I = I - 1 13390 23220 J = J + 1 13400 GOTO 23219 13410 23221 CONTINUE 13420 RETURN 13430 END 13440 C 13450 C LABELC - OUTPUT STATEMENT NUMBER 13460 C 13470 SUBROUTINE LABELC(LEXSTR) 13480 INTEGER LEXSTR(100) 13490 INTEGER LENGTH 13500 IF(.NOT.(LENGTH(LEXSTR) .EQ. 5)) GOTO 23222 13510 IF(.NOT.(LEXSTR(1) .EQ. 50 .AND. LEXSTR(2) .EQ. 51)) GOTO 23224 13520 CALL SYNERR(33HWARNING: POSSIBLE LABEL CONFLICT.) 13530 23224 CONTINUE 13540 23222 CONTINUE 13550 CALL OUTSTR(LEXSTR) 13560 CALL OUTTAB 13570 RETURN 13580 END 13590 C 13600 C LABGEN - GENERATE N CONSECUTIVE LABELS, RETURN FIRST ONE 13610 C 13620 INTEGER FUNCTION LABGEN(N) 13630 INTEGER LABEL, N 13640 DATA LABEL /23000/ 13650 LABGEN = LABEL 13660 LABEL = LABEL + N 13670 RETURN 13680 END 13690 C 13700 C LENGTH - COMPUTE LENGTH OF STRING 13710 C 13720 INTEGER FUNCTION LENGTH(STR) 13730 INTEGER STR(100) 13740 CONTINUE 13750 LENGTH = 0 13760 23226 IF(.NOT.( STR(LENGTH+1) .NE. 10002)) GOTO 23228 13770 23227 LENGTH = LENGTH + 1 13780 GOTO 23226 13790 23228 CONTINUE 13800 RETURN 13810 END 13820 C 13830 C LEX - RETURN LEXICAL TYPE OF TOKEN 13840 C 13850 INTEGER FUNCTION LEX(LEXSTR) 13860 INTEGER GETTOK 13870 INTEGER LEXSTR(200) 13880 INTEGER ALLDIG, EQUAL 13890 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 13900 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 13910 INTEGER EXTDIG 13920 INTEGER INTDIG 13930 INTEGER EXTLET 13940 INTEGER INTLET 13950 INTEGER EXTBIG 13960 INTEGER INTBIG 13970 INTEGER EXTCHR 13980 INTEGER INTCHR 13990 INTEGER EXTBLK 14000 INTEGER INTBLK 14010 COMMON /CDEFIO/ BP, BUF(300) 14020 INTEGER BP 14030 INTEGER BUF 14040 COMMON /CFOR/ FORDEP, FORSTK(200) 14050 INTEGER FORDEP 14060 INTEGER FORSTK 14070 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 14080 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 14090 *UNTIL 14100 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 14110 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 14120 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 14130 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 14140 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 14150 INTEGER LEVEL 14160 INTEGER LINECT 14170 INTEGER INFILE 14180 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 14190 INTEGER LASTP 14200 INTEGER LASTT 14210 INTEGER NAMPTR 14220 INTEGER TABLE 14230 COMMON /COUTLN/ OUTP, OUTBUF(81) 14240 INTEGER OUTP 14250 INTEGER OUTBUF 14260 CONTINUE 14270 23229 IF(.NOT.(GETTOK(LEXSTR, 200) .EQ. 10)) GOTO 23230 14280 GOTO 23229 14290 23230 CONTINUE 14300 LEX = LEXSTR(1) 14310 IF(.NOT.(LEX.EQ.10003 .OR. LEX.EQ.59 .OR. LEX.EQ.123 .OR. LEX.EQ. 14320 *125)) GOTO 23231 14330 RETURN 14340 23231 CONTINUE 14350 IF(.NOT.(ALLDIG(LEXSTR) .EQ. 1)) GOTO 23233 14360 LEX = 10260 14370 GOTO 23234 14380 23233 CONTINUE 14390 IF(.NOT.(EQUAL(LEXSTR, SIF) .EQ. 1)) GOTO 23235 14400 LEX = VIF(1) 14410 GOTO 23236 14420 23235 CONTINUE 14430 IF(.NOT.(EQUAL(LEXSTR, SELSE) .EQ. 1)) GOTO 23237 14440 LEX = VELSE(1) 14450 GOTO 23238 14460 23237 CONTINUE 14470 IF(.NOT.(EQUAL(LEXSTR, SWHILE) .EQ. 1)) GOTO 23239 14480 LEX = VWHILE(1) 14490 GOTO 23240 14500 23239 CONTINUE 14510 IF(.NOT.(EQUAL(LEXSTR, SDO) .EQ. 1)) GOTO 23241 14520 LEX = VDO(1) 14530 GOTO 23242 14540 23241 CONTINUE 14550 IF(.NOT.(EQUAL(LEXSTR, SBREAK) .EQ. 1)) GOTO 23243 14560 LEX = VBREAK(1) 14570 GOTO 23244 14580 23243 CONTINUE 14590 IF(.NOT.(EQUAL(LEXSTR, SNEXT) .EQ. 1)) GOTO 23245 14600 LEX = VNEXT(1) 14610 GOTO 23246 14620 23245 CONTINUE 14630 IF(.NOT.(EQUAL(LEXSTR, SFOR) .EQ. 1)) GOTO 23247 14640 LEX = VFOR(1) 14650 GOTO 23248 14660 23247 CONTINUE 14670 IF(.NOT.(EQUAL(LEXSTR, SREPT) .EQ. 1)) GOTO 23249 14680 LEX = VREPT(1) 14690 GOTO 23250 14700 23249 CONTINUE 14710 IF(.NOT.(EQUAL(LEXSTR, SUNTIL) .EQ. 1)) GOTO 23251 14720 LEX = VUNTIL(1) 14730 GOTO 23252 14740 23251 CONTINUE 14750 LEX = 10267 14760 23252 CONTINUE 14770 23250 CONTINUE 14780 23248 CONTINUE 14790 23246 CONTINUE 14800 23244 CONTINUE 14810 23242 CONTINUE 14820 23240 CONTINUE 14830 23238 CONTINUE 14840 23236 CONTINUE 14850 23234 CONTINUE 14860 RETURN 14870 END 14880 C 14890 C LOOKUP - LOCATE NAME, EXTRACT DEFINITION FROM TABLE 14900 C 14910 INTEGER FUNCTION LOOKUP(NAME, DEFN) 14920 INTEGER DEFN(200), NAME(200) 14930 INTEGER I, J, K 14940 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 14950 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 14960 INTEGER EXTDIG 14970 INTEGER INTDIG 14980 INTEGER EXTLET 14990 INTEGER INTLET 15000 INTEGER EXTBIG 15010 INTEGER INTBIG 15020 INTEGER EXTCHR 15030 INTEGER INTCHR 15040 INTEGER EXTBLK 15050 INTEGER INTBLK 15060 COMMON /CDEFIO/ BP, BUF(300) 15070 INTEGER BP 15080 INTEGER BUF 15090 COMMON /CFOR/ FORDEP, FORSTK(200) 15100 INTEGER FORDEP 15110 INTEGER FORSTK 15120 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 15130 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 15140 *UNTIL 15150 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 15160 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 15170 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 15180 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 15190 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 15200 INTEGER LEVEL 15210 INTEGER LINECT 15220 INTEGER INFILE 15230 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 15240 INTEGER LASTP 15250 INTEGER LASTT 15260 INTEGER NAMPTR 15270 INTEGER TABLE 15280 COMMON /COUTLN/ OUTP, OUTBUF(81) 15290 INTEGER OUTP 15300 INTEGER OUTBUF 15310 CONTINUE 15320 I = LASTP 15330 23253 IF(.NOT.( I .GT. 0)) GOTO 23255 15340 J = NAMPTR(I) 15350 CONTINUE 15360 K = 1 15370 23256 IF(.NOT.( NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 10002)) GOTO 15380 *23258 15390 J = J + 1 15400 23257 K = K + 1 15410 GOTO 23256 15420 23258 CONTINUE 15430 IF(.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 23259 15440 CALL SCOPY(TABLE, J+1, DEFN, 1) 15450 LOOKUP = 1 15460 RETURN 15470 23259 CONTINUE 15480 23254 I = I - 1 15490 GOTO 23253 15500 23255 CONTINUE 15510 LOOKUP = 0 15520 RETURN 15530 END 15540 C 15550 C NGETCH - GET A (POSSIBLY PUSHED BACK) CHARACTER 15560 C 15570 INTEGER FUNCTION NGETCH(C, FD) 15580 INTEGER GETCH 15590 INTEGER C 15600 INTEGER FD 15610 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 15620 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 15630 INTEGER EXTDIG 15640 INTEGER INTDIG 15650 INTEGER EXTLET 15660 INTEGER INTLET 15670 INTEGER EXTBIG 15680 INTEGER INTBIG 15690 INTEGER EXTCHR 15700 INTEGER INTCHR 15710 INTEGER EXTBLK 15720 INTEGER INTBLK 15730 COMMON /CDEFIO/ BP, BUF(300) 15740 INTEGER BP 15750 INTEGER BUF 15760 COMMON /CFOR/ FORDEP, FORSTK(200) 15770 INTEGER FORDEP 15780 INTEGER FORSTK 15790 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 15800 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 15810 *UNTIL 15820 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 15830 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 15840 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 15850 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 15860 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 15870 INTEGER LEVEL 15880 INTEGER LINECT 15890 INTEGER INFILE 15900 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 15910 INTEGER LASTP 15920 INTEGER LASTT 15930 INTEGER NAMPTR 15940 INTEGER TABLE 15950 COMMON /COUTLN/ OUTP, OUTBUF(81) 15960 INTEGER OUTP 15970 INTEGER OUTBUF 15980 IF(.NOT.(BP .GT. 0)) GOTO 23261 15990 C = BUF(BP) 16000 GOTO 23262 16010 23261 CONTINUE 16020 BP = 1 16030 BUF(BP) = GETCH(C, FD) 16040 23262 CONTINUE 16050 BP = BP - 1 16060 NGETCH = C 16070 RETURN 16080 END 16090 C 16100 C OPEN - EXCEEDINGLY TEMPORARY VERSION FOR GETTOK 16110 C 16120 INTEGER FUNCTION OPEN(NAME, MODE) 16130 INTEGER NAME(30) 16140 INTEGER CTOI 16150 INTEGER I, MODE 16160 I = 1 16170 OPEN = CTOI(NAME, I) 16180 RETURN 16190 END 16200 C 16210 C OTHERC - OUTPUT ORDINARY FORTRAN STATEMENT 16220 C 16230 SUBROUTINE OTHERC(LEXSTR) 16240 INTEGER LEXSTR(100) 16250 CALL OUTTAB 16260 CALL OUTSTR(LEXSTR) 16270 CALL EATUP 16280 CALL OUTDON 16290 RETURN 16300 END 16310 C 16320 C OUTCH - PUT ONE CHARACTER INTO OUTPUT BUFFER 16330 C 16340 SUBROUTINE OUTCH(C) 16350 INTEGER C 16360 INTEGER I 16370 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 16380 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 16390 INTEGER EXTDIG 16400 INTEGER INTDIG 16410 INTEGER EXTLET 16420 INTEGER INTLET 16430 INTEGER EXTBIG 16440 INTEGER INTBIG 16450 INTEGER EXTCHR 16460 INTEGER INTCHR 16470 INTEGER EXTBLK 16480 INTEGER INTBLK 16490 COMMON /CDEFIO/ BP, BUF(300) 16500 INTEGER BP 16510 INTEGER BUF 16520 COMMON /CFOR/ FORDEP, FORSTK(200) 16530 INTEGER FORDEP 16540 INTEGER FORSTK 16550 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 16560 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 16570 *UNTIL 16580 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 16590 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 16600 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 16610 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 16620 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 16630 INTEGER LEVEL 16640 INTEGER LINECT 16650 INTEGER INFILE 16660 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 16670 INTEGER LASTP 16680 INTEGER LASTT 16690 INTEGER NAMPTR 16700 INTEGER TABLE 16710 COMMON /COUTLN/ OUTP, OUTBUF(81) 16720 INTEGER OUTP 16730 INTEGER OUTBUF 16740 IF(.NOT.(OUTP .GE. 72)) GOTO 23263 16750 CALL OUTDON 16760 CONTINUE 16770 I = 1 16780 23265 IF(.NOT.( I .LT. 6)) GOTO 23267 16790 OUTBUF(I) = 32 16800 23266 I = I + 1 16810 GOTO 23265 16820 23267 CONTINUE 16830 OUTBUF(6) = 42 16840 OUTP = 6 16850 23263 CONTINUE 16860 OUTP = OUTP + 1 16870 OUTBUF(OUTP) = C 16880 RETURN 16890 END 16900 C 16910 C OUTCON - OUTPUT "N CONTINUE" 16920 C 16930 SUBROUTINE OUTCON(N) 16940 INTEGER N 16950 INTEGER CONTIN(9) 16960 DATA CONTIN(1) /99/ 16970 DATA CONTIN(2) /111/ 16980 DATA CONTIN(3) /110/ 16990 DATA CONTIN(4) /116/ 17000 DATA CONTIN(5) /105/ 17010 DATA CONTIN(6) /110/ 17020 DATA CONTIN(7) /117/ 17030 DATA CONTIN(8) /101/ 17040 DATA CONTIN(9) /10002/ 17050 IF(.NOT.(N .GT. 0)) GOTO 23268 17060 CALL OUTNUM(N) 17070 23268 CONTINUE 17080 CALL OUTTAB 17090 CALL OUTSTR(CONTIN) 17100 CALL OUTDON 17110 RETURN 17120 END 17130 C 17140 C OUTDON - FINISH OFF AN OUTPUT LINE 17150 C 17160 SUBROUTINE OUTDON 17170 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 17180 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 17190 INTEGER EXTDIG 17200 INTEGER INTDIG 17210 INTEGER EXTLET 17220 INTEGER INTLET 17230 INTEGER EXTBIG 17240 INTEGER INTBIG 17250 INTEGER EXTCHR 17260 INTEGER INTCHR 17270 INTEGER EXTBLK 17280 INTEGER INTBLK 17290 COMMON /CDEFIO/ BP, BUF(300) 17300 INTEGER BP 17310 INTEGER BUF 17320 COMMON /CFOR/ FORDEP, FORSTK(200) 17330 INTEGER FORDEP 17340 INTEGER FORSTK 17350 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 17360 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 17370 *UNTIL 17380 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 17390 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 17400 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 17410 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 17420 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 17430 INTEGER LEVEL 17440 INTEGER LINECT 17450 INTEGER INFILE 17460 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 17470 INTEGER LASTP 17480 INTEGER LASTT 17490 INTEGER NAMPTR 17500 INTEGER TABLE 17510 COMMON /COUTLN/ OUTP, OUTBUF(81) 17520 INTEGER OUTP 17530 INTEGER OUTBUF 17540 OUTBUF(OUTP+1) = 10 17550 OUTBUF(OUTP+2) = 10002 17560 CALL PUTLIN(OUTBUF, 6) 17570 OUTP = 0 17580 RETURN 17590 END 17600 C 17610 C OUTGO - OUTPUT "GOTO N" 17620 C 17630 SUBROUTINE OUTGO(N) 17640 INTEGER N 17650 INTEGER GOTO(6) 17660 DATA GOTO(1) /103/ 17670 DATA GOTO(2) /111/ 17680 DATA GOTO(3) /116/ 17690 DATA GOTO(4) /111/ 17700 DATA GOTO(5) /32/ 17710 DATA GOTO(6) /10002/ 17720 CALL OUTTAB 17730 CALL OUTSTR(GOTO) 17740 CALL OUTNUM(N) 17750 CALL OUTDON 17760 RETURN 17770 END 17780 C 17790 C OUTMAP - CONVERT RIGHT ADJ ASCII TO LEFT ADJUSTED EXTERNAL REP 17800 C 17810 INTEGER FUNCTION OUTMAP(INCHAR) 17820 INTEGER I, INCHAR 17830 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 17840 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 17850 INTEGER EXTDIG 17860 INTEGER INTDIG 17870 INTEGER EXTLET 17880 INTEGER INTLET 17890 INTEGER EXTBIG 17900 INTEGER INTBIG 17910 INTEGER EXTCHR 17920 INTEGER INTCHR 17930 INTEGER EXTBLK 17940 INTEGER INTBLK 17950 COMMON /CDEFIO/ BP, BUF(300) 17960 INTEGER BP 17970 INTEGER BUF 17980 COMMON /CFOR/ FORDEP, FORSTK(200) 17990 INTEGER FORDEP 18000 INTEGER FORSTK 18010 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 18020 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 18030 *UNTIL 18040 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 18050 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 18060 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 18070 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 18080 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 18090 INTEGER LEVEL 18100 INTEGER LINECT 18110 INTEGER INFILE 18120 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 18130 INTEGER LASTP 18140 INTEGER LASTT 18150 INTEGER NAMPTR 18160 INTEGER TABLE 18170 COMMON /COUTLN/ OUTP, OUTBUF(81) 18180 INTEGER OUTP 18190 INTEGER OUTBUF 18200 IF(.NOT.(INCHAR .EQ. INTBLK)) GOTO 23270 18210 OUTMAP = EXTBLK 18220 RETURN 18230 23270 CONTINUE 18240 DO23272I = 1, 10 18250 IF(.NOT.(INCHAR .EQ. INTDIG(I))) GOTO 23274 18260 OUTMAP = EXTDIG(I) 18270 RETURN 18280 23274 CONTINUE 18290 23272 CONTINUE 18300 23273 CONTINUE 18310 DO23276I = 1, 26 18320 IF(.NOT.(INCHAR .EQ. INTLET(I))) GOTO 23278 18330 OUTMAP = EXTLET(I) 18340 RETURN 18350 23278 CONTINUE 18360 23276 CONTINUE 18370 23277 CONTINUE 18380 DO23280I = 1, 26 18390 IF(.NOT.(INCHAR .EQ. INTBIG(I))) GOTO 23282 18400 OUTMAP = EXTBIG(I) 18410 RETURN 18420 23282 CONTINUE 18430 23280 CONTINUE 18440 23281 CONTINUE 18450 DO23284I = 1, 33 18460 IF(.NOT.(INCHAR .EQ. INTCHR(I))) GOTO 23286 18470 OUTMAP = EXTCHR(I) 18480 RETURN 18490 23286 CONTINUE 18500 23284 CONTINUE 18510 23285 CONTINUE 18520 OUTMAP = INCHAR 18530 RETURN 18540 END 18550 C 18560 C OUTNUM - OUTPUT DECIMAL NUMBER 18570 C 18580 SUBROUTINE OUTNUM(N) 18590 INTEGER CHARS(10) 18600 INTEGER ITOC 18610 INTEGER I, LEN, N 18620 LEN = ITOC(N, CHARS, 10) 18630 CONTINUE 18640 I = 1 18650 23288 IF(.NOT.( I .LE. LEN)) GOTO 23290 18660 CALL OUTCH(CHARS(I)) 18670 23289 I = I + 1 18680 GOTO 23288 18690 23290 CONTINUE 18700 RETURN 18710 END 18720 C 18730 C OUTSTR - OUTPUT STRING 18740 C 18750 SUBROUTINE OUTSTR(STR) 18760 INTEGER C, STR(100) 18770 INTEGER I, J 18780 CONTINUE 18790 I = 1 18800 23291 IF(.NOT.( STR(I) .NE. 10002)) GOTO 23293 18810 C = STR(I) 18820 IF(.NOT.(C .NE. 39 .AND. C .NE. 34)) GOTO 23294 18830 CALL OUTCH(C) 18840 GOTO 23295 18850 23294 CONTINUE 18860 I = I + 1 18870 CONTINUE 18880 J = I 18890 23296 IF(.NOT.( STR(J) .NE. C)) GOTO 23298 18900 23297 J = J + 1 18910 GOTO 23296 18920 23298 CONTINUE 18930 CALL OUTNUM(J-I) 18940 CALL OUTCH(104) 18950 CONTINUE 18960 23299 IF(.NOT.( I .LT. J)) GOTO 23301 18970 CALL OUTCH(STR(I)) 18980 23300 I = I + 1 18990 GOTO 23299 19000 23301 CONTINUE 19010 23295 CONTINUE 19020 23292 I = I + 1 19030 GOTO 23291 19040 23293 CONTINUE 19050 RETURN 19060 END 19070 C 19080 C OUTTAB - GET PAST COLUMN 6 19090 C 19100 SUBROUTINE OUTTAB 19110 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 19120 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 19130 INTEGER EXTDIG 19140 INTEGER INTDIG 19150 INTEGER EXTLET 19160 INTEGER INTLET 19170 INTEGER EXTBIG 19180 INTEGER INTBIG 19190 INTEGER EXTCHR 19200 INTEGER INTCHR 19210 INTEGER EXTBLK 19220 INTEGER INTBLK 19230 COMMON /CDEFIO/ BP, BUF(300) 19240 INTEGER BP 19250 INTEGER BUF 19260 COMMON /CFOR/ FORDEP, FORSTK(200) 19270 INTEGER FORDEP 19280 INTEGER FORSTK 19290 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 19300 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 19310 *UNTIL 19320 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 19330 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 19340 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 19350 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 19360 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 19370 INTEGER LEVEL 19380 INTEGER LINECT 19390 INTEGER INFILE 19400 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 19410 INTEGER LASTP 19420 INTEGER LASTT 19430 INTEGER NAMPTR 19440 INTEGER TABLE 19450 COMMON /COUTLN/ OUTP, OUTBUF(81) 19460 INTEGER OUTP 19470 INTEGER OUTBUF 19480 CONTINUE 19490 23302 IF(.NOT.(OUTP .LT. 6)) GOTO 23303 19500 CALL OUTCH(32) 19510 GOTO 23302 19520 23303 CONTINUE 19530 RETURN 19540 END 19550 C 19560 C PARSE - PARSE RATFOR SOURCE PROGRAM 19570 C 19580 SUBROUTINE PARSE 19590 INTEGER LEXSTR(200) 19600 INTEGER LEX 19610 INTEGER LAB, LABVAL(100), LEXTYP(100), SP, TOKEN 19620 CALL INITKW 19630 SP = 1 19640 LEXTYP(1) = 10003 19650 CONTINUE 19660 TOKEN = LEX(LEXSTR) 19670 23304 IF(.NOT.( TOKEN .NE. 10003)) GOTO 23306 19680 IF(.NOT.(TOKEN .EQ. 10261)) GOTO 23307 19690 CALL IFCODE(LAB) 19700 GOTO 23308 19710 23307 CONTINUE 19720 IF(.NOT.(TOKEN .EQ. 10266)) GOTO 23309 19730 CALL DOCODE(LAB) 19740 GOTO 23310 19750 23309 CONTINUE 19760 IF(.NOT.(TOKEN .EQ. 10263)) GOTO 23311 19770 CALL WHILEC(LAB) 19780 GOTO 23312 19790 23311 CONTINUE 19800 IF(.NOT.(TOKEN .EQ. 10268)) GOTO 23313 19810 CALL FORCOD(LAB) 19820 GOTO 23314 19830 23313 CONTINUE 19840 IF(.NOT.(TOKEN .EQ. 10269)) GOTO 23315 19850 CALL REPCOD(LAB) 19860 GOTO 23316 19870 23315 CONTINUE 19880 IF(.NOT.(TOKEN .EQ. 10260)) GOTO 23317 19890 CALL LABELC(LEXSTR) 19900 GOTO 23318 19910 23317 CONTINUE 19920 IF(.NOT.(TOKEN .EQ. 10262)) GOTO 23319 19930 IF(.NOT.(LEXTYP(SP) .EQ. 10261)) GOTO 23321 19940 CALL ELSEIF(LABVAL(SP)) 19950 GOTO 23322 19960 23321 CONTINUE 19970 CALL SYNERR(13HILLEGAL ELSE.) 19980 23322 CONTINUE 19990 23319 CONTINUE 20000 23318 CONTINUE 20010 23316 CONTINUE 20020 23314 CONTINUE 20030 23312 CONTINUE 20040 23310 CONTINUE 20050 23308 CONTINUE 20060 IF(.NOT.(TOKEN.EQ.10261 .OR. TOKEN.EQ.10262 .OR. TOKEN.EQ.10263 20070 * .OR. TOKEN.EQ.10268 .OR. TOKEN.EQ.10269 .OR. TOKEN.E 20080 *Q.10266 .OR. TOKEN.EQ.10260 .OR. TOKEN.EQ.123)) GOTO 23323 20090 SP = SP + 1 20100 IF(.NOT.(SP .GT. 100)) GOTO 23325 20110 CALL ERROR(25HSTACK OVERFLOW IN PARSER.) 20120 23325 CONTINUE 20130 LEXTYP(SP) = TOKEN 20140 LABVAL(SP) = LAB 20150 GOTO 23324 20160 23323 CONTINUE 20170 IF(.NOT.(TOKEN .EQ. 125)) GOTO 23327 20180 IF(.NOT.(LEXTYP(SP) .EQ. 123)) GOTO 23329 20190 SP = SP - 1 20200 GOTO 23330 20210 23329 CONTINUE 20220 CALL SYNERR(20HILLEGAL RIGHT BRACE.) 20230 23330 CONTINUE 20240 GOTO 23328 20250 23327 CONTINUE 20260 IF(.NOT.(TOKEN .EQ. 10267)) GOTO 23331 20270 CALL OTHERC(LEXSTR) 20280 GOTO 23332 20290 23331 CONTINUE 20300 IF(.NOT.(TOKEN .EQ. 10264 .OR. TOKEN .EQ. 10265)) GOTO 23333 20310 CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN) 20320 23333 CONTINUE 20330 23332 CONTINUE 20340 23328 CONTINUE 20350 TOKEN = LEX(LEXSTR) 20360 CALL PBSTR(LEXSTR) 20370 CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN) 20380 23324 CONTINUE 20390 23305 TOKEN = LEX(LEXSTR) 20400 GOTO 23304 20410 23306 CONTINUE 20420 IF(.NOT.(SP .NE. 1)) GOTO 23335 20430 CALL SYNERR(15HUNEXPECTED EOF.) 20440 23335 CONTINUE 20450 RETURN 20460 END 20470 C 20480 C PBSTR - PUSH STRING BACK ONTO INPUT 20490 C 20500 SUBROUTINE PBSTR(IN) 20510 INTEGER IN(100) 20520 INTEGER LENGTH 20530 INTEGER I 20540 CONTINUE 20550 I = LENGTH(IN) 20560 23337 IF(.NOT.( I .GT. 0)) GOTO 23339 20570 CALL PUTBAK(IN(I)) 20580 23338 I = I - 1 20590 GOTO 23337 20600 23339 CONTINUE 20610 RETURN 20620 END 20630 C 20640 C PUTBAK - PUSH CHARACTER BACK ONTO INPUT 20650 C 20660 SUBROUTINE PUTBAK(C) 20670 INTEGER C 20680 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 20690 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 20700 INTEGER EXTDIG 20710 INTEGER INTDIG 20720 INTEGER EXTLET 20730 INTEGER INTLET 20740 INTEGER EXTBIG 20750 INTEGER INTBIG 20760 INTEGER EXTCHR 20770 INTEGER INTCHR 20780 INTEGER EXTBLK 20790 INTEGER INTBLK 20800 COMMON /CDEFIO/ BP, BUF(300) 20810 INTEGER BP 20820 INTEGER BUF 20830 COMMON /CFOR/ FORDEP, FORSTK(200) 20840 INTEGER FORDEP 20850 INTEGER FORSTK 20860 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 20870 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 20880 *UNTIL 20890 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 20900 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 20910 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 20920 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 20930 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 20940 INTEGER LEVEL 20950 INTEGER LINECT 20960 INTEGER INFILE 20970 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 20980 INTEGER LASTP 20990 INTEGER LASTT 21000 INTEGER NAMPTR 21010 INTEGER TABLE 21020 COMMON /COUTLN/ OUTP, OUTBUF(81) 21030 INTEGER OUTP 21040 INTEGER OUTBUF 21050 BP = BP + 1 21060 IF(.NOT.(BP .GT. 300)) GOTO 23340 21070 CALL ERROR(32HTOO MANY CHARACTERS PUSHED BACK.) 21080 23340 CONTINUE 21090 BUF(BP) = C 21100 RETURN 21110 END 21120 C 21130 C PUTCH (INTERIM VERSION) PUT CHARACTERS 21140 C 21150 SUBROUTINE PUTCH(C, F) 21160 INTEGER BUF(81), C 21170 INTEGER OUTMAP 21180 INTEGER F, I, LASTC 21190 DATA LASTC /0/ 21200 IF(.NOT.(LASTC .GE. 81 .OR. C .EQ. 10)) GOTO 23342 21210 IF(.NOT.( LASTC .LE. 0 )) GOTO 23344 21220 WRITE(F,2) 21230 2 FORMAT(/) 21240 GOTO 23345 21250 23344 CONTINUE 21260 WRITE(F, 1) (BUF(I), I = 1, LASTC) 21270 1 FORMAT(80 A1) 21280 23345 CONTINUE 21290 LASTC = 0 21300 23342 CONTINUE 21310 IF(.NOT.(C .NE. 10)) GOTO 23346 21320 LASTC = LASTC + 1 21330 BUF(LASTC) = OUTMAP(C) 21340 23346 CONTINUE 21350 RETURN 21360 END 21370 C 21380 C PUTLIN - PUT OUT LINE BY REPEATED CALLS TO PUTCH 21390 C 21400 SUBROUTINE PUTLIN(B, F) 21410 INTEGER B(100) 21420 INTEGER F, I 21430 CONTINUE 21440 I = 1 21450 23348 IF(.NOT.( B(I) .NE. 10002)) GOTO 23350 21460 CALL PUTCH(B(I), F) 21470 23349 I = I + 1 21480 GOTO 23348 21490 23350 CONTINUE 21500 RETURN 21510 END 21520 C 21530 C RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM 21540 C 21550 SUBROUTINE RELATE(TOKEN, LAST, FD) 21560 INTEGER NGETCH 21570 INTEGER TOKEN(100) 21580 INTEGER LENGTH 21590 INTEGER FD, LAST 21600 INTEGER DOTGE(5), DOTGT(5), DOTLT(5), DOTLE(5) 21610 INTEGER DOTNE(5), DOTNOT(6), DOTEQ(5), DOTAND(6), DOTOR(5) 21620 DATA DOTGE(1), DOTGE(2), DOTGE(3), DOTGE(4), DOTGE(5)/ 46, 103, 1 21630 *01, 46, 10002/ 21640 DATA DOTGT(1), DOTGT(2), DOTGT(3), DOTGT(4), DOTGT(5)/ 46, 103, 1 21650 *16, 46, 10002/ 21660 DATA DOTLE(1), DOTLE(2), DOTLE(3), DOTLE(4), DOTLE(5)/ 46, 108, 1 21670 *01, 46, 10002/ 21680 DATA DOTLT(1), DOTLT(2), DOTLT(3), DOTLT(4), DOTLT(5)/ 46, 108, 1 21690 *16, 46, 10002/ 21700 DATA DOTNE(1), DOTNE(2), DOTNE(3), DOTNE(4), DOTNE(5)/ 46, 110, 1 21710 *01, 46, 10002/ 21720 DATA DOTEQ(1), DOTEQ(2), DOTEQ(3), DOTEQ(4), DOTEQ(5)/ 46, 101, 1 21730 *13, 46, 10002/ 21740 DATA DOTOR(1), DOTOR(2), DOTOR(3), DOTOR(4), DOTOR(5)/ 46, 111, 1 21750 *14, 46, 10002/ 21760 DATA DOTAND(1), DOTAND(2), DOTAND(3), DOTAND(4), DOTAND(5), DOTAN 21770 *D(6) /46, 97, 110, 100, 46, 10002/ 21780 DATA DOTNOT(1), DOTNOT(2), DOTNOT(3), DOTNOT(4), DOTNOT(5), DOTNO 21790 *T(6) /46, 110, 111, 116, 46, 10002/ 21800 IF(.NOT.(NGETCH(TOKEN(2), FD) .NE. 61)) GOTO 23351 21810 CALL PUTBAK(TOKEN(2)) 21820 23351 CONTINUE 21830 IF(.NOT.(TOKEN(1) .EQ. 62)) GOTO 23353 21840 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23355 21850 CALL SCOPY(DOTGE, 1, TOKEN, 1) 21860 GOTO 23356 21870 23355 CONTINUE 21880 CALL SCOPY(DOTGT, 1, TOKEN, 1) 21890 23356 CONTINUE 21900 GOTO 23354 21910 23353 CONTINUE 21920 IF(.NOT.(TOKEN(1) .EQ. 60)) GOTO 23357 21930 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23359 21940 CALL SCOPY(DOTLE, 1, TOKEN, 1) 21950 GOTO 23360 21960 23359 CONTINUE 21970 CALL SCOPY(DOTLT, 1, TOKEN, 1) 21980 23360 CONTINUE 21990 GOTO 23358 22000 23357 CONTINUE 22010 IF(.NOT.(TOKEN(1) .EQ. 33)) GOTO 23361 22020 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23363 22030 CALL SCOPY(DOTNE, 1, TOKEN, 1) 22040 GOTO 23364 22050 23363 CONTINUE 22060 CALL SCOPY(DOTNOT, 1, TOKEN, 1) 22070 23364 CONTINUE 22080 GOTO 23362 22090 23361 CONTINUE 22100 IF(.NOT.(TOKEN(1) .EQ. 61)) GOTO 23365 22110 IF(.NOT.(TOKEN(2) .EQ. 61)) GOTO 23367 22120 CALL SCOPY(DOTEQ, 1, TOKEN, 1) 22130 GOTO 23368 22140 23367 CONTINUE 22150 TOKEN(2) = 10002 22160 23368 CONTINUE 22170 GOTO 23366 22180 23365 CONTINUE 22190 IF(.NOT.(TOKEN(1) .EQ. 38)) GOTO 23369 22200 CALL SCOPY(DOTAND, 1, TOKEN, 1) 22210 GOTO 23370 22220 23369 CONTINUE 22230 IF(.NOT.(TOKEN(1) .EQ. 124)) GOTO 23371 22240 CALL SCOPY(DOTOR, 1, TOKEN, 1) 22250 GOTO 23372 22260 23371 CONTINUE 22270 TOKEN(2) = 10002 22280 23372 CONTINUE 22290 23370 CONTINUE 22300 23366 CONTINUE 22310 23362 CONTINUE 22320 23358 CONTINUE 22330 23354 CONTINUE 22340 LAST = LENGTH(TOKEN) 22350 RETURN 22360 END 22370 C 22380 C REMARK - PRINT WARNING MESSAGE 22390 C 22400 SUBROUTINE REMARK(BUF) 22410 INTEGER BUF(100), I 22420 WRITE(6, 10) (BUF(I), I = 1, 5) 22430 10 FORMAT(5A4) 22440 RETURN 22450 END 22460 C 22470 C REPCOD - GENERATE CODE FOR BEGINNING OF REPEAT 22480 C 22490 SUBROUTINE REPCOD(LAB) 22500 INTEGER LABGEN 22510 INTEGER LAB 22520 CALL OUTCON(0) 22530 LAB = LABGEN(3) 22540 CALL OUTCON(LAB) 22550 LAB = LAB + 1 22560 RETURN 22570 END 22580 C 22590 C SCOPY - COPY STRING AT FROM(I) TO TO(J) 22600 C 22610 SUBROUTINE SCOPY(FROM, I, TO, J) 22620 INTEGER FROM(100), TO(100) 22630 INTEGER I, J, K1, K2 22640 K2 = J 22650 CONTINUE 22660 K1 = I 22670 23373 IF(.NOT.( FROM(K1) .NE. 10002)) GOTO 23375 22680 TO(K2) = FROM(K1) 22690 K2 = K2 + 1 22700 23374 K1 = K1 + 1 22710 GOTO 23373 22720 23375 CONTINUE 22730 TO(K2) = 10002 22740 RETURN 22750 END 22760 C 22770 C SYNERR - REPORT RATFOR SYNTAX ERROR 22780 C 22790 SUBROUTINE SYNERR(MSG) 22800 INTEGER LC(81), MSG(81) 22810 INTEGER ITOC 22820 INTEGER I, JUNK 22830 COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), E 22840 *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK 22850 INTEGER EXTDIG 22860 INTEGER INTDIG 22870 INTEGER EXTLET 22880 INTEGER INTLET 22890 INTEGER EXTBIG 22900 INTEGER INTBIG 22910 INTEGER EXTCHR 22920 INTEGER INTCHR 22930 INTEGER EXTBLK 22940 INTEGER INTBLK 22950 COMMON /CDEFIO/ BP, BUF(300) 22960 INTEGER BP 22970 INTEGER BUF 22980 COMMON /CFOR/ FORDEP, FORSTK(200) 22990 INTEGER FORDEP 23000 INTEGER FORSTK 23010 COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE 23020 *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V 23030 *UNTIL 23040 INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5) 23050 INTEGER SFOR(4), SREPT(7), SUNTIL(6) 23060 INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2) 23070 INTEGER VFOR(2), VREPT(2), VUNTIL(2) 23080 COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5) 23090 INTEGER LEVEL 23100 INTEGER LINECT 23110 INTEGER INFILE 23120 COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500) 23130 INTEGER LASTP 23140 INTEGER LASTT 23150 INTEGER NAMPTR 23160 INTEGER TABLE 23170 COMMON /COUTLN/ OUTP, OUTBUF(81) 23180 INTEGER OUTP 23190 INTEGER OUTBUF 23200 CALL REMARK(14HERROR AT LINE.) 23210 CONTINUE 23220 I = 1 23230 23376 IF(.NOT.( I .LE. LEVEL)) GOTO 23378 23240 CALL PUTCH(32, 6) 23250 JUNK = ITOC(LINECT(I), LC, 81) 23260 CALL PUTLIN(LC, 6) 23270 23377 I = I + 1 23280 GOTO 23376 23290 23378 CONTINUE 23300 CALL PUTCH(58, 6) 23310 CALL PUTCH(10, 6) 23320 CALL REMARK(MSG) 23330 RETURN 23340 END 23350 C 23360 C TYPE - RETURN LETTER, DIGIT OR CHARACTER 23370 C 23380 INTEGER FUNCTION TYPE(C) 23390 INTEGER C 23400 IF(.NOT.( C .GE. 48 .AND. C .LE. 57 )) GOTO 23379 23410 TYPE = 2 23420 GOTO 23380 23430 23379 CONTINUE 23440 IF(.NOT.( C .GE. 97 .AND. C .LE. 122 )) GOTO 23381 23450 TYPE = 1 23460 GOTO 23382 23470 23381 CONTINUE 23480 IF(.NOT.( C .GE. 65 .AND. C .LE. 90 )) GOTO 23383 23490 TYPE = 1 23500 GOTO 23384 23510 23383 CONTINUE 23520 TYPE = C 23530 23384 CONTINUE 23540 23382 CONTINUE 23550 23380 CONTINUE 23560 RETURN 23570 END 23580 C 23590 C UNSTAK - UNSTACK AT END OF STATEMENT 23600 C 23610 SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN) 23620 INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN 23630 CONTINUE 23640 23385 IF(.NOT.( SP .GT. 1)) GOTO 23387 23650 IF(.NOT.(LEXTYP(SP) .EQ. 123)) GOTO 23388 23660 GOTO 23387 23670 23388 CONTINUE 23680 IF(.NOT.(LEXTYP(SP) .EQ. 10261 .AND. TOKEN .EQ. 10262)) GOTO 233 23690 *90 23700 GOTO 23387 23710 23390 CONTINUE 23720 IF(.NOT.(LEXTYP(SP) .EQ. 10261)) GOTO 23392 23730 CALL OUTCON(LABVAL(SP)) 23740 GOTO 23393 23750 23392 CONTINUE 23760 IF(.NOT.(LEXTYP(SP) .EQ. 10262)) GOTO 23394 23770 IF(.NOT.(SP .GT. 2)) GOTO 23396 23780 SP = SP - 1 23790 23396 CONTINUE 23800 CALL OUTCON(LABVAL(SP)+1) 23810 GOTO 23395 23820 23394 CONTINUE 23830 IF(.NOT.(LEXTYP(SP) .EQ. 10266)) GOTO 23398 23840 CALL DOSTAT(LABVAL(SP)) 23850 GOTO 23399 23860 23398 CONTINUE 23870 IF(.NOT.(LEXTYP(SP) .EQ. 10263)) GOTO 23400 23880 CALL WHILES(LABVAL(SP)) 23890 GOTO 23401 23900 23400 CONTINUE 23910 IF(.NOT.(LEXTYP(SP) .EQ. 10268)) GOTO 23402 23920 CALL FORS(LABVAL(SP)) 23930 GOTO 23403 23940 23402 CONTINUE 23950 IF(.NOT.(LEXTYP(SP) .EQ. 10269)) GOTO 23404 23960 CALL UNTILS(LABVAL(SP), TOKEN) 23970 23404 CONTINUE 23980 23403 CONTINUE 23990 23401 CONTINUE 24000 23399 CONTINUE 24010 23395 CONTINUE 24020 23393 CONTINUE 24030 23386 SP = SP - 1 24040 GOTO 23385 24050 23387 CONTINUE 24060 RETURN 24070 END 24080 C 24090 C UNTILS - GENERATE CODE FOR UNTIL OR END OF REPEAT 24100 C 24110 SUBROUTINE UNTILS(LAB, TOKEN) 24120 INTEGER PTOKEN(200) 24130 INTEGER LEX 24140 INTEGER JUNK, LAB, TOKEN 24150 CALL OUTNUM(LAB) 24160 IF(.NOT.(TOKEN .EQ. 10270)) GOTO 23406 24170 JUNK = LEX(PTOKEN) 24180 CALL IFGO(LAB-1) 24190 GOTO 23407 24200 23406 CONTINUE 24210 CALL OUTGO(LAB-1) 24220 23407 CONTINUE 24230 CALL OUTCON(LAB+1) 24240 RETURN 24250 END 24260 C 24270 C WHILEC - GENERATE CODE FOR BEGINNING OF WHILE 24280 C 24290 SUBROUTINE WHILEC(LAB) 24300 INTEGER LABGEN 24310 INTEGER LAB 24320 CALL OUTCON(0) 24330 LAB = LABGEN(2) 24340 CALL OUTNUM(LAB) 24350 CALL IFGO(LAB+1) 24360 RETURN 24370 END 24380 C 24390 C WHILES - GENERATE CODE FOR END OF WHILE 24400 C 24410 SUBROUTINE WHILES(LAB) 24420 INTEGER LAB 24430 CALL OUTGO(LAB) 24440 CALL OUTCON(LAB+1) 24450 RETURN 24460 END 24470 ========== Ratfor definitions ========== 24480 24490 # Because some compilers will not compile logical expressions 24500 # of the form (i .ne. -1), we have used positive values for 24510 # some symbolic constants where negative values would be 24520 # a better choice. (EOS, EOF, and so on are examples.) 24530 # These positive values are all greater than 10000. 24540 24550 define(ALPHA,10100) 24560 define(AMPER,38) # ampersand 24570 define(ARB,100) 24580 define(ATSIGN,64) 24590 define(BACKSLASH,92) 24600 define(BACKSPACE,8) 24610 define(BANG,33) # exclamation mark 24620 define(BAR,124) 24630 define(BIGA,65) 24640 define(BIGB,66) 24650 define(BIGC,67) 24660 define(BIGD,68) 24670 define(BIGE,69) 24680 define(BIGF,70) 24690 define(BIGG,71) 24700 define(BIGH,72) 24710 define(BIGI,73) 24720 define(BIGJ,74) 24730 define(BIGK,75) 24740 define(BIGL,76) 24750 define(BIGM,77) 24760 define(BIGN,78) 24770 define(BIGO,79) 24780 define(BIGP,80) 24790 define(BIGQ,81) 24800 define(BIGR,82) 24810 define(BIGS,83) 24820 define(BIGT,84) 24830 define(BIGU,85) 24840 define(BIGV,86) 24850 define(BIGW,87) 24860 define(BIGX,88) 24870 define(BIGY,89) 24880 define(BIGZ,90) 24890 define(BLANK,32) 24900 define(BUFSIZE,300) # pushback buffer for ngetch and putbak 24910 define(COLON,58) 24920 define(COMMA,44) 24930 define(DEFTYPE,10010) 24940 define(DIG0,48) 24950 define(DIG1,49) 24960 define(DIG2,50) 24970 define(DIG3,51) 24980 define(DIG4,52) 24990 define(DIG5,53) 25000 define(DIG6,54) 25010 define(DIG7,55) 25020 define(DIG8,56) 25030 define(DIG9,57) 25040 define(DIGIT,2) 25050 define(DOLLAR,36) 25060 define(DQUOTE,34) 25070 define(EOF,10003) 25080 define(EOS,10002) 25090 define(EQUALS,61) 25100 define(ERR,10001) 25110 define(ERROUT,6) # temporarily same as standard output 25120 define(GREATER,62) 25130 define(LBRACE,123) 25140 define(LBRACK,91) 25150 define(LESS,60) 25160 define(LETA,97) 25170 define(LETB,98) 25180 define(LETC,99) 25190 define(LETD,100) 25200 define(LETE,101) 25210 define(LETF,102) 25220 define(LETG,103) 25230 define(LETH,104) 25240 define(LETI,105) 25250 define(LETJ,106) 25260 define(LETK,107) 25270 define(LETL,108) 25280 define(LETM,109) 25290 define(LETN,110) 25300 define(LETO,111) 25310 define(LETP,112) 25320 define(LETQ,113) 25330 define(LETR,114) 25340 define(LETS,115) 25350 define(LETT,116) 25360 define(LETTER,1) 25370 define(LETU,117) 25380 define(LETV,118) 25390 define(LETW,119) 25400 define(LETX,120) 25410 define(LETY,121) 25420 define(LETZ,122) 25430 define(LEXBREAK,10264) 25440 define(LEXDIGITS,10260) 25450 define(LEXDO,10266) 25460 define(LEXELSE,10262) 25470 define(LEXFOR,10268) 25480 define(LEXIF,10261) 25490 define(LEXNEXT,10265) 25500 define(LEXOTHER,10267) 25510 define(LEXREPEAT,10269) 25520 define(LEXUNTIL,10270) 25530 define(LEXWHILE,10263) 25540 define(LPAREN,40) 25550 define(MAXCARD,80) # card size 25560 define(MAXCHARS,10) # characters for outnum 25570 define(MAXDEF,200) # max chars in a defn 25580 define(MAXFORSTK,200) # max space for for reinit clauses 25590 define(MAXLINE,81) # must be 1 more than MAXCARD 25600 define(MAXNAME,30) # file name size in gettok 25610 define(MAXPTR,200) # number of defines in lookup 25620 define(MAXSTACK,100) # max stack depth for parser 25630 define(MAXTBL,1500) # max chars in all definitions 25640 define(MAXTOK,200) # max chars in a token 25650 define(MINUS,45) 25660 define(NCHARS,33) # number of special characters 25670 define(NEWLINE,10) 25680 define(NFILES,5) # max depth of file inclusion 25690 define(NO,0) 25700 define(NOT,BANG) # exclamation mark for now; change for ebcdic 25710 define(PERCENT,37) 25720 define(PERIOD,46) 25730 define(PLUS,43) 25740 define(QMARK,63) 25750 define(RBRACE,125) 25760 define(RBRACK,93) 25770 define(READONLY,0) 25780 define(RPAREN,41) 25790 define(SEMICOL,59) 25800 define(SHARP,35) 25810 define(SLASH,47) 25820 define(SQUOTE,39) 25830 define(STAR,42) 25840 define(STDIN,5) 25850 define(STDOUT,6) 25860 define(TAB,9) 25870 define(UNDERLINE,95) 25880 define(YES,1) 25890 define(character,integer) 25900 define(abs,iabs) 25910 ========== commonblocks ========== 25920 # common blocks. 25930 # these have been lumped into one place to minimize 25940 # the operational problems of picking up several small 25950 # files in an environment that doesn't support files 25960 # by name. The individual routines still name as comments the 25970 # actual common blocks they need, but actually include 25980 # everything in this batch, with a statement: 25990 # include commonblocks 26000 26010 common /cchar/ extdig(10), intdig(10), extlet(26), intlet(26), 26020 extbig(26), intbig(26), extchr(NCHARS), intchr(NCHARS), 26030 extblk, intblk 26040 integer extdig # external representation of digits 26050 integer intdig # internal rep (ascii) 26060 integer extlet # external rep of letters (normal case) 26070 integer intlet # internal rep (ascii lower case) 26080 integer extbig # external rep of upper case, if used 26090 integer intbig # internal rep (upper case ascii) 26100 integer extchr # external rep of special chars 26110 integer intchr # internal rep (ascii) 26120 integer extblk # external blank 26130 integer intblk # internal blank (ascii) 26140 26150 common /cdefio/ bp, buf(BUFSIZE) 26160 integer bp # next available character; init = 0 26170 character buf # pushed-back characters 26180 26190 common /cfor/ fordep, forstk(MAXFORSTK) 26200 integer fordep # current depth of for statements 26210 character forstk # stack of reinit strings 26220 26230 common /ckeywd/ sdo, sif, selse, swhile, sbreak, snext, 26240 sfor, srept, suntil, 26250 vdo, vif, velse, vwhile, vbreak, vnext, vfor, vrept, vuntil 26260 integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5) 26270 integer sfor(4), srept(7), suntil(6) 26280 integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2) 26290 integer vfor(2), vrept(2), vuntil(2) 26300 26310 common /cline/ level, linect(NFILES), infile(NFILES) 26320 integer level # level of file inclusion; init = 1 26330 integer linect # line count on input file(level); init = 1 26340 integer infile # file number(level); init infile(1) = STDIN 26350 26360 common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL) 26370 integer lastp # last used in namptr; init = 0 26380 integer lastt # last used in table; init = 0 26390 integer namptr # name pointers 26400 character table # actual text of names and defns 26410 26420 common /coutln/ outp, outbuf(MAXLINE) 26430 integer outp # last position filled in outbuf; init = 0 26440 character outbuf # output lines collected here 26450 ========== Ratfor in ratfor ========== 26460 # block data - initialize global variables 26470 block data 26480 include commonblocks 26490 # include coutln 26500 # include cline 26510 # include cdefio 26520 # include cfor 26530 # include clook 26540 # include ckeywd 26550 # include cchar 26560 26570 # output character pointer: 26580 data outp /0/ 26590 26600 # file control: 26610 data level /1/ 26620 data linect(1) /1/ 26630 data infile(1) /STDIN/ 26640 26650 # pushback buffer pointer: 26660 data bp /0/ 26670 26680 # depth of for stack: 26690 data fordep /0/ 26700 26710 # pointers for table lookup code: 26720 data lastp /0/ 26730 data lastt /0/ 26740 26750 # keywords: 26760 data sdo(1), sdo(2), sdo(3) /LETD, LETO, EOS/ 26770 data vdo(1), vdo(2) /LEXDO, EOS/ 26780 26790 data sif(1), sif(2), sif(3) /LETI, LETF, EOS/ 26800 data vif(1), vif(2) /LEXIF, EOS/ 26810 26820 data selse(1), selse(2), selse(3), selse(4), selse(5) /LETE, 26830 LETL, LETS, LETE, EOS/ 26840 data velse(1), velse(2) /LEXELSE, EOS/ 26850 26860 data swhile(1), swhile(2), swhile(3), swhile(4), swhile(5), 26870 swhile(6) /LETW, LETH, LETI, LETL, LETE, EOS/ 26880 data vwhile(1), vwhile(2) /LEXWHILE, EOS/ 26890 26900 data sbreak(1), sbreak(2), sbreak(3), sbreak(4), sbreak(5), 26910 sbreak(6) /LETB, LETR, LETE, LETA, LETK, EOS/ 26920 data vbreak(1), vbreak(2) /LEXBREAK, EOS/ 26930 26940 data snext(1), snext(2), snext(3), snext(4), snext(5) /LETN, 26950 LETE, LETX, LETT, EOS/ 26960 data vnext(1), vnext(2) /LEXNEXT, EOS/ 26970 26980 data sfor(1), sfor(2), sfor(3), sfor(4) /LETF, 26990 LETO, LETR, EOS/ 27000 data vfor(1), vfor(2) /LEXFOR, EOS/ 27010 27020 data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6), 27030 srept(7) /LETR, LETE, LETP, LETE, LETA, LETT, EOS/ 27040 data vrept(1), vrept(2) /LEXREPEAT, EOS/ 27050 27060 data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5), 27070 suntil(6) /LETU, LETN, LETT, LETI, LETL, EOS/ 27080 data vuntil(1), vuntil(2) /LEXUNTIL, EOS/ 27090 27100 # character set definitions: 27110 27120 data extblk /' '/, intblk /BLANK/ 27130 27140 data extdig(1) /'0'/, intdig(1) /DIG0/ 27150 data extdig(2) /'1'/, intdig(2) /DIG1/ 27160 data extdig(3) /'2'/, intdig(3) /DIG2/ 27170 data extdig(4) /'3'/, intdig(4) /DIG3/ 27180 data extdig(5) /'4'/, intdig(5) /DIG4/ 27190 data extdig(6) /'5'/, intdig(6) /DIG5/ 27200 data extdig(7) /'6'/, intdig(7) /DIG6/ 27210 data extdig(8) /'7'/, intdig(8) /DIG7/ 27220 data extdig(9) /'8'/, intdig(9) /DIG8/ 27230 data extdig(10) /'9'/, intdig(10) /DIG9/ 27240 27250 # normal case of letters 27260 27270 data extlet(1) /'a'/, intlet(1) /LETA/ 27280 data extlet(2) /'b'/, intlet(2) /LETB/ 27290 data extlet(3) /'c'/, intlet(3) /LETC/ 27300 data extlet(4) /'d'/, intlet(4) /LETD/ 27310 data extlet(5) /'e'/, intlet(5) /LETE/ 27320 data extlet(6) /'f'/, intlet(6) /LETF/ 27330 data extlet(7) /'g'/, intlet(7) /LETG/ 27340 data extlet(8) /'h'/, intlet(8) /LETH/ 27350 data extlet(9) /'i'/, intlet(9) /LETI/ 27360 data extlet(10) /'j'/, intlet(10) /LETJ/ 27370 data extlet(11) /'k'/, intlet(11) /LETK/ 27380 data extlet(12) /'l'/, intlet(12) /LETL/ 27390 data extlet(13) /'m'/, intlet(13) /LETM/ 27400 data extlet(14) /'n'/, intlet(14) /LETN/ 27410 data extlet(15) /'o'/, intlet(15) /LETO/ 27420 data extlet(16) /'p'/, intlet(16) /LETP/ 27430 data extlet(17) /'q'/, intlet(17) /LETQ/ 27440 data extlet(18) /'r'/, intlet(18) /LETR/ 27450 data extlet(19) /'s'/, intlet(19) /LETS/ 27460 data extlet(20) /'t'/, intlet(20) /LETT/ 27470 data extlet(21) /'u'/, intlet(21) /LETU/ 27480 data extlet(22) /'v'/, intlet(22) /LETV/ 27490 data extlet(23) /'w'/, intlet(23) /LETW/ 27500 data extlet(24) /'x'/, intlet(24) /LETX/ 27510 data extlet(25) /'y'/, intlet(25) /LETY/ 27520 data extlet(26) /'z'/, intlet(26) /LETZ/ 27530 27540 # upper case of letters 27550 27560 data extbig(1) /'A'/, intbig(1) /BIGA/ 27570 data extbig(2) /'B'/, intbig(2) /BIGB/ 27580 data extbig(3) /'C'/, intbig(3) /BIGC/ 27590 data extbig(4) /'D'/, intbig(4) /BIGD/ 27600 data extbig(5) /'E'/, intbig(5) /BIGE/ 27610 data extbig(6) /'F'/, intbig(6) /BIGF/ 27620 data extbig(7) /'G'/, intbig(7) /BIGG/ 27630 data extbig(8) /'H'/, intbig(8) /BIGH/ 27640 data extbig(9) /'I'/, intbig(9) /BIGI/ 27650 data extbig(10) /'J'/, intbig(10) /BIGJ/ 27660 data extbig(11) /'K'/, intbig(11) /BIGK/ 27670 data extbig(12) /'L'/, intbig(12) /BIGL/ 27680 data extbig(13) /'M'/, intbig(13) /BIGM/ 27690 data extbig(14) /'N'/, intbig(14) /BIGN/ 27700 data extbig(15) /'O'/, intbig(15) /BIGO/ 27710 data extbig(16) /'P'/, intbig(16) /BIGP/ 27720 data extbig(17) /'Q'/, intbig(17) /BIGQ/ 27730 data extbig(18) /'R'/, intbig(18) /BIGR/ 27740 data extbig(19) /'S'/, intbig(19) /BIGS/ 27750 data extbig(20) /'T'/, intbig(20) /BIGT/ 27760 data extbig(21) /'U'/, intbig(21) /BIGU/ 27770 data extbig(22) /'V'/, intbig(22) /BIGV/ 27780 data extbig(23) /'W'/, intbig(23) /BIGW/ 27790 data extbig(24) /'X'/, intbig(24) /BIGX/ 27800 data extbig(25) /'Y'/, intbig(25) /BIGY/ 27810 data extbig(26) /'Z'/, intbig(26) /BIGZ/ 27820 27830 # special characters. some of these may 27840 # change for your machine 27850 27860 data extchr(1) /']'/, intchr(1) /NOT/ # use exclam for not-sign 27870 data extchr(2) /'"'/, intchr(2) /DQUOTE/ 27880 data extchr(3) /"#"/, intchr(3) /SHARP/ 27890 data extchr(4) /'$'/, intchr(4) /DOLLAR/ 27900 data extchr(5) /'%'/, intchr(5) /PERCENT/ 27910 data extchr(6) /'&'/, intchr(6) /AMPER/ 27920 data extchr(7) /"'"/, intchr(7) /SQUOTE/ 27930 data extchr(8) /'('/, intchr(8) /LPAREN/ 27940 data extchr(9) /')'/, intchr(9) /RPAREN/ 27950 data extchr(10) /'*'/, intchr(10) /STAR/ 27960 data extchr(11) /'+'/, intchr(11) /PLUS/ 27970 data extchr(12) /','/, intchr(12) /COMMA/ 27980 data extchr(13) /'-'/, intchr(13) /MINUS/ 27990 data extchr(14) /'.'/, intchr(14) /PERIOD/ 28000 data extchr(15) /'/'/, intchr(15) /SLASH/ 28010 data extchr(16) /':'/, intchr(16) /COLON/ 28020 data extchr(17) /';'/, intchr(17) /SEMICOL/ 28030 data extchr(18) /'<'/, intchr(18) /LESS/ 28040 data extchr(19) /'='/, intchr(19) /EQUALS/ 28050 data extchr(20) /'>'/, intchr(20) /GREATER/ 28060 data extchr(21) /'?'/, intchr(21) /QMARK/ 28070 data extchr(22) /'@'/, intchr(22) /ATSIGN/ 28080 data extchr(23) /'Õ'/, intchr(23) /LBRACK/ 28090 data extchr(24) /'\'/, intchr(24) /BACKSLASH/ 28100 data extchr(25) /'å'/, intchr(25) /RBRACK/ 28110 data extchr(26) /'_'/, intchr(26) /UNDERLINE/ 28120 data extchr(27) /'{'/, intchr(27) /LBRACE/ 28130 data extchr(28) /'!'/, intchr(28) /BAR/ 28140 data extchr(29) /'}'/, intchr(29) /RBRACE/ 28150 data extchr(30) /''/, intchr(30) /BACKSPACE/ 28160 data extchr(31) /' '/, intchr(31) /TAB/ 28170 data extchr(32) /'^'/, intchr(32) /NOT/ # use caret for not-sign 28180 data extchr(33) /'~'/, intchr(33) /NOT/ # use tilde for not-sign 28190 # NCHARS is last subscript in this array 28200 28210 end 28220 # ratfor - main program for Ratfor 28230 call parse 28240 stop 28250 end 28260 # alldig - return YES if str is all digits 28270 integer function alldig(str) 28280 character type 28290 character str(ARB) 28300 integer i 28310 28320 alldig = NO 28330 if (str(1) == EOS) 28340 return 28350 for (i = 1; str(i) ^= EOS; i = i + 1) 28360 if (type(str(i)) ^= DIGIT) 28370 return 28380 alldig = YES 28390 return 28400 end 28410 # balpar - copy balanced paren string 28420 subroutine balpar 28430 character gettok 28440 character t, token(MAXTOK) 28450 integer nlpar 28460 28470 if (gettok(token, MAXTOK) ^= LPAREN) { 28480 call synerr("missing left paren.") 28490 return 28500 } 28510 call outstr(token) 28520 nlpar = 1 28530 repeat { 28540 t = gettok(token, MAXTOK) 28550 if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) { 28560 call pbstr(token) 28570 break 28580 } 28590 if (t == NEWLINE) # delete newlines 28600 token(1) = EOS 28610 else if (t == LPAREN) 28620 nlpar = nlpar + 1 28630 else if (t == RPAREN) 28640 nlpar = nlpar - 1 28650 # else nothing special 28660 call outstr(token) 28670 } until (nlpar <= 0) 28680 if (nlpar ^= 0) 28690 call synerr("missing parenthesis in condition.") 28700 return 28710 end 28720 # brknxt - generate code for break and next 28730 subroutine brknxt(sp, lextyp, labval, token) 28740 integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token 28750 28760 for (i = sp; i > 0; i = i - 1) 28770 if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO 28780 | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) { 28790 if (token == LEXBREAK) 28800 call outgo(labval(i)+1) 28810 else 28820 call outgo(labval(i)) 28830 return 28840 } 28850 if (token == LEXBREAK) 28860 call synerr("illegal break.") 28870 else 28880 call synerr("illegal next.") 28890 return 28900 end 28910 # close - exceedingly temporary version for gettok 28920 subroutine close(fd) 28930 integer fd 28940 28950 rewind fd 28960 return 28970 end 28980 # ctoi - convert string at in(i) to integer, increment i 28990 integer function ctoi(in, i) 29000 character in(ARB) 29010 integer index 29020 integer d, i 29030 # string digits "0123456789" 29040 integer digits(11) 29050 data digits(1) /DIG0/ 29060 data digits(2) /DIG1/ 29070 data digits(3) /DIG2/ 29080 data digits(4) /DIG3/ 29090 data digits(5) /DIG4/ 29100 data digits(6) /DIG5/ 29110 data digits(7) /DIG6/ 29120 data digits(8) /DIG7/ 29130 data digits(9) /DIG8/ 29140 data digits(10) /DIG9/ 29150 data digits(11) /EOS/ 29160 29170 while (in(i) == BLANK | in(i) == TAB) 29180 i = i + 1 29190 for (ctoi = 0; in(i) ^= EOS; i = i + 1) { 29200 d = index(digits, in(i)) 29210 if (d == 0) # non-digit 29220 break 29230 ctoi = 10 * ctoi + d - 1 29240 } 29250 return 29260 end 29270 # deftok - get token; process macro calls and invocations 29280 character function deftok(token, toksiz, fd) 29290 character gtok 29300 integer fd, toksiz 29310 character defn(MAXDEF), t, token(toksiz) 29320 integer lookup 29330 29340 for (t=gtok(token, toksiz, fd); t^=EOF; t=gtok(token, toksiz, fd)) { 29350 if (t ^= ALPHA) # non-alpha 29360 break 29370 if (lookup(token, defn) == NO) # undefined 29380 break 29390 if (defn(1) == DEFTYPE) { # get definition 29400 call getdef(token, toksiz, defn, MAXDEF, fd) 29410 call instal(token, defn) 29420 } 29430 else 29440 call pbstr(defn) # push replacement onto input 29450 } 29460 deftok = t 29470 if (deftok == ALPHA) # convert to single case 29480 call fold(token) 29490 return 29500 end 29510 29520 # fold - convert alphabetic token to single case 29530 subroutine fold(token) 29540 character token(ARB) 29550 integer i 29560 29570 # WARNING - this routine depends heavily on the 29580 # fact that letters have been mapped into internal 29590 # right-adjusted ascii. god help you if you 29600 # have subverted this mechanism. 29610 29620 for (i = 1; token(i) ^= EOS; i = i + 1) 29630 if (token(i) >= BIGA & token(i) <= BIGZ) 29640 token(i) = token(i) - BIGA + LETA 29650 return 29660 end 29670 # docode - generate code for beginning of do 29680 subroutine docode(lab) 29690 integer labgen 29700 integer lab 29710 # string dostr "do" 29720 integer dostr(4) 29730 data dostr(1), dostr(2), dostr(3), 29740 dostr(4)/LETD, LETO, BLANK, EOS/ 29750 29760 call outtab 29770 call outstr(dostr) 29780 lab = labgen(2) 29790 call outnum(lab) 29800 call eatup 29810 call outdon 29820 return 29830 end 29840 # dostat - generate code for end of do statement 29850 subroutine dostat(lab) 29860 integer lab 29870 29880 call outcon(lab) 29890 call outcon(lab+1) 29900 return 29910 end 29920 # eatup - process rest of statement; interpret continuations 29930 subroutine eatup 29940 character gettok 29950 character ptoken(MAXTOK), t, token(MAXTOK) 29960 integer nlpar 29970 29980 nlpar = 0 29990 repeat { 30000 t = gettok(token, MAXTOK) 30010 if (t == SEMICOL | t == NEWLINE) 30020 break 30030 if (t == RBRACE) { 30040 call pbstr(token) 30050 break 30060 } 30070 if (t == LBRACE | t == EOF) { 30080 call synerr("unexpected brace or EOF.") 30090 call pbstr(token) 30100 break 30110 } 30120 if (t == COMMA | t == UNDERLINE) { 30130 if (gettok(ptoken, MAXTOK) ^= NEWLINE) 30140 call pbstr(ptoken) 30150 if (t == UNDERLINE) 30160 token(1) = EOS 30170 } 30180 else if (t == LPAREN) 30190 nlpar = nlpar + 1 30200 else if (t == RPAREN) 30210 nlpar = nlpar - 1 30220 call outstr(token) 30230 } until (nlpar < 0) 30240 if (nlpar ^= 0) 30250 call synerr("unbalanced parentheses.") 30260 return 30270 end 30280 # elseif - generate code for end of if before else 30290 subroutine elseif(lab) 30300 integer lab 30310 30320 call outgo(lab+1) 30330 call outcon(lab) 30340 return 30350 end 30360 # equal - compare str1 to str2; return YES if equal, NO if not 30370 integer function equal(str1, str2) 30380 character str1(ARB), str2(ARB) 30390 integer i 30400 30410 for (i = 1; str1(i) == str2(i); i = i + 1) 30420 if (str1(i) == EOS) { 30430 equal = YES 30440 return 30450 } 30460 equal = NO 30470 return 30480 end 30490 # error - print fatal error message, then die 30500 subroutine error(buf) 30510 integer buf(ARB) 30520 30530 call remark(buf) 30540 stop 30550 end 30560 # forcod - beginning of for statement 30570 subroutine forcod(lab) 30580 character gettok 30590 character t, token(MAXTOK) 30600 integer length, labgen 30610 integer i, j, lab, nlpar 30620 include commonblocks 30630 # include cfor 30640 # string ifnot "if(.not." 30650 integer ifnot(9) 30660 data ifnot(1) /LETI/ 30670 data ifnot(2) /LETF/ 30680 data ifnot(3) /LPAREN/ 30690 data ifnot(4) /PERIOD/ 30700 data ifnot(5) /LETN/ 30710 data ifnot(6) /LETO/ 30720 data ifnot(7) /LETT/ 30730 data ifnot(8) /PERIOD/ 30740 data ifnot(9) /EOS/ 30750 30760 lab = labgen(3) 30770 call outcon(0) 30780 if (gettok(token, MAXTOK) ^= LPAREN) { 30790 call synerr("missing left paren.") 30800 return 30810 } 30820 if (gettok(token, MAXTOK) ^= SEMICOL) { # real init clause 30830 call pbstr(token) 30840 call outtab 30850 call eatup 30860 call outdon 30870 } 30880 if (gettok(token, MAXTOK) == SEMICOL) # empty condition 30890 call outcon(lab) 30900 else { # non-empty condition 30910 call pbstr(token) 30920 call outnum(lab) 30930 call outtab 30940 call outstr(ifnot) 30950 call outch(LPAREN) 30960 nlpar = 0 30970 while (nlpar >= 0) { 30980 t = gettok(token, MAXTOK) 30990 if (t == SEMICOL) 31000 break 31010 if (t == LPAREN) 31020 nlpar = nlpar + 1 31030 else if (t == RPAREN) 31040 nlpar = nlpar - 1 31050 if (t ^= NEWLINE & t ^= UNDERLINE) 31060 call outstr(token) 31070 } 31080 call outch(RPAREN) 31090 call outch(RPAREN) 31100 call outgo(lab+2) 31110 if (nlpar < 0) 31120 call synerr("invalid for clause.") 31130 } 31140 fordep = fordep + 1 # stack reinit clause 31150 j = 1 31160 for (i = 1; i < fordep; i = i + 1) # find end 31170 j = j + length(forstk(j)) + 1 31180 forstk(j) = EOS # null, in case no reinit 31190 nlpar = 0 31200 while (nlpar >= 0) { 31210 t = gettok(token, MAXTOK) 31220 if (t == LPAREN) 31230 nlpar = nlpar + 1 31240 else if (t == RPAREN) 31250 nlpar = nlpar - 1 31260 if (nlpar >= 0 & t ^= NEWLINE & t ^= UNDERLINE) { 31270 call scopy(token, 1, forstk, j) 31280 j = j + length(token) 31290 } 31300 } 31310 lab = lab + 1 # label for next's 31320 return 31330 end 31340 # fors - process end of for statement 31350 subroutine fors(lab) 31360 integer length 31370 integer i, j, lab 31380 include commonblocks 31390 # include cfor 31400 31410 call outnum(lab) 31420 j = 1 31430 for (i = 1; i < fordep; i = i + 1) 31440 j = j + length(forstk(j)) + 1 31450 if (length(forstk(j)) > 0) { 31460 call outtab 31470 call outstr(forstk(j)) 31480 call outdon 31490 } 31500 call outgo(lab-1) 31510 call outcon(lab+1) 31520 fordep = fordep - 1 31530 return 31540 end 31550 # getch - get characters from file 31560 integer function getch(c, f) 31570 character inmap 31580 character buf(MAXLINE), c 31590 integer f, i, lastc 31600 data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/ 31610 # note: MAXLINE = MAXCARD + 1 31620 31630 if (buf(lastc) == NEWLINE | lastc >= MAXLINE) { 31640 read(f, 1, end=10) (buf(i), i = 1, MAXCARD) 31650 1 format(MAXCARD a1) 31660 for (i = 1; i <= MAXCARD; i = i + 1) 31670 buf(i) = inmap(buf(i)) 31680 for (i = MAXCARD; i > 0; i = i - 1) 31690 if (buf(i) ^= BLANK) 31700 break 31710 buf(i+1) = NEWLINE 31720 lastc = 0 31730 } 31740 lastc = lastc + 1 31750 c = buf(lastc) 31760 getch = c 31770 return 31780 31790 10 c = EOF 31800 getch = EOF 31810 return 31820 end 31830 # getdef (for no arguments) - get name and definition 31840 subroutine getdef(token, toksiz, defn, defsiz, fd) 31850 character gtok, ngetch 31860 integer defsiz, fd, i, nlpar, toksiz 31870 character c, defn(defsiz), token(toksiz) 31880 31890 if (ngetch(c, fd) ^= LPAREN) 31900 call remark("missing left paren.") 31910 if (gtok(token, toksiz, fd) ^= ALPHA) 31920 call remark("non-alphanumeric name.") 31930 else if (ngetch(c, fd) ^= COMMA) 31940 call remark("missing comma in define.") 31950 # else got (name, 31960 nlpar = 0 31970 for (i = 1; nlpar >= 0; i = i + 1) 31980 if (i > defsiz) 31990 call error("definition too long.") 32000 else if (ngetch(defn(i), fd) == EOF) 32010 call error("missing right paren.") 32020 else if (defn(i) == LPAREN) 32030 nlpar = nlpar + 1 32040 else if (defn(i) == RPAREN) 32050 nlpar = nlpar - 1 32060 # else normal character in defn(i) 32070 defn(i-1) = EOS 32080 return 32090 end 32100 # gettok - get token. handles file inclusion and line numbers 32110 character function gettok(token, toksiz) 32120 integer equal, open 32130 integer junk, toksiz 32140 character deftok 32150 character name(MAXNAME), token(toksiz) 32160 include commonblocks 32170 # include cline 32180 # string incl "include" 32190 integer incl(8) 32200 data incl(1) /LETI/ 32210 data incl(2) /LETN/ 32220 data incl(3) /LETC/ 32230 data incl(4) /LETL/ 32240 data incl(5) /LETU/ 32250 data incl(6) /LETD/ 32260 data incl(7) /LETE/ 32270 data incl(8) /EOS/ 32280 32290 for ( ; level > 0; level = level - 1) { 32300 for (gettok = deftok(token, toksiz, infile(level)); gettok ^= EOF; 32310 gettok = deftok(token, toksiz, infile(level))) { 32320 if (equal(token, incl) == NO) 32330 return 32340 junk = deftok(name, MAXNAME, infile(level)) 32350 if (level >= NFILES) 32360 call synerr("includes nested too deeply.") 32370 else { 32380 infile(level+1) = open(name, READONLY) 32390 linect(level+1) = 1 32400 if (infile(level+1) == ERR) 32410 call synerr("can't open include.") 32420 else 32430 level = level + 1 32440 } 32450 } 32460 if (level > 1) 32470 call close(infile(level)) 32480 } 32490 gettok = EOF 32500 return 32510 end 32520 # gtok - get token for Ratfor 32530 character function gtok(lexstr, toksiz, fd) 32540 character ngetch, type 32550 integer fd, i, toksiz 32560 character c, lexstr(toksiz) 32570 include commonblocks 32580 # include cline 32590 32600 while (ngetch(c, fd) ^= EOF) 32610 if (c ^= BLANK & c ^= TAB) 32620 break 32630 call putbak(c) 32640 for (i = 1; i < toksiz-1; i = i + 1) { 32650 gtok = type(ngetch(lexstr(i), fd)) 32660 if (gtok ^= LETTER & gtok ^= DIGIT) 32670 break 32680 } 32690 if (i >= toksiz-1) 32700 call synerr("token too long.") 32710 if (i > 1) { # some alpha seen 32720 call putbak(lexstr(i)) # went one too far 32730 lexstr(i) = EOS 32740 gtok = ALPHA 32750 } 32760 else if (lexstr(1) == DOLLAR) { # allow $( and $) for { and } 32770 if (ngetch(lexstr(2), fd) == LPAREN) { 32780 lexstr(1) = LBRACE 32790 gtok = LBRACE 32800 } 32810 else if (lexstr(2) == RPAREN) { 32820 lexstr(1) = RBRACE 32830 gtok = RBRACE 32840 } 32850 else 32860 call putbak(lexstr(2)) 32870 } 32880 else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) { 32890 for (i = 2; ngetch(lexstr(i), fd) ^= lexstr(1); i = i + 1) 32900 if (lexstr(i) == NEWLINE | i >= toksiz-1) { 32910 call synerr("missing quote.") 32920 lexstr(i) = lexstr(1) 32930 call putbak(NEWLINE) 32940 break 32950 } 32960 } 32970 else if (lexstr(1) == SHARP) { # strip comments 32980 while (ngetch(lexstr(1), fd) ^= NEWLINE) 32990 ; 33000 gtok = NEWLINE 33010 } 33020 else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT 33030 | lexstr(1) == EQUALS | lexstr(1) == AMPER | lexstr(1) == BAR) 33040 call relate(lexstr, i, fd) 33050 lexstr(i+1) = EOS 33060 if (lexstr(1) == NEWLINE) 33070 linect(level) = linect(level) + 1 33080 return 33090 end 33100 # ifcode - generate initial code for if 33110 subroutine ifcode(lab) 33120 integer labgen 33130 integer lab 33140 33150 lab = labgen(2) 33160 call ifgo(lab) 33170 return 33180 end 33190 # ifgo - generate "if(.not.(...))goto lab" 33200 subroutine ifgo(lab) 33210 integer lab 33220 # string ifnot "if(.not." 33230 integer ifnot(9) 33240 data ifnot(1) /LETI/ 33250 data ifnot(2) /LETF/ 33260 data ifnot(3) /LPAREN/ 33270 data ifnot(4) /PERIOD/ 33280 data ifnot(5) /LETN/ 33290 data ifnot(6) /LETO/ 33300 data ifnot(7) /LETT/ 33310 data ifnot(8) /PERIOD/ 33320 data ifnot(9) /EOS/ 33330 33340 call outtab # get to column 7 33350 call outstr(ifnot) # " if(.not. " 33360 call balpar # collect and output condition 33370 call outch(RPAREN) # " ) " 33380 call outgo(lab) # " goto lab " 33390 return 33400 end 33410 # index - find character c in string str 33420 integer function index(str, c) 33430 character c, str(ARB) 33440 33450 for (index = 1; str(index) ^= EOS; index = index + 1) 33460 if (str(index) == c) 33470 return 33480 index = 0 33490 return 33500 end 33510 # initkw - install keyword "define" in table 33520 subroutine initkw 33530 # string defnam "define" 33540 integer defnam(7), deftyp(2) 33550 data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ 33560 data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ 33570 data defnam(7) /EOS/ 33580 data deftyp(1), deftyp(2) /DEFTYPE, EOS/ 33590 33600 call instal(defnam, deftyp) 33610 return 33620 end 33630 # inmap - convert left adjusted external rep to right adj ascii 33640 integer function inmap(inchar) 33650 integer i, inchar 33660 include commonblocks 33670 # include cchar 33680 33690 if (inchar == extblk) { 33700 inmap = intblk 33710 return 33720 } 33730 do i = 1, 10 33740 if (inchar == extdig(i)) { 33750 inmap = intdig(i) 33760 return 33770 } 33780 do i = 1, 26 33790 if (inchar == extlet(i)) { 33800 inmap = intlet(i) 33810 return 33820 } 33830 do i = 1, 26 33840 if (inchar == extbig(i)) { 33850 inmap = intbig(i) 33860 return 33870 } 33880 do i = 1, NCHARS 33890 if (inchar == extchr(i)) { 33900 inmap = intchr(i) 33910 return 33920 } 33930 inmap = inchar 33940 return 33950 end 33960 # instal - add name and definition to table 33970 subroutine instal(name, defn) 33980 character defn(MAXTOK), name(MAXDEF) 33990 integer length 34000 integer dlen, nlen 34010 include commonblocks 34020 # include clook 34030 34040 nlen = length(name) + 1 34050 dlen = length(defn) + 1 34060 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { 34070 call putlin(name, ERROUT) 34080 call remark(": too many definitions.") 34090 } 34100 lastp = lastp + 1 34110 namptr(lastp) = lastt + 1 34120 call scopy(name, 1, table, lastt + 1) 34130 call scopy(defn, 1, table, lastt + nlen + 1) 34140 lastt = lastt + nlen + dlen 34150 return 34160 end 34170 # itoc - convert integer int to char string in str 34180 integer function itoc(int, str, size) 34190 integer abs, mod 34200 integer d, i, int, intval, j, k, size 34210 character str(size) 34220 # string digits "0123456789" 34230 integer digits(11) 34240 data digits(1) /DIG0/ 34250 data digits(2) /DIG1/ 34260 data digits(3) /DIG2/ 34270 data digits(4) /DIG3/ 34280 data digits(5) /DIG4/ 34290 data digits(6) /DIG5/ 34300 data digits(7) /DIG6/ 34310 data digits(8) /DIG7/ 34320 data digits(9) /DIG8/ 34330 data digits(10) /DIG9/ 34340 data digits(11) /EOS/ 34350 34360 intval = abs(int) 34370 str(1) = EOS 34380 i = 1 34390 repeat { # generate digits 34400 i = i + 1 34410 d = mod(intval, 10) 34420 str(i) = digits(d+1) 34430 intval = intval / 10 34440 } until (intval == 0 | i >= size) 34450 if (int < 0 & i < size) { # then sign 34460 i = i + 1 34470 str(i) = MINUS 34480 } 34490 itoc = i - 1 34500 for (j = 1; j < i; j = j + 1) { # then reverse 34510 k = str(i) 34520 str(i) = str(j) 34530 str(j) = k 34540 i = i - 1 34550 } 34560 return 34570 end 34580 # labelc - output statement number 34590 subroutine labelc(lexstr) 34600 character lexstr(ARB) 34610 integer length 34620 34630 if (length(lexstr) == 5) # warn about 23xxx labels 34640 if (lexstr(1) == DIG2 & lexstr(2) == DIG3) 34650 call synerr("warning: possible label conflict.") 34660 call outstr(lexstr) 34670 call outtab 34680 return 34690 end 34700 # labgen - generate n consecutive labels, return first one 34710 integer function labgen(n) 34720 integer label, n 34730 data label /23000/ 34740 34750 labgen = label 34760 label = label + n 34770 return 34780 end 34790 # length - compute length of string 34800 integer function length(str) 34810 integer str(ARB) 34820 34830 for (length = 0; str(length+1) ^= EOS; length = length + 1) 34840 ; 34850 return 34860 end 34870 # lex - return lexical type of token 34880 integer function lex(lexstr) 34890 character gettok 34900 character lexstr(MAXTOK) 34910 integer alldig, equal 34920 include commonblocks 34930 # include ckeywd 34940 34950 while (gettok(lexstr, MAXTOK) == NEWLINE) 34960 ; 34970 lex = lexstr(1) 34980 if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE) 34990 return 35000 if (alldig(lexstr) == YES) 35010 lex = LEXDIGITS 35020 else if (equal(lexstr, sif) == YES) 35030 lex = vif(1) 35040 else if (equal(lexstr, selse) == YES) 35050 lex = velse(1) 35060 else if (equal(lexstr, swhile) == YES) 35070 lex = vwhile(1) 35080 else if (equal(lexstr, sdo) == YES) 35090 lex = vdo(1) 35100 else if (equal(lexstr, sbreak) == YES) 35110 lex = vbreak(1) 35120 else if (equal(lexstr, snext) == YES) 35130 lex = vnext(1) 35140 else if (equal(lexstr, sfor) == YES) 35150 lex = vfor(1) 35160 else if (equal(lexstr, srept) == YES) 35170 lex = vrept(1) 35180 else if (equal(lexstr, suntil) == YES) 35190 lex = vuntil(1) 35200 else 35210 lex = LEXOTHER 35220 return 35230 end 35240 # lookup - locate name, extract definition from table 35250 integer function lookup(name, defn) 35260 character defn(MAXDEF), name(MAXTOK) 35270 integer i, j, k 35280 include commonblocks 35290 # include clook 35300 35310 for (i = lastp; i > 0; i = i - 1) { 35320 j = namptr(i) 35330 for (k = 1; name(k) == table(j) & name(k) ^= EOS; k = k + 1) 35340 j = j + 1 35350 if (name(k) == table(j)) { # got one 35360 call scopy(table, j+1, defn, 1) 35370 lookup = YES 35380 return 35390 } 35400 } 35410 lookup = NO 35420 return 35430 end 35440 # ngetch - get a (possibly pushed back) character 35450 character function ngetch(c, fd) 35460 character getch 35470 character c 35480 integer fd 35490 include commonblocks 35500 # include cdefio 35510 35520 if (bp > 0) 35530 c = buf(bp) 35540 else { 35550 bp = 1 35560 buf(bp) = getch(c, fd) 35570 } 35580 bp = bp - 1 35590 ngetch = c 35600 return 35610 end 35620 # open - exceedingly temporary version for gettok 35630 integer function open(name, mode) 35640 character name(MAXNAME) 35650 integer ctoi 35660 integer i, mode 35670 35680 i = 1 35690 open = ctoi(name, i) 35700 return 35710 end 35720 # otherc - output ordinary Fortran statement 35730 subroutine otherc(lexstr) 35740 character lexstr(ARB) 35750 35760 call outtab 35770 call outstr(lexstr) 35780 call eatup 35790 call outdon 35800 return 35810 end 35820 # outch - put one character into output buffer 35830 subroutine outch(c) 35840 character c 35850 integer i 35860 include commonblocks 35870 # include coutln 35880 35890 if (outp >= 72) { # continuation card 35900 call outdon 35910 for (i = 1; i < 6; i = i + 1) 35920 outbuf(i) = BLANK 35930 outbuf(6) = STAR 35940 outp = 6 35950 } 35960 outp = outp + 1 35970 outbuf(outp) = c 35980 return 35990 end 36000 # outcon - output "n continue" 36010 subroutine outcon(n) 36020 integer n 36030 # string contin "continue" 36040 integer contin(9) 36050 data contin(1) /LETC/ 36060 data contin(2) /LETO/ 36070 data contin(3) /LETN/ 36080 data contin(4) /LETT/ 36090 data contin(5) /LETI/ 36100 data contin(6) /LETN/ 36110 data contin(7) /LETU/ 36120 data contin(8) /LETE/ 36130 data contin(9) /EOS/ 36140 36150 if (n > 0) 36160 call outnum(n) 36170 call outtab 36180 call outstr(contin) 36190 call outdon 36200 return 36210 end 36220 # outdon - finish off an output line 36230 subroutine outdon 36240 include commonblocks 36250 # include coutln 36260 36270 outbuf(outp+1) = NEWLINE 36280 outbuf(outp+2) = EOS 36290 call putlin(outbuf, STDOUT) 36300 outp = 0 36310 return 36320 end 36330 # outgo - output "goto n" 36340 subroutine outgo(n) 36350 integer n 36360 # string goto "goto" 36370 integer goto(6) 36380 data goto(1) /LETG/ 36390 data goto(2) /LETO/ 36400 data goto(3) /LETT/ 36410 data goto(4) /LETO/ 36420 data goto(5) /BLANK/ 36430 data goto(6) /EOS/ 36440 36450 call outtab 36460 call outstr(goto) 36470 call outnum(n) 36480 call outdon 36490 return 36500 end 36510 # outmap - convert right adj ascii to left adjusted external rep 36520 integer function outmap(inchar) 36530 integer i, inchar 36540 include commonblocks 36550 # include cchar 36560 36570 if (inchar == intblk) { 36580 outmap = extblk 36590 return 36600 } 36610 do i = 1, 10 36620 if (inchar == intdig(i)) { 36630 outmap = extdig(i) 36640 return 36650 } 36660 do i = 1, 26 36670 if (inchar == intlet(i)) { 36680 outmap = extlet(i) 36690 return 36700 } 36710 do i = 1, 26 36720 if (inchar == intbig(i)) { 36730 outmap = extbig(i) 36740 return 36750 } 36760 do i = 1, NCHARS 36770 if (inchar == intchr(i)) { 36780 outmap = extchr(i) 36790 return 36800 } 36810 outmap = inchar 36820 return 36830 end 36840 # outnum - output decimal number 36850 subroutine outnum(n) 36860 character chars(MAXCHARS) 36870 integer itoc 36880 integer i, len, n 36890 36900 len = itoc(n, chars, MAXCHARS) 36910 for (i = 1; i <= len; i = i + 1) 36920 call outch(chars(i)) 36930 return 36940 end 36950 # outstr - output string 36960 subroutine outstr(str) 36970 character c, str(ARB) 36980 integer i, j 36990 37000 for (i = 1; str(i) ^= EOS; i = i + 1) { 37010 c = str(i) 37020 if (c ^= SQUOTE & c ^= DQUOTE) 37030 call outch(c) 37040 else { 37050 i = i + 1 37060 for (j = i; str(j) ^= c; j = j + 1) # find end 37070 ; 37080 call outnum(j-i) 37090 call outch(LETH) 37100 for ( ; i < j; i = i + 1) 37110 call outch(str(i)) 37120 } 37130 } 37140 return 37150 end 37160 # outtab - get past column 6 37170 subroutine outtab 37180 include commonblocks 37190 # include coutln 37200 37210 while (outp < 6) 37220 call outch(BLANK) 37230 return 37240 end 37250 # parse - parse Ratfor source program 37260 subroutine parse 37270 character lexstr(MAXTOK) 37280 integer lex 37290 integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token 37300 37310 call initkw # install keywords in table 37320 sp = 1 37330 lextyp(1) = EOF 37340 for (token = lex(lexstr); token ^= EOF; token = lex(lexstr)) { 37350 if (token == LEXIF) 37360 call ifcode(lab) 37370 else if (token == LEXDO) 37380 call docode(lab) 37390 else if (token == LEXWHILE) 37400 call whilec(lab) 37410 else if (token == LEXFOR) 37420 call forcod(lab) 37430 else if (token == LEXREPEAT) 37440 call repcod(lab) 37450 else if (token == LEXDIGITS) 37460 call labelc(lexstr) 37470 else if (token == LEXELSE) { 37480 if (lextyp(sp) == LEXIF) 37490 call elseif(labval(sp)) 37500 else 37510 call synerr("illegal else.") 37520 } 37530 if (token==LEXIF | token==LEXELSE | token==LEXWHILE 37540 | token==LEXFOR | token==LEXREPEAT 37550 | token==LEXDO | token==LEXDIGITS | token==LBRACE) { 37560 sp = sp + 1 # beginning of statement 37570 if (sp > MAXSTACK) 37580 call error("stack overflow in parser.") 37590 lextyp(sp) = token # stack type and value 37600 labval(sp) = lab 37610 } 37620 else { # end of statement - prepare to unstack 37630 if (token == RBRACE) { 37640 if (lextyp(sp) == LBRACE) 37650 sp = sp - 1 37660 else 37670 call synerr("illegal right brace.") 37680 } 37690 else if (token == LEXOTHER) 37700 call otherc(lexstr) 37710 else if (token == LEXBREAK | token == LEXNEXT) 37720 call brknxt(sp, lextyp, labval, token) 37730 token = lex(lexstr) # peek at next token 37740 call pbstr(lexstr) 37750 call unstak(sp, lextyp, labval, token) 37760 } 37770 } 37780 if (sp ^= 1) 37790 call synerr("unexpected EOF.") 37800 return 37810 end 37820 # pbstr - push string back onto input 37830 subroutine pbstr(in) 37840 character in(ARB) 37850 integer length 37860 integer i 37870 37880 for (i = length(in); i > 0; i = i - 1) 37890 call putbak(in(i)) 37900 return 37910 end 37920 # putbak - push character back onto input 37930 subroutine putbak(c) 37940 character c 37950 include commonblocks 37960 # include cdefio 37970 37980 bp = bp + 1 37990 if (bp > BUFSIZE) 38000 call error("too many characters pushed back.") 38010 buf(bp) = c 38020 return 38030 end 38040 # putch (interim version) put characters 38050 subroutine putch(c, f) 38060 integer buf(MAXLINE), c 38070 integer outmap 38080 integer f, i, lastc 38090 data lastc /0/ 38100 38110 if (lastc >= MAXLINE | c == NEWLINE) { 38120 if ( lastc <= 0 ) { 38130 write(f,2) 38140 2 format(/) 38150 } 38160 else { 38170 write(f, 1) (buf(i), i = 1, lastc) 38180 1 format(MAXCARD a1) 38190 } 38200 lastc = 0 38210 } 38220 if (c ^= NEWLINE) { 38230 lastc = lastc + 1 38240 buf(lastc) = outmap(c) 38250 } 38260 return 38270 end 38280 # putlin - put out line by repeated calls to putch 38290 subroutine putlin(b, f) 38300 character b(ARB) 38310 integer f, i 38320 38330 for (i = 1; b(i) ^= EOS; i = i + 1) 38340 call putch(b(i), f) 38350 return 38360 end 38370 # relate - convert relational shorthands into long form 38380 subroutine relate(token, last, fd) 38390 character ngetch 38400 character token(ARB) 38410 integer length 38420 integer fd, last 38430 # string dotge ".ge." 38440 # string dotgt ".gt." 38450 # string dotlt ".lt." 38460 # string dotle ".le." 38470 # string dotne ".ne." 38480 # string dotnot ".not." 38490 # string doteq ".eq." 38500 # string dotand ".and." 38510 # string dotor ".or." 38520 integer dotge(5), dotgt(5), dotlt(5), dotle(5) 38530 integer dotne(5), dotnot(6), doteq(5), dotand(6), dotor(5) 38540 data dotge(1), dotge(2), dotge(3), dotge(4), dotge(5)/ PERIOD, 38550 LETG, LETE, PERIOD, EOS/ 38560 data dotgt(1), dotgt(2), dotgt(3), dotgt(4), dotgt(5)/ PERIOD, 38570 LETG, LETT, PERIOD, EOS/ 38580 data dotle(1), dotle(2), dotle(3), dotle(4), dotle(5)/ PERIOD, 38590 LETL, LETE, PERIOD, EOS/ 38600 data dotlt(1), dotlt(2), dotlt(3), dotlt(4), dotlt(5)/ PERIOD, 38610 LETL, LETT, PERIOD, EOS/ 38620 data dotne(1), dotne(2), dotne(3), dotne(4), dotne(5)/ PERIOD, 38630 LETN, LETE, PERIOD, EOS/ 38640 data doteq(1), doteq(2), doteq(3), doteq(4), doteq(5)/ PERIOD, 38650 LETE, LETQ, PERIOD, EOS/ 38660 data dotor(1), dotor(2), dotor(3), dotor(4), dotor(5)/ PERIOD, 38670 LETO, LETR, PERIOD, EOS/ 38680 data dotand(1), dotand(2), dotand(3), dotand(4), dotand(5), 38690 dotand(6) /PERIOD, LETA, LETN, LETD, PERIOD, EOS/ 38700 data dotnot(1), dotnot(2), dotnot(3), dotnot(4), dotnot(5), 38710 dotnot(6) /PERIOD, LETN, LETO, LETT, PERIOD, EOS/ 38720 38730 if (ngetch(token(2), fd) ^= EQUALS) 38740 call putbak(token(2)) 38750 if (token(1) == GREATER) { 38760 if (token(2) == EQUALS) 38770 call scopy(dotge, 1, token, 1) 38780 else 38790 call scopy(dotgt, 1, token, 1) 38800 } 38810 else if (token(1) == LESS) { 38820 if (token(2) == EQUALS) 38830 call scopy(dotle, 1, token, 1) 38840 else 38850 call scopy(dotlt, 1, token, 1) 38860 } 38870 else if (token(1) == NOT) { 38880 if (token(2) == EQUALS) 38890 call scopy(dotne, 1, token, 1) 38900 else 38910 call scopy(dotnot, 1, token, 1) 38920 } 38930 else if (token(1) == EQUALS) { 38940 if (token(2) == EQUALS) 38950 call scopy(doteq, 1, token, 1) 38960 else 38970 token(2) = EOS 38980 } 38990 else if (token(1) == AMPER) 39000 call scopy(dotand, 1, token, 1) 39010 else if (token(1) == BAR) 39020 call scopy(dotor, 1, token, 1) 39030 else # can't happen 39040 token(2) = EOS 39050 last = length(token) 39060 return 39070 end 39080 # remark - print warning message 39090 # this version is intentionally crude, and should be replaced 39100 # instantaneously by something tuned for your 39110 # specific environment. 39120 subroutine remark(buf) 39130 integer buf(ARB), i 39140 39150 write(ERROUT, 10) (buf(i), i = 1, 5) 39160 10 format(5a4) 39170 return 39180 end 39190 # repcod - generate code for beginning of repeat 39200 subroutine repcod(lab) 39210 integer labgen 39220 integer lab 39230 39240 call outcon(0) # in case there was a label 39250 lab = labgen(3) 39260 call outcon(lab) 39270 lab = lab + 1 # label to go on next's 39280 return 39290 end 39300 # scopy - copy string at from(i) to to(j) 39310 subroutine scopy(from, i, to, j) 39320 character from(ARB), to(ARB) 39330 integer i, j, k1, k2 39340 39350 k2 = j 39360 for (k1 = i; from(k1) ^= EOS; k1 = k1 + 1) { 39370 to(k2) = from(k1) 39380 k2 = k2 + 1 39390 } 39400 to(k2) = EOS 39410 return 39420 end 39430 # synerr - report Ratfor syntax error 39440 subroutine synerr(msg) 39450 character lc(MAXLINE), msg(MAXLINE) 39460 integer itoc 39470 integer i, junk 39480 include commonblocks 39490 # include cline 39500 39510 call remark("error at line.") 39520 for (i = 1; i <= level; i = i + 1) { 39530 call putch(BLANK, ERROUT) 39540 junk = itoc(linect(i), lc, MAXLINE) 39550 call putlin(lc, ERROUT) 39560 } 39570 call putch(COLON, ERROUT) 39580 call putch(NEWLINE, ERROUT) 39590 call remark(msg) 39600 return 39610 end 39620 # type - return LETTER, DIGIT or character 39630 # this one works with ascii alphabet 39640 integer function type(c) 39650 integer c 39660 39670 if( c >= DIG0 & c <= DIG9 ) 39680 type = DIGIT 39690 else if( c >= LETA & c <= LETZ ) 39700 type = LETTER 39710 else if( c >= BIGA & c <= BIGZ ) 39720 type = LETTER 39730 else 39740 type = c 39750 return 39760 end 39770 # unstak - unstack at end of statement 39780 subroutine unstak(sp, lextyp, labval, token) 39790 integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token 39800 39810 for ( ; sp > 1; sp = sp - 1) { 39820 if (lextyp(sp) == LBRACE) 39830 break 39840 if (lextyp(sp) == LEXIF & token == LEXELSE) 39850 break 39860 if (lextyp(sp) == LEXIF) 39870 call outcon(labval(sp)) 39880 else if (lextyp(sp) == LEXELSE) { 39890 if (sp > 2) 39900 sp = sp - 1 39910 call outcon(labval(sp)+1) 39920 } 39930 else if (lextyp(sp) == LEXDO) 39940 call dostat(labval(sp)) 39950 else if (lextyp(sp) == LEXWHILE) 39960 call whiles(labval(sp)) 39970 else if (lextyp(sp) == LEXFOR) 39980 call fors(labval(sp)) 39990 else if (lextyp(sp) == LEXREPEAT) 40000 call untils(labval(sp), token) 40010 } 40020 return 40030 end 40040 # untils - generate code for until or end of repeat 40050 subroutine untils(lab, token) 40060 character ptoken(MAXTOK) 40070 integer lex 40080 integer junk, lab, token 40090 40100 call outnum(lab) 40110 if (token == LEXUNTIL) { 40120 junk = lex(ptoken) 40130 call ifgo(lab-1) 40140 } 40150 else 40160 call outgo(lab-1) 40170 call outcon(lab+1) 40180 return 40190 end 40200 # whilec - generate code for beginning of while 40210 subroutine whilec(lab) 40220 integer labgen 40230 integer lab 40240 40250 call outcon(0) # unlabeled continue, in case there was a label 40260 lab = labgen(2) 40270 call outnum(lab) 40280 call ifgo(lab+1) 40290 return 40300 end 40310 # whiles - generate code for end of while 40320 subroutine whiles(lab) 40330 integer lab 40340 40350 call outgo(lab) 40360 call outcon(lab+1) 40370 return 40380 end 40390 ========== miscellaneous support for all programs ========== 40400 # cant - print cant open file message 40410 subroutine cant(buf) 40420 integer buf(MAXLINE) 40430 40440 call putlin(buf, ERROUT) 40450 call error(" : can't open.") 40460 return 40470 end 40480 # ctoi - convert string at in(i) to integer, increment i 40490 integer function ctoi(in, i) 40500 character in(ARB) 40510 integer index 40520 integer d, i 40530 # string digits "0123456789" 40540 integer digits(11) 40550 data digits(1) /DIG0/ 40560 data digits(2) /DIG1/ 40570 data digits(3) /DIG2/ 40580 data digits(4) /DIG3/ 40590 data digits(5) /DIG4/ 40600 data digits(6) /DIG5/ 40610 data digits(7) /DIG6/ 40620 data digits(8) /DIG7/ 40630 data digits(9) /DIG8/ 40640 data digits(10) /DIG9/ 40650 data digits(11) /EOS/ 40660 40670 while (in(i) == BLANK | in(i) == TAB) 40680 i = i + 1 40690 for (ctoi = 0; in(i) ^= EOS; i = i + 1) { 40700 d = index(digits, in(i)) 40710 if (d == 0) # non-digit 40720 break 40730 ctoi = 10 * ctoi + d - 1 40740 } 40750 return 40760 end 40770 # equal - compare str1 to str2; return YES if equal, NO if not 40780 integer function equal(str1, str2) 40790 character str1(ARB), str2(ARB) 40800 integer i 40810 40820 for (i = 1; str1(i) == str2(i); i = i + 1) 40830 if (str1(i) == EOS) { 40840 equal = YES 40850 return 40860 } 40870 equal = NO 40880 return 40890 end 40900 # error - print fatal error message, then die 40910 subroutine error(buf) 40920 integer buf(ARB) 40930 40940 call remark(buf) 40950 stop 40960 end 40970 # fcopy - copy file in to file out 40980 subroutine fcopy(in, out) 40990 character buf(MAXLINE) 41000 integer getlin 41010 integer in, out 41020 41030 while (getlin(buf, in) ^= EOF) 41040 call putlin(buf, out) 41050 return 41060 end 41070 # index - find character c in string str 41080 integer function index(str, c) 41090 character c, str(ARB) 41100 41110 for (index = 1; str(index) ^= EOS; index = index + 1) 41120 if (str(index) == c) 41130 return 41140 index = 0 41150 return 41160 end 41170 41180 define(abs,iabs) 41190 # itoc - convert integer int to char string in str 41200 integer function itoc(int, str, size) 41210 integer abs, mod 41220 integer d, i, int, intval, j, k, size 41230 character str(size) 41240 # string digits "0123456789" 41250 integer digits(11) 41260 data digits(1) /DIG0/ 41270 data digits(2) /DIG1/ 41280 data digits(3) /DIG2/ 41290 data digits(4) /DIG3/ 41300 data digits(5) /DIG4/ 41310 data digits(6) /DIG5/ 41320 data digits(7) /DIG6/ 41330 data digits(8) /DIG7/ 41340 data digits(9) /DIG8/ 41350 data digits(10) /DIG9/ 41360 data digits(11) /EOS/ 41370 41380 intval = abs(int) 41390 str(1) = EOS 41400 i = 1 41410 repeat { # generate digits 41420 i = i + 1 41430 d = mod(intval, 10) 41440 str(i) = digits(d+1) 41450 intval = intval / 10 41460 } until (intval == 0 | i >= size) 41470 if (int < 0 & i < size) { # then sign 41480 i = i + 1 41490 str(i) = MINUS 41500 } 41510 itoc = i - 1 41520 for (j = 1; j < i; j = j + 1) { # then reverse 41530 k = str(i) 41540 str(i) = str(j) 41550 str(j) = k 41560 i = i - 1 41570 } 41580 return 41590 end 41600 # length - compute length of string 41610 integer function length(str) 41620 integer str(ARB) 41630 41640 for (length = 0; str(length+1) ^= EOS; length = length + 1) 41650 ; 41660 return 41670 end 41680 41690 define(MAXCHARS,10) 41700 41710 # putdec - put decimal integer n in field width >= w 41720 subroutine putdec(n, w) 41730 character chars(MAXCHARS) 41740 integer itoc 41750 integer i, n, nd, w 41760 41770 nd = itoc(n, chars, MAXCHARS) 41780 for (i = nd + 1; i <= w; i = i + 1) 41790 call putc(BLANK) 41800 for (i = 1; i <= nd; i = i + 1) 41810 call putc(chars(i)) 41820 return 41830 end 41840 # scopy - copy string at from(i) to to(j) 41850 subroutine scopy(from, i, to, j) 41860 character from(ARB), to(ARB) 41870 integer i, j, k1, k2 41880 41890 k2 = j 41900 for (k1 = i; from(k1) ^= EOS; k1 = k1 + 1) { 41910 to(k2) = from(k1) 41920 k2 = k2 + 1 41930 } 41940 to(k2) = EOS 41950 return 41960 end 41970 # type - determine type of character 41980 character function type(c) 41990 character c 42000 integer index 42010 integer upalf(27) 42020 integer lowalf(27) 42030 integer digits(11) 42040 # string digits "0123456789" 42050 data digits(1) /DIG0/ 42060 data digits(2) /DIG1/ 42070 data digits(3) /DIG2/ 42080 data digits(4) /DIG3/ 42090 data digits(5) /DIG4/ 42100 data digits(6) /DIG5/ 42110 data digits(7) /DIG6/ 42120 data digits(8) /DIG7/ 42130 data digits(9) /DIG8/ 42140 data digits(10) /DIG9/ 42150 data digits(11) /EOS/ 42160 # string lowalf "abcdefghijklmnopqrstuvwxyz" 42170 data lowalf(01)/LETA/ 42180 data lowalf(02)/LETB/ 42190 data lowalf(03)/LETC/ 42200 data lowalf(04)/LETD/ 42210 data lowalf(05)/LETE/ 42220 data lowalf(06)/LETF/ 42230 data lowalf(07)/LETG/ 42240 data lowalf(08)/LETH/ 42250 data lowalf(09)/LETI/ 42260 data lowalf(10)/LETJ/ 42270 data lowalf(11)/LETK/ 42280 data lowalf(12)/LETL/ 42290 data lowalf(13)/LETM/ 42300 data lowalf(14)/LETN/ 42310 data lowalf(15)/LETO/ 42320 data lowalf(16)/LETP/ 42330 data lowalf(17)/LETQ/ 42340 data lowalf(18)/LETR/ 42350 data lowalf(19)/LETS/ 42360 data lowalf(20)/LETT/ 42370 data lowalf(21)/LETU/ 42380 data lowalf(22)/LETV/ 42390 data lowalf(23)/LETW/ 42400 data lowalf(24)/LETX/ 42410 data lowalf(25)/LETY/ 42420 data lowalf(26)/LETZ/ 42430 data lowalf(27)/EOS/ 42440 # string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 42450 data upalf(01) /BIGA/ 42460 data upalf(02) /BIGB/ 42470 data upalf(03) /BIGC/ 42480 data upalf(04) /BIGD/ 42490 data upalf(05) /BIGE/ 42500 data upalf(06) /BIGF/ 42510 data upalf(07) /BIGG/ 42520 data upalf(08) /BIGH/ 42530 data upalf(09) /BIGI/ 42540 data upalf(10) /BIGJ/ 42550 data upalf(11) /BIGK/ 42560 data upalf(12) /BIGL/ 42570 data upalf(13) /BIGM/ 42580 data upalf(14) /BIGN/ 42590 data upalf(15) /BIGO/ 42600 data upalf(16) /BIGP/ 42610 data upalf(17) /BIGQ/ 42620 data upalf(18) /BIGR/ 42630 data upalf(19) /BIGS/ 42640 data upalf(20) /BIGT/ 42650 data upalf(21) /BIGU/ 42660 data upalf(22) /BIGV/ 42670 data upalf(23) /BIGW/ 42680 data upalf(24) /BIGX/ 42690 data upalf(25) /BIGY/ 42700 data upalf(26) /BIGZ/ 42710 data upalf(27) /EOS/ 42720 42730 if (index(lowalf, c) > 0) 42740 type = LETTER 42750 else if (index(upalf, c) > 0) 42760 type = LETTER 42770 else if (index(digits, c) > 0) 42780 type = DIGIT 42790 else 42800 type = c 42810 return 42820 end 42830 ========== programs from chapter 1 ========== 42840 # copy - copy input characters to output 42850 integer getc 42860 integer c 42870 42880 while (getc(c) ^= EOF) 42890 call putc(c) 42900 stop 42910 end 42920 42930 # charcount - count characters in standard input 42940 character getc 42950 character c 42960 integer nc 42970 42980 nc = 0 42990 while (getc(c) ^= EOF) 43000 nc = nc + 1 43010 call putdec(nc, 1) 43020 call putc(NEWLINE) 43030 stop 43040 end 43050 # linecount - count lines in standard input 43060 character getc 43070 character c 43080 integer nl 43090 43100 nl = 0 43110 while (getc(c) ^= EOF) 43120 if (c == NEWLINE) 43130 nl = nl + 1 43140 call putdec(nl, 1) 43150 call putc(NEWLINE) 43160 stop 43170 end 43180 # wordcount - count words in standard input 43190 character getc 43200 character c 43210 integer inword, wc 43220 43230 wc = 0 43240 inword = NO 43250 while (getc(c) ^= EOF) 43260 if (c == BLANK | c == NEWLINE | c == TAB) 43270 inword = NO 43280 else if (inword == NO) { 43290 inword = YES 43300 wc = wc + 1 43310 } 43320 call putdec(wc, 1) 43330 call putc(NEWLINE) 43340 stop 43350 end 43360 # detab - convert tabs to equivalent number of blanks 43370 character getc 43380 character c 43390 integer tabpos 43400 integer col, i, tabs(MAXLINE) 43410 43420 call settab(tabs) # set initial tab stops 43430 col = 1 43440 while (getc(c) ^= EOF) 43450 if (c == TAB) 43460 repeat { 43470 call putc(BLANK) 43480 col = col + 1 43490 } until (tabpos(col, tabs) == YES) 43500 else if (c == NEWLINE) { 43510 call putc(NEWLINE) 43520 col = 1 43530 } 43540 else { 43550 call putc(c) 43560 col = col + 1 43570 } 43580 stop 43590 end 43600 43610 # tabpos - return YES if col is a tab stop 43620 integer function tabpos(col, tabs) 43630 integer col, i, tabs(MAXLINE) 43640 43650 if (col > MAXLINE) 43660 tabpos = YES 43670 else 43680 tabpos = tabs(col) 43690 return 43700 end 43710 43720 # settab - set initial tab stops 43730 subroutine settab(tabs) 43740 integer mod 43750 integer i, tabs(MAXLINE) 43760 43770 for (i = 1; i <= MAXLINE; i = i + 1) 43780 if (mod(i, 8) == 1) 43790 tabs(i) = YES 43800 else 43810 tabs(i) = NO 43820 return 43830 end 43840 #c detab - convert tabs to equivalent number of blanks; Fortran version 43850 integer getc 43860 integer c 43870 integer tabpos 43880 integer col, i, tabs(MAXLINE) 43890 #c 43900 #c set initial tab stops 43910 call settab(tabs) 43920 col = 1 43930 10 if (getc(c) .eq. EOF) goto 60 43940 if (c .ne. TAB) goto 30 43950 20 call putc(BLANK) 43960 col = col + 1 43970 if (tabpos(col, tabs) .ne. YES) goto 20 43980 goto 50 43990 #c else if 44000 30 if (c .ne. NEWLINE) goto 40 44010 call putc(NEWLINE) 44020 col = 1 44030 goto 50 44040 #c else 44050 40 call putc(c) 44060 col = col + 1 44070 50 goto 10 44080 60 stop 44090 end 44100 44110 #c tabpos - return YES if col is a tab stop; Fortran version 44120 integer function tabpos(col, tabs) 44130 integer col, i, tabs(MAXLINE) 44140 #c 44150 if (col .gt. MAXLINE) tabpos = YES 44160 if (col .le. MAXLINE) tabpos = tabs(col) 44170 return 44180 end 44190 44200 #c settab - set initial tab stops; Fortran version 44210 subroutine settab(tabs) 44220 integer mod 44230 integer i, tabs(MAXLINE) 44240 #c 44250 i = 1 44260 10 if (i .gt. MAXLINE) goto 20 44270 if (mod(i, 8) .eq. 1) tabs(i) = YES 44280 if (mod(i, 8) .ne. 1) tabs(i) = NO 44290 i = i + 1 44300 goto 10 44310 20 return 44320 end 44330 /* copy _ copy input characters to output */ 44340 copy: procedure options (main); 44350 declare getc entry (fixed binary) returns (fixed binary); 44360 declare putc entry (fixed binary); 44370 declare c fixed binary; 44380 44390 do while (getc(c) ^= EOF); 44400 call putc(c); 44410 end; 44420 end copy; 44430 /* detab _ convert tabs into equivalent number of blanks */ 44440 detab: procedure options (main); 44450 declare getc entry (fixed binary) returns (fixed binary); 44460 declare putc entry (fixed binary); 44470 declare c fixed binary; 44480 declare settab entry ((*)fixed binary); 44490 declare tabpos entry (fixed bin, (*)fixed bin) returns (fixed bin); 44500 declare (col, tabs(MAXLINE)) fixed binary; 44510 44520 call settab(tabs); /* set initial tab stops */ 44530 col = 1; 44540 do while (getc(c) ^= EOF); 44550 if c = TAB then do; 44560 loop: 44570 call putc(BLANK); 44580 col = col + 1; 44590 if tabpos(col, tabs) ^= YES then 44600 goto loop; 44610 end; 44620 else if c = NEWLINE then do; 44630 call putc(NEWLINE); 44640 col = 1; 44650 end; 44660 else do; 44670 call putc(c); 44680 col = col + 1; 44690 end; 44700 end; 44710 end detab; 44720 44730 /* tabpos _ return YES if col is a tab stop */ 44740 tabpos: procedure (col, tabs) returns (fixed binary); 44750 declare (col, tabs(*)) fixed binary; 44760 44770 if col > MAXLINE then 44780 return(YES); 44790 else 44800 return(tabs(col)); 44810 end tabpos; 44820 44830 /* settab _ set initial tab stops */ 44840 settab: procedure (tabs); 44850 declare (i, tabs(*)) fixed binary; 44860 44870 do i = 1 to MAXLINE; 44880 if mod(i, 8) = 1 then 44890 tabs(i) = YES; 44900 else 44910 tabs(i) = NO; 44920 end; 44930 end settab; 44940 ========== smaller programs from chapter 2 ========== 44950 # entab - replace blanks by tabs and blanks 44960 character getc 44970 character c 44980 integer tabpos 44990 integer col, i, newcol, tabs(MAXLINE) 45000 45010 call settab(tabs) 45020 col = 1 45030 repeat { 45040 newcol = col 45050 while (getc(c) == BLANK) { # collect blanks 45060 newcol = newcol + 1 45070 if (tabpos(newcol, tabs) == YES) { 45080 call putc(TAB) 45090 col = newcol 45100 } 45110 } 45120 for ( ; col < newcol; col = col + 1) 45130 call putc(BLANK) # output leftover blanks 45140 if (c == EOF) 45150 break 45160 call putc(c) 45170 if (c == NEWLINE) 45180 col = 1 45190 else 45200 col = col + 1 45210 } 45220 stop 45230 end 45240 45250 # tabpos - return YES if col is a tab stop 45260 integer function tabpos(col, tabs) 45270 integer col, i, tabs(MAXLINE) 45280 45290 if (col > MAXLINE) 45300 tabpos = YES 45310 else 45320 tabpos = tabs(col) 45330 return 45340 end 45350 45360 # settab - set initial tab stops 45370 subroutine settab(tabs) 45380 integer mod 45390 integer i, tabs(MAXLINE) 45400 45410 for (i = 1; i <= MAXLINE; i = i + 1) 45420 if (mod(i, 8) == 1) 45430 tabs(i) = YES 45440 else 45450 tabs(i) = NO 45460 return 45470 end 45480 define(NOSKIP,PLUS) 45490 define(SKIP,STAR) 45500 # overstrike - convert backspaces into multiple lines 45510 character getc 45520 character c 45530 integer max 45540 integer col, newcol 45550 45560 col = 1 45570 repeat { 45580 newcol = col 45590 while (getc(c) == BACKSPACE) # eat up backspaces 45600 newcol = max(newcol-1, 1) 45610 if (newcol < col) { # start overstrike line 45620 call putc(NEWLINE) 45630 call putc(NOSKIP) 45640 for (col = 1; col < newcol; col = col + 1) 45650 call putc(BLANK) 45660 } 45670 else if (col == 1 & c ^= EOF) # start normal line 45680 call putc(SKIP) 45690 # else middle of line 45700 if (c == EOF) 45710 break 45720 call putc(c) # normal character 45730 if (c == NEWLINE) 45740 col = 1 45750 else 45760 col = col + 1 45770 } 45780 stop 45790 end 45800 define(RCODE,STAR) 45810 define(MAXCHUNK,10) 45820 define(THRESH,5) 45830 # compress - compress standard input 45840 character getc 45850 character buf(MAXCHUNK), c, lastc 45860 integer nrep, nsave 45870 # must have RCODE > MAXCHUNK or RCODE = 0 45880 45890 nsave = 0 45900 for (lastc = getc(lastc); lastc ^= EOF; lastc = c) { 45910 for (nrep = 1; getc(c) == lastc; nrep = nrep + 1) 45920 if (nrep >= MAXCHUNK) # count repetitions 45930 break 45940 if (nrep < THRESH) # append short string 45950 for ( ; nrep > 0; nrep = nrep - 1) { 45960 nsave = nsave + 1 45970 buf(nsave) = lastc 45980 if (nsave >= MAXCHUNK) 45990 call putbuf(buf, nsave) 46000 } 46010 else { 46020 call putbuf(buf, nsave) 46030 call putc(RCODE) 46040 call putc(lastc) 46050 call putc(nrep) 46060 } 46070 } 46080 call putbuf(buf, nsave) # put last chunk 46090 stop 46100 end 46110 46120 # putbuf - output buf(1) ... buf(nsave), clear nsave 46130 subroutine putbuf(buf, nsave) 46140 character buf(MAXCHUNK) 46150 integer i, nsave 46160 46170 if (nsave > 0) { 46180 call putc(nsave) 46190 for (i = 1; i <= nsave; i = i + 1) 46200 call putc(buf(i)) 46210 } 46220 nsave = 0 46230 return 46240 end 46250 define(RCODE,STAR) 46260 # expand - uncompress standard input 46270 character getc 46280 character c, code 46290 46300 while (getc(code) ^= EOF) 46310 if (code == RCODE) { # expand repetition 46320 if (getc(c) == EOF) 46330 break 46340 if (getc(code) == EOF) 46350 break 46360 for ( ; code > 0; code = code - 1) 46370 call putc(c) 46380 } 46390 else { # expand chunk 46400 for ( ; code > 0; code = code - 1) { 46410 if (getc(c) == EOF) 46420 break 46430 call putc(c) 46440 } 46450 if (c == EOF) 46460 break 46470 } 46480 stop 46490 end 46500 define(MAXKEY,50) 46510 # crypt - encrypt and decrypt 46520 character getc, xor 46530 character c, key(MAXKEY) 46540 integer getarg, mod 46550 integer i, keylen 46560 46570 keylen = getarg(1, key, MAXKEY) 46580 if (keylen == EOF) 46590 call error("usage: crypt key.") 46600 for (i = 1; getc(c) ^= EOF; i = mod(i, keylen) + 1) 46610 call putc(xor(c, key(i))) 46620 stop 46630 end 46640 # xor - exclusive-or of a and b 46650 character function xor(a, b) 46660 character and, not, or 46670 character a, b 46680 46690 xor = or(and(a, not(b)), and(not(a), b)) 46700 return 46710 end 46720 ========== translit program from chapter 2 ========== 46730 define(MAXARR,100) 46740 define(MAXSET,100) 46750 define(ESCAPE,ATSIGN) 46760 define(DASH,MINUS) 46770 define(NOT,BANG) 46780 # addset - put c in set(j) if it fits, increment j 46790 integer function addset(c, set, j, maxsiz) 46800 integer j, maxsiz 46810 character c, set(maxsiz) 46820 46830 if (j > maxsiz) 46840 addset = NO 46850 else { 46860 set(j) = c 46870 j = j + 1 46880 addset = YES 46890 } 46900 return 46910 end 46920 # dodash - expand array(i-1)-array(i+1) into set(j)... from valid 46930 subroutine dodash(valid, array, i, set, j, maxset) 46940 character esc 46950 integer addset, index 46960 integer i, j, junk, k, limit, maxset 46970 character array(ARB), set(maxset), valid(ARB) 46980 46990 i = i + 1 47000 j = j - 1 47010 limit = index(valid, esc(array, i)) 47020 for (k = index(valid, set(j)); k <= limit; k = k + 1) 47030 junk = addset(valid(k), set, j, maxset) 47040 return 47050 end 47060 # esc - map array(i) into escaped character if appropriate 47070 character function esc(array, i) 47080 character array(ARB) 47090 integer i 47100 47110 if (array(i) ^= ESCAPE) 47120 esc = array(i) 47130 else if (array(i+1) == EOS) # \*a not special at end 47140 esc = ESCAPE 47150 else { 47160 i = i + 1 47170 if (array(i) == LETN) 47180 esc = NEWLINE 47190 else if (array(i) == LETT) 47200 esc = TAB 47210 else 47220 esc = array(i) 47230 } 47240 return 47250 end 47260 # filset - expand set at array(i) into set(j), stop at delim 47270 subroutine filset(delim, array, i, set, j, maxset) 47280 character esc 47290 integer addset, index 47300 integer i, j, junk, maxset 47310 character array(ARB), delim, set(maxset) 47320 # string digits "0123456789" 47330 integer digits(11) 47340 # string lowalf "abcdefghijklmnopqrstuvwxyz" 47350 integer lowalf(27) 47360 # string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 47370 integer upalf(27) 47380 data digits(1)/DIG0/, digits(2)/DIG1/, digits(3)/DIG2/ 47390 data digits(4)/DIG3/, digits(5)/DIG4/, digits(6)/DIG5/ 47400 data digits(7)/DIG6/, digits(8)/DIG7/, digits(9)/DIG8/ 47410 data digits(10)/DIG9/, digits(11)/EOS/ 47420 data lowalf(01)/LETA/ 47430 data lowalf(02)/LETB/ 47440 data lowalf(03)/LETC/ 47450 data lowalf(04)/LETD/ 47460 data lowalf(05)/LETE/ 47470 data lowalf(06)/LETF/ 47480 data lowalf(07)/LETG/ 47490 data lowalf(08)/LETH/ 47500 data lowalf(09)/LETI/ 47510 data lowalf(10)/LETJ/ 47520 data lowalf(11)/LETK/ 47530 data lowalf(12)/LETL/ 47540 data lowalf(13)/LETM/ 47550 data lowalf(14)/LETN/ 47560 data lowalf(15)/LETO/ 47570 data lowalf(16)/LETP/ 47580 data lowalf(17)/LETQ/ 47590 data lowalf(18)/LETR/ 47600 data lowalf(19)/LETS/ 47610 data lowalf(20)/LETT/ 47620 data lowalf(21)/LETU/ 47630 data lowalf(22)/LETV/ 47640 data lowalf(23)/LETW/ 47650 data lowalf(24)/LETX/ 47660 data lowalf(25)/LETY/ 47670 data lowalf(26)/LETZ/ 47680 data lowalf(27)/EOS/ 47690 data upalf(01) /BIGA/ 47700 data upalf(02) /BIGB/ 47710 data upalf(03) /BIGC/ 47720 data upalf(04) /BIGD/ 47730 data upalf(05) /BIGE/ 47740 data upalf(06) /BIGF/ 47750 data upalf(07) /BIGG/ 47760 data upalf(08) /BIGH/ 47770 data upalf(09) /BIGI/ 47780 data upalf(10) /BIGJ/ 47790 data upalf(11) /BIGK/ 47800 data upalf(12) /BIGL/ 47810 data upalf(13) /BIGM/ 47820 data upalf(14) /BIGN/ 47830 data upalf(15) /BIGO/ 47840 data upalf(16) /BIGP/ 47850 data upalf(17) /BIGQ/ 47860 data upalf(18) /BIGR/ 47870 data upalf(19) /BIGS/ 47880 data upalf(20) /BIGT/ 47890 data upalf(21) /BIGU/ 47900 data upalf(22) /BIGV/ 47910 data upalf(23) /BIGW/ 47920 data upalf(24) /BIGX/ 47930 data upalf(25) /BIGY/ 47940 data upalf(26) /BIGZ/ 47950 data upalf(27) /EOS/ 47960 47970 for ( ; array(i) ^= delim & array(i) ^= EOS; i = i + 1) 47980 if (array(i) == ESCAPE) 47990 junk = addset(esc(array, i), set, j, maxset) 48000 else if (array(i) ^= DASH) 48010 junk = addset(array(i), set, j, maxset) 48020 else if (j <= 1 | array(i+1) == EOS) # literal - 48030 junk = addset(DASH, set, j, maxset) 48040 else if (index(digits, set(j-1)) > 0) 48050 call dodash(digits, array, i, set, j, maxset) 48060 else if (index(lowalf, set(j-1)) > 0) 48070 call dodash(lowalf, array, i, set, j, maxset) 48080 else if (index(upalf, set(j-1)) > 0) 48090 call dodash(upalf, array, i, set, j, maxset) 48100 else 48110 junk = addset(DASH, set, j, maxset) 48120 return 48130 end 48140 # makset - make set from array(k) in set 48150 integer function makset(array, k, set, size) 48160 integer addset 48170 integer i, j, k, size 48180 character array(ARB), set(size) 48190 48200 i = k 48210 j = 1 48220 call filset(EOS, array, i, set, j, size) 48230 makset = addset(EOS, set, j, size) 48240 return 48250 end 48260 # translit - map characters 48270 character getc 48280 character arg(MAXARR), c, from(MAXSET), to(MAXSET) 48290 integer getarg, length, makset, xindex 48300 integer allbut, collap, i, lastto 48310 48320 if (getarg(1, arg, MAXARR) == EOF) 48330 call error("usage: translit from to.") 48340 else if (arg(1) == NOT) { 48350 allbut = YES 48360 if (makset(arg, 2, from, MAXSET) == NO) 48370 call error("from: too large.") 48380 } 48390 else { 48400 allbut = NO 48410 if (makset(arg, 1, from, MAXSET) == NO) 48420 call error("from: too large.") 48430 } 48440 if (getarg(2, arg, MAXARR) == EOF) 48450 to(1) = EOS 48460 else if (makset(arg, 1, to, MAXSET) == NO) 48470 call error("to: too large.") 48480 48490 lastto = length(to) 48500 if (length(from) > lastto | allbut == YES) 48510 collap = YES 48520 else 48530 collap = NO 48540 repeat { 48550 i = xindex(from, getc(c), allbut, lastto) 48560 if (collap == YES & i >= lastto & lastto > 0) { # collapse 48570 call putc(to(lastto)) 48580 repeat 48590 i = xindex(from, getc(c), allbut, lastto) 48600 until (i < lastto) 48610 } 48620 if (c == EOF) 48630 break 48640 if (i > 0 & lastto > 0) # translate 48650 call putc(to(i)) 48660 else if (i == 0) # copy 48670 call putc(c) 48680 # else delete 48690 } 48700 stop 48710 end 48720 # xindex - invert condition returned by index 48730 integer function xindex(array, c, allbut, lastto) 48740 character array(ARB), c 48750 integer index 48760 integer allbut, lastto 48770 48780 if (c == EOF) 48790 xindex = 0 48800 else if (allbut == NO) 48810 xindex = index(array, c) 48820 else if (index(array, c) > 0) 48830 xindex = 0 48840 else 48850 xindex = lastto + 1 48860 return 48870 end 48880 ========== smaller programs from chapter 3 ========== 48890 define(INFILE1,1) 48900 define(INFILE2,2) 48910 define(NAMESIZE,50) 48920 # compare (simple version) - compare file 1 to file 2 48930 character line1(MAXLINE), line2(MAXLINE) 48940 integer equal, getlin 48950 integer lineno, m1, m2 48960 48970 lineno = 0 48980 repeat { 48990 m1 = getlin(line1, INFILE1) 49000 m2 = getlin(line2, INFILE2) 49010 if (m1 == EOF | m2 == EOF) 49020 break 49030 lineno = lineno + 1 49040 if (equal(line1, line2) == NO) 49050 call difmsg(lineno, line1, line2) 49060 } 49070 if (m1 == EOF & m2 ^= EOF) 49080 call remark("eof on file 1.") 49090 else if (m2 == EOF & m1 ^= EOF) 49100 call remark("eof on file 2.") 49110 # else they match 49120 stop 49130 end 49140 49150 # difmsg - print line numbers and differing lines 49160 subroutine difmsg(lineno, line1, line2) 49170 character line1(ARB), line2(ARB) 49180 integer lineno 49190 49200 call putdec(lineno, 5) 49210 call putc(NEWLINE) 49220 call putlin(line1, STDOUT) 49230 call putlin(line2, STDOUT) 49240 return 49250 end 49260 define(NAMESIZE,50) 49270 # compare - compare two files for equality 49280 character arg1(MAXLINE), arg2(MAXLINE) 49290 character line1(MAXLINE), line2(MAXLINE) 49300 integer equal, getarg, getlin, open 49310 integer infil1, infil2, lineno, m1, m2 49320 49330 if (getarg(1, arg1, MAXLINE) == EOF 49340 | getarg(2, arg2, MAXLINE) == EOF) 49350 call error("usage: compare file1 file2.") 49360 infil1 = open(arg1, READ) 49370 if (infil1 == ERR) 49380 call cant(arg1) 49390 infil2 = open(arg2, READ) 49400 if (infil2 == ERR) 49410 call cant(arg2) 49420 lineno = 0 49430 repeat { 49440 m1 = getlin(line1, infil1) 49450 m2 = getlin(line2, infil2) 49460 if (m1 == EOF | m2 == EOF) 49470 break 49480 lineno = lineno + 1 49490 if (equal(line1, line2) == NO) 49500 call difmsg(lineno, line1, line2) 49510 } 49520 if (m1 == EOF & m2 ^= EOF) 49530 call remark("eof on file 1.") 49540 else if (m2 == EOF & m1 ^= EOF) 49550 call remark("eof on file 2.") 49560 stop 49570 end 49580 49590 #difmsg 49600 subroutine difmsg(lineno, line1, line2) 49610 integer line1(MAXLINE), line2(MAXLINE) 49620 integer lineno 49630 49640 call putdec(lineno, 5) 49650 call putc(NEWLINE) 49660 call putlin(line1, STDOUT) 49670 call putlin(line2, STDOUT) 49680 return 49690 end 49700 define(NFILES,5) 49710 # include - replace include file by contents of file 49720 character line(MAXLINE), str(MAXLINE) 49730 integer equal, getlin, getwrd, open 49740 integer infile(NFILES), len, level, loc 49750 # string incl "include" 49760 integer incl(8) 49770 data incl(1) /LETI/ 49780 data incl(2) /LETN/ 49790 data incl(3) /LETC/ 49800 data incl(4) /LETL/ 49810 data incl(5) /LETU/ 49820 data incl(6) /LETD/ 49830 data incl(7) /LETE/ 49840 data incl(8) /EOS/ 49850 49860 infile(1) = STDIN 49870 for (level = 1; level > 0; level = level - 1) { 49880 while (getlin(line, infile(level)) ^= EOF) { 49890 loc = 1 49900 len = getwrd(line, loc, str) 49910 if (equal(str, incl) == NO) 49920 call putlin(line, STDOUT) 49930 else { 49940 level = level + 1 49950 if (level > NFILES) 49960 call error("includes nested too deeply.") 49970 len = getwrd(line, loc, str) 49980 infile(level) = open(str, READ) 49990 if (infile(level) == ERR) 50000 call cant(str) 50010 } 50020 } 50030 if (level > 1) 50040 call close(infile(level)) 50050 } 50060 stop 50070 end 50080 # getwrd - get non-blank word from in(i) into out, increment i 50090 integer function getwrd(in, i, out) 50100 character in(ARB), out(ARB) 50110 integer i, j 50120 50130 while (in(i) == BLANK | in(i) == TAB) 50140 i = i + 1 50150 j = 1 50160 while (in(i) ^= EOS & in(i) ^= BLANK 50170 & in(i) ^= TAB & in(i) ^= NEWLINE) { 50180 out(j) = in(i) 50190 i = i + 1 50200 j = j + 1 50210 } 50220 out(j) = EOS 50230 getwrd = j - 1 50240 return 50250 end 50260 50270 define(NAMESIZE,50) 50280 # concat - concatenate named files onto standard output 50290 character name(NAMESIZE) 50300 integer getarg, open 50310 integer fin, i 50320 50330 for (i = 1; getarg(i, name, NAMESIZE) ^= EOF; i = i + 1) { 50340 fin = open(name, READ) 50350 if (fin == ERR) 50360 call cant(name) 50370 call fcopy(fin, STDOUT) 50380 call close(fin) 50390 } 50400 stop 50410 end 50420 define(NAMESIZE,50) 50430 define(MARGIN1,3) 50440 define(MARGIN2,2) 50450 define(MARGIN3,2) 50460 define(MARGIN4,3) 50470 define(BOTTOM,60) 50480 define(PAGELEN,66) 50490 # print - print files with headings 50500 character name(NAMESIZE) 50510 integer getarg, open 50520 integer fin, i 50530 50540 for (i = 1; getarg(i, name, NAMESIZE) ^= EOF; i = i + 1) { 50550 fin = open(name, READ) 50560 if (fin == ERR) 50570 call cant(name) 50580 call fprint(name, fin) 50590 call close(fin) 50600 } 50610 stop 50620 end 50630 50640 # fprint - print file "name" from fin 50650 subroutine fprint(name, fin) 50660 character line(MAXLINE), name(NAMESIZE) 50670 integer getlin, open 50680 integer fin, lineno, pageno 50690 50700 pageno = 0 50710 lineno = 0 50720 while (getlin(line, fin) ^= EOF) { 50730 if (lineno == 0) { 50740 call skip(MARGIN1) 50750 pageno = pageno + 1 50760 call head(name, pageno) 50770 call skip(MARGIN2) 50780 lineno = MARGIN1 + MARGIN2 + 1 50790 } 50800 call putlin(line, STDOUT) 50810 lineno = lineno + 1 50820 if (lineno >= BOTTOM) { 50830 call skip(PAGELEN-lineno) 50840 lineno = 0 50850 } 50860 } 50870 if (lineno > 0) 50880 call skip(PAGELEN-lineno) 50890 return 50900 end 50910 50920 # skip - output n blank lines 50930 subroutine skip(n) 50940 integer i, n 50950 50960 for (i = 1; i <= n; i = i + 1) 50970 call putc(NEWLINE) 50980 return 50990 end 51000 51010 # head - print top of page header 51020 subroutine head(name, pageno) 51030 character name(NAMESIZE) 51040 integer pageno 51050 # string page " Page " 51060 integer page(7) 51070 data page(1) /BLANK/ 51080 data page(2) /LETP/ 51090 data page(3) /LETA/ 51100 data page(4) /LETG/ 51110 data page(5) /LETE/ 51120 data page(6) /BLANK/ 51130 data page(7) /EOS/ 51140 51150 call putlin(name, STDOUT) 51160 call putlin(page, STDOUT) 51170 call putdec(pageno, 1) 51180 call putc(NEWLINE) 51190 return 51200 end 51210 define(NAMESIZE,50) 51220 define(MARGIN1,3) 51230 define(MARGIN2,2) 51240 define(MARGIN3,2) 51250 define(MARGIN4,3) 51260 define(BOTTOM,60) 51270 define(PAGELEN,66) 51280 # print (default input STDIN) - print files with headings 51290 character name(NAMESIZE) 51300 integer getarg, open 51310 integer fin, i 51320 # string null "" 51330 integer null(1) 51340 data null(1) /EOS/ 51350 51360 for (i = 1; getarg(i, name, NAMESIZE) ^= EOF; i = i + 1) { 51370 fin = open(name, READ) 51380 if (fin == ERR) 51390 call cant(name) 51400 call fprint(name, fin) 51410 call close(fin) 51420 } 51430 if (i == 1) # no files specified 51440 call fprint(null, STDIN) 51450 stop 51460 end 51470 51480 # fprint - print file "name" from fin 51490 subroutine fprint(name, fin) 51500 integer line(MAXLINE), name(NAMESIZE) 51510 integer getlin, open 51520 integer fin, lineno, pageno 51530 51540 pageno = 0 51550 lineno = 0 51560 while (getlin(line, fin) ^= EOF) { 51570 if (lineno == 0) { 51580 call skip(MARGIN1) 51590 pageno = pageno + 1 51600 call head(name, pageno) 51610 call skip(MARGIN2) 51620 lineno = MARGIN1 + MARGIN2 + 1 51630 } 51640 call putlin(line, STDOUT) 51650 lineno = lineno + 1 51660 if (lineno >= BOTTOM) { 51670 call skip(PAGELEN-lineno) 51680 lineno = 0 51690 } 51700 } 51710 if (lineno > 0) 51720 call skip(PAGELEN-lineno) 51730 return 51740 end 51750 51760 # skip - output n blank lines 51770 subroutine skip(n) 51780 integer i, n 51790 51800 for (i = 1; i <= n; i = i + 1) 51810 call putc(NEWLINE) 51820 return 51830 end 51840 51850 # head - print top of page header 51860 subroutine head(name, pageno) 51870 integer name(NAMESIZE) 51880 integer pageno 51890 # string page " Page " 51900 integer page(7) 51910 data page(1) /BLANK/ 51920 data page(2) /LETP/ 51930 data page(3) /LETA/ 51940 data page(4) /LETG/ 51950 data page(5) /LETE/ 51960 data page(6) /BLANK/ 51970 data page(7) /EOS/ 51980 51990 call putlin(name, STDOUT) 52000 call putlin(page, STDOUT) 52010 call putdec(pageno, 1) 52020 call putc(NEWLINE) 52030 return 52040 end 52050 define(NAMESIZE,50) 52060 # makecopy - copy one file to another 52070 character iname(NAMESIZE), oname(NAMESIZE) 52080 integer create, getarg, open 52090 integer fin, fout 52100 52110 if (getarg(1, iname, NAMESIZE) == EOF 52120 | getarg(2, oname, NAMESIZE) == EOF) 52130 call error("usage: makecopy input output.") 52140 fin = open(iname, READ) 52150 if (fin == ERR) 52160 call cant(iname) 52170 fout = create(oname, WRITE) 52180 if (fout == ERR) 52190 call cant(oname) 52200 call fcopy(fin, fout) 52210 call close(fin) 52220 call close(fout) 52230 stop 52240 end 52250 ========== archive program from chapter 3 ========== 52260 define(NAMESIZE,20) 52270 define(MAXFILES,5) 52280 52290 define(TBL,LETT) 52300 define(PRINT,LETP) 52310 define(EXTR,LETX) 52320 define(UPD,LETU) 52330 define(DEL,LETD) 52340 common /carch/ fname(NAMESIZE,MAXFILES),fstat(MAXFILES),nfiles,errcnt 52350 character fname # file arguments 52360 integer fstat # YES if touched, NO otherwise; init = NO 52370 integer nfiles # number of file args 52380 integer errcnt # error count; init = 0 52390 # acopy - copy size characters from fdi to fdo 52400 subroutine acopy(fdi, fdo, size) 52410 character getch 52420 character c 52430 integer fdi, fdo, i, size 52440 52450 for (i = 1; i <= size; i = i + 1) { 52460 if (getch(c, fdi) == EOF) 52470 break 52480 call putch(c, fdo) 52490 } 52500 return 52510 end 52520 # addfil - add file "name" to archive 52530 subroutine addfil(name, fd, errcnt) 52540 character head(MAXLINE), name(ARB) 52550 integer open 52560 integer errcnt, fd, nfd 52570 52580 nfd = open(name, READ) 52590 if (nfd == ERR) { 52600 call putlin(name, ERROUT) 52610 call remark(": can't add.") 52620 errcnt = errcnt + 1 52630 } 52640 if (errcnt == 0) { 52650 call makhdr(name, head) 52660 call putlin(head, fd) 52670 call fcopy(nfd, fd) 52680 call close(nfd) 52690 } 52700 return 52710 end 52720 # amove - move name1 to name2 52730 subroutine amove(name1, name2) 52740 character name1(ARB), name2(ARB) 52750 integer create, open 52760 integer fd1, fd2 52770 52780 fd1 = open(name1, READ) 52790 if (fd1 == ERR) 52800 call cant(name1) 52810 fd2 = create(name2, WRITE) 52820 if (fd2 == ERR) 52830 call cant(name2) 52840 call fcopy(fd1, fd2) 52850 return 52860 end 52870 # archive - file maintainer 52880 character aname(NAMESIZE) 52890 integer getarg 52900 integer comand(2) 52910 52920 if (getarg(1, comand, 2) == EOF 52930 | getarg(2, aname, NAMESIZE) == EOF) 52940 call help 52950 call getfns 52960 if (comand(1) == UPD) 52970 call update(aname) 52980 else if (comand(1) == TBL) 52990 call table(aname) 53000 else if (comand(1) == EXTR | comand(1) == PRINT) 53010 call extrac(aname, comand(1)) 53020 else if (comand(1) == DEL) 53030 call delete(aname) 53040 else 53050 call help 53060 stop 53070 end 53080 # block data for archive 53090 block data 53100 include carch 53110 data errcnt /0/ 53120 end 53130 # delete - delete files from archive 53140 subroutine delete(aname) 53150 character aname(NAMESIZE), in(MAXLINE) 53160 integer create, open 53170 integer afd, tfd 53180 include carch 53190 # string tname "archtemp" 53200 integer tname(9) 53210 data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/ 53220 data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/ 53230 data tname(9)/EOS/ 53240 53250 if (nfiles <= 0) # protect innocents 53260 call error("delete by name only.") 53270 afd = open(aname, READWRITE) 53280 if (afd == ERR) 53290 call cant(aname) 53300 tfd = create(tname, READWRITE) 53310 if (tfd == ERR) 53320 call cant(tname) 53330 call replac(afd, tfd, DEL, errcnt) 53340 call notfnd 53350 call close(afd) 53360 call close(tfd) 53370 if (errcnt == 0) 53380 call amove(tname, aname) 53390 else 53400 call remark("fatal errors - archive not altered.") 53410 call remove(tname) 53420 return 53430 end 53440 # extrac - extract files from archive 53450 subroutine extrac(aname, cmd) 53460 character aname(NAMESIZE), ename(NAMESIZE), in(MAXLINE) 53470 integer create, filarg, gethdr, open 53480 integer afd, cmd, efd, size 53490 include carch 53500 53510 afd = open(aname, READ) 53520 if (afd == ERR) 53530 call cant(aname) 53540 if (cmd == PRINT) 53550 efd = STDOUT 53560 else 53570 efd = ERR 53580 while (gethdr(afd, in, ename, size) ^= EOF) 53590 if (filarg(ename) == NO) 53600 call fskip(afd, size) 53610 else { 53620 if (efd ^= STDOUT) 53630 efd = create(ename, WRITE) 53640 if (efd == ERR) { 53650 call putlin(ename, ERROUT) 53660 call remark(": can't create.") 53670 errcnt = errcnt + 1 53680 call fskip(afd, size) 53690 } 53700 else { 53710 call acopy(afd, efd, size) 53720 if (efd ^= STDOUT) 53730 call close(efd) 53740 } 53750 } 53760 call notfnd 53770 return 53780 end 53790 # filarg - check if name matches argument list 53800 integer function filarg(name) 53810 character name(ARB) 53820 integer equal, getarg 53830 integer i 53840 include carch 53850 53860 if (nfiles <= 0) { 53870 filarg = YES 53880 return 53890 } 53900 for (i = 1; i <= nfiles; i = i + 1) 53910 if (equal(name, fname(1, i)) == YES) { 53920 fstat(i) = YES 53930 filarg = YES 53940 return 53950 } 53960 filarg = NO 53970 return 53980 end 53990 # fsize - size of file in characters 54000 integer function fsize(name) 54010 character getch 54020 character c, name(ARB) 54030 integer open 54040 integer fd 54050 54060 fd = open(name, READ) 54070 if (fd == ERR) 54080 fsize = ERR 54090 else { 54100 for (fsize = 0; getch(c, fd) ^= EOF; fsize = fsize + 1) 54110 ; 54120 call close(fd) 54130 } 54140 return 54150 end 54160 # fskip - skip n characters on file fd 54170 subroutine fskip(fd, n) 54180 character getch 54190 character c 54200 integer fd, i, n 54210 54220 for (i = 1; i <= n; i = i + 1) 54230 if (getch(c, fd) == EOF) 54240 break 54250 return 54260 end 54270 # getfns - get file names into fname, check for duplicates 54280 subroutine getfns 54290 integer equal, getarg 54300 integer i, j 54310 include carch 54320 54330 errcnt = 0 54340 for (i = 1; i <= MAXFILES; i = i + 1) 54350 if (getarg(i+2, fname(1, i), NAMESIZE) == EOF) 54360 break 54370 nfiles = i - 1 54380 if (i > MAXFILES) 54390 if (getarg(i+2, j, 1) ^= EOF) 54400 call error("too many file names.") 54410 for (i = 1; i <= nfiles; i = i + 1) 54420 fstat(i) = NO 54430 for (i = 1; i < nfiles; i = i + 1) 54440 for (j = i + 1; j <= nfiles; j = j + 1) 54450 if (equal(fname(1, i), fname(1, j)) == YES) { 54460 call putlin(fname(1, i), ERROUT) 54470 call error(": duplicate file name.") 54480 } 54490 return 54500 end 54510 # gethdr - get header info from fd 54520 integer function gethdr(fd, buf, name, size) 54530 character buf(MAXLINE), c, name(NAMESIZE), temp(NAMESIZE) 54540 integer ctoi, equal, getlin, getwrd 54550 integer fd, i, len, size 54560 # string hdr "-h-" 54570 integer hdr(4) 54580 data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/ 54590 54600 if (getlin(buf, fd) == EOF) { 54610 gethdr = EOF 54620 return 54630 } 54640 i = 1 54650 len = getwrd(buf, i, temp) 54660 if (equal(temp, hdr) == NO) 54670 call error("archive not in proper format.") 54680 gethdr = YES 54690 len = getwrd(buf, i, name) 54700 size = ctoi(buf, i) 54710 return 54720 end 54730 # getwrd - get non-blank word from in(i) into out, increment i 54740 integer function getwrd(in, i, out) 54750 integer in(ARB), out(ARB) 54760 integer i, j 54770 54780 while (in(i) == BLANK | in(i) == TAB) 54790 i = i + 1 54800 j = 1 54810 while (in(i)^=EOS & in(i)^=BLANK & in(i)^=TAB & in(i)^=NEWLINE) { 54820 out(j) = in(i) 54830 i = i + 1 54840 j = j + 1 54850 } 54860 out(j) = EOS 54870 getwrd = j - 1 54880 return 54890 end 54900 # help - diagnostic printout 54910 subroutine help 54920 54930 call error("usage: archive {dptux} archname Õfileså.") 54940 return 54950 end 54960 define(MAXCHARS,10) 54970 # makhdr - make header line for archive member 54980 subroutine makhdr(name, head) 54990 character head(MAXLINE), name(NAMESIZE) 55000 integer fsize, itoc, length 55010 integer i 55020 # string hdr "-h-" 55030 integer hdr(4) 55040 data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/ 55050 55060 call scopy(hdr, 1, head, 1) 55070 i = length(hdr) + 1 55080 head(i) = BLANK 55090 call scopy(name, 1, head, i+1) 55100 i = length(head) + 1 55110 head(i) = BLANK 55120 i = i + 1 + itoc(fsize(name), head(i+1), MAXCHARS) 55130 head(i) = NEWLINE 55140 head(i+1) = EOS 55150 return 55160 end 55170 # notfnd - print "not found" message 55180 subroutine notfnd 55190 integer i 55200 include carch 55210 55220 for (i = 1; i <= nfiles; i = i + 1) 55230 if (fstat(i) == NO) { 55240 call putlin(fname(1, i), ERROUT) 55250 call remark(": not in archive.") 55260 errcnt = errcnt + 1 55270 } 55280 return 55290 end 55300 # replac - replace or delete files 55310 subroutine replac(afd, tfd, cmd, errcnt) 55320 character in(MAXLINE), uname(NAMESIZE) 55330 integer filarg, gethdr 55340 integer afd, cmd, errcnt, size, tfd 55350 55360 while (gethdr(afd, in, uname, size) ^= EOF) 55370 if (filarg(uname) == YES) { 55380 if (cmd == UPD) # add new one 55390 call addfil(uname, tfd, errcnt) 55400 call fskip(afd, size) # discard old one 55410 } 55420 else { 55430 call putlin(in, tfd) 55440 call acopy(afd, tfd, size) 55450 } 55460 return 55470 end 55480 # table - print table of archive contents 55490 subroutine table(aname) 55500 character aname(NAMESIZE), in(MAXLINE), lname(NAMESIZE) 55510 integer filarg, gethdr, open 55520 integer afd, size 55530 55540 afd = open(aname, READ) 55550 if (afd == ERR) 55560 call cant(aname) 55570 while (gethdr(afd, in, lname, size) ^= EOF) { 55580 if (filarg(lname) == YES) 55590 call tprint(in) 55600 call fskip(afd, size) 55610 } 55620 call notfnd 55630 return 55640 end 55650 # tprint - print table entry for one member 55660 subroutine tprint(buf) 55670 character buf(ARB) 55680 55690 call putlin(buf, STDOUT) 55700 return 55710 end 55720 # update - update existing files, add new ones at end 55730 subroutine update(aname) 55740 character aname(NAMESIZE) 55750 integer create, getarg, open 55760 integer afd, i, tfd 55770 include carch 55780 # string tname "archtemp" 55790 integer tname(9) 55800 data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/ 55810 data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/ 55820 data tname(9)/EOS/ 55830 55840 afd = open(aname, READWRITE) 55850 if (afd == ERR) # maybe it's a new one 55860 afd = create(aname, READWRITE) 55870 if (afd == ERR) 55880 call cant(aname) 55890 tfd = create(tname, READWRITE) 55900 if (tfd == ERR) 55910 call cant(tname) 55920 call replac(afd, tfd, UPD, errcnt) # update existing 55930 for (i = 1; i <= nfiles; i = i + 1) # add new ones 55940 if (fstat(i) == NO) { 55950 call addfil(fname(1, i), tfd, errcnt) 55960 fstat(i) = YES 55970 } 55980 call close(afd) 55990 call close(tfd) 56000 if (errcnt == 0) 56010 call amove(tname, aname) 56020 else 56030 call remark("fatal errors - archive not altered.") 56040 call remove(tname) 56050 return 56060 end 56070 ========== programs from chapter 4 ========== 56080 # bubble - bubble sort v(1) ... v(n) increasing 56090 subroutine bubble(v, n) 56100 integer i, j, k, n, v(n) 56110 56120 for (i = n; i > 1; i = i - 1) 56130 for (j = 1; j < i; j = j + 1) 56140 if (v(j) > v(j+1)) { # compare 56150 k = v(j) # exchange 56160 v(j) = v(j+1) # 56170 v(j+1) = k # 56180 } 56190 return 56200 end 56210 # shell - Shell sort v(1)...v(n) increasing 56220 subroutine shell(v, n) 56230 integer gap, i, j, jg, k, n, v(n) 56240 56250 for (gap = n/2; gap > 0; gap = gap/2) 56260 for (i = gap + 1; i <= n; i = i + 1) 56270 for (j = i - gap; j > 0; j = j - gap) { 56280 jg = j + gap 56290 if (v(j) <= v(jg)) # compare 56300 break 56310 k = v(j) # exchange 56320 v(j) = v(jg) # 56330 v(jg) = k # 56340 } 56350 return 56360 end 56370 56380 define(MERGEORDER,7) 56390 define(NAMESIZE,20) 56400 define(MAXTEXT,400) 56410 define(MAXPTR,1000) 56420 define(LOGPTR,20) 56430 # sort - sort text lines in memory 56440 character linbuf(MAXTEXT) 56450 integer gtext 56460 integer linptr(MAXPTR), nlines 56470 56480 if (gtext(linptr, nlines, linbuf, STDIN) == EOF) { 56490 call shell(linptr, nlines, linbuf) 56500 call ptext(linptr, nlines, linbuf, STDOUT) 56510 } 56520 else 56530 call error("too big to sort.") 56540 stop 56550 end 56560 # shell - Shell sort for character lines 56570 subroutine shell(linptr, nlines, linbuf) 56580 character linbuf(ARB) 56590 integer compar 56600 integer gap, i, ig, j, k, linptr(ARB), nlines 56610 56620 for (gap = nlines/2; gap > 0; gap = gap/2) 56630 for (j = gap + 1; j <= nlines; j = j + 1) 56640 for (i = j - gap; i > 0; i = i - gap) { 56650 ig = i + gap 56660 if (compar(linptr(i), linptr(ig), linbuf) <= 0) 56670 break 56680 call exchan(linptr(i), linptr(ig), linbuf) 56690 } 56700 return 56710 end 56720 # gtext - get text lines into linbuf 56730 integer function gtext(linptr, nlines, linbuf, infile) 56740 character linbuf(MAXTEXT) 56750 integer getlin 56760 integer infile, lbp, len, linptr(MAXPTR), nlines 56770 56780 nlines = 0 56790 lbp = 1 56800 repeat { 56810 len = getlin(linbuf(lbp), infile) 56820 if (len == EOF) 56830 break 56840 nlines = nlines + 1 56850 linptr(nlines) = lbp 56860 lbp = lbp + len + 1 # "1" = room for EOS 56870 } until (lbp >= MAXTEXT-MAXLINE | nlines >= MAXPTR) 56880 gtext = len 56890 return 56900 end 56910 # ptext - output text lines from linbuf 56920 subroutine ptext(linptr, nlines, linbuf, outfil) 56930 character linbuf(MAXTEXT) 56940 integer i, j, linptr(MAXPTR), nlines, outfil 56950 56960 for (i = 1; i <= nlines; i = i + 1) { 56970 j = linptr(i) 56980 call putlin(linbuf(j), outfil) 56990 } 57000 return 57010 end 57020 # compar - compare linbuf(lp1) with linbuf(lp2) 57030 integer function compar(lp1, lp2, linbuf) 57040 character linbuf(ARB) 57050 integer i, j, lp1, lp2 57060 57070 i = lp1 57080 j = lp2 57090 while (linbuf(i) == linbuf(j)) { 57100 if (linbuf(i) == EOS) { 57110 compar = 0 57120 return 57130 } 57140 i = i + 1 57150 j = j + 1 57160 } 57170 if (linbuf(i) < linbuf(j)) 57180 compar = -1 57190 else 57200 compar = +1 57210 return 57220 end 57230 # exchan - exchange linbuf(lp1) with linbuf(lp2) 57240 subroutine exchan(lp1, lp2, linbuf) 57250 character linbuf(ARB) 57260 integer k, lp1, lp2 57270 57280 k = lp1 57290 lp1 = lp2 57300 lp2 = k 57310 return 57320 end 57330 # quick - quicksort for character lines 57340 subroutine quick(linptr, nlines, linbuf) 57350 character linbuf(ARB) 57360 integer compar 57370 integer i, j, linptr(ARB), lv(LOGPTR), nlines, p, pivlin, uv(LOGPTR) 57380 57390 lv(1) = 1 57400 uv(1) = nlines 57410 p = 1 57420 while (p > 0) 57430 if (lv(p) >= uv(p)) # only one element in this subset 57440 p = p - 1 # pop stack 57450 else { 57460 i = lv(p) - 1 57470 j = uv(p) 57480 pivlin = linptr(j) # pivot line 57490 while (i < j) { 57500 for (i=i+1; compar(linptr(i), pivlin, linbuf) < 0; i=i+1) 57510 ; 57520 for (j = j - 1; j > i; j = j - 1) 57530 if (compar(linptr(j), pivlin, linbuf) <= 0) 57540 break 57550 if (i < j) # out of order pair 57560 call exchan(linptr(i), linptr(j), linbuf) 57570 } 57580 j = uv(p) # move pivot to position i 57590 call exchan(linptr(i), linptr(j), linbuf) 57600 if (i-lv(p) < uv(p)-i) { # stack so shorter done first 57610 lv(p+1) = lv(p) 57620 uv(p+1) = i - 1 57630 lv(p) = i + 1 57640 } 57650 else { 57660 lv(p+1) = i + 1 57670 uv(p+1) = uv(p) 57680 uv(p) = i - 1 57690 } 57700 p = p + 1 # push onto stack 57710 } 57720 return 57730 end 57740 # sort - external sort of text lines 57750 character linbuf(MAXTEXT), name(NAMESIZE) 57760 integer gtext, makfil, min, open 57770 integer infil(MERGEORDER), linptr(MAXPTR), nlines 57780 integer high, lim, low, outfil, t 57790 57800 high = 0 57810 repeat { # initial formation of runs 57820 t = gtext(linptr, nlines, linbuf, STDIN) 57830 call quick(linptr, nlines, linbuf) 57840 high = high + 1 57850 outfil = makfil(high) 57860 call ptext(linptr, nlines, linbuf, outfil) 57870 call close(outfil) 57880 } until (t == EOF) 57890 57900 for (low = 1; low < high; low = low + MERGEORDER) { # merge 57910 lim = min(low+MERGEORDER-1, high) 57920 call gopen(infil, low, lim) 57930 high = high + 1 57940 outfil = makfil(high) 57950 call merge(infil, lim-low+1, outfil) 57960 call close(outfil) 57970 call gremov(infil, low, lim) 57980 } 57990 58000 call gname(high, name) # final cleanup 58010 outfil = open(name, READ) 58020 call fcopy(outfil, STDOUT) 58030 call close(outfil) 58040 call remove(name) 58050 stop 58060 end 58070 58080 # gname - make unique name for file id n 58090 subroutine gname(n, name) 58100 character name(NAMESIZE) 58110 integer itoc, length 58120 integer i, junk, n 58130 # string stemp "stemp" 58140 integer stemp(6) 58150 data stemp(1), stemp(2), stemp(3)/ LETS, LETT, LETE/ 58160 data stemp(4), stemp(5), stemp(6)/ LETM, LETP, EOS/ 58170 58180 call scopy(stemp, 1, name, 1) 58190 i = length(stemp) + 1 58200 junk = itoc(n, name(i), NAMESIZE-i) 58210 return 58220 end 58230 58240 # makfil - make new file for number n 58250 integer function makfil(n) 58260 character name(NAMESIZE) 58270 integer create 58280 integer n 58290 58300 call gname(n, name) 58310 makfil = create(name, READWRITE) 58320 if (makfil == ERR) 58330 call cant(name) 58340 return 58350 end 58360 58370 # gopen - open group of files low ... lim 58380 subroutine gopen(infil, low, lim) 58390 character name(NAMESIZE) 58400 integer i, infil(MERGEORDER), lim, low 58410 integer open 58420 58430 for (i = 1; i <= lim-low+1; i = i + 1) { 58440 call gname(low+i-1, name) 58450 infil(i) = open(name, READ) 58460 if (infil(i) == ERR) 58470 call cant(name) 58480 } 58490 return 58500 end 58510 58520 # gremov - remove group of files low ... lim 58530 subroutine gremov(infil, low, lim) 58540 character name(NAMESIZE) 58550 integer i, infil(MERGEORDER), lim, low 58560 58570 for (i = 1; i <= lim-low+1; i = i + 1) { 58580 call close(infil(i)) 58590 call gname(low+i-1, name) 58600 call remove(name) 58610 } 58620 return 58630 end 58640 define(MERGETEXT,900) 58650 # merge - merge infil(1) ... infil(nfiles) onto outfil 58660 subroutine merge(infil, nfiles, outfil) 58670 character linbuf(MERGETEXT) 58680 integer getlin 58690 integer i, inf, lbp, lp1, nf, nfiles, outfil 58700 integer infil(MERGEORDER), linptr(MERGEORDER) 58710 58720 lbp = 1 58730 nf = 0 58740 for (i = 1; i <= nfiles; i = i + 1) # get one line from each file 58750 if (getlin(linbuf(lbp), infil(i)) ^= EOF) { 58760 nf = nf + 1 58770 linptr(nf) = lbp 58780 lbp = lbp + MAXLINE # room for largest line 58790 } 58800 call quick(linptr, nf, linbuf) # make initial heap 58810 while (nf > 0) { 58820 lp1 = linptr(1) 58830 call putlin(linbuf(lp1), outfil) 58840 inf = lp1 / MAXLINE + 1 # compute file index 58850 if (getlin(linbuf(lp1), infil(inf)) == EOF) { 58860 linptr(1) = linptr(nf) 58870 nf = nf - 1 58880 } 58890 call reheap(linptr, nf, linbuf) 58900 } 58910 return 58920 end 58930 58940 # reheap - propagate linbuf(linptr(1)) to proper place in heap 58950 subroutine reheap(linptr, nf, linbuf) 58960 character linbuf(MAXTEXT) 58970 integer compar 58980 integer i, j, nf, linptr(nf) 58990 59000 for (i = 1; 2 * i <= nf; i = j) { 59010 j = 2 * i 59020 if (j < nf) # find smaller child 59030 if (compar(linptr(j), linptr(j+1), linbuf) > 0) 59040 j = j + 1 59050 if (compar(linptr(i), linptr(j), linbuf) <= 0) 59060 break # proper position found 59070 call exchan(linptr(i), linptr(j), linbuf) # percolate 59080 } 59090 return 59100 end 59110 ========== other routines from chapter 4 ========== 59120 # unique - strip adjacent duplicate lines 59130 character buf1(MAXLINE), buf2(MAXLINE) 59140 integer equal, getlin 59150 integer t 59160 59170 t = getlin(buf1, STDIN) 59180 while (t ^= EOF) { 59190 call putlin(buf1, STDOUT) 59200 for (t = getlin(buf2, STDIN); t ^= EOF; t = getlin(buf2, STDIN)) 59210 if (equal(buf1, buf2) == NO) 59220 break 59230 if (t == EOF) 59240 break 59250 call putlin(buf2, STDOUT) 59260 for (t = getlin(buf1, STDIN); t ^= EOF; t = getlin(buf1, STDIN)) 59270 if (equal(buf1, buf2) == NO) 59280 break 59290 } 59300 stop 59310 end 59320 define(FOLD,DOLLAR) 59330 # kwic - make keyword in context index 59340 character buf(MAXLINE) 59350 integer getlin 59360 59370 while (getlin(buf, STDIN) ^= EOF) 59380 call putrot(buf, STDOUT) 59390 stop 59400 end 59410 59420 # putrot - create lines with keyword at front 59430 subroutine putrot(buf, outfil) 59440 character type 59450 character buf(ARB), t 59460 integer i, outfil 59470 59480 for (i = 1; buf(i) ^= NEWLINE; i = i + 1) { 59490 t = type(buf(i)) 59500 if (t == LETTER | t == DIGIT) { # alpha 59510 call rotate(buf, i, outfil) # token starts at "i" 59520 t = type(buf(i+1)) 59530 for ( ; t == LETTER | t == DIGIT; t = type(buf(i+1))) 59540 i = i + 1 59550 } 59560 } 59570 return 59580 end 59590 59600 # rotate - output rotated line 59610 subroutine rotate(buf, n, outfil) 59620 character buf(ARB) 59630 integer i, n, outfil 59640 59650 for (i = n; buf(i) ^= NEWLINE; i = i + 1) 59660 call putch(buf(i), outfil) 59670 call putch(FOLD, outfil) 59680 for (i = 1; i < n; i = i + 1) 59690 call putch(buf(i), outfil) 59700 call putch(NEWLINE, outfil) 59710 return 59720 end 59730 59740 # type - determine type of character 59750 character function type(c) 59760 character c 59770 integer index 59780 # string digits "0123456789" 59790 integer digits(11) 59800 # string lowalf "abcdefghijklmnopqrstuvwxyz" 59810 integer lowalf(27) 59820 # string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 59830 integer upalf(27) 59840 data digits(1) /DIG0/ 59850 data digits(2) /DIG1/ 59860 data digits(3) /DIG2/ 59870 data digits(4) /DIG3/ 59880 data digits(5) /DIG4/ 59890 data digits(6) /DIG5/ 59900 data digits(7) /DIG6/ 59910 data digits(8) /DIG7/ 59920 data digits(9) /DIG8/ 59930 data digits(10) /DIG9/ 59940 data digits(11) /EOS/ 59950 data lowalf(01)/LETA/ 59960 data lowalf(02)/LETB/ 59970 data lowalf(03)/LETC/ 59980 data lowalf(04)/LETD/ 59990 data lowalf(05)/LETE/ 60000 data lowalf(06)/LETF/ 60010 data lowalf(07)/LETG/ 60020 data lowalf(08)/LETH/ 60030 data lowalf(09)/LETI/ 60040 data lowalf(10)/LETJ/ 60050 data lowalf(11)/LETK/ 60060 data lowalf(12)/LETL/ 60070 data lowalf(13)/LETM/ 60080 data lowalf(14)/LETN/ 60090 data lowalf(15)/LETO/ 60100 data lowalf(16)/LETP/ 60110 data lowalf(17)/LETQ/ 60120 data lowalf(18)/LETR/ 60130 data lowalf(19)/LETS/ 60140 data lowalf(20)/LETT/ 60150 data lowalf(21)/LETU/ 60160 data lowalf(22)/LETV/ 60170 data lowalf(23)/LETW/ 60180 data lowalf(24)/LETX/ 60190 data lowalf(25)/LETY/ 60200 data lowalf(26)/LETZ/ 60210 data lowalf(27)/EOS/ 60220 data upalf(01) /BIGA/ 60230 data upalf(02) /BIGB/ 60240 data upalf(03) /BIGC/ 60250 data upalf(04) /BIGD/ 60260 data upalf(05) /BIGE/ 60270 data upalf(06) /BIGF/ 60280 data upalf(07) /BIGG/ 60290 data upalf(08) /BIGH/ 60300 data upalf(09) /BIGI/ 60310 data upalf(10) /BIGJ/ 60320 data upalf(11) /BIGK/ 60330 data upalf(12) /BIGL/ 60340 data upalf(13) /BIGM/ 60350 data upalf(14) /BIGN/ 60360 data upalf(15) /BIGO/ 60370 data upalf(16) /BIGP/ 60380 data upalf(17) /BIGQ/ 60390 data upalf(18) /BIGR/ 60400 data upalf(19) /BIGS/ 60410 data upalf(20) /BIGT/ 60420 data upalf(21) /BIGU/ 60430 data upalf(22) /BIGV/ 60440 data upalf(23) /BIGW/ 60450 data upalf(24) /BIGX/ 60460 data upalf(25) /BIGY/ 60470 data upalf(26) /BIGZ/ 60480 data upalf(27) /EOS/ 60490 60500 if (index(lowalf, c) > 0) 60510 type = LETTER 60520 else if (index(upalf, c) > 0) 60530 type = LETTER 60540 else if (index(digits, c) > 0) 60550 type = DIGIT 60560 else 60570 type = c 60580 return 60590 end 60600 define(FOLD,DOLLAR) 60610 define(MIDDLE,40) 60620 define(MAXOUT,80) 60630 # unrot - unrotate lines rotated by kwic 60640 character inbuf(MAXLINE), outbuf(MAXOUT) 60650 integer getlin, index 60660 integer i, j 60670 60680 while (getlin(inbuf, STDIN) ^= EOF) { 60690 for (i = 1; i < MAXOUT; i = i + 1) # blank line 60700 outbuf(i) = BLANK 60710 j = MIDDLE 60720 for (i = 1; inbuf(i) ^= FOLD & inbuf(i) ^= NEWLINE; i = i + 1) { 60730 j = j + 1 # copy up to FOLD 60740 if (j >= MAXOUT - 1) 60750 j = 1 60760 outbuf(j) = inbuf(i) 60770 } 60780 if (inbuf(i) == FOLD) { # copy second half, 60790 j = MIDDLE # working backwards 60800 for (i = index(inbuf, NEWLINE) - 1; i > 0; i = i - 1) { 60810 if (inbuf(i) == FOLD) 60820 break 60830 j = j - 1 60840 if (j <= 0) 60850 j = MAXOUT - 2 60860 outbuf(j) = inbuf(i) 60870 } 60880 } 60890 for (i = MAXOUT - 2; i > 0; i = i - 1) 60900 if (outbuf(i) ^= BLANK) # delete trailing blanks 60910 break 60920 outbuf(i+1) = NEWLINE # terminate line properly 60930 outbuf(i+2) = EOS 60940 call putlin(outbuf, STDOUT) 60950 } 60960 stop 60970 end 60980 ========== find program from chapter 5 ========== 60990 61000 define(MAXARG,128) 61010 define(MAXPAT,128) 61020 61030 define(COUNT,1) 61040 define(PREVCL,2) 61050 define(START,3) 61060 define(CLOSIZE,4) 61070 61080 define(NOT,BANG) 61090 define(BOL,PERCENT) 61100 define(ANY,QMARK) 61110 define(EOL,DOLLAR) 61120 define(CLOSURE,STAR) 61130 define(CCL,LBRACK) 61140 define(CCLEND,RBRACK) 61150 define(NCCL,LETN) 61160 define(CHAR,LETA) 61170 define(ESCAPE,ATSIGN) 61180 # amatch (non-recursive) - look for match starting at lin(from) 61190 integer function amatch(lin, from, pat) 61200 character lin(MAXLINE), pat(MAXPAT) 61210 integer omatch, patsiz 61220 integer from, i, j, offset, stack 61230 61240 stack = 0 61250 offset = from # next unexamined input character 61260 for (j = 1; pat(j) ^= EOS; j = j + patsiz(pat, j)) 61270 if (pat(j) == CLOSURE) { # a closure entry 61280 stack = j 61290 j = j + CLOSIZE # step over CLOSURE 61300 for (i = offset; lin(i) ^= EOS; ) # match as many as 61310 if (omatch(lin, i, pat, j) == NO) # possible 61320 break 61330 pat(stack+COUNT) = i - offset 61340 pat(stack+START) = offset 61350 offset = i # character that made us fail 61360 } 61370 else if (omatch(lin, offset, pat, j) == NO) { # non-closure 61380 for ( ; stack > 0; stack = pat(stack+PREVCL)) 61390 if (pat(stack+COUNT) > 0) 61400 break 61410 if (stack <= 0) { # stack is empty 61420 amatch = 0 # return failure 61430 return 61440 } 61450 pat(stack+COUNT) = pat(stack+COUNT) - 1 61460 j = stack + CLOSIZE 61470 offset = pat(stack+START) + pat(stack+COUNT) 61480 } 61490 # else omatch succeeded 61500 amatch = offset 61510 return # success 61520 end 61530 # amatch with no metacharacters 61540 integer function amatch(lin, from, pat) 61550 character lin(MAXLINE), pat(MAXPAT) 61560 integer from, i, j 61570 61580 i = from 61590 for (j = 1; pat(j) ^= EOS; j = j + 1) { 61600 if (lin(i) ^= pat(j)) { 61610 amatch = 0 61620 return # with no match 61630 } 61640 i = i + 1 61650 } 61660 amatch = i 61670 return # successfully 61680 end 61690 # amatch with some metacharacters 61700 integer function amatch(lin, from, pat) 61710 character lin(MAXLINE), pat(MAXPAT) 61720 integer omatch, patsiz 61730 integer from, i, j 61740 61750 i = from 61760 for (j = 1; pat(j) ^= EOS; j = j + patsiz(pat, j)) 61770 if (omatch(lin, i, pat, j) == NO) { 61780 amatch = 0 61790 return # with no match 61800 } 61810 amatch = i 61820 return # successfully 61830 end 61840 # find - find patterns in text 61850 character arg(MAXARG), lin(MAXLINE), pat(MAXPAT) 61860 integer getarg, getlin, getpat, match 61870 61880 if (getarg(1, arg, MAXARG) == EOF) 61890 call error("usage: find pattern.") 61900 if (getpat(arg, pat) == ERR) 61910 call error("illegal pattern.") 61920 while (getlin(lin, STDIN) ^= EOF) 61930 if (match(lin, pat) == YES) 61940 call putlin(lin, STDOUT) 61950 stop 61960 end 61970 # getccl - expand char class at arg(i) into pat(j) 61980 integer function getccl(arg, i, pat, j) 61990 character arg(MAXARG), pat(MAXPAT) 62000 integer addset 62010 integer i, j, jstart, junk 62020 62030 i = i + 1 # skip over Õ 62040 if (arg(i) == NOT) { 62050 junk = addset(NCCL, pat, j, MAXPAT) 62060 i = i + 1 62070 } 62080 else 62090 junk = addset(CCL, pat, j, MAXPAT) 62100 jstart = j 62110 junk = addset(0, pat, j, MAXPAT) # leave room for count 62120 call filset(CCLEND, arg, i, pat, j, MAXPAT) 62130 pat(jstart) = j - jstart - 1 62140 if (arg(i) == CCLEND) 62150 getccl = OK 62160 else 62170 getccl = ERR 62180 return 62190 end 62200 # getpat - convert argument into pattern 62210 integer function getpat(arg, pat) 62220 integer arg(MAXARG), pat(MAXPAT) 62230 integer makpat 62240 62250 getpat = makpat(arg, 1, EOS, pat) 62260 return 62270 end 62280 # locate - look for c in char class at pat(offset) 62290 integer function locate(c, pat, offset) 62300 character c, pat(MAXPAT) 62310 integer i, offset 62320 # size of class is at pat(offset), characters follow 62330 62340 for (i = offset + pat(offset); i > offset; i = i - 1) 62350 if (c == pat(i)) { 62360 locate = YES 62370 return 62380 } 62390 locate = NO 62400 return 62410 end 62420 # makpat - make pattern from arg(from), terminate at delim 62430 integer function makpat(arg, from, delim, pat) 62440 character esc 62450 character arg(MAXARG), delim, pat(MAXPAT) 62460 integer addset, getccl, stclos 62470 integer from, i, j, junk, lastcl, lastj, lj 62480 62490 j = 1 # pat index 62500 lastj = 1 62510 lastcl = 0 62520 for (i = from; arg(i) ^= delim & arg(i) ^= EOS; i = i + 1) { 62530 lj = j 62540 if (arg(i) == ANY) 62550 junk = addset(ANY, pat, j, MAXPAT) 62560 else if (arg(i) == BOL & i == from) 62570 junk = addset(BOL, pat, j, MAXPAT) 62580 else if (arg(i) == EOL & arg(i + 1) == delim) 62590 junk = addset(EOL, pat, j, MAXPAT) 62600 else if (arg(i) == CCL) { 62610 if (getccl(arg, i, pat, j) == ERR) 62620 break 62630 } 62640 else if (arg(i) == CLOSURE & i > from) { 62650 lj = lastj 62660 if (pat(lj)==BOL | pat(lj)==EOL | pat(lj)==CLOSURE) 62670 break 62680 lastcl = stclos(pat, j, lastj, lastcl) 62690 } 62700 else { 62710 junk = addset(CHAR, pat, j, MAXPAT) 62720 junk = addset(esc(arg, i), pat, j, MAXPAT) 62730 } 62740 lastj = lj 62750 } 62760 if (arg(i) ^= delim) # terminated early 62770 makpat = ERR 62780 else if (addset(EOS, pat, j, MAXPAT) == NO) # no room 62790 makpat = ERR 62800 else 62810 makpat = i 62820 return 62830 end 62840 # match - find match anywhere on line 62850 integer function match(lin, pat) 62860 character lin(MAXLINE), pat(MAXPAT) 62870 integer amatch 62880 integer i 62890 62900 for (i = 1; lin(i) ^= EOS; i = i + 1) 62910 if (amatch(lin, i, pat) > 0) { 62920 match = YES 62930 return 62940 } 62950 match = NO 62960 return 62970 end 62980 # omatch - try to match a single pattern at pat(j) 62990 integer function omatch(lin, i, pat, j) 63000 character lin(MAXLINE), pat(MAXPAT) 63010 integer locate 63020 integer bump, i, j 63030 63040 omatch = NO 63050 if (lin(i) == EOS) 63060 return 63070 bump = -1 63080 if (pat(j) == CHAR) { 63090 if (lin(i) == pat(j + 1)) 63100 bump = 1 63110 } 63120 else if (pat(j) == BOL) { 63130 if (i == 1) 63140 bump = 0 63150 } 63160 else if (pat(j) == ANY) { 63170 if (lin(i) ^= NEWLINE) 63180 bump = 1 63190 } 63200 else if (pat(j) == EOL) { 63210 if (lin(i) == NEWLINE) 63220 bump = 0 63230 } 63240 else if (pat(j) == CCL) { 63250 if (locate(lin(i), pat, j + 1) == YES) 63260 bump = 1 63270 } 63280 else if (pat(j) == NCCL) { 63290 if (lin(i) ^= NEWLINE & locate(lin(i), pat, j + 1) == NO) 63300 bump = 1 63310 } 63320 else 63330 call error("in omatch: can't happen.") 63340 if (bump >= 0) { 63350 i = i + bump 63360 omatch = YES 63370 } 63380 return 63390 end 63400 # patsiz - returns size of pattern entry at pat(n) 63410 integer function patsiz(pat, n) 63420 character pat(MAXPAT) 63430 integer n 63440 63450 if (pat(n) == CHAR) 63460 patsiz = 2 63470 else if (pat(n) == BOL | pat(n) == EOL | pat(n) == ANY) 63480 patsiz = 1 63490 else if (pat(n) == CCL | pat(n) == NCCL) 63500 patsiz = pat(n + 1) + 2 63510 else if (pat(n) == CLOSURE) # optional 63520 patsiz = CLOSIZE 63530 else 63540 call error("in patsiz: can't happen.") 63550 return 63560 end 63570 # stclos - insert closure entry at pat(j) 63580 integer function stclos(pat, j, lastj, lastcl) 63590 character pat(MAXPAT) 63600 integer addset 63610 integer j, jp, jt, junk, lastcl, lastj 63620 63630 for (jp = j - 1; jp >= lastj; jp = jp - 1) { # make a hole 63640 jt = jp + CLOSIZE 63650 junk = addset(pat(jp), pat, jt, MAXPAT) 63660 } 63670 j = j + CLOSIZE 63680 stclos = lastj 63690 junk = addset(CLOSURE, pat, lastj, MAXPAT) # put closure in it 63700 junk = addset(0, pat, lastj, MAXPAT) # COUNT 63710 junk = addset(lastcl, pat, lastj, MAXPAT) # PREVCL 63720 junk = addset(0, pat, lastj, MAXPAT) # START 63730 return 63740 end 63750 ========== change program from chapter 5 ========== 63760 define(MAXPAT,128) 63770 define(MAXARG,128) 63780 define(ESCAPE,ATSIGN) 63790 define(DITTO,(-3)) 63800 # catsub - add replacement text to end of new 63810 subroutine catsub(lin, from, to, sub, new, k, maxnew) 63820 integer addset 63830 integer from, i, j, junk, k, maxnew, to 63840 character lin(MAXLINE), new(maxnew), sub(MAXPAT) 63850 63860 for (i = 1; sub(i) ^= EOS; i = i + 1) 63870 if (sub(i) == DITTO) 63880 for (j = from; j < to; j = j + 1) 63890 junk = addset(lin(j), new, k, maxnew) 63900 else 63910 junk = addset(sub(i), new, k, maxnew) 63920 return 63930 end 63940 # change - change "from" into "to" 63950 character lin(MAXLINE), new(MAXLINE), pat(MAXPAT), sub(MAXPAT) 63960 character arg(MAXARG) 63970 integer addset, amatch, getarg, getlin, getpat, getsub 63980 integer i, junk, k, lastm, m 63990 64000 if (getarg(1, arg, MAXARG) == EOF) 64010 call error("usage: change from to.") 64020 if (getpat(arg, pat) == ERR) 64030 call error("illegal from pattern.") 64040 if (getarg(2, arg, MAXARG) == EOF) 64050 arg(1) = EOS 64060 if (getsub(arg, sub) == ERR) 64070 call error("illegal to.") 64080 while (getlin(lin, STDIN) ^= EOF) { 64090 k = 1 64100 lastm = 0 64110 for ( i =1; lin(i) ^= EOS; ) { 64120 m = amatch(lin, i, pat) 64130 if (m > 0 & lastm ^= m) { # replace matched text 64140 call catsub(lin, i, m, sub, new, k, MAXLINE) 64150 lastm = m 64160 } 64170 if (m == 0 | m == i) { # no match or null match 64180 junk = addset(lin(i), new, k, MAXLINE) 64190 i = i + 1 64200 } 64210 else # skip matched text 64220 i = m 64230 } 64240 if (addset(EOS, new, k, MAXLINE) == NO) { 64250 k = MAXLINE 64260 junk = addset(EOS, new, k, MAXLINE) 64270 call remark("line truncated:.") 64280 call putlin(new, ERROUT) 64290 call putch(NEWLINE, ERROUT) 64300 } 64310 call putlin(new, STDOUT) 64320 } 64330 stop 64340 end 64350 # getsub - get substitution pattern into sub 64360 integer function getsub(arg, sub) 64370 character arg(MAXARG), sub(MAXPAT) 64380 integer maksub 64390 64400 getsub = maksub(arg, 1, EOS, sub) 64410 return 64420 end 64430 # maksub - make substitution string in sub 64440 integer function maksub(arg, from, delim, sub) 64450 character esc 64460 character arg(MAXARG), delim, sub(MAXPAT) 64470 integer addset 64480 integer from, i, j, junk 64490 64500 j = 1 64510 for (i = from; arg(i) ^= delim & arg(i) ^= EOS; i = i + 1) 64520 if (arg(i) == AND) 64530 junk = addset(DITTO, sub, j, MAXPAT) 64540 else 64550 junk = addset(esc(arg, i), sub, j, MAXPAT) 64560 if (arg(i) ^= delim) # missing delimiter 64570 maksub = ERR 64580 else if (addset(EOS, sub, j, MAXPAT) == NO) # no room 64590 maksub = ERR 64600 else 64610 maksub = i 64620 return 64630 end 64640 ========== edit program from chapter 6 ========== 64650 define(MAXPAT,128) 64660 define(andif,if) 64670 define(GLOBAL,LETG) 64680 define(PRINT,LETP) 64690 64700 define(MARKED,LETY) 64710 define(NOMARK,LETN) 64720 64730 define(FORWARD,0) 64740 define(BACKWARD,-1) 64750 define(EXCLUDE,LETX) 64760 define(APPENDCOM,LETA) 64770 define(CHANGE,LETC) 64780 define(DELCOM,LETD) 64790 define(ENTER,LETE) 64800 define(PRINTFIL,LETF) 64810 define(READCOM,LETR) 64820 define(WRITECOM,LETW) 64830 define(INSERT,LETI) 64840 define(PRINTCUR,EQUALS) 64850 define(MOVECOM,LETM) 64860 define(QUIT,LETQ) 64870 define(SUBSTITUTE,LETS) 64880 define(CURLINE,PERIOD) 64890 define(LASTLINE,DOLLAR) 64900 define(SCAN,SLASH) 64910 define(BACKSCAN,BACKSLASH) 64920 define(NOSTATUS,1) 64930 define(LINE0,1) 64940 define(PREV,0) 64950 define(NEXT,1) 64960 define(MARK,2) 64970 define(TEXT,3) 64980 define(MAXBUF,1000) 64990 common /cbuf/ buf(MAXBUF), lastbf 65000 character buf # buffer for pointers plus text 65010 integer lastbf # last element used in buf 65020 common /clines/ line1, line2, nlines, curln, lastln 65030 integer line1 # first line number 65040 integer line2 # second line number 65050 integer nlines # number of line numbers specified 65060 integer curln # current line: value of dot 65070 integer lastln # last line: value of $ 65080 common /cpat/ pat(MAXPAT) 65090 character pat # pattern 65100 common /ctxt/ txt(MAXLINE) 65110 character txt # text line for matching and output 65120 common /cfile/ savfil(MAXLINE) 65130 character savfil # remembered file name 65140 # append - append lines after "line" 65150 integer function append(line, glob) 65160 character lin(MAXLINE) 65170 integer getlin, inject 65180 integer line, glob 65190 include clines 65200 65210 if (glob == YES) 65220 append = ERR 65230 else { 65240 curln = line 65250 for (append = NOSTATUS; append == NOSTATUS; ) 65260 if (getlin(lin, STDIN) == EOF) 65270 append = EOF 65280 else if (lin(1) == PERIOD & lin(2) == NEWLINE) 65290 append = OK 65300 else if (inject(lin) == ERR) 65310 append = ERR 65320 } 65330 return 65340 end 65350 # ckglob - if global prefix, mark lines to be affected 65360 integer function ckglob(lin, i, status) 65370 character lin(MAXLINE) 65380 integer defalt, getind, gettxt, match, nextln, optpat 65390 integer gflag, i, k, line, status 65400 include cbuf 65410 include clines 65420 include cpat 65430 include ctxt 65440 65450 if (lin(i) ^= GLOBAL & lin(i) ^= EXCLUDE) 65460 status = EOF 65470 else { 65480 if (lin(i) == GLOBAL) 65490 gflag = YES 65500 else 65510 gflag = NO 65520 i = i + 1 65530 if (optpat(lin, i) == ERR | defalt(1, lastln, status) == ERR) 65540 status = ERR 65550 else { 65560 i = i + 1 65570 for (line = line1; line <= line2; line = line + 1) { 65580 k = gettxt(line) 65590 if (match(txt, pat) == gflag) 65600 buf(k+MARK) = YES 65610 else 65620 buf(k+MARK) = NO 65630 } 65640 for (line=nextln(line2); line^=line1; line=nextln(line)) { 65650 k = getind(line) 65660 buf(k+MARK) = NO 65670 } 65680 status = OK 65690 } 65700 } 65710 ckglob = status 65720 return 65730 end 65740 # ckp - check for "p" after command 65750 integer function ckp(lin, i, pflag, status) 65760 character lin(MAXLINE) 65770 integer i, j, pflag, status 65780 65790 j = i 65800 if (lin(j) == PRINT) { 65810 j = j + 1 65820 pflag = YES 65830 } 65840 else 65850 pflag = NO 65860 if (lin(j) == NEWLINE) 65870 status = OK 65880 else 65890 status = ERR 65900 ckp = status 65910 return 65920 end 65930 # clrbuf (in memory) - initialize for new file 65940 subroutine clrbuf 65950 65960 return # nothing to do 65970 end 65980 # defalt - set defaulted line numbers 65990 integer function defalt(def1, def2, status) 66000 integer def1, def2, status 66010 include clines 66020 66030 if (nlines == 0) { 66040 line1 = def1 66050 line2 = def2 66060 } 66070 if (line1 > line2 | line1 <= 0) 66080 status = ERR 66090 else 66100 status = OK 66110 defalt = status 66120 return 66130 end 66140 # delete - delete lines from through to 66150 integer function delete(from, to, status) 66160 integer getind, nextln, prevln 66170 integer from, k1, k2, status, to 66180 include clines 66190 66200 if (from <= 0) 66210 status = ERR 66220 else { 66230 k1 = getind(prevln(from)) 66240 k2 = getind(nextln(to)) 66250 lastln = lastln - (to - from + 1) 66260 curln = prevln(from) 66270 call relink(k1, k2, k1, k2) 66280 status = OK 66290 } 66300 delete = status 66310 return 66320 end 66330 # docmd - handle all commands except globals 66340 integer function docmd(lin, i, glob, status) 66350 character file(MAXLINE), lin(MAXLINE), sub(MAXPAT) 66360 integer append, delete, doprnt, doread, dowrit, move, subst 66370 integer ckp, defalt, getfn, getone, getrhs, nextln, optpat, prevln 66380 integer gflag, glob, i, line3, pflag, status 66390 include cfile 66400 include clines 66410 include cpat 66420 66430 pflag = NO # may be set by d, m, s 66440 status = ERR 66450 if (lin(i) == APPENDCOM) { 66460 if (lin(i + 1) == NEWLINE) 66470 status = append(line2, glob) 66480 } 66490 else if (lin(i) == CHANGE) { 66500 if (lin(i + 1) == NEWLINE) 66510 andif (defalt(curln, curln, status) == OK) 66520 andif (delete(line1, line2, status) == OK) 66530 status = append(prevln(line1), glob) 66540 } 66550 else if (lin(i) == DELCOM) { 66560 if (ckp(lin, i + 1, pflag, status) == OK) 66570 andif (defalt(curln, curln, status) == OK) 66580 andif (delete(line1, line2, status) == OK) 66590 andif (nextln(curln) ^= 0) 66600 curln = nextln(curln) 66610 } 66620 else if (lin(i) == INSERT) { 66630 if (lin(i + 1) == NEWLINE) 66640 status = append(prevln(line2), glob) 66650 } 66660 else if (lin(i) == PRINTCUR) { 66670 if (ckp(lin, i + 1, pflag, status) == OK) { 66680 call putdec(line2, 1) 66690 call putc(NEWLINE) 66700 } 66710 } 66720 else if (lin(i) == MOVECOM) { 66730 i = i + 1 66740 if (getone(lin, i, line3, status) == EOF) 66750 status = ERR 66760 if (status == OK) 66770 andif (ckp(lin, i, pflag, status) == OK) 66780 andif (defalt(curln, curln, status) == OK) 66790 status = move(line3) 66800 } 66810 else if (lin(i) == SUBSTITUTE) { 66820 i = i + 1 66830 if (optpat(lin, i) == OK) 66840 andif (getrhs(lin, i, sub, gflag) == OK) 66850 andif (ckp(lin, i + 1, pflag, status) == OK) 66860 andif (defalt(curln, curln, status) == OK) 66870 status = subst(sub, gflag) 66880 } 66890 else if (lin(i) == ENTER) { 66900 if (nlines == 0) 66910 andif (getfn(lin, i, file) == OK) { 66920 call scopy(file, 1, savfil, 1) 66930 call clrbuf 66940 call setbuf 66950 status = doread(0, file) 66960 } 66970 } 66980 else if (lin(i) == PRINTFIL) { 66990 if (nlines == 0) 67000 andif (getfn(lin, i, file) == OK) { 67010 call scopy(file, 1, savfil, 1) 67020 call putlin(savfil, STDOUT) 67030 call putc(NEWLINE) 67040 status = OK 67050 } 67060 } 67070 else if (lin(i) == READCOM) { 67080 if (getfn(lin, i, file) == OK) 67090 status = doread(line2, file) 67100 } 67110 else if (lin(i) == WRITECOM) { 67120 if (getfn(lin, i, file) == OK) 67130 andif (defalt(1, lastln, status) == OK) 67140 status = dowrit(line1, line2, file) 67150 } 67160 else if (lin(i) == PRINT) { 67170 if (lin(i + 1) == NEWLINE) 67180 andif (defalt(curln, curln, status) == OK) 67190 status = doprnt(line1, line2) 67200 } 67210 else if (lin(i) == NEWLINE) { 67220 if (nlines == 0) 67230 line2 = nextln(curln) 67240 status = doprnt(line2, line2) 67250 } 67260 else if (lin(i) == QUIT) { 67270 if (lin(i + 1) == NEWLINE & nlines == 0 & glob == NO) 67280 status = EOF 67290 } 67300 # else status is ERR 67310 if (status == OK & pflag == YES) 67320 status = doprnt(curln, curln) 67330 docmd = status 67340 return 67350 end 67360 # doglob - do command at lin(i) on all marked lines 67370 integer function doglob(lin, i, cursav, status) 67380 character lin(MAXLINE) 67390 integer docmd, getind, getlst, nextln 67400 integer count, cursav, i, istart, k, line, status 67410 include cbuf 67420 include clines 67430 67440 status = OK 67450 count = 0 67460 line = line1 67470 istart = i 67480 repeat { 67490 k = getind(line) 67500 if (buf(k+MARK) == YES) { 67510 buf(k+MARK) = NO 67520 curln = line 67530 cursav = curln 67540 i = istart 67550 if (getlst(lin, i, status) == OK) 67560 andif (docmd(lin, i, YES, status) == OK) 67570 count = 0 67580 } 67590 else { 67600 line = nextln(line) 67610 count = count + 1 67620 } 67630 } until (count > lastln | status ^= OK) 67640 doglob = status 67650 return 67660 end 67670 # doprnt - print lines from through to 67680 integer function doprnt(from, to) 67690 integer gettxt 67700 integer from, i, j, to 67710 include clines 67720 include ctxt 67730 67740 if (from <= 0) 67750 doprnt = ERR 67760 else { 67770 for (i = from; i <= to; i = i + 1) { 67780 j = gettxt(i) 67790 call putlin(txt, STDOUT) 67800 } 67810 curln = to 67820 doprnt = OK 67830 } 67840 return 67850 end 67860 # doread - read "file" after "line" 67870 integer function doread(line, file) 67880 character file(MAXLINE), lin(MAXLINE) 67890 integer getlin, inject, open 67900 integer count, fd, line 67910 include clines 67920 67930 fd = open(file, READ) 67940 if (fd == ERR) 67950 doread = ERR 67960 else { 67970 curln = line 67980 doread = OK 67990 for (count = 0; getlin(lin, fd) ^= EOF; count = count + 1) { 68000 doread = inject(lin) 68010 if (doread == ERR) 68020 break 68030 } 68040 call close(fd) 68050 call putdec(count, 1) 68060 call putc(NEWLINE) 68070 } 68080 return 68090 end 68100 # dowrit - write "from" through "to" into file 68110 integer function dowrit(from, to, file) 68120 character file(MAXLINE) 68130 integer create, gettxt 68140 integer fd, from, k, line, to 68150 include ctxt 68160 68170 fd = create(file, WRITE) 68180 if (fd == ERR) 68190 dowrit = ERR 68200 else { 68210 for (line = from; line <= to; line = line + 1) { 68220 k = gettxt(line) 68230 call putlin(txt, fd) 68240 } 68250 call close(fd) 68260 call putdec(to-from+1, 1) 68270 call putc(NEWLINE) 68280 dowrit = OK 68290 } 68300 return 68310 end 68320 # edit - main routine 68330 character lin(MAXLINE) 68340 integer ckglob, docmd, doglob, doread, getarg, getlin, getlst 68350 integer cursav, i, status 68360 include cfile 68370 include clines 68380 include cpat 68390 68400 call setbuf 68410 pat(1) = EOS 68420 savfil(1) = EOS 68430 if (getarg(1, savfil, MAXLINE) ^= EOF) 68440 if (doread(0, savfil) == ERR) 68450 call remark("?.") 68460 while (getlin(lin, STDIN) ^= EOF) { 68470 i = 1 68480 cursav = curln 68490 if (getlst(lin, i, status) == OK) { 68500 if (ckglob(lin, i, status) == OK) 68510 status = doglob(lin, i, cursav, status) 68520 else if (status ^= ERR) 68530 status = docmd(lin, i, NO, status) 68540 # else error, do nothing 68550 } 68560 if (status == ERR) { 68570 call remark("?.") 68580 curln = cursav 68590 } 68600 else if (status == EOF) 68610 break 68620 # else OK, loop 68630 } 68640 call clrbuf 68650 stop 68660 end 68670 # getfn - get file name from lin(i)... 68680 integer function getfn(lin, i, file) 68690 character lin(MAXLINE), file(MAXLINE) 68700 integer i, j, k 68710 include cfile 68720 68730 getfn = ERR 68740 if (lin(i + 1) == BLANK) { 68750 j = i + 2 # get new file name 68760 call skipbl(lin, j) 68770 for (k = 1; lin(j) ^= NEWLINE; k = k + 1) { 68780 file(k) = lin(j) 68790 j = j + 1 68800 } 68810 file(k) = EOS 68820 if (k > 1) 68830 getfn = OK 68840 } 68850 else if (lin(i + 1) == NEWLINE & savfil(1) ^= EOS) { 68860 call scopy(savfil, 1, file, 1) # or old name 68870 getfn = OK 68880 } 68890 # else error 68900 if (getfn == OK & savfil(1) == EOS) 68910 call scopy(file, 1, savfil, 1) # save if no old one 68920 return 68930 end 68940 # getind - locate line index in buffer 68950 integer function getind(line) 68960 integer j, k, line 68970 include cbuf 68980 68990 k = LINE0 69000 for (j = 0; j < line; j = j + 1) 69010 k = buf(k + NEXT) 69020 getind = k 69030 return 69040 end 69050 # getlst - collect line numbers (if any) at lin(i), increment i 69060 integer function getlst(lin, i, status) 69070 character lin(MAXLINE) 69080 integer getone, min 69090 integer i, num, status 69100 include clines 69110 69120 line2 = 0 69130 for (nlines = 0; getone(lin, i, num, status) == OK; ) { 69140 line1 = line2 69150 line2 = num 69160 nlines = nlines + 1 69170 if (lin(i) ^= COMMA & lin(i) ^= SEMICOL) 69180 break 69190 if (lin(i) == SEMICOL) 69200 curln = num 69210 i = i + 1 69220 } 69230 nlines = min(nlines, 2) 69240 if (nlines == 0) 69250 line2 = curln 69260 if (nlines <= 1) 69270 line1 = line2 69280 if (status ^= ERR) 69290 status = OK 69300 getlst = status 69310 return 69320 end 69330 # getnum - convert one term to line number 69340 integer function getnum(lin, i, pnum, status) 69350 character lin(MAXLINE) 69360 integer ctoi, index, optpat, ptscan 69370 integer i, pnum, status 69380 include clines 69390 include cpat 69400 # string digits "0123456789" 69410 integer digits(11) 69420 data digits(01)/DIG0/ 69430 data digits(02)/DIG1/ 69440 data digits(03)/DIG2/ 69450 data digits(04)/DIG3/ 69460 data digits(05)/DIG4/ 69470 data digits(06)/DIG5/ 69480 data digits(07)/DIG6/ 69490 data digits(08)/DIG7/ 69500 data digits(09)/DIG8/ 69510 data digits(10)/DIG9/ 69520 data digits(11)/EOS/ 69530 69540 getnum = OK 69550 if (index(digits, lin(i)) > 0) { 69560 pnum = ctoi(lin, i) 69570 i = i - 1 # move back; to be advanced at the end 69580 } 69590 else if (lin(i) == CURLINE) 69600 pnum = curln 69610 else if (lin(i) == LASTLINE) 69620 pnum = lastln 69630 else if (lin(i) == SCAN | lin(i) == BACKSCAN) { 69640 if (optpat(lin, i) == ERR) # build the pattern 69650 getnum = ERR 69660 else if (lin(i) == SCAN) 69670 getnum = ptscan(FORWARD, pnum) 69680 else 69690 getnum = ptscan(BACKWARD, pnum) 69700 } 69710 else 69720 getnum = EOF 69730 if (getnum == OK) 69740 i = i + 1 # point at next character to be examined 69750 status = getnum 69760 return 69770 end 69780 # getone - evaluate one line number expression 69790 integer function getone(lin, i, num, status) 69800 character lin(MAXLINE) 69810 integer getnum 69820 integer i, istart, mul, num, pnum, status 69830 include clines 69840 69850 istart = i 69860 num = 0 69870 call skipbl(lin, i) 69880 if (getnum(lin, i, num, status) == OK) # first term 69890 repeat { # + or - terms 69900 call skipbl(lin, i) 69910 if (lin(i) ^= PLUS & lin(i) ^= MINUS) { 69920 status = EOF 69930 break 69940 } 69950 if (lin(i) == PLUS) 69960 mul = +1 69970 else 69980 mul = -1 69990 i = i + 1 70000 call skipbl(lin, i) 70010 if (getnum(lin, i, pnum, status) == OK) 70020 num = num + mul * pnum 70030 if (status == EOF) 70040 status = ERR 70050 } until (status ^= OK) 70060 if (num < 0 | num > lastln) 70070 status = ERR 70080 70090 if (status == ERR) 70100 getone = ERR 70110 else if (i <= istart) 70120 getone = EOF 70130 else 70140 getone = OK 70150 70160 status = getone 70170 return 70180 end 70190 # getrhs - get substitution string for "s" command 70200 integer function getrhs(lin, i, sub, gflag) 70210 character lin(MAXLINE), sub(MAXPAT) 70220 integer maksub 70230 integer gflag, i 70240 70250 getrhs = ERR 70260 if (lin(i) == EOS) 70270 return 70280 if (lin(i + 1) == EOS) 70290 return 70300 i = maksub(lin, i + 1, lin(i), sub) 70310 if (i == ERR) 70320 return 70330 if (lin(i + 1) == GLOBAL) { 70340 i = i + 1 70350 gflag = YES 70360 } 70370 else 70380 gflag = NO 70390 getrhs = OK 70400 return 70410 end 70420 # gettxt (in memory) - locate text for line and make available 70430 integer function gettxt(line) 70440 integer getind 70450 integer line 70460 include cbuf 70470 include ctxt 70480 70490 gettxt = getind(line) 70500 call scopy(buf, gettxt + TEXT, txt, 1) 70510 return 70520 end 70530 # inject (in memory) - put text from lin after curln 70540 integer function inject(lin) 70550 character lin(MAXLINE) 70560 integer addset, getind, nextln 70570 integer i, junk, k1, k2, k3 70580 include cbuf 70590 include clines 70600 70610 for (i = 1; lin(i) ^= EOS; ) { 70620 k3 = lastbf 70630 lastbf = lastbf + TEXT 70640 while (lin(i) ^= EOS) { 70650 junk = addset(lin(i), buf, lastbf, MAXBUF) 70660 i = i + 1 70670 if (lin(i - 1) == NEWLINE) 70680 break 70690 } 70700 if (addset(EOS, buf, lastbf, MAXBUF) == NO) { 70710 inject = ERR 70720 break 70730 } 70740 k1 = getind(curln) 70750 k2 = getind(nextln(curln)) 70760 call relink(k1, k3, k3, k2) 70770 call relink(k3, k2, k1, k3) 70780 curln = curln + 1 70790 lastln = lastln + 1 70800 inject = OK 70810 } 70820 return 70830 end 70840 # move - move line1 through line2 after line3 70850 integer function move(line3) 70860 integer getind, nextln, prevln 70870 integer k0, k1, k2, k3, k4, k5, line3 70880 include clines 70890 70900 if (line1 <= 0 | (line1 <= line3 & line3 <= line2)) 70910 move = ERR 70920 else { 70930 k0 = getind(prevln(line1)) 70940 k3 = getind(nextln(line2)) 70950 k1 = getind(line1) 70960 k2 = getind(line2) 70970 call relink(k0, k3, k0, k3) 70980 if (line3 > line1) { 70990 curln = line3 71000 line3 = line3 - (line2 - line1 + 1) 71010 } 71020 else 71030 curln = line3 + (line2 - line1 + 1) 71040 k4 = getind(line3) 71050 k5 = getind(nextln(line3)) 71060 call relink(k4, k1, k2, k5) 71070 call relink(k2, k5, k4, k1) 71080 move = OK 71090 } 71100 return 71110 end 71120 # nextln - get line after "line" 71130 integer function nextln(line) 71140 integer line 71150 include clines 71160 71170 nextln = line + 1 71180 if (nextln > lastln) 71190 nextln = 0 71200 return 71210 end 71220 # optpat - make pattern if specified at lin(i) 71230 integer function optpat(lin, i) 71240 character lin(MAXLINE) 71250 integer makpat 71260 integer i 71270 include cpat 71280 71290 if (lin(i) == EOS) 71300 i = ERR 71310 else if (lin(i + 1) == EOS) 71320 i = ERR 71330 else if (lin(i + 1) == lin(i)) # repeated delimiter 71340 i = i + 1 # leave existing pattern alone 71350 else 71360 i = makpat(lin, i + 1, lin(i), pat) 71370 if (pat(1) == EOS) 71380 i = ERR 71390 if (i == ERR) { 71400 pat(1) = EOS 71410 optpat = ERR 71420 } 71430 else 71440 optpat = OK 71450 return 71460 end 71470 # prevln - get line before "line" 71480 integer function prevln(line) 71490 integer line 71500 include clines 71510 71520 prevln = line - 1 71530 if (prevln < 0) 71540 prevln = lastln 71550 return 71560 end 71570 # ptscan - scan for next occurrence of pattern 71580 integer function ptscan(way, num) 71590 integer gettxt, match, nextln, prevln 71600 integer k, num, way 71610 include clines 71620 include cpat 71630 include ctxt 71640 71650 num = curln 71660 repeat { 71670 if (way == FORWARD) 71680 num = nextln(num) 71690 else 71700 num = prevln(num) 71710 k = gettxt(num) 71720 if (match(txt, pat) == YES) { 71730 ptscan = OK 71740 return 71750 } 71760 } until (num == curln) 71770 ptscan = ERR 71780 return 71790 end 71800 # relink - rewrite two half links 71810 subroutine relink(a, x, y, b) 71820 integer a, b, x, y 71830 include cbuf 71840 71850 buf(x + PREV) = a 71860 buf(y + NEXT) = b 71870 return 71880 end 71890 # setbuf (in memory) - initialize line storage buffer 71900 subroutine setbuf 71910 integer addset 71920 integer junk 71930 include cbuf 71940 include clines 71950 71960 call relink(LINE0, LINE0, LINE0, LINE0) 71970 lastbf = LINE0 + TEXT 71980 junk = addset(EOS, buf, lastbf, MAXBUF) 71990 curln = 0 72000 lastln = 0 72010 return 72020 end 72030 # skipbl - skip blanks and tabs at lin(i)... 72040 subroutine skipbl(lin, i) 72050 character lin(ARB) 72060 integer i 72070 72080 while (lin(i) == BLANK | lin(i) == TAB) 72090 i = i + 1 72100 return 72110 end 72120 # subst - substitute "sub" for occurrences of pattern 72130 integer function subst(sub, gflag) 72140 character new(MAXLINE), sub(MAXPAT) 72150 integer addset, amatch, gettxt, inject 72160 integer gflag, j, junk, k, lastm, line, m, status, subbed 72170 include clines 72180 include cpat 72190 include ctxt 72200 72210 subst = ERR 72220 if (line1 <= 0) 72230 return 72240 for (line = line1; line <= line2; line = line + 1) { 72250 j = 1 72260 subbed = NO 72270 junk = gettxt(line) 72280 lastm = 0 72290 for (k = 1; txt(k) ^= EOS; ) { 72300 if (gflag == YES | subbed == NO) 72310 m = amatch(txt, k, pat) 72320 else 72330 m = 0 72340 if (m > 0 & lastm ^= m) { # replace matched text 72350 subbed = YES 72360 call catsub(txt, k, m, sub, new, j, MAXLINE) 72370 lastm = m 72380 } 72390 if (m == 0 | m == k) { # no match or null match 72400 junk = addset(txt(k), new, j, MAXLINE) 72410 k = k + 1 72420 } 72430 else # skip matched text 72440 k = m 72450 } 72460 if (subbed == YES) { 72470 if (addset(EOS, new, j, MAXLINE) == NO) { 72480 subst = ERR 72490 break 72500 } 72510 call delete(line, line, status) # remembers dot 72520 subst = inject(new) 72530 if (subst == ERR) 72540 break 72550 subst = OK 72560 } 72570 } 72580 return 72590 end 72600 ========== file primitives for scratch file editor ========== 72610 define(PREV,0) 72620 define(NEXT,1) 72630 define(MARK,2) 72640 define(SEEKADR,3) 72650 define(LENG,4) 72660 define(BUFENT,5) 72670 72680 define(MAXBUF,1000) 72690 define(LINE0,1) 72700 72710 common /cbuf/ buf(MAXBUF), lastbf 72720 character buf # structure of pointers for all lines: 72730 # buf(k+0) PREV previous line 72740 # buf(k+1) NEXT next line 72750 # buf(k+2) MARK mark for global commands 72760 # buf(k+3) SEEKADR where line is on scratch file 72770 # buf(k+4) LENG length on scratch 72780 integer lastbf # last pointer used in buf 72790 common /cscrat/ scr, scrend 72800 integer scr # scratch file id 72810 integer scrend # end of info on scratch file 72820 # clrbuf (scratch file) - dispose of scratch file 72830 subroutine clrbuf 72840 include cscrat 72850 # string scrfil "scratch" 72860 integer scrfil(8) 72870 data scrfil(1)/LETS/ 72880 data scrfil(2)/LETC/ 72890 data scrfil(3)/LETR/ 72900 data scrfil(4)/LETA/ 72910 data scrfil(5)/LETT/ 72920 data scrfil(6)/LETC/ 72930 data scrfil(7)/LETH/ 72940 data scrfil(8)/EOS/ 72950 72960 call close(scr) 72970 call remove(scrfil) 72980 return 72990 end 73000 # gettxt (scratch file) - locate text for line, copy to txt 73010 integer function gettxt(line) 73020 integer getbuf, getind 73030 integer j, k, line 73040 include cbuf 73050 include cscrat 73060 include ctxt 73070 73080 k = getind(line) 73090 call seek(buf(k + SEEKADR), scr) 73100 call readf(txt, buf(k + LENG), scr) 73110 j = buf(k + LENG) + 1 73120 txt(j) = EOS 73130 gettxt = k 73140 return 73150 end 73160 # inject (scratch file) - insert lin after curln, write scratch 73170 integer function inject(lin) 73180 character lin(MAXLINE) 73190 integer getind, maklin, nextln 73200 integer i, k1, k2, k3 73210 include clines 73220 73230 for (i = 1; lin(i) ^= EOS; ) { 73240 i = maklin(lin, i, k3) 73250 if (i == ERR) { 73260 inject = ERR 73270 break 73280 } 73290 k1 = getind(curln) 73300 k2 = getind(nextln(curln)) 73310 call relink(k1, k3, k3, k2) 73320 call relink(k3, k2, k1, k3) 73330 curln = curln + 1 73340 lastln = lastln + 1 73350 inject = OK 73360 } 73370 return 73380 end 73390 # maklin (scratch file) - make new line entry, copy text to scratch 73400 integer function maklin(lin, i, newind) 73410 character lin(MAXLINE) 73420 integer addset, length 73430 integer i, j, junk, newind, txtend 73440 include cbuf 73450 include cscrat 73460 include ctxt 73470 73480 maklin = ERR 73490 if (lastbf + BUFENT > MAXBUF) 73500 return # no room for new line entry 73510 txtend = 1 73520 for (j = i; lin(j) ^= EOS; ) { 73530 junk = addset(lin(j), txt, txtend, MAXLINE) 73540 j = j + 1 73550 if (lin(j - 1) == NEWLINE) 73560 break 73570 } 73580 if (addset(EOS, txt, txtend, MAXLINE) == NO) 73590 return 73600 call seek(scrend, scr) # add line to end of scratch file 73610 buf(lastbf + SEEKADR) = scrend 73620 buf(lastbf + LENG) = length(txt) 73630 call putlin(txt, scr) 73640 scrend = scrend + buf(lastbf + LENG) 73650 buf(lastbf + MARK) = NO 73660 newind = lastbf 73670 lastbf = lastbf + BUFENT 73680 maklin = j # next character to be examined in lin 73690 return 73700 end 73710 # setbuf (scratch file) - create scratch file, set up line 0 73720 subroutine setbuf 73730 integer create 73740 integer k 73750 include cbuf 73760 include clines 73770 include cscrat 73780 # string scrfil "scratch" 73790 integer scrfil(8) 73800 # string null "" 73810 integer null(1) 73820 data scrfil(1)/LETS/ 73830 data scrfil(2)/LETC/ 73840 data scrfil(3)/LETR/ 73850 data scrfil(4)/LETA/ 73860 data scrfil(5)/LETT/ 73870 data scrfil(6)/LETC/ 73880 data scrfil(7)/LETH/ 73890 data scrfil(8)/EOS/ 73900 data null(1) /EOS/ 73910 73920 scr = create(scrfil, READWRITE) 73930 if (scr == ERR) 73940 call cant(scrfil) 73950 scrend = 0 73960 lastbf = LINE0 73970 call maklin(null, 1, k) # create empty line 0 73980 call relink(k, k, k, k) # establish initial linked list 73990 curln = 0 74000 lastln = 0 74010 return 74020 end 74030 ========== text formatter of chapter 7 ========== 74040 define(INSIZE,300) 74050 define(MAXOUT,300) 74060 define(COMMAND,PERIOD) 74070 define(PAGENUM,SHARP) 74080 define(PAGEWIDTH,60) 74090 define(PAGELEN,66) 74100 74110 define(UNKNOWN,0) 74120 define(FI,1) 74130 define(NF,2) 74140 define(BR,3) 74150 define(LS,4) 74160 define(BP,5) 74170 define(SP,6) 74180 define(IN,7) 74190 define(RM,8) 74200 define(TI,9) 74210 define(CE,10) 74220 define(UL,11) 74230 define(HE,12) 74240 define(FO,13) 74250 define(PL,14) 74260 74270 define(HUGE,1000) 74280 common /cout/ outp, outw, outwds, outbuf(MAXOUT) 74290 integer outp # last char position in outbuf; init = 0 74300 integer outw # width of text currently in outbuf; init = 0 74310 integer outwds # number of words in outbuf; init = 0 74320 character outbuf # lines to be filled collect here 74330 common /cpage/ curpag,newpag,lineno,plval,m1val,m2val,m3val,m4val, 74340 bottom, header(MAXLINE), footer(MAXLINE) 74350 integer curpag # current output page number; init = 0 74360 integer newpag # next output page number; init = 1 74370 integer lineno # next line to be printed; init = 0 74380 integer plval # page length in lines; init = PAGELEN = 66 74390 integer m1val # margin before and including header 74400 integer m2val # margin after header 74410 integer m3val # margin after last text line 74420 integer m4val # bottom margin, including footer 74430 integer bottom # last live line on page, = plval-m3val-m4val 74440 character header # top of page title; init = NEWLINE 74450 character footer # bottom of page title; init = NEWLINE 74460 common /cparam/ fill, lsval, inval, rmval, tival, ceval, ulval 74470 integer fill # fill if YES; init = YES 74480 integer lsval # current line spacing; init = 1 74490 integer inval # current indent; >= 0; init = 0 74500 integer rmval # current right margin; init = PAGEWIDTH = 60 74510 integer tival # current temporary indent; init = 0 74520 integer ceval # number of lines to center; init = 0 74530 integer ulval # number of lines to underline; init = 0 74540 # brk - end current filled line 74550 subroutine brk 74560 include cout 74570 74580 if (outp > 0) { 74590 outbuf(outp) = NEWLINE 74600 outbuf(outp+1) = EOS 74610 call put(outbuf) 74620 } 74630 outp = 0 74640 outw = 0 74650 outwds = 0 74660 return 74670 end 74680 # center - center a line by setting tival 74690 subroutine center(buf) 74700 character buf(ARB) 74710 integer max, width 74720 include cparam 74730 74740 tival = max((rmval+tival-width(buf))/2, 0) 74750 return 74760 end 74770 # comand - perform formatting command 74780 subroutine comand(buf) 74790 character buf(MAXLINE) 74800 integer comtyp, getval, max 74810 integer argtyp, ct, spval, val 74820 include cpage 74830 include cparam 74840 74850 ct = comtyp(buf) 74860 if (ct == UNKNOWN) # ignore unknown commands 74870 return 74880 val = getval(buf, argtyp) 74890 if (ct == FI) { 74900 call brk 74910 fill = YES 74920 } 74930 else if (ct == NF) { 74940 call brk 74950 fill = NO 74960 } 74970 else if (ct == BR) 74980 call brk 74990 else if (ct == LS) 75000 call set(lsval, val, argtyp, 1, 1, HUGE) 75010 else if (ct == CE) { 75020 call brk 75030 call set(ceval, val, argtyp, 1, 0, HUGE) 75040 } 75050 else if (ct == UL) 75060 call set(ulval, val, argtyp, 0, 1, HUGE) 75070 else if (ct == HE) 75080 call gettl(buf, header) 75090 else if (ct == FO) 75100 call gettl(buf, footer) 75110 else if (ct == BP) { 75120 if (lineno > 0) 75130 call space(HUGE) 75140 call set(curpag, val, argtyp, curpag+1, -HUGE, HUGE) 75150 newpag = curpag 75160 } 75170 else if (ct == SP) { 75180 call set(spval, val, argtyp, 1, 0, HUGE) 75190 call space(spval) 75200 } 75210 else if (ct == IN) { 75220 call set(inval, val, argtyp, 0, 0, rmval-1) 75230 tival = inval 75240 } 75250 else if (ct == RM) 75260 call set(rmval, val, argtyp, PAGEWIDTH, tival+1, HUGE) 75270 else if (ct == TI) { 75280 call brk 75290 call set(tival, val, argtyp, 0, 0, rmval) 75300 } 75310 else if (ct == PL) { 75320 call set(plval, val, argtyp, PAGELEN, 75330 m1val+m2val+m3val+m4val+1, HUGE) 75340 bottom = plval - m3val - m4val 75350 } 75360 return 75370 end 75380 # comtyp - decode command type 75390 integer function comtyp(buf) 75400 character buf(MAXLINE) 75410 75420 if (buf(2) == LETF & buf(3) == LETI) 75430 comtyp = FI 75440 else if (buf(2) == LETN & buf(3) == LETF) 75450 comtyp = NF 75460 else if (buf(2) == LETB & buf(3) == LETR) 75470 comtyp = BR 75480 else if (buf(2) == LETL & buf(3) == LETS) 75490 comtyp = LS 75500 else if (buf(2) == LETB & buf(3) == LETP) 75510 comtyp = BP 75520 else if (buf(2) == LETS & buf(3) == LETP) 75530 comtyp = SP 75540 else if (buf(2) == LETI & buf(3) == LETN) 75550 comtyp = IN 75560 else if (buf(2) == LETR & buf(3) == LETM) 75570 comtyp = RM 75580 else if (buf(2) == LETT & buf(3) == LETI) 75590 comtyp = TI 75600 else if (buf(2) == LETC & buf(3) == LETE) 75610 comtyp = CE 75620 else if (buf(2) == LETU & buf(3) == LETL) 75630 comtyp = UL 75640 else if (buf(2) == LETH & buf(3) == LETE) 75650 comtyp = HE 75660 else if (buf(2) == LETF & buf(3) == LETO) 75670 comtyp = FO 75680 else if (buf(2) == LETP & buf(3) == LETL) 75690 comtyp = PL 75700 else 75710 comtyp = UNKNOWN 75720 return 75730 end 75740 # format - text formatter main program (final version) 75750 character inbuf(INSIZE) 75760 integer getlin 75770 include cpage 75780 75790 call init 75800 while (getlin(inbuf, STDIN) ^= EOF) 75810 if (inbuf(1) == COMMAND) # it's a command 75820 call comand(inbuf) 75830 else # it's text 75840 call text(inbuf) 75850 if (lineno > 0) 75860 call space(HUGE) # flush last output 75870 stop 75880 end 75890 # gettl - copy title from buf to ttl 75900 subroutine gettl(buf, ttl) 75910 character buf(MAXLINE), ttl(MAXLINE) 75920 integer i 75930 75940 i = 1 # skip command name 75950 while (buf(i) ^= BLANK & buf(i) ^= TAB & buf(i) ^= NEWLINE) 75960 i = i + 1 75970 call skipbl(buf, i) # find argument 75980 if (buf(i) == SQUOTE | buf(i) == DQUOTE) # strip quote if found 75990 i = i + 1 76000 call scopy(buf, i, ttl, 1) 76010 return 76020 end 76030 # getval - evaluate optional numeric argument 76040 integer function getval(buf, argtyp) 76050 character buf(MAXLINE) 76060 integer ctoi 76070 integer argtyp, i 76080 76090 i = 1 # skip command name 76100 while (buf(i) ^= BLANK & buf(i) ^= TAB & buf(i) ^= NEWLINE) 76110 i = i + 1 76120 call skipbl(buf, i) # find argument 76130 argtyp = buf(i) 76140 if (argtyp == PLUS | argtyp == MINUS) 76150 i = i + 1 76160 getval = ctoi(buf, i) 76170 return 76180 end 76190 # getwrd - get non-blank word from in(i) into out, increment i 76200 integer function getwrd(in, i, out) 76210 integer in(MAXLINE), out(MAXLINE) 76220 integer i, j 76230 76240 while (in(i) == BLANK | in(i) == TAB) 76250 i = i + 1 76260 j = 1 76270 while (in(i)^=EOS & in(i)^=BLANK & in(i)^=TAB & in(i)^=NEWLINE) { 76280 out(j) = in(i) 76290 i = i + 1 76300 j = j + 1 76310 } 76320 out(j) = EOS 76330 getwrd = j - 1 76340 return 76350 end 76360 # init - set parameters to default values 76370 subroutine init 76380 76390 include cparam 76400 include cpage 76410 include cout 76420 76430 inval = 0 76440 rmval = PAGEWIDTH 76450 tival = 0 76460 lsval = 1 76470 fill = YES 76480 ceval = 0 76490 ulval = 0 76500 lineno = 0 76510 curpag = 0 76520 newpag = 1 76530 plval = PAGELEN 76540 m1val = 3; m2val = 2; m3val = 2; m4val = 3 76550 bottom = plval - m3val - m4val 76560 header(1) = NEWLINE; header(2) = EOS # initial titles 76570 footer(1) = NEWLINE; footer(2) = EOS 76580 outp = 0 76590 outw = 0 76600 outwds = 0 76610 76620 return 76630 end 76640 # leadbl - delete leading blanks, set tival 76650 subroutine leadbl(buf) 76660 character buf(MAXLINE) 76670 integer max 76680 integer i, j 76690 include cparam 76700 76710 call brk 76720 for (i = 1; buf(i) == BLANK; i = i + 1) # find 1st non-blank 76730 ; 76740 if (buf(i) ^= NEWLINE) 76750 tival = i - 1 76760 for (j = 1; buf(i) ^= EOS; j = j + 1) { # move line to left 76770 buf(j) = buf(i) 76780 i = i + 1 76790 } 76800 buf(j) = EOS 76810 return 76820 end 76830 # pfoot - put out page footer 76840 subroutine pfoot 76850 include cpage 76860 76870 call skip(m3val) 76880 if (m4val > 0) { 76890 call puttl(footer, curpag) 76900 call skip(m4val-1) 76910 } 76920 return 76930 end 76940 # phead - put out page header 76950 subroutine phead 76960 include cpage 76970 76980 curpag = newpag 76990 newpag = newpag + 1 77000 if (m1val > 0) { 77010 call skip(m1val-1) 77020 call puttl(header, curpag) 77030 } 77040 call skip(m2val) 77050 lineno = m1val + m2val + 1 77060 return 77070 end 77080 # put - put out line with proper spacing and indenting 77090 subroutine put(buf) 77100 character buf(MAXLINE) 77110 integer min 77120 integer i 77130 include cpage 77140 include cparam 77150 77160 if (lineno == 0 | lineno > bottom) 77170 call phead 77180 for (i = 1; i <= tival; i = i + 1) # indenting 77190 call putc(BLANK) 77200 tival = inval 77210 call putlin(buf, STDOUT) 77220 call skip(min(lsval-1, bottom-lineno)) 77230 lineno = lineno + lsval 77240 if (lineno > bottom) 77250 call pfoot 77260 return 77270 end 77280 # puttl - put out title line with optional page number 77290 subroutine puttl(buf, pageno) 77300 character buf(MAXLINE) 77310 integer pageno 77320 integer i 77330 77340 for (i = 1; buf(i) ^= EOS; i = i + 1) 77350 if (buf(i) == PAGENUM) 77360 call putdec(pageno, 1) 77370 else 77380 call putc(buf(i)) 77390 return 77400 end 77410 # putwrd - put a word in outbuf; includes margin justification 77420 subroutine putwrd(wrdbuf) 77430 character wrdbuf(INSIZE) 77440 integer length, width 77450 integer last, llval, nextra, w 77460 include cout 77470 include cparam 77480 77490 w = width(wrdbuf) 77500 last = length(wrdbuf) + outp + 1 # new end of outbuf 77510 llval = rmval - tival 77520 if (outp > 0 & (outw+w > llval | last >= MAXOUT)) { # too big 77530 last = last - outp # remember end of wrdbuf 77540 nextra = llval - outw + 1 77550 call spread(outbuf, outp, nextra, outwds) 77560 if (nextra > 0 & outwds > 1) 77570 outp = outp + nextra 77580 call brk # flush previous line 77590 } 77600 call scopy(wrdbuf, 1, outbuf, outp+1) 77610 outp = last 77620 outbuf(outp) = BLANK # blank between words 77630 outw = outw + w + 1 # 1 for blank 77640 outwds = outwds + 1 77650 return 77660 end 77670 # set - set parameter and check range 77680 subroutine set(param, val, argtyp, defval, minval, maxval) 77690 integer max, min 77700 integer argtyp, defval, maxval, minval, param, val 77710 77720 if (argtyp == NEWLINE) # defaulted 77730 param = defval 77740 else if (argtyp == PLUS) # relative + 77750 param = param + val 77760 else if (argtyp == MINUS) # relative - 77770 param = param - val 77780 else # absolute 77790 param = val 77800 param = min(param, maxval) 77810 param = max(param, minval) 77820 return 77830 end 77840 # skip - output n blank lines 77850 subroutine skip(n) 77860 integer i, n 77870 77880 for (i = 1; i <= n; i = i + 1) { 77890 call putc(PERIOD) 77900 call putc(NEWLINE) 77910 } 77920 return 77930 end 77940 # skipbl - skip blanks and tabs at lin(i)... 77950 subroutine skipbl(lin, i) 77960 character lin(ARB) 77970 integer i 77980 77990 while (lin(i) == BLANK | lin(i) == TAB) 78000 i = i + 1 78010 return 78020 end 78030 # space - space n lines or to bottom of page 78040 subroutine space(n) 78050 integer min 78060 integer n 78070 include cpage 78080 78090 call brk 78100 if (lineno > bottom) 78110 return 78120 if (lineno == 0) 78130 call phead 78140 call skip(min(n, bottom+1-lineno)) 78150 lineno = lineno + n 78160 if (lineno > bottom) 78170 call pfoot 78180 return 78190 end 78200 # spread - spread words to justify right margin 78210 subroutine spread(buf, outp, nextra, outwds) 78220 character buf(MAXOUT) 78230 integer min 78240 integer dir, i, j, nb, ne, nextra, nholes, outp, outwds 78250 data dir /0/ 78260 78270 if (nextra <= 0 | outwds <= 1) 78280 return 78290 dir = 1 - dir # reverse previous direction 78300 ne = nextra 78310 nholes = outwds - 1 78320 i = outp - 1 78330 j = min(MAXOUT-2, i+ne) # leave room for NEWLINE, EOS 78340 while (i < j) { 78350 buf(j) = buf(i) 78360 if (buf(i) == BLANK) { 78370 if (dir == 0) 78380 nb = (ne-1) / nholes + 1 78390 else 78400 nb = ne / nholes 78410 ne = ne - nb 78420 nholes = nholes - 1 78430 for ( ; nb > 0; nb = nb - 1) { 78440 j = j - 1 78450 buf(j) = BLANK 78460 } 78470 } 78480 i = i - 1 78490 j = j - 1 78500 } 78510 return 78520 end 78530 # putwrd - put a word in outbuf 78540 subroutine putwrd(wrdbuf) 78550 character wrdbuf(INSIZE) 78560 integer length, width 78570 integer last, llval, w 78580 include cout 78590 include cparam 78600 78610 w = width(wrdbuf) 78620 last = length(wrdbuf) + outp + 1 # new end of outbuf 78630 llval = rmval - tival 78640 if (outp > 0 & (outw+w > llval | last >= MAXOUT)) { # too big 78650 last = last - outp # remember end of wrdbuf 78660 call brk # flush previous line 78670 } 78680 call scopy(wrdbuf, 1, outbuf, outp+1) 78690 outp = last 78700 outbuf(outp) = BLANK # blank between words 78710 outw = outw + w + 1 # 1 for blank 78720 outwds = outwds + 1 78730 return 78740 end 78750 # text - process text lines (final version) 78760 subroutine text(inbuf) 78770 character inbuf(INSIZE), wrdbuf(INSIZE) 78780 integer getwrd 78790 integer i 78800 include cparam 78810 78820 if (inbuf(1) == BLANK | inbuf(1) == NEWLINE) 78830 call leadbl(inbuf) # move left, set tival 78840 if (ulval > 0) { # underlining 78850 call underl(inbuf, wrdbuf, INSIZE) 78860 ulval = ulval - 1 78870 } 78880 if (ceval > 0) { # centering 78890 call center(inbuf) 78900 call put(inbuf) 78910 ceval = ceval - 1 78920 } 78930 else if (inbuf(1) == NEWLINE) # all blank line 78940 call put(inbuf) 78950 else if (fill == NO) # unfilled text 78960 call put(inbuf) 78970 else # filled text 78980 for (i = 1; getwrd(inbuf, i, wrdbuf) > 0; ) 78990 call putwrd(wrdbuf) 79000 return 79010 end 79020 # text - process text lines (interim version 1) 79030 subroutine text(inbuf) 79040 character inbuf(INSIZE) 79050 79060 call put(inbuf) 79070 return 79080 end 79090 # text - process text lines (interim version 2) 79100 subroutine text(inbuf) 79110 character inbuf(INSIZE), wrdbuf(INSIZE) 79120 integer getwrd 79130 integer i 79140 include cparam 79150 79160 if (inbuf(1) == BLANK | inbuf(1) == NEWLINE) 79170 call leadbl(inbuf) # move left, set tival 79180 if (inbuf(1) == NEWLINE) # all blank line 79190 call put(inbuf) 79200 else if (fill == NO) # unfilled text 79210 call put(inbuf) 79220 else # filled text 79230 for (i = 1; getwrd(inbuf, i, wrdbuf) > 0; ) 79240 call putwrd(wrdbuf) 79250 return 79260 end 79270 # underl - underline a line 79280 subroutine underl(buf, tbuf, size) 79290 integer i, j, size 79300 character buf(size), tbuf(size) 79310 79320 j = 1 # expand into tbuf 79330 for (i = 1; buf(i) ^= NEWLINE & j < size-1; i = i + 1) { 79340 tbuf(j) = buf(i) 79350 j = j + 1 79360 if (buf(i) ^= BLANK & buf(i) ^= TAB & buf(i) ^= BACKSPACE) { 79370 tbuf(j) = BACKSPACE 79380 tbuf(j+1) = UNDERLINE 79390 j = j + 2 79400 } 79410 } 79420 tbuf(j) = NEWLINE 79430 tbuf(j+1) = EOS 79440 call scopy(tbuf, 1, buf, 1) # copy it back to buf 79450 return 79460 end 79470 # width - compute width of character string 79480 integer function width(buf) 79490 character buf(MAXLINE) 79500 integer i 79510 79520 width = 0 79530 for (i = 1; buf(i) ^= EOS; i = i + 1) 79540 if (buf(i) == BACKSPACE) 79550 width = width - 1 79560 else if (buf(i) ^= NEWLINE) 79570 width = width + 1 79580 return 79590 end 79600 ========== macro processors of chapter 8 ========== 79610 define(ALPHA,-100) 79620 define(MAXTBL,500) 79630 define(MAXPTR,50) 79640 define(CALLSIZE,20) 79650 define(ARGSIZE,100) 79660 define(MAXDEF,200) 79670 define(MAXTOK,200) 79680 79690 define(ARGFLAG,DOLLAR) 79700 79710 define(DEFTYPE,-10) 79720 define(IFTYPE,-11) 79730 define(INCTYPE,-12) 79740 define(SUBTYPE,-13) 79750 79760 define(EVALSIZE,500) 79770 define(BUFSIZE,500) 79780 common /cdefio/ bp, buf(BUFSIZE) 79790 integer bp # next available character; init = 0 79800 character buf # pushed-back characters 79810 common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL) 79820 integer lastp # last used in namptr; init = 0 79830 integer lastt # last used in table; init = 0 79840 integer namptr # name pointers 79850 character table # actual text of names and defns 79860 common /cmacro/ cp, ep, evalst(EVALSIZE) 79870 integer cp # current call stack pointer 79880 integer ep # next free position in evalst 79890 character evalst # evaluation stack 79900 # block data for macro 79910 block data 79920 include cdefio 79930 data bp /0/ 79940 end 79950 # gettok - get alphanumeric string or single non-alpha for define 79960 character function gettok(token, toksiz) 79970 character ngetc, type 79980 integer i, toksiz 79990 character token(toksiz) 80000 80010 for (i = 1; i < toksiz; i = i + 1) { 80020 gettok = type(ngetc(token(i))) 80030 if (gettok ^= LETTER & gettok ^= DIGIT) 80040 break 80050 } 80060 if (i >= toksiz) 80070 call error("token too long.") 80080 if (i > 1) { # some alpha was seen 80090 call putbak(token(i)) 80100 i = i - 1 80110 gettok = ALPHA 80120 } 80130 # else single character token 80140 token(i+1) = EOS 80150 return 80160 end 80170 # lookup - locate name, extract definition from table 80180 integer function lookup(name, defn) 80190 character defn(MAXDEF), name(MAXTOK) 80200 integer i, j, k 80210 include clook 80220 80230 for (i = lastp; i > 0; i = i - 1) { 80240 j = namptr(i) 80250 for (k = 1; name(k) == table(j) & name(k) ^= EOS; k = k + 1) 80260 j = j + 1 80270 if (name(k) == table(j)) { # got one 80280 call scopy(table, j+1, defn, 1) 80290 lookup = YES 80300 return 80310 } 80320 } 80330 lookup = NO 80340 return 80350 end 80360 80370 # instal - add name and definition to table 80380 subroutine instal(name, defn) 80390 character defn(MAXTOK), name(MAXDEF) 80400 integer length 80410 integer dlen, nlen 80420 include clook 80430 80440 nlen = length(name) + 1 80450 dlen = length(defn) + 1 80460 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { 80470 call putlin(name, ERROUT) 80480 call remark(": too many definitions.") 80490 } 80500 lastp = lastp + 1 80510 namptr(lastp) = lastt + 1 80520 call scopy(name, 1, table, lastt + 1) 80530 call scopy(defn, 1, table, lastt + nlen + 1) 80540 lastt = lastt + nlen + dlen 80550 return 80560 end 80570 80580 80590 #block data 80600 block data 80610 include clook 80620 80630 data lastp /0/ 80640 data lastt /0/ 80650 80660 end 80670 # macro - expand macros with arguments 80680 character gettok 80690 character defn(MAXDEF), t, token(MAXTOK) 80700 integer lookup, push 80710 integer ap, argstk(ARGSIZE), callst(CALLSIZE), nlb, plev(CALLSIZE) 80720 include cmacro 80730 # string balp "()" 80740 integer balp(3) 80750 # string defnam "define" 80760 integer defnam(7) 80770 # string incnam "incr" 80780 integer incnam(5) 80790 # string subnam "substr" 80800 integer subnam(7) 80810 # string ifnam "ifelse" 80820 integer ifnam(7) 80830 integer deftyp(2) 80840 integer inctyp(2) 80850 integer subtyp(2) 80860 integer iftyp(2) 80870 data balp(1) /LPAREN/, balp(2) /RPAREN/, balp(3) /EOS/ 80880 data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ 80890 data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ 80900 data defnam(7) /EOS/ 80910 data incnam(1)/LETI/,incnam(2)/LETN/,incnam(3)/LETC/,incnam(4)/LETR/ 80920 data incnam(5) /EOS/ 80930 data subnam(1) /LETS/, subnam(2) /LETU/, subnam(3) /LETB/ 80940 data subnam(4) /LETS/, subnam(5) /LETT/, subnam(6) /LETR/ 80950 data subnam(7) /EOS/ 80960 data ifnam(1) /LETI/, ifnam(2) /LETF/, ifnam(3) /LETE/ 80970 data ifnam(4) /LETL/, ifnam(5) /LETS/, ifnam(6) /LETE/ 80980 data ifnam(7) /EOS/ 80990 data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/ 81000 data inctyp(1) /INCTYPE/, inctyp(2) /EOS/ 81010 data subtyp(1) /SUBTYPE/, subtyp(2) /EOS/ 81020 data iftyp(1) /IFTYPE/, iftyp(2) /EOS/ 81030 81040 call instal(defnam, deftyp) 81050 call instal(incnam, inctyp) 81060 call instal(subnam, subtyp) 81070 call instal(ifnam, iftyp) 81080 81090 cp = 0 81100 ap = 1 81110 ep = 1 81120 for (t=gettok(token, MAXTOK); t ^= EOF; t=gettok(token, MAXTOK)) { 81130 if (t == ALPHA) { 81140 if (lookup(token, defn) == NO) 81150 call puttok(token) 81160 else { # defined; put it in eval stack 81170 cp = cp + 1 81180 if (cp > CALLSIZE) 81190 call error("call stack overflow.") 81200 callst(cp) = ap 81210 ap = push(ep, argstk, ap) 81220 call puttok(defn) # stack definition 81230 call putchr(EOS) 81240 ap = push(ep, argstk, ap) 81250 call puttok(token) # stack name 81260 call putchr(EOS) 81270 ap = push(ep, argstk, ap) 81280 t = gettok(token, MAXTOK) # peek at next 81290 call pbstr(token) 81300 if (t ^= LPAREN) # add ( ) if not present 81310 call pbstr(balp) 81320 plev(cp) = 0 81330 } 81340 } 81350 else if (t == LBRACK) { # strip one level of Õ å 81360 nlb = 1 81370 repeat { 81380 t = gettok(token, MAXTOK) 81390 if (t == LBRACK) 81400 nlb = nlb + 1 81410 else if (t == RBRACK) { 81420 nlb = nlb - 1 81430 if (nlb == 0) 81440 break 81450 } 81460 else if (t == EOF) 81470 call error("EOF in string.") 81480 call puttok(token) 81490 } 81500 } 81510 else if (cp == 0) # not in a macro at all 81520 call puttok(token) 81530 else if (t == LPAREN) { 81540 if (plev(cp) > 0) 81550 call puttok(token) 81560 plev(cp) = plev(cp) + 1 81570 } 81580 else if (t == RPAREN) { 81590 plev(cp) = plev(cp) - 1 81600 if (plev(cp) > 0) 81610 call puttok(token) 81620 else { # end of argument list 81630 call putchr(EOS) 81640 call eval(argstk, callst(cp), ap-1) 81650 ap = callst(cp) # pop eval stack 81660 ep = argstk(ap) 81670 cp = cp - 1 81680 } 81690 } 81700 else if (t == COMMA & plev(cp) == 1) { # new arg 81710 call putchr(EOS) 81720 ap = push(ep, argstk, ap) 81730 } 81740 else 81750 call puttok(token) # just stack it 81760 } 81770 if (cp ^= 0) 81780 call error("unexpected EOF.") 81790 stop 81800 end 81810 81820 # push - push ep onto argstk, return new pointer ap 81830 integer function push(ep, argstk, ap) 81840 integer ap, argstk(ARGSIZE), ep 81850 81860 if (ap > ARGSIZE) 81870 call error("arg stack overflow.") 81880 argstk(ap) = ep 81890 push = ap + 1 81900 return 81910 end 81920 81930 # puttok - put a token either on output or into evaluation stack 81940 subroutine puttok(str) 81950 character str(MAXTOK) 81960 integer i 81970 81980 for (i = 1; str(i) ^= EOS; i = i + 1) 81990 call putchr(str(i)) 82000 return 82010 end 82020 82030 # putchr - put single char on output or into evaluation stack 82040 subroutine putchr(c) 82050 character c 82060 include cmacro 82070 82080 if (cp == 0) 82090 call putc(c) 82100 else { 82110 if (ep > EVALSIZE) 82120 call error("evaluation stack overflow.") 82130 evalst(ep) = c 82140 ep = ep + 1 82150 } 82160 return 82170 end 82180 82190 # eval - expand args i through j: evaluate builtin or push back defn 82200 subroutine eval(argstk, i, j) 82210 integer index, length 82220 integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td 82230 include cmacro 82240 # string digits "0123456789" 82250 integer digits(11) 82260 data digits(1) /DIG0/ 82270 data digits(2) /DIG1/ 82280 data digits(3) /DIG2/ 82290 data digits(4) /DIG3/ 82300 data digits(5) /DIG4/ 82310 data digits(6) /DIG5/ 82320 data digits(7) /DIG6/ 82330 data digits(8) /DIG7/ 82340 data digits(9) /DIG8/ 82350 data digits(10) /DIG9/ 82360 data digits(11) /EOS/ 82370 82380 t = argstk(i) 82390 td = evalst(t) 82400 if (td == DEFTYPE) 82410 call dodef(argstk, i, j) 82420 else if (td == INCTYPE) 82430 call doincr(argstk, i, j) 82440 else if (td == SUBTYPE) 82450 call dosub(argstk, i, j) 82460 else if (td == IFTYPE) 82470 call doif(argstk, i, j) 82480 else { 82490 for (k = t+length(evalst(t))-1; k > t; k = k - 1) 82500 if (evalst(k-1) ^= ARGFLAG) 82510 call putbak(evalst(k)) 82520 else { 82530 argno = index(digits, evalst(k)) - 1 82540 if (argno >= 0 & argno < j-i) { 82550 n = i + argno + 1 82560 m = argstk(n) 82570 call pbstr(evalst(m)) 82580 } 82590 k = k - 1 # skip over $ 82600 } 82610 if (k == t) # do last character 82620 call putbak(evalst(k)) 82630 } 82640 return 82650 end 82660 82670 # dodef - install definition in table 82680 subroutine dodef(argstk, i, j) 82690 integer a2, a3, argstk(ARGSIZE), i, j 82700 include cmacro 82710 82720 if (j - i > 2) { 82730 a2 = argstk(i+2) 82740 a3 = argstk(i+3) 82750 call instal(evalst(a2), evalst(a3)) # subarrays 82760 } 82770 return 82780 end 82790 82800 # doincr - increment argument by 1 82810 subroutine doincr(argstk, i, j) 82820 integer ctoi 82830 integer argstk(ARGSIZE), i, j, k 82840 include cmacro 82850 82860 k = argstk(i+2) 82870 call pbnum(ctoi(evalst, k)+1) 82880 return 82890 end 82900 82910 # pbnum - convert number to string, push back on input 82920 subroutine pbnum(n) 82930 integer mod 82940 integer m, n, num 82950 # string digits "0123456789" 82960 integer digits(11) 82970 data digits(1) /DIG0/ 82980 data digits(2) /DIG1/ 82990 data digits(3) /DIG2/ 83000 data digits(4) /DIG3/ 83010 data digits(5) /DIG4/ 83020 data digits(6) /DIG5/ 83030 data digits(7) /DIG6/ 83040 data digits(8) /DIG7/ 83050 data digits(9) /DIG8/ 83060 data digits(10) /DIG9/ 83070 data digits(11) /EOS/ 83080 83090 num = n 83100 repeat { 83110 m = mod(num, 10) 83120 call putbak(digits(m+1)) 83130 num = num / 10 83140 } until (num == 0) 83150 return 83160 end 83170 83180 # dosub - select substring 83190 subroutine dosub(argstk, i, j) 83200 integer ctoi, length, max, min 83210 integer ap, argstk(ARGSIZE), fc, i, j, k, nc 83220 include cmacro 83230 83240 if (j - i < 3) 83250 return 83260 if (j - i < 4) 83270 nc = MAXTOK 83280 else { 83290 k = argstk(i+4) 83300 nc = ctoi(evalst, k) # number of characters 83310 } 83320 k = argstk(i+3) # origin 83330 ap = argstk(i+2) # target string 83340 fc = ap + ctoi(evalst, k) - 1 # first char of substring 83350 if (fc >= ap & fc < ap + length(evalst(ap))) { # subarrays 83360 k = fc + min(nc, length(evalst(fc))) - 1 83370 for ( ; k >= fc; k = k - 1) 83380 call putbak(evalst(k)) 83390 } 83400 return 83410 end 83420 83430 # doif - select one of two arguments 83440 subroutine doif(argstk, i, j) 83450 integer equal 83460 integer a2, a3, a4, a5, argstk(ARGSIZE), i, j 83470 include cmacro 83480 83490 if (j - i < 5) 83500 return 83510 a2 = argstk(i+2) 83520 a3 = argstk(i+3) 83530 a4 = argstk(i+4) 83540 a5 = argstk(i+5) 83550 if (equal(evalst(a2), evalst(a3)) == YES) # subarrays 83560 call pbstr(evalst(a4)) 83570 else 83580 call pbstr(evalst(a5)) 83590 return 83600 end 83610 # ngetc - get a (possibly pushed back) character 83620 character function ngetc(c) 83630 character getc 83640 character c 83650 include cdefio 83660 83670 if (bp > 0) 83680 c = buf(bp) 83690 else { 83700 bp = 1 83710 buf(bp) = getc(c) 83720 } 83730 if (c ^= EOF) 83740 bp = bp - 1 83750 ngetc = c 83760 return 83770 end 83780 # pbstr - push string back onto input 83790 subroutine pbstr(in) 83800 character in(MAXLINE) 83810 integer length 83820 integer i 83830 83840 for (i = length(in); i > 0; i = i - 1) 83850 call putbak(in(i)) 83860 return 83870 end 83880 83890 # putbak - push character back onto input 83900 subroutine putbak(c) 83910 character c 83920 include cdefio 83930 83940 bp = bp + 1 83950 if (bp > BUFSIZE) 83960 call error("too many characters pushed back.") 83970 buf(bp) = c 83980 return 83990 end 84000 # define - simple string replacement macro processor 84010 character gettok 84020 character defn(MAXDEF), t, token(MAXTOK) 84030 integer lookup 84040 # string defnam "define" 84050 integer defnam(7) 84060 integer deftyp(2) 84070 data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ 84080 data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ 84090 data defnam(7) /EOS/ 84100 data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/ 84110 84120 call instal(defnam, deftyp) 84130 for (t = gettok(token, MAXTOK); t ^= EOF; t = gettok(token, MAXTOK)) 84140 if (t ^= ALPHA) # output non-alpha tokens 84150 call putlin(token, STDOUT) 84160 else if (lookup(token, defn) == NO) # and undefined 84170 call putlin(token, STDOUT) 84180 else if (defn(1) == DEFTYPE) { # get definition 84190 call getdef(token, MAXTOK, defn, MAXDEF) 84200 call instal(token, defn) 84210 } 84220 else 84230 call pbstr(defn) # push replacement onto input 84240 stop 84250 end 84260 84270 # getdef (for no arguments) - get name and definition 84280 subroutine getdef(token, toksiz, defn, defsiz) 84290 character gettok, ngetc 84300 integer defsiz, i, nlpar, toksiz 84310 character c, defn(defsiz), token(toksiz) 84320 84330 if (ngetc(c) ^= LPAREN) 84340 call error("missing left paren.") 84350 else if (gettok(token, toksiz) ^= ALPHA) 84360 call error("non-alphanumeric name.") 84370 else if (ngetc(c) ^= COMMA) 84380 call error("missing comma in define.") 84390 # else got (name, 84400 nlpar = 0 84410 for (i = 1; nlpar >= 0; i = i + 1) 84420 if (i > defsiz) 84430 call error("definition too long.") 84440 else if (ngetc(defn(i)) == EOF) 84450 call error("missing right paren.") 84460 else if (defn(i) == LPAREN) 84470 nlpar = nlpar + 1 84480 else if (defn(i) == RPAREN) 84490 nlpar = nlpar - 1 84500 # else normal character in defn(i) 84510 defn(i-1) = EOS 84520 return 84530 end 84540 ========== ratfor of chapter 9 ========== 84550 define(MAXSTACK,10) 84560 84570 define(LEXDIGITS,-260) 84580 define(LEXIF,-261) 84590 define(LEXELSE,-262) 84600 define(LEXWHILE,-263) 84610 define(LEXBREAK,-264) 84620 define(LEXNEXT,-265) 84630 define(LEXDO,-266) 84640 define(LEXOTHER,-267) 84650 define(ALPHA,-100) 84660 define(MAXTOK,10) 84670 define(ALPHA,-100) 84680 define(MAXTBL,500) 84690 define(MAXPTR,50) 84700 define(CALLSIZE,20) 84710 define(ARGSIZE,100) 84720 define(MAXDEF,200) 84730 define(MAXTOK,200) 84740 84750 define(ARGFLAG,DOLLAR) 84760 84770 define(DEFTYPE,-10) 84780 define(IFTYPE,-11) 84790 define(INCTYPE,-12) 84800 define(SUBTYPE,-13) 84810 84820 define(EVALSIZE,500) 84830 define(BUFSIZE,500) 84840 common /cdefio/ bp, buf(BUFSIZE) 84850 integer bp # next available character; init = 0 84860 character buf # pushed-back characters 84870 common /cline/ linect 84880 integer linect # line count on input file; init = 1 84890 common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL) 84900 integer lastp # last used in namptr; init = 0 84910 integer lastt # last used in table; init = 0 84920 integer namptr # name pointers 84930 character table # actual text of names and defns 84940 common /coutln/ outp, outbuf(MAXLINE) 84950 integer outp # last position filled in outbuf; init = 0 84960 character outbuf # output lines collected here 84970 # alldig - return YES if str is all digits 84980 integer function alldig(str) 84990 character type 85000 character str(ARB) 85010 integer i 85020 85030 alldig = NO 85040 if (str(1) == EOS) 85050 return 85060 for (i = 1; str(i) ^= EOS; i = i + 1) 85070 if (type(str(i)) ^= DIGIT) 85080 return 85090 alldig = YES 85100 return 85110 end 85120 # balpar - copy balanced paren string 85130 subroutine balpar 85140 character gettok 85150 character t, token(MAXTOK) 85160 integer nlpar 85170 85180 if (gettok(token, MAXTOK) ^= LPAREN) { 85190 call synerr("missing left paren.") 85200 return 85210 } 85220 call outstr(token) 85230 nlpar = 1 85240 repeat { 85250 t = gettok(token, MAXTOK) 85260 if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) { 85270 call pbstr(token) 85280 break 85290 } 85300 if (t == NEWLINE) # delete newlines 85310 token(1) = EOS 85320 else if (t == LPAREN) 85330 nlpar = nlpar + 1 85340 else if (t == RPAREN) 85350 nlpar = nlpar - 1 85360 # else nothing special 85370 call outstr(token) 85380 } until (nlpar <= 0) 85390 if (nlpar ^= 0) 85400 call synerr("missing parenthesis in condition.") 85410 return 85420 end 85430 #block data 85440 block data 85450 85460 include coutln 85470 include cline 85480 include cdefio 85490 85500 data outp /0/ 85510 data linect/1/ 85520 data bp /0/ 85530 85540 end 85550 # brknxt - generate code for break and next 85560 subroutine brknxt(sp, lextyp, labval, token) 85570 integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token 85580 85590 for (i = sp; i > 0; i = i - 1) 85600 if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO) { 85610 if (token == LEXBREAK) 85620 call outgo(labval(i)+1) 85630 else 85640 call outgo(labval(i)) 85650 return 85660 } 85670 if (token == LEXBREAK) 85680 call synerr("illegal break.") 85690 else 85700 call synerr("illegal next.") 85710 return 85720 end 85730 # docode - generate code for beginning of do 85740 subroutine docode(lab) 85750 integer labgen 85760 integer lab 85770 # string dostr "do" 85780 integer dostr(4) 85790 data dostr(1), dostr(2), dostr(3), 85800 dostr(4)/LETD, LETO, BLANK, EOS/ 85810 85820 call outtab 85830 call outstr(dostr) 85840 lab = labgen(2) 85850 call outnum(lab) 85860 call eatup 85870 call outdon 85880 return 85890 end 85900 # dostat - generate code for end of do statement 85910 subroutine dostat(lab) 85920 integer lab 85930 85940 call outcon(lab) 85950 call outcon(lab+1) 85960 return 85970 end 85980 # eatup - process rest of statement; interpret continuations 85990 subroutine eatup 86000 character gettok 86010 character ptoken(MAXTOK), t, token(MAXTOK) 86020 integer nlpar 86030 86040 nlpar = 0 86050 repeat { 86060 t = gettok(token, MAXTOK) 86070 if (t == SEMICOL | t == NEWLINE) 86080 break 86090 if (t == RBRACE) { 86100 call pbstr(token) 86110 break 86120 } 86130 if (t == LBRACE | t == EOF) { 86140 call synerr("unexpected brace or EOF.") 86150 call pbstr(token) 86160 break 86170 } 86180 if (t == COMMA) { 86190 if (gettok(ptoken, MAXTOK) ^= NEWLINE) 86200 call pbstr(ptoken) 86210 } 86220 else if (t == LPAREN) 86230 nlpar = nlpar + 1 86240 else if (t == RPAREN) 86250 nlpar = nlpar - 1 86260 call outstr(token) 86270 } until (nlpar < 0) 86280 if (nlpar ^= 0) 86290 call synerr("unbalanced parentheses.") 86300 return 86310 end 86320 # elseif - generate code for end of if before else 86330 subroutine elseif(lab) 86340 integer lab 86350 86360 call outgo(lab+1) 86370 call outcon(lab) 86380 return 86390 end 86400 # gettok - get token for Ratfor 86410 character function gettok(lexstr, toksiz) 86420 character ngetc, type 86430 integer i, toksiz 86440 character c, lexstr(toksiz) 86450 include cline 86460 86470 while (ngetc(c) ^= EOF) 86480 if (c ^= BLANK & c ^= TAB) 86490 break 86500 call putbak(c) 86510 for (i = 1; i < toksiz-1; i = i + 1) { 86520 gettok = type(ngetc(lexstr(i))) 86530 if (gettok ^= LETTER & gettok ^= DIGIT) 86540 break 86550 } 86560 if (i >= toksiz-1) 86570 call synerr("token too long.") 86580 if (i > 1) { # some alpha seen 86590 call putbak(lexstr(i)) # went one too far 86600 lexstr(i) = EOS 86610 gettok = ALPHA 86620 } 86630 else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) { 86640 for (i = 2; ngetc(lexstr(i)) ^= lexstr(1); i = i + 1) 86650 if (lexstr(i) == NEWLINE | i >= toksiz-1) { 86660 call synerr("missing quote.") 86670 lexstr(i) = lexstr(1) 86680 call putbak(NEWLINE) 86690 break 86700 } 86710 } 86720 else if (lexstr(1) == SHARP) { # strip comments 86730 while (ngetc(lexstr(1)) ^= NEWLINE) 86740 ; 86750 gettok = NEWLINE 86760 } 86770 lexstr(i+1) = EOS 86780 if (lexstr(1) == NEWLINE) 86790 linect = linect + 1 86800 return 86810 end 86820 # ifcode - generate initial code for if 86830 subroutine ifcode(lab) 86840 integer labgen 86850 integer lab 86860 86870 lab = labgen(2) 86880 call ifgo(lab) 86890 return 86900 end 86910 # ifgo - generate "if(.not.(...))goto lab" 86920 subroutine ifgo(lab) 86930 integer lab 86940 # string ifnot "if(.not." 86950 integer ifnot(9) 86960 data ifnot(1) /LETI/ 86970 data ifnot(2) /LETF/ 86980 data ifnot(3) /LPAREN/ 86990 data ifnot(4) /PERIOD/ 87000 data ifnot(5) /LETN/ 87010 data ifnot(6) /LETO/ 87020 data ifnot(7) /LETT/ 87030 data ifnot(8) /PERIOD/ 87040 data ifnot(9) /EOS/ 87050 87060 call outtab # get to column 7 87070 call outstr(ifnot) # " if(.not. " 87080 call balpar # collect and output condition 87090 call outch(RPAREN) # " ) " 87100 call outgo(lab) # " goto lab " 87110 return 87120 end 87130 # initkw - initialize keyword tables 87140 subroutine initkw 87150 87160 integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5) 87170 integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2) 87180 87190 data sdo(1),sdo(2),sdo(3) /LETD,LETO,EOS/ 87200 data vdo(1),vdo(2) /LEXDO,EOS/ 87210 87220 data sif(1),sif(2),sif(3) /LETI,LETF,EOS/ 87230 data vif(1),vif(2) /LEXIF,EOS/ 87240 87250 data selse(1),selse(2),selse(3),selse(4),selse(5) /LETE, 87260 LETL,LETS,LETE,EOS/ 87270 data velse(1),velse(2) /LEXELSE,EOS/ 87280 87290 data swhile(1),swhile(2),swhile(3),swhile(4),swhile(5), 87300 swhile(6) /LETW,LETH,LETI,LETL,LETE,EOS/ 87310 data vwhile(1),vwhile(2) /LEXWHILE,EOS/ 87320 87330 data sbreak(1),sbreak(2),sbreak(3),sbreak(4),sbreak(5), 87340 sbreak(6) /LETB,LETR,LETE,LETA,LETK,EOS/ 87350 data vbreak(1),vbreak(2) /LEXBREAK,EOS/ 87360 87370 data snext(1),snext(2),snext(3),snext(4),snext(5) /LETN, 87380 LETE,LETX,LETT,EOS/ 87390 data vnext(1),vnext(2) /LEXNEXT,EOS/ 87400 87410 call instal(sdo,vdo) 87420 call instal(sif,vif) 87430 call instal(selse,velse) 87440 call instal(swhile,vwhile) 87450 call instal(sbreak,vbreak) 87460 call instal(snext,vnext) 87470 87480 return 87490 end 87500 # labelc - output statement number 87510 subroutine labelc(lexstr) 87520 character lexstr(ARB) 87530 integer length 87540 87550 if (length(lexstr) == 5) # warn about 23xxx labels 87560 if (lexstr(1) == DIG2 & lexstr(2) == DIG3) 87570 call synerr("warning: possible label conflict.") 87580 call outstr(lexstr) 87590 call outtab 87600 return 87610 end 87620 # labgen - generate n consecutive labels, return first one 87630 integer function labgen(n) 87640 integer label, n 87650 data label /23000/ 87660 87670 labgen = label 87680 label = label + n 87690 return 87700 end 87710 # lex - return lexical type of token 87720 integer function lex(lexstr) 87730 character gettok 87740 character lexstr(MAXTOK) 87750 integer alldig, lookup 87760 integer ltype(2) 87770 87780 while (gettok(lexstr, MAXTOK) == NEWLINE) 87790 ; 87800 lex = lexstr(1) 87810 if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE) 87820 return 87830 if (alldig(lexstr) == YES) 87840 lex = LEXDIGITS 87850 else if (lookup(lexstr, ltype) == YES) 87860 lex = ltype(1) 87870 else 87880 lex = LEXOTHER 87890 return 87900 end 87910 # lookup - locate name, extract definition from table 87920 integer function lookup(name, defn) 87930 character defn(MAXDEF), name(MAXTOK) 87940 integer i, j, k 87950 include clook 87960 87970 for (i = lastp; i > 0; i = i - 1) { 87980 j = namptr(i) 87990 for (k = 1; name(k) == table(j) & name(k) ^= EOS; k = k + 1) 88000 j = j + 1 88010 if (name(k) == table(j)) { # got one 88020 call scopy(table, j+1, defn, 1) 88030 lookup = YES 88040 return 88050 } 88060 } 88070 lookup = NO 88080 return 88090 end 88100 88110 # instal - add name and definition to table 88120 subroutine instal(name, defn) 88130 character defn(MAXTOK), name(MAXDEF) 88140 integer length 88150 integer dlen, nlen 88160 include clook 88170 88180 nlen = length(name) + 1 88190 dlen = length(defn) + 1 88200 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { 88210 call putlin(name, ERROUT) 88220 call remark(": too many definitions.") 88230 } 88240 lastp = lastp + 1 88250 namptr(lastp) = lastt + 1 88260 call scopy(name, 1, table, lastt + 1) 88270 call scopy(defn, 1, table, lastt + nlen + 1) 88280 lastt = lastt + nlen + dlen 88290 return 88300 end 88310 88320 88330 #block data 88340 block data 88350 include clook 88360 88370 data lastp /0/ 88380 data lastt /0/ 88390 88400 end 88410 # ngetc - get a (possibly pushed back) character 88420 character function ngetc(c) 88430 character getc 88440 character c 88450 include cdefio 88460 88470 if (bp > 0) 88480 c = buf(bp) 88490 else { 88500 bp = 1 88510 buf(bp) = getc(c) 88520 } 88530 if (c ^= EOF) 88540 bp = bp - 1 88550 ngetc = c 88560 return 88570 end 88580 # otherc - output ordinary Fortran statement 88590 subroutine otherc(lexstr) 88600 character lexstr(ARB) 88610 88620 call outtab 88630 call outstr(lexstr) 88640 call eatup 88650 call outdon 88660 return 88670 end 88680 # outch - put one character into output buffer 88690 subroutine outch(c) 88700 character c 88710 integer i 88720 include coutln 88730 88740 if (outp >= 72) { # continuation card 88750 call outdon 88760 for (i = 1; i < 6; i = i + 1) 88770 outbuf(i) = BLANK 88780 outbuf(6) = STAR 88790 outp = 6 88800 } 88810 outp = outp + 1 88820 outbuf(outp) = c 88830 return 88840 end 88850 # outcon - output "n continue" 88860 subroutine outcon(n) 88870 integer n 88880 # string contin "continue" 88890 integer contin(9) 88900 data contin(1) /LETC/ 88910 data contin(2) /LETO/ 88920 data contin(3) /LETN/ 88930 data contin(4) /LETT/ 88940 data contin(5) /LETI/ 88950 data contin(6) /LETN/ 88960 data contin(7) /LETU/ 88970 data contin(8) /LETE/ 88980 data contin(9) /EOS/ 88990 89000 if (n > 0) 89010 call outnum(n) 89020 call outtab 89030 call outstr(contin) 89040 call outdon 89050 return 89060 end 89070 # outdon - finish off an output line 89080 subroutine outdon 89090 include coutln 89100 89110 outbuf(outp+1) = NEWLINE 89120 outbuf(outp+2) = EOS 89130 call putlin(outbuf, STDOUT) 89140 outp = 0 89150 return 89160 end 89170 # outgo - output "goto n" 89180 subroutine outgo(n) 89190 integer n 89200 # string goto "goto" 89210 integer goto(6) 89220 data goto(1) /LETG/ 89230 data goto(2) /LETO/ 89240 data goto(3) /LETT/ 89250 data goto(4) /LETO/ 89260 data goto(5) /BLANK/ 89270 data goto(6) /EOS/ 89280 89290 call outtab 89300 call outstr(goto) 89310 call outnum(n) 89320 call outdon 89330 return 89340 end 89350 define(MAXCHARS,10) 89360 # outnum - output decimal number 89370 subroutine outnum(n) 89380 character chars(MAXCHARS) 89390 integer itoc 89400 integer i, len, n 89410 89420 len = itoc(n, chars, MAXCHARS) 89430 for (i = 1; i <= len; i = i + 1) 89440 call outch(chars(i)) 89450 return 89460 end 89470 # outstr - output string 89480 subroutine outstr(str) 89490 character c, str(ARB) 89500 integer i, j 89510 89520 for (i = 1; str(i) ^= EOS; i = i + 1) { 89530 c = str(i) 89540 if (c ^= SQUOTE & c ^= DQUOTE) 89550 call outch(c) 89560 else { 89570 i = i + 1 89580 for (j = i; str(j) ^= c; j = j + 1) # find end 89590 ; 89600 call outnum(j-i) 89610 call outch(LETH) 89620 for ( ; i < j; i = i + 1) 89630 call outch(str(i)) 89640 } 89650 } 89660 return 89670 end 89680 # outtab - get past column 6 89690 subroutine outtab 89700 include coutln 89710 89720 while (outp < 6) 89730 call outch(BLANK) 89740 return 89750 end 89760 # parse - parse Ratfor source program 89770 subroutine parse 89780 character lexstr(MAXTOK) 89790 integer lex 89800 integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token 89810 89820 call initkw # install keywords in table 89830 sp = 1 89840 lextyp(1) = EOF 89850 for (token = lex(lexstr); token ^= EOF; token = lex(lexstr)) { 89860 if (token == LEXIF) 89870 call ifcode(lab) 89880 else if (token == LEXDO) 89890 call docode(lab) 89900 else if (token == LEXWHILE) 89910 call whilec(lab) 89920 else if (token == LEXDIGITS) 89930 call labelc(lexstr) 89940 else if (token == LEXELSE) { 89950 if (lextyp(sp) == LEXIF) 89960 call elseif(labval(sp)) 89970 else 89980 call synerr("illegal else.") 89990 } 90000 if (token==LEXIF | token==LEXELSE | token==LEXWHILE 90010 | token==LEXDO | token==LEXDIGITS | token==LBRACE) { 90020 sp = sp + 1 # beginning of statement 90030 if (sp > MAXSTACK) 90040 call error("stack overflow in parser.") 90050 lextyp(sp) = token # stack type and value 90060 labval(sp) = lab 90070 } 90080 else { # end of statement - prepare to unstack 90090 if (token == RBRACE) { 90100 if (lextyp(sp) == LBRACE) 90110 sp = sp - 1 90120 else 90130 call synerr("illegal right brace.") 90140 } 90150 else if (token == LEXOTHER) 90160 call otherc(lexstr) 90170 else if (token == LEXBREAK | token == LEXNEXT) 90180 call brknxt(sp, lextyp, labval, token) 90190 token = lex(lexstr) # peek at next token 90200 call pbstr(lexstr) 90210 call unstak(sp, lextyp, labval, token) 90220 } 90230 } 90240 if (sp ^= 1) 90250 call synerr("unexpected EOF.") 90260 return 90270 end 90280 # pbstr - push string back onto input 90290 subroutine pbstr(in) 90300 character in(MAXLINE) 90310 integer length 90320 integer i 90330 90340 for (i = length(in); i > 0; i = i - 1) 90350 call putbak(in(i)) 90360 return 90370 end 90380 90390 # putbak - push character back onto input 90400 subroutine putbak(c) 90410 character c 90420 include cdefio 90430 90440 bp = bp + 1 90450 if (bp > BUFSIZE) 90460 call error("too many characters pushed back.") 90470 buf(bp) = c 90480 return 90490 end 90500 # ratfor - main program for Ratfor 90510 call parse 90520 stop 90530 end 90540 # synerr - report Ratfor syntax error 90550 subroutine synerr(msg) 90560 character lc(MAXLINE), msg(MAXLINE) 90570 integer itoc 90580 integer junk 90590 include cline 90600 90610 call remark("error at line .") 90620 junk = itoc(linect, lc, MAXLINE) 90630 call putlin(lc, ERROUT) 90640 call putch(COLON, ERROUT) 90650 call remark(msg) 90660 return 90670 end 90680 # unstak - unstack at end of statement 90690 subroutine unstak(sp, lextyp, labval, token) 90700 integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token 90710 90720 for ( ; sp > 1; sp = sp - 1) { 90730 if (lextyp(sp) == LBRACE) 90740 break 90750 if (lextyp(sp) == LEXIF & token == LEXELSE) 90760 break 90770 if (lextyp(sp) == LEXIF) 90780 call outcon(labval(sp)) 90790 else if (lextyp(sp) == LEXELSE) { 90800 if (sp > 2) 90810 sp = sp - 1 90820 call outcon(labval(sp)+1) 90830 } 90840 else if (lextyp(sp) == LEXDO) 90850 call dostat(labval(sp)) 90860 else if (lextyp(sp) == LEXWHILE) 90870 call whiles(labval(sp)) 90880 } 90890 return 90900 end 90910 # whilec - generate code for beginning of while 90920 subroutine whilec(lab) 90930 integer labgen 90940 integer lab 90950 90960 call outcon(0) # unlabeled continue, in case there was a label 90970 lab = labgen(2) 90980 call outnum(lab) 90990 call ifgo(lab+1) 91000 return 91010 end 91020 # whiles - generate code for end of while 91030 subroutine whiles(lab) 91040 integer lab 91050 91060 call outgo(lab) 91070 call outcon(lab+1) 91080 return 91090 end 91100 ========== end of information ========== 91110