[unix-history] / usr / src / cmd / pc0 / conv.c

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

static char sccsid[] = "@(#)conv.c 1.2 3/8/81";

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

#ifndef PI0
/*
 * Convert a p1 into a p2.
 * Mostly used for different
 * length integers and "to real" conversions.
 */
convert(p1, p2)
	struct nl *p1, *p2;
{
	if (p1 == NIL || p2 == NIL)
		return;
	switch (width(p1) - width(p2)) {
		case -7:
		case -6:
			put(1, O_STOD);
			return;
		case -4:
			put(1, O_ITOD);
			return;
		case -3:
		case -2:
			put(1, O_STOI);
			return;
		case -1:
		case 0:
		case 1:
			return;
		case 2:
		case 3:
			put(1, O_ITOS);
			return;
		default:
			panic("convert");
	}
}
#endif

/*
 * Compat tells whether
 * p1 and p2 are compatible
 * types for an assignment like
 * context, i.e. value parameters,
 * indicies for 'in', etc.
 */
compat(p1, p2, t)
	struct nl *p1, *p2;
{
	register c1, c2;

	c1 = classify(p1);
	if (c1 == NIL)
		return (NIL);
	c2 = classify(p2);
	if (c2 == NIL)
		return (NIL);
	switch (c1) {
		case TBOOL:
		case TCHAR:
			if (c1 == c2)
				return (1);
			break;
		case TINT:
			if (c2 == TINT)
				return (1);
		case TDOUBLE:
			if (c2 == TDOUBLE)
				return (1);
#ifndef PI0
			if (c2 == TINT && divflg == 0 && t != NIL ) {
				divchk= 1;
				c1 = classify(rvalue(t, NLNIL , RREQ ));
				divchk = NIL;
				if (c1 == TINT) {
					error("Type clash: real is incompatible with integer");
					cerror("This resulted because you used '/' which always returns real rather");
					cerror("than 'div' which divides integers and returns integers");
					divflg = 1;
					return (NIL);
				}
			}
#endif
			break;
		case TSCAL:
			if (c2 != TSCAL)
				break;
			if (scalar(p1) != scalar(p2)) {
				derror("Type clash: non-identical scalar types");
				return (NIL);
			}
			return (1);
		case TSTR:
			if (c2 != TSTR)
				break;
			if (width(p1) != width(p2)) {
				derror("Type clash: unequal length strings");
				return (NIL);
			}
			return (1);
		case TNIL:
			if (c2 != TPTR)
				break;
			return (1);
		case TFILE:
			if (c1 != c2)
				break;
			derror("Type clash: files not allowed in this context");
			return (NIL);
		default:
			if (c1 != c2)
				break;
			if (p1 != p2) {
				derror("Type clash: non-identical %s types", clnames[c1]);
				return (NIL);
			}
			if (p1->nl_flags & NFILES) {
				derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
				return (NIL);
			}
			return (1);
	}
	derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
	return (NIL);
}

#ifndef PI0
/*
 * Rangechk generates code to
 * check if the type p on top
 * of the stack is in range for
 * assignment to a variable
 * of type q.
 */
rangechk(p, q)
	struct nl *p, *q;
{
	register struct nl *rp;
	register op;
	int wq, wrp;

	if (opt('t') == 0)
		return;
	rp = p;
	if (rp == NIL)
		return;
	if (q == NIL)
		return;
#	ifdef OBJ
	    /*
	     * When op is 1 we are checking length
	     * 4 numbers against length 2 bounds,
	     * and adding it to the opcode forces
	     * generation of appropriate tests.
	     */
	    op = 0;
	    wq = width(q);
	    wrp = width(rp);
	    op = wq != wrp && (wq == 4 || wrp == 4);
	    if (rp->class == TYPE)
		    rp = rp->type;
	    switch (rp->class) {
	    case RANGE:
		    if (rp->range[0] != 0) {
#    		    ifndef DEBUG
			    if (wrp <= 2)
				    put(3, O_RANG2+op, ( short ) rp->range[0],
						     ( short ) rp->range[1]);
			    else if (rp != nl+T4INT)
				    put(3, O_RANG4+op, rp->range[0], rp->range[1] );
#    		    else
			    if (!hp21mx) {
				    if (wrp <= 2)
					    put(3, O_RANG2+op,( short ) rp->range[0],
							    ( short ) rp->range[1]);
				    else if (rp != nl+T4INT)
					    put(3, O_RANG4+op,rp->range[0],
							     rp->range[1]);
			    } else
				    if (rp != nl+T2INT && rp != nl+T4INT)
					    put(3, O_RANG2+op,( short ) rp->range[0],
							    ( short ) rp->range[1]);
#    		    endif
			break;
		    }
		    /*
		     * Range whose lower bounds are
		     * zero can be treated as scalars.
		     */
	    case SCAL:
		    if (wrp <= 2)
			    put(2, O_RSNG2+op, ( short ) rp->range[1]);
		    else
			    put( 2 , O_RSNG4+op, rp->range[1]);
		    break;
	    default:
		    panic("rangechk");
	    }
#	endif OBJ
#	ifdef PC
		/*
		 * what i want to do is make this and some other stuff
		 * arguments to a function call, which will do the rangecheck,
		 * and return the value of the current expression, or abort
		 * if the rangecheck fails.
		 * probably i need one rangecheck routine to return each c-type
		 * of value.
		 * also, i haven't figured out what the `other stuff' is.
		 */
	    putprintf( "#	call rangecheck" , 0 );
#	endif PC
}
#endif
#endif

