home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / lval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  14.1 KB  |  583 lines
  1. /*-
  2.  * Copyright (c) 1980 The Regents of the University of California.
  3.  * All rights reserved.
  4.  *
  5.  * Redistribution and use in source and binary forms, with or without
  6.  * modification, are permitted provided that the following conditions
  7.  * are met:
  8.  * 1. Redistributions of source code must retain the above copyright
  9.  *    notice, this list of conditions and the following disclaimer.
  10.  * 2. Redistributions in binary form must reproduce the above copyright
  11.  *    notice, this list of conditions and the following disclaimer in the
  12.  *    documentation and/or other materials provided with the distribution.
  13.  * 3. All advertising materials mentioning features or use of this software
  14.  *    must display the following acknowledgement:
  15.  *    This product includes software developed by the University of
  16.  *    California, Berkeley and its contributors.
  17.  * 4. Neither the name of the University nor the names of its contributors
  18.  *    may be used to endorse or promote products derived from this software
  19.  *    without specific prior written permission.
  20.  *
  21.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  22.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  23.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  24.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  25.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  26.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  27.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  29.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  30.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  31.  * SUCH DAMAGE.
  32.  */
  33.  
  34. #ifndef lint
  35. static char sccsid[] = "@(#)lval.c    5.3 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #include "0.h"
  40. #include "tree.h"
  41. #include "opcode.h"
  42. #include "objfmt.h"
  43. #include "tree_ty.h"
  44. #ifdef PC
  45. #   include    "pc.h"
  46. #   include    <pcc.h>
  47. #endif PC
  48.  
  49. extern    int flagwas;
  50. /*
  51.  * Lvalue computes the address
  52.  * of a qualified name and
  53.  * leaves it on the stack.
  54.  * for pc, it can be asked for either an lvalue or an rvalue.
  55.  * the semantics are the same, only the code is different.
  56.  */
  57. /*ARGSUSED*/
  58. struct nl *
  59. lvalue(var, modflag , required )
  60.     struct tnode *var; 
  61.     int    modflag;
  62.     int    required;
  63. {
  64. #ifdef OBJ
  65.     register struct nl *p;
  66.     struct nl *firstp, *lastp;
  67.     register struct tnode *c, *co;
  68.     int f, o, s;
  69.     /*
  70.      * Note that the local optimizations
  71.      * done here for offsets would more
  72.      * appropriately be done in put.
  73.      */
  74.     struct tnode    tr;    /* T_FIELD */ 
  75.     struct tnode    *tr_ptr;
  76.     struct tnode    l_node;
  77. #endif
  78.  
  79.     if (var == TR_NIL) {
  80.         return (NLNIL);
  81.     }
  82.     if (nowexp(var)) {
  83.         return (NLNIL);
  84.     }
  85.     if (var->tag != T_VAR) {
  86.         error("Variable required");    /* Pass mesgs down from pt of call ? */
  87.         return (NLNIL);
  88.     }
  89. #    ifdef PC
  90.         /*
  91.          *    pc requires a whole different control flow
  92.          */
  93.         return pclvalue( var , modflag , required );
  94. #    endif PC
  95. #    ifdef OBJ
  96.         /*
  97.          *    pi uses the rest of the function
  98.          */
  99.     firstp = p = lookup(var->var_node.cptr);
  100.     if (p == NLNIL) {
  101.         return (NLNIL);
  102.     }
  103.     c = var->var_node.qual;
  104.     if ((modflag & NOUSE) && !lptr(c)) {
  105.         p->nl_flags = flagwas;
  106.     }
  107.     if (modflag & MOD) {
  108.         p->nl_flags |= NMOD;
  109.     }
  110.     /*
  111.      * Only possibilities for p->class here
  112.      * are the named classes, i.e. CONST, TYPE
  113.      * VAR, PROC, FUNC, REF, or a WITHPTR.
  114.      */
  115.     tr_ptr = &l_node;
  116.     switch (p->class) {
  117.         case WITHPTR:
  118.             /*
  119.              * Construct the tree implied by
  120.              * the with statement
  121.              */
  122.             l_node.tag = T_LISTPP;
  123.  
  124.             /* the cast has got to go but until the node is figured
  125.                out it stays */
  126.  
  127.             tr_ptr->list_node.list = (&tr);
  128.             tr_ptr->list_node.next = var->var_node.qual;
  129.             tr.tag = T_FIELD;
  130.             tr.field_node.id_ptr = var->var_node.cptr;
  131.             c = tr_ptr; /* c is a ptr to a tnode */
  132. #            ifdef PTREE
  133.                 /*
  134.                  * mung var->fields to say which field this T_VAR is
  135.                  * for VarCopy
  136.                  */
  137.  
  138.                 /* problem! reclook returns struct nl* */
  139.  
  140.                 var->var_node.fields = reclook( p -> type , 
  141.                         var->var_node.line_no );
  142. #            endif
  143.             /* and fall through */
  144.         case REF:
  145.             /*
  146.              * Obtain the indirect word
  147.              * of the WITHPTR or REF
  148.              * as the base of our lvalue
  149.              */
  150.             (void) put(2, PTR_RV | bn << 8+INDX , (int)p->value[0] );
  151.             f = 0;        /* have an lv on stack */
  152.             o = 0;
  153.             break;
  154.         case VAR:
  155.             if (p->type->class != CRANGE) {
  156.                 f = 1;        /* no lv on stack yet */
  157.                 o = p->value[0];
  158.             } else {
  159.                 error("Conformant array bound %s found where variable required", p->symbol);
  160.                 return(NLNIL);
  161.             }
  162.             break;
  163.         default:
  164.             error("%s %s found where variable required", classes[p->class], p->symbol);
  165.             return (NLNIL);
  166.     }
  167.     /*
  168.      * Loop and handle each
  169.      * qualification on the name
  170.      */
  171.     if (c == TR_NIL && (modflag&ASGN) && ( p->value[NL_FORV] & FORVAR ) ) {
  172.         error("Can't modify the for variable %s in the range of the loop", p->symbol);
  173.         return (NLNIL);
  174.     }
  175.     s = 0;        /* subscripts seen */
  176.     for (; c != TR_NIL; c = c->list_node.next) {
  177.         co = c->list_node.list; /* co is a ptr to a tnode */
  178.         if (co == TR_NIL) {
  179.             return (NLNIL);
  180.         }
  181.         lastp = p;
  182.         p = p->type;
  183.         if (p == NLNIL) {
  184.             return (NLNIL);
  185.         }
  186.         /*
  187.          * If we haven't seen enough subscripts, and the next
  188.          * qualification isn't array reference, then it's an error.
  189.          */
  190.         if (s && co->tag != T_ARY) {
  191.             error("Too few subscripts (%d given, %d required)",
  192.                 s, p->value[0]);
  193.         }
  194.         switch (co->tag) {
  195.             case T_PTR:
  196.                 /*
  197.                  * Pointer qualification.
  198.                  */
  199.                 lastp->nl_flags |= NUSED;
  200.                 if (p->class != PTR && p->class != FILET) {
  201.                     error("^ allowed only on files and pointers, not on %ss", nameof(p));
  202.                     goto bad;
  203.                 }
  204.                 if (f) {
  205.                     if (p->class == FILET && bn != 0)
  206.                         (void) put(2, O_LV | bn <<8+INDX , o );
  207.                     else
  208.                     /*
  209.                      * this is the indirection from
  210.                      * the address of the pointer 
  211.                      * to the pointer itself.
  212.                      * kirk sez:
  213.                      * fnil doesn't want this.
  214.                      * and does it itself for files
  215.                      * since only it knows where the
  216.                      * actual window is.
  217.                      * but i have to do this for
  218.                      * regular pointers.
  219.                      * This is further complicated by
  220.                      * the fact that global variables
  221.                      * are referenced through pointers
  222.                      * on the stack. Thus an RV on a
  223.                      * global variable is the same as
  224.                      * an LV of a non-global one ?!?
  225.                      */
  226.                         (void) put(2, PTR_RV | bn <<8+INDX , o );
  227.                 } else {
  228.                     if (o) {
  229.                         (void) put(2, O_OFF, o);
  230.                     }
  231.                         if (p->class != FILET || bn == 0)
  232.                         (void) put(1, PTR_IND);
  233.                 }
  234.                 /*
  235.                  * Pointer cannot be
  236.                  * nil and file cannot
  237.                  * be at end-of-file.
  238.                  */
  239.                 (void) put(1, p->class == FILET ? O_FNIL : O_NIL);
  240.                 f = o = 0;
  241.                 continue;
  242.             case T_ARGL:
  243.                 if (p->class != ARRAY) {
  244.                     if (lastp == firstp) {
  245.                         error("%s is a %s, not a function", var->var_node.cptr, classes[firstp->class]);
  246.                     } else {
  247.                         error("Illegal function qualificiation");
  248.                     }
  249.                     return (NLNIL);
  250.                 }
  251.                 recovered();
  252.                 error("Pascal uses [] for subscripting, not ()");
  253.             case T_ARY:
  254.                 if (p->class != ARRAY) {
  255.                     error("Subscripting allowed only on arrays, not on %ss", nameof(p));
  256.                     goto bad;
  257.                 }
  258.                 if (f) {
  259.                     if (bn == 0)
  260.                         /*
  261.                          * global variables are
  262.                          * referenced through pointers
  263.                          * on the stack
  264.                          */
  265.                         (void) put(2, PTR_RV | bn<<8+INDX, o);
  266.                     else
  267.                         (void) put(2, O_LV | bn<<8+INDX, o);
  268.                 } else {
  269.                     if (o) {
  270.                         (void) put(2, O_OFF, o);
  271.                     }
  272.                 }
  273.                 switch(s = arycod(p,co->ary_node.expr_list,s)) {
  274.                     /*
  275.                      * This is the number of subscripts seen
  276.                      */
  277.                     case 0:
  278.                         return (NLNIL);
  279.                     case -1:
  280.                         goto bad;
  281.                 }
  282.                 if (s == p->value[0]) {
  283.                     s = 0;
  284.                 } else {
  285.                     p = lastp;
  286.                 }
  287.                 f = o = 0;
  288.                 continue;
  289.             case T_FIELD:
  290.                 /*
  291.                  * Field names are just
  292.                  * an offset with some 
  293.                  * semantic checking.
  294.                  */
  295.                 if (p->class != RECORD) {
  296.                     error(". allowed only on records, not on %ss", nameof(p));
  297.                     goto bad;
  298.                 }
  299.                 /* must define the field node!! */
  300.                 if (co->field_node.id_ptr == NIL) {
  301.                     return (NLNIL);
  302.                 }
  303.                 p = reclook(p, co->field_node.id_ptr);
  304.                 if (p == NLNIL) {
  305.                     error("%s is not a field in this record", co->field_node.id_ptr);
  306.                     goto bad;
  307.                 }
  308. #                ifdef PTREE
  309.                     /*
  310.                      * mung co[3] to indicate which field
  311.                      * this is for SelCopy
  312.                      */
  313.                     co->field_node.nl_entry = p;
  314. #                endif
  315.                 if (modflag & MOD) {
  316.                     p->nl_flags |= NMOD;
  317.                 }
  318.                 if ((modflag & NOUSE) == 0 ||
  319.                     lptr(c->list_node.next)) {
  320.                 /* figure out what kind of node c is !! */
  321.                     p->nl_flags |= NUSED;
  322.                 }
  323.                 o += p->value[0];
  324.                 continue;
  325.             default:
  326.                 panic("lval2");
  327.         }
  328.     }
  329.     if (s) {
  330.         error("Too few subscripts (%d given, %d required)",
  331.             s, p->type->value[0]);
  332.         return NLNIL;
  333.     }
  334.     if (f) {
  335.         if (bn == 0)
  336.             /*
  337.              * global variables are referenced through
  338.              * pointers on the stack
  339.              */
  340.             (void) put(2, PTR_RV | bn<<8+INDX, o);
  341.         else
  342.             (void) put(2, O_LV | bn<<8+INDX, o);
  343.     } else {
  344.         if (o) {
  345.             (void) put(2, O_OFF, o);
  346.         }
  347.     }
  348.     return (p->type);
  349. bad:
  350.     cerror("Error occurred on qualification of %s", var->var_node.cptr);
  351.     return (NLNIL);
  352. #    endif OBJ
  353. }
  354.  
  355. int lptr(c)
  356.     register struct tnode *c;
  357. {
  358.     register struct tnode *co;
  359.  
  360.     for (; c != TR_NIL; c = c->list_node.next) {
  361.         co = c->list_node.list;
  362.         if (co == TR_NIL) {
  363.             return (NIL);
  364.         }
  365.         switch (co->tag) {
  366.  
  367.         case T_PTR:
  368.             return (1);
  369.         case T_ARGL:
  370.             return (0);
  371.         case T_ARY:
  372.         case T_FIELD:
  373.             continue;
  374.         default:
  375.             panic("lptr");
  376.         }
  377.     }
  378.     return (0);
  379. }
  380.  
  381. /*
  382.  * Arycod does the
  383.  * code generation
  384.  * for subscripting.
  385.  * n is the number of
  386.  * subscripts already seen
  387.  * (CLN 09/13/83)
  388.  */
  389. int arycod(np, el, n)
  390.     struct nl *np;
  391.     struct tnode *el;
  392.     int n;
  393. {
  394.     register struct nl *p, *ap;
  395.     long sub;
  396.     bool constsub;
  397.     extern bool constval();
  398.     int i, d;  /* v, v1;  these aren't used */
  399.     int w;
  400.  
  401.     p = np;
  402.     if (el == TR_NIL) {
  403.         return (0);
  404.     }
  405.     d = p->value[0];
  406.     for (i = 1; i <= n; i++) {
  407.         p = p->chain;
  408.     }
  409.     /*
  410.      * Check each subscript
  411.      */
  412.     for (i = n+1; i <= d; i++) {
  413.         if (el == TR_NIL) {
  414.             return (i-1);
  415.         }
  416.         p = p->chain;
  417.         if (p == NLNIL)
  418.             return (0);
  419.         if ((p->class != CRANGE) &&
  420.             (constsub = constval(el->list_node.list))) {
  421.             ap = con.ctype;
  422.             sub = con.crval;
  423.             if (sub < p->range[0] || sub > p->range[1]) {
  424.             error("Subscript value of %D is out of range", (char *) sub);
  425.             return (0);
  426.             }
  427.             sub -= p->range[0];
  428.         } else {
  429. #            ifdef PC
  430.             precheck( p , "_SUBSC" , "_SUBSCZ" );
  431. #            endif PC
  432.             ap = rvalue(el->list_node.list, NLNIL , RREQ );
  433.             if (ap == NIL) {
  434.                 return (0);
  435.             }
  436. #            ifdef PC
  437.             postcheck(p, ap);
  438.             sconv(p2type(ap),PCCT_INT);
  439. #            endif PC
  440.         }
  441.         if (incompat(ap, p->type, el->list_node.list)) {
  442.             cerror("Array index type incompatible with declared index type");
  443.             if (d != 1) {
  444.                 cerror("Error occurred on index number %d", (char *) i);
  445.             }
  446.             return (-1);
  447.         }
  448.         if (p->class == CRANGE) {
  449.             constsub = FALSE;
  450.         } else {
  451.             w = aryconst(np, i);
  452.         }
  453. #        ifdef OBJ
  454.             if (constsub) {
  455.             sub *= w;
  456.             if (sub != 0) {
  457.                 w = bytes(sub, sub);
  458.                 (void) put(2, w <= 2 ? O_CON2 : O_CON4, sub);
  459.                 (void) gen(NIL, T_ADD, sizeof(char *), w);
  460.             }
  461.             el = el->list_node.next;
  462.             continue;
  463.             }
  464.             if (p->class == CRANGE) {
  465.             putcbnds(p, 0);
  466.             putcbnds(p, 1);
  467.             putcbnds(p, 2);
  468.             } else if (opt('t') == 0) {
  469.                 switch (w) {
  470.                 case 8:
  471.                     w = 6;
  472.                 case 4:
  473.                 case 2:
  474.                 case 1:
  475.                     (void) put(2, (width(ap) != 4 ? O_INX2P2 : O_INX4P2) | (w & ~1) << 7, ( short ) p->range[0]);
  476.                     el = el->list_node.next;
  477.                     continue;
  478.                 }
  479.             }
  480.             if (p->class == CRANGE) {
  481.             if (width(p) == 4) {
  482.                 put(1, width(ap) != 4 ? O_VINX42 : O_VINX4);
  483.             } else {
  484.                 put(1, width(ap) != 4 ? O_VINX2 : O_VINX24);
  485.             }
  486.             } else {
  487.             put(4, width(ap) != 4 ? O_INX2 : O_INX4, w,
  488.                 (short)p->range[0], (short)(p->range[1]));
  489.             }
  490.             el = el->list_node.next;
  491.             continue;
  492. #        endif OBJ
  493. #        ifdef PC
  494.             /*
  495.              *    subtract off the lower bound
  496.              */
  497.             if (constsub) {
  498.             sub *= w;
  499.             if (sub != 0) {
  500.                 putleaf( PCC_ICON , (int) sub , 0 , PCCT_INT , (char *) 0 );
  501.                 putop(PCC_PLUS, PCCM_ADDTYPE(p2type(np->type), PCCTM_PTR));
  502.             }
  503.             el = el->list_node.next;
  504.             continue;
  505.             }
  506.             if (p->class == CRANGE) {
  507.             /*
  508.              *    if conformant array, subtract off lower bound
  509.              */
  510.             ap = p->nptr[0];
  511.             putRV(ap->symbol, (ap->nl_block & 037), ap->value[0], 
  512.                 ap->extra_flags, p2type( ap ) );
  513.             putop( PCC_MINUS, PCCT_INT );
  514.             /*
  515.              *    and multiply by the width of the elements
  516.              */
  517.             ap = p->nptr[2];
  518.             putRV( 0 , (ap->nl_block & 037), ap->value[0], 
  519.                 ap->extra_flags, p2type( ap ) );
  520.             putop( PCC_MUL , PCCT_INT );
  521.             } else {
  522.             if ( p -> range[ 0 ] != 0 ) {
  523.                 putleaf( PCC_ICON , (int) p -> range[0] , 0 , PCCT_INT , (char *) 0 );
  524.                 putop( PCC_MINUS , PCCT_INT );
  525.             }
  526.                 /*
  527.                  *    multiply by the width of the elements
  528.                  */
  529.             if ( w != 1 ) {
  530.                 putleaf( PCC_ICON , w , 0 , PCCT_INT , (char *) 0 );
  531.                 putop( PCC_MUL , PCCT_INT );
  532.             }
  533.             }
  534.             /*
  535.              *    and add it to the base address
  536.              */
  537.             putop( PCC_PLUS , PCCM_ADDTYPE( p2type( np -> type ) , PCCTM_PTR ) );
  538.         el = el->list_node.next;
  539. #        endif PC
  540.     }
  541.     if (el != TR_NIL) {
  542.         if (np->type->class != ARRAY) {
  543.         do {
  544.             el = el->list_node.next;
  545.             i++;
  546.         } while (el != TR_NIL);
  547.         error("Too many subscripts (%d given, %d required)", (char *) (i-1), (char *) d);
  548.         return (-1);
  549.         } else {
  550.         return(arycod(np->type, el, d));
  551.         }
  552.     }
  553.     return (d);
  554. }
  555.  
  556. #ifdef OBJ
  557. /*
  558.  * Put out the conformant array bounds (lower bound, upper bound or width)
  559.  * for conformant array type ctype.
  560.  * The value of i determines which is being put
  561.  * i = 0: lower bound, i=1: upper bound, i=2: width
  562.  */
  563. putcbnds(ctype, i)
  564. struct nl *ctype;
  565. int i;
  566. {
  567.     switch(width(ctype->type)) {
  568.         case 1:
  569.         put(2, O_RV1 | (ctype->nl_block & 037) << 8+INDX,
  570.             (int)ctype->nptr[i]->value[0]);
  571.         break;
  572.         case 2:
  573.         put(2, O_RV2 | (ctype->nl_block & 037) << 8+INDX,
  574.             (int)ctype->nptr[i]->value[0]);
  575.         break;
  576.         case 4:
  577.         default:
  578.         put(2, O_RV4 | (ctype->nl_block & 037) << 8+INDX,
  579.             (int)ctype->nptr[i]->value[0]);
  580.     }
  581. }
  582. #endif OBJ
  583.