Commit | Line | Data |
---|---|---|
5c0fc6b7 CH |
1 | /* Copyright (c) 1979 Regents of the University of California */ |
2 | # | |
3 | /* | |
4 | * pi - Pascal interpreter code translator | |
5 | * | |
6 | * Charles Haley, Bill Joy UCB | |
7 | * Version 1.2 November 1978 | |
8 | */ | |
9 | ||
10 | #include "whoami" | |
11 | #include "0.h" | |
12 | #include "tree.h" | |
13 | #include "opcode.h" | |
14 | ||
15 | extern int flagwas; | |
16 | /* | |
17 | * Lvalue computes the address | |
18 | * of a qualified name and | |
19 | * leaves it on the stack. | |
20 | */ | |
21 | struct nl * | |
22 | lvalue(r, modflag) | |
23 | int *r, modflag; | |
24 | { | |
25 | register struct nl *p; | |
26 | struct nl *firstp, *lastp; | |
27 | register *c, *co; | |
28 | int f, o; | |
29 | /* | |
30 | * Note that the local optimizations | |
31 | * done here for offsets would more | |
32 | * appropriately be done in put. | |
33 | */ | |
34 | int tr[2], trp[3]; | |
35 | ||
36 | if (r == NIL) | |
37 | return (NIL); | |
38 | if (nowexp(r)) | |
39 | return (NIL); | |
40 | if (r[0] != T_VAR) { | |
41 | error("Variable required"); /* Pass mesgs down from pt of call ? */ | |
42 | return (NIL); | |
43 | } | |
44 | firstp = p = lookup(r[2]); | |
45 | if (p == NIL) | |
46 | return (NIL); | |
47 | c = r[3]; | |
48 | if ((modflag & NOUSE) && !lptr(c)) | |
49 | p->nl_flags = flagwas; | |
50 | if (modflag & MOD) | |
51 | p->nl_flags |= NMOD; | |
52 | /* | |
53 | * Only possibilities for p->class here | |
54 | * are the named classes, i.e. CONST, TYPE | |
55 | * VAR, PROC, FUNC, REF, or a WITHPTR. | |
56 | */ | |
57 | switch (p->class) { | |
58 | case WITHPTR: | |
59 | /* | |
60 | * Construct the tree implied by | |
61 | * the with statement | |
62 | */ | |
63 | trp[0] = T_LISTPP; | |
64 | trp[1] = tr; | |
65 | trp[2] = r[3]; | |
66 | tr[0] = T_FIELD; | |
67 | tr[1] = r[2]; | |
68 | c = trp; | |
69 | # ifdef PTREE | |
70 | /* | |
71 | * mung r[4] to say which field this T_VAR is | |
72 | * for VarCopy | |
73 | */ | |
74 | r[4] = reclook( p -> type , r[2] ); | |
75 | # endif | |
76 | /* and fall through */ | |
77 | case REF: | |
78 | /* | |
79 | * Obtain the indirect word | |
80 | * of the WITHPTR or REF | |
81 | * as the base of our lvalue | |
82 | */ | |
83 | # ifdef VAX | |
84 | put2 ( O_RV4 | bn << 9 , p->value[0] ); | |
85 | # endif | |
86 | # ifdef PDP11 | |
87 | put2(O_RV2 | bn << 9, p->value[0]); | |
88 | # endif | |
89 | f = 0; /* have an lv on stack */ | |
90 | o = 0; | |
91 | break; | |
92 | case VAR: | |
93 | f = 1; /* no lv on stack yet */ | |
94 | o = p->value[0]; | |
95 | break; | |
96 | default: | |
97 | error("%s %s found where variable required", classes[p->class], p->symbol); | |
98 | return (NIL); | |
99 | } | |
100 | /* | |
101 | * Loop and handle each | |
102 | * qualification on the name | |
103 | */ | |
104 | if (c == NIL && (modflag&ASGN) && p->value[NL_FORV]) { | |
105 | error("Can't modify the for variable %s in the range of the loop", p->symbol); | |
106 | return (NIL); | |
107 | } | |
108 | for (; c != NIL; c = c[2]) { | |
109 | co = c[1]; | |
110 | if (co == NIL) | |
111 | return (NIL); | |
112 | lastp = p; | |
113 | p = p->type; | |
114 | if (p == NIL) | |
115 | return (NIL); | |
116 | switch (co[0]) { | |
117 | case T_PTR: | |
118 | /* | |
119 | * Pointer qualification. | |
120 | */ | |
121 | lastp->nl_flags |= NUSED; | |
122 | if (p->class != PTR && p->class != FILET) { | |
123 | error("^ allowed only on files and pointers, not on %ss", nameof(p)); | |
124 | goto bad; | |
125 | } | |
126 | if (f) | |
127 | # ifdef VAX | |
128 | put2 ( O_RV4 | bn << 9 , o ); | |
129 | # endif | |
130 | # ifdef PDP11 | |
131 | put2(O_RV2 | bn<<9, o); | |
132 | # endif | |
133 | else { | |
134 | if (o) | |
135 | put2(O_OFF, o); | |
136 | # ifdef VAX | |
137 | put1 ( O_IND4 ); | |
138 | # endif | |
139 | # ifdef PDP11 | |
140 | put1(O_IND2); | |
141 | # endif | |
142 | } | |
143 | /* | |
144 | * Pointer cannot be | |
145 | * nil and file cannot | |
146 | * be at end-of-file. | |
147 | */ | |
148 | put1(p->class == FILET ? O_FNIL : O_NIL); | |
149 | f = o = 0; | |
150 | continue; | |
151 | case T_ARGL: | |
152 | if (p->class != ARRAY) { | |
153 | if (lastp == firstp) | |
154 | error("%s is a %s, not a function", r[2], classes[firstp->class]); | |
155 | else | |
156 | error("Illegal function qualificiation"); | |
157 | return (NIL); | |
158 | } | |
159 | recovered(); | |
160 | error("Pascal uses [] for subscripting, not ()"); | |
161 | case T_ARY: | |
162 | if (p->class != ARRAY) { | |
163 | error("Subscripting allowed only on arrays, not on %ss", nameof(p)); | |
164 | goto bad; | |
165 | } | |
166 | if (f) | |
167 | put2(O_LV | bn<<9, o); | |
168 | else if (o) | |
169 | put2(O_OFF, o); | |
170 | switch (arycod(p, co[1])) { | |
171 | case 0: | |
172 | return (NIL); | |
173 | case -1: | |
174 | goto bad; | |
175 | } | |
176 | f = o = 0; | |
177 | continue; | |
178 | case T_FIELD: | |
179 | /* | |
180 | * Field names are just | |
181 | * an offset with some | |
182 | * semantic checking. | |
183 | */ | |
184 | if (p->class != RECORD) { | |
185 | error(". allowed only on records, not on %ss", nameof(p)); | |
186 | goto bad; | |
187 | } | |
188 | if (co[1] == NIL) | |
189 | return (NIL); | |
190 | p = reclook(p, co[1]); | |
191 | if (p == NIL) { | |
192 | error("%s is not a field in this record", co[1]); | |
193 | goto bad; | |
194 | } | |
195 | # ifdef PTREE | |
196 | /* | |
197 | * mung co[3] to indicate which field | |
198 | * this is for SelCopy | |
199 | */ | |
200 | co[3] = p; | |
201 | # endif | |
202 | if (modflag & MOD) | |
203 | p->nl_flags |= NMOD; | |
204 | if ((modflag & NOUSE) == 0 || lptr(c[2])) | |
205 | p->nl_flags |= NUSED; | |
206 | o += p->value[0]; | |
207 | continue; | |
208 | default: | |
209 | panic("lval2"); | |
210 | } | |
211 | } | |
212 | if (f) | |
213 | put2(O_LV | bn<<9, o); | |
214 | else if (o) | |
215 | put2(O_OFF, o); | |
216 | return (p->type); | |
217 | bad: | |
218 | cerror("Error occurred on qualification of %s", r[2]); | |
219 | return (NIL); | |
220 | } | |
221 | ||
222 | lptr(c) | |
223 | register int *c; | |
224 | { | |
225 | register int *co; | |
226 | ||
227 | for (; c != NIL; c = c[2]) { | |
228 | co = c[1]; | |
229 | if (co == NIL) | |
230 | return (NIL); | |
231 | switch (co[0]) { | |
232 | ||
233 | case T_PTR: | |
234 | return (1); | |
235 | case T_ARGL: | |
236 | return (0); | |
237 | case T_ARY: | |
238 | case T_FIELD: | |
239 | continue; | |
240 | default: | |
241 | panic("lptr"); | |
242 | } | |
243 | } | |
244 | return (0); | |
245 | } | |
246 | ||
247 | /* | |
248 | * Arycod does the | |
249 | * code generation | |
250 | * for subscripting. | |
251 | */ | |
252 | arycod(np, el) | |
253 | struct nl *np; | |
254 | int *el; | |
255 | { | |
256 | register struct nl *p, *ap; | |
257 | int i, d, v, v1; | |
258 | int w; | |
259 | ||
260 | p = np; | |
261 | if (el == NIL) | |
262 | return (0); | |
263 | d = p->value[0]; | |
264 | /* | |
265 | * Check each subscript | |
266 | */ | |
267 | for (i = 1; i <= d; i++) { | |
268 | if (el == NIL) { | |
269 | error("Too few subscripts (%d given, %d required)", i-1, d); | |
270 | return (-1); | |
271 | } | |
272 | p = p->chain; | |
273 | ap = rvalue(el[1], NLNIL); | |
274 | if (ap == NIL) | |
275 | return (0); | |
276 | if (incompat(ap, p->type, el[1])) { | |
277 | cerror("Array index type incompatible with declared index type"); | |
278 | if (d != 1) | |
279 | cerror("Error occurred on index number %d", i); | |
280 | return (-1); | |
281 | } | |
282 | w = aryconst(np, i); | |
283 | if (opt('t') == 0) | |
284 | switch (w) { | |
285 | case 8: | |
286 | w = 6; | |
287 | case 4: | |
288 | case 2: | |
289 | case 1: | |
290 | put2((width(ap) != 4 ? O_INX2P2 : O_INX4P2) | (w & ~1) << 7, ( short ) p->range[0]); | |
291 | el = el[2]; | |
292 | continue; | |
293 | } | |
294 | put(4, width(ap) != 4 ? O_INX2 : O_INX4,w,( short ) p->range[0], | |
295 | ( short ) ( p->range[1] - p->range[0] ) ); | |
296 | el = el[2]; | |
297 | } | |
298 | if (el != NIL) { | |
299 | do { | |
300 | el = el[2]; | |
301 | i++; | |
302 | } while (el != NIL); | |
303 | error("Too many subscripts (%d given, %d required)", i-1, d); | |
304 | return (-1); | |
305 | } | |
306 | return (1); | |
307 | } |