xref: /csrg-svn/usr.bin/pascal/pdx/sym/tree.c (revision 5531) 
1 /* Copyright (c) 1982 Regents of the University of California */
2 
3 static char sccsid[] = "@(#)tree.c 1.1 01/18/82";
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, *olda;
320 
321 	olda = a;
322 	t = rtype(a->nodetype);
323 	if (t->class != ARRAY) {
324 		trerror("%t is not an array");
325 	}
326 	eltype = t->type;
327 	p = slist;
328 	t = t->chain;
329 	for (; p != NIL && t != NIL; p = p->right, t = t->chain) {
330 		esub = p->left;
331 		etype = rtype(esub->nodetype);
332 		atype = rtype(t);
333 		if (!compatible(atype, etype)) {
334 			trerror("subscript %t is the wrong type", esub);
335 		}
336 		a = build(O_INDEX, a, esub);
337 		a->nodetype = eltype;
338 	}
339 	if (p != NIL) {
340 		trerror("too many subscripts for %t", olda);
341 	} else if (t != NIL) {
342 		trerror("not enough subscripts for %t", olda);
343 	}
344 	return(a);
345 }
346 
347 /*
348  * Evaluate a subscript index.
349  */
350 
351 evalindex(s)
352 SYM *s;
353 {
354 	long i;
355 	long lb, ub;
356 
357 	s = rtype(s)->chain;
358 	i = pop(long);
359 	lb = s->symvalue.rangev.lower;
360 	ub = s->symvalue.rangev.upper;
361 	if (i < lb || i > ub) {
362 		error("subscript out of range");
363 	}
364 	return(i - lb);
365 }
366 
367 /*
368  * Check that a record.field usage is proper.
369  */
370 
371 LOCAL chkfield(r, f)
372 NODE *r;
373 SYM *f;
374 {
375 	register SYM *s;
376 
377 	chkclass(r, RECORD);
378 
379 	/*
380 	 * Don't do this for compiled code.
381 	 */
382 #	if (!isvax)
383 		for (s = r->nodetype->chain; s != NIL; s = s->chain) {
384 			if (s == f) {
385 				break;
386 			}
387 		}
388 		if (s == NIL) {
389 			error("\"%s\" is not a field in specified record", f->symbol);
390 		}
391 #	endif
392 }
393 
394 /*
395  * Check to see if a tree is boolean-valued, if not it's an error.
396  */
397 
398 chkboolean(p)
399 register NODE *p;
400 {
401 	if (p->nodetype != t_boolean) {
402 		trerror("found %t, expected boolean expression");
403 	}
404 }
405 
406 /*
407  * Check to make sure the given tree has a type of the given class.
408  */
409 
410 LOCAL chkclass(p, class)
411 NODE *p;
412 int class;
413 {
414 	SYM tmpsym;
415 
416 	tmpsym.class = class;
417 	if (p->nodetype->class != class) {
418 		trerror("%t is not a %s", p, classname(&tmpsym));
419 	}
420 }
421 
422 /*
423  * Construct a node for the type of a string.  While we're at it,
424  * scan the string for '' that collapse to ', and chop off the ends.
425  */
426 
427 LOCAL SYM *mkstring(str)
428 char *str;
429 {
430 	register char *p, *q;
431 	SYM *s, *t;
432 	static SYM zerosym;
433 
434 	p = str;
435 	q = str + 1;
436 	while (*q != '\0') {
437 		if (q[0] != '\'' || q[1] != '\'') {
438 			*p = *q;
439 			p++;
440 		}
441 		q++;
442 	}
443 	*--p = '\0';
444 	if (p == str + 1) {
445 		return t_char;
446 	}
447 	s = alloc(1, SYM);
448 	*s = zerosym;
449 	s->class = ARRAY;
450 	s->type = t_char;
451 	s->chain = alloc(1, SYM);
452 	t = s->chain;
453 	*t = zerosym;
454 	t->class = RANGE;
455 	t->type = t_int;
456 	t->symvalue.rangev.lower = 1;
457 	t->symvalue.rangev.upper = p - str + 1;
458 	return s;
459 }
460 
461 /*
462  * Free up the space allocated for a string type.
463  */
464 
465 unmkstring(s)
466 SYM *s;
467 {
468 	dispose(s->chain);
469 }
470