![[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] / 42BSD / ucb / pascal / src|
Return to pclval.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / pascal / src |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2:
3: static char sccsid[] = "@(#)pclval.c 1.4 6/1/81";
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: char firstextra_flags;
42: int firstbn;
43:
44: if ( r == NIL ) {
45: return NIL;
46: }
47: if ( nowexp( r ) ) {
48: return NIL;
49: }
50: if ( r[0] != T_VAR ) {
51: error("Variable required"); /* Pass mesgs down from pt of call ? */
52: return NIL;
53: }
54: firstp = p = lookup( r[2] );
55: if ( p == NIL ) {
56: return NIL;
57: }
58: firstsymbol = p -> symbol;
59: firstbn = bn;
60: firstextra_flags = p -> extra_flags;
61: c = r[3];
62: if ( ( modflag & NOUSE ) && ! lptr( c ) ) {
63: p -> nl_flags = flagwas;
64: }
65: if ( modflag & MOD ) {
66: p -> nl_flags |= NMOD;
67: }
68: /*
69: * Only possibilities for p -> class here
70: * are the named classes, i.e. CONST, TYPE
71: * VAR, PROC, FUNC, REF, or a WITHPTR.
72: */
73: if ( p -> class == WITHPTR ) {
74: /*
75: * Construct the tree implied by
76: * the with statement
77: */
78: trp[0] = T_LISTPP;
79: trp[1] = tr;
80: trp[2] = r[3];
81: tr[0] = T_FIELD;
82: tr[1] = r[2];
83: c = trp;
84: }
85: /*
86: * this not only puts out the names of functions to call
87: * but also does all the semantic checking of the qualifications.
88: */
89: if ( ! nilfnil( p , c , modflag , firstp , r[2] ) ) {
90: return NIL;
91: }
92: switch (p -> class) {
93: case WITHPTR:
94: case REF:
95: /*
96: * Obtain the indirect word
97: * of the WITHPTR or REF
98: * as the base of our lvalue
99: */
100: putRV( firstsymbol , firstbn , p -> value[ 0 ] ,
101: firstextra_flags , p2type( p ) );
102: firstsymbol = 0;
103: f = 0; /* have an lv on stack */
104: o = 0;
105: break;
106: case VAR:
107: f = 1; /* no lv on stack yet */
108: o = p -> value[0];
109: break;
110: default:
111: error("%s %s found where variable required", classes[p -> class], p -> symbol);
112: return (NIL);
113: }
114: /*
115: * Loop and handle each
116: * qualification on the name
117: */
118: if ( c == NIL &&
119: ( modflag & ASGN ) &&
120: ( p -> value[ NL_FORV ] & FORVAR ) ) {
121: error("Can't modify the for variable %s in the range of the loop", p -> symbol);
122: return (NIL);
123: }
124: for ( ; c != NIL ; c = c[2] ) {
125: co = c[1];
126: if ( co == NIL ) {
127: return NIL;
128: }
129: lastp = p;
130: p = p -> type;
131: if ( p == NIL ) {
132: return NIL;
133: }
134: switch ( co[0] ) {
135: case T_PTR:
136: /*
137: * Pointer qualification.
138: */
139: if ( f ) {
140: putLV( firstsymbol , firstbn , o ,
141: firstextra_flags , p2type( p ) );
142: firstsymbol = 0;
143: } else {
144: if (o) {
145: putleaf( P2ICON , o , 0 , P2INT
146: , 0 );
147: putop( P2PLUS , P2PTR | P2CHAR );
148: }
149: }
150: /*
151: * Pointer cannot be
152: * nil and file cannot
153: * be at end-of-file.
154: * the appropriate function name is
155: * already out there from nilfnil.
156: */
157: if ( p -> class == PTR ) {
158: /*
159: * this is the indirection from
160: * the address of the pointer
161: * to the pointer itself.
162: * kirk sez:
163: * fnil doesn't want this.
164: * and does it itself for files
165: * since only it knows where the
166: * actual window is.
167: * but i have to do this for
168: * regular pointers.
169: */
170: putop( P2UNARY P2MUL , p2type( p ) );
171: if ( opt( 't' ) ) {
172: putop( P2CALL , P2INT );
173: }
174: } else {
175: putop( P2CALL , P2INT );
176: }
177: f = o = 0;
178: continue;
179: case T_ARGL:
180: case T_ARY:
181: if ( f ) {
182: putLV( firstsymbol , firstbn , o ,
183: firstextra_flags , p2type( p ) );
184: firstsymbol = 0;
185: } else {
186: if (o) {
187: putleaf( P2ICON , o , 0 , P2INT
188: , 0 );
189: putop( P2PLUS , P2INT );
190: }
191: }
192: arycod( p , co[1] );
193: f = o = 0;
194: continue;
195: case T_FIELD:
196: /*
197: * Field names are just
198: * an offset with some
199: * semantic checking.
200: */
201: p = reclook(p, co[1]);
202: o += p -> value[0];
203: continue;
204: default:
205: panic("lval2");
206: }
207: }
208: if (f) {
209: if ( required == LREQ ) {
210: putLV( firstsymbol , firstbn , o ,
211: firstextra_flags , p2type( p -> type ) );
212: } else {
213: putRV( firstsymbol , firstbn , o ,
214: firstextra_flags , p2type( p -> type ) );
215: }
216: } else {
217: if (o) {
218: putleaf( P2ICON , o , 0 , P2INT , 0 );
219: putop( P2PLUS , P2INT );
220: }
221: if ( required == RREQ ) {
222: putop( P2UNARY P2MUL , p2type( p -> type ) );
223: }
224: }
225: return ( p -> type );
226: }
227:
228: /*
229: * this recursively follows done a list of qualifications
230: * and puts out the beginnings of calls to fnil for files
231: * or nil for pointers (if checking is on) on the way back.
232: * this returns true or false.
233: */
234: nilfnil( p , c , modflag , firstp , r2 )
235: struct nl *p;
236: int *c;
237: int modflag;
238: struct nl *firstp;
239: char *r2; /* no, not r2-d2 */
240: {
241: int *co;
242: struct nl *lastp;
243: int t;
244:
245: if ( c == NIL ) {
246: return TRUE;
247: }
248: co = (int *) ( c[1] );
249: if ( co == NIL ) {
250: return FALSE;
251: }
252: lastp = p;
253: p = p -> type;
254: if ( p == NIL ) {
255: return FALSE;
256: }
257: switch ( co[0] ) {
258: case T_PTR:
259: /*
260: * Pointer qualification.
261: */
262: lastp -> nl_flags |= NUSED;
263: if ( p -> class != PTR && p -> class != FILET) {
264: error("^ allowed only on files and pointers, not on %ss", nameof(p));
265: goto bad;
266: }
267: break;
268: case T_ARGL:
269: if ( p -> class != ARRAY ) {
270: if ( lastp == firstp ) {
271: error("%s is a %s, not a function", r2, classes[firstp -> class]);
272: } else {
273: error("Illegal function qualificiation");
274: }
275: return FALSE;
276: }
277: recovered();
278: error("Pascal uses [] for subscripting, not ()");
279: /* and fall through */
280: case T_ARY:
281: if ( p -> class != ARRAY ) {
282: error("Subscripting allowed only on arrays, not on %ss", nameof(p));
283: goto bad;
284: }
285: codeoff();
286: t = arycod( p , co[1] );
287: codeon();
288: switch ( t ) {
289: case 0:
290: return FALSE;
291: case -1:
292: goto bad;
293: }
294: break;
295: case T_FIELD:
296: /*
297: * Field names are just
298: * an offset with some
299: * semantic checking.
300: */
301: if ( p -> class != RECORD ) {
302: error(". allowed only on records, not on %ss", nameof(p));
303: goto bad;
304: }
305: if ( co[1] == NIL ) {
306: return FALSE;
307: }
308: p = reclook( p , co[1] );
309: if ( p == NIL ) {
310: error("%s is not a field in this record", co[1]);
311: goto bad;
312: }
313: if ( modflag & MOD ) {
314: p -> nl_flags |= NMOD;
315: }
316: if ( ( modflag & NOUSE ) == 0 || lptr( c[2] ) ) {
317: p -> nl_flags |= NUSED;
318: }
319: break;
320: default:
321: panic("nilfnil");
322: }
323: /*
324: * recursive call, check the rest of the qualifications.
325: */
326: if ( ! nilfnil( p , c[2] , modflag , firstp , r2 ) ) {
327: return FALSE;
328: }
329: /*
330: * the point of all this.
331: */
332: if ( co[0] == T_PTR ) {
333: if ( p -> class == PTR ) {
334: if ( opt( 't' ) ) {
335: putleaf( P2ICON , 0 , 0
336: , ADDTYPE( P2FTN | P2INT , P2PTR )
337: , "_NIL" );
338: }
339: } else {
340: putleaf( P2ICON , 0 , 0
341: , ADDTYPE( P2FTN | P2INT , P2PTR )
342: , "_FNIL" );
343: }
344: }
345: return TRUE;
346: bad:
347: cerror("Error occurred on qualification of %s", r2);
348: return FALSE;
349: }
350: #endif PC
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.