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