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