ack/lang/pc/comp/cstoper.c

/* C O N S T A N T   E X P R E S S I O N   H A N D L I N G */

#include	"debug.h"
#include	"target_sizes.h"

#include	<alloc.h>
#include	<assert.h>
#include	<em_arith.h>
#include	<em_label.h>

#include	"LLlex.h"
#include	"Lpars.h"
#include	"const.h"
#include	"node.h"
#include	"required.h"
#include	"type.h"

long mach_long_sign;	/* sign bit of the machine long */
int mach_long_size;	/* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int;		/* maximum integer on target machine	*/
char *maxint_str;	/* string representation of maximum integer */
arith wrd_bits;		/* number of bits in a word */
arith max_intset;	/* largest value of set of integer */

cstunary(expp)
	register struct node *expp;
{
	/*	The unary operation in "expp" is performed on the constant
		expression below it, and the result restored in expp.
	*/
	register arith o1 = expp->nd_right->nd_INT;

	switch( expp->nd_symb )	{
		/* Should not get here
		case '+':
		case '(':
			break;
		*/

		case '-':
			o1 = -o1;
			break;

		case NOT:
			o1 = !o1;
			break;

		default:
			crash("(cstunary)");
	}

	expp->nd_class = Value;
	expp->nd_token = expp->nd_right->nd_token;
	expp->nd_INT = o1;
	CutSize(expp);
	FreeNode(expp->nd_right);
	expp->nd_right = NULLNODE;
}

cstbin(expp)
	register struct node *expp;
{
	/*	The binary operation in "expp" is performed on the constant
		expressions below it, and the result restored in expp.
	*/
	register arith o1, o2;
	register char *s1, *s2;
	int str = expp->nd_left->nd_type->tp_fund & T_STRING;

	if( str )	{
		s1 = expp->nd_left->nd_STR;
		s2 = expp->nd_right->nd_STR;
	}
	else	{
		o1 = expp->nd_left->nd_INT;
		o2 = expp->nd_right->nd_INT;
	}

	assert(expp->nd_class == Boper);
	assert(expp->nd_left->nd_class == Value);
	assert(expp->nd_right->nd_class == Value);

	switch( expp->nd_symb )	{
		case '+':
			o1 += o2;
			break;

		case '-':
			o1 -= o2;
			break;

		case '*':
			o1 *= o2;
			break;

		case DIV:
			if( o2 == 0 )	{
				node_error(expp, "division by 0");
				return;
			}
			else o1 /= o2;
			break;

		case MOD:
			if( o2 == 0 )	{
				node_error(expp, "modulo by 0");
				return;
			}
			else
				o1 %= o2;
			break;

		case OR:
			o1 = (o1 || o2);
			break;

		case AND:
			o1 = (o1 && o2);
			break;

		case '=':
			o1 = str ? !strcmp(s1, s2) : (o1 == o2);
			break;

		case NOTEQUAL:
			o1 = str ? (strcmp(s1, s2) != 0) : (o1 != o2);
			break;

		case LESSEQUAL:
			o1 = str ? (strcmp(s1, s2) <= 0) : (o1 <= o2);
			break;

		case GREATEREQUAL:
			o1 = str ? (strcmp(s1, s2) >= 0) : (o1 >= o2);
			break;

		case '<':
			o1 = str ? (strcmp(s1, s2) < 0) : (o1 < o2);
			break;

		case '>':
			o1 = str ? (strcmp(s1, s2) > 0) : (o1 > o2);
			break;

		/* case '/': */
		default:
			crash("(cstbin)");

	}

	expp->nd_class = Value;
	expp->nd_token = expp->nd_right->nd_token;
	/* STRING compare has a bool_type as result */
	if( expp->nd_type == bool_type ) expp->nd_symb = INTEGER;
	expp->nd_INT = o1;
	CutSize(expp);
	FreeNode(expp->nd_left);
	FreeNode(expp->nd_right);
	expp->nd_left = expp->nd_right = NULLNODE;
}

