1 /*-
2 * Copyright (c) 1980, 1993
3 * The Regents of the University of California. All rights reserved.
4 *
5 * %sccs.include.redist.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)lval.c 8.1 (Berkeley) 06/06/93";
10 #endif /* not lint */
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 # include "pc.h"
20 # include <pcc.h>
21 #endif PC
22
23 extern int flagwas;
24 /*
25 * Lvalue computes the address
26 * of a qualified name and
27 * leaves it on the stack.
28 * for pc, it can be asked for either an lvalue or an rvalue.
29 * the semantics are the same, only the code is different.
30 */
31 /*ARGSUSED*/
32 struct nl *
lvalue(var,modflag,required)33 lvalue(var, modflag , required )
34 struct tnode *var;
35 int modflag;
36 int required;
37 {
38 #ifdef OBJ
39 register struct nl *p;
40 struct nl *firstp, *lastp;
41 register struct tnode *c, *co;
42 int f, o, s;
43 /*
44 * Note that the local optimizations
45 * done here for offsets would more
46 * appropriately be done in put.
47 */
48 struct tnode tr; /* T_FIELD */
49 struct tnode *tr_ptr;
50 struct tnode l_node;
51 #endif
52
53 if (var == TR_NIL) {
54 return (NLNIL);
55 }
56 if (nowexp(var)) {
57 return (NLNIL);
58 }
59 if (var->tag != T_VAR) {
60 error("Variable required"); /* Pass mesgs down from pt of call ? */
61 return (NLNIL);
62 }
63 # ifdef PC
64 /*
65 * pc requires a whole different control flow
66 */
67 return pclvalue( var , modflag , required );
68 # endif PC
69 # ifdef OBJ
70 /*
71 * pi uses the rest of the function
72 */
73 firstp = p = lookup(var->var_node.cptr);
74 if (p == NLNIL) {
75 return (NLNIL);
76 }
77 c = var->var_node.qual;
78 if ((modflag & NOUSE) && !lptr(c)) {
79 p->nl_flags = flagwas;
80 }
81 if (modflag & MOD) {
82 p->nl_flags |= NMOD;
83 }
84 /*
85 * Only possibilities for p->class here
86 * are the named classes, i.e. CONST, TYPE
87 * VAR, PROC, FUNC, REF, or a WITHPTR.
88 */
89 tr_ptr = &l_node;
90 switch (p->class) {
91 case WITHPTR:
92 /*
93 * Construct the tree implied by
94 * the with statement
95 */
96 l_node.tag = T_LISTPP;
97
98 /* the cast has got to go but until the node is figured
99 out it stays */
100
101 tr_ptr->list_node.list = (&tr);
102 tr_ptr->list_node.next = var->var_node.qual;
103 tr.tag = T_FIELD;
104 tr.field_node.id_ptr = var->var_node.cptr;
105 c = tr_ptr; /* c is a ptr to a tnode */
106 # ifdef PTREE
107 /*
108 * mung var->fields to say which field this T_VAR is
109 * for VarCopy
110 */
111
112 /* problem! reclook returns struct nl* */
113
114 var->var_node.fields = reclook( p -> type ,
115 var->var_node.line_no );
116 # endif
117 /* and fall through */
118 case REF:
119 /*
120 * Obtain the indirect word
121 * of the WITHPTR or REF
122 * as the base of our lvalue
123 */
124 (void) put(2, PTR_RV | bn << 8+INDX , (int)p->value[0] );
125 f = 0; /* have an lv on stack */
126 o = 0;
127 break;
128 case VAR:
129 if (p->type->class != CRANGE) {
130 f = 1; /* no lv on stack yet */
131 o = p->value[0];
132 } else {
133 error("Conformant array bound %s found where variable required", p->symbol);
134 return(NLNIL);
135 }
136 break;
137 default:
138 error("%s %s found where variable required", classes[p->class], p->symbol);
139 return (NLNIL);
140 }
141 /*
142 * Loop and handle each
143 * qualification on the name
144 */
145 if (c == TR_NIL && (modflag&ASGN) && ( p->value[NL_FORV] & FORVAR ) ) {
146 error("Can't modify the for variable %s in the range of the loop", p->symbol);
147 return (NLNIL);
148 }
149 s = 0; /* subscripts seen */
150 for (; c != TR_NIL; c = c->list_node.next) {
151 co = c->list_node.list; /* co is a ptr to a tnode */
152 if (co == TR_NIL) {
153 return (NLNIL);
154 }
155 lastp = p;
156 p = p->type;
157 if (p == NLNIL) {
158 return (NLNIL);
159 }
160 /*
161 * If we haven't seen enough subscripts, and the next
162 * qualification isn't array reference, then it's an error.
163 */
164 if (s && co->tag != T_ARY) {
165 error("Too few subscripts (%d given, %d required)",
166 s, p->value[0]);
167 }
168 switch (co->tag) {
169 case T_PTR:
170 /*
171 * Pointer qualification.
172 */
173 lastp->nl_flags |= NUSED;
174 if (p->class != PTR && p->class != FILET) {
175 error("^ allowed only on files and pointers, not on %ss", nameof(p));
176 goto bad;
177 }
178 if (f) {
179 if (p->class == FILET && bn != 0)
180 (void) put(2, O_LV | bn <<8+INDX , o );
181 else
182 /*
183 * this is the indirection from
184 * the address of the pointer
185 * to the pointer itself.
186 * kirk sez:
187 * fnil doesn't want this.
188 * and does it itself for files
189 * since only it knows where the
190 * actual window is.
191 * but i have to do this for
192 * regular pointers.
193 * This is further complicated by
194 * the fact that global variables
195 * are referenced through pointers
196 * on the stack. Thus an RV on a
197 * global variable is the same as
198 * an LV of a non-global one ?!?
199 */
200 (void) put(2, PTR_RV | bn <<8+INDX , o );
201 } else {
202 if (o) {
203 (void) put(2, O_OFF, o);
204 }
205 if (p->class != FILET || bn == 0)
206 (void) put(1, PTR_IND);
207 }
208 /*
209 * Pointer cannot be
210 * nil and file cannot
211 * be at end-of-file.
212 */
213 (void) put(1, p->class == FILET ? O_FNIL : O_NIL);
214 f = o = 0;
215 continue;
216 case T_ARGL:
217 if (p->class != ARRAY) {
218 if (lastp == firstp) {
219 error("%s is a %s, not a function", var->var_node.cptr, classes[firstp->class]);
220 } else {
221 error("Illegal function qualificiation");
222 }
223 return (NLNIL);
224 }
225 recovered();
226 error("Pascal uses [] for subscripting, not ()");
227 case T_ARY:
228 if (p->class != ARRAY) {
229 error("Subscripting allowed only on arrays, not on %ss", nameof(p));
230 goto bad;
231 }
232 if (f) {
233 if (bn == 0)
234 /*
235 * global variables are
236 * referenced through pointers
237 * on the stack
238 */
239 (void) put(2, PTR_RV | bn<<8+INDX, o);
240 else
241 (void) put(2, O_LV | bn<<8+INDX, o);
242 } else {
243 if (o) {
244 (void) put(2, O_OFF, o);
245 }
246 }
247 switch(s = arycod(p,co->ary_node.expr_list,s)) {
248 /*
249 * This is the number of subscripts seen
250 */
251 case 0:
252 return (NLNIL);
253 case -1:
254 goto bad;
255 }
256 if (s == p->value[0]) {
257 s = 0;
258 } else {
259 p = lastp;
260 }
261 f = o = 0;
262 continue;
263 case T_FIELD:
264 /*
265 * Field names are just
266 * an offset with some
267 * semantic checking.
268 */
269 if (p->class != RECORD) {
270 error(". allowed only on records, not on %ss", nameof(p));
271 goto bad;
272 }
273 /* must define the field node!! */
274 if (co->field_node.id_ptr == NIL) {
275 return (NLNIL);
276 }
277 p = reclook(p, co->field_node.id_ptr);
278 if (p == NLNIL) {
279 error("%s is not a field in this record", co->field_node.id_ptr);
280 goto bad;
281 }
282 # ifdef PTREE
283 /*
284 * mung co[3] to indicate which field
285 * this is for SelCopy
286 */
287 co->field_node.nl_entry = p;
288 # endif
289 if (modflag & MOD) {
290 p->nl_flags |= NMOD;
291 }
292 if ((modflag & NOUSE) == 0 ||
293 lptr(c->list_node.next)) {
294 /* figure out what kind of node c is !! */
295 p->nl_flags |= NUSED;
296 }
297 o += p->value[0];
298 continue;
299 default:
300 panic("lval2");
301 }
302 }
303 if (s) {
304 error("Too few subscripts (%d given, %d required)",
305 s, p->type->value[0]);
306 return NLNIL;
307 }
308 if (f) {
309 if (bn == 0)
310 /*
311 * global variables are referenced through
312 * pointers on the stack
313 */
314 (void) put(2, PTR_RV | bn<<8+INDX, o);
315 else
316 (void) put(2, O_LV | bn<<8+INDX, o);
317 } else {
318 if (o) {
319 (void) put(2, O_OFF, o);
320 }
321 }
322 return (p->type);
323 bad:
324 cerror("Error occurred on qualification of %s", var->var_node.cptr);
325 return (NLNIL);
326 # endif OBJ
327 }
328
lptr(c)329 int lptr(c)
330 register struct tnode *c;
331 {
332 register struct tnode *co;
333
334 for (; c != TR_NIL; c = c->list_node.next) {
335 co = c->list_node.list;
336 if (co == TR_NIL) {
337 return (NIL);
338 }
339 switch (co->tag) {
340
341 case T_PTR:
342 return (1);
343 case T_ARGL:
344 return (0);
345 case T_ARY:
346 case T_FIELD:
347 continue;
348 default:
349 panic("lptr");
350 }
351 }
352 return (0);
353 }
354
355 /*
356 * Arycod does the
357 * code generation
358 * for subscripting.
359 * n is the number of
360 * subscripts already seen
361 * (CLN 09/13/83)
362 */
arycod(np,el,n)363 int arycod(np, el, n)
364 struct nl *np;
365 struct tnode *el;
366 int n;
367 {
368 register struct nl *p, *ap;
369 long sub;
370 bool constsub;
371 extern bool constval();
372 int i, d; /* v, v1; these aren't used */
373 int w;
374
375 p = np;
376 if (el == TR_NIL) {
377 return (0);
378 }
379 d = p->value[0];
380 for (i = 1; i <= n; i++) {
381 p = p->chain;
382 }
383 /*
384 * Check each subscript
385 */
386 for (i = n+1; i <= d; i++) {
387 if (el == TR_NIL) {
388 return (i-1);
389 }
390 p = p->chain;
391 if (p == NLNIL)
392 return (0);
393 if ((p->class != CRANGE) &&
394 (constsub = constval(el->list_node.list))) {
395 ap = con.ctype;
396 sub = con.crval;
397 if (sub < p->range[0] || sub > p->range[1]) {
398 error("Subscript value of %D is out of range", (char *) sub);
399 return (0);
400 }
401 sub -= p->range[0];
402 } else {
403 # ifdef PC
404 precheck( p , "_SUBSC" , "_SUBSCZ" );
405 # endif PC
406 ap = rvalue(el->list_node.list, NLNIL , RREQ );
407 if (ap == NIL) {
408 return (0);
409 }
410 # ifdef PC
411 postcheck(p, ap);
412 sconv(p2type(ap),PCCT_INT);
413 # endif PC
414 }
415 if (incompat(ap, p->type, el->list_node.list)) {
416 cerror("Array index type incompatible with declared index type");
417 if (d != 1) {
418 cerror("Error occurred on index number %d", (char *) i);
419 }
420 return (-1);
421 }
422 if (p->class == CRANGE) {
423 constsub = FALSE;
424 } else {
425 w = aryconst(np, i);
426 }
427 # ifdef OBJ
428 if (constsub) {
429 sub *= w;
430 if (sub != 0) {
431 w = bytes(sub, sub);
432 (void) put(2, w <= 2 ? O_CON2 : O_CON4, sub);
433 (void) gen(NIL, T_ADD, sizeof(char *), w);
434 }
435 el = el->list_node.next;
436 continue;
437 }
438 if (p->class == CRANGE) {
439 putcbnds(p, 0);
440 putcbnds(p, 1);
441 putcbnds(p, 2);
442 } else if (opt('t') == 0) {
443 switch (w) {
444 case 8:
445 w = 6;
446 case 4:
447 case 2:
448 case 1:
449 (void) put(2, (width(ap) != 4 ? O_INX2P2 : O_INX4P2) | (w & ~1) << 7, ( short ) p->range[0]);
450 el = el->list_node.next;
451 continue;
452 }
453 }
454 if (p->class == CRANGE) {
455 if (width(p) == 4) {
456 put(1, width(ap) != 4 ? O_VINX42 : O_VINX4);
457 } else {
458 put(1, width(ap) != 4 ? O_VINX2 : O_VINX24);
459 }
460 } else {
461 put(4, width(ap) != 4 ? O_INX2 : O_INX4, w,
462 (short)p->range[0], (short)(p->range[1]));
463 }
464 el = el->list_node.next;
465 continue;
466 # endif OBJ
467 # ifdef PC
468 /*
469 * subtract off the lower bound
470 */
471 if (constsub) {
472 sub *= w;
473 if (sub != 0) {
474 putleaf( PCC_ICON , (int) sub , 0 , PCCT_INT , (char *) 0 );
475 putop(PCC_PLUS, PCCM_ADDTYPE(p2type(np->type), PCCTM_PTR));
476 }
477 el = el->list_node.next;
478 continue;
479 }
480 if (p->class == CRANGE) {
481 /*
482 * if conformant array, subtract off lower bound
483 */
484 ap = p->nptr[0];
485 putRV(ap->symbol, (ap->nl_block & 037), ap->value[0],
486 ap->extra_flags, p2type( ap ) );
487 putop( PCC_MINUS, PCCT_INT );
488 /*
489 * and multiply by the width of the elements
490 */
491 ap = p->nptr[2];
492 putRV( 0 , (ap->nl_block & 037), ap->value[0],
493 ap->extra_flags, p2type( ap ) );
494 putop( PCC_MUL , PCCT_INT );
495 } else {
496 if ( p -> range[ 0 ] != 0 ) {
497 putleaf( PCC_ICON , (int) p -> range[0] , 0 , PCCT_INT , (char *) 0 );
498 putop( PCC_MINUS , PCCT_INT );
499 }
500 /*
501 * multiply by the width of the elements
502 */
503 if ( w != 1 ) {
504 putleaf( PCC_ICON , w , 0 , PCCT_INT , (char *) 0 );
505 putop( PCC_MUL , PCCT_INT );
506 }
507 }
508 /*
509 * and add it to the base address
510 */
511 putop( PCC_PLUS , PCCM_ADDTYPE( p2type( np -> type ) , PCCTM_PTR ) );
512 el = el->list_node.next;
513 # endif PC
514 }
515 if (el != TR_NIL) {
516 if (np->type->class != ARRAY) {
517 do {
518 el = el->list_node.next;
519 i++;
520 } while (el != TR_NIL);
521 error("Too many subscripts (%d given, %d required)", (char *) (i-1), (char *) d);
522 return (-1);
523 } else {
524 return(arycod(np->type, el, d));
525 }
526 }
527 return (d);
528 }
529
530 #ifdef OBJ
531 /*
532 * Put out the conformant array bounds (lower bound, upper bound or width)
533 * for conformant array type ctype.
534 * The value of i determines which is being put
535 * i = 0: lower bound, i=1: upper bound, i=2: width
536 */
537 putcbnds(ctype, i)
538 struct nl *ctype;
539 int i;
540 {
541 switch(width(ctype->type)) {
542 case 1:
543 put(2, O_RV1 | (ctype->nl_block & 037) << 8+INDX,
544 (int)ctype->nptr[i]->value[0]);
545 break;
546 case 2:
547 put(2, O_RV2 | (ctype->nl_block & 037) << 8+INDX,
548 (int)ctype->nptr[i]->value[0]);
549 break;
550 case 4:
551 default:
552 put(2, O_RV4 | (ctype->nl_block & 037) << 8+INDX,
553 (int)ctype->nptr[i]->value[0]);
554 }
555 }
556 #endif OBJ
557