2.9BSD - /usr/src/ucb/pascal/pi/lval.c

   1: /*	@(#)lval.c	2.2	SCCS id keyword	*/
   2: /* Copyright (c) 1979 Regents of the University of California */
   3: #
   4: /*
   5:  * pi - Pascal interpreter code translator
   6:  *
   7:  * Charles Haley, Bill Joy UCB
   8:  * Version 1.2 November 1978
   9:  */
  10: 
  11: #include "whoami"
  12: #include "0.h"
  13: #include "tree.h"
  14: #include "opcode.h"
  15: 
  16: extern  int flagwas;
  17: /*
  18:  * Lvalue computes the address
  19:  * of a qualified name and
  20:  * leaves it on the stack.
  21:  */
  22: struct nl *
  23: lvalue(r, modflag)
  24:     int *r, modflag;
  25: {
  26:     register struct nl *p;
  27:     struct nl *firstp, *lastp;
  28:     register *c, *co;
  29:     int f, o;
  30:     /*
  31: 	 * Note that the local optimizations
  32: 	 * done here for offsets would more
  33: 	 * appropriately be done in put.
  34: 	 */
  35:     int tr[2], trp[3];
  36: 
  37:     if (r == NIL)
  38:         return (NIL);
  39:     if (nowexp(r))
  40:         return (NIL);
  41:     if (r[0] != T_VAR) {
  42:         error("Variable required"); /* Pass mesgs down from pt of call ? */
  43:         return (NIL);
  44:     }
  45:     firstp = p = lookup(r[2]);
  46:     if (p == NIL)
  47:         return (NIL);
  48:     c = r[3];
  49:     if ((modflag & NOUSE) && !lptr(c))
  50:         p->nl_flags = flagwas;
  51:     if (modflag & MOD)
  52:         p->nl_flags |= NMOD;
  53:     /*
  54: 	 * Only possibilities for p->class here
  55: 	 * are the named classes, i.e. CONST, TYPE
  56: 	 * VAR, PROC, FUNC, REF, or a WITHPTR.
  57: 	 */
  58:     switch (p->class) {
  59:         case WITHPTR:
  60:             /*
  61: 			 * Construct the tree implied by
  62: 			 * the with statement
  63: 			 */
  64:             trp[0] = T_LISTPP;
  65:             trp[1] = tr;
  66:             trp[2] = r[3];
  67:             tr[0] = T_FIELD;
  68:             tr[1] = r[2];
  69:             c = trp;
  70:         case REF:
  71:             /*
  72: 			 * Obtain the indirect word
  73: 			 * of the WITHPTR or REF
  74: 			 * as the base of our lvalue
  75: 			 */
  76: #ifdef  VAX
  77:             put2 ( O_RV4 | bn << 9 , p->value[0] );
  78: #else
  79:             put2(O_RV2 | bn << 9, p->value[0]);
  80: #endif
  81:             f = 0;      /* have an lv on stack */
  82:             o = 0;
  83:             break;
  84:         case VAR:
  85:             f = 1;      /* no lv on stack yet */
  86:             o = p->value[0];
  87:             break;
  88:         default:
  89:             error("%s %s found where variable required", classes[p->class], p->symbol);
  90:             return (NIL);
  91:     }
  92:     /*
  93: 	 * Loop and handle each
  94: 	 * qualification on the name
  95: 	 */
  96:     if (c == NIL && (modflag&ASGN) && p->value[NL_FORV]) {
  97:         error("Can't modify the for variable %s in the range of the loop", p->symbol);
  98:         return (NIL);
  99:     }
 100:     for (; c != NIL; c = c[2]) {
 101:         co = c[1];
 102:         if (co == NIL)
 103:             return (NIL);
 104:         lastp = p;
 105:         p = p->type;
 106:         if (p == NIL)
 107:             return (NIL);
 108:         switch (co[0]) {
 109:             case T_PTR:
 110:                 /*
 111: 				 * Pointer qualification.
 112: 				 */
 113:                 lastp->nl_flags |= NUSED;
 114:                 if (p->class != PTR && p->class != FILET) {
 115:                     error("^ allowed only on files and pointers, not on %ss", nameof(p));
 116:                     goto bad;
 117:                 }
 118:                 if (f)
 119: #ifdef  VAX
 120:                     put2 ( O_RV4 | bn << 9 , o );
 121: #else
 122:                     put2(O_RV2 | bn<<9, o);
 123: #endif
 124:                 else {
 125:                     if (o)
 126:                         put2(O_OFF, o);
 127: #ifdef  VAX
 128:                     put1 ( O_IND4 );
 129: #else
 130:                     put1(O_IND2);
 131: #endif
 132:                 }
 133:                 /*
 134: 				 * Pointer cannot be
 135: 				 * nil and file cannot
 136: 				 * be at end-of-file.
 137: 				 */
 138:                 put1(p->class == FILET ? O_FNIL : O_NIL);
 139:                 f = o = 0;
 140:                 continue;
 141:             case T_ARGL:
 142:                 if (p->class != ARRAY) {
 143:                     if (lastp == firstp)
 144:                         error("%s is a %s, not a function", r[2], classes[firstp->class]);
 145:                     else
 146:                         error("Illegal function qualificiation");
 147:                     return (NIL);
 148:                 }
 149:                 recovered();
 150:                 error("Pascal uses [] for subscripting, not ()");
 151:             case T_ARY:
 152:                 if (p->class != ARRAY) {
 153:                     error("Subscripting allowed only on arrays, not on %ss", nameof(p));
 154:                     goto bad;
 155:                 }
 156:                 if (f)
 157:                     put2(O_LV | bn<<9, o);
 158:                 else if (o)
 159:                     put2(O_OFF, o);
 160:                 switch (arycod(p, co[1])) {
 161:                     case 0:
 162:                         return (NIL);
 163:                     case -1:
 164:                         goto bad;
 165:                 }
 166:                 f = o = 0;
 167:                 continue;
 168:             case T_FIELD:
 169:                 /*
 170: 				 * Field names are just
 171: 				 * an offset with some
 172: 				 * semantic checking.
 173: 				 */
 174:                 if (p->class != RECORD) {
 175:                     error(". allowed only on records, not on %ss", nameof(p));
 176:                     goto bad;
 177:                 }
 178:                 if (co[1] == NIL)
 179:                     return (NIL);
 180:                 p = reclook(p, co[1]);
 181:                 if (p == NIL) {
 182:                     error("%s is not a field in this record", co[1]);
 183:                     goto bad;
 184:                 }
 185:                 if (modflag & MOD)
 186:                     p->nl_flags |= NMOD;
 187:                 if ((modflag & NOUSE) == 0 || lptr(c[2]))
 188:                     p->nl_flags |= NUSED;
 189:                 o += p->value[0];
 190:                 continue;
 191:             default:
 192:                 panic("lval2");
 193:         }
 194:     }
 195:     if (f)
 196:         put2(O_LV | bn<<9, o);
 197:     else if (o)
 198:         put2(O_OFF, o);
 199:     return (p->type);
 200: bad:
 201:     cerror("Error occurred on qualification of %s", r[2]);
 202:     return (NIL);
 203: }
 204: 
 205: lptr(c)
 206:     register int *c;
 207: {
 208:     register int *co;
 209: 
 210:     for (; c != NIL; c = c[2]) {
 211:         co = c[1];
 212:         if (co == NIL)
 213:             return (NIL);
 214:         switch (co[0]) {
 215: 
 216:         case T_PTR:
 217:             return (1);
 218:         case T_ARGL:
 219:             return (0);
 220:         case T_ARY:
 221:         case T_FIELD:
 222:             continue;
 223:         default:
 224:             panic("lptr");
 225:         }
 226:     }
 227:     return (0);
 228: }
 229: 
 230: /*
 231:  * Arycod does the
 232:  * code generation
 233:  * for subscripting.
 234:  */
 235: arycod(np, el)
 236:     struct nl *np;
 237:     int *el;
 238: {
 239:     register struct nl *p, *ap;
 240:     int i, d, v, v1;
 241:     int w;
 242: 
 243:     p = np;
 244:     if (el == NIL)
 245:         return (0);
 246:     d = p->value[0];
 247:     /*
 248: 	 * Check each subscript
 249: 	 */
 250:     for (i = 1; i <= d; i++) {
 251:         if (el == NIL) {
 252:             error("Too few subscripts (%d given, %d required)", i-1, d);
 253:             return (-1);
 254:         }
 255:         p = p->chain;
 256:         ap = rvalue(el[1], NLNIL);
 257:         if (ap == NIL)
 258:             return (0);
 259:         if (incompat(ap, p->type, el[1])) {
 260:             cerror("Array index type incompatible with declared index type");
 261:             if (d != 1)
 262:                 cerror("Error occurred on index number %d", i);
 263:             return (-1);
 264:         }
 265:         w = aryconst(np, i);
 266:         if (opt('t') == 0)
 267:             switch (w) {
 268:             case 8:
 269:                 w = 6;
 270:             case 4:
 271:             case 2:
 272:             case 1:
 273:                 put2((width(ap) != 4 ? O_INX2P2 : O_INX4P2) | (w & ~1) << 7, ( short ) p->range[0]);
 274:                 el = el[2];
 275:                 continue;
 276:             }
 277:         put(4, width(ap) != 4 ? O_INX2 : O_INX4,w,( short ) p->range[0],
 278:                ( short ) ( p->range[1] - p->range[0] ) );
 279:         el = el[2];
 280:     }
 281:     if (el != NIL) {
 282:         do {
 283:             el = el[2];
 284:             i++;
 285:         } while (el != NIL);
 286:         error("Too many subscripts (%d given, %d required)", i-1, d);
 287:         return (-1);
 288:     }
 289:     return (1);
 290: }

Defined functions