| 1 | /* Copyright (c) 1979 Regents of the University of California */ |
| 2 | |
| 3 | static char sccsid[] = "@(#)pclval.c 1.1 8/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 |