[unix-history] / usr / src / cmd / pc0 / pclval.c

/* Copyright (c) 1979 Regents of the University of California */

static	char sccsid[] = "@(#)pclval.c 1.1 8/27/80";

#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "objfmt.h"
#ifdef PC
	/*
	 *	and the rest of the file
	 */
#   include	"pc.h"
#   include	"pcops.h"

extern	int flagwas;
/*
 * pclvalue computes the address
 * of a qualified name and
 * leaves it on the stack.
 * for pc, it can be asked for either an lvalue or an rvalue.
 * the semantics are the same, only the code is different.
 * for putting out calls to check for nil and fnil,
 * we have to traverse the list of qualifications twice:
 * once to put out the calls and once to put out the address to be checked.
 */
struct nl *
pclvalue( r , modflag , required )
	int	*r;
	int	modflag;
	int	required;
{
	register struct nl	*p;
	register		*c, *co;
	int			f, o;
	int			tr[2], trp[3];
	struct nl		*firstp;
	struct nl		*lastp;
	char			*firstsymbol;
	int			firstbn;

	if ( r == NIL ) {
		return NIL;
	}
	if ( nowexp( r ) ) {
		return NIL;
	}
	if ( r[0] != T_VAR ) {
		error("Variable required");	/* Pass mesgs down from pt of call ? */
		return NIL;
	}
	firstp = p = lookup( r[2] );
	if ( p == NIL ) {
		return NIL;
	}
	firstsymbol = p -> symbol;
	firstbn = bn;
	c = r[3];
	if ( ( modflag & NOUSE ) && ! lptr( c ) ) {
		p -> nl_flags = flagwas;
	}
	if ( modflag & MOD ) {
		p -> nl_flags |= NMOD;
	}
	/*
	 * Only possibilities for p -> class here
	 * are the named classes, i.e. CONST, TYPE
	 * VAR, PROC, FUNC, REF, or a WITHPTR.
	 */
	if ( p -> class == WITHPTR ) {
		/*
		 * Construct the tree implied by
		 * the with statement
		 */
	    trp[0] = T_LISTPP;
	    trp[1] = tr;
	    trp[2] = r[3];
	    tr[0] = T_FIELD;
	    tr[1] = r[2];
	    c = trp;
	}
	    /*
	     *	this not only puts out the names of functions to call
	     *	but also does all the semantic checking of the qualifications.
	     */
	if ( ! nilfnil( p , c , modflag , firstp , r[2] ) ) {
	    return NIL;
	}
	switch (p -> class) {
		case WITHPTR:
		case REF:
			/*
			 * Obtain the indirect word
			 * of the WITHPTR or REF
			 * as the base of our lvalue
			 */
			putRV( firstsymbol , firstbn , p -> value[ 0 ]
				    , p2type( p ) );
			firstsymbol = 0;
			f = 0;		/* have an lv on stack */
			o = 0;
			break;
		case VAR:
			f = 1;		/* no lv on stack yet */
			o = p -> value[0];
			break;
		default:
			error("%s %s found where variable required", classes[p -> class], p -> symbol);
			return (NIL);
	}
	/*
	 * Loop and handle each
	 * qualification on the name
	 */
	if ( c == NIL && ( modflag & ASGN ) && p -> value[ NL_FORV ] ) {
		error("Can't modify the for variable %s in the range of the loop", p -> symbol);
		return (NIL);
	}
	for ( ; c != NIL ; c = c[2] ) {
		co = c[1];
		if ( co == NIL ) {
			return NIL;
		}
		lastp = p;
		p = p -> type;
		if ( p == NIL ) {
			return NIL;
		}
		switch ( co[0] ) {
			case T_PTR:
				/*
				 * Pointer qualification.
				 */
				if ( f ) {
					putLV( firstsymbol , firstbn , o
					       , p2type( p ) );
					firstsymbol = 0;
				} else {
					if (o) {
					    putleaf( P2ICON , o , 0 , P2INT
						    , 0 );
					    putop( P2PLUS , P2PTR | P2CHAR );
					}
				}
				    /*
				     * Pointer cannot be
				     * nil and file cannot
				     * be at end-of-file.
				     * the appropriate function name is 
				     * already out there from nilfnil.
				     */
				if ( p -> class == PTR ) {
					/*
					 * this is the indirection from
					 * the address of the pointer 
					 * to the pointer itself.
					 * kirk sez:
					 * fnil doesn't want this.
					 * and does it itself for files
					 * since only it knows where the
					 * actual window is.
					 * but i have to do this for
					 * regular pointers.
					 */
				    putop( P2UNARY P2MUL , p2type( p ) );
				    if ( opt( 't' ) ) {
					putop( P2CALL , P2INT );
				    }
				} else {
				    putop( P2CALL , P2INT );
				}
				f = o = 0;
				continue;
			case T_ARGL:
			case T_ARY:
				if ( f ) {
					putLV( firstsymbol , firstbn , o
						, p2type( p ) );
					firstsymbol = 0;
				} else {
					if (o) {
					    putleaf( P2ICON , o , 0 , P2INT
						    , 0 );
					    putop( P2PLUS , P2INT );
					}
				}
				arycod( p , co[1] );
				f = o = 0;
				continue;
			case T_FIELD:
				/*
				 * Field names are just
				 * an offset with some 
				 * semantic checking.
				 */
				p = reclook(p, co[1]);
				o += p -> value[0];
				continue;
			default:
				panic("lval2");
		}
	}
	if (f) {
		putLV( firstsymbol , firstbn , o , p2type( p -> type ) );
	} else {
		if (o) {
		    putleaf( P2ICON , o , 0 , P2INT , 0 );
		    putop( P2PLUS , P2INT );
		}
	}
	if ( required == RREQ ) {
	    putop( P2UNARY P2MUL , p2type( p -> type ) );
	}
	return ( p -> type );
}

    /*
     *	this recursively follows done a list of qualifications
     *	and puts out the beginnings of calls to fnil for files
     *	or nil for pointers (if checking is on) on the way back.
     *	this returns true or false.
     */
