xref: /original-bsd/usr.bin/pascal/pdx/sym/tree.c (revision ec35a16d) 
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 
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 
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 
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 
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 
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 
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 
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 
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 
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 
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 
491 unmkstring(s)
492 SYM *s;
493 {
494     dispose(s->chain);
495 }
496