[unix-history] / .ref-5cb41021d721f4e0ac572d592613f963e495d1ff / usr / src / usr.bin / pascal / src / lval.c

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

static	char sccsid[] = "@(#)lval.c 1.1 %G%";

#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "objfmt.h"
#ifdef PC
#   include	"pc.h"
#   include	"pcops.h"
#endif PC

extern	int flagwas;
/*
 * Lvalue 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.
 */
struct nl *
lvalue(r, modflag , required )
	int *r, modflag;
	int	required;
{
	register struct nl *p;
	struct nl *firstp, *lastp;
	register *c, *co;
	int f, o;
	/*
	 * Note that the local optimizations
	 * done here for offsets would more
	 * appropriately be done in put.
	 */
	int tr[2], trp[3];

	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);
	}
#	ifdef PC
		/*
		 *	pc requires a whole different control flow
		 */
	    return pclvalue( r , modflag , required );
#	endif PC
	firstp = p = lookup(r[2]);
	if (p == NIL) {
		return (NIL);
	}
	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.
	 */
	switch (p->class) {
		case 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;
#			ifdef PTREE
			    /*
			     * mung r[4] to say which field this T_VAR is
			     * for VarCopy
			     */
			    r[4] = reclook( p -> type , r[2] );
#			endif
			/* and fall through */
		case REF:
			/*
			 * Obtain the indirect word
			 * of the WITHPTR or REF
			 * as the base of our lvalue
			 */
			put(2, PTR_RV | bn << 8+INDX , p->value[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.
				 */
				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;
				}
				if (f) {
				    put(2, PTR_RV | bn <<8+INDX , o );
				} else {
					if (o) {
					    put2(O_OFF, o);
					}
					put(1, PTR_IND);
				}
				/*
				 * Pointer cannot be
				 * nil and file cannot
				 * be at end-of-file.
				 */
				put1(p->class == FILET ? O_FNIL : O_NIL);
				f = o = 0;
				continue;
			case T_ARGL:
				if (p->class != ARRAY) {
					if (lastp == firstp) {
						error("%s is a %s, not a function", r[2], classes[firstp->class]);
					} else {
						error("Illegal function qualificiation");
					}
					return (NIL);
				}
				recovered();
				error("Pascal uses [] for subscripting, not ()");
			case T_ARY:
				if (p->class != ARRAY) {
					error("Subscripting allowed only on arrays, not on %ss", nameof(p));
					goto bad;
				}
				if (f) {
					put2(O_LV | bn<<8+INDX, o);
				} else {
					if (o) {
					    put2(O_OFF, o);
					}
				}
				switch (arycod(p, co[1])) {
					case 0:
						return (NIL);
					case -1:
						goto bad;
				}
				f = o = 0;
				continue;
			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 (NIL);
				}
				p = reclook(p, co[1]);
				if (p == NIL) {
					error("%s is not a field in this record", co[1]);
					goto bad;
				}
#				ifdef PTREE
				    /*
				     * mung co[3] to indicate which field
				     * this is for SelCopy
				     */
				    co[3] = p;
#				endif
				if (modflag & MOD) {
					p->nl_flags |= NMOD;
				}
				if ((modflag & NOUSE) == 0 || lptr(c[2])) {
					p->nl_flags |= NUSED;
				}
				o += p->value[0];
				continue;
			default:
				panic("lval2");
		}
	}
	if (f) {
		put2(O_LV | bn<<8+INDX, o);
	} else {
		if (o) {
		    put2(O_OFF, o);
		}
	}
	return (p->type);
bad:
	cerror("Error occurred on qualification of %s", r[2]);
	return (NIL);
}

lptr(c)
	register int *c;
{
	register int *co;

	for (; c != NIL; c = c[2]) {
		co = c[1];
		if (co == NIL) {
			return (NIL);
		}
		switch (co[0]) {

		case T_PTR:
			return (1);
		case T_ARGL:
			return (0);
		case T_ARY:
		case T_FIELD:
			continue;
		default:
			panic("lptr");
		}
	}
	return (0);
}

