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