xref: /csrg-svn/usr.bin/pascal/src/stkrval.c (revision 22194)
1*22194Sdist /*
2*22194Sdist  * Copyright (c) 1980 Regents of the University of California.
3*22194Sdist  * All rights reserved.  The Berkeley software License Agreement
4*22194Sdist  * specifies the terms and conditions for redistribution.
5*22194Sdist  */
6775Speter 
714743Sthien #ifndef lint
8*22194Sdist static char sccsid[] = "@(#)stkrval.c	5.1 (Berkeley) 06/05/85";
9*22194Sdist #endif not lint
10775Speter 
11775Speter #include "whoami.h"
12775Speter #include "0.h"
13775Speter #include "tree.h"
14775Speter #include "opcode.h"
15775Speter #include "objfmt.h"
16775Speter #ifdef PC
1718471Sralph #   include <pcc.h>
18775Speter #endif PC
1914743Sthien #include "tree_ty.h"
20775Speter 
21775Speter /*
22775Speter  * stkrval Rvalue - an expression, and coerce it to be a stack quantity.
23775Speter  *
24775Speter  * Contype is the type that the caller would prefer, nand is important
25775Speter  * if constant sets or constant strings are involved, the latter
26775Speter  * because of string padding.
27775Speter  */
28775Speter /*
29775Speter  * for the obj version, this is a copy of rvalue hacked to use fancy new
30775Speter  * push-onto-stack-and-convert opcodes.
31775Speter  * for the pc version, i just call rvalue and convert if i have to,
32775Speter  * based on the return type of rvalue.
33775Speter  */
34775Speter struct nl *
35775Speter stkrval(r, contype , required )
3614743Sthien 	register struct tnode *r;
37775Speter 	struct nl *contype;
38775Speter 	long	required;
39775Speter {
40775Speter 	register struct nl *p;
41775Speter 	register struct nl *q;
42775Speter 	register char *cp, *cp1;
43775Speter 	register int c, w;
4414743Sthien 	struct tnode *pt;
45775Speter 	long l;
4614743Sthien 	union
4714743Sthien 	{
4814743Sthien 		double pdouble;
4914743Sthien 		long   plong[2];
5014743Sthien 	}f;
51775Speter 
5214743Sthien 	if (r == TR_NIL)
5314743Sthien 		return (NLNIL);
54775Speter 	if (nowexp(r))
5514743Sthien 		return (NLNIL);
56775Speter 	/*
57775Speter 	 * The root of the tree tells us what sort of expression we have.
58775Speter 	 */
5914743Sthien 	switch (r->tag) {
60775Speter 
61775Speter 	/*
62775Speter 	 * The constant nil
63775Speter 	 */
64775Speter 	case T_NIL:
65775Speter #		ifdef OBJ
6614743Sthien 		    (void) put(2, O_CON14, 0);
67775Speter #		endif OBJ
68775Speter #		ifdef PC
6918471Sralph 		    putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
70775Speter #		endif PC
71775Speter 		return (nl+TNIL);
72775Speter 
73775Speter 	case T_FCALL:
74775Speter 	case T_VAR:
7514743Sthien 		p = lookup(r->var_node.cptr);
7614743Sthien 		if (p == NLNIL || p->class == BADUSE)
7714743Sthien 			return (NLNIL);
78775Speter 		switch (p->class) {
79775Speter 		case VAR:
80775Speter 			/*
813080Smckusic 			 * if a variable is
82775Speter 			 * qualified then get
83775Speter 			 * the rvalue by a
84775Speter 			 * stklval and an ind.
85775Speter 			 */
8614743Sthien 			if (r->var_node.qual != TR_NIL)
87775Speter 				goto ind;
88775Speter 			q = p->type;
8914743Sthien 			if (q == NLNIL)
9014743Sthien 				return (NLNIL);
91775Speter 			if (classify(q) == TSTR)
92775Speter 				return(stklval(r, NOFLAGS));
93775Speter #			ifdef OBJ
9410568Smckusick 				return (stackRV(p));
95775Speter #			endif OBJ
96775Speter #			ifdef PC
9714743Sthien 			    q = rvalue( r , contype , (int) required );
9810360Smckusick 			    if (isa(q, "sbci")) {
9918471Sralph 				sconv(p2type(q),PCCT_INT);
10010360Smckusick 			    }
10110360Smckusick 			    return q;
102775Speter #			endif PC
103775Speter 
104775Speter 		case WITHPTR:
105775Speter 		case REF:
106775Speter 			/*
107775Speter 			 * A stklval for these
108775Speter 			 * is actually what one
109775Speter 			 * might consider a rvalue.
110775Speter 			 */
111775Speter ind:
112775Speter 			q = stklval(r, NOFLAGS);
11314743Sthien 			if (q == NLNIL)
11414743Sthien 				return (NLNIL);
115775Speter 			if (classify(q) == TSTR)
116775Speter 				return(q);
117775Speter #			ifdef OBJ
118775Speter 			    w = width(q);
119775Speter 			    switch (w) {
120775Speter 				    case 8:
12114743Sthien 					    (void) put(1, O_IND8);
122775Speter 					    return(q);
123775Speter 				    case 4:
12414743Sthien 					    (void) put(1, O_IND4);
125775Speter 					    return(q);
126775Speter 				    case 2:
12714743Sthien 					    (void) put(1, O_IND24);
128775Speter 					    return(q);
129775Speter 				    case 1:
13014743Sthien 					    (void) put(1, O_IND14);
131775Speter 					    return(q);
132775Speter 				    default:
13314743Sthien 					    (void) put(2, O_IND, w);
134775Speter 					    return(q);
135775Speter 			    }
136775Speter #			endif OBJ
137775Speter #			ifdef PC
138775Speter 			    if ( required == RREQ ) {
13918471Sralph 				putop( PCCOM_UNARY PCC_MUL , p2type( q ) );
14010360Smckusick 				if (isa(q,"sbci")) {
14118471Sralph 				    sconv(p2type(q),PCCT_INT);
14210360Smckusick 				}
143775Speter 			    }
144775Speter 			    return q;
145775Speter #			endif PC
146775Speter 
147775Speter 		case CONST:
14814743Sthien 			if (r->var_node.qual != TR_NIL) {
14914743Sthien 				error("%s is a constant and cannot be qualified", r->var_node.cptr);
15014743Sthien 				return (NLNIL);
151775Speter 			}
152775Speter 			q = p->type;
15314743Sthien 			if (q == NLNIL)
15414743Sthien 				return (NLNIL);
155775Speter 			if (q == nl+TSTR) {
156775Speter 				/*
157775Speter 				 * Find the size of the string
158775Speter 				 * constant if needed.
159775Speter 				 */
16014743Sthien 				cp = (char *) p->ptr[0];
161775Speter cstrng:
162775Speter 				cp1 = cp;
163775Speter 				for (c = 0; *cp++; c++)
164775Speter 					continue;
16510841Speter 				w = c;
166775Speter 				if (contype != NIL && !opt('s')) {
167775Speter 					if (width(contype) < c && classify(contype) == TSTR) {
168775Speter 						error("Constant string too long");
16914743Sthien 						return (NLNIL);
170775Speter 					}
17110841Speter 					w = width(contype);
172775Speter 				}
173775Speter #				ifdef OBJ
17414743Sthien 				    (void) put(2, O_LVCON, lenstr(cp1, w - c));
17510841Speter 				    putstr(cp1, w - c);
176775Speter #				endif OBJ
177775Speter #				ifdef PC
17810841Speter 				    putCONG( cp1 , w , LREQ );
179775Speter #				endif PC
180775Speter 				/*
181775Speter 				 * Define the string temporarily
182775Speter 				 * so later people can know its
183775Speter 				 * width.
184775Speter 				 * cleaned out by stat.
185775Speter 				 */
18614743Sthien 				q = defnl((char *) 0, STR, NLNIL, w);
187775Speter 				q->type = q;
188775Speter 				return (q);
189775Speter 			}
190775Speter 			if (q == nl+T1CHAR) {
191775Speter #			    ifdef OBJ
19214743Sthien 				(void) put(2, O_CONC4, (int)p->value[0]);
193775Speter #			    endif OBJ
194775Speter #			    ifdef PC
19518471Sralph 				putleaf(PCC_ICON, p -> value[0], 0, PCCT_INT,
19614743Sthien 						(char *) 0);
197775Speter #			    endif PC
198775Speter 			    return(q);
199775Speter 			}
200775Speter 			/*
201775Speter 			 * Every other kind of constant here
202775Speter 			 */
203775Speter #			ifdef OBJ
204775Speter 			    switch (width(q)) {
205775Speter 			    case 8:
206775Speter #ifndef DEBUG
20714743Sthien 				    (void) put(2, O_CON8, p->real);
208775Speter 				    return(q);
209775Speter #else
210775Speter 				    if (hp21mx) {
21114743Sthien 					    f.pdouble = p->real;
21214743Sthien 					    conv((int *) (&f.pdouble));
21314743Sthien 					    l = f.plong[1];
21414743Sthien 					    (void) put(2, O_CON4, l);
215775Speter 				    } else
21614743Sthien 					    (void) put(2, O_CON8, p->real);
217775Speter 				    return(q);
218775Speter #endif
219775Speter 			    case 4:
22014743Sthien 				    (void) put(2, O_CON4, p->range[0]);
221775Speter 				    return(q);
222775Speter 			    case 2:
22314743Sthien 				    (void) put(2, O_CON24, (short)p->range[0]);
224775Speter 				    return(q);
225775Speter 			    case 1:
22614743Sthien 				    (void) put(2, O_CON14, p->value[0]);
227775Speter 				    return(q);
228775Speter 			    default:
229775Speter 				    panic("stkrval");
230775Speter 			    }
231775Speter #			endif OBJ
232775Speter #			ifdef PC
23314743Sthien 			    q = rvalue( r , contype , (int) required );
23410360Smckusick 			    if (isa(q,"sbci")) {
23518471Sralph 				sconv(p2type(q),PCCT_INT);
23610360Smckusick 			    }
23710360Smckusick 			    return q;
238775Speter #			endif PC
239775Speter 
240775Speter 		case FUNC:
2411201Speter 		case FFUNC:
242775Speter 			/*
243775Speter 			 * Function call
244775Speter 			 */
24514743Sthien 			pt = r->var_node.qual;
24614743Sthien 			if (pt != TR_NIL) {
24714743Sthien 				switch (pt->list_node.list->tag) {
248775Speter 				case T_PTR:
249775Speter 				case T_ARGL:
250775Speter 				case T_ARY:
251775Speter 				case T_FIELD:
252775Speter 					error("Can't qualify a function result value");
25314743Sthien 					return (NLNIL);
254775Speter 				}
255775Speter 			}
256775Speter #			ifdef OBJ
257775Speter 			    q = p->type;
258775Speter 			    if (classify(q) == TSTR) {
259775Speter 				    c = width(q);
26014743Sthien 				    (void) put(2, O_LVCON, even(c+1));
261775Speter 				    putstr("", c);
26214743Sthien 				    (void) put(1, PTR_DUP);
263775Speter 				    p = funccod(r);
26414743Sthien 				    (void) put(2, O_AS, c);
265775Speter 				    return(p);
266775Speter 			    }
267775Speter 			    p = funccod(r);
268775Speter 			    if (width(p) <= 2)
26914743Sthien 				    (void) put(1, O_STOI);
270775Speter #			endif OBJ
271775Speter #			ifdef PC
272775Speter 			    p = pcfunccod( r );
27310360Smckusick 			    if (isa(p,"sbci")) {
27418471Sralph 				sconv(p2type(p),PCCT_INT);
27510360Smckusick 			    }
276775Speter #			endif PC
277775Speter 			return (p);
278775Speter 
279775Speter 		case TYPE:
280775Speter 			error("Type names (e.g. %s) allowed only in declarations", p->symbol);
28114743Sthien 			return (NLNIL);
282775Speter 
283775Speter 		case PROC:
2841201Speter 		case FPROC:
285775Speter 			error("Procedure %s found where expression required", p->symbol);
28614743Sthien 			return (NLNIL);
287775Speter 		default:
288775Speter 			panic("stkrvid");
289775Speter 		}
290775Speter 	case T_PLUS:
291775Speter 	case T_MINUS:
292775Speter 	case T_NOT:
293775Speter 	case T_AND:
294775Speter 	case T_OR:
295775Speter 	case T_DIVD:
296775Speter 	case T_MULT:
297775Speter 	case T_SUB:
298775Speter 	case T_ADD:
299775Speter 	case T_MOD:
300775Speter 	case T_DIV:
301775Speter 	case T_EQ:
302775Speter 	case T_NE:
303775Speter 	case T_GE:
304775Speter 	case T_LE:
305775Speter 	case T_GT:
306775Speter 	case T_LT:
307775Speter 	case T_IN:
30814743Sthien 		p = rvalue(r, contype , (int) required );
309775Speter #		ifdef OBJ
310775Speter 		    if (width(p) <= 2)
31114743Sthien 			    (void) put(1, O_STOI);
312775Speter #		endif OBJ
31310360Smckusick #		ifdef PC
31410360Smckusick 		    if (isa(p,"sbci")) {
31518471Sralph 			sconv(p2type(p),PCCT_INT);
31610360Smckusick 		    }
31710360Smckusick #		endif PC
318775Speter 		return (p);
319909Speter 	case T_CSET:
32014743Sthien 		p = rvalue(r, contype , (int) required );
321909Speter 		return (p);
322775Speter 	default:
32314743Sthien 		if (r->const_node.cptr == (char *) NIL)
32414743Sthien 			return (NLNIL);
32514743Sthien 		switch (r->tag) {
326775Speter 		default:
327775Speter 			panic("stkrval3");
328775Speter 
329775Speter 		/*
330775Speter 		 * An octal number
331775Speter 		 */
332775Speter 		case T_BINT:
33314743Sthien 			f.pdouble = a8tol(r->const_node.cptr);
334775Speter 			goto conint;
335775Speter 
336775Speter 		/*
337775Speter 		 * A decimal number
338775Speter 		 */
339775Speter 		case T_INT:
34014743Sthien 			f.pdouble = atof(r->const_node.cptr);
341775Speter conint:
34214743Sthien 			if (f.pdouble > MAXINT || f.pdouble < MININT) {
343775Speter 				error("Constant too large for this implementation");
34414743Sthien 				return (NLNIL);
345775Speter 			}
34614743Sthien 			l = f.pdouble;
347775Speter 			if (bytes(l, l) <= 2) {
348775Speter #			    ifdef OBJ
34914743Sthien 				(void) put(2, O_CON24, (short)l);
350775Speter #			    endif OBJ
351775Speter #			    ifdef PC
35218471Sralph 				putleaf( PCC_ICON , (short) l , 0 , PCCT_INT ,
35314743Sthien 						(char *) 0 );
354775Speter #			    endif PC
355775Speter 				return(nl+T4INT);
356775Speter 			}
357775Speter #			ifdef OBJ
35814743Sthien 			    (void) put(2, O_CON4, l);
359775Speter #			endif OBJ
360775Speter #			ifdef PC
36118471Sralph 			    putleaf( PCC_ICON , (int) l , 0 , PCCT_INT , (char *) 0 );
362775Speter #			endif PC
363775Speter 			return (nl+T4INT);
364775Speter 
365775Speter 		/*
366775Speter 		 * A floating point number
367775Speter 		 */
368775Speter 		case T_FINT:
369775Speter #		   	ifdef OBJ
37014743Sthien 			    (void) put(2, O_CON8, atof(r->const_node.cptr));
371775Speter #			endif OBJ
372775Speter #			ifdef PC
37314743Sthien 			    putCON8( atof( r->const_node.cptr ) );
374775Speter #			endif PC
375775Speter 			return (nl+TDOUBLE);
376775Speter 
377775Speter 		/*
378775Speter 		 * Constant strings.  Note that constant characters
379775Speter 		 * are constant strings of length one; there is
380775Speter 		 * no constant string of length one.
381775Speter 		 */
382775Speter 		case T_STRNG:
38314743Sthien 			cp = r->const_node.cptr;
384775Speter 			if (cp[1] == 0) {
385775Speter #				ifdef OBJ
38614743Sthien 				    (void) put(2, O_CONC4, cp[0]);
387775Speter #				endif OBJ
388775Speter #				ifdef PC
38918471Sralph 				    putleaf( PCC_ICON , cp[0] , 0 , PCCT_INT ,
39014743Sthien 						(char *) 0 );
391775Speter #				endif PC
392775Speter 				return(nl+T1CHAR);
393775Speter 			}
394775Speter 			goto cstrng;
395775Speter 		}
396775Speter 
397775Speter 	}
398775Speter }
39910568Smckusick 
40010568Smckusick #ifdef OBJ
40110568Smckusick /*
40210568Smckusick  * push a value onto the interpreter stack, longword aligned.
40310568Smckusick  */
40414743Sthien struct nl
40514743Sthien *stackRV(p)
40610568Smckusick 	struct nl *p;
40710568Smckusick {
40810568Smckusick 	struct nl *q;
40910568Smckusick 	int w, bn;
41010568Smckusick 
41110568Smckusick 	q = p->type;
41214743Sthien 	if (q == NLNIL)
41314743Sthien 		return (NLNIL);
41410568Smckusick 	bn = BLOCKNO(p->nl_block);
41510568Smckusick 	w = width(q);
41610568Smckusick 	switch (w) {
41710568Smckusick 	case 8:
41814743Sthien 		(void) put(2, O_RV8 | bn << 8+INDX, (int)p->value[0]);
41910568Smckusick 		break;
42010568Smckusick 	case 4:
42114743Sthien 		(void) put(2, O_RV4 | bn << 8+INDX, (int)p->value[0]);
42210568Smckusick 		break;
42310568Smckusick 	case 2:
42414743Sthien 		(void) put(2, O_RV24 | bn << 8+INDX, (int)p->value[0]);
42510568Smckusick 		break;
42610568Smckusick 	case 1:
42714743Sthien 		(void) put(2, O_RV14 | bn << 8+INDX, (int)p->value[0]);
42810568Smckusick 		break;
42910568Smckusick 	default:
43014743Sthien 		(void) put(3, O_RV | bn << 8+INDX, (int)p->value[0], w);
43110568Smckusick 		break;
43210568Smckusick 	}
43310568Smckusick 	return (q);
43410568Smckusick }
43510568Smckusick #endif OBJ
436