ack/lang/m2/comp/cstoper.c

/*
 * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
 * See the copyright notice in the ACK home directory, in the file "Copyright".
 *
 * Author: Ceriel J.H. Jacobs
 */

/* 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 */

/* $Id$ */

#include <stdlib.h>
#include "parameters.h"
#include	"debug.h"

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

#include	"idf.h"
#include	"type.h"
#include	"LLlex.h"
#include	"node.h"
#include	"Lpars.h"
#include	"standards.h"
#include	"warning.h"

extern char	*symbol2str();

#define arith_sign	((arith) (1L << (sizeof(arith) * 8 - 1)))

#ifndef NOCROSS
arith full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int[MAXSIZE+1]; /* max_int[1] == 0x7F, max_int[2] == 0x7FFF, .. */
arith min_int[MAXSIZE+1]; /* min_int[1] == 0xFFFFFF80, min_int[2] = 0xFFFF8000,
			     ...
			  */
unsigned int wrd_bits;	/* number of bits in a word */
#else
arith full_mask[] = { 0L, 0xFFL, 0xFFFFL, 0L, 0xFFFFFFFFL };
arith max_int[] =   { 0L, 0x7FL, 0x7FFFL, 0L, 0x7FFFFFFFL };
arith min_int[] =   { 0L, -128L, -32768L, 0L, -2147483647L-1 };
#endif

extern char options[];

overflow(expp)
	t_node *expp;
{
	if (expp->nd_type != address_type) {
	    node_warning(expp, W_ORDINARY, "overflow in constant expression");
	}
}

STATIC
commonbin(expp)
	t_node **expp;
{
	register t_node *exp = *expp;
	t_type *tp = exp->nd_type;
	register t_node *right = exp->nd_RIGHT;
	
	exp->nd_RIGHT = 0;
	FreeNode(exp);
	*expp = right;
	right->nd_type = tp;
}

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

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

	case '-':
		if (! options['s'] &&
		    o1 == min_int[(int)(right->nd_type->tp_size)]) {
			overflow(exp);
		}
		o1 = -o1;
		break;

	case NOT:
	case '~':
		o1 = !o1;
		break;

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

	commonbin(expp);
	(*expp)->nd_INT = o1;
	CutSize(*expp);
}

STATIC
divide(pdiv, prem)
	arith *pdiv, *prem;
{
	/*	Unsigned divide *pdiv by *prem, and store result in *pdiv,
		remainder in *prem
	*/
	register arith o1 = *pdiv;
	register arith o2 = *prem;

#ifndef UNSIGNED_ARITH
	/*	this is more of a problem than you might
		think on C compilers which do not have
		unsigned long.
	*/
	if (o2 & arith_sign)	{/* o2 > max_arith */
		if (! (o1 >= 0 || o1 < o2)) {
			/*	this is the unsigned test
				o1 < o2 for o2 > max_arith
			*/
			*prem = o2 - o1;
			*pdiv = 1;
		}
		else {
			*pdiv = 0;
		}
	}
	else	{		/* o2 <= max_arith */
		arith half, bit, hdiv, hrem, rem;

		half = (o1 >> 1) & ~arith_sign;
		bit = o1 & 01;
		/*	now o1 == 2 * half + bit
			and half <= max_arith
			and bit <= max_arith
		*/
		hdiv = half / o2;
		hrem = half % o2;
		rem = 2 * hrem + bit;
		*pdiv = 2*hdiv;
		*prem = rem;
		if (rem < 0 || rem >= o2) {
			/*	that is the unsigned compare
				rem >= o2 for o2 <= max_arith
			*/
			*pdiv += 1;
			*prem -= o2;
		}
	}
#else
	*pdiv = (UNSIGNED_ARITH) o1 / (UNSIGNED_ARITH) o2;
	*prem = (UNSIGNED_ARITH) o1 % (UNSIGNED_ARITH) o2;
#endif
}