cstset(expp)
	register struct node *expp;
{
	register arith *set1, *set2;
	arith *resultset = (arith *) 0;
	int empty_result = 0;
	register int setsize, j;

	assert(expp->nd_right->nd_class == Set);
	assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
	set2 = expp->nd_right->nd_set;
	setsize = expp->nd_right->nd_type->tp_size / word_size;

	if( expp->nd_symb == IN )	{
		arith i;

		assert(expp->nd_left->nd_class == Value);

		i = expp->nd_left->nd_INT;
		expp->nd_class = Value;
		expp->nd_symb = INTEGER;

		expp->nd_INT = (i >= 0 && set2 && i < (setsize * wrd_bits) &&
				(set2[i/wrd_bits] & (1 << (i%wrd_bits))));

		if( set2 ) free((char *) set2);
	}
	else	{
		set1 = expp->nd_left->nd_set;
		resultset = set1;
		expp->nd_left->nd_set = (arith *) 0;
		switch( expp->nd_symb )	{
		case '+':
			/* Set union
			*/
			if( !set1 )	{
				resultset = set2;
				expp->nd_right->nd_set = (arith *) 0;
				break;
			}
			if( set2 )
				for( j = 0; j < setsize; j++ )
					*set1++ |= *set2++;
			break;

		case '-':
			/* Set difference
			*/
			if( !set1 || !set2 )	{
				/* The set from which something is substracted
				   is already empty, or the set that is
				   substracted is empty. In either case, the
				   result set is set1.
				*/
				break;
			}
			empty_result = 1;
			for( j = 0; j < setsize; j++ )
				if( *set1++ &= ~*set2++ ) empty_result = 0;
			break;

		case '*':
			/* Set intersection
			*/
			if( !set1 )	{
				/* set1 is empty, and so is the result set
				*/
				break;
			}
			if( !set2 )	{
				/* set 2 is empty, so the result set must be
				   empty too.
				*/
				resultset = set2;
				expp->nd_right->nd_set = (arith *) 0;
				break;
			}
			empty_result = 1;
			for( j = 0; j < setsize; j++ )
				if( *set1++ &= *set2++ ) empty_result = 0;
			break;

		case '=':
		case NOTEQUAL:
		case LESSEQUAL:
		case GREATEREQUAL:
			/* Constant set comparisons
			*/
			if( !setsize ) setsize++;	/* force comparison */
			expp->nd_left->nd_set = set1;	/* may be disposed of */
			for( j = 0; j < setsize; j++ )	{
				switch( expp->nd_symb )	{
				case '=':
				case NOTEQUAL:
					if( !set1 && !set2 )	{
						j = setsize;
						break;
					}
					if( !set1 || !set2 ) break;
					if( *set1++ != *set2++ ) break;
					continue;
				case LESSEQUAL:
					if( !set1 )	{
						j = setsize;
						break;
					}
					if( !set2 ) break;
					if( (*set2 | *set1++) != *set2 ) break;
					set2++;
					continue;
				case GREATEREQUAL:
					if( !set2 )	{
						j = setsize;
						break;
					}
					if( !set1 ) break;
					if( (*set1 | *set2++) != *set1 ) break;
					set1++;
					continue;
				}
				break;
			}
			if( j < setsize )
				expp->nd_INT = expp->nd_symb == NOTEQUAL;
			else
				expp->nd_INT = expp->nd_symb != NOTEQUAL;
			expp->nd_class = Value;
			expp->nd_symb = INTEGER;
			if( expp->nd_left->nd_set )
				free((char *) expp->nd_left->nd_set);
			if( expp->nd_right->nd_set )
				free((char *) expp->nd_right->nd_set);
			FreeNode(expp->nd_left);
			FreeNode(expp->nd_right);
			expp->nd_left = expp->nd_right = NULLNODE;
			return;
		default:
			crash("(cstset)");
		}
		if( expp->nd_right->nd_set )
			free((char *) expp->nd_right->nd_set);
		if( expp->nd_left->nd_set )
			free((char *) expp->nd_left->nd_set);
		if( empty_result )	{
			free((char *) resultset);
			resultset = (arith *) 0;
		}
		expp->nd_class = Set;
		expp->nd_set = resultset;
	}
	FreeNode(expp->nd_left);
	FreeNode(expp->nd_right);
	expp->nd_left = expp->nd_right = NULLNODE;
}

