========== start of info ==========
Tue Mar  2 10:33:30 EST 1976
         0       0      00
         1       1      01
         2       2      02
         3       3      03
         4       4      37
         5       5      2D
         6       6      2E
         7       7      2F
bs       8      10      16
tab      9      11      05
        10      12      25
        11      13      0B
        12      14      0C
        13      15      0D
        14      16      0E
        15      17      0F
        16      20      10
        17      21      11
        18      22      12
        19      23      13
        20      24      3C
        21      25      3D
        22      26      32
        23      27      26
        24      30      18
        25      31      19
        26      32      3F
        27      33      27
        28      34      1C
        29      35      1D
        30      36      1E
        31      37      1F
blnk    32      40      40
 !      33      41      5A
 "      34      42      7F
 #      35      43      7B
 $      36      44      5B
 %      37      45      6C
 &      38      46      50
 '      39      47      7D
 (      40      50      4D
 )      41      51      5D
 *      42      52      5C
 +      43      53      4E
 ,      44      54      6B
 -      45      55      60
 .      46      56      4B
 /      47      57      61
 0      48      60      F0
 1      49      61      F1
 2      50      62      F2
 3      51      63      F3
 4      52      64      F4
 5      53      65      F5
 6      54      66      F6
 7      55      67      F7
 8      56      70      F8
 9      57      71      F9
 :      58      72      7A
 ;      59      73      5E
 <      60      74      4C
 =      61      75      7E
 >      62      76      6E
 ?      63      77      6F
 @      64     100      7C
 A      65     101      C1
 B      66     102      C2
 C      67     103      C3
 D      68     104      C4
 E      69     105      C5
 F      70     106      C6
 G      71     107      C7
 H      72     110      C8
 I      73     111      C9
 J      74     112      D1
 K      75     113      D2
 L      76     114      D3
 M      77     115      D4
 N      78     116      D5
 O      79     117      D6
 P      80     120      D7
 Q      81     121      D8
 R      82     122      D9
 S      83     123      E2
 T      84     124      E3
 U      85     125      E4
 V      86     126      E5
 W      87     127      E6
 X      88     130      E7
 Y      89     131      E8
 Z      90     132      E9
 [      91     133      AD
 \      92     134      E0
 ]      93     135      BD
 ~      94     136      5F
 _      95     137      6D
 `      96     140      79
 a      97     141      81
 b      98     142      82
 c      99     143      83
 d     100     144      84
 e     101     145      85
 f     102     146      86
 g     103     147      87
 h     104     150      88
 i     105     151      89
 j     106     152      91
 k     107     153      92
 l     108     154      93
 m     109     155      94
 n     110     156      95
 o     111     157      96
 p     112     160      97
 q     113     161      98
 r     114     162      99
 s     115     163      A2
 t     116     164      A3
 u     117     165      A4
 v     118     166      A5
 w     119     167      A6
 x     120     170      A7
 y     121     171      A8
 z     122     172      A9
 {     123     173      C0
 |     124     174      4F
 $@$     125     175      D0
 ^     126     176      A1
      127     177      07
not     94     136      5F
========== ratfor in fortran for bootstrap ==========
C
C BLOCK DATA - INITIALIZE GLOBAL VARIABLES
C
       BLOCK DATA
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       DATA OUTP /0/
       DATA LEVEL /1/
       DATA LINECT(1) /1/
       DATA INFILE(1) /5/
       DATA BP /0/
       DATA FORDEP /0/
       DATA LASTP /0/
       DATA LASTT /0/
       DATA SDO(1), SDO(2), SDO(3) /100, 111, 10002/
       DATA VDO(1), VDO(2) /10266, 10002/
       DATA SIF(1), SIF(2), SIF(3) /105, 102, 10002/
       DATA VIF(1), VIF(2) /10261, 10002/
       DATA SELSE(1), SELSE(2), SELSE(3), SELSE(4), SELSE(5) /101,  108,
     * 115, 101, 10002/
       DATA VELSE(1), VELSE(2) /10262, 10002/
       DATA SWHILE(1), SWHILE(2), SWHILE(3), SWHILE(4), SWHILE(5), SWHIL
     *E(6) /119, 104, 105, 108, 101, 10002/
       DATA VWHILE(1), VWHILE(2) /10263, 10002/
       DATA SBREAK(1), SBREAK(2), SBREAK(3), SBREAK(4), SBREAK(5), SBREA
     *K(6) /98, 114, 101, 97, 107, 10002/
       DATA VBREAK(1), VBREAK(2) /10264, 10002/
       DATA SNEXT(1), SNEXT(2), SNEXT(3), SNEXT(4), SNEXT(5) /110,  101,
     * 120, 116, 10002/
       DATA VNEXT(1), VNEXT(2) /10265, 10002/
       DATA SFOR(1), SFOR(2), SFOR(3), SFOR(4) /102,  111, 114, 10002/
       DATA VFOR(1), VFOR(2) /10268, 10002/
       DATA SREPT(1), SREPT(2), SREPT(3), SREPT(4), SREPT(5), SREPT(6),
     * SREPT(7) /114, 101, 112, 101, 97, 116, 10002/
       DATA VREPT(1), VREPT(2) /10269, 10002/
       DATA SUNTIL(1), SUNTIL(2), SUNTIL(3), SUNTIL(4), SUNTIL(5), SUNTI
     *L(6) /117, 110, 116, 105, 108, 10002/
       DATA VUNTIL(1), VUNTIL(2) /10270, 10002/
       DATA EXTBLK /1H /, INTBLK /32/
       DATA EXTDIG(1) /1H0/, INTDIG(1) /48/
       DATA EXTDIG(2) /1H1/, INTDIG(2) /49/
       DATA EXTDIG(3) /1H2/, INTDIG(3) /50/
       DATA EXTDIG(4) /1H3/, INTDIG(4) /51/
       DATA EXTDIG(5) /1H4/, INTDIG(5) /52/
       DATA EXTDIG(6) /1H5/, INTDIG(6) /53/
       DATA EXTDIG(7) /1H6/, INTDIG(7) /54/
       DATA EXTDIG(8) /1H7/, INTDIG(8) /55/
       DATA EXTDIG(9) /1H8/, INTDIG(9) /56/
       DATA EXTDIG(10) /1H9/, INTDIG(10) /57/
       DATA EXTLET(1) /1HA/, INTLET(1) /97/
       DATA EXTLET(2) /1HB/, INTLET(2) /98/
       DATA EXTLET(3) /1HC/, INTLET(3) /99/
       DATA EXTLET(4) /1HD/, INTLET(4) /100/
       DATA EXTLET(5) /1HE/, INTLET(5) /101/
       DATA EXTLET(6) /1HF/, INTLET(6) /102/
       DATA EXTLET(7) /1HG/, INTLET(7) /103/
       DATA EXTLET(8) /1HH/, INTLET(8) /104/
       DATA EXTLET(9) /1HI/, INTLET(9) /105/
       DATA EXTLET(10) /1HJ/, INTLET(10) /106/
       DATA EXTLET(11) /1HK/, INTLET(11) /107/
       DATA EXTLET(12) /1HL/, INTLET(12) /108/
       DATA EXTLET(13) /1HM/, INTLET(13) /109/
       DATA EXTLET(14) /1HN/, INTLET(14) /110/
       DATA EXTLET(15) /1HO/, INTLET(15) /111/
       DATA EXTLET(16) /1HP/, INTLET(16) /112/
       DATA EXTLET(17) /1HQ/, INTLET(17) /113/
       DATA EXTLET(18) /1HR/, INTLET(18) /114/
       DATA EXTLET(19) /1HS/, INTLET(19) /115/
       DATA EXTLET(20) /1HT/, INTLET(20) /116/
       DATA EXTLET(21) /1HU/, INTLET(21) /117/
       DATA EXTLET(22) /1HV/, INTLET(22) /118/
       DATA EXTLET(23) /1HW/, INTLET(23) /119/
       DATA EXTLET(24) /1HX/, INTLET(24) /120/
       DATA EXTLET(25) /1HY/, INTLET(25) /121/
       DATA EXTLET(26) /1HZ/, INTLET(26) /122/
       DATA EXTBIG(1) /1HA/, INTBIG(1) /65/
       DATA EXTBIG(2) /1HB/, INTBIG(2) /66/
       DATA EXTBIG(3) /1HC/, INTBIG(3) /67/
       DATA EXTBIG(4) /1HD/, INTBIG(4) /68/
       DATA EXTBIG(5) /1HE/, INTBIG(5) /69/
       DATA EXTBIG(6) /1HF/, INTBIG(6) /70/
       DATA EXTBIG(7) /1HG/, INTBIG(7) /71/
       DATA EXTBIG(8) /1HH/, INTBIG(8) /72/
       DATA EXTBIG(9) /1HI/, INTBIG(9) /73/
       DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/
       DATA EXTBIG(11) /1HK/, INTBIG(11) /75/
       DATA EXTBIG(12) /1HL/, INTBIG(12) /76/
       DATA EXTBIG(13) /1HM/, INTBIG(13) /77/
       DATA EXTBIG(14) /1HN/, INTBIG(14) /78/
       DATA EXTBIG(15) /1HO/, INTBIG(15) /79/
       DATA EXTBIG(16) /1HP/, INTBIG(16) /80/
       DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/
       DATA EXTBIG(18) /1HR/, INTBIG(18) /82/
       DATA EXTBIG(19) /1HS/, INTBIG(19) /83/
       DATA EXTBIG(20) /1HT/, INTBIG(20) /84/
       DATA EXTBIG(21) /1HU/, INTBIG(21) /85/
       DATA EXTBIG(22) /1HV/, INTBIG(22) /86/
       DATA EXTBIG(23) /1HW/, INTBIG(23) /87/
       DATA EXTBIG(24) /1HX/, INTBIG(24) /88/
       DATA EXTBIG(25) /1HY/, INTBIG(25) /89/
       DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/
       DATA EXTCHR(1) /1H!/, INTCHR(1) /33/
       DATA EXTCHR(2) /1H"/, INTCHR(2) /34/
       DATA EXTCHR(3) /1H#/, INTCHR(3) /35/
       DATA EXTCHR(4) /1H$/, INTCHR(4) /36/
       DATA EXTCHR(5) /1H%/, INTCHR(5) /37/
       DATA EXTCHR(6) /1H&/, INTCHR(6) /38/
       DATA EXTCHR(7) /1H'/, INTCHR(7) /39/
       DATA EXTCHR(8) /1H(/, INTCHR(8) /40/
       DATA EXTCHR(9) /1H)/, INTCHR(9) /41/
       DATA EXTCHR(10) /1H*/, INTCHR(10) /42/
       DATA EXTCHR(11) /1H+/, INTCHR(11) /43/
       DATA EXTCHR(12) /1H,/, INTCHR(12) /44/
       DATA EXTCHR(13) /1H-/, INTCHR(13) /45/
       DATA EXTCHR(14) /1H./, INTCHR(14) /46/
       DATA EXTCHR(15) /1H//, INTCHR(15) /47/
       DATA EXTCHR(16) /1H:/, INTCHR(16) /58/
       DATA EXTCHR(17) /1H;/, INTCHR(17) /59/
       DATA EXTCHR(18) /1H</, INTCHR(18) /60/
       DATA EXTCHR(19) /1H=/, INTCHR(19) /61/
       DATA EXTCHR(20) /1H>/, INTCHR(20) /62/
       DATA EXTCHR(21) /1H?/, INTCHR(21) /63/
       DATA EXTCHR(22) /1H@/, INTCHR(22) /64/
       DATA EXTCHR(23) /1H[/, INTCHR(23) /91/
       DATA EXTCHR(24) /1H\/, INTCHR(24) /92/
       DATA EXTCHR(25) /1H]/, INTCHR(25) /93/
       DATA EXTCHR(26) /1H_/, INTCHR(26) /95/
       DATA EXTCHR(27) /1H{/, INTCHR(27) /123/
       DATA EXTCHR(28) /1H|/, INTCHR(28) /124/
       DATA EXTCHR(29) /1H$@$/, INTCHR(29) /125/
       DATA EXTCHR(30) /1H/, INTCHR(30) /8/
       DATA EXTCHR(31) /1H	/, INTCHR(31) /9/
       DATA EXTCHR(32) /1H~/, INTCHR(32) /33/
       DATA EXTCHR(33) /1H^/, INTCHR(33) /33/
       END
C
C RATFOR - MAIN PROGRAM FOR RATFOR
C
       CALL PARSE
       STOP
       END
C
C ALLDIG - RETURN YES IF STR IS ALL DIGITS
C
       INTEGER FUNCTION ALLDIG(STR)
       INTEGER TYPE
       INTEGER STR(100)
       INTEGER I
       ALLDIG = 0
       IF(.NOT.(STR(1) .EQ. 10002))  GOTO 23000
       RETURN
23000  CONTINUE
       CONTINUE
       I = 1
23002  IF(.NOT.( STR(I) .NE. 10002)) GOTO 23004
       IF(.NOT.(TYPE(STR(I)) .NE. 2))   GOTO 23005
       RETURN
23005  CONTINUE
23003   I = I + 1
       GOTO 23002
23004  CONTINUE
       ALLDIG = 1
       RETURN
       END
C
C BALPAR - COPY BALANCED PAREN STRING
C
       SUBROUTINE BALPAR
       INTEGER GETTOK
       INTEGER T, TOKEN(200)
       INTEGER NLPAR
       IF(.NOT.(GETTOK(TOKEN, 200) .NE. 40))  GOTO 23007
       CALL SYNERR(19HMISSING LEFT PAREN.)
       RETURN
23007  CONTINUE
       CALL OUTSTR(TOKEN)
       NLPAR = 1
       CONTINUE
23009  CONTINUE
       T = GETTOK(TOKEN, 200)
       IF(.NOT.(T.EQ.59 .OR. T.EQ.123 .OR. T.EQ.125 .OR. T.EQ.10003)) GO
     *TO 23012
       CALL PBSTR(TOKEN)
       GOTO 23011
23012  CONTINUE
       IF(.NOT.(T .EQ. 10)) GOTO 23014
       TOKEN(1) = 10002
       GOTO 23015
23014  CONTINUE
       IF(.NOT.(T .EQ. 40)) GOTO 23016
       NLPAR = NLPAR + 1
       GOTO 23017
23016  CONTINUE
       IF(.NOT.(T .EQ. 41)) GOTO 23018
       NLPAR = NLPAR - 1
23018  CONTINUE
23017  CONTINUE
23015  CONTINUE
       CALL OUTSTR(TOKEN)
23010  IF(.NOT.(NLPAR .LE. 0)) GOTO 23009
23011  CONTINUE
       IF(.NOT.(NLPAR .NE. 0)) GOTO 23020
       CALL SYNERR(33HMISSING PARENTHESIS IN CONDITION.)
23020  CONTINUE
       RETURN
       END
C
C BRKNXT - GENERATE CODE FOR BREAK AND NEXT
C
       SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN)
       INTEGER I, LABVAL(100), LEXTYP(100), SP, TOKEN
       CONTINUE
       I = SP
23022  IF(.NOT.( I .GT. 0)) GOTO 23024
       IF(.NOT.(LEXTYP(I) .EQ. 10263 .OR. LEXTYP(I) .EQ. 10266       .OR
     *. LEXTYP(I) .EQ. 10268 .OR. LEXTYP(I) .EQ. 10269))  GOTO 23025
       IF(.NOT.(TOKEN .EQ. 10264))   GOTO 23027
       CALL OUTGO(LABVAL(I)+1)
       GOTO 23028
23027  CONTINUE
       CALL OUTGO(LABVAL(I))
23028  CONTINUE
       RETURN
23025  CONTINUE
23023   I = I - 1
       GOTO 23022
23024  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10264))   GOTO 23029
       CALL SYNERR(14HILLEGAL BREAK.)
       GOTO 23030
23029  CONTINUE
       CALL SYNERR(13HILLEGAL NEXT.)
23030  CONTINUE
       RETURN
       END
C
C CLOSE - EXCEEDINGLY TEMPORARY VERSION FOR GETTOK
C
       SUBROUTINE CLOSE(FD)
       INTEGER FD
       REWIND FD
       RETURN
       END
C
C CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I
C
       INTEGER FUNCTION CTOI(IN, I)
       INTEGER IN(100)
       INTEGER INDEX
       INTEGER D, I
       INTEGER DIGITS(11)
       DATA DIGITS(1) /48/
       DATA DIGITS(2) /49/
       DATA DIGITS(3) /50/
       DATA DIGITS(4) /51/
       DATA DIGITS(5) /52/
       DATA DIGITS(6) /53/
       DATA DIGITS(7) /54/
       DATA DIGITS(8) /55/
       DATA DIGITS(9) /56/
       DATA DIGITS(10) /57/
       DATA DIGITS(11) /10002/
       CONTINUE
23031  IF(.NOT.(IN(I) .EQ. 32 .OR. IN(I) .EQ. 9))   GOTO 23032
       I = I + 1
       GOTO 23031
23032  CONTINUE
       CONTINUE
       CTOI = 0
23033  IF(.NOT.( IN(I) .NE. 10002))  GOTO 23035
       D = INDEX(DIGITS, IN(I))
       IF(.NOT.(D .EQ. 0))  GOTO 23036
       GOTO 23035
23036  CONTINUE
       CTOI = 10 * CTOI + D - 1
23034   I = I + 1
       GOTO 23033
23035  CONTINUE
       RETURN
       END
C
C DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS
C
       INTEGER FUNCTION DEFTOK(TOKEN, TOKSIZ, FD)
       INTEGER GTOK
       INTEGER FD, TOKSIZ
       INTEGER DEFN(200), T, TOKEN(TOKSIZ)
       INTEGER LOOKUP
       CONTINUE
       T=GTOK(TOKEN, TOKSIZ, FD)
23038  IF(.NOT.( T.NE.10003))  GOTO 23040
       IF(.NOT.(T .NE. 10100)) GOTO 23041
       GOTO 23040
23041  CONTINUE
       IF(.NOT.(LOOKUP(TOKEN, DEFN) .EQ. 0))  GOTO 23043
       GOTO 23040
23043  CONTINUE
       IF(.NOT.(DEFN(1) .EQ. 10010)) GOTO 23045
       CALL GETDEF(TOKEN, TOKSIZ, DEFN, 200, FD)
       CALL INSTAL(TOKEN, DEFN)
       GOTO 23046
23045  CONTINUE
       CALL PBSTR(DEFN)
23046  CONTINUE
23039   T=GTOK(TOKEN, TOKSIZ, FD)
       GOTO 23038
23040  CONTINUE
       DEFTOK = T
       IF(.NOT.(DEFTOK .EQ. 10100))  GOTO 23047
       CALL FOLD(TOKEN)
23047  CONTINUE
       RETURN
       END
C
C FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE
C
       SUBROUTINE FOLD(TOKEN)
       INTEGER TOKEN(100)
       INTEGER I
       CONTINUE
       I = 1
23049  IF(.NOT.( TOKEN(I) .NE. 10002))  GOTO 23051
       IF(.NOT.(TOKEN(I) .GE. 65 .AND. TOKEN(I) .LE. 90)) GOTO 23052
       TOKEN(I) = TOKEN(I) - 65 + 97
23052  CONTINUE
23050   I = I + 1
       GOTO 23049
23051  CONTINUE
       RETURN
       END
C
C DOCODE - GENERATE CODE FOR BEGINNING OF DO
C
       SUBROUTINE DOCODE(LAB)
       INTEGER LABGEN
       INTEGER LAB
       INTEGER DOSTR(4)
       DATA DOSTR(1), DOSTR(2), DOSTR(3), DOSTR(4)/100, 111, 32, 10002/
       CALL OUTTAB
       CALL OUTSTR(DOSTR)
       LAB = LABGEN(2)
       CALL OUTNUM(LAB)
       CALL EATUP
       CALL OUTDON
       RETURN
       END
C
C DOSTAT - GENERATE CODE FOR END OF DO STATEMENT
C
       SUBROUTINE DOSTAT(LAB)
       INTEGER LAB
       CALL OUTCON(LAB)
       CALL OUTCON(LAB+1)
       RETURN
       END
C
C EATUP - PROCESS REST OF STATEMENT; INTERPRET CONTINUATIONS
C
       SUBROUTINE EATUP
       INTEGER GETTOK
       INTEGER PTOKEN(200), T, TOKEN(200)
       INTEGER NLPAR
       NLPAR = 0
       CONTINUE
23054  CONTINUE
       T = GETTOK(TOKEN, 200)
       IF(.NOT.(T .EQ. 59 .OR. T .EQ. 10)) GOTO 23057
       GOTO 23056
23057  CONTINUE
       IF(.NOT.(T .EQ. 125))   GOTO 23059
       CALL PBSTR(TOKEN)
       GOTO 23056
23059  CONTINUE
       IF(.NOT.(T .EQ. 123 .OR. T .EQ. 10003))   GOTO 23061
       CALL SYNERR(24HUNEXPECTED BRACE OR EOF.)
       CALL PBSTR(TOKEN)
       GOTO 23056
23061  CONTINUE
       IF(.NOT.(T .EQ. 44 .OR. T .EQ. 95)) GOTO 23063
       IF(.NOT.(GETTOK(PTOKEN, 200) .NE. 10)) GOTO 23065
       CALL PBSTR(PTOKEN)
23065  CONTINUE
       IF(.NOT.(T .EQ. 95)) GOTO 23067
       TOKEN(1) = 10002
23067  CONTINUE
       GOTO 23064
23063  CONTINUE
       IF(.NOT.(T .EQ. 40)) GOTO 23069
       NLPAR = NLPAR + 1
       GOTO 23070
23069  CONTINUE
       IF(.NOT.(T .EQ. 41)) GOTO 23071
       NLPAR = NLPAR - 1
23071  CONTINUE
23070  CONTINUE
23064  CONTINUE
       CALL OUTSTR(TOKEN)
23055  IF(.NOT.(NLPAR .LT. 0)) GOTO 23054
23056  CONTINUE
       IF(.NOT.(NLPAR .NE. 0)) GOTO 23073
       CALL SYNERR(23HUNBALANCED PARENTHESES.)
23073  CONTINUE
       RETURN
       END
C
C ELSEIF - GENERATE CODE FOR END OF IF BEFORE ELSE
C
       SUBROUTINE ELSEIF(LAB)
       INTEGER LAB
       CALL OUTGO(LAB+1)
       CALL OUTCON(LAB)
       RETURN
       END
C
C EQUAL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, NO IF NOT
C
       INTEGER FUNCTION EQUAL(STR1, STR2)
       INTEGER STR1(100), STR2(100)
       INTEGER I
       CONTINUE
       I = 1
23075  IF(.NOT.( STR1(I) .EQ. STR2(I))) GOTO 23077
       IF(.NOT.(STR1(I) .EQ. 10002)) GOTO 23078
       EQUAL = 1
       RETURN
23078  CONTINUE
23076   I = I + 1
       GOTO 23075
23077  CONTINUE
       EQUAL = 0
       RETURN
       END
C
C ERROR - PRINT FATAL ERROR MESSAGE, THEN DIE
C
       SUBROUTINE ERROR(BUF)
       INTEGER BUF(100)
       CALL REMARK(BUF)
       STOP
       END
C
C FORCOD - BEGINNING OF FOR STATEMENT
C
       SUBROUTINE FORCOD(LAB)
       INTEGER GETTOK
       INTEGER T, TOKEN(200)
       INTEGER LENGTH, LABGEN
       INTEGER I, J, LAB, NLPAR
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       INTEGER IFNOT(9)
       DATA IFNOT(1) /105/
       DATA IFNOT(2) /102/
       DATA IFNOT(3) /40/
       DATA IFNOT(4) /46/
       DATA IFNOT(5) /110/
       DATA IFNOT(6) /111/
       DATA IFNOT(7) /116/
       DATA IFNOT(8) /46/
       DATA IFNOT(9) /10002/
       LAB = LABGEN(3)
       CALL OUTCON(0)
       IF(.NOT.(GETTOK(TOKEN, 200) .NE. 40))  GOTO 23080
       CALL SYNERR(19HMISSING LEFT PAREN.)
       RETURN
23080  CONTINUE
       IF(.NOT.(GETTOK(TOKEN, 200) .NE. 59))  GOTO 23082
       CALL PBSTR(TOKEN)
       CALL OUTTAB
       CALL EATUP
       CALL OUTDON
23082  CONTINUE
       IF(.NOT.(GETTOK(TOKEN, 200) .EQ. 59))  GOTO 23084
       CALL OUTCON(LAB)
       GOTO 23085
23084  CONTINUE
       CALL PBSTR(TOKEN)
       CALL OUTNUM(LAB)
       CALL OUTTAB
       CALL OUTSTR(IFNOT)
       CALL OUTCH(40)
       NLPAR = 0
       CONTINUE
23086  IF(.NOT.(NLPAR .GE. 0)) GOTO 23087
       T = GETTOK(TOKEN, 200)
       IF(.NOT.(T .EQ. 59)) GOTO 23088
       GOTO 23087
23088  CONTINUE
       IF(.NOT.(T .EQ. 40)) GOTO 23090
       NLPAR = NLPAR + 1
       GOTO 23091
23090  CONTINUE
       IF(.NOT.(T .EQ. 41)) GOTO 23092
       NLPAR = NLPAR - 1
23092  CONTINUE
23091  CONTINUE
       IF(.NOT.(T .NE. 10 .AND. T .NE. 95))   GOTO 23094
       CALL OUTSTR(TOKEN)
23094  CONTINUE
       GOTO 23086
23087  CONTINUE
       CALL OUTCH(41)
       CALL OUTCH(41)
       CALL OUTGO(LAB+2)
       IF(.NOT.(NLPAR .LT. 0)) GOTO 23096
       CALL SYNERR(19HINVALID FOR CLAUSE.)
23096  CONTINUE
23085  CONTINUE
       FORDEP = FORDEP + 1
       J = 1
       CONTINUE
       I = 1
23098  IF(.NOT.( I .LT. FORDEP))  GOTO 23100
       J = J + LENGTH(FORSTK(J)) + 1
23099   I = I + 1
       GOTO 23098
23100  CONTINUE
       FORSTK(J) = 10002
       NLPAR = 0
       CONTINUE
23101  IF(.NOT.(NLPAR .GE. 0)) GOTO 23102
       T = GETTOK(TOKEN, 200)
       IF(.NOT.(T .EQ. 40)) GOTO 23103
       NLPAR = NLPAR + 1
       GOTO 23104
23103  CONTINUE
       IF(.NOT.(T .EQ. 41)) GOTO 23105
       NLPAR = NLPAR - 1
23105  CONTINUE
23104  CONTINUE
       IF(.NOT.(NLPAR .GE. 0 .AND. T .NE. 10 .AND. T .NE. 95))  GOTO 231
     *07
       CALL SCOPY(TOKEN, 1, FORSTK, J)
       J = J + LENGTH(TOKEN)
23107  CONTINUE
       GOTO 23101
23102  CONTINUE
       LAB = LAB + 1
       RETURN
       END
C
C FORS - PROCESS END OF FOR STATEMENT
C
       SUBROUTINE FORS(LAB)
       INTEGER LENGTH
       INTEGER I, J, LAB
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       CALL OUTNUM(LAB)
       J = 1
       CONTINUE
       I = 1
23109  IF(.NOT.( I .LT. FORDEP))  GOTO 23111
       J = J + LENGTH(FORSTK(J)) + 1
23110   I = I + 1
       GOTO 23109
23111  CONTINUE
       IF(.NOT.(LENGTH(FORSTK(J)) .GT. 0)) GOTO 23112
       CALL OUTTAB
       CALL OUTSTR(FORSTK(J))
       CALL OUTDON
23112  CONTINUE
       CALL OUTGO(LAB-1)
       CALL OUTCON(LAB+1)
       FORDEP = FORDEP - 1
       RETURN
       END
C
C GETCH - GET CHARACTERS FROM FILE
C
       INTEGER FUNCTION GETCH(C, F)
       INTEGER INMAP
       INTEGER BUF(81), C
       INTEGER F, I, LASTC
       DATA LASTC /81/, BUF(81) /10/
       IF(.NOT.(BUF(LASTC) .EQ. 10 .OR. LASTC .GE. 81))   GOTO 23114
       READ(F, 1, END=10) (BUF(I), I = 1, 80)
1         FORMAT(80 A1)
       CONTINUE
       I = 1
23116  IF(.NOT.( I .LE. 80))   GOTO 23118
       BUF(I) = INMAP(BUF(I))
23117   I = I + 1
       GOTO 23116
23118  CONTINUE
       CONTINUE
       I = 80
23119  IF(.NOT.( I .GT. 0)) GOTO 23121
       IF(.NOT.(BUF(I) .NE. 32))  GOTO 23122
       GOTO 23121
23122  CONTINUE
23120   I = I - 1
       GOTO 23119
23121  CONTINUE
       BUF(I+1) = 10
       LASTC = 0
23114  CONTINUE
       LASTC = LASTC + 1
       C = BUF(LASTC)
       GETCH = C
       RETURN
10        C = 10003
       GETCH = 10003
       RETURN
       END
C
C GETDEF (FOR NO ARGUMENTS) - GET NAME AND DEFINITION
C
       SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD)
       INTEGER GTOK, NGETCH
       INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ
       INTEGER C, DEFN(DEFSIZ), TOKEN(TOKSIZ)
       IF(.NOT.(NGETCH(C, FD) .NE. 40)) GOTO 23124
       CALL REMARK(19HMISSING LEFT PAREN.)
23124  CONTINUE
       IF(.NOT.(GTOK(TOKEN, TOKSIZ, FD) .NE. 10100))   GOTO 23126
       CALL REMARK(22HNON-ALPHANUMERIC NAME.)
       GOTO 23127
23126  CONTINUE
       IF(.NOT.(NGETCH(C, FD) .NE. 44)) GOTO 23128
       CALL REMARK(24HMISSING COMMA IN DEFINE.)
23128  CONTINUE
23127  CONTINUE
       NLPAR = 0
       CONTINUE
       I = 1
23130  IF(.NOT.( NLPAR .GE. 0))   GOTO 23132
       IF(.NOT.(I .GT. DEFSIZ))   GOTO 23133
       CALL ERROR(20HDEFINITION TOO LONG.)
       GOTO 23134
23133  CONTINUE
       IF(.NOT.(NGETCH(DEFN(I), FD) .EQ. 10003)) GOTO 23135
       CALL ERROR(20HMISSING RIGHT PAREN.)
       GOTO 23136
23135  CONTINUE
       IF(.NOT.(DEFN(I) .EQ. 40)) GOTO 23137
       NLPAR = NLPAR + 1
       GOTO 23138
23137  CONTINUE
       IF(.NOT.(DEFN(I) .EQ. 41)) GOTO 23139
       NLPAR = NLPAR - 1
23139  CONTINUE
23138  CONTINUE
23136  CONTINUE
23134  CONTINUE
23131   I = I + 1
       GOTO 23130
23132  CONTINUE
       DEFN(I-1) = 10002
       RETURN
       END
C
C GETTOK - GET TOKEN. HANDLES FILE INCLUSION AND LINE NUMBERS
C
       INTEGER FUNCTION GETTOK(TOKEN, TOKSIZ)
       INTEGER EQUAL, OPEN
       INTEGER JUNK, TOKSIZ
       INTEGER DEFTOK
       INTEGER NAME(30), TOKEN(TOKSIZ)
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       INTEGER INCL(8)
       DATA INCL(1) /105/
       DATA INCL(2) /110/
       DATA INCL(3) /99/
       DATA INCL(4) /108/
       DATA INCL(5) /117/
       DATA INCL(6) /100/
       DATA INCL(7) /101/
       DATA INCL(8) /10002/
       CONTINUE
23141  IF(.NOT.( LEVEL .GT. 0))   GOTO 23143
       CONTINUE
       GETTOK = DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL))
23144  IF(.NOT.( GETTOK .NE. 10003)) GOTO 23146
       IF(.NOT.(EQUAL(TOKEN, INCL) .EQ. 0))   GOTO 23147
       RETURN
23147  CONTINUE
       JUNK = DEFTOK(NAME, 30, INFILE(LEVEL))
       IF(.NOT.(LEVEL .GE. 5)) GOTO 23149
       CALL SYNERR(27HINCLUDES NESTED TOO DEEPLY.)
       GOTO 23150
23149  CONTINUE
       INFILE(LEVEL+1) = OPEN(NAME, 0)
       LINECT(LEVEL+1) = 1
       IF(.NOT.(INFILE(LEVEL+1) .EQ. 10001))  GOTO 23151
       CALL SYNERR(19HCAN'T OPEN INCLUDE.)
       GOTO 23152
23151  CONTINUE
       LEVEL = LEVEL + 1
23152  CONTINUE
23150  CONTINUE
23145           GETTOK = DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL))
       GOTO 23144
23146  CONTINUE
       IF(.NOT.(LEVEL .GT. 1)) GOTO 23153
       CALL CLOSE(INFILE(LEVEL))
23153  CONTINUE
23142   LEVEL = LEVEL - 1
       GOTO 23141
23143  CONTINUE
       GETTOK = 10003
       RETURN
       END
C
C GTOK - GET TOKEN FOR RATFOR
C
       INTEGER FUNCTION GTOK(LEXSTR, TOKSIZ, FD)
       INTEGER NGETCH, TYPE
       INTEGER FD, I, TOKSIZ
       INTEGER C, LEXSTR(TOKSIZ)
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       CONTINUE
23155  IF(.NOT.(NGETCH(C, FD) .NE. 10003)) GOTO 23156
       IF(.NOT.(C .NE. 32 .AND. C .NE. 9)) GOTO 23157
       GOTO 23156
23157  CONTINUE
       GOTO 23155
23156  CONTINUE
       CALL PUTBAK(C)
       CONTINUE
       I = 1
23159  IF(.NOT.( I .LT. TOKSIZ-1))   GOTO 23161
       GTOK = TYPE(NGETCH(LEXSTR(I), FD))
       IF(.NOT.(GTOK .NE. 1 .AND. GTOK .NE. 2))  GOTO 23162
       GOTO 23161
23162  CONTINUE
23160   I = I + 1
       GOTO 23159
23161  CONTINUE
       IF(.NOT.(I .GE. TOKSIZ-1)) GOTO 23164
       CALL SYNERR(15HTOKEN TOO LONG.)
23164  CONTINUE
       IF(.NOT.(I .GT. 1))  GOTO 23166
       CALL PUTBAK(LEXSTR(I))
       LEXSTR(I) = 10002
       GTOK = 10100
       GOTO 23167
23166  CONTINUE
       IF(.NOT.(LEXSTR(1) .EQ. 36))  GOTO 23168
       IF(.NOT.(NGETCH(LEXSTR(2), FD) .EQ. 40))  GOTO 23170
       LEXSTR(1) = 123
       GTOK = 123
       GOTO 23171
23170  CONTINUE
       IF(.NOT.(LEXSTR(2) .EQ. 41))  GOTO 23172
       LEXSTR(1) = 125
       GTOK = 125
       GOTO 23173
23172  CONTINUE
       CALL PUTBAK(LEXSTR(2))
23173  CONTINUE
23171  CONTINUE
       GOTO 23169
23168  CONTINUE
       IF(.NOT.(LEXSTR(1) .EQ. 39 .OR. LEXSTR(1) .EQ. 34))   GOTO 23174
       CONTINUE
       I = 2
23176  IF(.NOT.( NGETCH(LEXSTR(I), FD) .NE. LEXSTR(1)))   GOTO 23178
       IF(.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ-1))  GOTO 23179
       CALL SYNERR(14HMISSING QUOTE.)
       LEXSTR(I) = LEXSTR(1)
       CALL PUTBAK(10)
       GOTO 23178
23179  CONTINUE
23177   I = I + 1
       GOTO 23176
23178  CONTINUE
       GOTO 23175
23174  CONTINUE
       IF(.NOT.(LEXSTR(1) .EQ. 35))  GOTO 23181
       CONTINUE
23183  IF(.NOT.(NGETCH(LEXSTR(1), FD) .NE. 10))  GOTO 23184
       GOTO 23183
23184  CONTINUE
       GTOK = 10
       GOTO 23182
23181  CONTINUE
       IF(.NOT.(LEXSTR(1) .EQ. 62 .OR. LEXSTR(1) .EQ. 60 .OR. LEXSTR(1)
     *.EQ. 33      .OR. LEXSTR(1) .EQ. 61 .OR. LEXSTR(1) .EQ. 38 .OR. LE
     *XSTR(1) .EQ. 124)) GOTO 23185
       CALL RELATE(LEXSTR, I, FD)
23185  CONTINUE
23182  CONTINUE
23175  CONTINUE
23169  CONTINUE
23167  CONTINUE
       LEXSTR(I+1) = 10002
       IF(.NOT.(LEXSTR(1) .EQ. 10))  GOTO 23187
       LINECT(LEVEL) = LINECT(LEVEL) + 1
23187  CONTINUE
       RETURN
       END
C
C IFCODE - GENERATE INITIAL CODE FOR IF
C
       SUBROUTINE IFCODE(LAB)
       INTEGER LABGEN
       INTEGER LAB
       LAB = LABGEN(2)
       CALL IFGO(LAB)
       RETURN
       END
C
C IFGO - GENERATE "IF(.NOT.(...))GOTO LAB"
C
       SUBROUTINE IFGO(LAB)
       INTEGER LAB
       INTEGER IFNOT(9)
       DATA IFNOT(1) /105/
       DATA IFNOT(2) /102/
       DATA IFNOT(3) /40/
       DATA IFNOT(4) /46/
       DATA IFNOT(5) /110/
       DATA IFNOT(6) /111/
       DATA IFNOT(7) /116/
       DATA IFNOT(8) /46/
       DATA IFNOT(9) /10002/
       CALL OUTTAB
       CALL OUTSTR(IFNOT)
       CALL BALPAR
       CALL OUTCH(41)
       CALL OUTGO(LAB)
       RETURN
       END
C
C INDEX - FIND CHARACTER  C  IN STRING  STR
C
       INTEGER FUNCTION INDEX(STR, C)
       INTEGER C, STR(100)
       CONTINUE
       INDEX = 1
23189  IF(.NOT.( STR(INDEX) .NE. 10002))   GOTO 23191
       IF(.NOT.(STR(INDEX) .EQ. C))  GOTO 23192
       RETURN
23192  CONTINUE
23190   INDEX = INDEX + 1
       GOTO 23189
23191  CONTINUE
       INDEX = 0
       RETURN
       END
C
C INITKW - INSTALL KEYWORD "DEFINE" IN TABLE
C
       SUBROUTINE INITKW
       INTEGER DEFNAM(7), DEFTYP(2)
       DATA DEFNAM(1) /100/, DEFNAM(2) /101/, DEFNAM(3) /102/
       DATA DEFNAM(4) /105/, DEFNAM(5) /110/, DEFNAM(6) /101/
       DATA DEFNAM(7) /10002/
       DATA DEFTYP(1), DEFTYP(2) /10010, 10002/
       CALL INSTAL(DEFNAM, DEFTYP)
       RETURN
       END
C
C INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII
C
       INTEGER FUNCTION INMAP(INCHAR)
       INTEGER I, INCHAR
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       IF(.NOT.(INCHAR .EQ. EXTBLK)) GOTO 23194
       INMAP = INTBLK
       RETURN
23194  CONTINUE
       DO23196I = 1, 10
       IF(.NOT.(INCHAR .EQ. EXTDIG(I))) GOTO 23198
       INMAP = INTDIG(I)
       RETURN
23198  CONTINUE
23196  CONTINUE
23197  CONTINUE
       DO23200I = 1, 26
       IF(.NOT.(INCHAR .EQ. EXTLET(I))) GOTO 23202
       INMAP = INTLET(I)
       RETURN
23202  CONTINUE
23200  CONTINUE
23201  CONTINUE
       DO23204I = 1, 26
       IF(.NOT.(INCHAR .EQ. EXTBIG(I))) GOTO 23206
       INMAP = INTBIG(I)
       RETURN
23206  CONTINUE
23204  CONTINUE
23205  CONTINUE
       DO23208I = 1, 33
       IF(.NOT.(INCHAR .EQ. EXTCHR(I))) GOTO 23210
       INMAP = INTCHR(I)
       RETURN
23210  CONTINUE
23208  CONTINUE
23209  CONTINUE
       INMAP = INCHAR
       RETURN
       END
C
C INSTAL - ADD NAME AND DEFINITION TO TABLE
C
       SUBROUTINE INSTAL(NAME, DEFN)
       INTEGER DEFN(200), NAME(200)
       INTEGER LENGTH
       INTEGER DLEN, NLEN
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       NLEN = LENGTH(NAME) + 1
       DLEN = LENGTH(DEFN) + 1
       IF(.NOT.(LASTT + NLEN + DLEN .GT. 1500 .OR. LASTP .GE. 200))   GO
     *TO 23212
       CALL PUTLIN(NAME, 6)
       CALL REMARK(23H: TOO MANY DEFINITIONS.)
23212  CONTINUE
       LASTP = LASTP + 1
       NAMPTR(LASTP) = LASTT + 1
       CALL SCOPY(NAME, 1, TABLE, LASTT + 1)
       CALL SCOPY(DEFN, 1, TABLE, LASTT + NLEN + 1)
       LASTT = LASTT + NLEN + DLEN
       RETURN
       END
C
C ITOC - CONVERT INTEGER  INT  TO CHAR STRING IN  STR
C
       INTEGER FUNCTION ITOC(INT, STR, SIZE)
       INTEGER IABS, MOD
       INTEGER D, I, INT, INTVAL, J, K, SIZE
       INTEGER STR(SIZE)
       INTEGER DIGITS(11)
       DATA DIGITS(1) /48/
       DATA DIGITS(2) /49/
       DATA DIGITS(3) /50/
       DATA DIGITS(4) /51/
       DATA DIGITS(5) /52/
       DATA DIGITS(6) /53/
       DATA DIGITS(7) /54/
       DATA DIGITS(8) /55/
       DATA DIGITS(9) /56/
       DATA DIGITS(10) /57/
       DATA DIGITS(11) /10002/
       INTVAL = IABS(INT)
       STR(1) = 10002
       I = 1
       CONTINUE
23214  CONTINUE
       I = I + 1
       D = MOD(INTVAL, 10)
       STR(I) = DIGITS(D+1)
       INTVAL = INTVAL / 10
23215  IF(.NOT.(INTVAL .EQ. 0 .OR. I .GE. SIZE)) GOTO 23214
23216  CONTINUE
       IF(.NOT.(INT .LT. 0 .AND. I .LT. SIZE))   GOTO 23217
       I = I + 1
       STR(I) = 45
23217  CONTINUE
       ITOC = I - 1
       CONTINUE
       J = 1
23219  IF(.NOT.( J .LT. I)) GOTO 23221
       K = STR(I)
       STR(I) = STR(J)
       STR(J) = K
       I = I - 1
23220   J = J + 1
       GOTO 23219
23221  CONTINUE
       RETURN
       END
C
C LABELC - OUTPUT STATEMENT NUMBER
C
       SUBROUTINE LABELC(LEXSTR)
       INTEGER LEXSTR(100)
       INTEGER LENGTH
       IF(.NOT.(LENGTH(LEXSTR) .EQ. 5)) GOTO 23222
       IF(.NOT.(LEXSTR(1) .EQ. 50 .AND. LEXSTR(2) .EQ. 51))  GOTO 23224
       CALL SYNERR(33HWARNING: POSSIBLE LABEL CONFLICT.)
23224  CONTINUE
23222  CONTINUE
       CALL OUTSTR(LEXSTR)
       CALL OUTTAB
       RETURN
       END
C
C LABGEN - GENERATE  N  CONSECUTIVE LABELS, RETURN FIRST ONE
C
       INTEGER FUNCTION LABGEN(N)
       INTEGER LABEL, N
       DATA LABEL /23000/
       LABGEN = LABEL
       LABEL = LABEL + N
       RETURN
       END
C
C LENGTH - COMPUTE LENGTH OF STRING
C
       INTEGER FUNCTION LENGTH(STR)
       INTEGER STR(100)
       CONTINUE
       LENGTH = 0
23226  IF(.NOT.( STR(LENGTH+1) .NE. 10002))   GOTO 23228
23227   LENGTH = LENGTH + 1
       GOTO 23226
23228  CONTINUE
       RETURN
       END
C
C LEX - RETURN LEXICAL TYPE OF TOKEN
C
       INTEGER FUNCTION LEX(LEXSTR)
       INTEGER GETTOK
       INTEGER LEXSTR(200)
       INTEGER ALLDIG, EQUAL
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       CONTINUE
23229  IF(.NOT.(GETTOK(LEXSTR, 200) .EQ. 10)) GOTO 23230
       GOTO 23229
23230  CONTINUE
       LEX = LEXSTR(1)
       IF(.NOT.(LEX.EQ.10003 .OR. LEX.EQ.59 .OR. LEX.EQ.123 .OR. LEX.EQ.
     *125))  GOTO 23231
       RETURN
23231  CONTINUE
       IF(.NOT.(ALLDIG(LEXSTR) .EQ. 1)) GOTO 23233
       LEX = 10260
       GOTO 23234
23233  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SIF) .EQ. 1))   GOTO 23235
       LEX = VIF(1)
       GOTO 23236
23235  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SELSE) .EQ. 1)) GOTO 23237
       LEX = VELSE(1)
       GOTO 23238
23237  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SWHILE) .EQ. 1))   GOTO 23239
       LEX = VWHILE(1)
       GOTO 23240
23239  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SDO) .EQ. 1))   GOTO 23241
       LEX = VDO(1)
       GOTO 23242
23241  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SBREAK) .EQ. 1))   GOTO 23243
       LEX = VBREAK(1)
       GOTO 23244
23243  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SNEXT) .EQ. 1)) GOTO 23245
       LEX = VNEXT(1)
       GOTO 23246
23245  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SFOR) .EQ. 1))  GOTO 23247
       LEX = VFOR(1)
       GOTO 23248
23247  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SREPT) .EQ. 1)) GOTO 23249
       LEX = VREPT(1)
       GOTO 23250
23249  CONTINUE
       IF(.NOT.(EQUAL(LEXSTR, SUNTIL) .EQ. 1))   GOTO 23251
       LEX = VUNTIL(1)
       GOTO 23252
23251  CONTINUE
       LEX = 10267
23252  CONTINUE
23250  CONTINUE
23248  CONTINUE
23246  CONTINUE
23244  CONTINUE
23242  CONTINUE
23240  CONTINUE
23238  CONTINUE
23236  CONTINUE
23234  CONTINUE
       RETURN
       END
C
C LOOKUP - LOCATE NAME, EXTRACT DEFINITION FROM TABLE
C
       INTEGER FUNCTION LOOKUP(NAME, DEFN)
       INTEGER DEFN(200), NAME(200)
       INTEGER I, J, K
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       CONTINUE
       I = LASTP
23253  IF(.NOT.( I .GT. 0)) GOTO 23255
       J = NAMPTR(I)
       CONTINUE
       K = 1
23256  IF(.NOT.( NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 10002))  GOTO
     *23258
       J = J + 1
23257   K = K + 1
       GOTO 23256
23258  CONTINUE
       IF(.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 23259
       CALL SCOPY(TABLE, J+1, DEFN, 1)
       LOOKUP = 1
       RETURN
23259  CONTINUE
23254   I = I - 1
       GOTO 23253
23255  CONTINUE
       LOOKUP = 0
       RETURN
       END
C
C NGETCH - GET A (POSSIBLY PUSHED BACK) CHARACTER
C
       INTEGER FUNCTION NGETCH(C, FD)
       INTEGER GETCH
       INTEGER C
       INTEGER FD
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       IF(.NOT.(BP .GT. 0)) GOTO 23261
       C = BUF(BP)
       GOTO 23262
23261  CONTINUE
       BP = 1
       BUF(BP) = GETCH(C, FD)
23262  CONTINUE
       BP = BP - 1
       NGETCH = C
       RETURN
       END
C
C OPEN - EXCEEDINGLY TEMPORARY VERSION FOR GETTOK
C
       INTEGER FUNCTION OPEN(NAME, MODE)
       INTEGER NAME(30)
       INTEGER CTOI
       INTEGER I, MODE
       I = 1
       OPEN = CTOI(NAME, I)
       RETURN
       END
C
C OTHERC - OUTPUT ORDINARY FORTRAN STATEMENT
C
       SUBROUTINE OTHERC(LEXSTR)
       INTEGER LEXSTR(100)
       CALL OUTTAB
       CALL OUTSTR(LEXSTR)
       CALL EATUP
       CALL OUTDON
       RETURN
       END
C
C OUTCH - PUT ONE CHARACTER INTO OUTPUT BUFFER
C
       SUBROUTINE OUTCH(C)
       INTEGER C
       INTEGER I
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       IF(.NOT.(OUTP .GE. 72)) GOTO 23263
       CALL OUTDON
       CONTINUE
       I = 1
23265  IF(.NOT.( I .LT. 6)) GOTO 23267
       OUTBUF(I) = 32
23266   I = I + 1
       GOTO 23265
23267  CONTINUE
       OUTBUF(6) = 42
       OUTP = 6
23263  CONTINUE
       OUTP = OUTP + 1
       OUTBUF(OUTP) = C
       RETURN
       END
C
C OUTCON - OUTPUT "N   CONTINUE"
C
       SUBROUTINE OUTCON(N)
       INTEGER N
       INTEGER CONTIN(9)
       DATA CONTIN(1) /99/
       DATA CONTIN(2) /111/
       DATA CONTIN(3) /110/
       DATA CONTIN(4) /116/
       DATA CONTIN(5) /105/
       DATA CONTIN(6) /110/
       DATA CONTIN(7) /117/
       DATA CONTIN(8) /101/
       DATA CONTIN(9) /10002/
       IF(.NOT.(N .GT. 0))  GOTO 23268
       CALL OUTNUM(N)
23268  CONTINUE
       CALL OUTTAB
       CALL OUTSTR(CONTIN)
       CALL OUTDON
       RETURN
       END
C
C OUTDON - FINISH OFF AN OUTPUT LINE
C
       SUBROUTINE OUTDON
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       OUTBUF(OUTP+1) = 10
       OUTBUF(OUTP+2) = 10002
       CALL PUTLIN(OUTBUF, 6)
       OUTP = 0
       RETURN
       END
C
C OUTGO - OUTPUT "GOTO  N"
C
       SUBROUTINE OUTGO(N)
       INTEGER N
       INTEGER GOTO(6)
       DATA GOTO(1) /103/
       DATA GOTO(2) /111/
       DATA GOTO(3) /116/
       DATA GOTO(4) /111/
       DATA GOTO(5) /32/
       DATA GOTO(6) /10002/
       CALL OUTTAB
       CALL OUTSTR(GOTO)
       CALL OUTNUM(N)
       CALL OUTDON
       RETURN
       END
C
C OUTMAP - CONVERT RIGHT ADJ ASCII TO LEFT ADJUSTED EXTERNAL REP
C
       INTEGER FUNCTION OUTMAP(INCHAR)
       INTEGER I, INCHAR
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       IF(.NOT.(INCHAR .EQ. INTBLK)) GOTO 23270
       OUTMAP = EXTBLK
       RETURN
23270  CONTINUE
       DO23272I = 1, 10
       IF(.NOT.(INCHAR .EQ. INTDIG(I))) GOTO 23274
       OUTMAP = EXTDIG(I)
       RETURN
23274  CONTINUE
23272  CONTINUE
23273  CONTINUE
       DO23276I = 1, 26
       IF(.NOT.(INCHAR .EQ. INTLET(I))) GOTO 23278
       OUTMAP = EXTLET(I)
       RETURN
23278  CONTINUE
23276  CONTINUE
23277  CONTINUE
       DO23280I = 1, 26
       IF(.NOT.(INCHAR .EQ. INTBIG(I))) GOTO 23282
       OUTMAP = EXTBIG(I)
       RETURN
23282  CONTINUE
23280  CONTINUE
23281  CONTINUE
       DO23284I = 1, 33
       IF(.NOT.(INCHAR .EQ. INTCHR(I))) GOTO 23286
       OUTMAP = EXTCHR(I)
       RETURN
23286  CONTINUE
23284  CONTINUE
23285  CONTINUE
       OUTMAP = INCHAR
       RETURN
       END
C
C OUTNUM - OUTPUT DECIMAL NUMBER
C
       SUBROUTINE OUTNUM(N)
       INTEGER CHARS(10)
       INTEGER ITOC
       INTEGER I, LEN, N
       LEN = ITOC(N, CHARS, 10)
       CONTINUE
       I = 1
23288  IF(.NOT.( I .LE. LEN))  GOTO 23290
       CALL OUTCH(CHARS(I))
23289   I = I + 1
       GOTO 23288
23290  CONTINUE
       RETURN
       END
C
C OUTSTR - OUTPUT STRING
C
       SUBROUTINE OUTSTR(STR)
       INTEGER C, STR(100)
       INTEGER I, J
       CONTINUE
       I = 1
23291  IF(.NOT.( STR(I) .NE. 10002)) GOTO 23293
       C = STR(I)
       IF(.NOT.(C .NE. 39 .AND. C .NE. 34))   GOTO 23294
       CALL OUTCH(C)
       GOTO 23295
23294  CONTINUE
       I = I + 1
       CONTINUE
       J = I
23296  IF(.NOT.( STR(J) .NE. C))  GOTO 23298
23297   J = J + 1
       GOTO 23296
23298  CONTINUE
       CALL OUTNUM(J-I)
       CALL OUTCH(104)
       CONTINUE
23299  IF(.NOT.( I .LT. J)) GOTO 23301
       CALL OUTCH(STR(I))
23300   I = I + 1
       GOTO 23299
23301  CONTINUE
23295  CONTINUE
23292   I = I + 1
       GOTO 23291
23293  CONTINUE
       RETURN
       END
C
C OUTTAB - GET PAST COLUMN 6
C
       SUBROUTINE OUTTAB
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       CONTINUE
23302  IF(.NOT.(OUTP .LT. 6))  GOTO 23303
       CALL OUTCH(32)
       GOTO 23302
23303  CONTINUE
       RETURN
       END
C
C PARSE - PARSE RATFOR SOURCE PROGRAM
C
       SUBROUTINE PARSE
       INTEGER LEXSTR(200)
       INTEGER LEX
       INTEGER LAB, LABVAL(100), LEXTYP(100), SP, TOKEN
       CALL INITKW
       SP = 1
       LEXTYP(1) = 10003
       CONTINUE
       TOKEN = LEX(LEXSTR)
23304  IF(.NOT.( TOKEN .NE. 10003))  GOTO 23306
       IF(.NOT.(TOKEN .EQ. 10261))   GOTO 23307
       CALL IFCODE(LAB)
       GOTO 23308
23307  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10266))   GOTO 23309
       CALL DOCODE(LAB)
       GOTO 23310
23309  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10263))   GOTO 23311
       CALL WHILEC(LAB)
       GOTO 23312
23311  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10268))   GOTO 23313
       CALL FORCOD(LAB)
       GOTO 23314
23313  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10269))   GOTO 23315
       CALL REPCOD(LAB)
       GOTO 23316
23315  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10260))   GOTO 23317
       CALL LABELC(LEXSTR)
       GOTO 23318
23317  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10262))   GOTO 23319
       IF(.NOT.(LEXTYP(SP) .EQ. 10261)) GOTO 23321
       CALL ELSEIF(LABVAL(SP))
       GOTO 23322
23321  CONTINUE
       CALL SYNERR(13HILLEGAL ELSE.)
23322  CONTINUE
23319  CONTINUE
23318  CONTINUE
23316  CONTINUE
23314  CONTINUE
23312  CONTINUE
23310  CONTINUE
23308  CONTINUE
       IF(.NOT.(TOKEN.EQ.10261 .OR. TOKEN.EQ.10262 .OR. TOKEN.EQ.10263
     *      .OR. TOKEN.EQ.10268 .OR. TOKEN.EQ.10269         .OR. TOKEN.E
     *Q.10266 .OR. TOKEN.EQ.10260 .OR. TOKEN.EQ.123))  GOTO 23323
       SP = SP + 1
       IF(.NOT.(SP .GT. 100))  GOTO 23325
       CALL ERROR(25HSTACK OVERFLOW IN PARSER.)
23325  CONTINUE
       LEXTYP(SP) = TOKEN
       LABVAL(SP) = LAB
       GOTO 23324
23323  CONTINUE
       IF(.NOT.(TOKEN .EQ. 125))  GOTO 23327
       IF(.NOT.(LEXTYP(SP) .EQ. 123))   GOTO 23329
       SP = SP - 1
       GOTO 23330
23329  CONTINUE
       CALL SYNERR(20HILLEGAL RIGHT BRACE.)
23330  CONTINUE
       GOTO 23328
23327  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10267))   GOTO 23331
       CALL OTHERC(LEXSTR)
       GOTO 23332
23331  CONTINUE
       IF(.NOT.(TOKEN .EQ. 10264 .OR. TOKEN .EQ. 10265))  GOTO 23333
       CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN)
23333  CONTINUE
23332  CONTINUE
23328  CONTINUE
       TOKEN = LEX(LEXSTR)
       CALL PBSTR(LEXSTR)
       CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN)
23324  CONTINUE
23305   TOKEN = LEX(LEXSTR)
       GOTO 23304
23306  CONTINUE
       IF(.NOT.(SP .NE. 1)) GOTO 23335
       CALL SYNERR(15HUNEXPECTED EOF.)
23335  CONTINUE
       RETURN
       END
C
C PBSTR - PUSH STRING BACK ONTO INPUT
C
       SUBROUTINE PBSTR(IN)
       INTEGER IN(100)
       INTEGER LENGTH
       INTEGER I
       CONTINUE
       I = LENGTH(IN)
23337  IF(.NOT.( I .GT. 0)) GOTO 23339
       CALL PUTBAK(IN(I))
23338   I = I - 1
       GOTO 23337
23339  CONTINUE
       RETURN
       END
C
C PUTBAK - PUSH CHARACTER BACK ONTO INPUT
C
       SUBROUTINE PUTBAK(C)
       INTEGER C
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       BP = BP + 1
       IF(.NOT.(BP .GT. 300))  GOTO 23340
       CALL ERROR(32HTOO MANY CHARACTERS PUSHED BACK.)
23340  CONTINUE
       BUF(BP) = C
       RETURN
       END
C
C PUTCH (INTERIM VERSION)  PUT CHARACTERS
C
       SUBROUTINE PUTCH(C, F)
       INTEGER BUF(81), C
       INTEGER OUTMAP
       INTEGER F, I, LASTC
       DATA LASTC /0/
       IF(.NOT.(LASTC .GE. 81 .OR. C .EQ. 10))   GOTO 23342
       IF(.NOT.( LASTC .LE. 0 ))  GOTO 23344
       WRITE(F,2)
2         FORMAT(/)
       GOTO 23345
23344  CONTINUE
       WRITE(F, 1) (BUF(I), I = 1, LASTC)
1         FORMAT(80 A1)
23345  CONTINUE
       LASTC = 0
23342  CONTINUE
       IF(.NOT.(C .NE. 10)) GOTO 23346
       LASTC = LASTC + 1
       BUF(LASTC) = OUTMAP(C)
23346  CONTINUE
       RETURN
       END
C
C PUTLIN - PUT OUT LINE BY REPEATED CALLS TO PUTCH
C
       SUBROUTINE PUTLIN(B, F)
       INTEGER B(100)
       INTEGER F, I
       CONTINUE
       I = 1
23348  IF(.NOT.( B(I) .NE. 10002))   GOTO 23350
       CALL PUTCH(B(I), F)
23349   I = I + 1
       GOTO 23348
23350  CONTINUE
       RETURN
       END
C
C RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM
C
       SUBROUTINE RELATE(TOKEN, LAST, FD)
       INTEGER NGETCH
       INTEGER TOKEN(100)
       INTEGER LENGTH
       INTEGER FD, LAST
       INTEGER DOTGE(5), DOTGT(5), DOTLT(5), DOTLE(5)
       INTEGER DOTNE(5), DOTNOT(6), DOTEQ(5), DOTAND(6), DOTOR(5)
       DATA DOTGE(1), DOTGE(2), DOTGE(3), DOTGE(4), DOTGE(5)/ 46, 103, 1
     *01, 46, 10002/
       DATA DOTGT(1), DOTGT(2), DOTGT(3), DOTGT(4), DOTGT(5)/ 46, 103, 1
     *16, 46, 10002/
       DATA DOTLE(1), DOTLE(2), DOTLE(3), DOTLE(4), DOTLE(5)/ 46, 108, 1
     *01, 46, 10002/
       DATA DOTLT(1), DOTLT(2), DOTLT(3), DOTLT(4), DOTLT(5)/ 46, 108, 1
     *16, 46, 10002/
       DATA DOTNE(1), DOTNE(2), DOTNE(3), DOTNE(4), DOTNE(5)/ 46, 110, 1
     *01, 46, 10002/
       DATA DOTEQ(1), DOTEQ(2), DOTEQ(3), DOTEQ(4), DOTEQ(5)/ 46, 101, 1
     *13, 46, 10002/
       DATA DOTOR(1), DOTOR(2), DOTOR(3), DOTOR(4), DOTOR(5)/ 46, 111, 1
     *14, 46, 10002/
       DATA DOTAND(1), DOTAND(2), DOTAND(3), DOTAND(4), DOTAND(5), DOTAN
     *D(6) /46, 97, 110, 100, 46, 10002/
       DATA DOTNOT(1), DOTNOT(2), DOTNOT(3), DOTNOT(4), DOTNOT(5), DOTNO
     *T(6) /46, 110, 111, 116, 46, 10002/
       IF(.NOT.(NGETCH(TOKEN(2), FD) .NE. 61))   GOTO 23351
       CALL PUTBAK(TOKEN(2))
23351  CONTINUE
       IF(.NOT.(TOKEN(1) .EQ. 62))   GOTO 23353
       IF(.NOT.(TOKEN(2) .EQ. 61))   GOTO 23355
       CALL SCOPY(DOTGE, 1, TOKEN, 1)
       GOTO 23356
23355  CONTINUE
       CALL SCOPY(DOTGT, 1, TOKEN, 1)
23356  CONTINUE
       GOTO 23354
23353  CONTINUE
       IF(.NOT.(TOKEN(1) .EQ. 60))   GOTO 23357
       IF(.NOT.(TOKEN(2) .EQ. 61))   GOTO 23359
       CALL SCOPY(DOTLE, 1, TOKEN, 1)
       GOTO 23360
23359  CONTINUE
       CALL SCOPY(DOTLT, 1, TOKEN, 1)
23360  CONTINUE
       GOTO 23358
23357  CONTINUE
       IF(.NOT.(TOKEN(1) .EQ. 33))   GOTO 23361
       IF(.NOT.(TOKEN(2) .EQ. 61))   GOTO 23363
       CALL SCOPY(DOTNE, 1, TOKEN, 1)
       GOTO 23364
23363  CONTINUE
       CALL SCOPY(DOTNOT, 1, TOKEN, 1)
23364  CONTINUE
       GOTO 23362
23361  CONTINUE
       IF(.NOT.(TOKEN(1) .EQ. 61))   GOTO 23365
       IF(.NOT.(TOKEN(2) .EQ. 61))   GOTO 23367
       CALL SCOPY(DOTEQ, 1, TOKEN, 1)
       GOTO 23368
23367  CONTINUE
       TOKEN(2) = 10002
23368  CONTINUE
       GOTO 23366
23365  CONTINUE
       IF(.NOT.(TOKEN(1) .EQ. 38))   GOTO 23369
       CALL SCOPY(DOTAND, 1, TOKEN, 1)
       GOTO 23370
23369  CONTINUE
       IF(.NOT.(TOKEN(1) .EQ. 124))  GOTO 23371
       CALL SCOPY(DOTOR, 1, TOKEN, 1)
       GOTO 23372
23371  CONTINUE
       TOKEN(2) = 10002
23372  CONTINUE
23370  CONTINUE
23366  CONTINUE
23362  CONTINUE
23358  CONTINUE
23354  CONTINUE
       LAST = LENGTH(TOKEN)
       RETURN
       END
C
C REMARK - PRINT WARNING MESSAGE
C
       SUBROUTINE REMARK(BUF)
       INTEGER BUF(100), I
       WRITE(6, 10) (BUF(I), I = 1, 5)
10        FORMAT(5A4)
       RETURN
       END
C
C REPCOD - GENERATE CODE FOR BEGINNING OF REPEAT
C
       SUBROUTINE REPCOD(LAB)
       INTEGER LABGEN
       INTEGER LAB
       CALL OUTCON(0)
       LAB = LABGEN(3)
       CALL OUTCON(LAB)
       LAB = LAB + 1
       RETURN
       END
C
C SCOPY - COPY STRING AT FROM(I) TO TO(J)
C
       SUBROUTINE SCOPY(FROM, I, TO, J)
       INTEGER FROM(100), TO(100)
       INTEGER I, J, K1, K2
       K2 = J
       CONTINUE
       K1 = I
23373  IF(.NOT.( FROM(K1) .NE. 10002))  GOTO 23375
       TO(K2) = FROM(K1)
       K2 = K2 + 1
23374   K1 = K1 + 1
       GOTO 23373
23375  CONTINUE
       TO(K2) = 10002
       RETURN
       END
C
C SYNERR - REPORT RATFOR SYNTAX ERROR
C
       SUBROUTINE SYNERR(MSG)
       INTEGER LC(81), MSG(81)
       INTEGER ITOC
       INTEGER I, JUNK
       COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
     *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
       INTEGER EXTDIG
       INTEGER INTDIG
       INTEGER EXTLET
       INTEGER INTLET
       INTEGER EXTBIG
       INTEGER INTBIG
       INTEGER EXTCHR
       INTEGER INTCHR
       INTEGER EXTBLK
       INTEGER INTBLK
       COMMON /CDEFIO/ BP, BUF(300)
       INTEGER BP
       INTEGER BUF
       COMMON /CFOR/ FORDEP, FORSTK(200)
       INTEGER FORDEP
       INTEGER FORSTK
       COMMON /CKEYWD/ SDO, SIF, SELSE, SWHILE, SBREAK, SNEXT, SFOR, SRE
     *PT, SUNTIL, VDO, VIF, VELSE, VWHILE, VBREAK, VNEXT, VFOR, VREPT, V
     *UNTIL
       INTEGER SDO(3), SIF(3), SELSE(5), SWHILE(6), SBREAK(6), SNEXT(5)
       INTEGER SFOR(4), SREPT(7), SUNTIL(6)
       INTEGER VDO(2), VIF(2), VELSE(2), VWHILE(2), VBREAK(2), VNEXT(2)
       INTEGER VFOR(2), VREPT(2), VUNTIL(2)
       COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5)
       INTEGER LEVEL
       INTEGER LINECT
       INTEGER INFILE
       COMMON /CLOOK/ LASTP, LASTT, NAMPTR(200), TABLE(1500)
       INTEGER LASTP
       INTEGER LASTT
       INTEGER NAMPTR
       INTEGER TABLE
       COMMON /COUTLN/ OUTP, OUTBUF(81)
       INTEGER OUTP
       INTEGER OUTBUF
       CALL REMARK(14HERROR AT LINE.)
       CONTINUE
       I = 1
23376  IF(.NOT.( I .LE. LEVEL))   GOTO 23378
       CALL PUTCH(32, 6)
       JUNK = ITOC(LINECT(I), LC, 81)
       CALL PUTLIN(LC, 6)
23377   I = I + 1
       GOTO 23376
23378  CONTINUE
       CALL PUTCH(58, 6)
       CALL PUTCH(10, 6)
       CALL REMARK(MSG)
       RETURN
       END
C
C TYPE - RETURN LETTER, DIGIT OR CHARACTER
C
       INTEGER FUNCTION TYPE(C)
       INTEGER C
       IF(.NOT.( C .GE. 48 .AND. C .LE. 57 )) GOTO 23379
       TYPE = 2
       GOTO 23380
23379  CONTINUE
       IF(.NOT.( C .GE. 97 .AND. C .LE. 122 ))   GOTO 23381
       TYPE = 1
       GOTO 23382
23381  CONTINUE
       IF(.NOT.( C .GE. 65 .AND. C .LE. 90 )) GOTO 23383
       TYPE = 1
       GOTO 23384
23383  CONTINUE
       TYPE = C
23384  CONTINUE
23382  CONTINUE
23380  CONTINUE
       RETURN
       END
C
C UNSTAK - UNSTACK AT END OF STATEMENT
C
       SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN)
       INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN
       CONTINUE
23385  IF(.NOT.( SP .GT. 1))   GOTO 23387
       IF(.NOT.(LEXTYP(SP) .EQ. 123))   GOTO 23388
       GOTO 23387
23388  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10261 .AND. TOKEN .EQ. 10262))  GOTO 233
     *90
       GOTO 23387
23390  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10261)) GOTO 23392
       CALL OUTCON(LABVAL(SP))
       GOTO 23393
23392  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10262)) GOTO 23394
       IF(.NOT.(SP .GT. 2)) GOTO 23396
       SP = SP - 1
23396  CONTINUE
       CALL OUTCON(LABVAL(SP)+1)
       GOTO 23395
23394  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10266)) GOTO 23398
       CALL DOSTAT(LABVAL(SP))
       GOTO 23399
23398  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10263)) GOTO 23400
       CALL WHILES(LABVAL(SP))
       GOTO 23401
23400  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10268)) GOTO 23402
       CALL FORS(LABVAL(SP))
       GOTO 23403
23402  CONTINUE
       IF(.NOT.(LEXTYP(SP) .EQ. 10269)) GOTO 23404
       CALL UNTILS(LABVAL(SP), TOKEN)
23404  CONTINUE
23403  CONTINUE
23401  CONTINUE
23399  CONTINUE
23395  CONTINUE
23393  CONTINUE
23386   SP = SP - 1
       GOTO 23385
23387  CONTINUE
       RETURN
       END
C
C UNTILS - GENERATE CODE FOR UNTIL OR END OF REPEAT
C
       SUBROUTINE UNTILS(LAB, TOKEN)
       INTEGER PTOKEN(200)
       INTEGER LEX
       INTEGER JUNK, LAB, TOKEN
       CALL OUTNUM(LAB)
       IF(.NOT.(TOKEN .EQ. 10270))   GOTO 23406
       JUNK = LEX(PTOKEN)
       CALL IFGO(LAB-1)
       GOTO 23407
23406  CONTINUE
       CALL OUTGO(LAB-1)
23407  CONTINUE
       CALL OUTCON(LAB+1)
       RETURN
       END
C
C WHILEC - GENERATE CODE FOR BEGINNING OF WHILE
C
       SUBROUTINE WHILEC(LAB)
       INTEGER LABGEN
       INTEGER LAB
       CALL OUTCON(0)
       LAB = LABGEN(2)
       CALL OUTNUM(LAB)
       CALL IFGO(LAB+1)
       RETURN
       END
C
C WHILES - GENERATE CODE FOR END OF WHILE
C
       SUBROUTINE WHILES(LAB)
       INTEGER LAB
       CALL OUTGO(LAB)
       CALL OUTCON(LAB+1)
       RETURN
       END
========== Ratfor definitions ==========

 # Because some compilers will not compile logical expressions
 # of the form (i .ne. -1), we have used positive values for
 # some symbolic constants where negative values would be
 # a better choice. (EOS, EOF, and so on are examples.)
 # These positive values are all greater than 10000.

define(ALPHA,10100)
define(AMPER,38)   # ampersand
define(ARB,100)
define(ATSIGN,64)
define(BACKSLASH,92)
define(BACKSPACE,8)
define(BANG,33)   # exclamation mark
define(BAR,124)
define(BIGA,65)
define(BIGB,66)
define(BIGC,67)
define(BIGD,68)
define(BIGE,69)
define(BIGF,70)
define(BIGG,71)
define(BIGH,72)
define(BIGI,73)
define(BIGJ,74)
define(BIGK,75)
define(BIGL,76)
define(BIGM,77)
define(BIGN,78)
define(BIGO,79)
define(BIGP,80)
define(BIGQ,81)
define(BIGR,82)
define(BIGS,83)
define(BIGT,84)
define(BIGU,85)
define(BIGV,86)
define(BIGW,87)
define(BIGX,88)
define(BIGY,89)
define(BIGZ,90)
define(BLANK,32)
define(BUFSIZE,300)   # pushback buffer for ngetch and putbak
define(COLON,58)
define(COMMA,44)
define(DEFTYPE,10010)
define(DIG0,48)
define(DIG1,49)
define(DIG2,50)
define(DIG3,51)
define(DIG4,52)
define(DIG5,53)
define(DIG6,54)
define(DIG7,55)
define(DIG8,56)
define(DIG9,57)
define(DIGIT,2)
define(DOLLAR,36)
define(DQUOTE,34)
define(EOF,10003)
define(EOS,10002)
define(EQUALS,61)
define(ERR,10001)
define(ERROUT,6)   # temporarily same as standard output
define(GREATER,62)
define(LBRACE,123)
define(LBRACK,91)
define(LESS,60)
define(LETA,97)
define(LETB,98)
define(LETC,99)
define(LETD,100)
define(LETE,101)
define(LETF,102)
define(LETG,103)
define(LETH,104)
define(LETI,105)
define(LETJ,106)
define(LETK,107)
define(LETL,108)
define(LETM,109)
define(LETN,110)
define(LETO,111)
define(LETP,112)
define(LETQ,113)
define(LETR,114)
define(LETS,115)
define(LETT,116)
define(LETTER,1)
define(LETU,117)
define(LETV,118)
define(LETW,119)
define(LETX,120)
define(LETY,121)
define(LETZ,122)
define(LEXBREAK,10264)
define(LEXDIGITS,10260)
define(LEXDO,10266)
define(LEXELSE,10262)
define(LEXFOR,10268)
define(LEXIF,10261)
define(LEXNEXT,10265)
define(LEXOTHER,10267)
define(LEXREPEAT,10269)
define(LEXUNTIL,10270)
define(LEXWHILE,10263)
define(LPAREN,40)
define(MAXCARD,80)   # card size
define(MAXCHARS,10)   # characters for outnum
define(MAXDEF,200)   # max chars in a defn
define(MAXFORSTK,200)   # max space for for reinit clauses
define(MAXLINE,81)   # must be 1 more than MAXCARD
define(MAXNAME,30)   # file name size in gettok
define(MAXPTR,200)   # number of defines in lookup
define(MAXSTACK,100)   # max stack depth for parser
define(MAXTBL,1500)   # max chars in all definitions
define(MAXTOK,200)   # max chars in a token
define(MINUS,45)
define(NCHARS,33)   # number of special characters
define(NEWLINE,10)
define(NFILES,5)   # max depth of file inclusion
define(NO,0)
define(NOT,BANG)   # exclamation mark for now; change for ebcdic
define(PERCENT,37)
define(PERIOD,46)
define(PLUS,43)
define(QMARK,63)
define(RBRACE,125)
define(RBRACK,93)
define(READONLY,0)
define(RPAREN,41)
define(SEMICOL,59)
define(SHARP,35)
define(SLASH,47)
define(SQUOTE,39)
define(STAR,42)
define(STDIN,5)
define(STDOUT,6)
define(TAB,9)
define(UNDERLINE,95)
define(YES,1)
define(character,integer)
define(abs,iabs)
========== commonblocks ==========
# common blocks.
#   these have been lumped into one place to minimize
#   the operational problems of picking up several small
#   files in an environment that doesn't support files
#   by name. The individual routines still name as comments the
#   actual common blocks they need, but actually include
#   everything in this batch, with a statement:
#      include commonblocks

common /cchar/ extdig(10), intdig(10), extlet(26), intlet(26),
   extbig(26), intbig(26), extchr(NCHARS), intchr(NCHARS),
   extblk, intblk
   integer extdig   # external representation of digits
   integer intdig   # internal rep (ascii)
   integer extlet   # external rep of letters (normal case)
   integer intlet   # internal rep (ascii lower case)
   integer extbig   # external rep of upper case, if used
   integer intbig   # internal rep (upper case ascii)
   integer extchr   # external rep of special chars
   integer intchr   # internal rep (ascii)
   integer extblk   # external blank
   integer intblk   # internal blank (ascii)

common /cdefio/ bp, buf(BUFSIZE)
   integer bp      # next available character; init = 0
   character buf   # pushed-back characters

common /cfor/ fordep, forstk(MAXFORSTK)
   integer fordep   # current depth of for statements
   character forstk   # stack of reinit strings

common /ckeywd/ sdo, sif, selse, swhile, sbreak, snext,
   sfor, srept, suntil,
   vdo, vif, velse, vwhile, vbreak, vnext, vfor, vrept, vuntil
   integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5)
   integer sfor(4), srept(7), suntil(6)
   integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2)
   integer vfor(2), vrept(2), vuntil(2)

common /cline/ level, linect(NFILES), infile(NFILES)
   integer level   # level of file inclusion; init = 1
   integer linect   # line count on input file(level); init = 1
   integer infile   # file number(level); init infile(1) = STDIN

common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL)
   integer lastp   # last used in namptr; init = 0
   integer lastt   # last used in table; init = 0
   integer namptr   # name pointers
   character table   # actual text of names and defns

common /coutln/ outp, outbuf(MAXLINE)
   integer outp      # last position filled in outbuf; init = 0
   character outbuf   # output lines collected here
========== Ratfor in ratfor ==========
# block data - initialize global variables
   block data
   include commonblocks
   # include coutln
   # include cline
   # include cdefio
   # include cfor
   # include clook
   # include ckeywd
   # include cchar

   # output character pointer:
   data outp /0/

   # file control:
   data level /1/
   data linect(1) /1/
   data infile(1) /STDIN/

   # pushback buffer pointer:
   data bp /0/

   # depth of for stack:
   data fordep /0/

   # pointers for table lookup code:
   data lastp /0/
   data lastt /0/

   # keywords:
   data sdo(1), sdo(2), sdo(3) /LETD, LETO, EOS/
   data vdo(1), vdo(2) /LEXDO, EOS/

   data sif(1), sif(2), sif(3) /LETI, LETF, EOS/
   data vif(1), vif(2) /LEXIF, EOS/

   data selse(1), selse(2), selse(3), selse(4), selse(5) /LETE,
      LETL, LETS, LETE, EOS/
   data velse(1), velse(2) /LEXELSE, EOS/

   data swhile(1), swhile(2), swhile(3), swhile(4), swhile(5),
      swhile(6) /LETW, LETH, LETI, LETL, LETE, EOS/
   data vwhile(1), vwhile(2) /LEXWHILE, EOS/

   data sbreak(1), sbreak(2), sbreak(3), sbreak(4), sbreak(5),
      sbreak(6) /LETB, LETR, LETE, LETA, LETK, EOS/
   data vbreak(1), vbreak(2) /LEXBREAK, EOS/

   data snext(1), snext(2), snext(3), snext(4), snext(5) /LETN,
      LETE, LETX, LETT, EOS/
   data vnext(1), vnext(2) /LEXNEXT, EOS/

   data sfor(1), sfor(2), sfor(3), sfor(4) /LETF,
      LETO, LETR, EOS/
   data vfor(1), vfor(2) /LEXFOR, EOS/

   data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6),
      srept(7) /LETR, LETE, LETP, LETE, LETA, LETT, EOS/
   data vrept(1), vrept(2) /LEXREPEAT, EOS/

   data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5),
      suntil(6) /LETU, LETN, LETT, LETI, LETL, EOS/
   data vuntil(1), vuntil(2) /LEXUNTIL, EOS/

   # character set definitions:

   data extblk /' '/, intblk /BLANK/

   data extdig(1) /'0'/, intdig(1) /DIG0/
   data extdig(2) /'1'/, intdig(2) /DIG1/
   data extdig(3) /'2'/, intdig(3) /DIG2/
   data extdig(4) /'3'/, intdig(4) /DIG3/
   data extdig(5) /'4'/, intdig(5) /DIG4/
   data extdig(6) /'5'/, intdig(6) /DIG5/
   data extdig(7) /'6'/, intdig(7) /DIG6/
   data extdig(8) /'7'/, intdig(8) /DIG7/
   data extdig(9) /'8'/, intdig(9) /DIG8/
   data extdig(10) /'9'/, intdig(10) /DIG9/

   # normal case of letters

   data extlet(1) /'a'/, intlet(1) /LETA/
   data extlet(2) /'b'/, intlet(2) /LETB/
   data extlet(3) /'c'/, intlet(3) /LETC/
   data extlet(4) /'d'/, intlet(4) /LETD/
   data extlet(5) /'e'/, intlet(5) /LETE/
   data extlet(6) /'f'/, intlet(6) /LETF/
   data extlet(7) /'g'/, intlet(7) /LETG/
   data extlet(8) /'h'/, intlet(8) /LETH/
   data extlet(9) /'i'/, intlet(9) /LETI/
   data extlet(10) /'j'/, intlet(10) /LETJ/
   data extlet(11) /'k'/, intlet(11) /LETK/
   data extlet(12) /'l'/, intlet(12) /LETL/
   data extlet(13) /'m'/, intlet(13) /LETM/
   data extlet(14) /'n'/, intlet(14) /LETN/
   data extlet(15) /'o'/, intlet(15) /LETO/
   data extlet(16) /'p'/, intlet(16) /LETP/
   data extlet(17) /'q'/, intlet(17) /LETQ/
   data extlet(18) /'r'/, intlet(18) /LETR/
   data extlet(19) /'s'/, intlet(19) /LETS/
   data extlet(20) /'t'/, intlet(20) /LETT/
   data extlet(21) /'u'/, intlet(21) /LETU/
   data extlet(22) /'v'/, intlet(22) /LETV/
   data extlet(23) /'w'/, intlet(23) /LETW/
   data extlet(24) /'x'/, intlet(24) /LETX/
   data extlet(25) /'y'/, intlet(25) /LETY/
   data extlet(26) /'z'/, intlet(26) /LETZ/

   # upper case of letters

   data extbig(1) /'A'/, intbig(1) /BIGA/
   data extbig(2) /'B'/, intbig(2) /BIGB/
   data extbig(3) /'C'/, intbig(3) /BIGC/
   data extbig(4) /'D'/, intbig(4) /BIGD/
   data extbig(5) /'E'/, intbig(5) /BIGE/
   data extbig(6) /'F'/, intbig(6) /BIGF/
   data extbig(7) /'G'/, intbig(7) /BIGG/
   data extbig(8) /'H'/, intbig(8) /BIGH/
   data extbig(9) /'I'/, intbig(9) /BIGI/
   data extbig(10) /'J'/, intbig(10) /BIGJ/
   data extbig(11) /'K'/, intbig(11) /BIGK/
   data extbig(12) /'L'/, intbig(12) /BIGL/
   data extbig(13) /'M'/, intbig(13) /BIGM/
   data extbig(14) /'N'/, intbig(14) /BIGN/
   data extbig(15) /'O'/, intbig(15) /BIGO/
   data extbig(16) /'P'/, intbig(16) /BIGP/
   data extbig(17) /'Q'/, intbig(17) /BIGQ/
   data extbig(18) /'R'/, intbig(18) /BIGR/
   data extbig(19) /'S'/, intbig(19) /BIGS/
   data extbig(20) /'T'/, intbig(20) /BIGT/
   data extbig(21) /'U'/, intbig(21) /BIGU/
   data extbig(22) /'V'/, intbig(22) /BIGV/
   data extbig(23) /'W'/, intbig(23) /BIGW/
   data extbig(24) /'X'/, intbig(24) /BIGX/
   data extbig(25) /'Y'/, intbig(25) /BIGY/
   data extbig(26) /'Z'/, intbig(26) /BIGZ/

   # special characters. some of these may
   # change for your machine

   data extchr(1) /'!'/, intchr(1) /NOT/   # use exclam for not-sign
   data extchr(2) /'"'/, intchr(2) /DQUOTE/
   data extchr(3) /"#"/, intchr(3) /SHARP/
   data extchr(4) /'$'/, intchr(4) /DOLLAR/
   data extchr(5) /'%'/, intchr(5) /PERCENT/
   data extchr(6) /'&'/, intchr(6) /AMPER/
   data extchr(7) /"'"/, intchr(7) /SQUOTE/
   data extchr(8) /'('/, intchr(8) /LPAREN/
   data extchr(9) /')'/, intchr(9) /RPAREN/
   data extchr(10) /'*'/, intchr(10) /STAR/
   data extchr(11) /'+'/, intchr(11) /PLUS/
   data extchr(12) /','/, intchr(12) /COMMA/
   data extchr(13) /'-'/, intchr(13) /MINUS/
   data extchr(14) /'.'/, intchr(14) /PERIOD/
   data extchr(15) /'/'/, intchr(15) /SLASH/
   data extchr(16) /':'/, intchr(16) /COLON/
   data extchr(17) /';'/, intchr(17) /SEMICOL/
   data extchr(18) /'<'/, intchr(18) /LESS/
   data extchr(19) /'='/, intchr(19) /EQUALS/
   data extchr(20) /'>'/, intchr(20) /GREATER/
   data extchr(21) /'?'/, intchr(21) /QMARK/
   data extchr(22) /'@'/, intchr(22) /ATSIGN/
   data extchr(23) /'['/, intchr(23) /LBRACK/
   data extchr(24) /'\'/, intchr(24) /BACKSLASH/
   data extchr(25) /']'/, intchr(25) /RBRACK/
   data extchr(26) /'_'/, intchr(26) /UNDERLINE/
   data extchr(27) /'{'/, intchr(27) /LBRACE/
   data extchr(28) /'|'/, intchr(28) /BAR/
   data extchr(29) /'$@$'/, intchr(29) /RBRACE/
   data extchr(30) /''/, intchr(30) /BACKSPACE/
	data extchr(31) /'	'/, intchr(31) /TAB/
   data extchr(32) /'~'/, intchr(32) /NOT/   # use caret for not-sign
   data extchr(33) /'^'/, intchr(33) /NOT/   # use tilde for not-sign
   # NCHARS is last subscript in this array

   end
# ratfor - main program for Ratfor
   call parse
   stop
   end
# alldig - return YES if str is all digits
   integer function alldig(str)
   character type
   character str(ARB)
   integer i

   alldig = NO
   if (str(1) == EOS)
      return
   for (i = 1; str(i) ~= EOS; i = i + 1)
      if (type(str(i)) ~= DIGIT)
         return
   alldig = YES
   return
   end
# balpar - copy balanced paren string
   subroutine balpar
   character gettok
   character t, token(MAXTOK)
   integer nlpar

   if (gettok(token, MAXTOK) ~= LPAREN) {
      call synerr("missing left paren.")
      return
      $@$
   call outstr(token)
   nlpar = 1
   repeat {
      t = gettok(token, MAXTOK)
      if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) {
         call pbstr(token)
         break
         $@$
      if (t == NEWLINE)      # delete newlines
         token(1) = EOS
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      # else nothing special
      call outstr(token)
      $@$ until (nlpar <= 0)
   if (nlpar ~= 0)
      call synerr("missing parenthesis in condition.")
   return
   end
# brknxt - generate code for break and next
   subroutine brknxt(sp, lextyp, labval, token)
   integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token

   for (i = sp; i > 0; i = i - 1)
      if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO
        | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) {
         if (token == LEXBREAK)
            call outgo(labval(i)+1)
         else
            call outgo(labval(i))
         return
         $@$
   if (token == LEXBREAK)
      call synerr("illegal break.")
   else
      call synerr("illegal next.")
   return
   end
# close - exceedingly temporary version for gettok
   subroutine close(fd)
   integer fd

   rewind fd
   return
   end
# ctoi - convert string at in(i) to integer, increment i
   integer function ctoi(in, i)
   character in(ARB)
   integer index
   integer d, i
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/

   while (in(i) == BLANK | in(i) == TAB)
      i = i + 1
   for (ctoi = 0; in(i) ~= EOS; i = i + 1) {
      d = index(digits, in(i))
      if (d == 0)      # non-digit
         break
      ctoi = 10 * ctoi + d - 1
      $@$
   return
   end
# deftok - get token; process macro calls and invocations
   character function deftok(token, toksiz, fd)
   character gtok
   integer fd, toksiz
   character defn(MAXDEF), t, token(toksiz)
   integer lookup

   for (t=gtok(token, toksiz, fd); t~=EOF; t=gtok(token, toksiz, fd)) {
      if (t ~= ALPHA)   # non-alpha
         break
      if (lookup(token, defn) == NO)   # undefined
         break
      if (defn(1) == DEFTYPE) {   # get definition
         call getdef(token, toksiz, defn, MAXDEF, fd)
         call instal(token, defn)
         $@$
      else
         call pbstr(defn)   # push replacement onto input
      $@$
   deftok = t
   if (deftok == ALPHA)   # convert to single case
      call fold(token)
   return
   end

# fold - convert alphabetic token to single case
   subroutine fold(token)
   character token(ARB)
   integer i

   # WARNING - this routine depends heavily on the
   # fact that letters have been mapped into internal
   # right-adjusted ascii. god help you if you
   # have subverted this mechanism.

   for (i = 1; token(i) ~= EOS; i = i + 1)
      if (token(i) >= BIGA & token(i) <= BIGZ)
         token(i) = token(i) - BIGA + LETA
   return
   end
# docode - generate code for beginning of do
   subroutine docode(lab)
   integer labgen
   integer lab
#   string dostr "do"
   integer dostr(4)
   data dostr(1), dostr(2), dostr(3),
      dostr(4)/LETD, LETO, BLANK, EOS/

   call outtab
   call outstr(dostr)
   lab = labgen(2)
   call outnum(lab)
   call eatup
   call outdon
   return
   end
# dostat - generate code for end of do statement
   subroutine dostat(lab)
   integer lab

   call outcon(lab)
   call outcon(lab+1)
   return
   end
# eatup - process rest of statement; interpret continuations
   subroutine eatup
   character gettok
   character ptoken(MAXTOK), t, token(MAXTOK)
   integer nlpar

   nlpar = 0
   repeat {
      t = gettok(token, MAXTOK)
      if (t == SEMICOL | t == NEWLINE)
         break
      if (t == RBRACE) {
         call pbstr(token)
         break
         $@$
      if (t == LBRACE | t == EOF) {
         call synerr("unexpected brace or EOF.")
         call pbstr(token)
         break
         $@$
      if (t == COMMA | t == UNDERLINE) {
         if (gettok(ptoken, MAXTOK) ~= NEWLINE)
            call pbstr(ptoken)
         if (t == UNDERLINE)
            token(1) = EOS
         $@$
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      call outstr(token)
      $@$ until (nlpar < 0)
   if (nlpar ~= 0)
      call synerr("unbalanced parentheses.")
   return
   end
# elseif - generate code for end of if before else
   subroutine elseif(lab)
   integer lab

   call outgo(lab+1)
   call outcon(lab)
   return
   end
# equal - compare str1 to str2; return YES if equal, NO if not
   integer function equal(str1, str2)
   character str1(ARB), str2(ARB)
   integer i

   for (i = 1; str1(i) == str2(i); i = i + 1)
      if (str1(i) == EOS) {
         equal = YES
         return
         $@$
   equal = NO
   return
   end
# error - print fatal error message, then die
   subroutine error(buf)
   integer buf(ARB)

   call remark(buf)
   stop
   end
# forcod - beginning of for statement
   subroutine forcod(lab)
   character gettok
   character t, token(MAXTOK)
   integer length, labgen
   integer i, j, lab, nlpar
   include commonblocks
   # include cfor
#   string ifnot "if(.not."
   integer ifnot(9)
      data ifnot(1) /LETI/
      data ifnot(2) /LETF/
      data ifnot(3) /LPAREN/
      data ifnot(4) /PERIOD/
      data ifnot(5) /LETN/
      data ifnot(6) /LETO/
      data ifnot(7) /LETT/
      data ifnot(8) /PERIOD/
      data ifnot(9) /EOS/

   lab = labgen(3)
   call outcon(0)
   if (gettok(token, MAXTOK) ~= LPAREN) {
      call synerr("missing left paren.")
      return
      $@$
   if (gettok(token, MAXTOK) ~= SEMICOL) {   # real init clause
      call pbstr(token)
      call outtab
      call eatup
      call outdon
      $@$
   if (gettok(token, MAXTOK) == SEMICOL)   # empty condition
      call outcon(lab)
   else {   # non-empty condition
      call pbstr(token)
      call outnum(lab)
      call outtab
      call outstr(ifnot)
      call outch(LPAREN)
      nlpar = 0
      while (nlpar >= 0) {
         t = gettok(token, MAXTOK)
         if (t == SEMICOL)
            break
         if (t == LPAREN)
            nlpar = nlpar + 1
         else if (t == RPAREN)
            nlpar = nlpar - 1
         if (t ~= NEWLINE & t ~= UNDERLINE)
            call outstr(token)
         $@$
      call outch(RPAREN)
      call outch(RPAREN)
      call outgo(lab+2)
      if (nlpar < 0)
         call synerr("invalid for clause.")
      $@$
   fordep = fordep + 1   # stack reinit clause
   j = 1
   for (i = 1; i < fordep; i = i + 1)   # find end
      j = j + length(forstk(j)) + 1
   forstk(j) = EOS   # null, in case no reinit
   nlpar = 0
   while (nlpar >= 0) {
      t = gettok(token, MAXTOK)
      if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      if (nlpar >= 0 & t ~= NEWLINE & t ~= UNDERLINE) {
         call scopy(token, 1, forstk, j)
         j = j + length(token)
         $@$
      $@$
   lab = lab + 1   # label for next's
   return
   end
# fors - process end of for statement
   subroutine fors(lab)
   integer length
   integer i, j, lab
   include commonblocks
   # include cfor

   call outnum(lab)
   j = 1
   for (i = 1; i < fordep; i = i + 1)
      j = j + length(forstk(j)) + 1
   if (length(forstk(j)) > 0) {
      call outtab
      call outstr(forstk(j))
      call outdon
      $@$
   call outgo(lab-1)
   call outcon(lab+1)
   fordep = fordep - 1
   return
   end
# getch - get characters from file
   integer function getch(c, f)
   character inmap
   character buf(MAXLINE), c
   integer f, i, lastc
   data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/
   # note: MAXLINE = MAXCARD + 1

   if (buf(lastc) == NEWLINE | lastc >= MAXLINE) {
      read(f, 1, end=10) (buf(i), i = 1, MAXCARD)
         1 format(MAXCARD a1)
      for (i = 1; i <= MAXCARD; i = i + 1)
         buf(i) = inmap(buf(i))
      for (i = MAXCARD; i > 0; i = i - 1)
         if (buf(i) ~= BLANK)
            break
      buf(i+1) = NEWLINE
      lastc = 0
      $@$
   lastc = lastc + 1
   c = buf(lastc)
   getch = c
   return

 10   c = EOF
   getch = EOF
   return
   end
# getdef (for no arguments) - get name and definition
   subroutine getdef(token, toksiz, defn, defsiz, fd)
   character gtok, ngetch
   integer defsiz, fd, i, nlpar, toksiz
   character c, defn(defsiz), token(toksiz)

   if (ngetch(c, fd) ~= LPAREN)
      call remark("missing left paren.")
   if (gtok(token, toksiz, fd) ~= ALPHA)
      call remark("non-alphanumeric name.")
   else if (ngetch(c, fd) ~= COMMA)
      call remark("missing comma in define.")
   # else got (name,
   nlpar = 0
   for (i = 1; nlpar >= 0; i = i + 1)
      if (i > defsiz)
         call error("definition too long.")
      else if (ngetch(defn(i), fd) == EOF)
         call error("missing right paren.")
      else if (defn(i) == LPAREN)
         nlpar = nlpar + 1
      else if (defn(i) == RPAREN)
         nlpar = nlpar - 1
      # else normal character in defn(i)
   defn(i-1) = EOS
   return
   end
# gettok - get token. handles file inclusion and line numbers
   character function gettok(token, toksiz)
   integer equal, open
   integer junk, toksiz
   character deftok
   character name(MAXNAME), token(toksiz)
   include commonblocks
   # include cline
#   string incl "include"
   integer incl(8)
   data incl(1) /LETI/
   data incl(2) /LETN/
   data incl(3) /LETC/
   data incl(4) /LETL/
   data incl(5) /LETU/
   data incl(6) /LETD/
   data incl(7) /LETE/
   data incl(8) /EOS/

   for ( ; level > 0; level = level - 1) {
      for (gettok = deftok(token, toksiz, infile(level)); gettok ~= EOF;
         gettok = deftok(token, toksiz, infile(level))) {
         if (equal(token, incl) == NO)
            return
         junk = deftok(name, MAXNAME, infile(level))
         if (level >= NFILES)
            call synerr("includes nested too deeply.")
         else {
            infile(level+1) = open(name, READONLY)
            linect(level+1) = 1
            if (infile(level+1) == ERR)
               call synerr("can't open include.")
            else
               level = level + 1
            $@$
         $@$
      if (level > 1)
         call close(infile(level))
      $@$
   gettok = EOF
   return
   end
# gtok - get token for Ratfor
   character function gtok(lexstr, toksiz, fd)
   character ngetch, type
   integer fd, i, toksiz
   character c, lexstr(toksiz)
   include commonblocks
   # include cline

   while (ngetch(c, fd) ~= EOF)
      if (c ~= BLANK & c ~= TAB)
         break
   call putbak(c)
   for (i = 1; i < toksiz-1; i = i + 1) {
      gtok = type(ngetch(lexstr(i), fd))
      if (gtok ~= LETTER & gtok ~= DIGIT)
         break
      $@$
   if (i >= toksiz-1)
      call synerr("token too long.")
   if (i > 1) {            # some alpha seen
      call putbak(lexstr(i))      # went one too far
      lexstr(i) = EOS
      gtok = ALPHA
      $@$
   else if (lexstr(1) == DOLLAR) {   # allow $( and $) for { and $@$
      if (ngetch(lexstr(2), fd) == LPAREN) {
         lexstr(1) = LBRACE
         gtok = LBRACE
         $@$
      else if (lexstr(2) == RPAREN) {
         lexstr(1) = RBRACE
         gtok = RBRACE
         $@$
      else
         call putbak(lexstr(2))
      $@$
   else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) {
      for (i = 2; ngetch(lexstr(i), fd) ~= lexstr(1); i = i + 1)
         if (lexstr(i) == NEWLINE | i >= toksiz-1) {
            call synerr("missing quote.")
            lexstr(i) = lexstr(1)
            call putbak(NEWLINE)
            break
            $@$
      $@$
   else if (lexstr(1) == SHARP) {   # strip comments
      while (ngetch(lexstr(1), fd) ~= NEWLINE)
         ;
      gtok = NEWLINE
      $@$
   else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT
      | lexstr(1) == EQUALS | lexstr(1) == AMPER | lexstr(1) == BAR)
      call relate(lexstr, i, fd)
   lexstr(i+1) = EOS
   if (lexstr(1) == NEWLINE)
      linect(level) = linect(level) + 1
   return
   end
# ifcode - generate initial code for if
   subroutine ifcode(lab)
   integer labgen
   integer lab

   lab = labgen(2)
   call ifgo(lab)
   return
   end
# ifgo - generate "if(.not.(...))goto lab"
   subroutine ifgo(lab)
   integer lab
#   string ifnot "if(.not."
   integer ifnot(9)
      data ifnot(1) /LETI/
      data ifnot(2) /LETF/
      data ifnot(3) /LPAREN/
      data ifnot(4) /PERIOD/
      data ifnot(5) /LETN/
      data ifnot(6) /LETO/
      data ifnot(7) /LETT/
      data ifnot(8) /PERIOD/
      data ifnot(9) /EOS/

   call outtab         # get to column 7
   call outstr(ifnot)      # " if(.not. "
   call balpar         # collect and output condition
   call outch(RPAREN)      # " ) "
   call outgo(lab)      # " goto lab "
   return
   end
# index - find character  c  in string  str
   integer function index(str, c)
   character c, str(ARB)

   for (index = 1; str(index) ~= EOS; index = index + 1)
      if (str(index) == c)
         return
   index = 0
   return
   end
# initkw - install keyword "define" in table
   subroutine initkw
#   string defnam "define"
   integer defnam(7), deftyp(2)
   data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/
   data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/
   data defnam(7) /EOS/
   data deftyp(1), deftyp(2) /DEFTYPE, EOS/

   call instal(defnam, deftyp)
   return
   end
# inmap - convert left adjusted external rep to right adj ascii
   integer function inmap(inchar)
   integer i, inchar
   include commonblocks
   # include cchar

   if (inchar == extblk) {
      inmap = intblk
      return
      $@$
   do i = 1, 10
      if (inchar == extdig(i)) {
         inmap = intdig(i)
         return
         $@$
   do i = 1, 26
      if (inchar == extlet(i)) {
         inmap = intlet(i)
         return
         $@$
   do i = 1, 26
      if (inchar == extbig(i)) {
         inmap = intbig(i)
         return
         $@$
   do i = 1, NCHARS
      if (inchar == extchr(i)) {
         inmap = intchr(i)
         return
         $@$
   inmap = inchar
   return
   end
# instal - add name and definition to table
   subroutine instal(name, defn)
   character defn(MAXTOK), name(MAXDEF)
   integer length
   integer dlen, nlen
   include commonblocks
   # include clook

   nlen = length(name) + 1
   dlen = length(defn) + 1
   if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) {
      call putlin(name, ERROUT)
      call remark(": too many definitions.")
      $@$
   lastp = lastp + 1
   namptr(lastp) = lastt + 1
   call scopy(name, 1, table, lastt + 1)
   call scopy(defn, 1, table, lastt + nlen + 1)
   lastt = lastt + nlen + dlen
   return
   end
# itoc - convert integer  int  to char string in  str
   integer function itoc(int, str, size)
   integer abs, mod
   integer d, i, int, intval, j, k, size
   character str(size)
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/

   intval = abs(int)
   str(1) = EOS
   i = 1
   repeat {            # generate digits
      i = i + 1
      d = mod(intval, 10)
      str(i) = digits(d+1)
      intval = intval / 10
      $@$ until (intval == 0 | i >= size)
   if (int < 0 & i < size) {      # then sign
      i = i + 1
      str(i) = MINUS
      $@$
   itoc = i - 1
   for (j = 1; j < i; j = j + 1) {   # then reverse
      k = str(i)
      str(i) = str(j)
      str(j) = k
      i = i - 1
      $@$
   return
   end
# labelc - output statement number
   subroutine labelc(lexstr)
   character lexstr(ARB)
   integer length

   if (length(lexstr) == 5)   # warn about 23xxx labels
      if (lexstr(1) == DIG2 & lexstr(2) == DIG3)
         call synerr("warning: possible label conflict.")
   call outstr(lexstr)
   call outtab
   return
   end
# labgen - generate  n  consecutive labels, return first one
   integer function labgen(n)
   integer label, n
   data label /23000/

   labgen = label
   label = label + n
   return
   end
# length - compute length of string
   integer function length(str)
   integer str(ARB)

   for (length = 0; str(length+1) ~= EOS; length = length + 1)
      ;
   return
   end
# lex - return lexical type of token
   integer function lex(lexstr)
   character gettok
   character lexstr(MAXTOK)
   integer alldig, equal
   include commonblocks
   # include ckeywd

   while (gettok(lexstr, MAXTOK) == NEWLINE)
      ;
   lex = lexstr(1)
   if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE)
      return
   if (alldig(lexstr) == YES)
      lex = LEXDIGITS
   else if (equal(lexstr, sif) == YES)
      lex = vif(1)
   else if (equal(lexstr, selse) == YES)
      lex = velse(1)
   else if (equal(lexstr, swhile) == YES)
      lex = vwhile(1)
   else if (equal(lexstr, sdo) == YES)
      lex = vdo(1)
   else if (equal(lexstr, sbreak) == YES)
      lex = vbreak(1)
   else if (equal(lexstr, snext) == YES)
      lex = vnext(1)
   else if (equal(lexstr, sfor) == YES)
      lex = vfor(1)
   else if (equal(lexstr, srept) == YES)
      lex = vrept(1)
   else if (equal(lexstr, suntil) == YES)
      lex = vuntil(1)
   else
      lex = LEXOTHER
   return
   end
# lookup - locate name, extract definition from table
   integer function lookup(name, defn)
   character defn(MAXDEF), name(MAXTOK)
   integer i, j, k
   include commonblocks
   # include clook

   for (i = lastp; i > 0; i = i - 1) {
      j = namptr(i)
      for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1)
         j = j + 1
      if (name(k) == table(j)) {      # got one
         call scopy(table, j+1, defn, 1)
         lookup = YES
         return
         $@$
      $@$
   lookup = NO
   return
   end
# ngetch - get a (possibly pushed back) character
   character function ngetch(c, fd)
   character getch
   character c
   integer fd
   include commonblocks
   # include cdefio

   if (bp > 0)
      c = buf(bp)
   else {
      bp = 1
      buf(bp) = getch(c, fd)
      $@$
   bp = bp - 1
   ngetch = c
   return
   end
# open - exceedingly temporary version for gettok
   integer function open(name, mode)
   character name(MAXNAME)
   integer ctoi
   integer i, mode

   i = 1
   open = ctoi(name, i)
   return
   end
# otherc - output ordinary Fortran statement
   subroutine otherc(lexstr)
   character lexstr(ARB)

   call outtab
   call outstr(lexstr)
   call eatup
   call outdon
   return
   end
# outch - put one character into output buffer
   subroutine outch(c)
   character c
   integer i
   include commonblocks
   # include coutln

   if (outp >= 72) {   # continuation card
      call outdon
      for (i = 1; i < 6; i = i + 1)
         outbuf(i) = BLANK
      outbuf(6) = STAR
      outp = 6
      $@$
   outp = outp + 1
   outbuf(outp) = c
   return
   end
# outcon - output "n   continue"
   subroutine outcon(n)
   integer n
#   string contin "continue"
   integer contin(9)
   data contin(1) /LETC/
   data contin(2) /LETO/
   data contin(3) /LETN/
   data contin(4) /LETT/
   data contin(5) /LETI/
   data contin(6) /LETN/
   data contin(7) /LETU/
   data contin(8) /LETE/
   data contin(9) /EOS/

   if (n > 0)
      call outnum(n)
   call outtab
   call outstr(contin)
   call outdon
   return
   end
# outdon - finish off an output line
   subroutine outdon
   include commonblocks
   # include coutln

   outbuf(outp+1) = NEWLINE
   outbuf(outp+2) = EOS
   call putlin(outbuf, STDOUT)
   outp = 0
   return
   end
# outgo - output "goto  n"
   subroutine outgo(n)
   integer n
#   string goto "goto"
   integer goto(6)
   data goto(1) /LETG/
   data goto(2) /LETO/
   data goto(3) /LETT/
   data goto(4) /LETO/
   data goto(5) /BLANK/
   data goto(6) /EOS/

   call outtab
   call outstr(goto)
   call outnum(n)
   call outdon
   return
   end
# outmap - convert right adj ascii to left adjusted external rep
   integer function outmap(inchar)
   integer i, inchar
   include commonblocks
   # include cchar

   if (inchar == intblk) {
      outmap = extblk
      return
      $@$
   do i = 1, 10
      if (inchar == intdig(i)) {
         outmap = extdig(i)
         return
         $@$
   do i = 1, 26
      if (inchar == intlet(i)) {
         outmap = extlet(i)
         return
         $@$
   do i = 1, 26
      if (inchar == intbig(i)) {
         outmap = extbig(i)
         return
         $@$
   do i = 1, NCHARS
      if (inchar == intchr(i)) {
         outmap = extchr(i)
         return
         $@$
   outmap = inchar
   return
   end
# outnum - output decimal number
   subroutine outnum(n)
   character chars(MAXCHARS)
   integer itoc
   integer i, len, n

   len = itoc(n, chars, MAXCHARS)
   for (i = 1; i <= len; i = i + 1)
      call outch(chars(i))
   return
   end
# outstr - output string
   subroutine outstr(str)
   character c, str(ARB)
   integer i, j

   for (i = 1; str(i) ~= EOS; i = i + 1) {
      c = str(i)
      if (c ~= SQUOTE & c ~= DQUOTE)
         call outch(c)
      else {
         i = i + 1
         for (j = i; str(j) ~= c; j = j + 1)   # find end
            ;
         call outnum(j-i)
         call outch(LETH)
         for ( ; i < j; i = i + 1)
            call outch(str(i))
         $@$
      $@$
   return
   end
# outtab - get past column 6
   subroutine outtab
   include commonblocks
   # include coutln

   while (outp < 6)
      call outch(BLANK)
   return
   end
# parse - parse Ratfor source program
   subroutine parse
   character lexstr(MAXTOK)
   integer lex
   integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token

   call initkw   # install keywords in table
   sp = 1
   lextyp(1) = EOF
   for (token = lex(lexstr); token ~= EOF; token = lex(lexstr)) {
      if (token == LEXIF)
         call ifcode(lab)
      else if (token == LEXDO)
         call docode(lab)
      else if (token == LEXWHILE)
         call whilec(lab)
      else if (token == LEXFOR)
         call forcod(lab)
      else if (token == LEXREPEAT)
         call repcod(lab)
      else if (token == LEXDIGITS)
         call labelc(lexstr)
      else if (token == LEXELSE) {
         if (lextyp(sp) == LEXIF)
            call elseif(labval(sp))
         else
            call synerr("illegal else.")
         $@$
      if (token==LEXIF | token==LEXELSE | token==LEXWHILE
        | token==LEXFOR | token==LEXREPEAT
        | token==LEXDO | token==LEXDIGITS | token==LBRACE) {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call error("stack overflow in parser.")
         lextyp(sp) = token      # stack type and value
         labval(sp) = lab
         $@$
      else {      # end of statement - prepare to unstack
         if (token == RBRACE) {
            if (lextyp(sp) == LBRACE)
               sp = sp - 1
            else
               call synerr("illegal right brace.")
            $@$
         else if (token == LEXOTHER)
            call otherc(lexstr)
         else if (token == LEXBREAK | token == LEXNEXT)
            call brknxt(sp, lextyp, labval, token)
         token = lex(lexstr)      # peek at next token
         call pbstr(lexstr)
         call unstak(sp, lextyp, labval, token)
         $@$
      $@$
   if (sp ~= 1)
      call synerr("unexpected EOF.")
   return
   end
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(ARB)
   integer length
   integer i

   for (i = length(in); i > 0; i = i - 1)
      call putbak(in(i))
   return
   end
# putbak - push character back onto input
   subroutine putbak(c)
   character c
   include commonblocks
   # include cdefio

   bp = bp + 1
   if (bp > BUFSIZE)
      call error("too many characters pushed back.")
   buf(bp) = c
   return
   end
# putch (interim version)  put characters
   subroutine putch(c, f)
   integer buf(MAXLINE), c
   integer outmap
   integer f, i, lastc
   data lastc /0/

   if (lastc >= MAXLINE | c == NEWLINE) {
      if ( lastc <= 0 ) {
         write(f,2)
         2 format(/)
         $@$
      else {
         write(f, 1) (buf(i), i = 1, lastc)
         1 format(MAXCARD a1)
         $@$
      lastc = 0
      $@$
   if (c ~= NEWLINE) {
      lastc = lastc + 1
      buf(lastc) = outmap(c)
      $@$
   return
   end
# putlin - put out line by repeated calls to putch
   subroutine putlin(b, f)
   character b(ARB)
   integer f, i

   for (i = 1; b(i) ~= EOS; i = i + 1)
      call putch(b(i), f)
   return
   end
# relate - convert relational shorthands into long form
   subroutine relate(token, last, fd)
   character ngetch
   character token(ARB)
   integer length
   integer fd, last
#   string dotge ".ge."
#   string dotgt ".gt."
#   string dotlt ".lt."
#   string dotle ".le."
#   string dotne ".ne."
#   string dotnot ".not."
#   string doteq ".eq."
#   string dotand ".and."
#   string dotor ".or."
   integer dotge(5), dotgt(5), dotlt(5), dotle(5)
   integer dotne(5), dotnot(6), doteq(5), dotand(6), dotor(5)
   data dotge(1), dotge(2), dotge(3), dotge(4), dotge(5)/ PERIOD,
      LETG, LETE, PERIOD, EOS/
   data dotgt(1), dotgt(2), dotgt(3), dotgt(4), dotgt(5)/ PERIOD,
      LETG, LETT, PERIOD, EOS/
   data dotle(1), dotle(2), dotle(3), dotle(4), dotle(5)/ PERIOD,
      LETL, LETE, PERIOD, EOS/
   data dotlt(1), dotlt(2), dotlt(3), dotlt(4), dotlt(5)/ PERIOD,
      LETL, LETT, PERIOD, EOS/
   data dotne(1), dotne(2), dotne(3), dotne(4), dotne(5)/ PERIOD,
      LETN, LETE, PERIOD, EOS/
   data doteq(1), doteq(2), doteq(3), doteq(4), doteq(5)/ PERIOD,
      LETE, LETQ, PERIOD, EOS/
   data dotor(1), dotor(2), dotor(3), dotor(4), dotor(5)/ PERIOD,
      LETO, LETR, PERIOD, EOS/
   data dotand(1), dotand(2), dotand(3), dotand(4), dotand(5),
      dotand(6) /PERIOD, LETA, LETN, LETD, PERIOD, EOS/
   data dotnot(1), dotnot(2), dotnot(3), dotnot(4), dotnot(5),
      dotnot(6) /PERIOD, LETN, LETO, LETT, PERIOD, EOS/

   if (ngetch(token(2), fd) ~= EQUALS)
      call putbak(token(2))
   if (token(1) == GREATER) {
      if (token(2) == EQUALS)
         call scopy(dotge, 1, token, 1)
      else
         call scopy(dotgt, 1, token, 1)
      $@$
   else if (token(1) == LESS) {
      if (token(2) == EQUALS)
         call scopy(dotle, 1, token, 1)
      else
         call scopy(dotlt, 1, token, 1)
      $@$
   else if (token(1) == NOT) {
      if (token(2) == EQUALS)
         call scopy(dotne, 1, token, 1)
      else
         call scopy(dotnot, 1, token, 1)
      $@$
   else if (token(1) == EQUALS) {
      if (token(2) == EQUALS)
         call scopy(doteq, 1, token, 1)
      else
         token(2) = EOS
      $@$
   else if (token(1) == AMPER)
      call scopy(dotand, 1, token, 1)
   else if (token(1) == BAR)
      call scopy(dotor, 1, token, 1)
   else   # can't happen
      token(2) = EOS
   last = length(token)
   return
   end
# remark - print warning message
   # this version is intentionally crude, and should be replaced
   # instantaneously by something tuned for your
   # specific environment.
   subroutine remark(buf)
   integer buf(ARB), i

   write(ERROUT, 10) (buf(i), i = 1, 5)
      10 format(5a4)
   return
   end
# repcod - generate code for beginning of repeat
   subroutine repcod(lab)
   integer labgen
   integer lab

   call outcon(0)   # in case there was a label
   lab = labgen(3)
   call outcon(lab)
   lab = lab + 1   # label to go on next's
   return
   end
# scopy - copy string at from(i) to to(j)
   subroutine scopy(from, i, to, j)
   character from(ARB), to(ARB)
   integer i, j, k1, k2

   k2 = j
   for (k1 = i; from(k1) ~= EOS; k1 = k1 + 1) {
      to(k2) = from(k1)
      k2 = k2 + 1
      $@$
   to(k2) = EOS
   return
   end
# synerr - report Ratfor syntax error
   subroutine synerr(msg)
   character lc(MAXLINE), msg(MAXLINE)
   integer itoc
   integer i, junk
   include commonblocks
   # include cline

   call remark("error at line.")
   for (i = 1; i <= level; i = i + 1) {
      call putch(BLANK, ERROUT)
      junk = itoc(linect(i), lc, MAXLINE)
      call putlin(lc, ERROUT)
      $@$
   call putch(COLON, ERROUT)
   call putch(NEWLINE, ERROUT)
   call remark(msg)
   return
   end
# type - return LETTER, DIGIT or character
   # this one works with ascii alphabet
   integer function type(c)
   integer c

   if( c >= DIG0 & c <= DIG9 )
      type = DIGIT
   else if( c >= LETA & c <= LETZ )
      type = LETTER
   else if( c >= BIGA & c <= BIGZ )
      type = LETTER
   else
      type = c
   return
   end
# unstak - unstack at end of statement
   subroutine unstak(sp, lextyp, labval, token)
   integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token

   for ( ; sp > 1; sp = sp - 1) {
      if (lextyp(sp) == LBRACE)
         break
      if (lextyp(sp) == LEXIF & token == LEXELSE)
         break
      if (lextyp(sp) == LEXIF)
         call outcon(labval(sp))
      else if (lextyp(sp) == LEXELSE) {
         if (sp > 2)
            sp = sp - 1
         call outcon(labval(sp)+1)
         $@$
      else if (lextyp(sp) == LEXDO)
         call dostat(labval(sp))
      else if (lextyp(sp) == LEXWHILE)
         call whiles(labval(sp))
      else if (lextyp(sp) == LEXFOR)
         call fors(labval(sp))
      else if (lextyp(sp) == LEXREPEAT)
         call untils(labval(sp), token)
      $@$
   return
   end
# untils - generate code for until or end of repeat
   subroutine untils(lab, token)
   character ptoken(MAXTOK)
   integer lex
   integer junk, lab, token

   call outnum(lab)
   if (token == LEXUNTIL) {
      junk = lex(ptoken)
      call ifgo(lab-1)
      $@$
   else
      call outgo(lab-1)
   call outcon(lab+1)
   return
   end
# whilec - generate code for beginning of while
   subroutine whilec(lab)
   integer labgen
   integer lab

   call outcon(0)    # unlabeled continue, in case there was a label
   lab = labgen(2)
   call outnum(lab)
   call ifgo(lab+1)
   return
   end
# whiles - generate code for end of while
   subroutine whiles(lab)
   integer lab

   call outgo(lab)
   call outcon(lab+1)
   return
   end
========== miscellaneous support for all programs ==========
# cant - print cant open file message
   subroutine cant(buf)
   integer buf(MAXLINE)

   call putlin(buf, ERROUT)
   call error(" : can't open.")
   return
   end
# ctoi - convert string at in(i) to integer, increment i
   integer function ctoi(in, i)
   character in(ARB)
   integer index
   integer d, i
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/

   while (in(i) == BLANK | in(i) == TAB)
      i = i + 1
   for (ctoi = 0; in(i) ~= EOS; i = i + 1) {
      d = index(digits, in(i))
      if (d == 0)      # non-digit
         break
      ctoi = 10 * ctoi + d - 1
      $@$
   return
   end
# equal - compare str1 to str2; return YES if equal, NO if not
   integer function equal(str1, str2)
   character str1(ARB), str2(ARB)
   integer i

   for (i = 1; str1(i) == str2(i); i = i + 1)
      if (str1(i) == EOS) {
         equal = YES
         return
         $@$
   equal = NO
   return
   end
# error - print fatal error message, then die
   subroutine error(buf)
   integer buf(ARB)

   call remark(buf)
   stop
   end
# fcopy - copy file  in  to file  out
   subroutine fcopy(in, out)
   character buf(MAXLINE)
   integer getlin
   integer in, out

   while (getlin(buf, in) ~= EOF)
      call putlin(buf, out)
   return
   end
# index - find character  c  in string  str
   integer function index(str, c)
   character c, str(ARB)

   for (index = 1; str(index) ~= EOS; index = index + 1)
      if (str(index) == c)
         return
   index = 0
   return
   end

define(abs,iabs)
# itoc - convert integer  int  to char string in  str
   integer function itoc(int, str, size)
   integer abs, mod
   integer d, i, int, intval, j, k, size
   character str(size)
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/

   intval = abs(int)
   str(1) = EOS
   i = 1
   repeat {            # generate digits
      i = i + 1
      d = mod(intval, 10)
      str(i) = digits(d+1)
      intval = intval / 10
      $@$ until (intval == 0 | i >= size)
   if (int < 0 & i < size) {      # then sign
      i = i + 1
      str(i) = MINUS
      $@$
   itoc = i - 1
   for (j = 1; j < i; j = j + 1) {   # then reverse
      k = str(i)
      str(i) = str(j)
      str(j) = k
      i = i - 1
      $@$
   return
   end
# length - compute length of string
   integer function length(str)
   integer str(ARB)

   for (length = 0; str(length+1) ~= EOS; length = length + 1)
      ;
   return
   end

define(MAXCHARS,10)

# putdec - put decimal integer  n  in field width >= w
   subroutine putdec(n, w)
   character chars(MAXCHARS)
   integer itoc
   integer i, n, nd, w

   nd = itoc(n, chars, MAXCHARS)
   for (i = nd + 1; i <= w; i = i + 1)
      call putc(BLANK)
   for (i = 1; i <= nd; i = i + 1)
      call putc(chars(i))
   return
   end
# scopy - copy string at from(i) to to(j)
   subroutine scopy(from, i, to, j)
   character from(ARB), to(ARB)
   integer i, j, k1, k2

   k2 = j
   for (k1 = i; from(k1) ~= EOS; k1 = k1 + 1) {
      to(k2) = from(k1)
      k2 = k2 + 1
      $@$
   to(k2) = EOS
   return
   end
# type - determine type of character
   character function type(c)
   character c
   integer index
   integer upalf(27)
   integer lowalf(27)
   integer digits(11)
#   string digits "0123456789"
      data digits(1) /DIG0/
      data digits(2) /DIG1/
      data digits(3) /DIG2/
      data digits(4) /DIG3/
      data digits(5) /DIG4/
      data digits(6) /DIG5/
      data digits(7) /DIG6/
      data digits(8) /DIG7/
      data digits(9) /DIG8/
      data digits(10) /DIG9/
      data digits(11) /EOS/
#   string lowalf "abcdefghijklmnopqrstuvwxyz"
   data lowalf(01)/LETA/
   data lowalf(02)/LETB/
   data lowalf(03)/LETC/
   data lowalf(04)/LETD/
   data lowalf(05)/LETE/
   data lowalf(06)/LETF/
   data lowalf(07)/LETG/
   data lowalf(08)/LETH/
   data lowalf(09)/LETI/
   data lowalf(10)/LETJ/
   data lowalf(11)/LETK/
   data lowalf(12)/LETL/
   data lowalf(13)/LETM/
   data lowalf(14)/LETN/
   data lowalf(15)/LETO/
   data lowalf(16)/LETP/
   data lowalf(17)/LETQ/
   data lowalf(18)/LETR/
   data lowalf(19)/LETS/
   data lowalf(20)/LETT/
   data lowalf(21)/LETU/
   data lowalf(22)/LETV/
   data lowalf(23)/LETW/
   data lowalf(24)/LETX/
   data lowalf(25)/LETY/
   data lowalf(26)/LETZ/
   data lowalf(27)/EOS/
#   string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   data upalf(01) /BIGA/
   data upalf(02) /BIGB/
   data upalf(03) /BIGC/
   data upalf(04) /BIGD/
   data upalf(05) /BIGE/
   data upalf(06) /BIGF/
   data upalf(07) /BIGG/
   data upalf(08) /BIGH/
   data upalf(09) /BIGI/
   data upalf(10) /BIGJ/
   data upalf(11) /BIGK/
   data upalf(12) /BIGL/
   data upalf(13) /BIGM/
   data upalf(14) /BIGN/
   data upalf(15) /BIGO/
   data upalf(16) /BIGP/
   data upalf(17) /BIGQ/
   data upalf(18) /BIGR/
   data upalf(19) /BIGS/
   data upalf(20) /BIGT/
   data upalf(21) /BIGU/
   data upalf(22) /BIGV/
   data upalf(23) /BIGW/
   data upalf(24) /BIGX/
   data upalf(25) /BIGY/
   data upalf(26) /BIGZ/
   data upalf(27) /EOS/

   if (index(lowalf, c) > 0)
      type = LETTER
   else if (index(upalf, c) > 0)
      type = LETTER
   else if (index(digits, c) > 0)
      type = DIGIT
   else
      type = c
   return
   end
========== programs from chapter 1 ==========
# copy - copy input characters to output
   integer getc
   integer c

   while (getc(c) ~= EOF)
      call putc(c)
   stop
   end

# charcount - count characters in standard input
   character getc
   character c
   integer nc

   nc = 0
   while (getc(c) ~= EOF)
      nc = nc + 1
   call putdec(nc, 1)
   call putc(NEWLINE)
   stop
   end
# linecount - count lines in standard input
   character getc
   character c
   integer nl

   nl = 0
   while (getc(c) ~= EOF)
      if (c == NEWLINE)
         nl = nl + 1
   call putdec(nl, 1)
   call putc(NEWLINE)
   stop
   end
# wordcount - count words in standard input
   character getc
   character c
   integer inword, wc

   wc = 0
   inword = NO
   while (getc(c) ~= EOF)
      if (c == BLANK | c == NEWLINE | c == TAB)
         inword = NO
      else if (inword == NO) {
         inword = YES
         wc = wc + 1
         $@$
   call putdec(wc, 1)
   call putc(NEWLINE)
   stop
   end
# detab - convert tabs to equivalent number of blanks
   character getc
   character c
   integer tabpos
   integer col, i, tabs(MAXLINE)

   call settab(tabs)   # set initial tab stops
   col = 1
   while (getc(c) ~= EOF)
      if (c == TAB)
         repeat {
            call putc(BLANK)
            col = col + 1
            $@$ until (tabpos(col, tabs) == YES)
      else if (c == NEWLINE) {
         call putc(NEWLINE)
         col = 1
         $@$
      else {
         call putc(c)
         col = col + 1
         $@$
   stop
   end

# tabpos - return YES if col is a tab stop
   integer function tabpos(col, tabs)
   integer col, i, tabs(MAXLINE)

   if (col > MAXLINE)
      tabpos = YES
   else
      tabpos = tabs(col)
   return
   end

# settab - set initial tab stops
   subroutine settab(tabs)
   integer mod
   integer i, tabs(MAXLINE)

   for (i = 1; i <= MAXLINE; i = i + 1)
      if (mod(i, 8) == 1)
         tabs(i) = YES
      else
         tabs(i) = NO
   return
   end
#c  detab - convert tabs to equivalent number of blanks; Fortran version
   integer getc
   integer c
   integer tabpos
   integer col, i, tabs(MAXLINE)
#c
#c   set initial tab stops
   call settab(tabs)
   col = 1
10   if (getc(c) .eq. EOF)  goto 60
      if (c .ne. TAB)  goto 30
20         call putc(BLANK)
         col = col + 1
         if (tabpos(col, tabs) .ne. YES)  goto 20
         goto 50
#c      else if
30      if (c .ne. NEWLINE)  goto 40
         call putc(NEWLINE)
         col = 1
         goto 50
#c      else
40         call putc(c)
         col = col + 1
50      goto 10
60   stop
   end

#c  tabpos - return YES if col is a tab stop; Fortran version
   integer function tabpos(col, tabs)
   integer col, i, tabs(MAXLINE)
#c
   if (col .gt. MAXLINE) tabpos = YES
   if (col .le. MAXLINE) tabpos = tabs(col)
   return
   end

#c  settab - set initial tab stops; Fortran version
   subroutine settab(tabs)
   integer mod
   integer i, tabs(MAXLINE)
#c
   i = 1
10   if (i .gt. MAXLINE) goto 20
      if (mod(i, 8) .eq. 1) tabs(i) = YES
      if (mod(i, 8) .ne. 1) tabs(i) = NO
      i = i + 1
      goto 10
20   return
   end
/* copy _ copy input characters to output */
   copy: procedure options (main);
   declare getc entry (fixed binary) returns (fixed binary);
   declare putc entry (fixed binary);
   declare c fixed binary;

   do while (getc(c) ~= EOF);
      call putc(c);
      end;
   end copy;
/* detab _ convert tabs into equivalent number of blanks */
   detab: procedure options (main);
   declare getc entry (fixed binary) returns (fixed binary);
   declare putc entry (fixed binary);
   declare c fixed binary;
   declare settab entry ((*)fixed binary);
   declare tabpos entry (fixed bin, (*)fixed bin) returns (fixed bin);
   declare (col, tabs(MAXLINE)) fixed binary;

   call settab(tabs);   /* set initial tab stops */
   col = 1;
   do while (getc(c) ~= EOF);
      if c = TAB then do;
         loop:
         call putc(BLANK);
         col = col + 1;
         if tabpos(col, tabs) ~= YES then
            goto loop;
         end;
      else if c = NEWLINE then do;
         call putc(NEWLINE);
         col = 1;
         end;
      else do;
         call putc(c);
         col = col + 1;
         end;
      end;
   end detab;

/* tabpos _ return YES if col is a tab stop */
   tabpos: procedure (col, tabs) returns (fixed binary);
   declare (col, tabs(*)) fixed binary;

   if col > MAXLINE then
      return(YES);
   else
      return(tabs(col));
   end tabpos;

/* settab _ set initial tab stops */
   settab: procedure (tabs);
   declare (i, tabs(*)) fixed binary;

   do i = 1 to MAXLINE;
      if mod(i, 8) = 1 then
         tabs(i) = YES;
      else
         tabs(i) = NO;
      end;
   end settab;
========== smaller programs from chapter 2 ==========
# entab - replace blanks by tabs and blanks
   character getc
   character c
   integer tabpos
   integer col, i, newcol, tabs(MAXLINE)

   call settab(tabs)
   col = 1
   repeat {
      newcol = col
      while (getc(c) == BLANK) {   # collect blanks
         newcol = newcol + 1
         if (tabpos(newcol, tabs) == YES) {
            call putc(TAB)
            col = newcol
            $@$
         $@$
      for ( ; col < newcol; col = col + 1)
         call putc(BLANK)      # output leftover blanks
      if (c == EOF)
         break
      call putc(c)
      if (c == NEWLINE)
         col = 1
      else
         col = col + 1
      $@$
   stop
   end

# tabpos - return YES if col is a tab stop
   integer function tabpos(col, tabs)
   integer col, i, tabs(MAXLINE)

   if (col > MAXLINE)
      tabpos = YES
   else
      tabpos = tabs(col)
   return
   end

# settab - set initial tab stops
   subroutine settab(tabs)
   integer mod
   integer i, tabs(MAXLINE)

   for (i = 1; i <= MAXLINE; i = i + 1)
      if (mod(i, 8) == 1)
         tabs(i) = YES
      else
         tabs(i) = NO
   return
   end
define(NOSKIP,PLUS)
define(SKIP,STAR)
# overstrike - convert backspaces into multiple lines
   character getc
   character c
   integer max
   integer col, newcol

   col = 1
   repeat {
      newcol = col
      while (getc(c) == BACKSPACE)   # eat up backspaces
         newcol = max(newcol-1, 1)
      if (newcol < col) {         # start overstrike line
         call putc(NEWLINE)
         call putc(NOSKIP)
         for (col = 1; col < newcol; col = col + 1)
            call putc(BLANK)
         $@$
      else if (col == 1 & c ~= EOF)   # start normal line
         call putc(SKIP)
                     # else middle of line
      if (c == EOF)
         break
      call putc(c)            # normal character
      if (c == NEWLINE)
         col = 1
      else
         col = col + 1
      $@$
   stop
   end
define(RCODE,STAR)
define(MAXCHUNK,10)
define(THRESH,5)
# compress - compress standard input
   character getc
   character buf(MAXCHUNK), c, lastc
   integer nrep, nsave
   # must have RCODE > MAXCHUNK or RCODE = 0

   nsave = 0
   for (lastc = getc(lastc); lastc ~= EOF; lastc = c) {
      for (nrep = 1; getc(c) == lastc; nrep = nrep + 1)
         if (nrep >= MAXCHUNK)   # count repetitions
            break
      if (nrep < THRESH)         # append short string
         for ( ; nrep > 0; nrep = nrep - 1) {
            nsave = nsave + 1
            buf(nsave) = lastc
            if (nsave >= MAXCHUNK)
               call putbuf(buf, nsave)
            $@$
      else {
         call putbuf(buf, nsave)
         call putc(RCODE)
         call putc(lastc)
         call putc(nrep)
         $@$
      $@$
   call putbuf(buf, nsave)   # put last chunk
   stop
   end

# putbuf - output buf(1) ... buf(nsave), clear nsave
   subroutine putbuf(buf, nsave)
   character buf(MAXCHUNK)
   integer i, nsave

   if (nsave > 0) {
      call putc(nsave)
      for (i = 1; i <= nsave; i = i + 1)
         call putc(buf(i))
      $@$
   nsave = 0
   return
   end
define(RCODE,STAR)
# expand - uncompress standard input
   character getc
   character c, code

   while (getc(code) ~= EOF)
      if (code == RCODE) {   # expand repetition
         if (getc(c) == EOF)
            break
         if (getc(code) == EOF)
            break
         for ( ; code > 0; code = code - 1)
            call putc(c)
         $@$
      else {            # expand chunk
         for ( ; code > 0; code = code - 1) {
            if (getc(c) == EOF)
               break
            call putc(c)
            $@$
         if (c == EOF)
            break
         $@$
   stop
   end
define(MAXKEY,50)
# crypt - encrypt and decrypt
   character getc, xor
   character c, key(MAXKEY)
   integer getarg, mod
   integer i, keylen

   keylen = getarg(1, key, MAXKEY)
   if (keylen == EOF)
      call error("usage: crypt key.")
   for (i = 1; getc(c) ~= EOF; i = mod(i, keylen) + 1)
      call putc(xor(c, key(i)))
   stop
   end
# xor - exclusive-or of  a  and  b
   character function xor(a, b)
   character and, not, or
   character a, b

   xor = or(and(a, not(b)), and(not(a), b))
   return
   end
========== translit program from chapter 2 ==========
define(MAXARR,100)
define(MAXSET,100)
define(ESCAPE,ATSIGN)
define(DASH,MINUS)
define(NOT,BANG)
# addset - put  c  in  set(j)  if it fits,  increment  j
   integer function addset(c, set, j, maxsiz)
   integer j, maxsiz
   character c, set(maxsiz)

   if (j > maxsiz)
      addset = NO
   else {
      set(j) = c
      j = j + 1
      addset = YES
      $@$
   return
   end
# dodash - expand array(i-1)-array(i+1) into set(j)... from valid
   subroutine dodash(valid, array, i, set, j, maxset)
   character esc
   integer addset, index
   integer i, j, junk, k, limit, maxset
   character array(ARB), set(maxset), valid(ARB)

   i = i + 1
   j = j - 1
   limit = index(valid, esc(array, i))
   for (k = index(valid, set(j)); k <= limit; k = k + 1)
      junk = addset(valid(k), set, j, maxset)
   return
   end
# esc - map  array(i)  into escaped character if appropriate
   character function esc(array, i)
   character array(ARB)
   integer i

   if (array(i) ~= ESCAPE)
      esc = array(i)
   else if (array(i+1) == EOS)   # \*a not special at end
      esc = ESCAPE
   else {
      i = i + 1
      if (array(i) == LETN)
         esc = NEWLINE
      else if (array(i) == LETT)
         esc = TAB
      else
         esc = array(i)
      $@$
   return
   end
# filset - expand set at  array(i)  into  set(j),  stop at  delim
   subroutine filset(delim, array, i, set, j, maxset)
   character esc
   integer addset, index
   integer i, j, junk, maxset
   character array(ARB), delim, set(maxset)
#   string digits "0123456789"
   integer digits(11)
#   string lowalf "abcdefghijklmnopqrstuvwxyz"
   integer lowalf(27)
#   string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   integer upalf(27)
   data digits(1)/DIG0/, digits(2)/DIG1/, digits(3)/DIG2/
   data digits(4)/DIG3/, digits(5)/DIG4/, digits(6)/DIG5/
   data digits(7)/DIG6/, digits(8)/DIG7/, digits(9)/DIG8/
   data digits(10)/DIG9/, digits(11)/EOS/
   data lowalf(01)/LETA/
   data lowalf(02)/LETB/
   data lowalf(03)/LETC/
   data lowalf(04)/LETD/
   data lowalf(05)/LETE/
   data lowalf(06)/LETF/
   data lowalf(07)/LETG/
   data lowalf(08)/LETH/
   data lowalf(09)/LETI/
   data lowalf(10)/LETJ/
   data lowalf(11)/LETK/
   data lowalf(12)/LETL/
   data lowalf(13)/LETM/
   data lowalf(14)/LETN/
   data lowalf(15)/LETO/
   data lowalf(16)/LETP/
   data lowalf(17)/LETQ/
   data lowalf(18)/LETR/
   data lowalf(19)/LETS/
   data lowalf(20)/LETT/
   data lowalf(21)/LETU/
   data lowalf(22)/LETV/
   data lowalf(23)/LETW/
   data lowalf(24)/LETX/
   data lowalf(25)/LETY/
   data lowalf(26)/LETZ/
   data lowalf(27)/EOS/
   data upalf(01) /BIGA/
   data upalf(02) /BIGB/
   data upalf(03) /BIGC/
   data upalf(04) /BIGD/
   data upalf(05) /BIGE/
   data upalf(06) /BIGF/
   data upalf(07) /BIGG/
   data upalf(08) /BIGH/
   data upalf(09) /BIGI/
   data upalf(10) /BIGJ/
   data upalf(11) /BIGK/
   data upalf(12) /BIGL/
   data upalf(13) /BIGM/
   data upalf(14) /BIGN/
   data upalf(15) /BIGO/
   data upalf(16) /BIGP/
   data upalf(17) /BIGQ/
   data upalf(18) /BIGR/
   data upalf(19) /BIGS/
   data upalf(20) /BIGT/
   data upalf(21) /BIGU/
   data upalf(22) /BIGV/
   data upalf(23) /BIGW/
   data upalf(24) /BIGX/
   data upalf(25) /BIGY/
   data upalf(26) /BIGZ/
   data upalf(27) /EOS/

   for ( ; array(i) ~= delim & array(i) ~= EOS; i = i + 1)
      if (array(i) == ESCAPE)
         junk = addset(esc(array, i), set, j, maxset)
      else if (array(i) ~= DASH)
         junk = addset(array(i), set, j, maxset)
      else if (j <= 1 | array(i+1) == EOS)   # literal -
         junk = addset(DASH, set, j, maxset)
      else if (index(digits, set(j-1)) > 0)
         call dodash(digits, array, i, set, j, maxset)
      else if (index(lowalf, set(j-1)) > 0)
         call dodash(lowalf, array, i, set, j, maxset)
      else if (index(upalf, set(j-1)) > 0)
         call dodash(upalf, array, i, set, j, maxset)
      else
         junk = addset(DASH, set, j, maxset)
   return
   end
# makset - make set from  array(k)  in  set
   integer function makset(array, k, set, size)
   integer addset
   integer i, j, k, size
   character array(ARB), set(size)

   i = k
   j = 1
   call filset(EOS, array, i, set, j, size)
   makset = addset(EOS, set, j, size)
   return
   end
# translit - map characters
   character getc
   character arg(MAXARR), c, from(MAXSET), to(MAXSET)
   integer getarg, length, makset, xindex
   integer allbut, collap, i, lastto

   if (getarg(1, arg, MAXARR) == EOF)
      call error("usage: translit from to.")
   else if (arg(1) == NOT) {
      allbut = YES
      if (makset(arg, 2, from, MAXSET) == NO)
         call error("from: too large.")
      $@$
   else {
      allbut = NO
      if (makset(arg, 1, from, MAXSET) == NO)
         call error("from: too large.")
      $@$
   if (getarg(2, arg, MAXARR) == EOF)
      to(1) = EOS
   else if (makset(arg, 1, to, MAXSET) == NO)
         call error("to: too large.")

   lastto = length(to)
   if (length(from) > lastto | allbut == YES)
      collap = YES
   else
      collap = NO
   repeat {
      i = xindex(from, getc(c), allbut, lastto)
      if (collap == YES & i >= lastto & lastto > 0) {  # collapse
         call putc(to(lastto))
         repeat
            i = xindex(from, getc(c), allbut, lastto)
            until (i < lastto)
         $@$
      if (c == EOF)
         break
      if (i > 0 & lastto > 0)   # translate
         call putc(to(i))
      else if (i == 0)      # copy
         call putc(c)
                  # else delete
      $@$
   stop
   end
# xindex - invert condition returned by index
   integer function xindex(array, c, allbut, lastto)
   character array(ARB), c
   integer index
   integer allbut, lastto

   if (c == EOF)
      xindex = 0
   else if (allbut == NO)
      xindex = index(array, c)
   else if (index(array, c) > 0)
      xindex = 0
   else
      xindex = lastto + 1
   return
   end
========== smaller programs from chapter 3 ==========
define(INFILE1,1)
define(INFILE2,2)
define(NAMESIZE,50)
# compare  (simple version) - compare file 1 to file 2
   character line1(MAXLINE), line2(MAXLINE)
   integer equal, getlin
   integer lineno, m1, m2

   lineno = 0
   repeat {
      m1 = getlin(line1, INFILE1)
      m2 = getlin(line2, INFILE2)
      if (m1 == EOF | m2 == EOF)
         break
      lineno = lineno + 1
      if (equal(line1, line2) == NO)
         call difmsg(lineno, line1, line2)
      $@$
   if (m1 == EOF & m2 ~= EOF)
      call remark("eof on file 1.")
   else if (m2 == EOF & m1 ~= EOF)
      call remark("eof on file 2.")
   # else they match
   stop
   end

# difmsg - print line numbers and differing lines
   subroutine difmsg(lineno, line1, line2)
   character line1(ARB), line2(ARB)
   integer lineno

   call putdec(lineno, 5)
   call putc(NEWLINE)
   call putlin(line1, STDOUT)
   call putlin(line2, STDOUT)
   return
   end
define(NAMESIZE,50)
# compare - compare two files for equality
   character arg1(MAXLINE), arg2(MAXLINE)
   character line1(MAXLINE), line2(MAXLINE)
   integer equal, getarg, getlin, open
   integer infil1, infil2, lineno, m1, m2

   if (getarg(1, arg1, MAXLINE) == EOF
      | getarg(2, arg2, MAXLINE) == EOF)
      call error("usage: compare file1 file2.")
   infil1 = open(arg1, READ)
   if (infil1 == ERR)
      call cant(arg1)
   infil2 = open(arg2, READ)
   if (infil2 == ERR)
      call cant(arg2)
   lineno = 0
   repeat {
      m1 = getlin(line1, infil1)
      m2 = getlin(line2, infil2)
      if (m1 == EOF | m2 == EOF)
         break
      lineno = lineno + 1
      if (equal(line1, line2) == NO)
         call difmsg(lineno, line1, line2)
      $@$
   if (m1 == EOF & m2 ~= EOF)
      call remark("eof on file 1.")
   else if (m2 == EOF & m1 ~= EOF)
      call remark("eof on file 2.")
   stop
   end

#difmsg
   subroutine difmsg(lineno, line1, line2)
   integer line1(MAXLINE), line2(MAXLINE)
   integer lineno

   call putdec(lineno, 5)
   call putc(NEWLINE)
   call putlin(line1, STDOUT)
   call putlin(line2, STDOUT)
   return
   end
define(NFILES,5)
# include - replace  include file  by contents of file
   character line(MAXLINE), str(MAXLINE)
   integer equal, getlin, getwrd, open
   integer infile(NFILES), len, level, loc
#   string incl "include"
   integer incl(8)
   data incl(1) /LETI/
   data incl(2) /LETN/
   data incl(3) /LETC/
   data incl(4) /LETL/
   data incl(5) /LETU/
   data incl(6) /LETD/
   data incl(7) /LETE/
   data incl(8) /EOS/

   infile(1) = STDIN
   for (level = 1; level > 0; level = level - 1) {
      while (getlin(line, infile(level)) ~= EOF) {
         loc = 1
         len = getwrd(line, loc, str)
         if (equal(str, incl) == NO)
            call putlin(line, STDOUT)
         else {
            level = level + 1
            if (level > NFILES)
               call error("includes nested too deeply.")
            len = getwrd(line, loc, str)
            infile(level) = open(str, READ)
            if (infile(level) == ERR)
               call cant(str)
            $@$
         $@$
      if (level > 1)
         call close(infile(level))
      $@$
   stop
   end
# getwrd - get non-blank word from in(i) into  out, increment i
   integer function getwrd(in, i, out)
   character in(ARB), out(ARB)
   integer i, j

   while (in(i) == BLANK | in(i) == TAB)
      i = i + 1
   j = 1
   while (in(i) ~= EOS & in(i) ~= BLANK
      & in(i) ~= TAB & in(i) ~= NEWLINE) {
      out(j) = in(i)
      i = i + 1
      j = j + 1
      $@$
   out(j) = EOS
   getwrd = j - 1
   return
   end

define(NAMESIZE,50)
# concat - concatenate named files onto standard output
   character name(NAMESIZE)
   integer getarg, open
   integer fin, i

   for (i = 1; getarg(i, name, NAMESIZE) ~= EOF; i = i + 1) {
      fin = open(name, READ)
      if (fin == ERR)
         call cant(name)
      call fcopy(fin, STDOUT)
      call close(fin)
      $@$
   stop
   end
define(NAMESIZE,50)
define(MARGIN1,3)
define(MARGIN2,2)
define(MARGIN3,2)
define(MARGIN4,3)
define(BOTTOM,60)
define(PAGELEN,66)
# print - print files with headings
   character name(NAMESIZE)
   integer getarg, open
   integer fin, i

   for (i = 1; getarg(i, name, NAMESIZE) ~= EOF; i = i + 1) {
      fin = open(name, READ)
      if (fin == ERR)
         call cant(name)
      call fprint(name, fin)
      call close(fin)
      $@$
   stop
   end

# fprint - print file "name" from  fin
   subroutine fprint(name, fin)
   character line(MAXLINE), name(NAMESIZE)
   integer getlin, open
   integer fin, lineno, pageno

   pageno = 0
   lineno = 0
   while (getlin(line, fin) ~= EOF) {
      if (lineno == 0) {
         call skip(MARGIN1)
         pageno = pageno + 1
         call head(name, pageno)
         call skip(MARGIN2)
         lineno = MARGIN1 + MARGIN2 + 1
         $@$
      call putlin(line, STDOUT)
      lineno = lineno + 1
      if (lineno >= BOTTOM) {
         call skip(PAGELEN-lineno)
         lineno = 0
         $@$
      $@$
   if (lineno > 0)
      call skip(PAGELEN-lineno)
   return
   end

# skip - output  n  blank lines
   subroutine skip(n)
   integer i, n

   for (i = 1; i <= n; i = i + 1)
      call putc(NEWLINE)
   return
   end

# head - print top of page header
   subroutine head(name, pageno)
   character name(NAMESIZE)
   integer pageno
#   string page " Page  "
   integer page(7)
   data page(1) /BLANK/
   data page(2) /LETP/
   data page(3) /LETA/
   data page(4) /LETG/
   data page(5) /LETE/
   data page(6) /BLANK/
   data page(7) /EOS/

   call putlin(name, STDOUT)
   call putlin(page, STDOUT)
   call putdec(pageno, 1)
   call putc(NEWLINE)
   return
   end
define(NAMESIZE,50)
define(MARGIN1,3)
define(MARGIN2,2)
define(MARGIN3,2)
define(MARGIN4,3)
define(BOTTOM,60)
define(PAGELEN,66)
# print  (default input STDIN) - print files with headings
   character name(NAMESIZE)
   integer getarg, open
   integer fin, i
#   string null ""
   integer null(1)
   data null(1) /EOS/

   for (i = 1; getarg(i, name, NAMESIZE) ~= EOF; i = i + 1) {
      fin = open(name, READ)
      if (fin == ERR)
         call cant(name)
      call fprint(name, fin)
      call close(fin)
      $@$
   if (i == 1)      # no files specified
      call fprint(null, STDIN)
   stop
   end

# fprint - print file "name" from  fin
   subroutine fprint(name, fin)
   integer line(MAXLINE), name(NAMESIZE)
   integer getlin, open
   integer fin, lineno, pageno

   pageno = 0
   lineno = 0
   while (getlin(line, fin) ~= EOF) {
      if (lineno == 0) {
         call skip(MARGIN1)
         pageno = pageno + 1
         call head(name, pageno)
         call skip(MARGIN2)
         lineno = MARGIN1 + MARGIN2 + 1
         $@$
      call putlin(line, STDOUT)
      lineno = lineno + 1
      if (lineno >= BOTTOM) {
         call skip(PAGELEN-lineno)
         lineno = 0
         $@$
      $@$
   if (lineno > 0)
      call skip(PAGELEN-lineno)
   return
   end

# skip - output  n  blank lines
   subroutine skip(n)
   integer i, n

   for (i = 1; i <= n; i = i + 1)
      call putc(NEWLINE)
   return
   end

# head - print top of page header
   subroutine head(name, pageno)
   integer name(NAMESIZE)
   integer pageno
#   string page " Page  "
   integer page(7)
   data page(1) /BLANK/
   data page(2) /LETP/
   data page(3) /LETA/
   data page(4) /LETG/
   data page(5) /LETE/
   data page(6) /BLANK/
   data page(7) /EOS/

   call putlin(name, STDOUT)
   call putlin(page, STDOUT)
   call putdec(pageno, 1)
   call putc(NEWLINE)
   return
   end
define(NAMESIZE,50)
# makecopy - copy one file to another
   character iname(NAMESIZE), oname(NAMESIZE)
   integer create, getarg, open
   integer fin, fout

   if (getarg(1, iname, NAMESIZE) == EOF
      | getarg(2, oname, NAMESIZE) == EOF)
      call error("usage: makecopy input output.")
   fin = open(iname, READ)
   if (fin == ERR)
      call cant(iname)
   fout = create(oname, WRITE)
   if (fout == ERR)
      call cant(oname)
   call fcopy(fin, fout)
   call close(fin)
   call close(fout)
   stop
   end
========== archive program from chapter 3 ==========
define(NAMESIZE,20)
define(MAXFILES,5)

define(TBL,LETT)
define(PRINT,LETP)
define(EXTR,LETX)
define(UPD,LETU)
define(DEL,LETD)
common /carch/ fname(NAMESIZE,MAXFILES),fstat(MAXFILES),nfiles,errcnt
   character fname      # file arguments
   integer fstat      # YES if touched, NO otherwise; init = NO
   integer nfiles      # number of file args
   integer errcnt      # error count; init = 0
# acopy - copy  size  characters from  fdi  to  fdo
   subroutine acopy(fdi, fdo, size)
   character getch
   character c
   integer fdi, fdo, i, size

   for (i = 1; i <= size; i = i + 1) {
      if (getch(c, fdi) == EOF)
         break
      call putch(c, fdo)
      $@$
   return
   end
# addfil - add file "name"  to archive
   subroutine addfil(name, fd, errcnt)
   character head(MAXLINE), name(ARB)
   integer open
   integer errcnt, fd, nfd

   nfd = open(name, READ)
   if (nfd == ERR) {
      call putlin(name, ERROUT)
      call remark(": can't add.")
      errcnt = errcnt + 1
      $@$
   if (errcnt == 0) {
      call makhdr(name, head)
      call putlin(head, fd)
      call fcopy(nfd, fd)
      call close(nfd)
      $@$
   return
   end
# amove - move  name1  to  name2
   subroutine amove(name1, name2)
   character name1(ARB), name2(ARB)
   integer create, open
   integer fd1, fd2

   fd1 = open(name1, READ)
   if (fd1 == ERR)
      call cant(name1)
   fd2 = create(name2, WRITE)
   if (fd2 == ERR)
      call cant(name2)
   call fcopy(fd1, fd2)
   return
   end
# archive - file maintainer
   character aname(NAMESIZE)
   integer getarg
   integer comand(2)

   if (getarg(1, comand, 2) == EOF
      | getarg(2, aname, NAMESIZE) == EOF)
      call help
   call getfns
   if (comand(1) == UPD)
      call update(aname)
   else if (comand(1) == TBL)
      call table(aname)
   else if (comand(1) == EXTR | comand(1) == PRINT)
      call extrac(aname, comand(1))
   else if (comand(1) == DEL)
      call delete(aname)
   else
      call help
   stop
   end
# block data for archive
   block data
   include carch
   data errcnt /0/
   end
# delete - delete files from archive
   subroutine delete(aname)
   character aname(NAMESIZE), in(MAXLINE)
   integer create, open
   integer afd, tfd
   include carch
#   string tname "archtemp"
   integer tname(9)
   data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/
   data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/
   data tname(9)/EOS/

   if (nfiles <= 0)   # protect innocents
      call error("delete by name only.")
   afd = open(aname, READWRITE)
   if (afd == ERR)
      call cant(aname)
   tfd = create(tname, READWRITE)
   if (tfd == ERR)
      call cant(tname)
   call replac(afd, tfd, DEL, errcnt)
   call notfnd
   call close(afd)
   call close(tfd)
   if (errcnt == 0)
      call amove(tname, aname)
   else
      call remark("fatal errors - archive not altered.")
   call remove(tname)
   return
   end
# extrac - extract files from archive
   subroutine extrac(aname, cmd)
   character aname(NAMESIZE), ename(NAMESIZE), in(MAXLINE)
   integer create, filarg, gethdr, open
   integer afd, cmd, efd, size
   include carch

   afd = open(aname, READ)
   if (afd == ERR)
      call cant(aname)
   if (cmd == PRINT)
      efd = STDOUT
   else
      efd = ERR
   while (gethdr(afd, in, ename, size) ~= EOF)
      if (filarg(ename) == NO)
         call fskip(afd, size)
      else {
         if (efd ~= STDOUT)
            efd = create(ename, WRITE)
         if (efd == ERR) {
            call putlin(ename, ERROUT)
            call remark(": can't create.")
            errcnt = errcnt + 1
            call fskip(afd, size)
            $@$
         else {
            call acopy(afd, efd, size)
            if (efd ~= STDOUT)
               call close(efd)
            $@$
         $@$
   call notfnd
   return
   end
# filarg - check if name matches argument list
   integer function filarg(name)
   character name(ARB)
   integer equal, getarg
   integer i
   include carch

   if (nfiles <= 0) {
      filarg = YES
      return
      $@$
   for (i = 1; i <= nfiles; i = i + 1)
      if (equal(name, fname(1, i)) == YES) {
         fstat(i) = YES
         filarg = YES
         return
         $@$
   filarg = NO
   return
   end
# fsize - size of file in characters
   integer function fsize(name)
   character getch
   character c, name(ARB)
   integer open
   integer fd

   fd = open(name, READ)
   if (fd == ERR)
      fsize = ERR
   else {
      for (fsize = 0; getch(c, fd) ~= EOF; fsize = fsize + 1)
         ;
      call close(fd)
      $@$
   return
   end
# fskip - skip  n  characters on file  fd
   subroutine fskip(fd, n)
   character getch
   character c
   integer fd, i, n

   for (i = 1; i <= n; i = i + 1)
      if (getch(c, fd) == EOF)
         break
   return
   end
# getfns - get file names into fname, check for duplicates
   subroutine getfns
   integer equal, getarg
   integer i, j
   include carch

   errcnt = 0
   for (i = 1; i <= MAXFILES; i = i + 1)
      if (getarg(i+2, fname(1, i), NAMESIZE) == EOF)
         break
   nfiles = i - 1
   if (i > MAXFILES)
      if (getarg(i+2, j, 1) ~= EOF)
         call error("too many file names.")
   for (i = 1; i <= nfiles; i = i + 1)
      fstat(i) = NO
   for (i = 1; i < nfiles; i = i + 1)
      for (j = i + 1; j <= nfiles; j = j + 1)
         if (equal(fname(1, i), fname(1, j)) == YES) {
            call putlin(fname(1, i), ERROUT)
            call error(": duplicate file name.")
            $@$
   return
   end
# gethdr - get header info from  fd
   integer function gethdr(fd, buf, name, size)
   character buf(MAXLINE), c, name(NAMESIZE), temp(NAMESIZE)
   integer ctoi, equal, getlin, getwrd
   integer fd, i, len, size
#   string hdr "-h-"
   integer hdr(4)
   data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/

   if (getlin(buf, fd) == EOF) {
      gethdr = EOF
      return
      $@$
   i = 1
   len = getwrd(buf, i, temp)
   if (equal(temp, hdr) == NO)
      call error("archive not in proper format.")
   gethdr = YES
   len = getwrd(buf, i, name)
   size = ctoi(buf, i)
   return
   end
# getwrd - get non-blank word from in(i) into  out, increment i
   integer function getwrd(in, i, out)
   integer in(ARB), out(ARB)
   integer i, j

   while (in(i) == BLANK | in(i) == TAB)
      i = i + 1
   j = 1
   while (in(i)~=EOS & in(i)~=BLANK & in(i)~=TAB & in(i)~=NEWLINE) {
      out(j) = in(i)
      i = i + 1
      j = j + 1
      $@$
   out(j) = EOS
   getwrd = j - 1
   return
   end
# help - diagnostic printout
   subroutine help

   call error("usage: archive {dptux$@$ archname [files].")
   return
   end
define(MAXCHARS,10)
# makhdr - make header line for archive member
   subroutine makhdr(name, head)
   character head(MAXLINE), name(NAMESIZE)
   integer fsize, itoc, length
   integer i
#   string hdr "-h-"
   integer hdr(4)
   data hdr(1),hdr(2),hdr(3),hdr(4)/MINUS,LETH,MINUS,EOS/

   call scopy(hdr, 1, head, 1)
   i = length(hdr) + 1
   head(i) = BLANK
   call scopy(name, 1, head, i+1)
   i = length(head) + 1
   head(i) = BLANK
   i = i + 1 + itoc(fsize(name), head(i+1), MAXCHARS)
   head(i) = NEWLINE
   head(i+1) = EOS
   return
   end
# notfnd - print "not found" message
   subroutine notfnd
   integer i
   include carch

   for (i = 1; i <= nfiles; i = i + 1)
      if (fstat(i) == NO) {
         call putlin(fname(1, i), ERROUT)
         call remark(": not in archive.")
         errcnt = errcnt + 1
         $@$
   return
   end
# replac - replace or delete files
   subroutine replac(afd, tfd, cmd, errcnt)
   character in(MAXLINE), uname(NAMESIZE)
   integer filarg, gethdr
   integer afd, cmd, errcnt, size, tfd

   while (gethdr(afd, in, uname, size) ~= EOF)
      if (filarg(uname) == YES) {
         if (cmd == UPD)   # add new one
            call addfil(uname, tfd, errcnt)
         call fskip(afd, size)   # discard old one
         $@$
      else {
         call putlin(in, tfd)
         call acopy(afd, tfd, size)
         $@$
   return
   end
# table - print table of archive contents
   subroutine table(aname)
   character aname(NAMESIZE), in(MAXLINE), lname(NAMESIZE)
   integer filarg, gethdr, open
   integer afd, size

   afd = open(aname, READ)
   if (afd == ERR)
      call cant(aname)
   while (gethdr(afd, in, lname, size) ~= EOF) {
      if (filarg(lname) == YES)
         call tprint(in)
      call fskip(afd, size)
      $@$
   call notfnd
   return
   end
# tprint - print table entry for one member
   subroutine tprint(buf)
   character buf(ARB)

   call putlin(buf, STDOUT)
   return
   end
# update - update existing files, add new ones at end
   subroutine update(aname)
   character aname(NAMESIZE)
   integer create, getarg, open
   integer afd, i, tfd
   include carch
#   string tname "archtemp"
   integer tname(9)
   data tname(1), tname(2), tname(3), tname(4)/LETA, LETR, LETC, LETH/
   data tname(5), tname(6), tname(7), tname(8)/LETT, LETE, LETM, LETP/
   data tname(9)/EOS/

   afd = open(aname, READWRITE)
   if (afd == ERR)      # maybe it's a new one
      afd = create(aname, READWRITE)
   if (afd == ERR)
      call cant(aname)
   tfd = create(tname, READWRITE)
   if (tfd == ERR)
      call cant(tname)
   call replac(afd, tfd, UPD, errcnt)      # update existing
   for (i = 1; i <= nfiles; i = i + 1)      # add new ones
      if (fstat(i) == NO) {
         call addfil(fname(1, i), tfd, errcnt)
         fstat(i) = YES
         $@$
   call close(afd)
   call close(tfd)
   if (errcnt == 0)
      call amove(tname, aname)
   else
      call remark("fatal errors - archive not altered.")
   call remove(tname)
   return
   end
========== programs from chapter 4 ==========
# bubble - bubble sort v(1) ... v(n) increasing
   subroutine bubble(v, n)
   integer i, j, k, n, v(n)

   for (i = n; i > 1; i = i - 1)
      for (j = 1; j < i; j = j + 1)
         if (v(j) > v(j+1)) {      # compare
            k = v(j)      # exchange
            v(j) = v(j+1)      #
            v(j+1) = k      #
            $@$
   return
   end
# shell - Shell sort v(1)...v(n) increasing
   subroutine shell(v, n)
   integer gap, i, j, jg, k, n, v(n)

   for (gap = n/2; gap > 0; gap = gap/2)
      for (i = gap + 1; i <= n; i = i + 1)
         for (j = i - gap; j > 0; j = j - gap) {
            jg = j + gap
            if (v(j) <= v(jg))   # compare
               break
            k = v(j)      # exchange
            v(j) = v(jg)      #
            v(jg) = k      #
            $@$
   return
   end

define(MERGEORDER,7)
define(NAMESIZE,20)
define(MAXTEXT,400)
define(MAXPTR,1000)
define(LOGPTR,20)
# sort - sort text lines in memory
   character linbuf(MAXTEXT)
   integer gtext
   integer linptr(MAXPTR), nlines

   if (gtext(linptr, nlines, linbuf, STDIN) == EOF) {
      call shell(linptr, nlines, linbuf)
      call ptext(linptr, nlines, linbuf, STDOUT)
      $@$
   else
      call error("too big to sort.")
   stop
   end
# shell - Shell sort for character lines
   subroutine shell(linptr, nlines, linbuf)
   character linbuf(ARB)
   integer compar
   integer gap, i, ig, j, k, linptr(ARB), nlines

   for (gap = nlines/2; gap > 0; gap = gap/2)
      for (j = gap + 1; j <= nlines; j = j + 1)
         for (i = j - gap; i > 0; i = i - gap) {
            ig = i + gap
            if (compar(linptr(i), linptr(ig), linbuf) <= 0)
               break
            call exchan(linptr(i), linptr(ig), linbuf)
            $@$
   return
   end
# gtext - get text lines into linbuf
   integer function gtext(linptr, nlines, linbuf, infile)
   character linbuf(MAXTEXT)
   integer getlin
   integer infile, lbp, len, linptr(MAXPTR), nlines

   nlines = 0
   lbp = 1
   repeat {
      len = getlin(linbuf(lbp), infile)
      if (len == EOF)
         break
      nlines = nlines + 1
      linptr(nlines) = lbp
      lbp = lbp + len + 1   # "1" = room for EOS
      $@$ until (lbp >= MAXTEXT-MAXLINE | nlines >= MAXPTR)
   gtext = len
   return
   end
# ptext - output text lines from linbuf
   subroutine ptext(linptr, nlines, linbuf, outfil)
   character linbuf(MAXTEXT)
   integer i, j, linptr(MAXPTR), nlines, outfil

   for (i = 1; i <= nlines; i = i + 1) {
      j = linptr(i)
      call putlin(linbuf(j), outfil)
      $@$
   return
   end
# compar - compare linbuf(lp1) with linbuf(lp2)
   integer function compar(lp1, lp2, linbuf)
   character linbuf(ARB)
   integer i, j, lp1, lp2

   i = lp1
   j = lp2
   while (linbuf(i) == linbuf(j)) {
      if (linbuf(i) == EOS) {
         compar = 0
         return
         $@$
      i = i + 1
      j = j + 1
      $@$
   if (linbuf(i) < linbuf(j))
      compar = -1
   else
      compar = +1
   return
   end
# exchan - exchange linbuf(lp1) with linbuf(lp2)
   subroutine exchan(lp1, lp2, linbuf)
   character linbuf(ARB)
   integer k, lp1, lp2

   k = lp1
   lp1 = lp2
   lp2 = k
   return
   end
# quick - quicksort for character lines
   subroutine quick(linptr, nlines, linbuf)
   character linbuf(ARB)
   integer compar
   integer i, j, linptr(ARB), lv(LOGPTR), nlines, p, pivlin, uv(LOGPTR)

   lv(1) = 1
   uv(1) = nlines
   p = 1
   while (p > 0)
      if (lv(p) >= uv(p))      # only one element in this subset
         p = p - 1      # pop stack
      else {
         i = lv(p) - 1
         j = uv(p)
         pivlin = linptr(j)   # pivot line
         while (i < j) {
            for (i=i+1; compar(linptr(i), pivlin, linbuf) < 0; i=i+1)
               ;
            for (j = j - 1; j > i; j = j - 1)
               if (compar(linptr(j), pivlin, linbuf) <= 0)
                  break
            if (i < j)      # out of order pair
               call exchan(linptr(i), linptr(j), linbuf)
            $@$
         j = uv(p)         # move pivot to position i
         call exchan(linptr(i), linptr(j), linbuf)
         if (i-lv(p) < uv(p)-i) {   # stack so shorter done first
            lv(p+1) = lv(p)
            uv(p+1) = i - 1
            lv(p) = i + 1
            $@$
         else {
            lv(p+1) = i + 1
            uv(p+1) = uv(p)
            uv(p) = i - 1
            $@$
         p = p + 1         # push onto stack
         $@$
   return
   end
# sort - external sort of text lines
   character linbuf(MAXTEXT), name(NAMESIZE)
   integer gtext, makfil, min, open
   integer infil(MERGEORDER), linptr(MAXPTR), nlines
   integer high, lim, low, outfil, t

   high = 0
   repeat {         # initial formation of runs
      t = gtext(linptr, nlines, linbuf, STDIN)
      call quick(linptr, nlines, linbuf)
      high = high + 1
      outfil = makfil(high)
      call ptext(linptr, nlines, linbuf, outfil)
      call close(outfil)
      $@$ until (t == EOF)

   for (low = 1; low < high; low = low + MERGEORDER) {   # merge
      lim = min(low+MERGEORDER-1, high)
      call gopen(infil, low, lim)
      high = high + 1
      outfil = makfil(high)
      call merge(infil, lim-low+1, outfil)
      call close(outfil)
      call gremov(infil, low, lim)
      $@$

   call gname(high, name)   # final cleanup
   outfil = open(name, READ)
   call fcopy(outfil, STDOUT)
   call close(outfil)
   call remove(name)
   stop
   end

# gname - make unique name for file id  n
   subroutine gname(n, name)
   character name(NAMESIZE)
   integer itoc, length
   integer i, junk, n
#   string stemp "stemp"
   integer stemp(6)
   data stemp(1), stemp(2), stemp(3)/ LETS, LETT, LETE/
   data stemp(4), stemp(5), stemp(6)/ LETM, LETP, EOS/

   call scopy(stemp, 1, name, 1)
   i = length(stemp) + 1
   junk = itoc(n, name(i), NAMESIZE-i)
   return
   end

# makfil - make new file for number  n
   integer function makfil(n)
   character name(NAMESIZE)
   integer create
   integer n

   call gname(n, name)
   makfil = create(name, READWRITE)
   if (makfil == ERR)
      call cant(name)
   return
   end

# gopen - open group of files low ... lim
   subroutine gopen(infil, low, lim)
   character name(NAMESIZE)
   integer i, infil(MERGEORDER), lim, low
   integer open

   for (i = 1; i <= lim-low+1; i = i + 1) {
      call gname(low+i-1, name)
      infil(i) = open(name, READ)
      if (infil(i) == ERR)
         call cant(name)
      $@$
   return
   end

# gremov - remove group of files  low ... lim
   subroutine gremov(infil, low, lim)
   character name(NAMESIZE)
   integer i, infil(MERGEORDER), lim, low

   for (i = 1; i <= lim-low+1; i = i + 1) {
      call close(infil(i))
      call gname(low+i-1, name)
      call remove(name)
      $@$
   return
   end
define(MERGETEXT,900)
# merge - merge infil(1) ... infil(nfiles) onto outfil
   subroutine merge(infil, nfiles, outfil)
   character linbuf(MERGETEXT)
   integer getlin
   integer i, inf, lbp, lp1, nf, nfiles, outfil
   integer infil(MERGEORDER), linptr(MERGEORDER)

   lbp = 1
   nf = 0
   for (i = 1; i <= nfiles; i = i + 1)   # get one line from each file
      if (getlin(linbuf(lbp), infil(i)) ~= EOF) {
         nf = nf + 1
         linptr(nf) = lbp
         lbp = lbp + MAXLINE   # room for largest line
         $@$
   call quick(linptr, nf, linbuf)         # make initial heap
   while (nf > 0) {
      lp1 = linptr(1)
      call putlin(linbuf(lp1), outfil)
      inf = lp1 / MAXLINE + 1      # compute file index
      if (getlin(linbuf(lp1), infil(inf)) == EOF) {
         linptr(1) = linptr(nf)
         nf = nf - 1
         $@$
      call reheap(linptr, nf, linbuf)
      $@$
   return
   end

# reheap - propagate linbuf(linptr(1)) to proper place in heap
   subroutine reheap(linptr, nf, linbuf)
   character linbuf(MAXTEXT)
   integer compar
   integer i, j, nf, linptr(nf)

   for (i = 1; 2 * i <= nf; i = j) {
      j = 2 * i
      if (j < nf)      # find smaller child
         if (compar(linptr(j), linptr(j+1), linbuf) > 0)
            j = j + 1
      if (compar(linptr(i), linptr(j), linbuf) <= 0)
         break      # proper position found
      call exchan(linptr(i), linptr(j), linbuf)   # percolate
      $@$
   return
   end
========== other routines from chapter 4 ==========
# unique - strip adjacent duplicate lines
   character buf1(MAXLINE), buf2(MAXLINE)
   integer equal, getlin
   integer t

   t = getlin(buf1, STDIN)
   while (t ~= EOF) {
      call putlin(buf1, STDOUT)
      for (t = getlin(buf2, STDIN); t ~= EOF; t = getlin(buf2, STDIN))
         if (equal(buf1, buf2) == NO)
            break
      if (t == EOF)
         break
      call putlin(buf2, STDOUT)
      for (t = getlin(buf1, STDIN); t ~= EOF; t = getlin(buf1, STDIN))
         if (equal(buf1, buf2) == NO)
            break
      $@$
   stop
   end
define(FOLD,DOLLAR)
# kwic - make keyword in context index
   character buf(MAXLINE)
   integer getlin

   while (getlin(buf, STDIN) ~= EOF)
      call putrot(buf, STDOUT)
   stop
   end

# putrot - create lines with keyword at front
   subroutine putrot(buf, outfil)
   character type
   character buf(ARB), t
   integer i, outfil

   for (i = 1; buf(i) ~= NEWLINE; i = i + 1) {
      t = type(buf(i))
      if (t == LETTER | t == DIGIT) {      # alpha
         call rotate(buf, i, outfil)      # token starts at "i"
         t = type(buf(i+1))
         for ( ; t == LETTER | t == DIGIT; t = type(buf(i+1)))
            i = i + 1
         $@$
      $@$
   return
   end

# rotate - output rotated line
   subroutine rotate(buf, n, outfil)
   character buf(ARB)
   integer i, n, outfil

   for (i = n; buf(i) ~= NEWLINE; i = i + 1)
      call putch(buf(i), outfil)
   call putch(FOLD, outfil)
   for (i = 1; i < n; i = i + 1)
      call putch(buf(i), outfil)
   call putch(NEWLINE, outfil)
   return
   end

# type - determine type of character
   character function type(c)
   character c
   integer index
#   string digits "0123456789"
   integer digits(11)
#   string lowalf "abcdefghijklmnopqrstuvwxyz"
   integer lowalf(27)
#   string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   integer upalf(27)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/
   data lowalf(01)/LETA/
   data lowalf(02)/LETB/
   data lowalf(03)/LETC/
   data lowalf(04)/LETD/
   data lowalf(05)/LETE/
   data lowalf(06)/LETF/
   data lowalf(07)/LETG/
   data lowalf(08)/LETH/
   data lowalf(09)/LETI/
   data lowalf(10)/LETJ/
   data lowalf(11)/LETK/
   data lowalf(12)/LETL/
   data lowalf(13)/LETM/
   data lowalf(14)/LETN/
   data lowalf(15)/LETO/
   data lowalf(16)/LETP/
   data lowalf(17)/LETQ/
   data lowalf(18)/LETR/
   data lowalf(19)/LETS/
   data lowalf(20)/LETT/
   data lowalf(21)/LETU/
   data lowalf(22)/LETV/
   data lowalf(23)/LETW/
   data lowalf(24)/LETX/
   data lowalf(25)/LETY/
   data lowalf(26)/LETZ/
   data lowalf(27)/EOS/
   data upalf(01) /BIGA/
   data upalf(02) /BIGB/
   data upalf(03) /BIGC/
   data upalf(04) /BIGD/
   data upalf(05) /BIGE/
   data upalf(06) /BIGF/
   data upalf(07) /BIGG/
   data upalf(08) /BIGH/
   data upalf(09) /BIGI/
   data upalf(10) /BIGJ/
   data upalf(11) /BIGK/
   data upalf(12) /BIGL/
   data upalf(13) /BIGM/
   data upalf(14) /BIGN/
   data upalf(15) /BIGO/
   data upalf(16) /BIGP/
   data upalf(17) /BIGQ/
   data upalf(18) /BIGR/
   data upalf(19) /BIGS/
   data upalf(20) /BIGT/
   data upalf(21) /BIGU/
   data upalf(22) /BIGV/
   data upalf(23) /BIGW/
   data upalf(24) /BIGX/
   data upalf(25) /BIGY/
   data upalf(26) /BIGZ/
   data upalf(27) /EOS/

   if (index(lowalf, c) > 0)
      type = LETTER
   else if (index(upalf, c) > 0)
      type = LETTER
   else if (index(digits, c) > 0)
      type = DIGIT
   else
      type = c
   return
   end
define(FOLD,DOLLAR)
define(MIDDLE,40)
define(MAXOUT,80)
# unrot - unrotate lines rotated by kwic
   character inbuf(MAXLINE), outbuf(MAXOUT)
   integer getlin, index
   integer i, j

   while (getlin(inbuf, STDIN) ~= EOF) {
      for (i = 1; i < MAXOUT; i = i + 1)   # blank line
         outbuf(i) = BLANK
      j = MIDDLE
      for (i = 1; inbuf(i) ~= FOLD & inbuf(i) ~= NEWLINE; i = i + 1) {
         j = j + 1         # copy up to FOLD
         if (j >= MAXOUT - 1)
            j = 1
         outbuf(j) = inbuf(i)
         $@$
      if (inbuf(i) == FOLD) {      # copy second half,
         j = MIDDLE         # working backwards
         for (i = index(inbuf, NEWLINE) - 1; i > 0; i = i - 1) {
            if (inbuf(i) == FOLD)
               break
            j = j - 1
            if (j <= 0)
               j = MAXOUT - 2
            outbuf(j) = inbuf(i)
            $@$
         $@$
      for (i = MAXOUT - 2; i > 0; i = i - 1)
         if (outbuf(i) ~= BLANK)   # delete trailing blanks
            break
      outbuf(i+1) = NEWLINE      # terminate line properly
      outbuf(i+2) = EOS
      call putlin(outbuf, STDOUT)
      $@$
   stop
   end
========== find program from chapter 5 ==========

define(MAXARG,128)
define(MAXPAT,128)

define(COUNT,1)
define(PREVCL,2)
define(START,3)
define(CLOSIZE,4)

define(NOT,BANG)
define(BOL,PERCENT)
define(ANY,QMARK)
define(EOL,DOLLAR)
define(CLOSURE,STAR)
define(CCL,LBRACK)
define(CCLEND,RBRACK)
define(NCCL,LETN)
define(CHAR,LETA)
define(ESCAPE,ATSIGN)
# amatch  (non-recursive) - look for match starting at lin(from)
   integer function amatch(lin, from, pat)
   character lin(MAXLINE), pat(MAXPAT)
   integer omatch, patsiz
   integer from, i, j, offset, stack

   stack = 0
   offset = from      # next unexamined input character
   for (j = 1; pat(j) ~= EOS; j = j + patsiz(pat, j))
      if (pat(j) == CLOSURE) {      # a closure entry
         stack = j
         j = j + CLOSIZE      # step over CLOSURE
         for (i = offset; lin(i) ~= EOS; )   # match as many as
            if (omatch(lin, i, pat, j) == NO)   # possible
               break
         pat(stack+COUNT) = i - offset
         pat(stack+START) = offset
         offset = i      # character that made us fail
         $@$
      else if (omatch(lin, offset, pat, j) == NO) {   # non-closure
         for ( ; stack > 0; stack = pat(stack+PREVCL))
            if (pat(stack+COUNT) > 0)
               break
         if (stack <= 0) {      # stack is empty
            amatch = 0      # return failure
            return
            $@$
         pat(stack+COUNT) = pat(stack+COUNT) - 1
         j = stack + CLOSIZE
         offset = pat(stack+START) + pat(stack+COUNT)
         $@$
      # else omatch succeeded
   amatch = offset
   return      # success
   end
# amatch with no metacharacters
   integer function amatch(lin, from, pat)
   character lin(MAXLINE), pat(MAXPAT)
   integer from, i, j

   i = from
   for (j = 1; pat(j) ~= EOS; j = j + 1) {
      if (lin(i) ~= pat(j)) {
         amatch = 0
         return      # with no match
         $@$
      i = i + 1
      $@$
   amatch = i
   return            # successfully
   end
# amatch with some metacharacters
   integer function amatch(lin, from, pat)
   character lin(MAXLINE), pat(MAXPAT)
   integer omatch, patsiz
   integer from, i, j

   i = from
   for (j = 1; pat(j) ~= EOS; j = j + patsiz(pat, j))
      if (omatch(lin, i, pat, j) == NO) {
         amatch = 0
         return      # with no match
         $@$
   amatch = i
   return            # successfully
   end
# find - find patterns in text
   character arg(MAXARG), lin(MAXLINE), pat(MAXPAT)
   integer getarg, getlin, getpat, match

   if (getarg(1, arg, MAXARG) == EOF)
      call error("usage: find pattern.")
   if (getpat(arg, pat) == ERR)
      call error("illegal pattern.")
   while (getlin(lin, STDIN) ~= EOF)
      if (match(lin, pat) == YES)
         call putlin(lin, STDOUT)
   stop
   end
# getccl - expand char class at arg(i) into pat(j)
   integer function getccl(arg, i, pat, j)
   character arg(MAXARG), pat(MAXPAT)
   integer addset
   integer i, j, jstart, junk

   i = i + 1      # skip over [
   if (arg(i) == NOT) {
      junk = addset(NCCL, pat, j, MAXPAT)
      i = i + 1
      $@$
   else
      junk = addset(CCL, pat, j, MAXPAT)
   jstart = j
   junk = addset(0, pat, j, MAXPAT)      # leave room for count
   call filset(CCLEND, arg, i, pat, j, MAXPAT)
   pat(jstart) = j - jstart - 1
   if (arg(i) == CCLEND)
      getccl = OK
   else
      getccl = ERR
   return
   end
# getpat - convert argument into pattern
   integer function getpat(arg, pat)
   integer arg(MAXARG), pat(MAXPAT)
   integer makpat

   getpat = makpat(arg, 1, EOS, pat)
   return
   end
# locate - look for c in char class at pat(offset)
   integer function locate(c, pat, offset)
   character c, pat(MAXPAT)
   integer i, offset
   # size of class is at pat(offset), characters follow

   for (i = offset + pat(offset); i > offset; i = i - 1)
      if (c == pat(i)) {
         locate = YES
         return
         $@$
   locate = NO
   return
   end
# makpat - make pattern from arg(from), terminate at delim
   integer function makpat(arg, from, delim, pat)
   character esc
   character arg(MAXARG), delim, pat(MAXPAT)
   integer addset, getccl, stclos
   integer from, i, j, junk, lastcl, lastj, lj

   j = 1      # pat index
   lastj = 1
   lastcl = 0
   for (i = from; arg(i) ~= delim & arg(i) ~= EOS; i = i + 1) {
      lj = j
      if (arg(i) == ANY)
         junk = addset(ANY, pat, j, MAXPAT)
      else if (arg(i) == BOL & i == from)
         junk = addset(BOL, pat, j, MAXPAT)
      else if (arg(i) == EOL & arg(i + 1) == delim)
         junk = addset(EOL, pat, j, MAXPAT)
      else if (arg(i) == CCL) {
         if (getccl(arg, i, pat, j) == ERR)
            break
         $@$
      else if (arg(i) == CLOSURE & i > from) {
         lj = lastj
         if (pat(lj)==BOL | pat(lj)==EOL | pat(lj)==CLOSURE)
            break
         lastcl = stclos(pat, j, lastj, lastcl)
         $@$
      else {
         junk = addset(CHAR, pat, j, MAXPAT)
         junk = addset(esc(arg, i), pat, j, MAXPAT)
         $@$
      lastj = lj
      $@$
   if (arg(i) ~= delim)   # terminated early
      makpat = ERR
   else if (addset(EOS, pat, j, MAXPAT) == NO)   # no room
      makpat = ERR
   else
      makpat = i
   return
   end
# match - find match anywhere on line
   integer function match(lin, pat)
   character lin(MAXLINE), pat(MAXPAT)
   integer amatch
   integer i

   for (i = 1; lin(i) ~= EOS; i = i + 1)
      if (amatch(lin, i, pat) > 0) {
         match = YES
         return
         $@$
   match = NO
   return
   end
# omatch - try to match a single pattern at pat(j)
   integer function omatch(lin, i, pat, j)
   character lin(MAXLINE), pat(MAXPAT)
   integer locate
   integer bump, i, j

   omatch = NO
   if (lin(i) == EOS)
      return
   bump = -1
   if (pat(j) == CHAR) {
      if (lin(i) == pat(j + 1))
         bump = 1
      $@$
   else if (pat(j) == BOL) {
      if (i == 1)
         bump = 0
      $@$
   else if (pat(j) == ANY) {
      if (lin(i) ~= NEWLINE)
         bump = 1
      $@$
   else if (pat(j) == EOL) {
      if (lin(i) == NEWLINE)
         bump = 0
      $@$
   else if (pat(j) == CCL) {
      if (locate(lin(i), pat, j + 1) == YES)
         bump = 1
      $@$
   else if (pat(j) == NCCL) {
      if (lin(i) ~= NEWLINE & locate(lin(i), pat, j + 1) == NO)
         bump = 1
      $@$
   else
      call error("in omatch: can't happen.")
   if (bump >= 0) {
      i = i + bump
      omatch = YES
      $@$
   return
   end
# patsiz - returns size of pattern entry at pat(n)
   integer function patsiz(pat, n)
   character pat(MAXPAT)
   integer n

   if (pat(n) == CHAR)
      patsiz = 2
   else if (pat(n) == BOL | pat(n) == EOL | pat(n) == ANY)
      patsiz = 1
   else if (pat(n) == CCL | pat(n) == NCCL)
      patsiz = pat(n + 1) + 2
   else if (pat(n) == CLOSURE)      # optional
      patsiz = CLOSIZE
   else
      call error("in patsiz: can't happen.")
   return
   end
# stclos - insert closure entry at pat(j)
   integer function stclos(pat, j, lastj, lastcl)
   character pat(MAXPAT)
   integer addset
   integer j, jp, jt, junk, lastcl, lastj

   for (jp = j - 1; jp >= lastj; jp = jp - 1) {   # make a hole
      jt = jp + CLOSIZE
      junk = addset(pat(jp), pat, jt, MAXPAT)
      $@$
   j = j + CLOSIZE
   stclos = lastj
   junk = addset(CLOSURE, pat, lastj, MAXPAT)   # put closure in it
   junk = addset(0, pat, lastj, MAXPAT)      # COUNT
   junk = addset(lastcl, pat, lastj, MAXPAT)   # PREVCL
   junk = addset(0, pat, lastj, MAXPAT)      # START
   return
   end
========== change program from chapter 5 ==========
define(MAXPAT,128)
define(MAXARG,128)
define(ESCAPE,ATSIGN)
define(DITTO,(-3))
# catsub - add replacement text to end of  new
   subroutine catsub(lin, from, to, sub, new, k, maxnew)
   integer addset
   integer from, i, j, junk, k, maxnew, to
   character lin(MAXLINE), new(maxnew), sub(MAXPAT)

   for (i = 1; sub(i) ~= EOS; i = i + 1)
      if (sub(i) == DITTO)
         for (j = from; j < to; j = j + 1)
            junk = addset(lin(j), new, k, maxnew)
      else
         junk = addset(sub(i), new, k, maxnew)
   return
   end
# change - change  "from"  into  "to"
   character lin(MAXLINE), new(MAXLINE), pat(MAXPAT), sub(MAXPAT)
   character arg(MAXARG)
   integer addset, amatch, getarg, getlin, getpat, getsub
   integer i, junk, k, lastm, m

   if (getarg(1, arg, MAXARG) == EOF)
      call error("usage: change from to.")
   if (getpat(arg, pat) == ERR)
      call error("illegal from pattern.")
   if (getarg(2, arg, MAXARG) == EOF)
      arg(1) = EOS
   if (getsub(arg, sub) == ERR)
      call error("illegal to.")
   while (getlin(lin, STDIN) ~= EOF) {
      k = 1
      lastm = 0
      for ( i =1; lin(i) ~= EOS; ) {
         m = amatch(lin, i, pat)
         if (m > 0 & lastm ~= m) {   # replace matched text
            call catsub(lin, i, m, sub, new, k, MAXLINE)
            lastm = m
            $@$
         if (m == 0 | m == i) {   # no match or null match
            junk = addset(lin(i), new, k, MAXLINE)
            i = i + 1
            $@$
         else            # skip matched text
            i = m
         $@$
      if (addset(EOS, new, k, MAXLINE) == NO) {
         k = MAXLINE
         junk = addset(EOS, new, k, MAXLINE)
         call remark("line truncated:.")
         call putlin(new, ERROUT)
         call putch(NEWLINE, ERROUT)
         $@$
      call putlin(new, STDOUT)
      $@$
   stop
   end
# getsub - get substitution pattern into sub
   integer function getsub(arg, sub)
   character arg(MAXARG), sub(MAXPAT)
   integer maksub

   getsub = maksub(arg, 1, EOS, sub)
   return
   end
# maksub - make substitution string in sub
   integer function maksub(arg, from, delim, sub)
   character esc
   character arg(MAXARG), delim, sub(MAXPAT)
   integer addset
   integer from, i, j, junk

   j = 1
   for (i = from; arg(i) ~= delim & arg(i) ~= EOS; i = i + 1)
      if (arg(i) == AND)
         junk = addset(DITTO, sub, j, MAXPAT)
      else
         junk = addset(esc(arg, i), sub, j, MAXPAT)
   if (arg(i) ~= delim)   # missing delimiter
      maksub = ERR
   else if (addset(EOS, sub, j, MAXPAT) == NO)   # no room
      maksub = ERR
   else
      maksub = i
   return
   end
========== edit program from chapter 6 ==========
define(MAXPAT,128)
define(andif,if)
define(GLOBAL,LETG)
define(PRINT,LETP)

define(MARKED,LETY)
define(NOMARK,LETN)

define(FORWARD,0)
define(BACKWARD,-1)
define(EXCLUDE,LETX)
define(APPENDCOM,LETA)
define(CHANGE,LETC)
define(DELCOM,LETD)
define(ENTER,LETE)
define(PRINTFIL,LETF)
define(READCOM,LETR)
define(WRITECOM,LETW)
define(INSERT,LETI)
define(PRINTCUR,EQUALS)
define(MOVECOM,LETM)
define(QUIT,LETQ)
define(SUBSTITUTE,LETS)
define(CURLINE,PERIOD)
define(LASTLINE,DOLLAR)
define(SCAN,SLASH)
define(BACKSCAN,BACKSLASH)
define(NOSTATUS,1)
define(LINE0,1)
define(PREV,0)
define(NEXT,1)
define(MARK,2)
define(TEXT,3)
define(MAXBUF,1000)
common /cbuf/ buf(MAXBUF), lastbf
   character buf      # buffer for pointers plus text
   integer lastbf      # last element used in buf
common /clines/ line1, line2, nlines, curln, lastln
   integer line1   # first line number
   integer line2   # second line number
   integer nlines   # number of line numbers specified
   integer curln   # current line: value of dot
   integer lastln   # last line: value of $
common /cpat/ pat(MAXPAT)
   character pat      # pattern
common /ctxt/ txt(MAXLINE)
   character txt      # text line for matching and output
common /cfile/ savfil(MAXLINE)
   character savfil   # remembered file name
# append - append lines after "line"
   integer function append(line, glob)
   character lin(MAXLINE)
   integer getlin, inject
   integer line, glob
   include clines

   if (glob == YES)
      append = ERR
   else {
      curln = line
      for (append = NOSTATUS; append == NOSTATUS; )
         if (getlin(lin, STDIN) == EOF)
            append = EOF
         else if (lin(1) == PERIOD & lin(2) == NEWLINE)
            append = OK
         else if (inject(lin) == ERR)
            append = ERR
      $@$
   return
   end
# ckglob - if global prefix, mark lines to be affected
   integer function ckglob(lin, i, status)
   character lin(MAXLINE)
   integer defalt, getind, gettxt, match, nextln, optpat
   integer gflag, i, k, line, status
   include cbuf
   include clines
   include cpat
   include ctxt

   if (lin(i) ~= GLOBAL & lin(i) ~= EXCLUDE)
      status = EOF
   else {
      if (lin(i) == GLOBAL)
         gflag = YES
      else
         gflag = NO
      i = i + 1
      if (optpat(lin, i) == ERR | defalt(1, lastln, status) == ERR)
         status = ERR
      else {
         i = i + 1
         for (line = line1; line <= line2; line = line + 1) {
            k = gettxt(line)
            if (match(txt, pat) == gflag)
               buf(k+MARK) = YES
            else
               buf(k+MARK) = NO
            $@$
         for (line=nextln(line2); line~=line1; line=nextln(line)) {
            k = getind(line)
            buf(k+MARK) = NO
            $@$
         status = OK
         $@$
      $@$
   ckglob = status
   return
   end
# ckp - check for "p" after command
   integer function ckp(lin, i, pflag, status)
   character lin(MAXLINE)
   integer i, j, pflag, status

   j = i
   if (lin(j) == PRINT) {
      j = j + 1
      pflag = YES
      $@$
   else
      pflag = NO
   if (lin(j) == NEWLINE)
      status = OK
   else
      status = ERR
   ckp = status
   return
   end
# clrbuf  (in memory) - initialize for new file
   subroutine clrbuf

   return      # nothing to do
   end
# defalt - set defaulted line numbers
   integer function defalt(def1, def2, status)
   integer def1, def2, status
   include clines

   if (nlines == 0) {
      line1 = def1
      line2 = def2
      $@$
   if (line1 > line2 | line1 <= 0)
      status = ERR
   else
      status = OK
   defalt = status
   return
   end
# delete - delete lines from through to
   integer function delete(from, to, status)
   integer getind, nextln, prevln
   integer from, k1, k2, status, to
   include clines

   if (from <= 0)
      status = ERR
   else {
      k1 = getind(prevln(from))
      k2 = getind(nextln(to))
      lastln = lastln - (to - from + 1)
      curln = prevln(from)
      call relink(k1, k2, k1, k2)
      status = OK
      $@$
   delete = status
   return
   end
# docmd - handle all commands except globals
   integer function docmd(lin, i, glob, status)
   character file(MAXLINE), lin(MAXLINE), sub(MAXPAT)
   integer append, delete, doprnt, doread, dowrit, move, subst
   integer ckp, defalt, getfn, getone, getrhs, nextln, optpat, prevln
   integer gflag, glob, i, line3, pflag, status
   include cfile
   include clines
   include cpat

   pflag = NO      # may be set by d, m, s
   status = ERR
   if (lin(i) == APPENDCOM) {
      if (lin(i + 1) == NEWLINE)
         status = append(line2, glob)
      $@$
   else if (lin(i) == CHANGE) {
      if (lin(i + 1) == NEWLINE)
        andif (defalt(curln, curln, status) == OK)
        andif (delete(line1, line2, status) == OK)
         status = append(prevln(line1), glob)
      $@$
   else if (lin(i) == DELCOM) {
      if (ckp(lin, i + 1, pflag, status) == OK)
        andif (defalt(curln, curln, status) == OK)
        andif (delete(line1, line2, status) == OK)
        andif (nextln(curln) ~= 0)
         curln = nextln(curln)
      $@$
   else if (lin(i) == INSERT) {
      if (lin(i + 1) == NEWLINE)
         status = append(prevln(line2), glob)
      $@$
   else if (lin(i) == PRINTCUR) {
      if (ckp(lin, i + 1, pflag, status) == OK) {
         call putdec(line2, 1)
         call putc(NEWLINE)
         $@$
      $@$
   else if (lin(i) == MOVECOM) {
      i = i + 1
      if (getone(lin, i, line3, status) == EOF)
         status = ERR
      if (status == OK)
        andif (ckp(lin, i, pflag, status) == OK)
        andif (defalt(curln, curln, status) == OK)
         status = move(line3)
      $@$
   else if (lin(i) == SUBSTITUTE) {
      i = i + 1
      if (optpat(lin, i) == OK)
        andif (getrhs(lin, i, sub, gflag) == OK)
        andif (ckp(lin, i + 1, pflag, status) == OK)
        andif (defalt(curln, curln, status) == OK)
         status = subst(sub, gflag)
      $@$
   else if (lin(i) == ENTER) {
      if (nlines == 0)
        andif (getfn(lin, i, file) == OK) {
         call scopy(file, 1, savfil, 1)
         call clrbuf
         call setbuf
         status = doread(0, file)
         $@$
      $@$
   else if (lin(i) == PRINTFIL) {
      if (nlines == 0)
        andif (getfn(lin, i, file) == OK) {
         call scopy(file, 1, savfil, 1)
         call putlin(savfil, STDOUT)
         call putc(NEWLINE)
         status = OK
         $@$
      $@$
   else if (lin(i) == READCOM) {
      if (getfn(lin, i, file) == OK)
         status = doread(line2, file)
      $@$
   else if (lin(i) == WRITECOM) {
      if (getfn(lin, i, file) == OK)
        andif (defalt(1, lastln, status) == OK)
         status = dowrit(line1, line2, file)
      $@$
   else if (lin(i) == PRINT) {
      if (lin(i + 1) == NEWLINE)
        andif (defalt(curln, curln, status) == OK)
         status = doprnt(line1, line2)
      $@$
   else if (lin(i) == NEWLINE) {
      if (nlines == 0)
         line2 = nextln(curln)
      status = doprnt(line2, line2)
      $@$
   else if (lin(i) == QUIT) {
      if (lin(i + 1) == NEWLINE & nlines == 0 & glob == NO)
         status = EOF
      $@$
   # else status is ERR
   if (status == OK & pflag == YES)
      status = doprnt(curln, curln)
   docmd = status
   return
   end
# doglob - do command at lin(i) on all marked lines
   integer function doglob(lin, i, cursav, status)
   character lin(MAXLINE)
   integer docmd, getind, getlst, nextln
   integer count, cursav, i, istart, k, line, status
   include cbuf
   include clines

   status = OK
   count = 0
   line = line1
   istart = i
   repeat {
      k = getind(line)
      if (buf(k+MARK) == YES) {
         buf(k+MARK) = NO
         curln = line
         cursav = curln
         i = istart
         if (getlst(lin, i, status) == OK)
           andif (docmd(lin, i, YES, status) == OK)
            count = 0
         $@$
      else {
         line = nextln(line)
         count = count + 1
         $@$
      $@$ until (count > lastln | status ~= OK)
   doglob = status
   return
   end
# doprnt - print lines from through to
   integer function doprnt(from, to)
   integer gettxt
   integer from, i, j, to
   include clines
   include ctxt

   if (from <= 0)
      doprnt = ERR
   else {
      for (i = from; i <= to; i = i + 1) {
         j = gettxt(i)
         call putlin(txt, STDOUT)
         $@$
      curln = to
      doprnt = OK
      $@$
   return
   end
# doread - read "file" after "line"
   integer function doread(line, file)
   character file(MAXLINE), lin(MAXLINE)
   integer getlin, inject, open
   integer count, fd, line
   include clines

   fd = open(file, READ)
   if (fd == ERR)
      doread = ERR
   else {
      curln = line
      doread = OK
      for (count = 0; getlin(lin, fd) ~= EOF; count = count + 1) {
         doread = inject(lin)
         if (doread == ERR)
            break
         $@$
      call close(fd)
      call putdec(count, 1)
      call putc(NEWLINE)
      $@$
   return
   end
# dowrit - write "from" through "to" into file
   integer function dowrit(from, to, file)
   character file(MAXLINE)
   integer create, gettxt
   integer fd, from, k, line, to
   include ctxt

   fd = create(file, WRITE)
   if (fd == ERR)
      dowrit = ERR
   else {
      for (line = from; line <= to; line = line + 1) {
         k = gettxt(line)
         call putlin(txt, fd)
         $@$
      call close(fd)
      call putdec(to-from+1, 1)
      call putc(NEWLINE)
      dowrit = OK
      $@$
   return
   end
# edit - main routine
   character lin(MAXLINE)
   integer ckglob, docmd, doglob, doread, getarg, getlin, getlst
   integer cursav, i, status
   include cfile
   include clines
   include cpat

   call setbuf
   pat(1) = EOS
   savfil(1) = EOS
   if (getarg(1, savfil, MAXLINE) ~= EOF)
      if (doread(0, savfil) == ERR)
         call remark("?.")
   while (getlin(lin, STDIN) ~= EOF) {
      i = 1
      cursav = curln
      if (getlst(lin, i, status) == OK) {
         if (ckglob(lin, i, status) == OK)
            status = doglob(lin, i, cursav, status)
         else if (status ~= ERR)
            status = docmd(lin, i, NO, status)
         # else error, do nothing
         $@$
      if (status == ERR) {
         call remark("?.")
         curln = cursav
         $@$
      else if (status == EOF)
         break
      # else OK, loop
      $@$
   call clrbuf
   stop
   end
# getfn - get file name from lin(i)...
   integer function getfn(lin, i, file)
   character lin(MAXLINE), file(MAXLINE)
   integer i, j, k
   include cfile

   getfn = ERR
   if (lin(i + 1) == BLANK) {
      j = i + 2      # get new file name
      call skipbl(lin, j)
      for (k = 1; lin(j) ~= NEWLINE; k = k + 1) {
         file(k) = lin(j)
         j = j + 1
         $@$
      file(k) = EOS
      if (k > 1)
         getfn = OK
      $@$
   else if (lin(i + 1) == NEWLINE & savfil(1) ~= EOS) {
      call scopy(savfil, 1, file, 1)   # or old name
      getfn = OK
      $@$
   # else error
   if (getfn == OK & savfil(1) == EOS)
      call scopy(file, 1, savfil, 1)   # save if no old one
   return
   end
# getind - locate line index in buffer
   integer function getind(line)
   integer j, k, line
   include cbuf

   k = LINE0
   for (j = 0; j < line; j = j + 1)
      k = buf(k + NEXT)
   getind = k
   return
   end
# getlst - collect line numbers (if any) at lin(i), increment i
   integer function getlst(lin, i, status)
   character lin(MAXLINE)
   integer getone, min
   integer i, num, status
   include clines

   line2 = 0
   for (nlines = 0; getone(lin, i, num, status) == OK; ) {
      line1 = line2
      line2 = num
      nlines = nlines + 1
      if (lin(i) ~= COMMA & lin(i) ~= SEMICOL)
         break
      if (lin(i) == SEMICOL)
         curln = num
      i = i + 1
      $@$
   nlines = min(nlines, 2)
   if (nlines == 0)
      line2 = curln
   if (nlines <= 1)
      line1 = line2
   if (status ~= ERR)
      status = OK
   getlst = status
   return
   end
# getnum - convert one term to line number
   integer function getnum(lin, i, pnum, status)
   character lin(MAXLINE)
   integer ctoi, index, optpat, ptscan
   integer i, pnum, status
   include clines
   include cpat
#   string digits "0123456789"
   integer digits(11)
   data digits(01)/DIG0/
   data digits(02)/DIG1/
   data digits(03)/DIG2/
   data digits(04)/DIG3/
   data digits(05)/DIG4/
   data digits(06)/DIG5/
   data digits(07)/DIG6/
   data digits(08)/DIG7/
   data digits(09)/DIG8/
   data digits(10)/DIG9/
   data digits(11)/EOS/

   getnum = OK
   if (index(digits, lin(i)) > 0) {
      pnum = ctoi(lin, i)
      i = i - 1   # move back; to be advanced at the end
      $@$
   else if (lin(i) == CURLINE)
      pnum = curln
   else if (lin(i) == LASTLINE)
      pnum = lastln
   else if (lin(i) == SCAN | lin(i) == BACKSCAN) {
      if (optpat(lin, i) == ERR)   # build the pattern
         getnum = ERR
      else if (lin(i) == SCAN)
         getnum = ptscan(FORWARD, pnum)
      else
         getnum = ptscan(BACKWARD, pnum)
      $@$
   else
      getnum = EOF
   if (getnum == OK)
      i = i + 1   # point at next character to be examined
   status = getnum
   return
   end
# getone - evaluate one line number expression
   integer function getone(lin, i, num, status)
   character lin(MAXLINE)
   integer getnum
   integer i, istart, mul, num, pnum, status
   include clines

   istart = i
   num = 0
   call skipbl(lin, i)
   if (getnum(lin, i, num, status) == OK)   # first term
      repeat {            # + or - terms
         call skipbl(lin, i)
         if (lin(i) ~= PLUS & lin(i) ~= MINUS) {
            status = EOF
            break
            $@$
         if (lin(i) == PLUS)
            mul = +1
         else
            mul = -1
         i = i + 1
         call skipbl(lin, i)
         if (getnum(lin, i, pnum, status) == OK)
            num = num + mul * pnum
         if (status == EOF)
            status = ERR
         $@$ until (status ~= OK)
   if (num < 0 | num > lastln)
      status = ERR

   if (status == ERR)
      getone = ERR
   else if (i <= istart)
      getone = EOF
   else
      getone = OK

   status = getone
   return
   end
# getrhs - get substitution string for "s" command
   integer function getrhs(lin, i, sub, gflag)
   character lin(MAXLINE), sub(MAXPAT)
   integer maksub
   integer gflag, i

   getrhs = ERR
   if (lin(i) == EOS)
      return
   if (lin(i + 1) == EOS)
      return
   i = maksub(lin, i + 1, lin(i), sub)
   if (i == ERR)
      return
   if (lin(i + 1) == GLOBAL) {
      i = i + 1
      gflag = YES
      $@$
   else
      gflag = NO
   getrhs = OK
   return
   end
# gettxt  (in memory) - locate text for line and make available
   integer function gettxt(line)
   integer getind
   integer line
   include cbuf
   include ctxt

   gettxt = getind(line)
   call scopy(buf, gettxt + TEXT, txt, 1)
   return
   end
# inject  (in memory) - put text from lin after curln
   integer function inject(lin)
   character lin(MAXLINE)
   integer addset, getind, nextln
   integer i, junk, k1, k2, k3
   include cbuf
   include clines

   for (i = 1; lin(i) ~= EOS; ) {
      k3 = lastbf
      lastbf = lastbf + TEXT
      while (lin(i) ~= EOS) {
         junk = addset(lin(i), buf, lastbf, MAXBUF)
         i = i + 1
         if (lin(i - 1) == NEWLINE)
            break
         $@$
      if (addset(EOS, buf, lastbf, MAXBUF) == NO) {
         inject = ERR
         break
         $@$
      k1 = getind(curln)
      k2 = getind(nextln(curln))
      call relink(k1, k3, k3, k2)
      call relink(k3, k2, k1, k3)
      curln = curln + 1
      lastln = lastln + 1
      inject = OK
      $@$
   return
   end
# move - move line1 through line2 after line3
   integer function move(line3)
   integer getind, nextln, prevln
   integer k0, k1, k2, k3, k4, k5, line3
   include clines

   if (line1 <= 0 | (line1 <= line3 & line3 <= line2))
      move = ERR
   else {
      k0 = getind(prevln(line1))
      k3 = getind(nextln(line2))
      k1 = getind(line1)
      k2 = getind(line2)
      call relink(k0, k3, k0, k3)
      if (line3 > line1) {
         curln = line3
         line3 = line3 - (line2 - line1 + 1)
         $@$
      else
         curln = line3 + (line2 - line1 + 1)
      k4 = getind(line3)
      k5 = getind(nextln(line3))
      call relink(k4, k1, k2, k5)
      call relink(k2, k5, k4, k1)
      move = OK
      $@$
   return
   end
# nextln - get line after "line"
   integer function nextln(line)
   integer line
   include clines

   nextln = line + 1
   if (nextln > lastln)
      nextln = 0
   return
   end
# optpat - make pattern if specified at lin(i)
   integer function optpat(lin, i)
   character lin(MAXLINE)
   integer makpat
   integer i
   include cpat

   if (lin(i) == EOS)
      i = ERR
   else if (lin(i + 1) == EOS)
      i = ERR
   else if (lin(i + 1) == lin(i))   # repeated delimiter
      i = i + 1         # leave existing pattern alone
   else
      i = makpat(lin, i + 1, lin(i), pat)
   if (pat(1) == EOS)
      i = ERR
   if (i == ERR) {
      pat(1) = EOS
      optpat = ERR
      $@$
   else
      optpat = OK
   return
   end
# prevln - get line before "line"
   integer function prevln(line)
   integer line
   include clines

   prevln = line - 1
   if (prevln < 0)
      prevln = lastln
   return
   end
# ptscan - scan for next occurrence of pattern
   integer function ptscan(way, num)
   integer gettxt, match, nextln, prevln
   integer k, num, way
   include clines
   include cpat
   include ctxt

   num = curln
   repeat {
      if (way == FORWARD)
         num = nextln(num)
      else
         num = prevln(num)
      k = gettxt(num)
      if (match(txt, pat) == YES) {
         ptscan = OK
         return
         $@$
      $@$ until (num == curln)
   ptscan = ERR
   return
   end
# relink - rewrite two half links
   subroutine relink(a, x, y, b)
   integer a, b, x, y
   include cbuf

   buf(x + PREV) = a
   buf(y + NEXT) = b
   return
   end
# setbuf (in memory) - initialize line storage buffer
   subroutine setbuf
   integer addset
   integer junk
   include cbuf
   include clines

   call relink(LINE0, LINE0, LINE0, LINE0)
   lastbf = LINE0 + TEXT
   junk = addset(EOS, buf, lastbf, MAXBUF)
   curln = 0
   lastln = 0
   return
   end
# skipbl - skip blanks and tabs at lin(i)...
   subroutine skipbl(lin, i)
   character lin(ARB)
   integer i

   while (lin(i) == BLANK | lin(i) == TAB)
      i = i + 1
   return
   end
# subst - substitute "sub" for occurrences of pattern
   integer function subst(sub, gflag)
   character new(MAXLINE), sub(MAXPAT)
   integer addset, amatch, gettxt, inject
   integer gflag, j, junk, k, lastm, line, m, status, subbed
   include clines
   include cpat
   include ctxt

   subst = ERR
   if (line1 <= 0)
      return
   for (line = line1; line <= line2; line = line + 1) {
      j = 1
      subbed = NO
      junk = gettxt(line)
      lastm = 0
      for (k = 1; txt(k) ~= EOS; ) {
         if (gflag == YES | subbed == NO)
            m = amatch(txt, k, pat)
         else
            m = 0
         if (m > 0 & lastm ~= m) {   # replace matched text
            subbed = YES
            call catsub(txt, k, m, sub, new, j, MAXLINE)
            lastm = m
            $@$
         if (m == 0 | m == k) {   # no match or null match
            junk = addset(txt(k), new, j, MAXLINE)
            k = k + 1
            $@$
         else            # skip matched text
            k = m
         $@$
      if (subbed == YES) {
         if (addset(EOS, new, j, MAXLINE) == NO) {
            subst = ERR
            break
            $@$
         call delete(line, line, status)   # remembers dot
         subst = inject(new)
         if (subst == ERR)
            break
         subst = OK
         $@$
      $@$
   return
   end
========== file primitives for scratch file editor ==========
define(PREV,0)
define(NEXT,1)
define(MARK,2)
define(SEEKADR,3)
define(LENG,4)
define(BUFENT,5)

define(MAXBUF,1000)
define(LINE0,1)

common /cbuf/ buf(MAXBUF), lastbf
   character buf   # structure of pointers for all lines:
   # buf(k+0)   PREV      previous line
   # buf(k+1)   NEXT      next line
   # buf(k+2)   MARK      mark for global commands
   # buf(k+3)   SEEKADR   where line is on scratch file
   # buf(k+4)   LENG      length on scratch
   integer lastbf   # last pointer used in buf
common /cscrat/ scr, scrend
   integer scr      # scratch file id
   integer scrend   # end of info on scratch file
# clrbuf  (scratch file) - dispose of scratch file
   subroutine clrbuf
   include cscrat
#   string scrfil "scratch"
   integer scrfil(8)
   data scrfil(1)/LETS/
   data scrfil(2)/LETC/
   data scrfil(3)/LETR/
   data scrfil(4)/LETA/
   data scrfil(5)/LETT/
   data scrfil(6)/LETC/
   data scrfil(7)/LETH/
   data scrfil(8)/EOS/

   call close(scr)
   call remove(scrfil)
   return
   end
# gettxt (scratch file) - locate text for line, copy to txt
   integer function gettxt(line)
   integer getbuf, getind
   integer j, k, line
   include cbuf
   include cscrat
   include ctxt

   k = getind(line)
   call seek(buf(k + SEEKADR), scr)
   call readf(txt, buf(k + LENG), scr)
   j = buf(k + LENG) + 1
   txt(j) = EOS
   gettxt = k
   return
   end
# inject  (scratch file) - insert lin after curln, write scratch
   integer function inject(lin)
   character lin(MAXLINE)
   integer getind, maklin, nextln
   integer i, k1, k2, k3
   include clines

   for (i = 1; lin(i) ~= EOS; ) {
      i = maklin(lin, i, k3)
      if (i == ERR) {
         inject = ERR
         break
         $@$
      k1 = getind(curln)
      k2 = getind(nextln(curln))
      call relink(k1, k3, k3, k2)
      call relink(k3, k2, k1, k3)
      curln = curln + 1
      lastln = lastln + 1
      inject = OK
      $@$
   return
   end
# maklin (scratch file) - make new line entry, copy text to scratch
   integer function maklin(lin, i, newind)
   character lin(MAXLINE)
   integer addset, length
   integer i, j, junk, newind, txtend
   include cbuf
   include cscrat
   include ctxt

   maklin = ERR
   if (lastbf + BUFENT > MAXBUF)
      return         # no room for new line entry
   txtend = 1
   for (j = i; lin(j) ~= EOS; ) {
      junk = addset(lin(j), txt, txtend, MAXLINE)
      j = j + 1
      if (lin(j - 1) == NEWLINE)
         break
      $@$
   if (addset(EOS, txt, txtend, MAXLINE) == NO)
      return
   call seek(scrend, scr)   # add line to end of scratch file
   buf(lastbf + SEEKADR) = scrend
   buf(lastbf + LENG) = length(txt)
   call putlin(txt, scr)
   scrend = scrend + buf(lastbf + LENG)
   buf(lastbf + MARK) = NO
   newind = lastbf
   lastbf = lastbf + BUFENT
   maklin = j         # next character to be examined in lin
   return
   end
# setbuf (scratch file) - create scratch file, set up line 0
   subroutine setbuf
   integer create
   integer k
   include cbuf
   include clines
   include cscrat
#   string scrfil "scratch"
   integer scrfil(8)
#   string null ""
   integer null(1)
   data scrfil(1)/LETS/
   data scrfil(2)/LETC/
   data scrfil(3)/LETR/
   data scrfil(4)/LETA/
   data scrfil(5)/LETT/
   data scrfil(6)/LETC/
   data scrfil(7)/LETH/
   data scrfil(8)/EOS/
   data null(1) /EOS/

   scr = create(scrfil, READWRITE)
   if (scr == ERR)
      call cant(scrfil)
   scrend = 0
   lastbf = LINE0
   call maklin(null, 1, k)   # create empty line 0
   call relink(k, k, k, k)      # establish initial linked list
   curln = 0
   lastln = 0
   return
   end
========== text formatter of chapter 7 ==========
define(INSIZE,300)
define(MAXOUT,300)
define(COMMAND,PERIOD)
define(PAGENUM,SHARP)
define(PAGEWIDTH,60)
define(PAGELEN,66)

define(UNKNOWN,0)
define(FI,1)
define(NF,2)
define(BR,3)
define(LS,4)
define(BP,5)
define(SP,6)
define(IN,7)
define(RM,8)
define(TI,9)
define(CE,10)
define(UL,11)
define(HE,12)
define(FO,13)
define(PL,14)

define(HUGE,1000)
common /cout/ outp, outw, outwds, outbuf(MAXOUT)
   integer outp      # last char position in outbuf; init = 0
   integer outw      # width of text currently in outbuf; init = 0
   integer outwds      # number of words in outbuf; init = 0
   character outbuf      # lines to be filled collect here
common /cpage/ curpag,newpag,lineno,plval,m1val,m2val,m3val,m4val,
   bottom, header(MAXLINE), footer(MAXLINE)
   integer curpag   # current output page number; init = 0
   integer newpag   # next output page number; init = 1
   integer lineno   # next line to be printed; init = 0
   integer plval   # page length in lines; init = PAGELEN = 66
   integer m1val   # margin before and including header
   integer m2val   # margin after header
   integer m3val   # margin after last text line
   integer m4val   # bottom margin, including footer
   integer bottom   # last live line on page, = plval-m3val-m4val
   character header   # top of page title; init = NEWLINE
   character footer   # bottom of page title; init = NEWLINE
common /cparam/ fill, lsval, inval, rmval, tival, ceval, ulval
   integer fill      # fill if YES; init = YES
   integer lsval   # current line spacing; init = 1
   integer inval   # current indent; >= 0; init = 0
   integer rmval   # current right margin; init = PAGEWIDTH = 60
   integer tival   # current temporary indent; init = 0
   integer ceval   # number of lines to center; init = 0
   integer ulval   # number of lines to underline; init = 0
# brk - end current filled line
   subroutine brk
   include cout

   if (outp > 0) {
      outbuf(outp) = NEWLINE
      outbuf(outp+1) = EOS
      call put(outbuf)
      $@$
   outp = 0
   outw = 0
   outwds = 0
   return
   end
# center - center a line by setting tival
   subroutine center(buf)
   character buf(ARB)
   integer max, width
   include cparam

   tival = max((rmval+tival-width(buf))/2, 0)
   return
   end
# comand - perform formatting command
   subroutine comand(buf)
   character buf(MAXLINE)
   integer comtyp, getval, max
   integer argtyp, ct, spval, val
   include cpage
   include cparam

   ct = comtyp(buf)
   if (ct == UNKNOWN)   # ignore unknown commands
      return
   val = getval(buf, argtyp)
   if (ct == FI) {
      call brk
      fill = YES
      $@$
   else if (ct == NF) {
      call brk
      fill = NO
      $@$
   else if (ct == BR)
      call brk
   else if (ct == LS)
      call set(lsval, val, argtyp, 1, 1, HUGE)
   else if (ct == CE) {
      call brk
      call set(ceval, val, argtyp, 1, 0, HUGE)
      $@$
   else if (ct == UL)
      call set(ulval, val, argtyp, 0, 1, HUGE)
   else if (ct == HE)
      call gettl(buf, header)
   else if (ct == FO)
      call gettl(buf, footer)
   else if (ct == BP) {
      if (lineno > 0)
         call space(HUGE)
      call set(curpag, val, argtyp, curpag+1, -HUGE, HUGE)
      newpag = curpag
      $@$
   else if (ct == SP) {
      call set(spval, val, argtyp, 1, 0, HUGE)
      call space(spval)
      $@$
   else if (ct == IN) {
      call set(inval, val, argtyp, 0, 0, rmval-1)
      tival = inval
      $@$
   else if (ct == RM)
      call set(rmval, val, argtyp, PAGEWIDTH, tival+1, HUGE)
   else if (ct == TI) {
      call brk
      call set(tival, val, argtyp, 0, 0, rmval)
      $@$
   else if (ct == PL) {
      call set(plval, val, argtyp, PAGELEN,
         m1val+m2val+m3val+m4val+1, HUGE)
      bottom = plval - m3val - m4val
      $@$
   return
   end
# comtyp - decode command type
   integer function comtyp(buf)
   character buf(MAXLINE)

   if (buf(2) == LETF & buf(3) == LETI)
      comtyp = FI
   else if (buf(2) == LETN & buf(3) == LETF)
      comtyp = NF
   else if (buf(2) == LETB & buf(3) == LETR)
      comtyp = BR
   else if (buf(2) == LETL & buf(3) == LETS)
      comtyp = LS
   else if (buf(2) == LETB & buf(3) == LETP)
      comtyp = BP
   else if (buf(2) == LETS & buf(3) == LETP)
      comtyp = SP
   else if (buf(2) == LETI & buf(3) == LETN)
      comtyp = IN
   else if (buf(2) == LETR & buf(3) == LETM)
      comtyp = RM
   else if (buf(2) == LETT & buf(3) == LETI)
      comtyp = TI
   else if (buf(2) == LETC & buf(3) == LETE)
      comtyp = CE
   else if (buf(2) == LETU & buf(3) == LETL)
      comtyp = UL
   else if (buf(2) == LETH & buf(3) == LETE)
      comtyp = HE
   else if (buf(2) == LETF & buf(3) == LETO)
      comtyp = FO
   else if (buf(2) == LETP & buf(3) == LETL)
      comtyp = PL
   else
      comtyp = UNKNOWN
   return
   end
# format - text formatter main program (final version)
   character inbuf(INSIZE)
   integer getlin
   include cpage

   call init
   while (getlin(inbuf, STDIN) ~= EOF)
      if (inbuf(1) == COMMAND)   # it's a command
         call comand(inbuf)
      else               # it's text
         call text(inbuf)
   if (lineno > 0)
      call space(HUGE)         # flush last output
   stop
   end
# gettl - copy title from buf to ttl
   subroutine gettl(buf, ttl)
   character buf(MAXLINE), ttl(MAXLINE)
   integer i

   i = 1            # skip command name
   while (buf(i) ~= BLANK & buf(i) ~= TAB & buf(i) ~= NEWLINE)
      i = i + 1
   call skipbl(buf, i)      # find argument
   if (buf(i) == SQUOTE | buf(i) == DQUOTE)   # strip quote if found
      i = i + 1
   call scopy(buf, i, ttl, 1)
   return
   end
# getval - evaluate optional numeric argument
   integer function getval(buf, argtyp)
   character buf(MAXLINE)
   integer ctoi
   integer argtyp, i

   i = 1            # skip command name
   while (buf(i) ~= BLANK & buf(i) ~= TAB & buf(i) ~= NEWLINE)
      i = i + 1
   call skipbl(buf, i)      # find argument
   argtyp = buf(i)
   if (argtyp == PLUS | argtyp == MINUS)
      i = i + 1
   getval = ctoi(buf, i)
   return
   end
# getwrd - get non-blank word from in(i) into  out, increment i
   integer function getwrd(in, i, out)
   integer in(MAXLINE), out(MAXLINE)
   integer i, j

   while (in(i) == BLANK | in(i) == TAB)
      i = i + 1
   j = 1
   while (in(i)~=EOS & in(i)~=BLANK & in(i)~=TAB & in(i)~=NEWLINE) {
      out(j) = in(i)
      i = i + 1
      j = j + 1
      $@$
   out(j) = EOS
   getwrd = j - 1
   return
   end
# init - set parameters to default values
   subroutine init

   include cparam
   include cpage
   include cout

   inval = 0
   rmval = PAGEWIDTH
   tival = 0
   lsval = 1
   fill = YES
   ceval = 0
   ulval = 0
   lineno = 0
   curpag = 0
   newpag = 1
   plval = PAGELEN
   m1val = 3; m2val = 2; m3val = 2; m4val = 3
   bottom = plval - m3val - m4val
   header(1) = NEWLINE; header(2) = EOS   # initial titles
   footer(1) = NEWLINE; footer(2) = EOS
   outp = 0
   outw = 0
   outwds = 0

   return
   end
# leadbl - delete leading blanks, set tival
   subroutine leadbl(buf)
   character buf(MAXLINE)
   integer max
   integer i, j
   include cparam

   call brk
   for (i = 1; buf(i) == BLANK; i = i + 1)   # find 1st non-blank
      ;
   if (buf(i) ~= NEWLINE)
      tival = i - 1
   for (j = 1; buf(i) ~= EOS; j = j + 1) {   # move line to left
      buf(j) = buf(i)
      i = i + 1
      $@$
   buf(j) = EOS
   return
   end
# pfoot - put out page footer
   subroutine pfoot
   include cpage

   call skip(m3val)
   if (m4val > 0) {
      call puttl(footer, curpag)
      call skip(m4val-1)
      $@$
   return
   end
# phead - put out page header
   subroutine phead
   include cpage

   curpag = newpag
   newpag = newpag + 1
   if (m1val > 0) {
      call skip(m1val-1)
      call puttl(header, curpag)
      $@$
   call skip(m2val)
   lineno = m1val + m2val + 1
   return
   end
# put - put out line with proper spacing and indenting
   subroutine put(buf)
   character buf(MAXLINE)
   integer min
   integer i
   include cpage
   include cparam

   if (lineno == 0 | lineno > bottom)
      call phead
   for (i = 1; i <= tival; i = i + 1)      # indenting
      call putc(BLANK)
   tival = inval
   call putlin(buf, STDOUT)
   call skip(min(lsval-1, bottom-lineno))
   lineno = lineno + lsval
   if (lineno > bottom)
      call pfoot
   return
   end
# puttl - put out title line with optional page number
   subroutine puttl(buf, pageno)
   character buf(MAXLINE)
   integer pageno
   integer i

   for (i = 1; buf(i) ~= EOS; i = i + 1)
      if (buf(i) == PAGENUM)
         call putdec(pageno, 1)
      else
         call putc(buf(i))
   return
   end
# putwrd - put a word in outbuf; includes margin justification
   subroutine putwrd(wrdbuf)
   character wrdbuf(INSIZE)
   integer length, width
   integer last, llval, nextra, w
   include cout
   include cparam

   w = width(wrdbuf)
   last = length(wrdbuf) + outp + 1   # new end of outbuf
   llval = rmval - tival
   if (outp > 0 & (outw+w > llval | last >= MAXOUT)) {   # too big
      last = last - outp      # remember end of wrdbuf
      nextra = llval - outw + 1
      call spread(outbuf, outp, nextra, outwds)
      if (nextra > 0 & outwds > 1)
         outp = outp + nextra
      call brk         # flush previous line
      $@$
   call scopy(wrdbuf, 1, outbuf, outp+1)
   outp = last
   outbuf(outp) = BLANK      # blank between words
   outw = outw + w + 1      # 1 for blank
   outwds = outwds + 1
   return
   end
# set - set parameter and check range
   subroutine set(param, val, argtyp, defval, minval, maxval)
   integer max, min
   integer argtyp, defval, maxval, minval, param, val

   if (argtyp == NEWLINE)      # defaulted
      param = defval
   else if (argtyp == PLUS)      # relative +
      param = param + val
   else if (argtyp == MINUS)   # relative -
      param = param - val
   else               # absolute
      param = val
   param = min(param, maxval)
   param = max(param, minval)
   return
   end
# skip - output  n  blank lines
   subroutine skip(n)
   integer i, n

   for (i = 1; i <= n; i = i + 1) {
      call putc(PERIOD)
      call putc(NEWLINE)
      $@$
   return
   end
# skipbl - skip blanks and tabs at lin(i)...
   subroutine skipbl(lin, i)
   character lin(ARB)
   integer i

   while (lin(i) == BLANK | lin(i) == TAB)
      i = i + 1
   return
   end
# space - space  n  lines or to bottom of page
   subroutine space(n)
   integer min
   integer n
   include cpage

   call brk
   if (lineno > bottom)
      return
   if (lineno == 0)
      call phead
   call skip(min(n, bottom+1-lineno))
   lineno = lineno + n
   if (lineno > bottom)
      call pfoot
   return
   end
# spread - spread words to justify right margin
   subroutine spread(buf, outp, nextra, outwds)
   character buf(MAXOUT)
   integer min
   integer dir, i, j, nb, ne, nextra, nholes, outp, outwds
   data dir /0/

   if (nextra <= 0 | outwds <= 1)
      return
   dir = 1 - dir   # reverse previous direction
   ne = nextra
   nholes = outwds - 1
   i = outp - 1
   j = min(MAXOUT-2, i+ne)   # leave room for NEWLINE, EOS
   while (i < j) {
      buf(j) = buf(i)
      if (buf(i) == BLANK) {
         if (dir == 0)
            nb = (ne-1) / nholes + 1
         else
            nb = ne / nholes
         ne = ne - nb
         nholes = nholes - 1
         for ( ; nb > 0; nb = nb - 1) {
            j = j - 1
            buf(j) = BLANK
            $@$
         $@$
      i = i - 1
      j = j - 1
      $@$
   return
   end
# putwrd - put a word in outbuf
   subroutine putwrd(wrdbuf)
   character wrdbuf(INSIZE)
   integer length, width
   integer last, llval, w
   include cout
   include cparam

   w = width(wrdbuf)
   last = length(wrdbuf) + outp + 1   # new end of outbuf
   llval = rmval - tival
   if (outp > 0 & (outw+w > llval | last >= MAXOUT)) {   # too big
      last = last - outp      # remember end of wrdbuf
      call brk         # flush previous line
      $@$
   call scopy(wrdbuf, 1, outbuf, outp+1)
   outp = last
   outbuf(outp) = BLANK      # blank between words
   outw = outw + w + 1      # 1 for blank
   outwds = outwds + 1
   return
   end
# text - process text lines (final version)
   subroutine text(inbuf)
   character inbuf(INSIZE), wrdbuf(INSIZE)
   integer getwrd
   integer i
   include cparam

   if (inbuf(1) == BLANK | inbuf(1) == NEWLINE)
      call leadbl(inbuf)   # move left, set tival
   if (ulval > 0) {      # underlining
      call underl(inbuf, wrdbuf, INSIZE)
      ulval = ulval - 1
      $@$
   if (ceval > 0) {      # centering
      call center(inbuf)
      call put(inbuf)
      ceval = ceval - 1
      $@$
   else if (inbuf(1) == NEWLINE)   # all blank line
      call put(inbuf)
   else if (fill == NO)      # unfilled text
      call put(inbuf)
   else            # filled text
      for (i = 1; getwrd(inbuf, i, wrdbuf) > 0; )
         call putwrd(wrdbuf)
   return
   end
# text - process text lines (interim version 1)
   subroutine text(inbuf)
   character inbuf(INSIZE)

   call put(inbuf)
   return
   end
# text - process text lines (interim version 2)
   subroutine text(inbuf)
   character inbuf(INSIZE), wrdbuf(INSIZE)
   integer getwrd
   integer i
   include cparam

   if (inbuf(1) == BLANK | inbuf(1) == NEWLINE)
      call leadbl(inbuf)   # move left, set tival
   if (inbuf(1) == NEWLINE)   # all blank line
      call put(inbuf)
   else if (fill == NO)      # unfilled text
      call put(inbuf)
   else            # filled text
      for (i = 1; getwrd(inbuf, i, wrdbuf) > 0; )
         call putwrd(wrdbuf)
   return
   end
# underl - underline a line
   subroutine underl(buf, tbuf, size)
   integer i, j, size
   character buf(size), tbuf(size)

   j = 1      # expand into tbuf
   for (i = 1; buf(i) ~= NEWLINE & j < size-1; i = i + 1) {
      tbuf(j) = buf(i)
      j = j + 1
      if (buf(i) ~= BLANK & buf(i) ~= TAB & buf(i) ~= BACKSPACE) {
         tbuf(j) = BACKSPACE
         tbuf(j+1) = UNDERLINE
         j = j + 2
         $@$
      $@$
   tbuf(j) = NEWLINE
   tbuf(j+1) = EOS
   call scopy(tbuf, 1, buf, 1)   # copy it back to buf
   return
   end
# width - compute width of character string
   integer function width(buf)
   character buf(MAXLINE)
   integer i

   width = 0
   for (i = 1; buf(i) ~= EOS; i = i + 1)
      if (buf(i) == BACKSPACE)
         width = width - 1
      else if (buf(i) ~= NEWLINE)
         width = width + 1
   return
   end
========== macro processors of chapter 8 ==========
define(ALPHA,-100)
define(MAXTBL,500)
define(MAXPTR,50)
define(CALLSIZE,20)
define(ARGSIZE,100)
define(MAXDEF,200)
define(MAXTOK,200)

define(ARGFLAG,DOLLAR)

define(DEFTYPE,-10)
define(IFTYPE,-11)
define(INCTYPE,-12)
define(SUBTYPE,-13)

define(EVALSIZE,500)
define(BUFSIZE,500)
common /cdefio/ bp, buf(BUFSIZE)
   integer bp      # next available character; init = 0
   character buf   # pushed-back characters
common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL)
   integer lastp      # last used in namptr; init = 0
   integer lastt      # last used in table; init = 0
   integer namptr      # name pointers
   character table      # actual text of names and defns
common /cmacro/ cp, ep, evalst(EVALSIZE)
   integer cp         # current call stack pointer
   integer ep         # next free position in evalst
   character evalst      # evaluation stack
# block data for macro
   block data
   include cdefio
   data bp /0/
   end
# gettok - get alphanumeric string or single non-alpha for define
   character function gettok(token, toksiz)
   character ngetc, type
   integer i, toksiz
   character token(toksiz)

   for (i = 1; i < toksiz; i = i + 1) {
      gettok = type(ngetc(token(i)))
      if (gettok ~= LETTER & gettok ~= DIGIT)
         break
      $@$
   if (i >= toksiz)
      call error("token too long.")
   if (i > 1) {         # some alpha was seen
      call putbak(token(i))
      i = i - 1
      gettok = ALPHA
      $@$
   # else single character token
   token(i+1) = EOS
   return
   end
# lookup - locate name, extract definition from table
   integer function lookup(name, defn)
   character defn(MAXDEF), name(MAXTOK)
   integer i, j, k
   include clook

   for (i = lastp; i > 0; i = i - 1) {
      j = namptr(i)
      for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1)
         j = j + 1
      if (name(k) == table(j)) {      # got one
         call scopy(table, j+1, defn, 1)
         lookup = YES
         return
         $@$
      $@$
   lookup = NO
   return
   end

# instal - add name and definition to table
   subroutine instal(name, defn)
   character defn(MAXTOK), name(MAXDEF)
   integer length
   integer dlen, nlen
   include clook

   nlen = length(name) + 1
   dlen = length(defn) + 1
   if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) {
      call putlin(name, ERROUT)
      call remark(": too many definitions.")
      $@$
   lastp = lastp + 1
   namptr(lastp) = lastt + 1
   call scopy(name, 1, table, lastt + 1)
   call scopy(defn, 1, table, lastt + nlen + 1)
   lastt = lastt + nlen + dlen
   return
   end


#block data
   block data
   include clook

   data lastp /0/
   data lastt /0/

   end
# macro - expand macros with arguments
   character gettok
   character defn(MAXDEF), t, token(MAXTOK)
   integer lookup, push
   integer ap, argstk(ARGSIZE), callst(CALLSIZE), nlb, plev(CALLSIZE)
   include cmacro
#   string balp "()"
   integer balp(3)
#   string defnam "define"
   integer defnam(7)
#   string incnam "incr"
   integer incnam(5)
#   string subnam "substr"
   integer subnam(7)
#   string ifnam "ifelse"
   integer ifnam(7)
   integer deftyp(2)
   integer inctyp(2)
   integer subtyp(2)
   integer iftyp(2)
   data balp(1) /LPAREN/, balp(2) /RPAREN/, balp(3) /EOS/
   data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/
   data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/
   data defnam(7) /EOS/
   data incnam(1)/LETI/,incnam(2)/LETN/,incnam(3)/LETC/,incnam(4)/LETR/
   data incnam(5) /EOS/
   data subnam(1) /LETS/, subnam(2) /LETU/, subnam(3) /LETB/
   data subnam(4) /LETS/, subnam(5) /LETT/, subnam(6) /LETR/
   data subnam(7) /EOS/
   data ifnam(1) /LETI/, ifnam(2) /LETF/, ifnam(3) /LETE/
   data ifnam(4) /LETL/, ifnam(5) /LETS/, ifnam(6) /LETE/
   data ifnam(7) /EOS/
   data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/
   data inctyp(1) /INCTYPE/, inctyp(2) /EOS/
   data subtyp(1) /SUBTYPE/, subtyp(2) /EOS/
   data iftyp(1) /IFTYPE/, iftyp(2) /EOS/

   call instal(defnam, deftyp)
   call instal(incnam, inctyp)
   call instal(subnam, subtyp)
   call instal(ifnam, iftyp)

   cp = 0
   ap = 1
   ep = 1
   for (t=gettok(token, MAXTOK); t ~= EOF; t=gettok(token, MAXTOK)) {
      if (t == ALPHA) {
         if (lookup(token, defn) == NO)
            call puttok(token)
         else {            # defined; put it in eval stack
            cp = cp + 1
            if (cp > CALLSIZE)
               call error("call stack overflow.")
            callst(cp) = ap
            ap = push(ep, argstk, ap)
            call puttok(defn)   # stack definition
            call putchr(EOS)
            ap = push(ep, argstk, ap)
            call puttok(token)   # stack name
            call putchr(EOS)
            ap = push(ep, argstk, ap)
            t = gettok(token, MAXTOK)   # peek at next
            call pbstr(token)
            if (t ~= LPAREN)   # add ( ) if not present
               call pbstr(balp)
            plev(cp) = 0
            $@$
         $@$
      else if (t == LBRACK) {      # strip one level of [ ]
         nlb = 1
         repeat {
            t = gettok(token, MAXTOK)
            if (t == LBRACK)
               nlb = nlb + 1
            else if (t == RBRACK) {
               nlb = nlb - 1
               if (nlb == 0)
                  break
               $@$
            else if (t == EOF)
               call error("EOF in string.")
            call puttok(token)
            $@$
         $@$
      else if (cp == 0)         # not in a macro at all
         call puttok(token)
      else if (t == LPAREN) {
         if (plev(cp) > 0)
            call puttok(token)
         plev(cp) = plev(cp) + 1
         $@$
      else if (t == RPAREN) {
         plev(cp) = plev(cp) - 1
         if (plev(cp) > 0)
            call puttok(token)
         else {            # end of argument list
            call putchr(EOS)
            call eval(argstk, callst(cp), ap-1)
            ap = callst(cp)   # pop eval stack
            ep = argstk(ap)
            cp = cp - 1
            $@$
         $@$
      else if (t == COMMA & plev(cp) == 1) {   # new arg
         call putchr(EOS)
         ap = push(ep, argstk, ap)
         $@$
      else
         call puttok(token)      # just stack it
      $@$
   if (cp ~= 0)
      call error("unexpected EOF.")
   stop
   end

# push - push ep onto argstk, return new pointer ap
   integer function push(ep, argstk, ap)
   integer ap, argstk(ARGSIZE), ep

   if (ap > ARGSIZE)
      call error("arg stack overflow.")
   argstk(ap) = ep
   push = ap + 1
   return
   end

# puttok - put a token either on output or into evaluation stack
   subroutine puttok(str)
   character str(MAXTOK)
   integer i

   for (i = 1; str(i) ~= EOS; i = i + 1)
      call putchr(str(i))
   return
   end

# putchr - put single char on output or into evaluation stack
   subroutine putchr(c)
   character c
   include cmacro

   if (cp == 0)
      call putc(c)
   else {
      if (ep > EVALSIZE)
         call error("evaluation stack overflow.")
      evalst(ep) = c
      ep = ep + 1
      $@$
   return
   end

# eval - expand args i through j: evaluate builtin or push back defn
   subroutine eval(argstk, i, j)
   integer index, length
   integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td
   include cmacro
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/

   t = argstk(i)
   td = evalst(t)
   if (td == DEFTYPE)
      call dodef(argstk, i, j)
   else if (td == INCTYPE)
      call doincr(argstk, i, j)
   else if (td == SUBTYPE)
      call dosub(argstk, i, j)
   else if (td == IFTYPE)
      call doif(argstk, i, j)
   else {
      for (k = t+length(evalst(t))-1; k > t; k = k - 1)
         if (evalst(k-1) ~= ARGFLAG)
            call putbak(evalst(k))
         else {
            argno = index(digits, evalst(k)) - 1
            if (argno >= 0 & argno < j-i) {
               n = i + argno + 1
               m = argstk(n)
               call pbstr(evalst(m))
               $@$
            k = k - 1   # skip over $
            $@$
      if (k == t)         # do last character
         call putbak(evalst(k))
      $@$
   return
   end

# dodef - install definition in table
   subroutine dodef(argstk, i, j)
   integer a2, a3, argstk(ARGSIZE), i, j
   include cmacro

   if (j - i > 2) {
      a2 = argstk(i+2)
      a3 = argstk(i+3)
      call instal(evalst(a2), evalst(a3))   # subarrays
      $@$
   return
   end

# doincr - increment argument by 1
   subroutine doincr(argstk, i, j)
   integer ctoi
   integer argstk(ARGSIZE), i, j, k
   include cmacro

   k = argstk(i+2)
   call pbnum(ctoi(evalst, k)+1)
   return
   end

# pbnum - convert number to string, push back on input
   subroutine pbnum(n)
   integer mod
   integer m, n, num
#   string digits "0123456789"
   integer digits(11)
   data digits(1) /DIG0/
   data digits(2) /DIG1/
   data digits(3) /DIG2/
   data digits(4) /DIG3/
   data digits(5) /DIG4/
   data digits(6) /DIG5/
   data digits(7) /DIG6/
   data digits(8) /DIG7/
   data digits(9) /DIG8/
   data digits(10) /DIG9/
   data digits(11) /EOS/

   num = n
   repeat {
      m = mod(num, 10)
      call putbak(digits(m+1))
      num = num / 10
      $@$ until (num == 0)
   return
   end

# dosub - select substring
   subroutine dosub(argstk, i, j)
   integer ctoi, length, max, min
   integer ap, argstk(ARGSIZE), fc, i, j, k, nc
   include cmacro

   if (j - i < 3)
      return
   if (j - i < 4)
      nc = MAXTOK
   else {
      k = argstk(i+4)
      nc = ctoi(evalst, k)      # number of characters
      $@$
   k = argstk(i+3)         # origin
   ap = argstk(i+2)         # target string
   fc = ap + ctoi(evalst, k) - 1   # first char of substring
   if (fc >= ap & fc < ap + length(evalst(ap))) {   # subarrays
      k = fc + min(nc, length(evalst(fc))) - 1
      for ( ; k >= fc; k = k - 1)
         call putbak(evalst(k))
      $@$
   return
   end

# doif - select one of two arguments
   subroutine doif(argstk, i, j)
   integer equal
   integer a2, a3, a4, a5, argstk(ARGSIZE), i, j
   include cmacro

   if (j - i < 5)
      return
   a2 = argstk(i+2)
   a3 = argstk(i+3)
   a4 = argstk(i+4)
   a5 = argstk(i+5)
   if (equal(evalst(a2), evalst(a3)) == YES)   # subarrays
      call pbstr(evalst(a4))
   else
      call pbstr(evalst(a5))
   return
   end
# ngetc - get a (possibly pushed back) character
   character function ngetc(c)
   character getc
   character c
   include cdefio

   if (bp > 0)
      c = buf(bp)
   else {
      bp = 1
      buf(bp) = getc(c)
      $@$
   if (c ~= EOF)
      bp = bp - 1
   ngetc = c
   return
   end
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(MAXLINE)
   integer length
   integer i

   for (i = length(in); i > 0; i = i - 1)
      call putbak(in(i))
   return
   end

# putbak - push character back onto input
   subroutine putbak(c)
   character c
   include cdefio

   bp = bp + 1
   if (bp > BUFSIZE)
      call error("too many characters pushed back.")
   buf(bp) = c
   return
   end
# define - simple string replacement macro processor
   character gettok
   character defn(MAXDEF), t, token(MAXTOK)
   integer lookup
#   string defnam "define"
   integer defnam(7)
   integer deftyp(2)
   data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/
   data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/
   data defnam(7) /EOS/
   data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/

   call instal(defnam, deftyp)
   for (t = gettok(token, MAXTOK); t ~= EOF; t = gettok(token, MAXTOK))
      if (t ~= ALPHA)      # output non-alpha tokens
         call putlin(token, STDOUT)
      else if (lookup(token, defn) == NO)   # and undefined
         call putlin(token, STDOUT)
      else if (defn(1) == DEFTYPE) {      # get definition
         call getdef(token, MAXTOK, defn, MAXDEF)
         call instal(token, defn)
         $@$
      else
         call pbstr(defn)   # push replacement onto input
   stop
   end

# getdef (for no arguments) - get name and definition
   subroutine getdef(token, toksiz, defn, defsiz)
   character gettok, ngetc
   integer defsiz, i, nlpar, toksiz
   character c, defn(defsiz), token(toksiz)

   if (ngetc(c) ~= LPAREN)
      call error("missing left paren.")
   else if (gettok(token, toksiz) ~= ALPHA)
      call error("non-alphanumeric name.")
   else if (ngetc(c) ~= COMMA)
      call error("missing comma in define.")
   # else got (name,
   nlpar = 0
   for (i = 1; nlpar >= 0; i = i + 1)
      if (i > defsiz)
         call error("definition too long.")
      else if (ngetc(defn(i)) == EOF)
         call error("missing right paren.")
      else if (defn(i) == LPAREN)
         nlpar = nlpar + 1
      else if (defn(i) == RPAREN)
         nlpar = nlpar - 1
      # else normal character in defn(i)
   defn(i-1) = EOS
   return
   end
========== ratfor of chapter 9 ==========
define(MAXSTACK,10)

define(LEXDIGITS,-260)
define(LEXIF,-261)
define(LEXELSE,-262)
define(LEXWHILE,-263)
define(LEXBREAK,-264)
define(LEXNEXT,-265)
define(LEXDO,-266)
define(LEXOTHER,-267)
define(ALPHA,-100)
define(MAXTOK,10)
define(ALPHA,-100)
define(MAXTBL,500)
define(MAXPTR,50)
define(CALLSIZE,20)
define(ARGSIZE,100)
define(MAXDEF,200)
define(MAXTOK,200)

define(ARGFLAG,DOLLAR)

define(DEFTYPE,-10)
define(IFTYPE,-11)
define(INCTYPE,-12)
define(SUBTYPE,-13)

define(EVALSIZE,500)
define(BUFSIZE,500)
common /cdefio/ bp, buf(BUFSIZE)
   integer bp      # next available character; init = 0
   character buf   # pushed-back characters
common /cline/ linect
   integer linect   # line count on input file; init = 1
common /clook/ lastp, lastt, namptr(MAXPTR), table(MAXTBL)
   integer lastp      # last used in namptr; init = 0
   integer lastt      # last used in table; init = 0
   integer namptr      # name pointers
   character table      # actual text of names and defns
common /coutln/ outp, outbuf(MAXLINE)
   integer outp      # last position filled in outbuf; init = 0
   character outbuf      # output lines collected here
# alldig - return YES if str is all digits
   integer function alldig(str)
   character type
   character str(ARB)
   integer i

   alldig = NO
   if (str(1) == EOS)
      return
   for (i = 1; str(i) ~= EOS; i = i + 1)
      if (type(str(i)) ~= DIGIT)
         return
   alldig = YES
   return
   end
# balpar - copy balanced paren string
   subroutine balpar
   character gettok
   character t, token(MAXTOK)
   integer nlpar

   if (gettok(token, MAXTOK) ~= LPAREN) {
      call synerr("missing left paren.")
      return
      $@$
   call outstr(token)
   nlpar = 1
   repeat {
      t = gettok(token, MAXTOK)
      if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) {
         call pbstr(token)
         break
         $@$
      if (t == NEWLINE)      # delete newlines
         token(1) = EOS
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      # else nothing special
      call outstr(token)
      $@$ until (nlpar <= 0)
   if (nlpar ~= 0)
      call synerr("missing parenthesis in condition.")
   return
   end
#block data
   block data

   include coutln
   include cline
   include cdefio

   data outp /0/
   data linect/1/
   data bp /0/

   end
# brknxt - generate code for break and next
   subroutine brknxt(sp, lextyp, labval, token)
   integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token

   for (i = sp; i > 0; i = i - 1)
      if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO) {
         if (token == LEXBREAK)
            call outgo(labval(i)+1)
         else
            call outgo(labval(i))
         return
         $@$
   if (token == LEXBREAK)
      call synerr("illegal break.")
   else
      call synerr("illegal next.")
   return
   end
# docode - generate code for beginning of do
   subroutine docode(lab)
   integer labgen
   integer lab
#   string dostr "do"
   integer dostr(4)
   data dostr(1), dostr(2), dostr(3),
   dostr(4)/LETD, LETO, BLANK, EOS/

   call outtab
   call outstr(dostr)
   lab = labgen(2)
   call outnum(lab)
   call eatup
   call outdon
   return
   end
# dostat - generate code for end of do statement
   subroutine dostat(lab)
   integer lab

   call outcon(lab)
   call outcon(lab+1)
   return
   end
# eatup - process rest of statement; interpret continuations
   subroutine eatup
   character gettok
   character ptoken(MAXTOK), t, token(MAXTOK)
   integer nlpar

   nlpar = 0
   repeat {
      t = gettok(token, MAXTOK)
      if (t == SEMICOL | t == NEWLINE)
         break
      if (t == RBRACE) {
         call pbstr(token)
         break
         $@$
      if (t == LBRACE | t == EOF) {
         call synerr("unexpected brace or EOF.")
         call pbstr(token)
         break
         $@$
      if (t == COMMA) {
         if (gettok(ptoken, MAXTOK) ~= NEWLINE)
            call pbstr(ptoken)
         $@$
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      call outstr(token)
      $@$ until (nlpar < 0)
   if (nlpar ~= 0)
      call synerr("unbalanced parentheses.")
   return
   end
# elseif - generate code for end of if before else
   subroutine elseif(lab)
   integer lab

   call outgo(lab+1)
   call outcon(lab)
   return
   end
# gettok - get token for Ratfor
   character function gettok(lexstr, toksiz)
   character ngetc, type
   integer i, toksiz
   character c, lexstr(toksiz)
   include cline

   while (ngetc(c) ~= EOF)
      if (c ~= BLANK & c ~= TAB)
         break
   call putbak(c)
   for (i = 1; i < toksiz-1; i = i + 1) {
      gettok = type(ngetc(lexstr(i)))
      if (gettok ~= LETTER & gettok ~= DIGIT)
         break
      $@$
   if (i >= toksiz-1)
      call synerr("token too long.")
   if (i > 1) {            # some alpha seen
      call putbak(lexstr(i))      # went one too far
      lexstr(i) = EOS
      gettok = ALPHA
      $@$
   else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) {
      for (i = 2; ngetc(lexstr(i)) ~= lexstr(1); i = i + 1)
         if (lexstr(i) == NEWLINE | i >= toksiz-1) {
            call synerr("missing quote.")
            lexstr(i) = lexstr(1)
            call putbak(NEWLINE)
            break
            $@$
      $@$
   else if (lexstr(1) == SHARP) {   # strip comments
      while (ngetc(lexstr(1)) ~= NEWLINE)
         ;
      gettok = NEWLINE
      $@$
   lexstr(i+1) = EOS
   if (lexstr(1) == NEWLINE)
      linect = linect + 1
   return
   end
# ifcode - generate initial code for if
   subroutine ifcode(lab)
   integer labgen
   integer lab

   lab = labgen(2)
   call ifgo(lab)
   return
   end
# ifgo - generate "if(.not.(...))goto lab"
   subroutine ifgo(lab)
   integer lab
#   string ifnot "if(.not."
   integer ifnot(9)
      data ifnot(1) /LETI/
      data ifnot(2) /LETF/
      data ifnot(3) /LPAREN/
      data ifnot(4) /PERIOD/
      data ifnot(5) /LETN/
      data ifnot(6) /LETO/
      data ifnot(7) /LETT/
      data ifnot(8) /PERIOD/
      data ifnot(9) /EOS/

   call outtab         # get to column 7
   call outstr(ifnot)      # " if(.not. "
   call balpar         # collect and output condition
   call outch(RPAREN)      # " ) "
   call outgo(lab)      # " goto lab "
   return
   end
# initkw - initialize keyword tables
   subroutine initkw

   integer sdo(3), sif(3), selse(5), swhile(6), sbreak(6), snext(5)
   integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2)

   data sdo(1),sdo(2),sdo(3) /LETD,LETO,EOS/
   data vdo(1),vdo(2) /LEXDO,EOS/

   data sif(1),sif(2),sif(3) /LETI,LETF,EOS/
   data vif(1),vif(2) /LEXIF,EOS/

   data selse(1),selse(2),selse(3),selse(4),selse(5) /LETE,
      LETL,LETS,LETE,EOS/
   data velse(1),velse(2) /LEXELSE,EOS/

   data swhile(1),swhile(2),swhile(3),swhile(4),swhile(5),
      swhile(6) /LETW,LETH,LETI,LETL,LETE,EOS/
   data vwhile(1),vwhile(2) /LEXWHILE,EOS/

   data sbreak(1),sbreak(2),sbreak(3),sbreak(4),sbreak(5),
      sbreak(6) /LETB,LETR,LETE,LETA,LETK,EOS/
   data vbreak(1),vbreak(2) /LEXBREAK,EOS/

   data snext(1),snext(2),snext(3),snext(4),snext(5) /LETN,
      LETE,LETX,LETT,EOS/
   data vnext(1),vnext(2) /LEXNEXT,EOS/

   call instal(sdo,vdo)
   call instal(sif,vif)
   call instal(selse,velse)
   call instal(swhile,vwhile)
   call instal(sbreak,vbreak)
   call instal(snext,vnext)

   return
   end
# labelc - output statement number
   subroutine labelc(lexstr)
   character lexstr(ARB)
   integer length

   if (length(lexstr) == 5)   # warn about 23xxx labels
      if (lexstr(1) == DIG2 & lexstr(2) == DIG3)
         call synerr("warning: possible label conflict.")
   call outstr(lexstr)
   call outtab
   return
   end
# labgen - generate  n  consecutive labels, return first one
   integer function labgen(n)
   integer label, n
   data label /23000/

   labgen = label
   label = label + n
   return
   end
# lex - return lexical type of token
   integer function lex(lexstr)
   character gettok
   character lexstr(MAXTOK)
   integer alldig, lookup
   integer ltype(2)

   while (gettok(lexstr, MAXTOK) == NEWLINE)
      ;
   lex = lexstr(1)
   if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE)
      return
   if (alldig(lexstr) == YES)
      lex = LEXDIGITS
   else if (lookup(lexstr, ltype) == YES)
      lex = ltype(1)
   else
      lex = LEXOTHER
   return
   end
# lookup - locate name, extract definition from table
   integer function lookup(name, defn)
   character defn(MAXDEF), name(MAXTOK)
   integer i, j, k
   include clook

   for (i = lastp; i > 0; i = i - 1) {
      j = namptr(i)
      for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1)
         j = j + 1
      if (name(k) == table(j)) {      # got one
         call scopy(table, j+1, defn, 1)
         lookup = YES
         return
         $@$
      $@$
   lookup = NO
   return
   end

# instal - add name and definition to table
   subroutine instal(name, defn)
   character defn(MAXTOK), name(MAXDEF)
   integer length
   integer dlen, nlen
   include clook

   nlen = length(name) + 1
   dlen = length(defn) + 1
   if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) {
      call putlin(name, ERROUT)
      call remark(": too many definitions.")
      $@$
   lastp = lastp + 1
   namptr(lastp) = lastt + 1
   call scopy(name, 1, table, lastt + 1)
   call scopy(defn, 1, table, lastt + nlen + 1)
   lastt = lastt + nlen + dlen
   return
   end


#block data
   block data
   include clook

   data lastp /0/
   data lastt /0/

   end
# ngetc - get a (possibly pushed back) character
   character function ngetc(c)
   character getc
   character c
   include cdefio

   if (bp > 0)
      c = buf(bp)
   else {
      bp = 1
      buf(bp) = getc(c)
      $@$
   if (c ~= EOF)
      bp = bp - 1
   ngetc = c
   return
   end
# otherc - output ordinary Fortran statement
   subroutine otherc(lexstr)
   character lexstr(ARB)

   call outtab
   call outstr(lexstr)
   call eatup
   call outdon
   return
   end
# outch - put one character into output buffer
   subroutine outch(c)
   character c
   integer i
   include coutln

   if (outp >= 72) {   # continuation card
      call outdon
      for (i = 1; i < 6; i = i + 1)
         outbuf(i) = BLANK
      outbuf(6) = STAR
      outp = 6
      $@$
   outp = outp + 1
   outbuf(outp) = c
   return
   end
# outcon - output "n   continue"
   subroutine outcon(n)
   integer n
#   string contin "continue"
   integer contin(9)
      data contin(1) /LETC/
      data contin(2) /LETO/
      data contin(3) /LETN/
      data contin(4) /LETT/
      data contin(5) /LETI/
      data contin(6) /LETN/
      data contin(7) /LETU/
      data contin(8) /LETE/
      data contin(9) /EOS/

   if (n > 0)
      call outnum(n)
   call outtab
   call outstr(contin)
   call outdon
   return
   end
# outdon - finish off an output line
   subroutine outdon
   include coutln

   outbuf(outp+1) = NEWLINE
   outbuf(outp+2) = EOS
   call putlin(outbuf, STDOUT)
   outp = 0
   return
   end
# outgo - output "goto  n"
   subroutine outgo(n)
   integer n
#   string goto "goto"
   integer goto(6)
      data goto(1) /LETG/
      data goto(2) /LETO/
      data goto(3) /LETT/
      data goto(4) /LETO/
      data goto(5) /BLANK/
      data goto(6) /EOS/

   call outtab
   call outstr(goto)
   call outnum(n)
   call outdon
   return
   end
define(MAXCHARS,10)
# outnum - output decimal number
   subroutine outnum(n)
   character chars(MAXCHARS)
   integer itoc
   integer i, len, n

   len = itoc(n, chars, MAXCHARS)
   for (i = 1; i <= len; i = i + 1)
      call outch(chars(i))
   return
   end
# outstr - output string
   subroutine outstr(str)
   character c, str(ARB)
   integer i, j

   for (i = 1; str(i) ~= EOS; i = i + 1) {
      c = str(i)
      if (c ~= SQUOTE & c ~= DQUOTE)
         call outch(c)
      else {
         i = i + 1
         for (j = i; str(j) ~= c; j = j + 1)   # find end
            ;
         call outnum(j-i)
         call outch(LETH)
         for ( ; i < j; i = i + 1)
            call outch(str(i))
         $@$
      $@$
   return
   end
# outtab - get past column 6
   subroutine outtab
   include coutln

   while (outp < 6)
      call outch(BLANK)
   return
   end
# parse - parse Ratfor source program
   subroutine parse
   character lexstr(MAXTOK)
   integer lex
   integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token

   call initkw   # install keywords in table
   sp = 1
   lextyp(1) = EOF
   for (token = lex(lexstr); token ~= EOF; token = lex(lexstr)) {
      if (token == LEXIF)
         call ifcode(lab)
      else if (token == LEXDO)
         call docode(lab)
      else if (token == LEXWHILE)
         call whilec(lab)
      else if (token == LEXDIGITS)
         call labelc(lexstr)
      else if (token == LEXELSE) {
         if (lextyp(sp) == LEXIF)
            call elseif(labval(sp))
         else
            call synerr("illegal else.")
         $@$
      if (token==LEXIF | token==LEXELSE | token==LEXWHILE
        | token==LEXDO | token==LEXDIGITS | token==LBRACE) {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call error("stack overflow in parser.")
         lextyp(sp) = token      # stack type and value
         labval(sp) = lab
         $@$
      else {      # end of statement - prepare to unstack
         if (token == RBRACE) {
            if (lextyp(sp) == LBRACE)
               sp = sp - 1
            else
               call synerr("illegal right brace.")
            $@$
         else if (token == LEXOTHER)
            call otherc(lexstr)
         else if (token == LEXBREAK | token == LEXNEXT)
            call brknxt(sp, lextyp, labval, token)
         token = lex(lexstr)      # peek at next token
         call pbstr(lexstr)
         call unstak(sp, lextyp, labval, token)
         $@$
      $@$
   if (sp ~= 1)
      call synerr("unexpected EOF.")
   return
   end
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(MAXLINE)
   integer length
   integer i

   for (i = length(in); i > 0; i = i - 1)
      call putbak(in(i))
   return
   end

# putbak - push character back onto input
   subroutine putbak(c)
   character c
   include cdefio

   bp = bp + 1
   if (bp > BUFSIZE)
      call error("too many characters pushed back.")
   buf(bp) = c
   return
   end
# ratfor - main program for Ratfor
   call parse
   stop
   end
# synerr - report Ratfor syntax error
   subroutine synerr(msg)
   character lc(MAXLINE), msg(MAXLINE)
   integer itoc
   integer junk
   include cline

   call remark("error at line .")
   junk = itoc(linect, lc, MAXLINE)
   call putlin(lc, ERROUT)
   call putch(COLON, ERROUT)
   call remark(msg)
   return
   end
# unstak - unstack at end of statement
   subroutine unstak(sp, lextyp, labval, token)
   integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token

   for ( ; sp > 1; sp = sp - 1) {
      if (lextyp(sp) == LBRACE)
         break
      if (lextyp(sp) == LEXIF & token == LEXELSE)
         break
      if (lextyp(sp) == LEXIF)
         call outcon(labval(sp))
      else if (lextyp(sp) == LEXELSE) {
         if (sp > 2)
            sp = sp - 1
         call outcon(labval(sp)+1)
         $@$
      else if (lextyp(sp) == LEXDO)
         call dostat(labval(sp))
      else if (lextyp(sp) == LEXWHILE)
         call whiles(labval(sp))
      $@$
   return
   end
# whilec - generate code for beginning of while
   subroutine whilec(lab)
   integer labgen
   integer lab

   call outcon(0)    # unlabeled continue, in case there was a label
   lab = labgen(2)
   call outnum(lab)
   call ifgo(lab+1)
   return
   end
# whiles - generate code for end of while
   subroutine whiles(lab)
   integer lab

   call outgo(lab)
   call outcon(lab+1)
   return
   end
========== end of information ==========
