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

   1: /*	@(#)type.c	2.3	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: 
  15: /*
  16:  * Type declaration part
  17:  */
  18: typebeg()
  19: {
  20: 
  21: #ifndef PI1
  22:     if (parts & VPRT)
  23:         error("Type declarations must precede var declarations");
  24:     if (parts & TPRT)
  25:         error("All types must be declared in one type part");
  26:     parts |= TPRT;
  27: #endif
  28:     /*
  29: 	 * Forechain is the head of a list of types that
  30: 	 * might be self referential.  We chain them up and
  31: 	 * process them later.
  32: 	 */
  33:     forechain = NIL;
  34: #ifdef PI0
  35:     send(REVTBEG);
  36: #endif
  37: }
  38: 
  39: type(tline, tid, tdecl)
  40:     int tline;
  41:     char *tid;
  42:     register int *tdecl;
  43: {
  44:     register struct nl *np;
  45: 
  46:     np = gtype(tdecl);
  47:     line = tline;
  48: #ifndef PI0
  49:     enter(defnl(tid, TYPE, np, 0))->nl_flags |= NMOD;
  50: #else
  51:     enter(defnl(tid, TYPE, np, 0));
  52:     send(REVTYPE, tline, tid, tdecl);
  53: #endif
  54: }
  55: 
  56: typeend()
  57: {
  58: 
  59: #ifdef PI0
  60:     send(REVTEND);
  61: #endif
  62:     foredecl();
  63: }
  64: 
  65: /*
  66:  * Return a type pointer (into the namelist)
  67:  * from a parse tree for a type, building
  68:  * namelist entries as needed.
  69:  */
  70: struct nl *
  71: gtype(r)
  72:     register int *r;
  73: {
  74:     register struct nl *np;
  75:     register char *cp;
  76:     int oline;
  77: 
  78:     if (r == NIL)
  79:         return (NIL);
  80:     oline = line;
  81:     if (r[0] != T_ID)
  82:         oline = line = r[1];
  83:     switch (r[0]) {
  84:         default:
  85:             panic("type");
  86:         case T_TYID:
  87:             r++;
  88:         case T_ID:
  89:             np = lookup(r[1]);
  90:             if (np == NIL)
  91:                 break;
  92:             if (np->class != TYPE) {
  93: #ifndef PI1
  94:                 error("%s is a %s, not a type as required", r[1], classes[np->class]);
  95: #endif
  96:                 np = NIL;
  97:                 break;
  98:             }
  99:             np = np->type;
 100:             break;
 101:         case T_TYSCAL:
 102:             np = tyscal(r);
 103:             break;
 104:         case T_TYRANG:
 105:             np = tyrang(r);
 106:             break;
 107:         case T_TYPTR:
 108:             np = defnl(0, PTR, 0, 0 );
 109:             np -> ptr[0] = r[2];
 110:             np->nl_next = forechain;
 111:             forechain = np;
 112:             break;
 113:         case T_TYPACK:
 114:             np = gtype(r[2]);
 115:             break;
 116:         case T_TYARY:
 117:             np = tyary(r);
 118:             break;
 119:         case T_TYREC:
 120:             np = tyrec(r[2], 0);
 121:             break;
 122:         case T_TYFILE:
 123:             np = gtype(r[2]);
 124:             if (np == NIL)
 125:                 break;
 126: #ifndef PI1
 127:             if (np->nl_flags & NFILES)
 128:                 error("Files cannot be members of files");
 129: #endif
 130:             np = defnl(0, FILET, np, 0);
 131:             np->nl_flags |= NFILES;
 132:             break;
 133:         case T_TYSET:
 134:             np = gtype(r[2]);
 135:             if (np == NIL)
 136:                 break;
 137:             if (np->type == nl+TDOUBLE) {
 138: #ifndef PI1
 139:                 error("Set of real is not allowed");
 140: #endif
 141:                 np = NIL;
 142:                 break;
 143:             }
 144:             if (np->class != RANGE && np->class != SCAL) {
 145: #ifndef PI1
 146:                 error("Set type must be range or scalar, not %s", nameof(np));
 147: #endif
 148:                 np = NIL;
 149:                 break;
 150:             }
 151: #ifndef PI1
 152:             if (width(np) > 2)
 153:                 error("Implementation restriction: sets must be indexed by 16 bit quantities");
 154: #endif
 155:             np = defnl(0, SET, np, 0);
 156:             break;
 157:     }
 158:     line = oline;
 159:     return (np);
 160: }
 161: 
 162: /*
 163:  * Scalar (enumerated) types
 164:  */
 165: tyscal(r)
 166:     int *r;
 167: {
 168:     register struct nl *np, *op;
 169:     register *v;
 170:     int i;
 171: 
 172:     np = defnl(0, SCAL, 0, 0);
 173:     np->type = np;
 174:     v = r[2];
 175:     if (v == NIL)
 176:         return (NIL);
 177:     i = -1;
 178:     for (; v != NIL; v = v[2]) {
 179:         op = enter(defnl(v[1], CONST, np, ++i));
 180: #ifndef PI0
 181:         op->nl_flags |= NMOD;
 182: #endif
 183:         op->value[1] = i;
 184:     }
 185:     np->range[1] = i;
 186:     return (np);
 187: }
 188: 
 189: /*
 190:  * Declare a subrange.
 191:  */
 192: tyrang(r)
 193:     register int *r;
 194: {
 195:     register struct nl *lp, *hp;
 196:     double high;
 197:     int c, c1;
 198: 
 199:     gconst(r[3]);
 200:     hp = con.ctype;
 201:     high = con.crval;
 202:     gconst(r[2]);
 203:     lp = con.ctype;
 204:     if (lp == NIL || hp == NIL)
 205:         return (NIL);
 206:     if (norange(lp) || norange(hp))
 207:         return (NIL);
 208:     c = classify(lp);
 209:     c1 = classify(hp);
 210:     if (c != c1) {
 211: #ifndef PI1
 212:         error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp));
 213: #endif
 214:         return (NIL);
 215:     }
 216:     if (c == TSCAL && scalar(lp) != scalar(hp)) {
 217: #ifndef PI1
 218:         error("Scalar types must be identical in subranges");
 219: #endif
 220:         return (NIL);
 221:     }
 222:     if (con.crval > high) {
 223: #ifndef PI1
 224:         error("Range lower bound exceeds upper bound");
 225: #endif
 226:         return (NIL);
 227:     }
 228:     lp = defnl(0, RANGE, hp->type, 0);
 229:     lp->range[0] = con.crval;
 230:     lp->range[1] = high;
 231:     return (lp);
 232: }
 233: 
 234: norange(p)
 235:     register struct nl *p;
 236: {
 237:     if (isa(p, "d")) {
 238: #ifndef PI1
 239:         error("Subrange of real is not allowed");
 240: #endif
 241:         return (1);
 242:     }
 243:     if (isnta(p, "bcsi")) {
 244: #ifndef PI1
 245:         error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p));
 246: #endif
 247:         return (1);
 248:     }
 249:     return (0);
 250: }
 251: 
 252: /*
 253:  * Declare arrays and chain together the dimension specification
 254:  */
 255: struct nl *
 256: tyary(r)
 257:     int *r;
 258: {
 259:     struct nl *np;
 260:     register *tl;
 261:     register struct nl *tp, *ltp;
 262:     int i;
 263: 
 264:     tp = gtype(r[3]);
 265:     if (tp == NIL)
 266:         return (NIL);
 267:     np = defnl(0, ARRAY, tp, 0);
 268:     np->nl_flags |= (tp->nl_flags) & NFILES;
 269:     ltp = np;
 270:     i = 0;
 271:     for (tl = r[2]; tl != NIL; tl = tl[2]) {
 272:         tp = gtype(tl[1]);
 273:         if (tp == NIL) {
 274:             np = NIL;
 275:             continue;
 276:         }
 277:         if (tp->class == RANGE && tp->type == nl+TDOUBLE) {
 278: #ifndef PI1
 279:             error("Index type for arrays cannot be real");
 280: #endif
 281:             np = NIL;
 282:             continue;
 283:         }
 284:         if (tp->class != RANGE && tp->class != SCAL) {
 285: #ifndef PI1
 286:             error("Array index type is a %s, not a range or scalar as required", classes[tp->class]);
 287: #endif
 288:             np = NIL;
 289:             continue;
 290:         }
 291:         if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) {
 292: #ifndef PI1
 293:             error("Value of dimension specifier too large or small for this implementation");
 294: #endif
 295:             continue;
 296:         }
 297:         tp = nlcopy(tp);
 298:         i++;
 299:         ltp->chain = tp;
 300:         ltp = tp;
 301:     }
 302:     if (np != NIL)
 303:         np->value[0] = i;
 304:     return (np);
 305: }
 306: 
 307: /*
 308:  * Delayed processing for pointers to
 309:  * allow self-referential and mutually
 310:  * recursive pointer constructs.
 311:  */
 312: foredecl()
 313: {
 314:     register struct nl *p, *q;
 315: 
 316:     for (p = forechain; p != NIL; p = p->nl_next) {
 317:         if (p->class == PTR && p -> ptr[0] != 0)
 318:         {
 319:             p->type = gtype(p -> ptr[0]);
 320: #ifndef PI1
 321:             if (p->type != NIL && ( ( p->type )->nl_flags & NFILES))
 322:                 error("Files cannot be members of dynamic structures");
 323: #endif
 324:             p -> ptr[0] = 0;
 325:         }
 326:     }
 327: }

Defined functions