#ifdef PC
    /*
     *	if type p requires a range check,
     *	    then put out the name of the checking function
     *	for the beginning of a function call which is completed by postcheck.
     *  (name1 is for a full check; name2 assumes a lower bound of zero)
     */
precheck( p , name1 , name2 )
    struct nl	*p;
    char	*name1 , *name2;
    {

	if ( opt( 't' ) == 0 ) {
	    return;
	}
	if ( p == NIL ) {
	    return;
	}
	if ( p -> class == TYPE ) {
	    p = p -> type;
	}
	switch ( p -> class ) {
	    case RANGE:
		if ( p != nl + T4INT ) {
		    putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
			    , p -> range[0] != 0 ? name1 : name2 );
		}
		break;
	    case SCAL:
		    /*
		     *	how could a scalar ever be out of range?
		     */
		break;
	    default:
		panic( "precheck" );
		break;
	}
    }

    /*
     *	if type p requires a range check,
     *	    then put out the rest of the arguments of to the checking function
     *	a call to which was started by precheck.
     *	the first argument is what is being rangechecked (put out by rvalue),
     *	the second argument is the lower bound of the range,
     *	the third argument is the upper bound of the range.
     */
postcheck( p )
    struct nl	*p;
    {

	if ( opt( 't' ) == 0 ) {
	    return;
	}
	if ( p == NIL ) {
	    return;
	}
	if ( p -> class == TYPE ) {
	    p = p -> type;
	}
	switch ( p -> class ) {
	    case RANGE:
		if ( p != nl + T4INT ) {
		    if (p -> range[0] != 0 ) {
			putleaf( P2ICON , p -> range[0] , 0 , P2INT , 0 );
			putop( P2LISTOP , P2INT );
		    }
		    putleaf( P2ICON , p -> range[1] , 0 , P2INT , 0 );
		    putop( P2LISTOP , P2INT );
		    putop( P2CALL , P2INT );
		}
		break;
	    case SCAL:
		break;
	    default:
		panic( "postcheck" );
		break;
	}
    }
#endif PC

#ifdef DEBUG
conv(dub)
	int *dub;
{
	int newfp[2];
	double *dp = dub;
	long *lp = dub;
	register int exp;
	long mant;

	newfp[0] = dub[0] & 0100000;
	newfp[1] = 0;
	if (*dp == 0.0)
		goto ret;
	exp = ((dub[0] >> 7) & 0377) - 0200;
	if (exp < 0) {
		newfp[1] = 1;
		exp = -exp;
	}
	if (exp > 63)
		exp = 63;
	dub[0] &= ~0177600;
	dub[0] |= 0200;
	mant = *lp;
	mant <<= 8;
	if (newfp[0])
		mant = -mant;
	newfp[0] |= (mant >> 17) & 077777;
	newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1);
