xref: /csrg-svn/usr.bin/pascal/src/stkrval.c (revision 1201)
1775Speter /* Copyright (c) 1979 Regents of the University of California */
2775Speter 
3*1201Speter static	char sccsid[] = "@(#)stkrval.c 1.3 10/03/80";
4775Speter 
5775Speter #include "whoami.h"
6775Speter #include "0.h"
7775Speter #include "tree.h"
8775Speter #include "opcode.h"
9775Speter #include "objfmt.h"
10775Speter #ifdef PC
11775Speter #   include "pcops.h"
12775Speter #endif PC
13775Speter 
14775Speter /*
15775Speter  * stkrval Rvalue - an expression, and coerce it to be a stack quantity.
16775Speter  *
17775Speter  * Contype is the type that the caller would prefer, nand is important
18775Speter  * if constant sets or constant strings are involved, the latter
19775Speter  * because of string padding.
20775Speter  */
21775Speter /*
22775Speter  * for the obj version, this is a copy of rvalue hacked to use fancy new
23775Speter  * push-onto-stack-and-convert opcodes.
24775Speter  * for the pc version, i just call rvalue and convert if i have to,
25775Speter  * based on the return type of rvalue.
26775Speter  */
27775Speter struct nl *
28775Speter stkrval(r, contype , required )
29775Speter 	register int *r;
30775Speter 	struct nl *contype;
31775Speter 	long	required;
32775Speter {
33775Speter 	register struct nl *p;
34775Speter 	register struct nl *q;
35775Speter 	register char *cp, *cp1;
36775Speter 	register int c, w;
37775Speter 	int **pt;
38775Speter 	long l;
39775Speter 	double f;
40775Speter 
41775Speter 	if (r == NIL)
42775Speter 		return (NIL);
43775Speter 	if (nowexp(r))
44775Speter 		return (NIL);
45775Speter 	/*
46775Speter 	 * The root of the tree tells us what sort of expression we have.
47775Speter 	 */
48775Speter 	switch (r[0]) {
49775Speter 
50775Speter 	/*
51775Speter 	 * The constant nil
52775Speter 	 */
53775Speter 	case T_NIL:
54775Speter #		ifdef OBJ
55775Speter 		    put(2, O_CON14, 0);
56775Speter #		endif OBJ
57775Speter #		ifdef PC
58775Speter 		    putleaf( P2ICON , 0 , 0 , P2INT , 0 );
59775Speter #		endif PC
60775Speter 		return (nl+TNIL);
61775Speter 
62775Speter 	case T_FCALL:
63775Speter 	case T_VAR:
64775Speter 		p = lookup(r[2]);
65775Speter 		if (p == NIL || p->class == BADUSE)
66775Speter 			return (NIL);
67775Speter 		switch (p->class) {
68775Speter 		case VAR:
69775Speter 			/*
70775Speter 			  if a variable is
71775Speter 			 * qualified then get
72775Speter 			 * the rvalue by a
73775Speter 			 * stklval and an ind.
74775Speter 			 */
75775Speter 			if (r[3] != NIL)
76775Speter 				goto ind;
77775Speter 			q = p->type;
78775Speter 			if (q == NIL)
79775Speter 				return (NIL);
80775Speter 			if (classify(q) == TSTR)
81775Speter 				return(stklval(r, NOFLAGS));
82775Speter #			ifdef OBJ
83775Speter 			    w = width(q);
84775Speter 			    switch (w) {
85775Speter 			    case 8:
86775Speter 				    put(2, O_RV8 | bn << 8+INDX, p->value[0]);
87775Speter 				    return(q);
88775Speter 			    case 4:
89775Speter 				    put(2, O_RV4 | bn << 8+INDX, p->value[0]);
90775Speter 				    return(q);
91775Speter 			    case 2:
92775Speter 				    put(2, O_RV24 | bn << 8+INDX, p->value[0]);
93775Speter 				    return(q);
94775Speter 			    case 1:
95775Speter 				    put(2, O_RV14 | bn << 8+INDX, p->value[0]);
96775Speter 				    return(q);
97775Speter 			    default:
98775Speter 				    put(3, O_RV | bn << 8+INDX, p->value[0], w);
99775Speter 				    return(q);
100775Speter 			     }
101775Speter #			endif OBJ
102775Speter #			ifdef PC
103775Speter 			     return rvalue( r , contype , required );
104775Speter #			endif PC
105775Speter 
106775Speter 		case WITHPTR:
107775Speter 		case REF:
108775Speter 			/*
109775Speter 			 * A stklval for these
110775Speter 			 * is actually what one
111775Speter 			 * might consider a rvalue.
112775Speter 			 */
113775Speter ind:
114775Speter 			q = stklval(r, NOFLAGS);
115775Speter 			if (q == NIL)
116775Speter 				return (NIL);
117775Speter 			if (classify(q) == TSTR)
118775Speter 				return(q);
119775Speter #			ifdef OBJ
120775Speter 			    w = width(q);
121775Speter 			    switch (w) {
122775Speter 				    case 8:
123775Speter 					    put(1, O_IND8);
124775Speter 					    return(q);
125775Speter 				    case 4:
126775Speter 					    put(1, O_IND4);
127775Speter 					    return(q);
128775Speter 				    case 2:
129775Speter 					    put(1, O_IND24);
130775Speter 					    return(q);
131775Speter 				    case 1:
132775Speter 					    put(1, O_IND14);
133775Speter 					    return(q);
134775Speter 				    default:
135775Speter 					    put(2, O_IND, w);
136775Speter 					    return(q);
137775Speter 			    }
138775Speter #			endif OBJ
139775Speter #			ifdef PC
140775Speter 			    if ( required == RREQ ) {
141775Speter 				putop( P2UNARY P2MUL , p2type( q ) );
142775Speter 			    }
143775Speter 			    return q;
144775Speter #			endif PC
145775Speter 
146775Speter 		case CONST:
147775Speter 			if (r[3] != NIL) {
148775Speter 				error("%s is a constant and cannot be qualified", r[2]);
149775Speter 				return (NIL);
150775Speter 			}
151775Speter 			q = p->type;
152775Speter 			if (q == NIL)
153775Speter 				return (NIL);
154775Speter 			if (q == nl+TSTR) {
155775Speter 				/*
156775Speter 				 * Find the size of the string
157775Speter 				 * constant if needed.
158775Speter 				 */
159775Speter 				cp = p->ptr[0];
160775Speter cstrng:
161775Speter 				cp1 = cp;
162775Speter 				for (c = 0; *cp++; c++)
163775Speter 					continue;
164775Speter 				w = 0;
165775Speter 				if (contype != NIL && !opt('s')) {
166775Speter 					if (width(contype) < c && classify(contype) == TSTR) {
167775Speter 						error("Constant string too long");
168775Speter 						return (NIL);
169775Speter 					}
170775Speter 					w = width(contype) - c;
171775Speter 				}
172775Speter #				ifdef OBJ
173775Speter 				    put(2, O_LVCON, lenstr(cp1, w));
174775Speter 				    putstr(cp1, w);
175775Speter #				endif OBJ
176775Speter #				ifdef PC
177775Speter 				    putCONG( cp1 , c + w , LREQ );
178775Speter #				endif PC
179775Speter 				/*
180775Speter 				 * Define the string temporarily
181775Speter 				 * so later people can know its
182775Speter 				 * width.
183775Speter 				 * cleaned out by stat.
184775Speter 				 */
185775Speter 				q = defnl(0, STR, 0, c);
186775Speter 				q->type = q;
187775Speter 				return (q);
188775Speter 			}
189775Speter 			if (q == nl+T1CHAR) {
190775Speter #			    ifdef OBJ
191775Speter 				put(2, O_CONC4, p->value[0]);
192775Speter #			    endif OBJ
193775Speter #			    ifdef PC
194775Speter 				putleaf( P2ICON , p -> value[0] , 0 , P2CHAR , 0 );
195775Speter #			    endif PC
196775Speter 			    return(q);
197775Speter 			}
198775Speter 			/*
199775Speter 			 * Every other kind of constant here
200775Speter 			 */
201775Speter #			ifdef OBJ
202775Speter 			    switch (width(q)) {
203775Speter 			    case 8:
204775Speter #ifndef DEBUG
205775Speter 				    put(2, O_CON8, p->real);
206775Speter 				    return(q);
207775Speter #else
208775Speter 				    if (hp21mx) {
209775Speter 					    f = p->real;
210775Speter 					    conv(&f);
211775Speter 					    l = f.plong;
212775Speter 					    put(2, O_CON4, l);
213775Speter 				    } else
214775Speter 					    put(2, O_CON8, p->real);
215775Speter 				    return(q);
216775Speter #endif
217775Speter 			    case 4:
218775Speter 				    put(2, O_CON4, p->range[0]);
219775Speter 				    return(q);
220775Speter 			    case 2:
221775Speter 				    put(2, O_CON24, (short)p->range[0]);
222775Speter 				    return(q);
223775Speter 			    case 1:
224775Speter 				    put(2, O_CON14, (short)p->range[0]);
225775Speter 				    return(q);
226775Speter 			    default:
227775Speter 				    panic("stkrval");
228775Speter 			    }
229775Speter #			endif OBJ
230775Speter #			ifdef PC
231775Speter 			    return rvalue( r , contype , required );
232775Speter #			endif PC
233775Speter 
234775Speter 		case FUNC:
235*1201Speter 		case FFUNC:
236775Speter 			/*
237775Speter 			 * Function call
238775Speter 			 */
239775Speter 			pt = (int **)r[3];
240775Speter 			if (pt != NIL) {
241775Speter 				switch (pt[1][0]) {
242775Speter 				case T_PTR:
243775Speter 				case T_ARGL:
244775Speter 				case T_ARY:
245775Speter 				case T_FIELD:
246775Speter 					error("Can't qualify a function result value");
247775Speter 					return (NIL);
248775Speter 				}
249775Speter 			}
250775Speter #			ifdef OBJ
251775Speter 			    q = p->type;
252775Speter 			    if (classify(q) == TSTR) {
253775Speter 				    c = width(q);
254775Speter 				    put(2, O_LVCON, even(c+1));
255775Speter 				    putstr("", c);
256775Speter 				    put(1, O_SDUP4);
257775Speter 				    p = funccod(r);
258775Speter 				    put(2, O_AS, c);
259775Speter 				    return(p);
260775Speter 			    }
261775Speter 			    p = funccod(r);
262775Speter 			    if (width(p) <= 2)
263775Speter 				    put(1, O_STOI);
264775Speter #			endif OBJ
265775Speter #			ifdef PC
266775Speter 			    p = pcfunccod( r );
267775Speter #			endif PC
268775Speter 			return (p);
269775Speter 
270775Speter 		case TYPE:
271775Speter 			error("Type names (e.g. %s) allowed only in declarations", p->symbol);
272775Speter 			return (NIL);
273775Speter 
274775Speter 		case PROC:
275*1201Speter 		case FPROC:
276775Speter 			error("Procedure %s found where expression required", p->symbol);
277775Speter 			return (NIL);
278775Speter 		default:
279775Speter 			panic("stkrvid");
280775Speter 		}
281775Speter 	case T_PLUS:
282775Speter 	case T_MINUS:
283775Speter 	case T_NOT:
284775Speter 	case T_AND:
285775Speter 	case T_OR:
286775Speter 	case T_DIVD:
287775Speter 	case T_MULT:
288775Speter 	case T_SUB:
289775Speter 	case T_ADD:
290775Speter 	case T_MOD:
291775Speter 	case T_DIV:
292775Speter 	case T_EQ:
293775Speter 	case T_NE:
294775Speter 	case T_GE:
295775Speter 	case T_LE:
296775Speter 	case T_GT:
297775Speter 	case T_LT:
298775Speter 	case T_IN:
299775Speter 		p = rvalue(r, contype , required );
300775Speter #		ifdef OBJ
301775Speter 		    if (width(p) <= 2)
302775Speter 			    put(1, O_STOI);
303775Speter #		endif OBJ
304775Speter 		return (p);
305909Speter 	case T_CSET:
306909Speter 		p = rvalue(r, contype , required );
307909Speter 		return (p);
308775Speter 	default:
309775Speter 		if (r[2] == NIL)
310775Speter 			return (NIL);
311775Speter 		switch (r[0]) {
312775Speter 		default:
313775Speter 			panic("stkrval3");
314775Speter 
315775Speter 		/*
316775Speter 		 * An octal number
317775Speter 		 */
318775Speter 		case T_BINT:
319775Speter 			f = a8tol(r[2]);
320775Speter 			goto conint;
321775Speter 
322775Speter 		/*
323775Speter 		 * A decimal number
324775Speter 		 */
325775Speter 		case T_INT:
326775Speter 			f = atof(r[2]);
327775Speter conint:
328775Speter 			if (f > MAXINT || f < MININT) {
329775Speter 				error("Constant too large for this implementation");
330775Speter 				return (NIL);
331775Speter 			}
332775Speter 			l = f;
333775Speter 			if (bytes(l, l) <= 2) {
334775Speter #			    ifdef OBJ
335775Speter 				put(2, O_CON24, (short)l);
336775Speter #			    endif OBJ
337775Speter #			    ifdef PC
338775Speter 				putleaf( P2ICON , (short) l , 0 , P2INT , 0 );
339775Speter #			    endif PC
340775Speter 				return(nl+T4INT);
341775Speter 			}
342775Speter #			ifdef OBJ
343775Speter 			    put(2, O_CON4, l);
344775Speter #			endif OBJ
345775Speter #			ifdef PC
346775Speter 			    putleaf( P2ICON , l , 0 , P2INT , 0 );
347775Speter #			endif PC
348775Speter 			return (nl+T4INT);
349775Speter 
350775Speter 		/*
351775Speter 		 * A floating point number
352775Speter 		 */
353775Speter 		case T_FINT:
354775Speter #		   	ifdef OBJ
355775Speter 			    put(2, O_CON8, atof(r[2]));
356775Speter #			endif OBJ
357775Speter #			ifdef PC
358775Speter 			    putCON8( atof( r[2] ) );
359775Speter #			endif PC
360775Speter 			return (nl+TDOUBLE);
361775Speter 
362775Speter 		/*
363775Speter 		 * Constant strings.  Note that constant characters
364775Speter 		 * are constant strings of length one; there is
365775Speter 		 * no constant string of length one.
366775Speter 		 */
367775Speter 		case T_STRNG:
368775Speter 			cp = r[2];
369775Speter 			if (cp[1] == 0) {
370775Speter #				ifdef OBJ
371775Speter 				    put(2, O_CONC4, cp[0]);
372775Speter #				endif OBJ
373775Speter #				ifdef PC
374775Speter 				    putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 );
375775Speter #				endif PC
376775Speter 				return(nl+T1CHAR);
377775Speter 			}
378775Speter 			goto cstrng;
379775Speter 		}
380775Speter 
381775Speter 	}
382775Speter }
383