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