========== 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 ==========