cstibin(expp)
	t_node **expp;
{
	/*	The binary operation in "expp" is performed on the constant
		expressions below it, and the result restored in expp.
		This version is for INTEGER expressions.
	*/
	register t_node *exp = *expp;
	register arith o1 = exp->nd_LEFT->nd_INT;
	register arith o2 = exp->nd_RIGHT->nd_INT;
	register int sz = exp->nd_type->tp_size;

	assert(exp->nd_class == Oper);
	assert(exp->nd_LEFT->nd_class == Value);
	assert(exp->nd_RIGHT->nd_class == Value);

	switch (exp->nd_symb)	{
	case '*':
		if (o1 > 0) {
			if (o2 > 0) {
				if (max_int[sz] / o1 < o2) overflow(exp);
			}
			else if (min_int[sz] / o1 > o2) overflow(exp);
		}
		else if (o1 < 0) {
			if (o2 < 0) {
				if (o1 == min_int[sz] || o2 == min_int[sz] ||
			 	   max_int[sz] / (-o1) < (-o2)) overflow(exp);
			}
			else if (o2 > 0) {
				if (min_int[sz] / o2 > o1) overflow(exp);
			}
		}
		o1 *= o2;
		break;

	case DIV:
	case MOD:
		if (o2 == 0)	{
			node_error(exp, exp->nd_symb == DIV ?
					"division by 0" :
					"modulo by 0");
			return;
		}
		if ((o1 < 0) != (o2 < 0)) {
			if (o1 < 0) o1 = -o1;
			else o2 = -o2;
			if (exp->nd_symb == DIV) o1 = -((o1+o2-1)/o2);
			else o1 = ((o1+o2-1)/o2) * o2 - o1;
		}
		else {
			if (exp->nd_symb == DIV) o1 /= o2;
			else o1 %= o2;
		}
		break;

	case '+':
		if (  (o1 > 0 && o2 > 0 && max_int[sz] - o1 < o2)
		   || (o1 < 0 && o2 < 0 && min_int[sz] - o1 > o2)
		   ) overflow(exp);
		o1 += o2;
		break;

	case '-':
		if (  (o1 >= 0 && o2 < 0 && max_int[sz] + o2 < o1)
		   || (o1 < 0 && o2 >= 0 && min_int[sz] + o2 > o1)
		   ) overflow(exp);
		o1 -= o2;
		break;

	case '<':
		o1 = (o1 < o2);
		break;

	case '>':
		o1 = (o1 > o2);
		break;

	case LESSEQUAL:
		o1 = (o1 <= o2);
		break;

	case GREATEREQUAL:
		o1 = (o1 >= o2);
		break;

	case '=':
		o1 = (o1 == o2);
		break;

	case '#':
		o1 = (o1 != o2);
		break;

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

	commonbin(expp);
	(*expp)->nd_INT = o1;
	CutSize(*expp);
}

cstfbin(expp)
	t_node **expp;
{
	/*	The binary operation in "expp" is performed on the constant
		expressions below it, and the result restored in expp.
		This version is for REAL expressions.
	*/
	register t_node *exp = *expp;
	register struct real *p = exp->nd_LEFT->nd_REAL;
	register flt_arith *o1 = &p->r_val;
	register flt_arith *o2 = &exp->nd_RIGHT->nd_RVAL;
	int compar = 0;
	int cmpval = 0;

	assert(exp->nd_class == Oper);
	assert(exp->nd_LEFT->nd_class == Value);
	assert(exp->nd_RIGHT->nd_class == Value);

	switch (exp->nd_symb)	{
	case '*':
		flt_mul(o1, o2, o1);
		break;

	case '/':
		flt_div(o1, o2, o1);
		break;

	case '+':
		flt_add(o1, o2, o1);
		break;

	case '-':
		flt_sub(o1, o2, o1);
		break;

	case '<':
	case '>':
	case LESSEQUAL:
	case GREATEREQUAL:
	case '=':
	case '#':
		compar++;
		cmpval = flt_cmp(o1, o2);
		switch(exp->nd_symb) {
		case '<':		cmpval = (cmpval < 0); break;
		case '>':		cmpval = (cmpval > 0); break;
		case LESSEQUAL:		cmpval = (cmpval <= 0); break;
		case GREATEREQUAL:	cmpval = (cmpval >= 0); break;
		case '=':		cmpval = (cmpval == 0); break;
		case '#':		cmpval = (cmpval != 0); break;
		}
		if (exp->nd_RIGHT->nd_RSTR) free(exp->nd_RIGHT->nd_RSTR);
		free_real(exp->nd_RIGHT->nd_REAL);
		break;

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

	switch(flt_status) {
	case FLT_OVFL:
		node_warning(exp, "floating point overflow on %s", 
				symbol2str(exp->nd_symb));
		break;
	case FLT_DIV0:
		node_error(exp, "division by 0.0");
		break;
	}

	if (p->r_real) {
		free(p->r_real);
		p->r_real = 0;
	}
	if (compar) {
		free_real(p);
	}
	commonbin(expp);
	exp = *expp;
	if (compar) {
		exp->nd_symb = INTEGER;
		exp->nd_INT = cmpval;
	}
	else {
		exp->nd_REAL = p;
	}
	CutSize(exp);
}

cstubin(expp)
	t_node **expp;
{
	/*	The binary operation in "expp" is performed on the constant
		expressions below it, and the result restored in
		expp.
	*/
	register t_node *exp = *expp;
	arith o1 = exp->nd_LEFT->nd_INT;
	arith o2 = exp->nd_RIGHT->nd_INT;
	register int sz = exp->nd_type->tp_size;
	arith tmp1, tmp2;

	assert(exp->nd_class == Oper);
	assert(exp->nd_LEFT->nd_class == Value);
	assert(exp->nd_RIGHT->nd_class == Value);

	switch (exp->nd_symb)	{
	case '*':
		if (o1 == 0 || o2 == 0) {
			o1 = 0;
			break;
		}
		tmp1 = full_mask[sz];
		tmp2 = o2;
		divide(&tmp1, &tmp2);
		if (! chk_bounds(o1, tmp1, T_CARDINAL)) overflow(exp);
		o1 *= o2;
		break;

	case DIV:
	case MOD:
		if (o2 == 0)	{
			node_error(exp, exp->nd_symb == DIV ? 
					"division by 0" :
					"modulo by 0");
			return;
		}
		divide(&o1, &o2);
		if (exp->nd_symb == MOD) o1 = o2;
		break;

	case '+':
		if (! chk_bounds(o2, full_mask[sz] - o1, T_CARDINAL)) {
			overflow(exp);
		}
		o1 += o2;
		break;

	case '-':
		if (  exp->nd_type != address_type
		   && !chk_bounds(o2, o1, T_CARDINAL)
		   && (  exp->nd_type->tp_fund != T_INTORCARD
	 	      || ( exp->nd_type = int_type
			 , !chk_bounds(min_int[sz], o1 - o2, T_CARDINAL) ) )
		   ) {
			node_warning(exp, W_ORDINARY,
				"underflow in constant expression");
		}
		o1 -= o2;
		break;

	case '<':
		o1 = ! chk_bounds(o2, o1, T_CARDINAL);
		break;

	case '>':
		o1 = ! chk_bounds(o1, o2, T_CARDINAL);
		break;

	case LESSEQUAL:
		o1 = chk_bounds(o1, o2, T_CARDINAL);
		break;

	case GREATEREQUAL:
		o1 = chk_bounds(o2, o1, T_CARDINAL);
		break;

	case '=':
		o1 = (o1 == o2);
		break;

	case '#':
		o1 = (o1 != o2);
		break;

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

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

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

	commonbin(expp);
	exp = *expp;
	exp->nd_INT = o1;
	if (exp->nd_type == bool_type) exp->nd_symb = INTEGER;
	CutSize(exp);
}

cstset(expp)
	t_node **expp;
{
	extern arith *MkSet();
	register t_node *exp = *expp;
	register arith *set1, *set2, *set3;
	register unsigned int setsize;
	register int j;

	assert(exp->nd_RIGHT->nd_class == Set);
	assert(exp->nd_symb == IN || exp->nd_LEFT->nd_class == Set);

	set2 = exp->nd_RIGHT->nd_set;
	setsize = (unsigned) (exp->nd_RIGHT->nd_type->tp_size) / (unsigned) word_size;

	if (exp->nd_symb == IN) {
		/*	The setsize must fit in an unsigned, as it is
			allocated with Malloc, so we can do the arithmetic
			in an unsigned too.
		*/
		unsigned i;

		assert(exp->nd_LEFT->nd_class == Value);

		exp->nd_LEFT->nd_INT -= exp->nd_RIGHT->nd_type->set_low;
		exp = exp->nd_LEFT;
		i = exp->nd_INT;
		/*	Careful here; use exp->nd_LEFT->nd_INT to see if
			it falls in the range of the set. Do not use i
			for this, as i may be truncated.
		*/
		i = (exp->nd_INT >= 0 &&
		     exp->nd_INT < setsize * wrd_bits &&
		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
		FreeSet(set2);
		exp = getnode(Value);
		exp->nd_symb = INTEGER;
		exp->nd_lineno = (*expp)->nd_lineno;
		exp->nd_INT = i;
		exp->nd_type = bool_type;
		FreeNode(*expp);
		*expp = exp;
		return;
	}

	set1 = exp->nd_LEFT->nd_set;
	*expp = getnode(Set);
	(*expp)->nd_type = exp->nd_type;
	(*expp)->nd_lineno = exp->nd_lineno;
	switch(exp->nd_symb) {
	case '+': /* Set union */
	case '-': /* Set difference */
	case '*': /* Set intersection */
	case '/': /* Symmetric set difference */
		(*expp)->nd_set = set3 = MkSet(exp->nd_type->set_sz);
		for (j = 0; j < setsize; j++) {
			switch(exp->nd_symb) {
			case '+':
				*set3++ = *set1++ | *set2++;
				break;
			case '-':
				*set3++ = *set1++ & ~*set2++;
				break;
			case '*':
				*set3++ = *set1++ & *set2++;
				break;
			case '/':
				*set3++ = *set1++ ^ *set2++;
				break;
			}
		}
		break;

	case GREATEREQUAL:
	case LESSEQUAL:
	case '=':
	case '#':
		/* Constant set comparisons
		*/
		for (j = 0; j < setsize; j++) {
			switch(exp->nd_symb) {
			case GREATEREQUAL:
				if ((*set1 | *set2++) != *set1) break;
				set1++;
				continue;
			case LESSEQUAL:
				if ((*set2 | *set1++) != *set2) break;
				set2++;
				continue;
			case '=':
			case '#':
				if (*set1++ != *set2++) break;
				continue;
			}
			break;
		}
		if (j < setsize) {
			j = exp->nd_symb == '#';
		}
		else {
			j = exp->nd_symb != '#';
		}
		*expp = getnode(Value);
		(*expp)->nd_symb = INTEGER;
		(*expp)->nd_INT = j;
		(*expp)->nd_type = bool_type;
		(*expp)->nd_lineno = (*expp)->nd_lineno;
		break;
	default:
		crash("(cstset)");
	}
	FreeSet(exp->nd_LEFT->nd_set);
	FreeSet(exp->nd_RIGHT->nd_set);
	FreeNode(exp);
}

cstcall(expp, call)
	t_node **expp;
{
	/*	a standard procedure call is found that can be evaluated
		compile time, so do so.
	*/
	register t_node *expr;
	register t_type *tp;

	assert((*expp)->nd_class == Call);
	expr = (*expp)->nd_RIGHT->nd_LEFT;
	tp = expr->nd_type;
	expr->nd_type = (*expp)->nd_type;

	(*expp)->nd_RIGHT->nd_LEFT = 0;
	FreeNode(*expp);
	*expp = expr;
	expr->nd_symb = INTEGER;
	expr->nd_class = Value;
	switch(call) {
	case S_ABS:
		if (expr->nd_INT < 0) {
			if (! options['s'] &&
			    expr->nd_INT <= min_int[(int)(tp->tp_size)]) {
				overflow(expr);
			}
			expr->nd_INT = - expr->nd_INT;
		}
		CutSize(expr);
		break;

	case S_CAP:
		if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
			expr->nd_INT += ('A' - 'a');
		}
		break;

	case S_HIGH:
	case S_MAX:
		if (tp->tp_fund == T_INTEGER) {
			expr->nd_INT = max_int[(int)(tp->tp_size)];
		}
		else if (tp->tp_fund == T_CARDINAL) {
			expr->nd_INT = full_mask[(int)(tp->tp_size)];
		}
		else if (tp->tp_fund == T_SUBRANGE) {
			expr->nd_INT = tp->sub_ub;
		}
		else	expr->nd_INT = tp->enm_ncst - 1;
		break;

	case S_MIN:
		if (tp->tp_fund == T_INTEGER) {
			expr->nd_INT = min_int[(int)(tp->tp_size)];
		}
		else if (tp->tp_fund == T_SUBRANGE) {
			expr->nd_INT = tp->sub_lb;
		}
		else	expr->nd_INT = 0;
		break;

	case S_ODD:
		expr->nd_INT &= 1;
		break;

	case S_TSIZE:
	case S_SIZE:
		expr->nd_INT = tp->tp_size;
		break;

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

CutSize(expr)
	register t_node *expr;
{
	/*	The constant value of the expression expr is made to
		conform to the size of the type of the expression.
	*/
	register t_type *tp = BaseType(expr->nd_type);

	assert(expr->nd_class == Value);
	if (tp->tp_fund == T_REAL) return;
	if (tp->tp_fund != T_INTEGER) {
		expr->nd_INT &= full_mask[(int)(tp->tp_size)];
	}
	else {
		int nbits = (int) (sizeof(arith) - tp->tp_size) * 8;

		expr->nd_INT = (expr->nd_INT << nbits) >> nbits;
	}
}

InitCst()
{
	register int i = 0;
#ifndef NOCROSS
	register arith bt = (arith)0;

	while (!(bt < 0))	{
		i++;
		bt = (bt << 8) + 0377;
		if (i == MAXSIZE+1)
			fatal("array full_mask too small for this machine");
		full_mask[i] = bt;
		max_int[i] = bt & ~(1L << ((8 * i) - 1));
		min_int[i] = - max_int[i];
		if (! options['s']) min_int[i]--;
	}
	if ((int)long_size > sizeof(arith)) {
		fatal("sizeof (arith) insufficient on this machine");
	}

	wrd_bits = 8 * (int) word_size;
#else
	if (options['s']) {
		for (i = 0; i < sizeof(long); i++) min_int[i] = - max_int[i];
	}
#endif
}