home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Distributions / ucb / spencer_2bsd.tar.gz / 2bsd.tar / src / pi / cset.c < prev    next >
Encoding:
C/C++ Source or Header  |  1980-02-17  |  3.0 KB  |  141 lines
  1. /* Copyright (c) 1979 Regents of the University of California */
  2. #
  3. /*
  4.  * pi - Pascal interpreter code translator
  5.  *
  6.  * Charles Haley, Bill Joy UCB
  7.  * Version 1.2 January 1979
  8.  */
  9.  
  10. #include "0.h"
  11. #include "tree.h"
  12. #include "opcode.h"
  13.  
  14. /*
  15.  * Constant set constructor.
  16.  * settype is the type of the
  17.  * set if we think that we know it
  18.  * if not we try our damndest to figure
  19.  * out what the type should be.
  20.  */
  21. cset(r, settype, x)
  22.     int *r;
  23.     struct nl *settype;
  24.     int x;
  25. {
  26.     register *e;
  27.     register struct nl *t, *exptype;
  28.     int n, *el;
  29.  
  30.     if (settype == NIL) {
  31.         /*
  32.          * So far we have no indication
  33.          * of what the set type should be.
  34.          * We "look ahead" and try to infer
  35.          * The type of the constant set
  36.          * by evaluating one of its members.
  37.          */
  38.         e = r[2];
  39.         if (e == NIL)
  40.             return (nl+TSET);    /* tenative for [] */
  41.         e = e[1];
  42.         if (e == NIL)
  43.             return (NIL);
  44.         if (e[0] == T_RANG)
  45.             e = e[1];
  46.         codeoff();
  47.         t = rvalue(e, NIL);
  48.         codeon();
  49.         if (t == NIL)
  50.             return (NIL);
  51.         /*
  52.          * The type of the set, settype, is
  53.          * deemed to be a set of the base type
  54.          * of t, which we call exptype.  If,
  55.          * however, this would involve a
  56.          * "set of integer", we cop out
  57.          * and use "intset"'s current scoped
  58.          * type instead.
  59.          */
  60.         if (isa(t, "r")) {
  61.             error("Sets may not have 'real' elements");
  62.             return (NIL);
  63.         }
  64.         if (isnta(t, "bcsi")) {
  65.             error("Set elements must be scalars, not %ss", nameof(t));
  66.             return (NIL);
  67.         }
  68.         if (isa(t, "i")) {
  69.             settype = lookup(intset);
  70.             if (settype == NIL)
  71.                 panic("intset");
  72.             settype = settype->type;
  73.             if (settype == NIL)
  74.                 return (NIL);
  75.             if (isnta(settype, "t")) {
  76.                 error("Set default type \"intset\" is not a set");
  77.                 return (NIL);
  78.             }
  79.             exptype = settype->type;
  80.         } else {
  81.             exptype = t->type;
  82.             if (exptype == NIL)
  83.                 return (NIL);
  84.             if (exptype->class != RANGE)
  85.                 exptype = exptype->type;
  86.             settype = defnl(0, SET, exptype, 0);
  87.         }
  88.     } else {
  89.         if (settype->class != SET) {
  90.             /*
  91.              * e.g string context [1,2] = 'abc'
  92.              */
  93.             error("Constant set involved in non set context");
  94.             return (NIL);
  95.         }
  96.         exptype = settype->type;
  97.     }
  98.     if (x == NIL)
  99.         put2(O_PUSH, -width(settype));
  100.     n = 0;
  101.     for (el=r[2]; el; el=el[2]) {
  102.         n++;
  103.         e = el[1];
  104.         if (e == NIL)
  105.             return (NIL);
  106.         if (e[0] == T_RANG) {
  107.             t = rvalue(e[2], NIL);
  108.             if (t == NIL) {
  109.                 rvalue(e[1], NIL);
  110.                 continue;
  111.             }
  112.             if (incompat(t, exptype, e[2]))
  113.                 cerror("Upper bound of element type clashed with set type in constant set");
  114.             else
  115.                 convert(t, nl+T2INT);
  116.             t = rvalue(e[1], NIL);
  117.             if (t == NIL)
  118.                 continue;
  119.             if (incompat(t, exptype, e[1]))
  120.                 cerror("Lower bound of element type clashed with set type in constant set");
  121.             else
  122.                 convert(t, nl+T2INT);
  123.         } else {
  124.             t = rvalue(e, NIL);
  125.             if (t == NIL)
  126.                 continue;
  127.             if (incompat(t, exptype, e))
  128.                 cerror("Element type clashed with set type in constant set");
  129.             else
  130.                 convert(t, nl+T2INT);
  131.             put1(O_SDUP);
  132.         }
  133.     }
  134.     if (x == NIL) {
  135.         setran(exptype);
  136.         put(4, O_CTTOT, n, set.lwrb, set.uprbp);
  137.     } else
  138.         put1(O_CON2, n);
  139.     return (settype);
  140. }
  141.