1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
#-h- deftok 4116 local 12/01/80 15:53:47
# deftok - get token; process macro calls and invocations
include defs
# this routine has been disabled to allow defines with parameters to be added
# character function deftok (token, toksiz)
# character gtok
# integer toksiz
# character defn (MAXDEF), t, token (MAXTOK)
# integer ludef
# include COMMON_BLOCKS
#
# for (t = gtok (token, toksiz); t!=EOF; t = gtok (token, toksiz)) {
# if (t != ALPHA) # non-alpha
# break
# if (ludef (token, defn, deftbl) == NO) # undefined
# break
# if (defn (1) == DEFTYPE) { # get definition
# call getdef (token, toksiz, defn, MAXDEF)
# call entdef (token, defn, deftbl)
# }
# else
# call pbstr (defn) # push replacement onto input
# }
# deftok = t
# if (deftok == ALPHA) # convert to single case
# call fold (token)
# return
# end
# deftok - get token; process macro calls and invocations
character function deftok (token, toksiz)
character token (MAXTOK)
integer toksiz
include COMMON_BLOCKS
character t, c, defn (MAXDEF), mdefn (MAXDEF)
character gtok
integer equal
integer ap, argstk (ARGSIZE), callst (CALLSIZE),
nlb, plev (CALLSIZE), ifl
integer ludef, push, ifparm
string balp "()"
string pswrg "switch_no_range_check"
cp = 0
ap = 1
ep = 1
for (t = gtok (token, toksiz); t != EOF; t = gtok (token, toksiz)) {
if (t == ALPHA)
if (ludef (token, defn, deftbl) == NO) {
if (cp == 0)
break
else
call puttok (token)
} else if (defn (1) == DEFTYPE) { # process defines directly
call getdef (token, toksiz, defn, MAXDEF)
call entdef (token, defn, deftbl)
} else if (defn (1) == IFDEFTYPE | defn (1) == IFNOTDEFTYPE) {
c = defn (1)
call getdef (token, toksiz, defn, MAXDEF)
ifl = ludef (token, mdefn, deftbl)
if ((ifl == YES & c == IFDEFTYPE) |
(ifl == NO & c == IFNOTDEFTYPE))
call pbstr (defn)
} else if (defn(1) == PRAGMATYPE & cp == 0) { # pragma
if (gtok (defn, MAXDEF) == BLANK) {
if (gtok (defn, MAXDEF) == ALPHA) {
if (equal (defn, pswrg) == YES)
swinrg = YES
else
goto 10
} else {
10 call pbstr (defn)
call putbak (BLANK)
break
}
} else {
call pbstr (defn)
break
}
} else {
cp = cp + 1
if (cp > CALLSIZE)
call baderr ("call stack overflow.")
callst (cp) = ap
ap = push (ep, argstk, ap)
call puttok (defn)
call putchr (EOS)
ap = push (ep, argstk, ap)
call puttok (token)
call putchr (EOS)
ap = push (ep, argstk, ap)
t = gtok (token, toksiz)
if (t == BLANK) { # allow blanks before arguments
t = gtok (token, toksiz)
call pbstr (token)
if (t != LPAREN)
call putbak (BLANK)
}
else
call pbstr (token)
if (t != LPAREN)
call pbstr (balp)
else if (ifparm (defn) == NO)
call pbstr (balp)
plev (cp) = 0
} else if (t == LSTRIPC) {
nlb = 1
repeat {
t = gtok (token, toksiz)
if (t == LSTRIPC)
nlb = nlb + 1
else if (t == RSTRIPC) {
nlb = nlb - 1
if (nlb == 0)
break
}
else if (t == EOF)
call baderr ("EOF in string.")
call puttok (token)
}
}
else if (cp == 0)
break
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 {
call putchr (EOS)
call evalr (argstk, callst (cp), ap - 1)
ap = callst (cp)
ep = argstk (ap)
cp = cp - 1
}
}
else if (t == COMMA & plev (cp) == 1) {
call putchr (EOS)
ap = push (ep, argstk, ap)
}
else
call puttok (token)
}
deftok = t
if (t == ALPHA)
call fold (token)
return
end
|
