1 /*-
2 * Copyright (c) 1980, 1993
3 * The Regents of the University of California. All rights reserved.
4 *
5 * %sccs.include.redist.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)tree.c 8.1 (Berkeley) 06/06/93";
10 #endif /* not lint */
11
12 /*
13 * This module contains the interface between the SYM routines and
14 * the parse tree routines. It would be nice if such a crude
15 * interface were not necessary, but some parts of tree building are
16 * language and hence SYM-representation dependent. It's probably
17 * better to have tree-representation dependent code here than vice versa.
18 */
19
20 #include "defs.h"
21 #include "tree.h"
22 #include "sym.h"
23 #include "btypes.h"
24 #include "classes.h"
25 #include "sym.rep"
26 #include "tree/tree.rep"
27
28 typedef char *ARGLIST;
29
30 #define nextarg(arglist, type) ((type *) (arglist += sizeof(type)))[-1]
31
32 LOCAL SYM *mkstring();
33 LOCAL SYM *namenode();
34
35 /*
36 * Determine the type of a parse tree. While we're at, check
37 * the parse tree out.
38 */
39
treetype(p,ap)40 SYM *treetype(p, ap)
41 register NODE *p;
42 register ARGLIST ap;
43 {
44 switch(p->op) {
45 case O_NAME: {
46 SYM *s;
47
48 s = nextarg(ap, SYM *);
49 s = which(s);
50 return namenode(p, s);
51 /* NOTREACHED */
52 }
53
54 case O_WHICH:
55 p->nameval = nextarg(ap, SYM *);
56 p->nameval = which(p->nameval);
57 return NIL;
58
59 case O_LCON:
60 return t_int;
61
62 case O_FCON:
63 return t_real;
64
65 case O_SCON: {
66 char *cpy;
67 SYM *s;
68
69 cpy = strdup(p->sconval);
70 p->sconval = cpy;
71 s = mkstring(p->sconval);
72 if (s == t_char) {
73 p->op = O_LCON;
74 p->lconval = p->sconval[0];
75 }
76 return s;
77 }
78
79 case O_INDIR:
80 p->left = nextarg(ap, NODE *);
81 chkclass(p->left, PTR);
82 return rtype(p->left->nodetype)->type;
83
84 case O_RVAL: {
85 NODE *p1;
86
87 p1 = p->left;
88 p->nodetype = p1->nodetype;
89 if (p1->op == O_NAME) {
90 if (p1->nodetype->class == FUNC) {
91 p->op = O_CALL;
92 p->right = NIL;
93 } else if (p1->nameval->class == CONST) {
94 if (p1->nameval->type == t_real->type) {
95 p->op = O_FCON;
96 p->fconval = p1->nameval->symvalue.fconval;
97 p->nodetype = t_real;
98 dispose(p1);
99 } else {
100 p->op = O_LCON;
101 p->lconval = p1->nameval->symvalue.iconval;
102 p->nodetype = p1->nameval->type;
103 dispose(p1);
104 }
105 }
106 }
107 return p->nodetype;
108 /* NOTREACHED */
109 }
110
111 case O_CALL: {
112 SYM *s;
113
114 p->left = nextarg(ap, NODE *);
115 p->right = nextarg(ap, NODE *);
116 s = p->left->nodetype;
117 if (isblock(s) && isbuiltin(s)) {
118 p->op = (OP) s->symvalue.token.tokval;
119 tfree(p->left);
120 p->left = p->right;
121 p->right = NIL;
122 }
123 return s->type;
124 }
125
126 case O_ITOF:
127 return t_real;
128
129 case O_NEG: {
130 SYM *s;
131
132 p->left = nextarg(ap, NODE *);
133 s = p->left->nodetype;
134 if (!compatible(s, t_int)) {
135 if (!compatible(s, t_real)) {
136 trerror("%t is improper type", p->left);
137 } else {
138 p->op = O_NEGF;
139 }
140 }
141 return s;
142 }
143
144 case O_ADD:
145 case O_SUB:
146 case O_MUL:
147 case O_LT:
148 case O_LE:
149 case O_GT:
150 case O_GE:
151 case O_EQ:
152 case O_NE:
153 {
154 BOOLEAN t1real, t2real;
155 SYM *t1, *t2;
156
157 p->left = nextarg(ap, NODE *);
158 p->right = nextarg(ap, NODE *);
159 t1 = rtype(p->left->nodetype);
160 t2 = rtype(p->right->nodetype);
161 t1real = (t1 == t_real);
162 t2real = (t2 == t_real);
163 if (t1real || t2real) {
164 p->op++;
165 if (!t1real) {
166 p->left = build(O_ITOF, p->left);
167 } else if (!t2real) {
168 p->right = build(O_ITOF, p->right);
169 }
170 } else {
171 if (t1real) {
172 convert(&p->left, t_int, O_NOP);
173 }
174 if (t2real) {
175 convert(&p->right, t_int, O_NOP);
176 }
177 }
178 if (p->op >= O_LT) {
179 return t_boolean;
180 } else {
181 if (t1real || t2real) {
182 return t_real;
183 } else {
184 return t_int;
185 }
186 }
187 /* NOTREACHED */
188 }
189
190 case O_DIVF:
191 p->left = nextarg(ap, NODE *);
192 p->right = nextarg(ap, NODE *);
193 convert(&p->left, t_real, O_ITOF);
194 convert(&p->right, t_real, O_ITOF);
195 return t_real;
196
197 case O_DIV:
198 case O_MOD:
199 p->left = nextarg(ap, NODE *);
200 p->right = nextarg(ap, NODE *);
201 convert(&p->left, t_int, O_NOP);
202 convert(&p->right, t_int, O_NOP);
203 return t_int;
204
205 case O_AND:
206 case O_OR:
207 p->left = nextarg(ap, NODE *);
208 p->right = nextarg(ap, NODE *);
209 chkboolean(p->left);
210 chkboolean(p->right);
211 return t_boolean;
212
213 default:
214 return NIL;
215 }
216 }
217
218 /*
219 * Create a node for a name. The symbol for the name has already
220 * been chosen, either implicitly with "which" or explicitly from
221 * the dot routine.
222 */
223
namenode(p,s)224 LOCAL SYM *namenode(p, s)
225 NODE *p;
226 SYM *s;
227 {
228 NODE *np;
229
230 p->nameval = s;
231 if (s->class == REF) {
232 np = alloc(1, NODE);
233 *np = *p;
234 p->op = O_INDIR;
235 p->left = np;
236 np->nodetype = s;
237 }
238 if (s->class == CONST || s->class == VAR || s->class == FVAR) {
239 return s->type;
240 } else {
241 return s;
242 }
243 }
244
245 /*
246 * Convert a tree to a type via a conversion operator;
247 * if this isn't possible generate an error.
248 *
249 * Note the tree is call by address, hence the #define below.
250 */
251
convert(tp,typeto,op)252 LOCAL convert(tp, typeto, op)
253 NODE **tp;
254 SYM *typeto;
255 OP op;
256 {
257 #define tree (*tp)
258
259 SYM *s;
260
261 s = rtype(tree->nodetype);
262 typeto = rtype(typeto);
263 if (typeto == t_real && compatible(s, t_int)) {
264 tree = build(op, tree);
265 } else if (!compatible(s, typeto)) {
266 trerror("%t is improper type");
267 } else if (op != O_NOP && s != typeto) {
268 tree = build(op, tree);
269 }
270
271 #undef tree
272 }
273
274 /*
275 * Construct a node for the Pascal dot operator.
276 *
277 * If the left operand is not a record, but rather a procedure
278 * or function, then we interpret the "." as referencing an
279 * "invisible" variable; i.e. a variable within a dynamically
280 * active block but not within the static scope of the current procedure.
281 */
282
dot(record,field)283 NODE *dot(record, field)
284 NODE *record;
285 SYM *field;
286 {
287 register NODE *p;
288 register SYM *s;
289
290 if (isblock(record->nodetype)) {
291 s = findsym(field, record->nodetype);
292 if (s == NIL) {
293 error("\"%s\" is not defined in \"%s\"",
294 field->symbol, record->nodetype->symbol);
295 }
296 p = alloc(1, NODE);
297 p->op = O_NAME;
298 p->nodetype = namenode(p, s);
299 } else {
300 s = findclass(field, FIELD);
301 if (s == NIL) {
302 error("\"%s\" is not a field", field->symbol);
303 }
304 field = s;
305 chkfield(record, field);
306 p = alloc(1, NODE);
307 p->op = O_ADD;
308 p->nodetype = field->type;
309 p->left = record;
310 p->right = build(O_LCON, (long) field->symvalue.offset);
311 }
312 return p;
313 }
314
315 /*
316 * Return a tree corresponding to an array reference and do the
317 * error checking.
318 */
319
subscript(a,slist)320 NODE *subscript(a, slist)
321 NODE *a, *slist;
322 {
323 register SYM *t;
324 register NODE *p;
325 SYM *etype, *atype, *eltype;
326 NODE *esub;
327
328 t = rtype(a->nodetype);
329 if (t->class != ARRAY) {
330 trerror("%t is not an array", a);
331 }
332 eltype = t->type;
333 p = slist;
334 t = t->chain;
335 for (; p != NIL && t != NIL; p = p->right, t = t->chain) {
336 esub = p->left;
337 etype = rtype(esub->nodetype);
338 atype = rtype(t);
339 if (!compatible(atype, etype)) {
340 trerror("subscript %t is the wrong type", esub);
341 }
342 esub->nodetype = atype;
343 }
344 if (p != NIL) {
345 trerror("too many subscripts for %t", a);
346 } else if (t != NIL) {
347 trerror("not enough subscripts for %t", a);
348 }
349 p = alloc(1, NODE);
350 p->op = O_INDEX;
351 p->left = a;
352 p->right = slist;
353 p->nodetype = eltype;
354 return p;
355 }
356
357 /*
358 * Evaluate a subscript (possibly more than one index).
359 */
360
evalindex(arraytype,subs)361 long evalindex(arraytype, subs)
362 SYM *arraytype;
363 NODE *subs;
364 {
365 long lb, ub, index, i;
366 SYM *t, *indextype;
367 NODE *p;
368
369 t = rtype(arraytype);
370 if (t->class != ARRAY) {
371 panic("unexpected class %d in evalindex", t->class);
372 }
373 i = 0;
374 t = t->chain;
375 p = subs;
376 while (t != NIL) {
377 if (p == NIL) {
378 panic("unexpected end of subscript list in evalindex");
379 }
380 indextype = rtype(t);
381 lb = indextype->symvalue.rangev.lower;
382 ub = indextype->symvalue.rangev.upper;
383 eval(p->left);
384 index = popsmall(p->left->nodetype);
385 if (index < lb || index > ub) {
386 error("subscript value %d out of range %d..%d", index, lb, ub);
387 }
388 i = (ub-lb+1)*i + (index-lb);
389 t = t->chain;
390 p = p->right;
391 }
392 return i;
393 }
394
395 /*
396 * Check that a record.field usage is proper.
397 */
398
chkfield(r,f)399 LOCAL chkfield(r, f)
400 NODE *r;
401 SYM *f;
402 {
403 register SYM *s;
404
405 chkclass(r, RECORD);
406
407 /*
408 * Don't do this for compiled code.
409 */
410 for (s = r->nodetype->chain; s != NIL; s = s->chain) {
411 if (s == f) {
412 break;
413 }
414 }
415 if (s == NIL) {
416 error("\"%s\" is not a field in specified record", f->symbol);
417 }
418 }
419
420 /*
421 * Check to see if a tree is boolean-valued, if not it's an error.
422 */
423
chkboolean(p)424 chkboolean(p)
425 register NODE *p;
426 {
427 if (p->nodetype != t_boolean) {
428 trerror("found %t, expected boolean expression");
429 }
430 }
431
432 /*
433 * Check to make sure the given tree has a type of the given class.
434 */
435
chkclass(p,class)436 LOCAL chkclass(p, class)
437 NODE *p;
438 int class;
439 {
440 SYM tmpsym;
441
442 tmpsym.class = class;
443 if (p->nodetype->class != class) {
444 trerror("%t is not a %s", p, classname(&tmpsym));
445 }
446 }
447
448 /*
449 * Construct a node for the type of a string. While we're at it,
450 * scan the string for '' that collapse to ', and chop off the ends.
451 */
452
mkstring(str)453 LOCAL SYM *mkstring(str)
454 char *str;
455 {
456 register char *p, *q;
457 SYM *s, *t;
458 static SYM zerosym;
459
460 p = str;
461 q = str + 1;
462 while (*q != '\0') {
463 if (q[0] != '\'' || q[1] != '\'') {
464 *p = *q;
465 p++;
466 }
467 q++;
468 }
469 *--p = '\0';
470 if (p == str + 1) {
471 return t_char;
472 }
473 s = alloc(1, SYM);
474 *s = zerosym;
475 s->class = ARRAY;
476 s->type = t_char;
477 s->chain = alloc(1, SYM);
478 t = s->chain;
479 *t = zerosym;
480 t->class = RANGE;
481 t->type = t_int;
482 t->symvalue.rangev.lower = 1;
483 t->symvalue.rangev.upper = p - str + 1;
484 return s;
485 }
486
487 /*
488 * Free up the space allocated for a string type.
489 */
490
unmkstring(s)491 unmkstring(s)
492 SYM *s;
493 {
494 dispose(s->chain);
495 }
496