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 / rval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1980-02-17  |  11.1 KB  |  552 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. extern    char *opnames[];
  15. /*
  16.  * Rvalue - an expression.
  17.  *
  18.  * Contype is the type that the caller would prefer, nand is important
  19.  * if constant sets or constant strings are involved, the latter
  20.  * because of string padding.
  21.  */
  22. rvalue(r, contype)
  23.     int *r;
  24.     struct nl *contype;
  25. {
  26.     register struct nl *p, *p1;
  27.     register struct nl *q;
  28.     int c, c1, *rt, w, g;
  29.     char *cp, *cp1, *opname;
  30.     long l;
  31.     double f;
  32.  
  33.     if (r == NIL)
  34.         return (NIL);
  35.     if (nowexp(r))
  36.         return (NIL);
  37.     /*
  38.      * Pick up the name of the operation
  39.      * for future error messages.
  40.      */
  41.     if (r[0] <= T_IN)
  42.         opname = opnames[r[0]];
  43.  
  44.     /*
  45.      * The root of the tree tells us what sort of expression we have.
  46.      */
  47.     switch (r[0]) {
  48.  
  49.     /*
  50.      * The constant nil
  51.      */
  52.     case T_NIL:
  53.         put2(O_CON2, 0);
  54.         return (nl+TNIL);
  55.  
  56.     /*
  57.      * Function call with arguments.
  58.      */
  59.     case T_FCALL:
  60.         return (funccod(r));
  61.  
  62.     case T_VAR:
  63.         p = lookup(r[2]);
  64.         if (p == NIL || p->class == BADUSE)
  65.             return (NIL);
  66.         switch (p->class) {
  67.             case VAR:
  68.                 /*
  69.                  * If a variable is
  70.                  * qualified then get
  71.                  * the rvalue by a
  72.                  * lvalue and an ind.
  73.                  */
  74.                 if (r[3] != NIL)
  75.                     goto ind;
  76.                 q = p->type;
  77.                 if (q == NIL)
  78.                     return (NIL);
  79.                 w = width(q);
  80.                 switch (w) {
  81.                     case 8:
  82.                         w = 6;
  83.                     case 4:
  84.                     case 2:
  85.                     case 1:
  86.                         put2(O_RV1 + (w >> 1) | bn << 9, p->value[0]);
  87.                         break;
  88.                     default:
  89.                         put3(O_RV | bn << 9, p->value[0], w);
  90.                 }
  91.                 return (q);
  92.  
  93.             case WITHPTR:
  94.             case REF:
  95.                 /*
  96.                  * A lvalue for these
  97.                  * is actually what one
  98.                  * might consider a rvalue.
  99.                  */
  100. ind:
  101.                 q = lvalue(r, NOMOD);
  102.                 if (q == NIL)
  103.                     return (NIL);
  104.                 w = width(q);
  105.                 switch (w) {
  106.                     case 8:
  107.                         w = 6;
  108.                     case 4:
  109.                     case 2:
  110.                     case 1:
  111.                         put1(O_IND1 + (w >> 1));
  112.                         break;
  113.                     default:
  114.                         put2(O_IND, w);
  115.                 }
  116.                 return (q);
  117.  
  118.             case CONST:
  119.                 if (r[3] != NIL) {
  120.                     error("%s is a constant and cannot be qualified", r[2]);
  121.                     return (NIL);
  122.                 }
  123.                 q = p->type;
  124.                 if (q == NIL)
  125.                     return (NIL);
  126.                 if (q == nl+TSTR) {
  127.                     /*
  128.                      * Find the size of the string
  129.                      * constant if needed.
  130.                      */
  131.                     cp = p->value[0];
  132. cstrng:
  133.                     cp1 = cp;
  134.                     for (c = 0; *cp++; c++)
  135.                         continue;
  136.                     if (contype != NIL && !opt('s')) {
  137.                         if (width(contype) < c && classify(contype) == TSTR) {
  138.                             error("Constant string too long");
  139.                             return (NIL);
  140.                         }
  141.                         c = width(contype);
  142.                     }
  143.                     put3(O_CONG, c, cp1);
  144.                     /*
  145.                      * Define the string temporarily
  146.                      * so later people can know its
  147.                      * width.
  148.                      * cleaned out by stat.
  149.                      */
  150.                     q = defnl(0, STR, 0, c);
  151.                     q->type = q;
  152.                     return (q);
  153.                 }
  154.                 if (q == nl+T1CHAR) {
  155.                     put2(O_CONC, p->value[0]);
  156.                     return (q);
  157.                 }
  158.                 /*
  159.                  * Every other kind of constant here
  160.                  */
  161.                 switch (width(q)) {
  162.                     case 8:
  163. #ifndef DEBUG
  164.                         put(5, O_CON8, p->real);
  165. #else
  166.                         if (hp21mx) {
  167.                             f = p->real;
  168.                             conv(&f);
  169.                             l = f.plong;
  170.                             put3(O_CON4, l);
  171.                         } else
  172.                             put(5, O_CON8, p->real);
  173. #endif
  174.                         break;
  175.                     case 4:
  176.                         put3(O_CON4, p->range[0]);
  177.                         break;
  178.                     case 2:
  179.                         put2(O_CON2, p->value[1]);
  180.                         break;
  181.                     case 1:
  182.                         put2(O_CON1, p->value[0]);
  183.                         break;
  184.                     default:
  185.                         panic("rval");
  186.                     }
  187.                 return (q);
  188.  
  189.             case FUNC:
  190.                 /*
  191.                  * Function call with no arguments.
  192.                  */
  193.                 if (r[3]) {
  194.                     error("Can't qualify a function result value");
  195.                     return (NIL);
  196.                 }
  197.                 return (funccod(r));
  198.  
  199.             case TYPE:
  200.                 error("Type names (e.g. %s) allowed only in declarations", p->symbol);
  201.                 return (NIL);
  202.  
  203.             case PROC:
  204.                 error("Procedure %s found where expression required", p->symbol);
  205.                 return (NIL);
  206.             default:
  207.                 panic("rvid");
  208.         }
  209.     /*
  210.      * Constant sets
  211.      */
  212.     case T_CSET:
  213.         return (cset(r, contype, NIL));
  214.  
  215.     /*
  216.      * Unary plus and minus
  217.      */
  218.     case T_PLUS:
  219.     case T_MINUS:
  220.         q = rvalue(r[2], NIL);
  221.         if (q == NIL)
  222.             return (NIL);
  223.         if (isnta(q, "id")) {
  224.             error("Operand of %s must be integer or real, not %s", opname, nameof(q));
  225.             return (NIL);
  226.         }
  227.         if (r[0] == T_MINUS) {
  228.             put1(O_NEG2 + (width(q) >> 2));
  229.             return (isa(q, "d") ? q : nl+T4INT);
  230.         }
  231.         return (q);
  232.  
  233.     case T_NOT:
  234.         q = rvalue(r[2], NIL);
  235.         if (q == NIL)
  236.             return (NIL);
  237.         if (isnta(q, "b")) {
  238.             error("not must operate on a Boolean, not %s", nameof(q));
  239.             return (NIL);
  240.         }
  241.         put1(O_NOT);
  242.         return (nl+T1BOOL);
  243.  
  244.     case T_AND:
  245.     case T_OR:
  246.         p = rvalue(r[2], NIL);
  247.         p1 = rvalue(r[3], NIL);
  248.         if (p == NIL || p1 == NIL)
  249.             return (NIL);
  250.         if (isnta(p, "b")) {
  251.             error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
  252.             return (NIL);
  253.         }
  254.         if (isnta(p1, "b")) {
  255.             error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
  256.             return (NIL);
  257.         }
  258.         put1(r[0] == T_AND ? O_AND : O_OR);
  259.         return (nl+T1BOOL);
  260.  
  261.     case T_DIVD:
  262.         p = rvalue(r[2], NIL);
  263.         p1 = rvalue(r[3], NIL);
  264.         if (p == NIL || p1 == NIL)
  265.             return (NIL);
  266.         if (isnta(p, "id")) {
  267.             error("Left operand of / must be integer or real, not %s", nameof(p));
  268.             return (NIL);
  269.         }
  270.         if (isnta(p1, "id")) {
  271.             error("Right operand of / must be integer or real, not %s", nameof(p1));
  272.             return (NIL);
  273.         }
  274.         return (gen(NIL, r[0], width(p), width(p1)));
  275.  
  276.     case T_MULT:
  277.     case T_SUB:
  278.     case T_ADD:
  279.         /*
  280.          * If the context hasn't told us
  281.          * the type and a constant set is
  282.          * present on the left we need to infer
  283.          * the type from the right if possible
  284.          * before generating left side code.
  285.          */
  286.         if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) {
  287.             codeoff();
  288.             contype = rvalue(r[3], NIL);
  289.             codeon();
  290.             if (contype == NIL)
  291.                 return (NIL);
  292.         }
  293.         p = rvalue(r[2], contype);
  294.         p1 = rvalue(r[3], p);
  295.         if (p == NIL || p1 == NIL)
  296.             return (NIL);
  297.         if (isa(p, "id") && isa(p1, "id"))
  298.             return (gen(NIL, r[0], width(p), width(p1)));
  299.         if (isa(p, "t") && isa(p1, "t")) {
  300.             if (p != p1) {
  301.                 error("Set types of operands of %s must be identical", opname);
  302.                 return (NIL);
  303.             }
  304.             gen(TSET, r[0], width(p), 0);
  305.             /*
  306.              * Note that set was filled in by the call
  307.              * to width above.
  308.              */
  309.             if (r[0] == T_SUB)
  310.                 put2(NIL, 0177777 << ((set.uprbp & 017) + 1));
  311.             return (p);
  312.         }
  313.         if (isnta(p, "idt")) {
  314.             error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
  315.             return (NIL);
  316.         }
  317.         if (isnta(p1, "idt")) {
  318.             error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
  319.             return (NIL);
  320.         }
  321.         error("Cannot mix sets with integers and reals as operands of %s", opname);
  322.         return (NIL);
  323.  
  324.     case T_MOD:
  325.     case T_DIV:
  326.         p = rvalue(r[2], NIL);
  327.         p1 = rvalue(r[3], NIL);
  328.         if (p == NIL || p1 == NIL)
  329.             return (NIL);
  330.         if (isnta(p, "i")) {
  331.             error("Left operand of %s must be integer, not %s", opname, nameof(p));
  332.             return (NIL);
  333.         }
  334.         if (isnta(p1, "i")) {
  335.             error("Right operand of %s must be integer, not %s", opname, nameof(p1));
  336.             return (NIL);
  337.         }
  338.         return (gen(NIL, r[0], width(p), width(p1)));
  339.  
  340.     case T_EQ:
  341.     case T_NE:
  342.     case T_GE:
  343.     case T_LE:
  344.     case T_GT:
  345.     case T_LT:
  346.         /*
  347.          * Since there can be no, a priori, knowledge
  348.          * of the context type should a constant string
  349.          * or set arise, we must poke around to find such
  350.          * a type if possible.  Since constant strings can
  351.          * always masquerade as identifiers, this is always
  352.          * necessary.
  353.          */
  354.         codeoff();
  355.         p1 = rvalue(r[3], NIL);
  356.         codeon();
  357.         if (p1 == NIL)
  358.             return (NIL);
  359.         contype = p1;
  360.         if (p1 == nl+TSET || p1->class == STR) {
  361.             /*
  362.              * For constant strings we want
  363.              * the longest type so as to be
  364.              * able to do padding (more importantly
  365.              * avoiding truncation). For clarity,
  366.              * we get this length here.
  367.              */
  368.             codeoff();
  369.             p = rvalue(r[2], NIL);
  370.             codeon();
  371.             if (p == NIL)
  372.                 return (NIL);
  373.             if (p1 == nl+TSET || width(p) > width(p1))
  374.                 contype = p;
  375.         }
  376.         /*
  377.          * Now we generate code for
  378.          * the operands of the relational
  379.          * operation.
  380.          */
  381.         p = rvalue(r[2], contype);
  382.         if (p == NIL)
  383.             return (NIL);
  384.         p1 = rvalue(r[3], p);
  385.         if (p1 == NIL)
  386.             return (NIL);
  387.         c = classify(p);
  388.         c1 = classify(p1);
  389.         if (nocomp(c) || nocomp(c1))
  390.             return (NIL);
  391.         g = NIL;
  392.         switch (c) {
  393.             case TBOOL:
  394.             case TCHAR:
  395.                 if (c != c1)
  396.                     goto clash;
  397.                 break;
  398.             case TINT:
  399.             case TDOUBLE:
  400.                 if (c1 != TINT && c1 != TDOUBLE)
  401.                     goto clash;
  402.                 break;
  403.             case TSCAL:
  404.                 if (c1 != TSCAL)
  405.                     goto clash;
  406.                 if (scalar(p) != scalar(p1))
  407.                     goto nonident;
  408.                 break;
  409.             case TSET:
  410.                 if (c1 != TSET)
  411.                     goto clash;
  412.                 if (p != p1)
  413.                     goto nonident;
  414.                 g = TSET;
  415.                 break;
  416.             case TPTR:
  417.             case TNIL:
  418.                 if (c1 != TPTR && c1 != TNIL)
  419.                     goto clash;
  420.                 if (r[0] != T_EQ && r[0] != T_NE) {
  421.                     error("%s not allowed on pointers - only allow = and <>");
  422.                     return (NIL);
  423.                 }
  424.                 break;
  425.             case TSTR:
  426.                 if (c1 != TSTR)
  427.                     goto clash;
  428.                 if (width(p) != width(p1)) {
  429.                     error("Strings not same length in %s comparison", opname);
  430.                     return (NIL);
  431.                 }
  432.                 g = TSTR;
  433.                 break;
  434.             default:
  435.                 panic("rval2");
  436.         }
  437.         return (gen(g, r[0], width(p), width(p1)));
  438. clash:
  439.         error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
  440.         return (NIL);
  441. nonident:
  442.         error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
  443.         return (NIL);
  444.  
  445.     case T_IN:
  446.         rt = r[3];
  447.         if (rt != NIL && rt[0] == T_CSET)
  448.             p1 = cset(rt, NIL, 1);
  449.         else {
  450.             p1 = rvalue(r[3], NIL);
  451.             rt = NIL;
  452.         }
  453.         if (p1 == nl+TSET) {
  454.             warning();
  455.             error("... in [] makes little sense, since it is always false!");
  456.             put1(O_CON1, 0);
  457.             return (nl+T1BOOL);
  458.         }
  459.         p = rvalue(r[2], NIL);
  460.         if (p == NIL || p1 == NIL)
  461.             return (NIL);
  462.         if (p1->class != SET) {
  463.             error("Right operand of 'in' must be a set, not %s", nameof(p1));
  464.             return (NIL);
  465.         }
  466.         if (incompat(p, p1->type, r[2])) {
  467.             cerror("Index type clashed with set component type for 'in'");
  468.             return (NIL);
  469.         }
  470.         convert(p, nl+T2INT);
  471.         setran(p1->type);
  472.         if (rt == NIL)
  473.             put4(O_IN, width(p1), set.lwrb, set.uprbp);
  474.         else
  475.             put1(O_INCT);
  476.         return (nl+T1BOOL);
  477.  
  478.     default:
  479.         if (r[2] == NIL)
  480.             return (NIL);
  481.         switch (r[0]) {
  482.         default:
  483.             panic("rval3");
  484.  
  485.  
  486.         /*
  487.          * An octal number
  488.          */
  489.         case T_BINT:
  490.             f = a8tol(r[2]);
  491.             goto conint;
  492.     
  493.         /*
  494.          * A decimal number
  495.          */
  496.         case T_INT:
  497.             f = atof(r[2]);
  498. conint:
  499.             if (f > MAXINT || f < MININT) {
  500.                 error("Constant too large for this implementation");
  501.                 return (NIL);
  502.             }
  503.             l = f;
  504.             if (bytes(l, l) <= 2) {
  505.                 put2(O_CON2, c=l);
  506.                 return (nl+T2INT);
  507.             }
  508.             put3(O_CON4, l);
  509.             return (nl+T4INT);
  510.     
  511.         /*
  512.          * A floating point number
  513.          */
  514.         case T_FINT:
  515.             put(5, O_CON8, atof(r[2]));
  516.             return (nl+TDOUBLE);
  517.     
  518.         /*
  519.          * Constant strings.  Note that constant characters
  520.          * are constant strings of length one; there is
  521.          * no constant string of length one.
  522.          */
  523.         case T_STRNG:
  524.             cp = r[2];
  525.             if (cp[1] == 0) {
  526.                 put2(O_CONC, cp[0]);
  527.                 return (nl+T1CHAR);
  528.             }
  529.             goto cstrng;
  530.         }
  531.     
  532.     }
  533. }
  534.  
  535. /*
  536.  * Can a class appear
  537.  * in a comparison ?
  538.  */
  539. nocomp(c)
  540.     int c;
  541. {
  542.  
  543.     switch (c) {
  544.         case TFILE:
  545.         case TARY:
  546.         case TREC:
  547.             error("%ss may not participate in comparisons", clnames[c]);
  548.             return (1);
  549.     }
  550.     return (NIL);
  551. }
  552.