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