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