![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pclval.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / src|
Return to pclval.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / src |
1.1 root 1: /*
2: * Copyright (c) 1980 Regents of the University of California.
3: * All rights reserved. The Berkeley software License Agreement
4: * specifies the terms and conditions for redistribution.
5: */
6:
7: #ifndef lint
8: static char sccsid[] = "@(#)pclval.c 5.1 (Berkeley) 6/5/85";
9: #endif not lint
10:
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 *
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
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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.