1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)pclval.c 1.5 08/19/83"; 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 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 lastp = p; 136 p = p -> type; 137 if ( p == NLNIL ) { 138 return NLNIL; 139 } 140 switch ( co->tag ) { 141 case T_PTR: 142 /* 143 * Pointer qualification. 144 */ 145 if ( f ) { 146 putLV( firstsymbol , firstbn , o , 147 firstextra_flags , p2type( p ) ); 148 firstsymbol = 0; 149 } else { 150 if (o) { 151 putleaf( P2ICON , o , 0 , P2INT 152 , (char *) 0 ); 153 putop( P2PLUS , P2PTR | P2CHAR ); 154 } 155 } 156 /* 157 * Pointer cannot be 158 * nil and file cannot 159 * be at end-of-file. 160 * the appropriate function name is 161 * already out there from nilfnil. 162 */ 163 if ( p -> class == PTR ) { 164 /* 165 * this is the indirection from 166 * the address of the pointer 167 * to the pointer itself. 168 * kirk sez: 169 * fnil doesn't want this. 170 * and does it itself for files 171 * since only it knows where the 172 * actual window is. 173 * but i have to do this for 174 * regular pointers. 175 */ 176 putop( P2UNARY P2MUL , p2type( p ) ); 177 if ( opt( 't' ) ) { 178 putop( P2CALL , P2INT ); 179 } 180 } else { 181 putop( P2CALL , P2INT ); 182 } 183 f = o = 0; 184 continue; 185 case T_ARGL: 186 case T_ARY: 187 if ( f ) { 188 putLV( firstsymbol , firstbn , o , 189 firstextra_flags , p2type( p ) ); 190 firstsymbol = 0; 191 } else { 192 if (o) { 193 putleaf( P2ICON , o , 0 , P2INT 194 , (char *) 0 ); 195 putop( P2PLUS , P2INT ); 196 } 197 } 198 (void) arycod( p , co->ary_node.expr_list ); 199 f = o = 0; 200 continue; 201 case T_FIELD: 202 /* 203 * Field names are just 204 * an offset with some 205 * semantic checking. 206 */ 207 p = reclook(p, co->field_node.id_ptr); 208 o += p -> value[0]; 209 continue; 210 default: 211 panic("lval2"); 212 } 213 } 214 if (f) { 215 if ( required == LREQ ) { 216 putLV( firstsymbol , firstbn , o , 217 firstextra_flags , p2type( p -> type ) ); 218 } else { 219 putRV( firstsymbol , firstbn , o , 220 firstextra_flags , p2type( p -> type ) ); 221 } 222 } else { 223 if (o) { 224 putleaf( P2ICON , o , 0 , P2INT , (char *) 0 ); 225 putop( P2PLUS , P2INT ); 226 } 227 if ( required == RREQ ) { 228 putop( P2UNARY P2MUL , p2type( p -> type ) ); 229 } 230 } 231 return ( p -> type ); 232 } 233 234 /* 235 * this recursively follows done a list of qualifications 236 * and puts out the beginnings of calls to fnil for files 237 * or nil for pointers (if checking is on) on the way back. 238 * this returns true or false. 239 */ 240 bool 241 nilfnil( p , c , modflag , firstp , r2 ) 242 struct nl *p; 243 struct tnode *c; 244 int modflag; 245 struct nl *firstp; 246 char *r2; /* no, not r2-d2 */ 247 { 248 struct tnode *co; 249 struct nl *lastp; 250 int t; 251 252 if ( c == TR_NIL ) { 253 return TRUE; 254 } 255 co = ( c->list_node.list ); 256 if ( co == TR_NIL ) { 257 return FALSE; 258 } 259 lastp = p; 260 p = p -> type; 261 if ( p == NLNIL ) { 262 return FALSE; 263 } 264 switch ( co->tag ) { 265 case T_PTR: 266 /* 267 * Pointer qualification. 268 */ 269 lastp -> nl_flags |= NUSED; 270 if ( p -> class != PTR && p -> class != FILET) { 271 error("^ allowed only on files and pointers, not on %ss", nameof(p)); 272 goto bad; 273 } 274 break; 275 case T_ARGL: 276 if ( p -> class != ARRAY ) { 277 if ( lastp == firstp ) { 278 error("%s is a %s, not a function", r2, classes[firstp -> class]); 279 } else { 280 error("Illegal function qualificiation"); 281 } 282 return FALSE; 283 } 284 recovered(); 285 error("Pascal uses [] for subscripting, not ()"); 286 /* and fall through */ 287 case T_ARY: 288 if ( p -> class != ARRAY ) { 289 error("Subscripting allowed only on arrays, not on %ss", nameof(p)); 290 goto bad; 291 } 292 codeoff(); 293 t = arycod( p , co->ary_node.expr_list ); 294 codeon(); 295 switch ( t ) { 296 case 0: 297 return FALSE; 298 case -1: 299 goto bad; 300 } 301 break; 302 case T_FIELD: 303 /* 304 * Field names are just 305 * an offset with some 306 * semantic checking. 307 */ 308 if ( p -> class != RECORD ) { 309 error(". allowed only on records, not on %ss", nameof(p)); 310 goto bad; 311 } 312 if ( co->field_node.id_ptr == NIL ) { 313 return FALSE; 314 } 315 p = reclook( p , co->field_node.id_ptr ); 316 if ( p == NIL ) { 317 error("%s is not a field in this record", co->field_node.id_ptr); 318 goto bad; 319 } 320 if ( modflag & MOD ) { 321 p -> nl_flags |= NMOD; 322 } 323 if ((modflag & NOUSE) == 0 || lptr(c->field_node.other )) { 324 p -> nl_flags |= NUSED; 325 } 326 break; 327 default: 328 panic("nilfnil"); 329 } 330 /* 331 * recursive call, check the rest of the qualifications. 332 */ 333 if ( ! nilfnil( p , c->list_node.next , modflag , firstp , r2 ) ) { 334 return FALSE; 335 } 336 /* 337 * the point of all this. 338 */ 339 if ( co->tag == T_PTR ) { 340 if ( p -> class == PTR ) { 341 if ( opt( 't' ) ) { 342 putleaf( P2ICON , 0 , 0 343 , ADDTYPE( P2FTN | P2INT , P2PTR ) 344 , "_NIL" ); 345 } 346 } else { 347 putleaf( P2ICON , 0 , 0 348 , ADDTYPE( P2FTN | P2INT , P2PTR ) 349 , "_FNIL" ); 350 } 351 } 352 return TRUE; 353 bad: 354 cerror("Error occurred on qualification of %s", r2); 355 return FALSE; 356 } 357 #endif PC 358