home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / pclval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  10.8 KB  |  420 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[] = "@(#)pclval.c    5.2 (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.     /*
  46.      *    and the rest of the file
  47.      */
  48. #   include    "pc.h"
  49. #   include    <pcc.h>
  50.  
  51. extern    int flagwas;
  52. /*
  53.  * pclvalue computes the address
  54.  * of a qualified name and
  55.  * leaves it on the stack.
  56.  * for pc, it can be asked for either an lvalue or an rvalue.
  57.  * the semantics are the same, only the code is different.
  58.  * for putting out calls to check for nil and fnil,
  59.  * we have to traverse the list of qualifications twice:
  60.  * once to put out the calls and once to put out the address to be checked.
  61.  */
  62. struct nl *
  63. pclvalue( var , modflag , required )
  64.     struct tnode    *var;
  65.     int    modflag;
  66.     int    required;
  67. {
  68.     register struct nl    *p;
  69.     register struct tnode     *c, *co;
  70.     int            f, o;
  71.     struct tnode        l_node, tr;
  72.     VAR_NODE        *v_node;
  73.     LIST_NODE        *tr_ptr;
  74.     struct nl        *firstp, *lastp;
  75.     char            *firstsymbol;
  76.     char            firstextra_flags;
  77.     int            firstbn;
  78.     int            s;
  79.  
  80.     if ( var == TR_NIL ) {
  81.         return NLNIL;
  82.     }
  83.     if ( nowexp( var ) ) {
  84.         return NLNIL;
  85.     }
  86.     if ( var->tag != T_VAR ) {
  87.         error("Variable required");    /* Pass mesgs down from pt of call ? */
  88.         return NLNIL;
  89.     }
  90.     v_node = &(var->var_node);
  91.     firstp = p = lookup( v_node->cptr );
  92.     if ( p == NLNIL ) {
  93.         return NLNIL;
  94.     }
  95.     firstsymbol = p -> symbol;
  96.     firstbn = bn;
  97.     firstextra_flags = p -> extra_flags;
  98.     c = v_node->qual;
  99.     if ( ( modflag & NOUSE ) && ! lptr( c ) ) {
  100.         p -> nl_flags = flagwas;
  101.     }
  102.     if ( modflag & MOD ) {
  103.         p -> nl_flags |= NMOD;
  104.     }
  105.     /*
  106.      * Only possibilities for p -> class here
  107.      * are the named classes, i.e. CONST, TYPE
  108.      * VAR, PROC, FUNC, REF, or a WITHPTR.
  109.      */
  110.      tr_ptr = &(l_node.list_node);
  111.     if ( p -> class == WITHPTR ) {
  112.         /*
  113.          * Construct the tree implied by
  114.          * the with statement
  115.          */
  116.         l_node.tag = T_LISTPP;
  117.         tr_ptr->list = &(tr);
  118.         tr_ptr->next = v_node->qual;
  119.         tr.tag = T_FIELD;
  120.         tr.field_node.id_ptr = v_node->cptr;
  121.         c = &(l_node);
  122.     }
  123.         /*
  124.          *    this not only puts out the names of functions to call
  125.          *    but also does all the semantic checking of the qualifications.
  126.          */
  127.     if ( ! nilfnil( p , c , modflag , firstp , v_node->cptr ) ) {
  128.         return NLNIL;
  129.     }
  130.     switch (p -> class) {
  131.         case WITHPTR:
  132.         case REF:
  133.             /*
  134.              * Obtain the indirect word
  135.              * of the WITHPTR or REF
  136.              * as the base of our lvalue
  137.              */
  138.             putRV( firstsymbol , firstbn , p -> value[ 0 ] ,
  139.                 firstextra_flags , p2type( p ) );
  140.             firstsymbol = 0;
  141.             f = 0;        /* have an lv on stack */
  142.             o = 0;
  143.             break;
  144.         case VAR:
  145.             if (p->type->class != CRANGE) {
  146.                 f = 1;        /* no lv on stack yet */
  147.                 o = p -> value[0];
  148.             } else {
  149.                 error("Conformant array bound %s found where variable required", p->symbol);
  150.                 return(NIL);
  151.             }
  152.             break;
  153.         default:
  154.             error("%s %s found where variable required", classes[p -> class], p -> symbol);
  155.             return (NLNIL);
  156.     }
  157.     /*
  158.      * Loop and handle each
  159.      * qualification on the name
  160.      */
  161.     if ( c == NIL &&
  162.         ( modflag & ASGN ) &&
  163.         ( p -> value[ NL_FORV ] & FORVAR ) ) {
  164.         error("Can't modify the for variable %s in the range of the loop", p -> symbol);
  165.         return (NLNIL);
  166.     }
  167.     s = 0;
  168.     for ( ; c != TR_NIL ; c = c->list_node.next ) {
  169.         co = c->list_node.list;
  170.         if ( co == TR_NIL ) {
  171.             return NLNIL;
  172.         }
  173.         lastp = p;
  174.         p = p -> type;
  175.         if ( p == NLNIL ) {
  176.             return NLNIL;
  177.         }
  178.         /*
  179.          * If we haven't seen enough subscripts, and the next
  180.          * qualification isn't array reference, then it's an error.
  181.          */
  182.         if (s && co->tag != T_ARY) {
  183.             error("Too few subscripts (%d given, %d required)",
  184.                 s, p->value[0]);
  185.         }
  186.         switch ( co->tag ) {
  187.             case T_PTR:
  188.                 /*
  189.                  * Pointer qualification.
  190.                  */
  191.                 if ( f ) {
  192.                     putLV( firstsymbol , firstbn , o ,
  193.                         firstextra_flags , p2type( p ) );
  194.                     firstsymbol = 0;
  195.                 } else {
  196.                     if (o) {
  197.                         putleaf( PCC_ICON , o , 0 , PCCT_INT
  198.                             , (char *) 0 );
  199.                         putop( PCC_PLUS , PCCTM_PTR | PCCT_CHAR );
  200.                     }
  201.                 }
  202.                     /*
  203.                      * Pointer cannot be
  204.                      * nil and file cannot
  205.                      * be at end-of-file.
  206.                      * the appropriate function name is 
  207.                      * already out there from nilfnil.
  208.                      */
  209.                 if ( p -> class == PTR ) {
  210.                     /*
  211.                      * this is the indirection from
  212.                      * the address of the pointer 
  213.                      * to the pointer itself.
  214.                      * kirk sez:
  215.                      * fnil doesn't want this.
  216.                      * and does it itself for files
  217.                      * since only it knows where the
  218.                      * actual window is.
  219.                      * but i have to do this for
  220.                      * regular pointers.
  221.                      */
  222.                     putop( PCCOM_UNARY PCC_MUL , p2type( p ) );
  223.                     if ( opt( 't' ) ) {
  224.                     putop( PCC_CALL , PCCT_INT );
  225.                     }
  226.                 } else {
  227.                     putop( PCC_CALL , PCCT_INT );
  228.                 }
  229.                 f = o = 0;
  230.                 continue;
  231.             case T_ARGL:
  232.             case T_ARY:
  233.                 if ( f ) {
  234.                     putLV( firstsymbol , firstbn , o ,
  235.                         firstextra_flags , p2type( p ) );
  236.                     firstsymbol = 0;
  237.                 } else {
  238.                     if (o) {
  239.                         putleaf( PCC_ICON , o , 0 , PCCT_INT
  240.                             , (char *) 0 );
  241.                         putop( PCC_PLUS , PCCT_INT );
  242.                     }
  243.                 }
  244.                 s = arycod( p , co->ary_node.expr_list, s);
  245.                 if (s == p->value[0]) {
  246.                     s = 0;
  247.                 } else {
  248.                     p = lastp;
  249.                 }
  250.                 f = o = 0;
  251.                 continue;
  252.             case T_FIELD:
  253.                 /*
  254.                  * Field names are just
  255.                  * an offset with some 
  256.                  * semantic checking.
  257.                  */
  258.                 p = reclook(p, co->field_node.id_ptr);
  259.                 o += p -> value[0];
  260.                 continue;
  261.             default:
  262.                 panic("lval2");
  263.         }
  264.     }
  265.     if (s) {
  266.         error("Too few subscripts (%d given, %d required)",
  267.             s, p->type->value[0]);
  268.         return NLNIL;
  269.     }
  270.     if (f) {
  271.         if ( required == LREQ ) {
  272.             putLV( firstsymbol , firstbn , o ,
  273.                 firstextra_flags , p2type( p -> type ) );
  274.         } else {
  275.             putRV( firstsymbol , firstbn , o ,
  276.                 firstextra_flags , p2type( p -> type ) );
  277.         }
  278.     } else {
  279.         if (o) {
  280.             putleaf( PCC_ICON , o , 0 , PCCT_INT , (char *) 0 );
  281.             putop( PCC_PLUS , PCCT_INT );
  282.         }
  283.         if ( required == RREQ ) {
  284.             putop( PCCOM_UNARY PCC_MUL , p2type( p -> type ) );
  285.         }
  286.     }
  287.     return ( p -> type );
  288. }
  289.  
  290.     /*
  291.      *    this recursively follows done a list of qualifications
  292.      *    and puts out the beginnings of calls to fnil for files
  293.      *    or nil for pointers (if checking is on) on the way back.
  294.      *    this returns true or false.
  295.      */
  296. bool
  297. nilfnil( p , c , modflag , firstp , r2 )
  298.     struct nl     *p;
  299.     struct tnode *c;
  300.     int        modflag;
  301.     struct nl    *firstp;
  302.     char    *r2;        /* no, not r2-d2 */
  303.     {
  304.     struct tnode     *co;
  305.     struct nl    *lastp;
  306.     int        t;
  307.     static int    s = 0;
  308.  
  309.     if ( c == TR_NIL ) {
  310.         return TRUE;
  311.     }
  312.     co = ( c->list_node.list );
  313.     if ( co == TR_NIL ) {
  314.         return FALSE;
  315.     }
  316.     lastp = p;
  317.     p = p -> type;
  318.     if ( p == NLNIL ) {
  319.         return FALSE;
  320.     }
  321.     switch ( co->tag ) {
  322.         case T_PTR:
  323.             /*
  324.              * Pointer qualification.
  325.              */
  326.             lastp -> nl_flags |= NUSED;
  327.             if ( p -> class != PTR && p -> class != FILET) {
  328.                 error("^ allowed only on files and pointers, not on %ss", nameof(p));
  329.                 goto bad;
  330.             }
  331.             break;
  332.         case T_ARGL:
  333.             if ( p -> class != ARRAY ) {
  334.                 if ( lastp == firstp ) {
  335.                     error("%s is a %s, not a function", r2, classes[firstp -> class]);
  336.                 } else {
  337.                     error("Illegal function qualificiation");
  338.                 }
  339.                 return FALSE;
  340.             }
  341.             recovered();
  342.             error("Pascal uses [] for subscripting, not ()");
  343.             /* and fall through */
  344.         case T_ARY:
  345.             if ( p -> class != ARRAY ) {
  346.                 error("Subscripting allowed only on arrays, not on %ss", nameof(p));
  347.                 goto bad;
  348.             }
  349.             codeoff();
  350.             s = arycod( p , co->ary_node.expr_list , s );
  351.             codeon();
  352.             switch ( s ) {
  353.                 case 0:
  354.                     return FALSE;
  355.                 case -1:
  356.                     goto bad;
  357.             }
  358.             if (s == p->value[0]) {
  359.                 s = 0;
  360.             } else {
  361.                 p = lastp;
  362.             }
  363.             break;
  364.         case T_FIELD:
  365.             /*
  366.              * Field names are just
  367.              * an offset with some 
  368.              * semantic checking.
  369.              */
  370.             if ( p -> class != RECORD ) {
  371.                 error(". allowed only on records, not on %ss", nameof(p));
  372.                 goto bad;
  373.             }
  374.             if ( co->field_node.id_ptr == NIL ) {
  375.                 return FALSE;
  376.             }
  377.             p = reclook( p , co->field_node.id_ptr );
  378.             if ( p == NIL ) {
  379.                 error("%s is not a field in this record", co->field_node.id_ptr);
  380.                 goto bad;
  381.             }
  382.             if ( modflag & MOD ) {
  383.                 p -> nl_flags |= NMOD;
  384.             }
  385.             if ((modflag & NOUSE) == 0 || lptr(c->field_node.other )) {
  386.                 p -> nl_flags |= NUSED;
  387.             }
  388.             break;
  389.         default:
  390.             panic("nilfnil");
  391.     }
  392.         /*
  393.          *    recursive call, check the rest of the qualifications.
  394.          */
  395.     if ( ! nilfnil( p , c->list_node.next , modflag , firstp , r2 ) ) {
  396.         return FALSE;
  397.     }
  398.         /*
  399.          *    the point of all this.
  400.          */
  401.     if ( co->tag == T_PTR ) {
  402.         if ( p -> class == PTR ) {
  403.             if ( opt( 't' ) ) {
  404.             putleaf( PCC_ICON , 0 , 0
  405.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  406.                 , "_NIL" );
  407.             }
  408.         } else {
  409.             putleaf( PCC_ICON , 0 , 0
  410.             , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  411.             , "_FNIL" );
  412.         }
  413.     }
  414.     return TRUE;
  415. bad:
  416.     cerror("Error occurred on qualification of %s", r2);
  417.     return FALSE;
  418.     }
  419. #endif PC
  420.