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