2.11BSD#431 - /usr/src/ucb/PORT/pascal/pdx/sym/tree.c

   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) 6/6/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: }

Defined functions

Defined variables

Defined typedef's

Defined macros