ret:
	dub[0] = newfp[0];
	dub[1] = newfp[1];
}
#endif
Commit	Line	Data
181348e1 PK	1	/* Copyright (c) 1979 Regents of the University of California */
181348e1 PK	2
4b9ccde7	3	static char sccsid[] = "@(#)conv.c 1.2 3/8/81";
181348e1 PK	4
	5	#include "whoami.h"
	6	#ifdef PI
	7	#include "0.h"
	8	#include "opcode.h"
	9	#ifdef PC
	10	# include "pcops.h"
	11	#endif PC
	12
	13	#ifndef PI0
	14	/*
	15	* Convert a p1 into a p2.
	16	* Mostly used for different
	17	* length integers and "to real" conversions.
	18	*/
	19	convert(p1, p2)
	20	struct nl p1, p2;
	21	{
	22	if (p1 == NIL \|\| p2 == NIL)
	23	return;
	24	switch (width(p1) - width(p2)) {
	25	case -7:
	26	case -6:
6cbd3a07	27	put(1, O_STOD);
181348e1 PK	28	return;
181348e1 PK	29	case -4:
6cbd3a07	30	put(1, O_ITOD);
181348e1 PK	31	return;
	32	case -3:
	33	case -2:
6cbd3a07	34	put(1, O_STOI);
181348e1 PK	35	return;
	36	case -1:
	37	case 0:
	38	case 1:
	39	return;
	40	case 2:
	41	case 3:
6cbd3a07	42	put(1, O_ITOS);
181348e1 PK	43	return;
	44	default:
	45	panic("convert");
	46	}
	47	}
	48	#endif
	49
	50	/*
	51	* Compat tells whether
	52	* p1 and p2 are compatible
	53	* types for an assignment like
	54	* context, i.e. value parameters,
	55	* indicies for 'in', etc.
	56	*/
	57	compat(p1, p2, t)
	58	struct nl p1, p2;
	59	{
	60	register c1, c2;
	61
	62	c1 = classify(p1);
	63	if (c1 == NIL)
	64	return (NIL);
	65	c2 = classify(p2);
	66	if (c2 == NIL)
	67	return (NIL);
	68	switch (c1) {
	69	case TBOOL:
	70	case TCHAR:
	71	if (c1 == c2)
	72	return (1);
	73	break;
	74	case TINT:
	75	if (c2 == TINT)
	76	return (1);
	77	case TDOUBLE:
	78	if (c2 == TDOUBLE)
	79	return (1);
	80	#ifndef PI0
	81	if (c2 == TINT && divflg == 0 && t != NIL ) {
	82	divchk= 1;
	83	c1 = classify(rvalue(t, NLNIL , RREQ ));
	84	divchk = NIL;
	85	if (c1 == TINT) {
	86	error("Type clash: real is incompatible with integer");
	87	cerror("This resulted because you used '/' which always returns real rather");
	88	cerror("than 'div' which divides integers and returns integers");
	89	divflg = 1;
	90	return (NIL);
	91	}
	92	}
	93	#endif
	94	break;
	95	case TSCAL:
	96	if (c2 != TSCAL)
	97	break;
	98	if (scalar(p1) != scalar(p2)) {
	99	derror("Type clash: non-identical scalar types");
	100	return (NIL);
	101	}
	102	return (1);
	103	case TSTR:
	104	if (c2 != TSTR)
	105	break;
	106	if (width(p1) != width(p2)) {
107	derror("Type clash: unequal length strings");
108	return (NIL);
109	}
110	return (1);
111	case TNIL:
112	if (c2 != TPTR)
113	break;
114	return (1);
115	case TFILE:
116	if (c1 != c2)
117	break;
118	derror("Type clash: files not allowed in this context");
119	return (NIL);
120	default:
121	if (c1 != c2)
122	break;
123	if (p1 != p2) {
124	derror("Type clash: non-identical %s types", clnames[c1]);
125	return (NIL);
126	}
127	if (p1->nl_flags & NFILES) {
128	derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
129	return (NIL);
130	}
131	return (1);
132	}
133	derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
134	return (NIL);
135	}
136
137	#ifndef PI0
138	/*
139	* Rangechk generates code to
140	* check if the type p on top
141	* of the stack is in range for
142	* assignment to a variable
143	* of type q.
144	*/
145	rangechk(p, q)
146	struct nl p, q;
147	{
148	register struct nl *rp;
149	register op;
150	int wq, wrp;
151
152	if (opt('t') == 0)
153	return;
154	rp = p;
155	if (rp == NIL)
156	return;
157	if (q == NIL)
158	return;
159	# ifdef OBJ
160	/*
161	* When op is 1 we are checking length
162	* 4 numbers against length 2 bounds,
163	* and adding it to the opcode forces
164	* generation of appropriate tests.
165	*/
166	op = 0;
167	wq = width(q);
168	wrp = width(rp);
169	op = wq != wrp && (wq == 4 \|\| wrp == 4);
170	if (rp->class == TYPE)
171	rp = rp->type;
172	switch (rp->class) {
173	case RANGE:
174	if (rp->range[0] != 0) {
175	# ifndef DEBUG
176	if (wrp <= 2)
177	put(3, O_RANG2+op, ( short ) rp->range[0],
178	( short ) rp->range[1]);
179	else if (rp != nl+T4INT)
180	put(3, O_RANG4+op, rp->range[0], rp->range[1] );
181	# else
182	if (!hp21mx) {
183	if (wrp <= 2)
184	put(3, O_RANG2+op,( short ) rp->range[0],
185	( short ) rp->range[1]);
186	else if (rp != nl+T4INT)
187	put(3, O_RANG4+op,rp->range[0],
188	rp->range[1]);
189	} else
190	if (rp != nl+T2INT && rp != nl+T4INT)
191	put(3, O_RANG2+op,( short ) rp->range[0],
192	( short ) rp->range[1]);
193	# endif
194	break;
195	}
196	/*
197	* Range whose lower bounds are
198	* zero can be treated as scalars.
199	*/
200	case SCAL:
201	if (wrp <= 2)
202	put(2, O_RSNG2+op, ( short ) rp->range[1]);
203	else
204	put( 2 , O_RSNG4+op, rp->range[1]);
205	break;
206	default:
207	panic("rangechk");
208	}
209	# endif OBJ
210	# ifdef PC
211	/*
212	* what i want to do is make this and some other stuff
213	* arguments to a function call, which will do the rangecheck,
214	* and return the value of the current expression, or abort
215	* if the rangecheck fails.
216	* probably i need one rangecheck routine to return each c-type
217	* of value.
218	* also, i haven't figured out what the `other stuff' is.
219	*/
220	putprintf( "# call rangecheck" , 0 );
221	# endif PC
222	}
223	#endif
224	#endif
225
226	#ifdef PC
227	/*
228	* if type p requires a range check,
229	* then put out the name of the checking function
230	* for the beginning of a function call which is completed by postcheck.
231	* (name1 is for a full check; name2 assumes a lower bound of zero)
232	*/
233	precheck( p , name1 , name2 )
234	struct nl *p;
235	char name1 , name2;
236	{
237
238	if ( opt( 't' ) == 0 ) {
239	return;
240	}
241	if ( p == NIL ) {
242	return;
243	}
244	if ( p -> class == TYPE ) {
245	p = p -> type;
246	}
247	switch ( p -> class ) {
248	case RANGE:
249	if ( p != nl + T4INT ) {
250	putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN \| P2INT , P2PTR )
251	, p -> range[0] != 0 ? name1 : name2 );
252	}
253	break;
254	case SCAL:
255	/*
256	* how could a scalar ever be out of range?
257	*/
258	break;
259	default:
260	panic( "precheck" );
261	break;
262	}
263	}
264
265	/*
266	* if type p requires a range check,
267	* then put out the rest of the arguments of to the checking function
268	* a call to which was started by precheck.
269	* the first argument is what is being rangechecked (put out by rvalue),
270	* the second argument is the lower bound of the range,
271	* the third argument is the upper bound of the range.
272	*/
273	postcheck( p )
274	struct nl *p;
275	{
276
277	if ( opt( 't' ) == 0 ) {
278	return;
279	}
280	if ( p == NIL ) {
281	return;
282	}
283	if ( p -> class == TYPE ) {
284	p = p -> type;
285	}
286	switch ( p -> class ) {
287	case RANGE:
288	if ( p != nl + T4INT ) {
289	if (p -> range[0] != 0 ) {
290	putleaf( P2ICON , p -> range[0] , 0 , P2INT , 0 );
291	putop( P2LISTOP , P2INT );
292	}
293	putleaf( P2ICON , p -> range[1] , 0 , P2INT , 0 );
294	putop( P2LISTOP , P2INT );
295	putop( P2CALL , P2INT );
296	}
297	break;
298	case SCAL:
299	break;
300	default:
301	panic( "postcheck" );
302	break;
303	}
304	}
305	#endif PC
306
307	#ifdef DEBUG
308	conv(dub)
309	int *dub;
310	{
311	int newfp[2];
312	double *dp = dub;
313	long *lp = dub;
314	register int exp;
315	long mant;
316
317	newfp[0] = dub[0] & 0100000;
318	newfp[1] = 0;
319	if (*dp == 0.0)
320	goto ret;
321	exp = ((dub[0] >> 7) & 0377) - 0200;
322	if (exp < 0) {
323	newfp[1] = 1;
324	exp = -exp;
325	}
326	if (exp > 63)
327	exp = 63;
328	dub[0] &= ~0177600;
329	dub[0] \|= 0200;
330	mant = *lp;
331	mant <<= 8;
332	if (newfp[0])
333	mant = -mant;
334	newfp[0] \|= (mant >> 17) & 077777;
335	newfp[1] \|= (((int) (mant >> 1)) & 0177400) \| (exp << 1);
336	ret:
337	dub[0] = newfp[0];
338	dub[1] = newfp[1];
339	}
340	#endif