xref: /csrg-svn/usr.bin/pascal/src/cset.c (revision 3170)

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

static char sccsid[] = "@(#)cset.c 1.5 03/10/81";

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

/*
 * CONSETS causes compile time constant sets to be constructed here.
 *
 * COMPSETSZE defines the maximum number of longs to be used in
 *	constant set construction
 */
#define CONSETS
#define COMPSETSZE 10

#define BITSPERBYTE 8
#define BITSPERLONG 32
#define LG2BITSBYTE 3
#define MSKBITSBYTE 0x07
#define LG2BITSLONG 5
#define MSKBITSLONG 0x1f

/*
 *	rummage through a `constant' set (i.e. anything within [ ]'s) tree
 *	and decide if this is a compile time constant set or a runtime set.
 *	this information is returned in a structure passed from the caller.
 *	while rummaging, this also reorders the tree so that all ranges
 *	preceed all singletons.
 */
bool
precset( r , settype , csetp )
	int		*r;
	struct nl	*settype;
	struct csetstr	*csetp;
{
	register int		*e;
	register struct nl	*t;
	register struct nl	*exptype;
	register int		*el;
	register int		*pairp;
	register int		*singp;
	int			*ip;
	int			lower;
	int			upper;
	bool			setofint;

	csetp -> csettype = NIL;
	csetp -> paircnt = 0;
	csetp -> singcnt = 0;
	csetp -> comptime = TRUE;
	setofint = FALSE;
	if ( settype != NIL ) {
	    if ( settype -> class == SET ) {
		    /*
		     *	the easy case, we are told the type of the set.
		     */
		exptype = settype -> type;
	    } else {
		    /*
		     *	we are told the type, but it's not a set
		     *	supposedly possible if someone tries
		     *	e.g string context [1,2] = 'abc'
		     */
		error("Constant set involved in non set context");
		return csetp -> comptime;
	    }
	} else {
		/*
		 * So far we have no indication
		 * of what the set type should be.
		 * We "look ahead" and try to infer
		 * The type of the constant set
		 * by evaluating one of its members.
		 */
	    e = r[2];
	    if (e == NIL) {
		    /*
		     *	tentative for [], return type of `intset'
		     */
		settype = lookup( intset );
		if ( settype == NIL ) {
		    panic( "empty set" );
		}
		settype = settype -> type;
		if ( settype == NIL ) {
		    return csetp -> comptime;
		}
		if ( isnta( settype , "t" ) ) {
		    error("Set default type \"intset\" is not a set");
		    return csetp -> comptime;
		}
		csetp -> csettype = settype;
		setran( settype -> type );
		if (((set.uprbp + 1) >> LG2BITSLONG) >= COMPSETSZE)
			csetp -> comptime = FALSE;
		return csetp -> comptime;
	    }
	    e = e[1];
	    if (e == NIL) {
		return csetp -> comptime;
	    }
	    if (e[0] == T_RANG) {
		    e = e[1];
	    }
	    codeoff();
	    t = rvalue(e, NIL , RREQ );
	    codeon();
	    if (t == NIL) {
		return csetp -> comptime;
	    }
		/*
		 * The type of the set, settype, is
		 * deemed to be a set of the base type
		 * of t, which we call exptype.  If,
		 * however, this would involve a
		 * "set of integer", we cop out
		 * and use "intset"'s current scoped
		 * type instead.
		 */
	    if (isa(t, "r")) {
		    error("Sets may not have 'real' elements");
		    return csetp -> comptime;
	    }
	    if (isnta(t, "bcsi")) {
		    error("Set elements must be scalars, not %ss", nameof(t));
		    return csetp -> comptime;
	    }
	    if (isa(t, "i")) {
		    settype = lookup(intset);
		    if (settype == NIL)
			    panic("intset");
		    settype = settype->type;
		    if (settype == NIL)
			    return csetp -> comptime;
		    if (isnta(settype, "t")) {
			    error("Set default type \"intset\" is not a set");
			    return csetp -> comptime;
		    }
		    exptype = settype->type;
			/*
			 *	say we are doing an intset
			 *	but, if we get out of range errors for intset
			 *	we punt constructing the set at	compile time.
			 */
		    setofint = TRUE;
	    } else {
			exptype = t->type;
			if (exptype == NIL)
				return csetp -> comptime;
			if (exptype->class != RANGE)
				exptype = exptype->type;
			settype = defnl(0, SET, exptype, 0);
	    }
	}
	csetp -> csettype = settype;
#	ifndef CONSETS
	    csetp -> comptime = FALSE;
#	endif CONSETS
	setran( exptype );
	if (((set.uprbp + 1) >> LG2BITSLONG) >= COMPSETSZE)
		csetp -> comptime = FALSE;
	lower = set.lwrb;
	upper = set.lwrb + set.uprbp;
	pairp = NIL;
	singp = NIL;
	codeoff();
	while ( el = r[2] ) {
		e = el[1];
		if (e == NIL) {
			    /*
			     *	don't hang this one anywhere.
			     */
			csetp -> csettype = NIL;
			r[2] = el[2];
			continue;
		}
		if (e[0] == T_RANG) {
			if ( csetp -> comptime && constval( e[2] ) ) {
#ifdef CONSETS
			    t = con.ctype;
			    if ( con.crval < lower || con.crval > upper ) {
				if ( setofint ) {
				    csetp -> comptime = FALSE;
				} else {
				    error("Range upper bound of %D out of set bounds" , ((long)con.crval) );
				    csetp -> csettype = NIL;
				}
			    }
#endif CONSETS
			} else {
			    csetp -> comptime = FALSE;
			    t = rvalue(e[2], NIL , RREQ );
			    if (t == NIL) {
				    rvalue(e[1], NIL , RREQ );
				    goto pairhang;
			    }
			}
			if (incompat(t, exptype, e[2])) {
				cerror("Upper bound of element type clashed with set type in constant set");
			}
			if ( csetp -> comptime && constval( e[1] ) ) {
#ifdef CONSETS
			    t = con.ctype;
			    if ( con.crval < lower || con.crval > upper ) {
				if ( setofint ) {
				    csetp -> comptime = FALSE;
				} else {
				    error("Range lower bound of %D out of set bounds" , ((long)con.crval) );
				    csetp -> csettype = NIL;
				}
			    }
#endif CONSETS
			} else {
			    csetp -> comptime = FALSE;
			    t = rvalue(e[1], NIL , RREQ );
			    if (t == NIL) {
				    goto pairhang;
			    }
			}
			if (incompat(t, exptype, e[1])) {
				cerror("Lower bound of element type clashed with set type in constant set");
			}
pairhang:
			    /*
			     *	remove this range from the tree list and
			     *	hang it on the pairs list.
			     */
			ip = el[2];
			el[2] = pairp;
			pairp = r[2];
			r[2] = ip;
			csetp -> paircnt++;
		} else {
			if ( csetp -> comptime && constval( e ) ) {
#ifdef CONSETS
			    t = con.ctype;
			    if ( con.crval < lower || con.crval > upper ) {
				if ( setofint ) {
				    csetp -> comptime = FALSE;
				} else {
				    error("Value of %D out of set bounds" , ((long)con.crval) );
				    csetp -> csettype = NIL;
				}
			    }
#endif CONSETS
			} else {
			    csetp -> comptime = FALSE;
			    t = rvalue((int *) e, NLNIL , RREQ );
			    if (t == NIL) {
				    goto singhang;
			    }
			}
			if (incompat(t, exptype, e)) {
				cerror("Element type clashed with set type in constant set");
			}
singhang:
			    /*
			     *	take this expression off the tree list and
			     *	hang it on the list of singletons.
			     */
			ip = el[2];
			el[2] = singp;
			singp = r[2];
			r[2] = ip;
			csetp -> singcnt++;
		}
	}
	codeon();
#	ifdef PC
	    if ( pairp != NIL ) {
		for ( el = pairp ; el[2] != NIL ; el = el[2] ) /* void */;
		el[2] = singp;
		r[2] = pairp;
	    } else {
		r[2] = singp;
	    }
#	endif PC
#	ifdef OBJ
	    if ( singp != NIL ) {
		for ( el = singp ; el[2] != NIL ; el = el[2] ) /* void */;
		el[2] = pairp;
		r[2] = singp;
	    } else {
		r[2] = pairp;
	    }
#	endif OBJ
	if ( csetp -> csettype == NIL ) {
	    csetp -> comptime = TRUE;
	}
	return csetp -> comptime;
}

