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