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) 06/05/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 394