#ifdef CONSETS
    /*
     *	mask[i] has the low i bits turned off.
     */
long	mask[] = {
#		ifdef DEC11
		    0xffffffff , 0xfffffffe , 0xfffffffc , 0xfffffff8 ,
		    0xfffffff0 , 0xffffffe0 , 0xffffffc0 , 0xffffff80 ,
		    0xffffff00 , 0xfffffe00 , 0xfffffc00 , 0xfffff800 ,
		    0xfffff000 , 0xffffe000 , 0xffffc000 , 0xffff8000 ,
		    0xffff0000 , 0xfffe0000 , 0xfffc0000 , 0xfff80000 ,
		    0xfff00000 , 0xffe00000 , 0xffc00000 , 0xff800000 ,
		    0xff000000 , 0xfe000000 , 0xfc000000 , 0xf8000000 ,
		    0xf0000000 , 0xe0000000 , 0xc0000000 , 0x80000000 ,
		    0x00000000
#		else
		    0xffffffff , 0xfeffffff , 0xfcffffff , 0xf8ffffff ,
		    0xf0ffffff , 0xe0ffffff , 0xc0ffffff , 0x80ffffff ,
		    0x00ffffff , 0x00feffff , 0x00fcffff , 0x00f8ffff ,
		    0x00f0ffff , 0x00e0ffff , 0x00c0ffff , 0x0080ffff ,
		    0x0000ffff , 0x0000feff , 0x0000fcff , 0x0000f8ff ,
		    0x0000f0ff , 0x0000e0ff , 0x0000c0ff , 0x000080ff ,
		    0x000000ff , 0x000000fe , 0x000000fc , 0x000000f8 ,
		    0x000000f0 , 0x000000e0 , 0x000000c0 , 0x00000080 ,
		    0x00000000
#		endif DEC11
	    };
    /*
     *	given a csetstr, either
     *	    put out a compile time constant set and an lvalue to it.
     *	or
     *	    put out rvalues for the singletons and the pairs
     *	    and counts of each.
     */