/*
 * Arycod does the
 * code generation
 * for subscripting.
 */
arycod(np, el)
	struct nl *np;
	int *el;
{
	register struct nl *p, *ap;
	int i, d, v, v1;
	int w;

	p = np;
	if (el == NIL) {
		return (0);
	}
	d = p->value[0];
	/*
	 * Check each subscript
	 */
	for (i = 1; i <= d; i++) {
		if (el == NIL) {
			error("Too few subscripts (%d given, %d required)", i-1, d);
			return (-1);
		}
		p = p->chain;
#		ifdef PC
		    precheck( p , "_SUBSC" , "_SUBSCZ" );
#		endif PC
		ap = rvalue(el[1], NLNIL , RREQ );
		if (ap == NIL) {
			return (0);
		}
#		ifdef PC
		    postcheck( p );
#		endif PC
		if (incompat(ap, p->type, el[1])) {
			cerror("Array index type incompatible with declared index type");
			if (d != 1) {
				cerror("Error occurred on index number %d", i);
			}
			return (-1);
		}
		w = aryconst(np, i);
#		ifdef OBJ
		    if (opt('t') == 0) {
			    switch (w) {
			    case 8:
				    w = 6;
			    case 4:
			    case 2:
			    case 1:
				    put2((width(ap) != 4 ? O_INX2P2 : O_INX4P2) | (w & ~1) << 7, ( short ) p->range[0]);
				    el = el[2];
				    continue;
			    }
		    }
		    put(4, width(ap) != 4 ? O_INX2 : O_INX4,w,( short ) p->range[0],
			   ( short ) ( p->range[1] - p->range[0] ) );
#		endif OBJ
#		ifdef PC
			/*
			 *	subtract off the lower bound
			 */
		    if ( p -> range[ 0 ] != 0 ) {
			putleaf( P2ICON , p -> range[0] , 0 , P2INT , 0 );
			putop( P2MINUS , P2INT );
		    }
			/*
			 *	multiply by the width of the elements
			 */
		    if ( w != 1 ) {
			putleaf( P2ICON , w , 0 , P2INT , 0 );
			putop( P2MUL , P2INT );
		    }
			/*
			 *	and add it to the base address
			 */
		    putop( P2PLUS , ADDTYPE( p2type( np -> type ) , P2PTR ) );
#		endif PC
		el = el[2];
	}
	if (el != NIL) {
		do {
			el = el[2];
			i++;
		} while (el != NIL);
		error("Too many subscripts (%d given, %d required)", i-1, d);
		return (-1);
	}
	return (1);
}
Commit	Line	Data
71fbd42d PK	1	/* Copyright (c) 1979 Regents of the University of California */
	2
	3	static char sccsid[] = "@(#)lval.c 1.1 %G%";
	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	# include "pc.h"
	12	# include "pcops.h"
	13	#endif PC
	14
	15	extern int flagwas;
	16	/*
	17	* Lvalue computes the address
	18	* of a qualified name and
	19	* leaves it on the stack.
	20	* for pc, it can be asked for either an lvalue or an rvalue.
	21	* the semantics are the same, only the code is different.
	22	*/
	23	struct nl *
	24	lvalue(r, modflag , required )
	25	int *r, modflag;
	26	int required;
	27	{
	28	register struct nl *p;
	29	struct nl firstp, lastp;
	30	register c, co;
	31	int f, o;
	32	/*
	33	* Note that the local optimizations
	34	* done here for offsets would more
	35	* appropriately be done in put.
	36	*/
	37	int tr[2], trp[3];
	38
	39	if (r == NIL) {
	40	return (NIL);
	41	}
	42	if (nowexp(r)) {
	43	return (NIL);
	44	}
	45	if (r[0] != T_VAR) {
	46	error("Variable required"); /* Pass mesgs down from pt of call ? */
	47	return (NIL);
	48	}
	49	# ifdef PC
	50	/*
	51	* pc requires a whole different control flow
	52	*/
	53	return pclvalue( r , modflag , required );
	54	# endif PC
	55	firstp = p = lookup(r[2]);
	56	if (p == NIL) {
	57	return (NIL);
	58	}
	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	switch (p->class) {
72	case WITHPTR:
73	/*
74	* Construct the tree implied by
75	* the with statement
76	*/
77	trp[0] = T_LISTPP;
78	trp[1] = tr;
79	trp[2] = r[3];
80	tr[0] = T_FIELD;
81	tr[1] = r[2];
82	c = trp;
83	# ifdef PTREE
84	/*
85	* mung r[4] to say which field this T_VAR is
86	* for VarCopy
87	*/
88	r[4] = reclook( p -> type , r[2] );
89	# endif
90	/* and fall through */
91	case REF:
92	/*
93	* Obtain the indirect word
94	* of the WITHPTR or REF
95	* as the base of our lvalue
96	*/
97	put(2, PTR_RV \| bn << 8+INDX , p->value[0] );
98	f = 0; /* have an lv on stack */
99	o = 0;
100	break;
101	case VAR:
102	f = 1; /* no lv on stack yet */
103	o = p->value[0];
104	break;
105	default:
106	error("%s %s found where variable required", classes[p->class], p->symbol);
107	return (NIL);
108	}
109	/*
110	* Loop and handle each
111	* qualification on the name
112	*/
113	if (c == NIL && (modflag&ASGN) && p->value[NL_FORV]) {
114	error("Can't modify the for variable %s in the range of the loop", p->symbol);
115	return (NIL);
116	}
117	for (; c != NIL; c = c[2]) {
118	co = c[1];
119	if (co == NIL) {
120	return (NIL);
121	}
122	lastp = p;
123	p = p->type;
124	if (p == NIL) {
125	return (NIL);
126	}
127	switch (co[0]) {
128	case T_PTR:
129	/*
130	* Pointer qualification.
131	*/
132	lastp->nl_flags \|= NUSED;
133	if (p->class != PTR && p->class != FILET) {
134	error("^ allowed only on files and pointers, not on %ss", nameof(p));
135	goto bad;
136	}
137	if (f) {
138	put(2, PTR_RV \| bn <<8+INDX , o );
139	} else {
140	if (o) {
141	put2(O_OFF, o);
142	}
143	put(1, PTR_IND);
144	}
145	/*
146	* Pointer cannot be
147	* nil and file cannot
148	* be at end-of-file.
149	*/
150	put1(p->class == FILET ? O_FNIL : O_NIL);
151	f = o = 0;
152	continue;
153	case T_ARGL:
154	if (p->class != ARRAY) {
155	if (lastp == firstp) {
156	error("%s is a %s, not a function", r[2], classes[firstp->class]);
157	} else {
158	error("Illegal function qualificiation");
159	}
160	return (NIL);
161	}
162	recovered();
163	error("Pascal uses [] for subscripting, not ()");
164	case T_ARY:
165	if (p->class != ARRAY) {
166	error("Subscripting allowed only on arrays, not on %ss", nameof(p));
167	goto bad;
168	}
169	if (f) {
170	put2(O_LV \| bn<<8+INDX, o);
171	} else {
172	if (o) {
173	put2(O_OFF, o);
174	}
175	}
176	switch (arycod(p, co[1])) {
177	case 0:
178	return (NIL);
179	case -1:
180	goto bad;
181	}
182	f = o = 0;
183	continue;
184	case T_FIELD:
185	/*
186	* Field names are just
187	* an offset with some
188	* semantic checking.
189	*/
190	if (p->class != RECORD) {
191	error(". allowed only on records, not on %ss", nameof(p));
192	goto bad;
193	}
194	if (co[1] == NIL) {
195	return (NIL);
196	}
197	p = reclook(p, co[1]);
198	if (p == NIL) {
199	error("%s is not a field in this record", co[1]);
200	goto bad;
201	}
202	# ifdef PTREE
203	/*
204	* mung co[3] to indicate which field
205	* this is for SelCopy
206	*/
207	co[3] = p;
208	# endif
209	if (modflag & MOD) {
210	p->nl_flags \|= NMOD;
211	}
212	if ((modflag & NOUSE) == 0 \|\| lptr(c[2])) {
213	p->nl_flags \|= NUSED;
214	}
215	o += p->value[0];
216	continue;
217	default:
218	panic("lval2");
219	}
220	}
221	if (f) {
222	put2(O_LV \| bn<<8+INDX, o);
223	} else {
224	if (o) {
225	put2(O_OFF, o);
226	}
227	}
228	return (p->type);
229	bad:
230	cerror("Error occurred on qualification of %s", r[2]);
231	return (NIL);
232	}
233
234	lptr(c)
235	register int *c;
236	{
237	register int *co;
238
239	for (; c != NIL; c = c[2]) {
240	co = c[1];
241	if (co == NIL) {
242	return (NIL);
243	}
244	switch (co[0]) {
245
246	case T_PTR:
247	return (1);
248	case T_ARGL:
249	return (0);
250	case T_ARY:
251	case T_FIELD:
252	continue;
253	default:
254	panic("lptr");
255	}
256	}
257	return (0);
258	}
259
260	/*
261	* Arycod does the
262	* code generation
263	* for subscripting.
264	*/
265	arycod(np, el)
266	struct nl *np;
267	int *el;
268	{
269	register struct nl p, ap;
270	int i, d, v, v1;
271	int w;
272
273	p = np;
274	if (el == NIL) {
275	return (0);
276	}
277	d = p->value[0];
278	/*
279	* Check each subscript
280	*/
281	for (i = 1; i <= d; i++) {
282	if (el == NIL) {
283	error("Too few subscripts (%d given, %d required)", i-1, d);
284	return (-1);
285	}
286	p = p->chain;
287	# ifdef PC
288	precheck( p , "_SUBSC" , "_SUBSCZ" );
289	# endif PC
290	ap = rvalue(el[1], NLNIL , RREQ );
291	if (ap == NIL) {
292	return (0);
293	}
294	# ifdef PC
295	postcheck( p );
296	# endif PC
297	if (incompat(ap, p->type, el[1])) {
298	cerror("Array index type incompatible with declared index type");
299	if (d != 1) {
300	cerror("Error occurred on index number %d", i);
301	}
302	return (-1);
303	}
304	w = aryconst(np, i);
305	# ifdef OBJ
306	if (opt('t') == 0) {
307	switch (w) {
308	case 8:
309	w = 6;
310	case 4:
311	case 2:
312	case 1:
313	put2((width(ap) != 4 ? O_INX2P2 : O_INX4P2) \| (w & ~1) << 7, ( short ) p->range[0]);
314	el = el[2];
315	continue;
316	}
317	}
318	put(4, width(ap) != 4 ? O_INX2 : O_INX4,w,( short ) p->range[0],
319	( short ) ( p->range[1] - p->range[0] ) );
320	# endif OBJ
321	# ifdef PC
322	/*
323	* subtract off the lower bound
324	*/
325	if ( p -> range[ 0 ] != 0 ) {
326	putleaf( P2ICON , p -> range[0] , 0 , P2INT , 0 );
327	putop( P2MINUS , P2INT );
328	}
329	/*
330	* multiply by the width of the elements
331	*/
332	if ( w != 1 ) {
333	putleaf( P2ICON , w , 0 , P2INT , 0 );
334	putop( P2MUL , P2INT );
335	}
336	/*
337	* and add it to the base address
338	*/
339	putop( P2PLUS , ADDTYPE( p2type( np -> type ) , P2PTR ) );
340	# endif PC
341	el = el[2];
342	}
343	if (el != NIL) {
344	do {
345	el = el[2];
346	i++;
347	} while (el != NIL);
348	error("Too many subscripts (%d given, %d required)", i-1, d);
349	return (-1);
350	}
351	return (1);
352	}