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

   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

Defined variables