[unix-history] / usr / src / cmd / pi / lval.c

/* Copyright (c) 1979 Regents of the University of California */
#
/*
 * pi - Pascal interpreter code translator
 *
 * Charles Haley, Bill Joy UCB
 * Version 1.2 November 1978
 */

#include "whoami"
#include "0.h"
#include "tree.h"
#include "opcode.h"

extern	int flagwas;
/*
 * Lvalue computes the address
 * of a qualified name and
 * leaves it on the stack.
 */
struct nl *
lvalue(r, modflag)
	int *r, modflag;
{
	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);
	}
	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
			 */
#			ifdef VAX
			    put2 ( O_RV4 | bn << 9 , p->value[0] );
#			endif
#			ifdef PDP11
			    put2(O_RV2 | bn << 9, p->value[0]);
#			endif
			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)
#					ifdef VAX
					    put2 ( O_RV4 | bn << 9 , o );
#					endif
#					ifdef PDP11
					    put2(O_RV2 | bn<<9, o);
#					endif
				else {
					if (o)
						put2(O_OFF, o);
#					ifdef VAX
					    put1 ( O_IND4 );
#					endif
#					ifdef PDP11
					    put1(O_IND2);
#					endif
				}
				/*
				 * 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<<9, 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<<9, 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;
		ap = rvalue(el[1], NLNIL);
		if (ap == NIL)
			return (0);
		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);
		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] ) );
		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
5c0fc6b7 CH	1	/* Copyright (c) 1979 Regents of the University of California */
	2	#
	3	/*
	4	* pi - Pascal interpreter code translator
	5	*
	6	* Charles Haley, Bill Joy UCB
	7	* Version 1.2 November 1978
	8	*/
	9
	10	#include "whoami"
	11	#include "0.h"
	12	#include "tree.h"
	13	#include "opcode.h"
	14
	15	extern int flagwas;
	16	/*
	17	* Lvalue computes the address
	18	* of a qualified name and
	19	* leaves it on the stack.
	20	*/
	21	struct nl *
	22	lvalue(r, modflag)
	23	int *r, modflag;
	24	{
	25	register struct nl *p;
	26	struct nl firstp, lastp;
	27	register c, co;
	28	int f, o;
	29	/*
	30	* Note that the local optimizations
	31	* done here for offsets would more
	32	* appropriately be done in put.
	33	*/
	34	int tr[2], trp[3];
	35
	36	if (r == NIL)
	37	return (NIL);
	38	if (nowexp(r))
	39	return (NIL);
	40	if (r[0] != T_VAR) {
	41	error("Variable required"); /* Pass mesgs down from pt of call ? */
	42	return (NIL);
	43	}
	44	firstp = p = lookup(r[2]);
	45	if (p == NIL)
	46	return (NIL);
	47	c = r[3];
	48	if ((modflag & NOUSE) && !lptr(c))
	49	p->nl_flags = flagwas;
	50	if (modflag & MOD)
	51	p->nl_flags \|= NMOD;
	52	/*
	53	* Only possibilities for p->class here
	54	* are the named classes, i.e. CONST, TYPE
	55	* VAR, PROC, FUNC, REF, or a WITHPTR.
	56	*/
	57	switch (p->class) {
	58	case WITHPTR:
	59	/*
	60	* Construct the tree implied by
	61	* the with statement
	62	*/
	63	trp[0] = T_LISTPP;
	64	trp[1] = tr;
65	trp[2] = r[3];
66	tr[0] = T_FIELD;
67	tr[1] = r[2];
68	c = trp;
69	# ifdef PTREE
70	/*
71	* mung r[4] to say which field this T_VAR is
72	* for VarCopy
73	*/
74	r[4] = reclook( p -> type , r[2] );
75	# endif
76	/* and fall through */
77	case REF:
78	/*
79	* Obtain the indirect word
80	* of the WITHPTR or REF
81	* as the base of our lvalue
82	*/
83	# ifdef VAX
84	put2 ( O_RV4 \| bn << 9 , p->value[0] );
85	# endif
86	# ifdef PDP11
87	put2(O_RV2 \| bn << 9, p->value[0]);
88	# endif
89	f = 0; /* have an lv on stack */
90	o = 0;
91	break;
92	case VAR:
93	f = 1; /* no lv on stack yet */
94	o = p->value[0];
95	break;
96	default:
97	error("%s %s found where variable required", classes[p->class], p->symbol);
98	return (NIL);
99	}
100	/*
101	* Loop and handle each
102	* qualification on the name
103	*/
104	if (c == NIL && (modflag&ASGN) && p->value[NL_FORV]) {
105	error("Can't modify the for variable %s in the range of the loop", p->symbol);
106	return (NIL);
107	}
108	for (; c != NIL; c = c[2]) {
109	co = c[1];
110	if (co == NIL)
111	return (NIL);
112	lastp = p;
113	p = p->type;
114	if (p == NIL)
115	return (NIL);
116	switch (co[0]) {
117	case T_PTR:
118	/*
119	* Pointer qualification.
120	*/
121	lastp->nl_flags \|= NUSED;
122	if (p->class != PTR && p->class != FILET) {
123	error("^ allowed only on files and pointers, not on %ss", nameof(p));
124	goto bad;
125	}
126	if (f)
127	# ifdef VAX
128	put2 ( O_RV4 \| bn << 9 , o );
129	# endif
130	# ifdef PDP11
131	put2(O_RV2 \| bn<<9, o);
132	# endif
133	else {
134	if (o)
135	put2(O_OFF, o);
136	# ifdef VAX
137	put1 ( O_IND4 );
138	# endif
139	# ifdef PDP11
140	put1(O_IND2);
141	# endif
142	}
143	/*
144	* Pointer cannot be
145	* nil and file cannot
146	* be at end-of-file.
147	*/
148	put1(p->class == FILET ? O_FNIL : O_NIL);
149	f = o = 0;
150	continue;
151	case T_ARGL:
152	if (p->class != ARRAY) {
153	if (lastp == firstp)
154	error("%s is a %s, not a function", r[2], classes[firstp->class]);
155	else
156	error("Illegal function qualificiation");
157	return (NIL);
158	}
159	recovered();
160	error("Pascal uses [] for subscripting, not ()");
161	case T_ARY:
162	if (p->class != ARRAY) {
163	error("Subscripting allowed only on arrays, not on %ss", nameof(p));
164	goto bad;
165	}
166	if (f)
167	put2(O_LV \| bn<<9, o);
168	else if (o)
169	put2(O_OFF, o);
170	switch (arycod(p, co[1])) {
171	case 0:
172	return (NIL);
173	case -1:
174	goto bad;
175	}
176	f = o = 0;
177	continue;
178	case T_FIELD:
179	/*
180	* Field names are just
181	* an offset with some
182	* semantic checking.
183	*/
184	if (p->class != RECORD) {
185	error(". allowed only on records, not on %ss", nameof(p));
186	goto bad;
187	}
188	if (co[1] == NIL)
189	return (NIL);
190	p = reclook(p, co[1]);
191	if (p == NIL) {
192	error("%s is not a field in this record", co[1]);
193	goto bad;
194	}
195	# ifdef PTREE
196	/*
197	* mung co[3] to indicate which field
198	* this is for SelCopy
199	*/
200	co[3] = p;
201	# endif
202	if (modflag & MOD)
203	p->nl_flags \|= NMOD;
204	if ((modflag & NOUSE) == 0 \|\| lptr(c[2]))
205	p->nl_flags \|= NUSED;
206	o += p->value[0];
207	continue;
208	default:
209	panic("lval2");
210	}
211	}
212	if (f)
213	put2(O_LV \| bn<<9, o);
214	else if (o)
215	put2(O_OFF, o);
216	return (p->type);
217	bad:
218	cerror("Error occurred on qualification of %s", r[2]);
219	return (NIL);
220	}
221
222	lptr(c)
223	register int *c;
224	{
225	register int *co;
226
227	for (; c != NIL; c = c[2]) {
228	co = c[1];
229	if (co == NIL)
230	return (NIL);
231	switch (co[0]) {
232
233	case T_PTR:
234	return (1);
235	case T_ARGL:
236	return (0);
237	case T_ARY:
238	case T_FIELD:
239	continue;
240	default:
241	panic("lptr");
242	}
243	}
244	return (0);
245	}
246
247	/*
248	* Arycod does the
249	* code generation
250	* for subscripting.
251	*/
252	arycod(np, el)
253	struct nl *np;
254	int *el;
255	{
256	register struct nl p, ap;
257	int i, d, v, v1;
258	int w;
259
260	p = np;
261	if (el == NIL)
262	return (0);
263	d = p->value[0];
264	/*
265	* Check each subscript
266	*/
267	for (i = 1; i <= d; i++) {
268	if (el == NIL) {
269	error("Too few subscripts (%d given, %d required)", i-1, d);
270	return (-1);
271	}
272	p = p->chain;
273	ap = rvalue(el[1], NLNIL);
274	if (ap == NIL)
275	return (0);
276	if (incompat(ap, p->type, el[1])) {
277	cerror("Array index type incompatible with declared index type");
278	if (d != 1)
279	cerror("Error occurred on index number %d", i);
280	return (-1);
281	}
282	w = aryconst(np, i);
283	if (opt('t') == 0)
284	switch (w) {
285	case 8:
286	w = 6;
287	case 4:
288	case 2:
289	case 1:
290	put2((width(ap) != 4 ? O_INX2P2 : O_INX4P2) \| (w & ~1) << 7, ( short ) p->range[0]);
291	el = el[2];
292	continue;
293	}
294	put(4, width(ap) != 4 ? O_INX2 : O_INX4,w,( short ) p->range[0],
295	( short ) ( p->range[1] - p->range[0] ) );
296	el = el[2];
297	}
298	if (el != NIL) {
299	do {
300	el = el[2];
301	i++;
302	} while (el != NIL);
303	error("Too many subscripts (%d given, %d required)", i-1, d);
304	return (-1);
305	}
306	return (1);
307	}