# 2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/pclval.c

##### Functions

    nilfnil           X
    pclvalue          X

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

#### Defined functions

nilfnil defined in line 270; used 3 times

- in line 101, 369
- in /usr/src/ucb/PORT/pascal/src/0.h line 729

pclvalue defined in line 36; used 2 times

- in /usr/src/ucb/PORT/pascal/src/0.h line 761
- in /usr/src/ucb/PORT/pascal/src/lval.c line 66

#### Defined variables

sccsid defined in line 8; never used

Last modified: 1985-06-05 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1169 |