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