[unix-history] / usr / src / usr.bin / pascal / src / stkrval.c

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

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

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

/*
 * stkrval Rvalue - an expression, and coerce it to be a stack quantity.
 *
 * Contype is the type that the caller would prefer, nand is important
 * if constant sets or constant strings are involved, the latter
 * because of string padding.
 */
/*
 * for the obj version, this is a copy of rvalue hacked to use fancy new
 * push-onto-stack-and-convert opcodes.
 * for the pc version, i just call rvalue and convert if i have to,
 * based on the return type of rvalue.
 */
struct nl *
stkrval(r, contype , required )
	register int *r;
	struct nl *contype;
	long	required;
{
	register struct nl *p;
	register struct nl *q;
	register char *cp, *cp1;
	register int c, w;
	int **pt;
	long l;
	double f;

	if (r == NIL)
		return (NIL);
	if (nowexp(r))
		return (NIL);
	/*
	 * The root of the tree tells us what sort of expression we have.
	 */
	switch (r[0]) {

	/*
	 * The constant nil
	 */
	case T_NIL:
#		ifdef OBJ
		    put(2, O_CON14, 0);
#		endif OBJ
#		ifdef PC
		    putleaf( P2ICON , 0 , 0 , P2INT , 0 );
#		endif PC
		return (nl+TNIL);

	case T_FCALL:
	case T_VAR:
		p = lookup(r[2]);
		if (p == NIL || p->class == BADUSE)
			return (NIL);
		switch (p->class) {
		case VAR:
			/*
			 * if a variable is
			 * qualified then get
			 * the rvalue by a
			 * stklval and an ind.
			 */
			if (r[3] != NIL)
				goto ind;
			q = p->type;
			if (q == NIL)
				return (NIL);
			if (classify(q) == TSTR)
				return(stklval(r, NOFLAGS));
#			ifdef OBJ
			    w = width(q);
			    switch (w) {
			    case 8:
				    put(2, O_RV8 | bn << 8+INDX,
					(int)p->value[0]);
				    return(q);
			    case 4:
				    put(2, O_RV4 | bn << 8+INDX,
					(int)p->value[0]);
				    return(q);
			    case 2:
				    put(2, O_RV24 | bn << 8+INDX,
					(int)p->value[0]);
				    return(q);
			    case 1:
				    put(2, O_RV14 | bn << 8+INDX,
					(int)p->value[0]);
				    return(q);
			    default:
				    put(3, O_RV | bn << 8+INDX,
					(int)p->value[0], w);
				    return(q);
			     }
#			endif OBJ
#			ifdef PC
			     return rvalue( r , contype , required );
#			endif PC

		case WITHPTR:
		case REF:
			/*
			 * A stklval for these
			 * is actually what one
			 * might consider a rvalue.
			 */
ind:
			q = stklval(r, NOFLAGS);
			if (q == NIL)
				return (NIL);
			if (classify(q) == TSTR)
				return(q);
#			ifdef OBJ
			    w = width(q);
			    switch (w) {
				    case 8:
					    put(1, O_IND8);
					    return(q);
				    case 4:
					    put(1, O_IND4);
					    return(q);
				    case 2:
					    put(1, O_IND24);
					    return(q);
				    case 1:
					    put(1, O_IND14);
					    return(q);
				    default:
					    put(2, O_IND, w);
					    return(q);
			    }
#			endif OBJ
#			ifdef PC
			    if ( required == RREQ ) {
				putop( P2UNARY P2MUL , p2type( q ) );
			    }
			    return q;
#			endif PC

		case CONST:
			if (r[3] != NIL) {
				error("%s is a constant and cannot be qualified", r[2]);
				return (NIL);
			}
			q = p->type;
			if (q == NIL)
				return (NIL);
			if (q == nl+TSTR) {
				/*
				 * Find the size of the string
				 * constant if needed.
				 */
				cp = p->ptr[0];
cstrng:
				cp1 = cp;
				for (c = 0; *cp++; c++)
					continue;
				w = 0;
				if (contype != NIL && !opt('s')) {
					if (width(contype) < c && classify(contype) == TSTR) {
						error("Constant string too long");
						return (NIL);
					}
					w = width(contype) - c;
				}
#				ifdef OBJ
				    put(2, O_LVCON, lenstr(cp1, w));
				    putstr(cp1, w);
#				endif OBJ
#				ifdef PC
				    putCONG( cp1 , c + w , LREQ );
#				endif PC
				/*
				 * Define the string temporarily
				 * so later people can know its
				 * width.
				 * cleaned out by stat.
				 */
				q = defnl(0, STR, 0, c);
				q->type = q;
				return (q);
			}
			if (q == nl+T1CHAR) {
#			    ifdef OBJ
				put(2, O_CONC4, (int)p->value[0]);
#			    endif OBJ
#			    ifdef PC
				putleaf( P2ICON , p -> value[0] , 0 , P2CHAR , 0 );
#			    endif PC
			    return(q);
			}
			/*
			 * Every other kind of constant here
			 */
#			ifdef OBJ
			    switch (width(q)) {
			    case 8:
#ifndef DEBUG
				    put(2, O_CON8, p->real);
				    return(q);
#else
				    if (hp21mx) {
					    f = p->real;
					    conv(&f);
					    l = f.plong;
					    put(2, O_CON4, l);
				    } else
					    put(2, O_CON8, p->real);
				    return(q);
#endif
			    case 4:
				    put(2, O_CON4, p->range[0]);
				    return(q);
			    case 2:
				    put(2, O_CON24, (short)p->range[0]);
				    return(q);
			    case 1:
				    put(2, O_CON14, p->value[0]);
				    return(q);
			    default:
				    panic("stkrval");
			    }
#			endif OBJ
#			ifdef PC
			    return rvalue( r , contype , required );
#			endif PC

		case FUNC:
		case FFUNC:
			/*
			 * Function call
			 */
			pt = (int **)r[3];
			if (pt != NIL) {
				switch (pt[1][0]) {
				case T_PTR:
				case T_ARGL:
				case T_ARY:
				case T_FIELD:
					error("Can't qualify a function result value");
					return (NIL);
				}
			}
#			ifdef OBJ
			    q = p->type;
			    if (classify(q) == TSTR) {
				    c = width(q);
				    put(2, O_LVCON, even(c+1));
				    putstr("", c);
				    put(1, PTR_DUP);
				    p = funccod(r);
				    put(2, O_AS, c);
				    return(p);
			    }
			    p = funccod(r);
			    if (width(p) <= 2)
				    put(1, O_STOI);
#			endif OBJ
#			ifdef PC
			    p = pcfunccod( r );
#			endif PC
			return (p);

		case TYPE:
			error("Type names (e.g. %s) allowed only in declarations", p->symbol);
			return (NIL);

		case PROC:
		case FPROC:
			error("Procedure %s found where expression required", p->symbol);
			return (NIL);
		default:
			panic("stkrvid");
		}
	case T_PLUS:
	case T_MINUS:
	case T_NOT:
	case T_AND:
	case T_OR:
	case T_DIVD:
	case T_MULT:
	case T_SUB:
	case T_ADD:
	case T_MOD:
	case T_DIV:
	case T_EQ:
	case T_NE:
	case T_GE:
	case T_LE:
	case T_GT:
	case T_LT:
	case T_IN:
		p = rvalue(r, contype , required );
#		ifdef OBJ
		    if (width(p) <= 2)
			    put(1, O_STOI);
#		endif OBJ
		return (p);
	case T_CSET:
		p = rvalue(r, contype , required );
		return (p);
	default:
		if (r[2] == NIL)
			return (NIL);
		switch (r[0]) {
		default:
			panic("stkrval3");

		/*
		 * An octal number
		 */
		case T_BINT:
			f = a8tol(r[2]);
			goto conint;
	
		/*
		 * A decimal number
		 */
		case T_INT:
			f = atof(r[2]);
conint:
			if (f > MAXINT || f < MININT) {
				error("Constant too large for this implementation");
				return (NIL);
			}
			l = f;
			if (bytes(l, l) <= 2) {
#			    ifdef OBJ
				put(2, O_CON24, (short)l);
#			    endif OBJ
#			    ifdef PC
				putleaf( P2ICON , (short) l , 0 , P2INT , 0 );
#			    endif PC
				return(nl+T4INT);
			}
#			ifdef OBJ
			    put(2, O_CON4, l); 
#			endif OBJ
#			ifdef PC
			    putleaf( P2ICON , l , 0 , P2INT , 0 );
#			endif PC
			return (nl+T4INT);
	
		/*
		 * A floating point number
		 */
		case T_FINT:
#		   	ifdef OBJ
			    put(2, O_CON8, atof(r[2]));
#			endif OBJ
#			ifdef PC
			    putCON8( atof( r[2] ) );
#			endif PC
			return (nl+TDOUBLE);
	
		/*
		 * Constant strings.  Note that constant characters
		 * are constant strings of length one; there is
		 * no constant string of length one.
		 */
		case T_STRNG:
			cp = r[2];
			if (cp[1] == 0) {
#				ifdef OBJ
				    put(2, O_CONC4, cp[0]);
#				endif OBJ
#				ifdef PC
				    putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 );
#				endif PC
				return(nl+T1CHAR);
			}
			goto cstrng;
		}
	
	}
}
Commit	Line	Data
28e6b83a PK	1	/* Copyright (c) 1979 Regents of the University of California */
28e6b83a PK	2
6cbd3a07	3	static char sccsid[] = "@(#)stkrval.c 1.4 %G%";
28e6b83a PK	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 "pcops.h"
	12	#endif PC
	13
	14	/*
	15	* stkrval Rvalue - an expression, and coerce it to be a stack quantity.
	16	*
	17	* Contype is the type that the caller would prefer, nand is important
	18	* if constant sets or constant strings are involved, the latter
	19	* because of string padding.
	20	*/
	21	/*
	22	* for the obj version, this is a copy of rvalue hacked to use fancy new
	23	* push-onto-stack-and-convert opcodes.
	24	* for the pc version, i just call rvalue and convert if i have to,
	25	* based on the return type of rvalue.
	26	*/
	27	struct nl *
	28	stkrval(r, contype , required )
	29	register int *r;
	30	struct nl *contype;
	31	long required;
	32	{
	33	register struct nl *p;
	34	register struct nl *q;
	35	register char cp, cp1;
	36	register int c, w;
	37	int **pt;
	38	long l;
	39	double f;
	40
	41	if (r == NIL)
	42	return (NIL);
	43	if (nowexp(r))
	44	return (NIL);
	45	/*
	46	* The root of the tree tells us what sort of expression we have.
	47	*/
	48	switch (r[0]) {
	49
	50	/*
	51	* The constant nil
	52	*/
	53	case T_NIL:
	54	# ifdef OBJ
	55	put(2, O_CON14, 0);
	56	# endif OBJ
	57	# ifdef PC
	58	putleaf( P2ICON , 0 , 0 , P2INT , 0 );
	59	# endif PC
	60	return (nl+TNIL);
	61
	62	case T_FCALL:
	63	case T_VAR:
	64	p = lookup(r[2]);
	65	if (p == NIL \|\| p->class == BADUSE)
	66	return (NIL);
	67	switch (p->class) {
68	case VAR:
69	/*
6cbd3a07	70	* if a variable is
28e6b83a PK	71	* qualified then get
	72	* the rvalue by a
	73	* stklval and an ind.
	74	*/
	75	if (r[3] != NIL)
	76	goto ind;
	77	q = p->type;
	78	if (q == NIL)
	79	return (NIL);
	80	if (classify(q) == TSTR)
	81	return(stklval(r, NOFLAGS));
	82	# ifdef OBJ
	83	w = width(q);
	84	switch (w) {
	85	case 8:
6cbd3a07 KM	86	put(2, O_RV8 \| bn << 8+INDX,
6cbd3a07 KM	87	(int)p->value[0]);
28e6b83a PK	88	return(q);
28e6b83a PK	89	case 4:
6cbd3a07 KM	90	put(2, O_RV4 \| bn << 8+INDX,
6cbd3a07 KM	91	(int)p->value[0]);
28e6b83a PK	92	return(q);
28e6b83a PK	93	case 2:
6cbd3a07 KM	94	put(2, O_RV24 \| bn << 8+INDX,
6cbd3a07 KM	95	(int)p->value[0]);
28e6b83a PK	96	return(q);
28e6b83a PK	97	case 1:
6cbd3a07 KM	98	put(2, O_RV14 \| bn << 8+INDX,
6cbd3a07 KM	99	(int)p->value[0]);
28e6b83a PK	100	return(q);
28e6b83a PK	101	default:
6cbd3a07 KM	102	put(3, O_RV \| bn << 8+INDX,
6cbd3a07 KM	103	(int)p->value[0], w);
28e6b83a PK	104	return(q);
	105	}
	106	# endif OBJ
	107	# ifdef PC
	108	return rvalue( r , contype , required );
	109	# endif PC
	110
	111	case WITHPTR:
	112	case REF:
	113	/*
	114	* A stklval for these
	115	* is actually what one
	116	* might consider a rvalue.
	117	*/
	118	ind:
	119	q = stklval(r, NOFLAGS);
	120	if (q == NIL)
	121	return (NIL);
	122	if (classify(q) == TSTR)
	123	return(q);
	124	# ifdef OBJ
	125	w = width(q);
	126	switch (w) {
	127	case 8:
	128	put(1, O_IND8);
	129	return(q);
	130	case 4:
	131	put(1, O_IND4);
	132	return(q);
	133	case 2:
	134	put(1, O_IND24);
	135	return(q);
	136	case 1:
	137	put(1, O_IND14);
	138	return(q);
	139	default:
	140	put(2, O_IND, w);
	141	return(q);
	142	}
	143	# endif OBJ
	144	# ifdef PC
	145	if ( required == RREQ ) {
	146	putop( P2UNARY P2MUL , p2type( q ) );
	147	}
	148	return q;
	149	# endif PC
	150
	151	case CONST:
	152	if (r[3] != NIL) {
	153	error("%s is a constant and cannot be qualified", r[2]);
	154	return (NIL);
	155	}
	156	q = p->type;
	157	if (q == NIL)
	158	return (NIL);
	159	if (q == nl+TSTR) {
	160	/*
	161	* Find the size of the string
	162	* constant if needed.
	163	*/
	164	cp = p->ptr[0];
	165	cstrng:
	166	cp1 = cp;
	167	for (c = 0; *cp++; c++)
168	continue;
169	w = 0;
170	if (contype != NIL && !opt('s')) {
171	if (width(contype) < c && classify(contype) == TSTR) {
172	error("Constant string too long");
173	return (NIL);
174	}
175	w = width(contype) - c;
176	}
177	# ifdef OBJ
178	put(2, O_LVCON, lenstr(cp1, w));
179	putstr(cp1, w);
180	# endif OBJ
181	# ifdef PC
182	putCONG( cp1 , c + w , LREQ );
183	# endif PC
184	/*
185	* Define the string temporarily
186	* so later people can know its
187	* width.
188	* cleaned out by stat.
189	*/
190	q = defnl(0, STR, 0, c);
191	q->type = q;
192	return (q);
193	}
194	if (q == nl+T1CHAR) {
195	# ifdef OBJ
6cbd3a07	196	put(2, O_CONC4, (int)p->value[0]);
28e6b83a PK	197	# endif OBJ
	198	# ifdef PC
	199	putleaf( P2ICON , p -> value[0] , 0 , P2CHAR , 0 );
	200	# endif PC
	201	return(q);
	202	}
	203	/*
	204	* Every other kind of constant here
	205	*/
	206	# ifdef OBJ
	207	switch (width(q)) {
	208	case 8:
	209	#ifndef DEBUG
	210	put(2, O_CON8, p->real);
	211	return(q);
	212	#else
	213	if (hp21mx) {
	214	f = p->real;
	215	conv(&f);
	216	l = f.plong;
	217	put(2, O_CON4, l);
	218	} else
	219	put(2, O_CON8, p->real);
	220	return(q);
	221	#endif
	222	case 4:
	223	put(2, O_CON4, p->range[0]);
	224	return(q);
	225	case 2:
	226	put(2, O_CON24, (short)p->range[0]);
	227	return(q);
	228	case 1:
6cbd3a07	229	put(2, O_CON14, p->value[0]);
28e6b83a PK	230	return(q);
	231	default:
	232	panic("stkrval");
	233	}
	234	# endif OBJ
	235	# ifdef PC
	236	return rvalue( r , contype , required );
	237	# endif PC
	238
	239	case FUNC:
c4e911b6	240	case FFUNC:
28e6b83a PK	241	/*
	242	* Function call
	243	*/
	244	pt = (int **)r[3];
	245	if (pt != NIL) {
	246	switch (pt[1][0]) {
	247	case T_PTR:
	248	case T_ARGL:
	249	case T_ARY:
	250	case T_FIELD:
	251	error("Can't qualify a function result value");
	252	return (NIL);
	253	}
	254	}
	255	# ifdef OBJ
	256	q = p->type;
	257	if (classify(q) == TSTR) {
	258	c = width(q);
	259	put(2, O_LVCON, even(c+1));
	260	putstr("", c);
6cbd3a07	261	put(1, PTR_DUP);
28e6b83a PK	262	p = funccod(r);
	263	put(2, O_AS, c);
	264	return(p);
	265	}
	266	p = funccod(r);
	267	if (width(p) <= 2)
	268	put(1, O_STOI);
	269	# endif OBJ
	270	# ifdef PC
	271	p = pcfunccod( r );
	272	# endif PC
	273	return (p);
	274
	275	case TYPE:
	276	error("Type names (e.g. %s) allowed only in declarations", p->symbol);
	277	return (NIL);
	278
	279	case PROC:
c4e911b6	280	case FPROC:
28e6b83a PK	281	error("Procedure %s found where expression required", p->symbol);
	282	return (NIL);
	283	default:
	284	panic("stkrvid");
	285	}
28e6b83a PK	286	case T_PLUS:
	287	case T_MINUS:
	288	case T_NOT:
	289	case T_AND:
	290	case T_OR:
	291	case T_DIVD:
	292	case T_MULT:
	293	case T_SUB:
	294	case T_ADD:
	295	case T_MOD:
	296	case T_DIV:
	297	case T_EQ:
	298	case T_NE:
	299	case T_GE:
	300	case T_LE:
	301	case T_GT:
	302	case T_LT:
	303	case T_IN:
	304	p = rvalue(r, contype , required );
	305	# ifdef OBJ
	306	if (width(p) <= 2)
	307	put(1, O_STOI);
	308	# endif OBJ
	309	return (p);
a26d837a PK	310	case T_CSET:
	311	p = rvalue(r, contype , required );
	312	return (p);
28e6b83a PK	313	default:
	314	if (r[2] == NIL)
	315	return (NIL);
	316	switch (r[0]) {
	317	default:
	318	panic("stkrval3");
	319
	320	/*
	321	* An octal number
	322	*/
	323	case T_BINT:
	324	f = a8tol(r[2]);
	325	goto conint;
	326
	327	/*
	328	* A decimal number
	329	*/
	330	case T_INT:
	331	f = atof(r[2]);
	332	conint:
	333	if (f > MAXINT \|\| f < MININT) {
	334	error("Constant too large for this implementation");
	335	return (NIL);
	336	}
	337	l = f;
	338	if (bytes(l, l) <= 2) {
	339	# ifdef OBJ
	340	put(2, O_CON24, (short)l);
	341	# endif OBJ
	342	# ifdef PC
	343	putleaf( P2ICON , (short) l , 0 , P2INT , 0 );
	344	# endif PC
	345	return(nl+T4INT);
	346	}
	347	# ifdef OBJ
	348	put(2, O_CON4, l);
	349	# endif OBJ
	350	# ifdef PC
	351	putleaf( P2ICON , l , 0 , P2INT , 0 );
	352	# endif PC
	353	return (nl+T4INT);
	354
	355	/*
	356	* A floating point number
	357	*/
	358	case T_FINT:
	359	# ifdef OBJ
	360	put(2, O_CON8, atof(r[2]));
	361	# endif OBJ
	362	# ifdef PC
	363	putCON8( atof( r[2] ) );
	364	# endif PC
	365	return (nl+TDOUBLE);
	366
	367	/*
	368	* Constant strings. Note that constant characters
	369	* are constant strings of length one; there is
	370	* no constant string of length one.
	371	*/
	372	case T_STRNG:
	373	cp = r[2];
	374	if (cp[1] == 0) {
	375	# ifdef OBJ
	376	put(2, O_CONC4, cp[0]);
377	# endif OBJ
378	# ifdef PC
379	putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 );
380	# endif PC
381	return(nl+T1CHAR);
382	}
383	goto cstrng;
384	}
385
386	}
387	}