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