cstcall(expp, req)
	register struct node *expp;
{
	/*	a standard procedure call is found that can be evaluated
		compile time, so do so.
	*/
	register struct node *expr = NULLNODE;

	assert(expp->nd_class == Call);

	expr = expp->nd_right->nd_left;

	expp->nd_class = Value;
	expp->nd_symb = INTEGER;
	switch( req )	{
	    case R_ABS:
		if( expr->nd_INT < 0 ) expp->nd_INT = - expr->nd_INT;
		else expp->nd_INT = expr->nd_INT;
		CutSize(expp);
		break;

	    case R_SQR:
		expp->nd_INT = expr->nd_INT * expr->nd_INT;
		CutSize(expp);
		break;

	    case R_ORD:
	    case R_CHR:
		expp->nd_INT = expr->nd_INT;
		CutSize(expp);
		break;

	    case R_ODD:
		expp->nd_INT = (expr->nd_INT & 1);
		break;

	    case R_SUCC:
		expp->nd_INT = expr->nd_INT + 1;
		if(	/* Check overflow of subranges or enumerations */
			(expp->nd_type->tp_fund & T_SUBRANGE &&
				expp->nd_INT > expp->nd_type->sub_ub
			)
		   ||
			( expp->nd_type->tp_fund & T_ENUMERATION &&
				expp->nd_INT >= expp->nd_type->enm_ncst
			)
		  )
			node_warning(expp, "\"succ\": no successor");
		else CutSize(expp);
		break;

	    case R_PRED:
		expp->nd_INT = expr->nd_INT - 1;
		if(	/* Check with lowerbound of subranges or enumerations */
			(expp->nd_type->tp_fund & T_SUBRANGE &&
				expp->nd_INT < expp->nd_type->sub_lb
			)
		   ||
			( expp->nd_type->tp_fund & T_ENUMERATION &&
				expp->nd_INT < 0
			)
		  )
			node_warning(expp, "\"pred\": no predecessor");
		else CutSize(expp);
		break;

	    default:
		crash("(cstcall)");
	}
	FreeNode(expp->nd_left);
	FreeNode(expp->nd_right);
	expp->nd_right = expp->nd_left = NULLNODE;
}

CutSize(expr)
	register struct node *expr;
{
	/* The constant value of the expression expr is made to conform
	 * to the size of the type of the expression
	 */
	register arith o1 = expr->nd_INT;
	register struct type *tp = BaseType(expr->nd_type);
	int size = tp->tp_size;
	long remainder = o1 & ~full_mask[size];

	assert(expr->nd_class == Value);

	if( tp->tp_fund & T_CHAR )	{
		if( o1 & (~full_mask[size] >> 1) ) 	{
			node_warning(expr, "overflow in character value");
			o1 &= 0177;
		}
	}
	else if( remainder != 0 && remainder != ~full_mask[size] ||
	    		(o1 & full_mask[size]) == 1 << (size * 8 - 1) )	{
		/* integers in [-maxint .. maxint] */
		int nbits = (int) (mach_long_size - size) * 8;

		node_warning(expr, "overflow in constant expression");
		/* sign bit of o1 in sign bit of mach_long */
		o1 <<= nbits;
		/* shift back to get sign extension */
		o1 >>= nbits;
	}
	expr->nd_INT = o1;
}

InitCst()
{
	extern char *long2str(), *Salloc();
	register int i = 0;
	register arith bt = (arith)0;

	while( !(bt < 0) )	{
		bt = (bt << 8) + 0377;
		i++;
		if( i == MAXSIZE + 1 )
			fatal("array full_mask too small for this machine");
		full_mask[i] = bt;
	}
	mach_long_size = i;
	mach_long_sign = 1 << (mach_long_size * 8 - 1);
	if( int_size > mach_long_size )
		fatal("sizeof (long) insufficient on this machine");

	max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
	maxint_str = long2str(max_int, 10);
	maxint_str = Salloc(maxint_str, (unsigned int) strlen(maxint_str));
	wrd_bits = 8 * word_size;
	if( !max_intset ) max_intset = wrd_bits - 1;
}