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