nilfnil( p , c , modflag , firstp , r2 )
    struct nl	*p;
    int		*c;
    int		modflag;
    struct nl	*firstp;
    char	*r2;		/* no, not r2-d2 */
    {
	int		*co;
	struct nl	*lastp;
	int		t;

	if ( c == NIL ) {
	    return TRUE;
	}
	co = (int *) ( c[1] );
	if ( co == NIL ) {
		return FALSE;
	}
	lastp = p;
	p = p -> type;
	if ( p == NIL ) {
		return FALSE;
	}
	switch ( co[0] ) {
	    case T_PTR:
		    /*
		     * Pointer qualification.
		     */
		    lastp -> nl_flags |= NUSED;
		    if ( p -> class != PTR && p -> class != FILET) {
			    error("^ allowed only on files and pointers, not on %ss", nameof(p));
			    goto bad;
		    }
		    break;
	    case T_ARGL:
		    if ( p -> class != ARRAY ) {
			    if ( lastp == firstp ) {
				    error("%s is a %s, not a function", r2, classes[firstp -> class]);
			    } else {
				    error("Illegal function qualificiation");
			    }
			    return FALSE;
		    }
		    recovered();
		    error("Pascal uses [] for subscripting, not ()");
		    /* and fall through */
	    case T_ARY:
		    if ( p -> class != ARRAY ) {
			    error("Subscripting allowed only on arrays, not on %ss", nameof(p));
			    goto bad;
		    }
		    codeoff();
		    t = arycod( p , co[1] );
		    codeon();
		    switch ( t ) {
			    case 0:
				    return FALSE;
			    case -1:
				    goto bad;
		    }
		    break;
	    case T_FIELD:
		    /*
		     * Field names are just
		     * an offset with some 
		     * semantic checking.
		     */
		    if ( p -> class != RECORD ) {
			    error(". allowed only on records, not on %ss", nameof(p));
			    goto bad;
		    }
		    if ( co[1] == NIL ) {
			    return FALSE;
		    }
		    p = reclook( p , co[1] );
		    if ( p == NIL ) {
			    error("%s is not a field in this record", co[1]);
			    goto bad;
		    }
		    if ( modflag & MOD ) {
			    p -> nl_flags |= NMOD;
		    }
		    if ( ( modflag & NOUSE ) == 0 || lptr( c[2] ) ) {
			    p -> nl_flags |= NUSED;
		    }
		    break;
	    default:
		    panic("nilfnil");
	}
	    /*
	     *	recursive call, check the rest of the qualifications.
	     */
	if ( ! nilfnil( p , c[2] , modflag , firstp , r2 ) ) {
	    return FALSE;
	}
	    /*
	     *	the point of all this.
	     */
	if ( co[0] == T_PTR ) {
	    if ( p -> class == PTR ) {
		    if ( opt( 't' ) ) {
			putleaf( P2ICON , 0 , 0
			    , ADDTYPE( P2FTN | P2INT , P2PTR )
			    , "_NIL" );
		    }
	    } else {
		    putleaf( P2ICON , 0 , 0
			, ADDTYPE( P2FTN | P2INT , P2PTR )
			, "_FNIL" );
	    }
	}
	return TRUE;
bad:
	cerror("Error occurred on qualification of %s", r2);
	return FALSE;
    }
#endif PC
Commit	Line	Data
3ef8af77 PK	1	/* Copyright (c) 1979 Regents of the University of California */
3ef8af77 PK	2
31cef89c	3	static char sccsid[] = "@(#)pclval.c 1.1 8/27/80";
3ef8af77 PK	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