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

   1: /*	@(#)cset.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: /*
  17:  * Constant set constructor.
  18:  * settype is the type of the
  19:  * set if we think that we know it
  20:  * if not we try our damndest to figure
  21:  * out what the type should be.
  22:  */
  23: struct nl *
  24: cset(r, settype, x)
  25:     int *r;
  26:     struct nl *settype;
  27:     int x;
  28: {
  29:     register *e;
  30:     register struct nl *t, *exptype;
  31:     int n, *el;
  32: 
  33:     if (settype == NIL) {
  34:         /*
  35: 		 * So far we have no indication
  36: 		 * of what the set type should be.
  37: 		 * We "look ahead" and try to infer
  38: 		 * The type of the constant set
  39: 		 * by evaluating one of its members.
  40: 		 */
  41:         e = r[2];
  42:         if (e == NIL)
  43:             return (nl+TSET);   /* tenative for [] */
  44:         e = e[1];
  45:         if (e == NIL)
  46:             return (NIL);
  47:         if (e[0] == T_RANG)
  48:             e = e[1];
  49:         codeoff();
  50:         t = rvalue(e, NIL);
  51:         codeon();
  52:         if (t == NIL)
  53:             return (NIL);
  54:         /*
  55: 		 * The type of the set, settype, is
  56: 		 * deemed to be a set of the base type
  57: 		 * of t, which we call exptype.  If,
  58: 		 * however, this would involve a
  59: 		 * "set of integer", we cop out
  60: 		 * and use "intset"'s current scoped
  61: 		 * type instead.
  62: 		 */
  63:         if (isa(t, "r")) {
  64:             error("Sets may not have 'real' elements");
  65:             return (NIL);
  66:         }
  67:         if (isnta(t, "bcsi")) {
  68:             error("Set elements must be scalars, not %ss", nameof(t));
  69:             return (NIL);
  70:         }
  71:         if (isa(t, "i")) {
  72:             settype = lookup(intset);
  73:             if (settype == NIL)
  74:                 panic("intset");
  75:             settype = settype->type;
  76:             if (settype == NIL)
  77:                 return (NIL);
  78:             if (isnta(settype, "t")) {
  79:                 error("Set default type \"intset\" is not a set");
  80:                 return (NIL);
  81:             }
  82:             exptype = settype->type;
  83:         } else {
  84:             exptype = t->type;
  85:             if (exptype == NIL)
  86:                 return (NIL);
  87:             if (exptype->class != RANGE)
  88:                 exptype = exptype->type;
  89:             settype = defnl(0, SET, exptype, 0);
  90:         }
  91:     } else {
  92:         if (settype->class != SET) {
  93:             /*
  94: 			 * e.g string context [1,2] = 'abc'
  95: 			 */
  96:             error("Constant set involved in non set context");
  97:             return (NIL);
  98:         }
  99:         exptype = settype->type;
 100:     }
 101:     if (x == NIL)
 102:         put2(O_PUSH, -width(settype));
 103:     n = 0;
 104:     for (el=r[2]; el; el=el[2]) {
 105:         n++;
 106:         e = el[1];
 107:         if (e == NIL)
 108:             return (NIL);
 109:         if (e[0] == T_RANG) {
 110:             t = rvalue(e[2], NIL);
 111:             if (t == NIL) {
 112:                 rvalue(e[1], NIL);
 113:                 continue;
 114:             }
 115:             if (incompat(t, exptype, e[2]))
 116:                 cerror("Upper bound of element type clashed with set type in constant set");
 117:             else
 118:                 convert(t, nl+T2INT);
 119:             t = rvalue(e[1], NIL);
 120:             if (t == NIL)
 121:                 continue;
 122:             if (incompat(t, exptype, e[1]))
 123:                 cerror("Lower bound of element type clashed with set type in constant set");
 124:             else
 125:                 convert(t, nl+T2INT);
 126:         } else {
 127:             t = rvalue((int *) e, NLNIL);
 128:             if (t == NIL)
 129:                 continue;
 130:             if (incompat(t, exptype, e))
 131:                 cerror("Element type clashed with set type in constant set");
 132:             else
 133:                 convert(t, nl+T2INT);
 134:             put1(O_SDUP);
 135:         }
 136:     }
 137:     if (x == NIL) {
 138:         setran(exptype);
 139:         put(4, O_CTTOT, n, set.lwrb, set.uprbp);
 140:     } else
 141:         put2(O_CON2, n);
 142:     return (settype);
 143: }

Defined functions