xref: /csrg-svn/usr.bin/pascal/src/stkrval.c (revision 10841)
1775Speter /* Copyright (c) 1979 Regents of the University of California */
2775Speter 
3*10841Speter static char sccsid[] = "@(#)stkrval.c 1.7 02/09/83";
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 			/*
703080Smckusic 			 * 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
8310568Smckusick 				return (stackRV(p));
84775Speter #			endif OBJ
85775Speter #			ifdef PC
8610360Smckusick 			    q = rvalue( r , contype , required );
8710360Smckusick 			    if (isa(q, "sbci")) {
8810360Smckusick 				sconv(p2type(q),P2INT);
8910360Smckusick 			    }
9010360Smckusick 			    return q;
91775Speter #			endif PC
92775Speter 
93775Speter 		case WITHPTR:
94775Speter 		case REF:
95775Speter 			/*
96775Speter 			 * A stklval for these
97775Speter 			 * is actually what one
98775Speter 			 * might consider a rvalue.
99775Speter 			 */
100775Speter ind:
101775Speter 			q = stklval(r, NOFLAGS);
102775Speter 			if (q == NIL)
103775Speter 				return (NIL);
104775Speter 			if (classify(q) == TSTR)
105775Speter 				return(q);
106775Speter #			ifdef OBJ
107775Speter 			    w = width(q);
108775Speter 			    switch (w) {
109775Speter 				    case 8:
110775Speter 					    put(1, O_IND8);
111775Speter 					    return(q);
112775Speter 				    case 4:
113775Speter 					    put(1, O_IND4);
114775Speter 					    return(q);
115775Speter 				    case 2:
116775Speter 					    put(1, O_IND24);
117775Speter 					    return(q);
118775Speter 				    case 1:
119775Speter 					    put(1, O_IND14);
120775Speter 					    return(q);
121775Speter 				    default:
122775Speter 					    put(2, O_IND, w);
123775Speter 					    return(q);
124775Speter 			    }
125775Speter #			endif OBJ
126775Speter #			ifdef PC
127775Speter 			    if ( required == RREQ ) {
128775Speter 				putop( P2UNARY P2MUL , p2type( q ) );
12910360Smckusick 				if (isa(q,"sbci")) {
13010360Smckusick 				    sconv(p2type(q),P2INT);
13110360Smckusick 				}
132775Speter 			    }
133775Speter 			    return q;
134775Speter #			endif PC
135775Speter 
136775Speter 		case CONST:
137775Speter 			if (r[3] != NIL) {
138775Speter 				error("%s is a constant and cannot be qualified", r[2]);
139775Speter 				return (NIL);
140775Speter 			}
141775Speter 			q = p->type;
142775Speter 			if (q == NIL)
143775Speter 				return (NIL);
144775Speter 			if (q == nl+TSTR) {
145775Speter 				/*
146775Speter 				 * Find the size of the string
147775Speter 				 * constant if needed.
148775Speter 				 */
149775Speter 				cp = p->ptr[0];
150775Speter cstrng:
151775Speter 				cp1 = cp;
152775Speter 				for (c = 0; *cp++; c++)
153775Speter 					continue;
154*10841Speter 				w = c;
155775Speter 				if (contype != NIL && !opt('s')) {
156775Speter 					if (width(contype) < c && classify(contype) == TSTR) {
157775Speter 						error("Constant string too long");
158775Speter 						return (NIL);
159775Speter 					}
160*10841Speter 					w = width(contype);
161775Speter 				}
162775Speter #				ifdef OBJ
163*10841Speter 				    put(2, O_LVCON, lenstr(cp1, w - c));
164*10841Speter 				    putstr(cp1, w - c);
165775Speter #				endif OBJ
166775Speter #				ifdef PC
167*10841Speter 				    putCONG( cp1 , w , LREQ );
168775Speter #				endif PC
169775Speter 				/*
170775Speter 				 * Define the string temporarily
171775Speter 				 * so later people can know its
172775Speter 				 * width.
173775Speter 				 * cleaned out by stat.
174775Speter 				 */
175*10841Speter 				q = defnl(0, STR, 0, w);
176775Speter 				q->type = q;
177775Speter 				return (q);
178775Speter 			}
179775Speter 			if (q == nl+T1CHAR) {
180775Speter #			    ifdef OBJ
1813080Smckusic 				put(2, O_CONC4, (int)p->value[0]);
182775Speter #			    endif OBJ
183775Speter #			    ifdef PC
18410360Smckusick 				putleaf(P2ICON, p -> value[0], 0, P2INT, 0);
185775Speter #			    endif PC
186775Speter 			    return(q);
187775Speter 			}
188775Speter 			/*
189775Speter 			 * Every other kind of constant here
190775Speter 			 */
191775Speter #			ifdef OBJ
192775Speter 			    switch (width(q)) {
193775Speter 			    case 8:
194775Speter #ifndef DEBUG
195775Speter 				    put(2, O_CON8, p->real);
196775Speter 				    return(q);
197775Speter #else
198775Speter 				    if (hp21mx) {
199775Speter 					    f = p->real;
200775Speter 					    conv(&f);
201775Speter 					    l = f.plong;
202775Speter 					    put(2, O_CON4, l);
203775Speter 				    } else
204775Speter 					    put(2, O_CON8, p->real);
205775Speter 				    return(q);
206775Speter #endif
207775Speter 			    case 4:
208775Speter 				    put(2, O_CON4, p->range[0]);
209775Speter 				    return(q);
210775Speter 			    case 2:
211775Speter 				    put(2, O_CON24, (short)p->range[0]);
212775Speter 				    return(q);
213775Speter 			    case 1:
2143080Smckusic 				    put(2, O_CON14, p->value[0]);
215775Speter 				    return(q);
216775Speter 			    default:
217775Speter 				    panic("stkrval");
218775Speter 			    }
219775Speter #			endif OBJ
220775Speter #			ifdef PC
22110360Smckusick 			    q = rvalue( r , contype , required );
22210360Smckusick 			    if (isa(q,"sbci")) {
22310360Smckusick 				sconv(p2type(q),P2INT);
22410360Smckusick 			    }
22510360Smckusick 			    return q;
226775Speter #			endif PC
227775Speter 
228775Speter 		case FUNC:
2291201Speter 		case FFUNC:
230775Speter 			/*
231775Speter 			 * Function call
232775Speter 			 */
233775Speter 			pt = (int **)r[3];
234775Speter 			if (pt != NIL) {
235775Speter 				switch (pt[1][0]) {
236775Speter 				case T_PTR:
237775Speter 				case T_ARGL:
238775Speter 				case T_ARY:
239775Speter 				case T_FIELD:
240775Speter 					error("Can't qualify a function result value");
241775Speter 					return (NIL);
242775Speter 				}
243775Speter 			}
244775Speter #			ifdef OBJ
245775Speter 			    q = p->type;
246775Speter 			    if (classify(q) == TSTR) {
247775Speter 				    c = width(q);
248775Speter 				    put(2, O_LVCON, even(c+1));
249775Speter 				    putstr("", c);
2503080Smckusic 				    put(1, PTR_DUP);
251775Speter 				    p = funccod(r);
252775Speter 				    put(2, O_AS, c);
253775Speter 				    return(p);
254775Speter 			    }
255775Speter 			    p = funccod(r);
256775Speter 			    if (width(p) <= 2)
257775Speter 				    put(1, O_STOI);
258775Speter #			endif OBJ
259775Speter #			ifdef PC
260775Speter 			    p = pcfunccod( r );
26110360Smckusick 			    if (isa(p,"sbci")) {
26210360Smckusick 				sconv(p2type(p),P2INT);
26310360Smckusick 			    }
264775Speter #			endif PC
265775Speter 			return (p);
266775Speter 
267775Speter 		case TYPE:
268775Speter 			error("Type names (e.g. %s) allowed only in declarations", p->symbol);
269775Speter 			return (NIL);
270775Speter 
271775Speter 		case PROC:
2721201Speter 		case FPROC:
273775Speter 			error("Procedure %s found where expression required", p->symbol);
274775Speter 			return (NIL);
275775Speter 		default:
276775Speter 			panic("stkrvid");
277775Speter 		}
278775Speter 	case T_PLUS:
279775Speter 	case T_MINUS:
280775Speter 	case T_NOT:
281775Speter 	case T_AND:
282775Speter 	case T_OR:
283775Speter 	case T_DIVD:
284775Speter 	case T_MULT:
285775Speter 	case T_SUB:
286775Speter 	case T_ADD:
287775Speter 	case T_MOD:
288775Speter 	case T_DIV:
289775Speter 	case T_EQ:
290775Speter 	case T_NE:
291775Speter 	case T_GE:
292775Speter 	case T_LE:
293775Speter 	case T_GT:
294775Speter 	case T_LT:
295775Speter 	case T_IN:
296775Speter 		p = rvalue(r, contype , required );
297775Speter #		ifdef OBJ
298775Speter 		    if (width(p) <= 2)
299775Speter 			    put(1, O_STOI);
300775Speter #		endif OBJ
30110360Smckusick #		ifdef PC
30210360Smckusick 		    if (isa(p,"sbci")) {
30310360Smckusick 			sconv(p2type(p),P2INT);
30410360Smckusick 		    }
30510360Smckusick #		endif PC
306775Speter 		return (p);
307909Speter 	case T_CSET:
308909Speter 		p = rvalue(r, contype , required );
309909Speter 		return (p);
310775Speter 	default:
311775Speter 		if (r[2] == NIL)
312775Speter 			return (NIL);
313775Speter 		switch (r[0]) {
314775Speter 		default:
315775Speter 			panic("stkrval3");
316775Speter 
317775Speter 		/*
318775Speter 		 * An octal number
319775Speter 		 */
320775Speter 		case T_BINT:
321775Speter 			f = a8tol(r[2]);
322775Speter 			goto conint;
323775Speter 
324775Speter 		/*
325775Speter 		 * A decimal number
326775Speter 		 */
327775Speter 		case T_INT:
328775Speter 			f = atof(r[2]);
329775Speter conint:
330775Speter 			if (f > MAXINT || f < MININT) {
331775Speter 				error("Constant too large for this implementation");
332775Speter 				return (NIL);
333775Speter 			}
334775Speter 			l = f;
335775Speter 			if (bytes(l, l) <= 2) {
336775Speter #			    ifdef OBJ
337775Speter 				put(2, O_CON24, (short)l);
338775Speter #			    endif OBJ
339775Speter #			    ifdef PC
340775Speter 				putleaf( P2ICON , (short) l , 0 , P2INT , 0 );
341775Speter #			    endif PC
342775Speter 				return(nl+T4INT);
343775Speter 			}
344775Speter #			ifdef OBJ
345775Speter 			    put(2, O_CON4, l);
346775Speter #			endif OBJ
347775Speter #			ifdef PC
348775Speter 			    putleaf( P2ICON , l , 0 , P2INT , 0 );
349775Speter #			endif PC
350775Speter 			return (nl+T4INT);
351775Speter 
352775Speter 		/*
353775Speter 		 * A floating point number
354775Speter 		 */
355775Speter 		case T_FINT:
356775Speter #		   	ifdef OBJ
357775Speter 			    put(2, O_CON8, atof(r[2]));
358775Speter #			endif OBJ
359775Speter #			ifdef PC
360775Speter 			    putCON8( atof( r[2] ) );
361775Speter #			endif PC
362775Speter 			return (nl+TDOUBLE);
363775Speter 
364775Speter 		/*
365775Speter 		 * Constant strings.  Note that constant characters
366775Speter 		 * are constant strings of length one; there is
367775Speter 		 * no constant string of length one.
368775Speter 		 */
369775Speter 		case T_STRNG:
370775Speter 			cp = r[2];
371775Speter 			if (cp[1] == 0) {
372775Speter #				ifdef OBJ
373775Speter 				    put(2, O_CONC4, cp[0]);
374775Speter #				endif OBJ
375775Speter #				ifdef PC
37610360Smckusick 				    putleaf( P2ICON , cp[0] , 0 , P2INT , 0 );
377775Speter #				endif PC
378775Speter 				return(nl+T1CHAR);
379775Speter 			}
380775Speter 			goto cstrng;
381775Speter 		}
382775Speter 
383775Speter 	}
384775Speter }
38510568Smckusick 
38610568Smckusick #ifdef OBJ
38710568Smckusick /*
38810568Smckusick  * push a value onto the interpreter stack, longword aligned.
38910568Smckusick  */
39010568Smckusick stackRV(p)
39110568Smckusick 	struct nl *p;
39210568Smckusick {
39310568Smckusick 	struct nl *q;
39410568Smckusick 	int w, bn;
39510568Smckusick 
39610568Smckusick 	q = p->type;
39710568Smckusick 	if (q == NIL)
39810568Smckusick 		return (NIL);
39910568Smckusick 	bn = BLOCKNO(p->nl_block);
40010568Smckusick 	w = width(q);
40110568Smckusick 	switch (w) {
40210568Smckusick 	case 8:
40310568Smckusick 		put(2, O_RV8 | bn << 8+INDX, (int)p->value[0]);
40410568Smckusick 		break;
40510568Smckusick 	case 4:
40610568Smckusick 		put(2, O_RV4 | bn << 8+INDX, (int)p->value[0]);
40710568Smckusick 		break;
40810568Smckusick 	case 2:
40910568Smckusick 		put(2, O_RV24 | bn << 8+INDX, (int)p->value[0]);
41010568Smckusick 		break;
41110568Smckusick 	case 1:
41210568Smckusick 		put(2, O_RV14 | bn << 8+INDX, (int)p->value[0]);
41310568Smckusick 		break;
41410568Smckusick 	default:
41510568Smckusick 		put(3, O_RV | bn << 8+INDX, (int)p->value[0], w);
41610568Smckusick 		break;
41710568Smckusick 	}
41810568Smckusick 	return (q);
41910568Smckusick }
42010568Smckusick #endif OBJ
421