#endif CONSETS
postcset( r , csetp )
    int			*r;
    struct csetstr	*csetp;
    {
	register int	*el;
	register int	*e;
	int		lower;
	int		upper;
	int		lowerdiv;
	int		lowermod;
	int		upperdiv;
	int		uppermod;
	int		label;
	long		*lp;
	long		*limit;
	long		tempset[ COMPSETSZE ];
	long		temp;
	char		*cp;
#	ifdef PC
	    char	labelname[ BUFSIZ ];
#	endif PC

	if ( csetp -> comptime ) {
#ifdef CONSETS
	    setran( ( csetp -> csettype ) -> type );
	    limit = &tempset[ ( set.uprbp >> LG2BITSLONG ) + 1 ];
	    for ( lp = &tempset[0] ; lp < limit ; lp++ ) {
		*lp = 0;
	    }
	    for ( el = r[2] ; el != NIL ; el = el[2] ) {
		e = el[1];
		if ( e[0] == T_RANG ) {
		    constval( e[1] );
		    lower = con.crval;
		    constval( e[2] );
		    upper = con.crval;
		    if ( upper < lower ) {
			continue;
		    }
		    lowerdiv = ( lower - set.lwrb ) >> LG2BITSLONG;
		    lowermod = ( lower - set.lwrb ) & MSKBITSLONG;
		    upperdiv = ( upper - set.lwrb ) >> LG2BITSLONG;
		    uppermod = ( upper - set.lwrb ) & MSKBITSLONG;
		    temp = mask[ lowermod ];
		    if ( lowerdiv == upperdiv ) {
			temp &= ~mask[ uppermod + 1 ];
		    }
		    tempset[ lowerdiv ] |= temp;
		    limit = &tempset[ upperdiv-1 ];
		    for ( lp = &tempset[ lowerdiv+1 ] ; lp <= limit ; lp++ ) {
			*lp |= 0xffffffff;
		    }
		    if ( lowerdiv != upperdiv ) {
			tempset[ upperdiv ] |= ~mask[ uppermod + 1 ];
		    }
		} else {
		    constval( e );
		    temp = con.crval - set.lwrb;
		    cp = (char *)tempset;
		    cp[temp >> LG2BITSBYTE] |= (1 << (temp & MSKBITSBYTE));
		}
	    }
	    if ( cgenflg )
		return;
#	    ifdef PC
		putprintf( "	.data" , 0 );
		putprintf( "	.align 2" , 0 );
		label = getlab();
		putlab( label );
		lp = &( tempset[0] );
		limit = &tempset[ ( set.uprbp >> LG2BITSLONG ) + 1 ];
		while ( lp < limit ) {
		    putprintf( "	.long	0x%x" , 1 , *lp ++ );
		    for ( temp = 2 ; ( temp <= 8 ) && lp < limit ; temp ++ ) {
			putprintf( ",0x%x" , 1 , *lp++ );
		    }
		    putprintf( "" , 0 );
		}
		putprintf( "	.text" , 0 );
		sprintf( labelname , PREFIXFORMAT , LABELPREFIX , label );
		putleaf( P2ICON , 0 , 0 , P2PTR | P2STRTY , labelname );
#	    endif PC
#	    ifdef OBJ
		put(2, O_CON, (int)(((set.uprbp >> LG2BITSLONG) + 1) *
				 (BITSPERLONG >> LG2BITSBYTE)));
		lp = &( tempset[0] );
		limit = &tempset[ ( set.uprbp >> LG2BITSLONG ) + 1 ];
		while ( lp < limit ) {
		    put(2, O_CASE4, *lp ++);
		}
#	    endif OBJ
#else
		panic("const cset");
#endif CONSETS
	} else {
#	    ifdef PC
		putleaf( P2ICON , csetp -> paircnt , 0 , P2INT , 0 );
		putop( P2LISTOP , P2INT );
		putleaf( P2ICON , csetp -> singcnt , 0 , P2INT , 0 );
		putop( P2LISTOP , P2INT );
		for ( el = r[2] ; el != NIL ; el = el[2] ) {
		    e = el[1];
		    if ( e[0] == T_RANG ) {
			rvalue( e[2] , NIL , RREQ );
			putop( P2LISTOP , P2INT );
			rvalue( e[1] , NIL , RREQ );
			putop( P2LISTOP , P2INT );
		    } else {
			rvalue( e , NIL , RREQ );
			putop( P2LISTOP , P2INT );
		    }
		}
#	    endif PC
#	    ifdef OBJ
		for ( el = r[2] ; el != NIL ; el = el[2] ) {
		    e = el[1];
		    if ( e[0] == T_RANG ) {
			stkrval( e[1] , NIL , RREQ );
			stkrval( e[2] , NIL , RREQ );
		    } else {
			stkrval( e , NIL , RREQ );
		    }
		}
		put(2 , O_CON24 , (int)csetp -> singcnt );
		put(2 , O_CON24 , (int)csetp -> paircnt );
#	    endif OBJ
	}
}