/* $Header$ */

/* This file contains the expression evaluator. It exports the following
   routines:
   - int eval_cond(p_tree p)
	This routine evaluates the conditional expression indicated by p
	and returns 1 if it evaluates to TRUE, or 0 if it could not be
	evaluated for some reason or if it evalutes to FALSE.
	If the expression cannot be evaluated, an error message is given.
   - int eval_desig(p_tree p, t_addr *paddr, long **psize, p_type *ptp)
	This routine evaluates the expression indicated by p, which should
	result in a designator. The result of the expression is an address
	which is to be found in *paddr. *psize will contain the size of the
	designated object, and *ptp its type.
	If the expression cannot be evaluated or does not result in a
	designator, 0 is returned and an error message is given.
	Otherwise, 1 is returned.
   - int eval_expr(p_tree p, char **pbuf, long **psize, p_type *ptp)
	This routine evaluates the expression indicated by p.
	The result of the expression is left in *pbuf.
	*psize will contain the size of the value, and *ptp its type.
	If the expression cannot be evaluated, 0 is returned and an error
	message is given.  Otherwise, 1 is returned.
   - int convert(char **pbuf, long *psize, p_type *ptp, p_type tp, long size)
	This routine tries to convert the value in pbuf of size psize
	and type ptp to type tp with size size. It returns 0 if this fails,
	while producing an error message. Otherwise, it returns 1 and
	the resulting value, type and size are left in pbuf, ptp, and
	psize, respectively.
   - long get_int(char *buf, long size, int class)
	Returns the value of size 'size', residing in 'buf', of 'class'
	T_INTEGER, T_UNSIGNED, or T_ENUM.
   - int put_int(char *buf, long size, long value)
	Stores the value 'value' of size 'size' in 'buf'.
   - double get_real(char *buf, long size)
	Returns the real value of size 'size', residing in 'buf'.
	T_INTEGER, T_UNSIGNED, or T_ENUM.
   - int put_real(char *buf, long size, double value)
	Stores the value 'value' of size 'size' in 'buf'.
*/

#include <stdio.h>
#include <alloc.h>
#include <assert.h>

#include "position.h"
#include "operator.h"
#include "tree.h"
#include "expr.h"
#include "symbol.h"
#include "type.h"
#include "langdep.h"
#include "scope.h"
#include "idf.h"

extern FILE	*db_out;
extern int	stack_offset;
extern char	*strcpy();
extern t_addr	*get_EM_regs();
extern char	*memcpy();

#define	malloc_succeeded(p)	if (! (p)) {\
					error("could not allocate enough memory");\
					return 0;\
				}

/* static t_addr	get_addr(p_symbol sym; long *psize);
   Get the address of the object indicated by sym. Returns 0 on failure,
   address on success. *psize will contain size of object.
   For local variables or parameters, the 'stack_offset' variable is
   used to determine from which stack frame the search must start.
*/
static t_addr
get_addr(sym, psize)
  register p_symbol	sym;
  long			*psize;
{
  p_type	tp = sym->sy_type;
  long		size = tp->ty_size;
  t_addr	*EM_regs;
  int		i;
  p_scope	sc, symsc;

  *psize = size;
  switch(sym->sy_class) {
  case VAR:
	/* exists if child exists; nm_value contains addres */
	return (t_addr) sym->sy_name.nm_value;
  case VARPAR:
  case LOCVAR:
	/* first find the stack frame in which it resides */
	symsc = base_scope(sym->sy_scope);

	/* now symsc contains the scope where the storage for sym is
	   allocated. Now find it on the stack of child.
	*/
	i = stack_offset;
	for (;;) {
		sc = 0;
		if (! (EM_regs = get_EM_regs(i++))) {
			return 0;
		}
		if (! EM_regs[1]) {
			error("%s not available", sym->sy_idf->id_text);
			return 0;
		}
		sc = base_scope(get_scope_from_addr(EM_regs[2]));
		if (! sc || sc->sc_start > EM_regs[2]) {
			error("%s not available", sym->sy_idf->id_text);
			sc = 0;
			return 0;
		}
		if (sc == symsc) break;		/* found it */
	}

	if (sym->sy_class == LOCVAR) {
		/* Either local variable or value parameter */
		return EM_regs[sym->sy_name.nm_value < 0 ? 0 : 1] +
				  (t_addr) sym->sy_name.nm_value;
	}

	/* If we get here, we have a var parameter. Get the parameters
	   of the current procedure invocation.
	*/
	{
		p_type proctype = sc->sc_definedby->sy_type;
		t_addr a;
		char *AB;

		size = proctype->ty_nbparams;
		if (has_static_link(sc)) size += pointer_size;
		AB = malloc((unsigned) size);
		if (! AB) {
			error("could not allocate enough memory");
			break;
		}
		if (! get_bytes(size, EM_regs[1], AB)) {
			break;
		}
		if ((size = tp->ty_size) == 0) {
			size = compute_size(tp, AB);
			*psize = size;
		}
		a = (t_addr) get_int(AB+sym->sy_name.nm_value, pointer_size, T_UNSIGNED);
		free(AB);
		return a;
	}
  default:
	error("%s is not a variable", sym->sy_idf->id_text);
	break;
  }
  return 0;
}

static int
get_v(a, pbuf, size)
  t_addr	a;
  char		**pbuf;
  long		size;
{
  if (a) {
	*pbuf = malloc((unsigned) size);
	if (! *pbuf) {
		error("could not allocate enough memory");
		return 0;
	}
	if (! get_bytes(size, a, *pbuf)) return 0;
  }
  return 1;
}

/* static int	get_value(p_symbol sym; char **pbuf; long *psize);
   Get the value of the symbol indicated by sym.  Return 0 on failure,
   1 on success. On success, 'pbuf' contains the value, and 'psize' contains
   the size. For 'pbuf', storage is allocated by malloc; this storage must
   be freed by caller (I don't like this any more than you do, but caller
   does not know sizes).
   For local variables or parameters, the 'stack_offset' variable is
   used to determine from which stack frame the search must start.
*/
static int
get_value(sym, pbuf, psize)
  register p_symbol	sym;
  char	**pbuf;
  long	*psize;
{
  p_type	tp = sym->sy_type;
  int		retval = 0;
  t_addr	a;
  long		size = tp->ty_size;

  *pbuf = 0;
  switch(sym->sy_class) {
  case CONST:
	*pbuf = malloc((unsigned) size);
	if (! *pbuf) {
		error("could not allocate enough memory");
		break;
	}
	switch(tp->ty_class) {
	case T_REAL:
		put_real(*pbuf, size, sym->sy_const.co_rval);
		break;
	case T_INTEGER:
	case T_SUBRANGE:
	case T_UNSIGNED:
	case T_ENUM:
		put_int(*pbuf, size, sym->sy_const.co_ival);
		break;
	case T_SET:
		memcpy(*pbuf, sym->sy_const.co_setval, (int) size);
		break;
	case T_STRING:
		memcpy(*pbuf, sym->sy_const.co_sval, (int) size);
		break;
	default:
		fatal("strange constant");
	}
	retval = 1;
	break;
  case VAR:
  case VARPAR:
  case LOCVAR:
	a = get_addr(sym, psize);
	retval = get_v(a, pbuf, *psize);
	size = *psize;
	break;
  case UBOUND:
	a = get_addr(sym->sy_descr, psize);
	retval = get_v(a, pbuf, *psize);
	if (! retval) break;
	size = get_int(*pbuf, *psize, T_INTEGER);
	retval = get_v(a+*psize, pbuf, *psize);
	if (! retval) break;
	size += get_int(*pbuf, *psize, T_INTEGER);
	put_int(*pbuf, *psize, size);
	size = *psize;
	break;
  case LBOUND:
	a = get_addr(sym->sy_descr, psize);
	retval = get_v(a, pbuf, *psize);
	break;
  }

  if (retval == 0) {
	if (*pbuf) free(*pbuf);
	*pbuf = 0;
	*psize = 0;
  }
  else *psize = size;

  return retval;
}

/* buffer to integer and vice versa routines */

long
get_int(buf, size, class)
  char	*buf;
  long	size;
  int	class;
{
  register long l;

  switch((int)size) {
  case sizeof(char):
	l = *buf;
	if (class == T_INTEGER && l >= 0x7F) l -= 256;
	else if (class != T_INTEGER && l < 0) l += 256;
	break;
  case sizeof(short):
	l = *((short *) buf);
	if (class == T_INTEGER && l >= 0x7FFF) l -= 65536;
	else if (class != T_INTEGER && l < 0) l += 65536;
	break;
  default:
	l = *((long *) buf);
  }
  return l;
}

put_int(buf, size, value)
  char	*buf;
  long	size;
  long	value;
{
  switch((int)size) {
  case sizeof(char):
	*buf = value;
	break;
  case sizeof(short):
	*((short *) buf) = value;
	break;
  default:
	*((long *) buf) = value;
	break;
  }
  /*NOTREACHED*/
}

/* buffer to real and vice versa routines */

double
get_real(buf, size)
  char	*buf;
  long	size;
{
  switch((int) size) {
  case sizeof(float):
	return *((float *) buf);
  default:
	return *((double *) buf);
  }
  /*NOTREACHED*/
}

put_real(buf, size, value)
  char	*buf;
  long	size;
  double value;
{
  switch((int)size) {
  case sizeof(float):
	*((float *) buf) = value;
	break;
  default:
	*((double *) buf) = value;
	break;
  }
  /* NOTREACHED */
}

int
convert(pbuf, psize, ptp, tp, size)
  char	**pbuf;
  long	*psize;
  register p_type *ptp;
  register p_type tp;
  long size;
{
  /* Convert the value in pbuf, of size psize and type ptp, to type
     tp and leave the resulting value in pbuf, the resulting size
     in psize, and the resulting type in ptp.
  */
  long	l;
  double d;

  if (*ptp == tp) return 1;
  if (size > *psize) {
	*pbuf = realloc(*pbuf, (unsigned int) size);
	malloc_succeeded(*pbuf);
  }
  if ((*ptp)->ty_class == T_SUBRANGE) *ptp = (*ptp)->ty_base;
  if (tp && *ptp) switch((*ptp)->ty_class) {
  case T_INTEGER:
  case T_UNSIGNED:
  case T_POINTER:
  case T_ENUM:
	l = get_int(*pbuf, *psize, (*ptp)->ty_class);
	if (tp == bool_type) l = l != 0;
	switch(tp->ty_class) {
  	case T_SUBRANGE:
  	case T_INTEGER:
  	case T_UNSIGNED:
  	case T_POINTER:
  	case T_ENUM:
		put_int(*pbuf, size, l);
		*psize = size;
		*ptp = tp;
		return 1;
	case T_REAL:
		put_real(*pbuf,
			 size,
			 (*ptp)->ty_class == T_INTEGER 
				? (double) l
				: (double) (unsigned long) l);
		*psize = size;
		*ptp = tp;
		return 1;
	default:
		break;
	}
	break;
  case T_REAL:
	d = get_real(*pbuf, *psize);
	switch(tp->ty_class) {
  	case T_ENUM:
  	case T_SUBRANGE:
  	case T_INTEGER:
  	case T_UNSIGNED:
  	case T_POINTER:
		if (tp == bool_type) put_int(*pbuf, size, (long) (d != 0));
		else put_int(*pbuf, size, (long) d);
		*psize = size;
		*ptp = tp;
		return 1;
	case T_REAL:
		put_real(*pbuf, size, d);
		*psize = size;
		*ptp = tp;
		return 1;
	default:
		break;
	}
	break;
  default:
	break;
  }
  error("illegal conversion");
  return 0;
}

int
eval_cond(p)
  p_tree	p;
{
  char	*buf;
  long	size;
  p_type tp;
  long val;
  p_type target_tp = currlang->has_bool_type ? bool_type : int_type;

  if (eval_expr(p, &buf, &size, &tp)) {
	if (convert(&buf, &size, &tp, target_tp, target_tp->ty_size)) {
		val = get_int(buf, size, T_UNSIGNED);
		free(buf);
		return (int) (val != 0);
	}
	free(buf);
  }
  return 0;
}

/* one routine for each unary operator */

static int
not_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  p_type target_tp = currlang->has_bool_type ? bool_type : int_type;

  if (eval_expr(p->t_args[0], pbuf, psize, ptp) &&
      convert(pbuf, psize, ptp, target_tp, target_tp->ty_size)) {
	put_int(*pbuf, *psize, (long) !get_int(*pbuf, *psize, T_UNSIGNED));
	return 1;
  }
  return 0;
}

static int
bnot_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  if (eval_expr(p->t_args[0], pbuf, psize, ptp)) {
	switch((*ptp)->ty_class) {
	case T_INTEGER:
	case T_ENUM:
	case T_UNSIGNED:
	case T_SUBRANGE:
		put_int(*pbuf, *psize, ~get_int(*pbuf, *psize, T_UNSIGNED));
		return 1;
	default:
		error("illegal operand type(s)");
		break;
	}
  }
  return 0;
}

static int
ptr_addr(p, paddr, psize, ptp)
  p_tree	p;
  t_addr	*paddr;
  long		*psize;
  p_type	*ptp;
{
  char	*buf;

  if (eval_expr(p->t_args[0], &buf, psize, ptp)) {
	switch((*ptp)->ty_class) {
	case T_POINTER:
		*ptp = (*ptp)->ty_ptrto;
		*psize = (*ptp)->ty_size;
		*paddr = get_int(buf, pointer_size, T_UNSIGNED);
		free(buf);
		return 1;
  	default:
		error("illegal operand of DEREF");
		free(buf);
		break;
	}
  }
  return 0;
}

static int
deref_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  t_addr addr;

  if (ptr_addr(p, &addr, psize, ptp)) {
	*pbuf = malloc((unsigned) *psize);
	malloc_succeeded(*pbuf);
	if (! get_bytes(*psize, addr, *pbuf)) {
		free(*pbuf);
		*pbuf = 0;
		return 0;
	}
	return 1;
  }
  return 0;
}

static int
addr_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  t_addr addr;

  if (eval_desig(p->t_args[0], &addr, psize, ptp)) {
	*pbuf = malloc((unsigned) pointer_size);
	malloc_succeeded(*pbuf);
	put_int(*pbuf, pointer_size, (long) addr);
	address_type->ty_ptrto = *ptp;
	*ptp = address_type;
	return 1;
  }
  return 0;
}

static int
unmin_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  if (eval_expr(p->t_args[0], pbuf, psize, ptp)) {
  	switch((*ptp)->ty_class) {
  	case T_SUBRANGE:
  	case T_INTEGER:
  	case T_ENUM:
  	case T_UNSIGNED:
		put_int(*pbuf, *psize, -get_int(*pbuf, *psize, (*ptp)->ty_class));
		return 1;
  	case T_REAL:
		put_real(*pbuf, *psize, -get_real(*pbuf, *psize));
		return 1;
  	default:
		error("illegal operand of unary -");
		break;
	}
  }
  return 0;
}

static int
unplus_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  if (eval_expr(p->t_args[0], pbuf, psize, ptp)) {
  	switch((*ptp)->ty_class) {
  	case T_SUBRANGE:
  	case T_INTEGER:
  	case T_ENUM:
  	case T_UNSIGNED:
  	case T_REAL:
		return 1;
  	default:
		error("illegal operand of unary +");
		break;
  	}
  }
  return 0;
}

static int (*un_op[])() = {
  0,
  not_op,
  deref_op,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  unplus_op,
  unmin_op,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  0,
  bnot_op,
  0,
  0,
  0,
  addr_op
};

static p_type
balance(tp1, tp2)
  p_type	tp1, tp2;
{

  if (tp1->ty_class == T_SUBRANGE) tp1 = tp1->ty_base;
  if (tp2->ty_class == T_SUBRANGE) tp2 = tp2->ty_base;
  if (tp1 == tp2) return tp2;
  if (tp2->ty_class == T_REAL) {
  	p_type tmp = tp1; tp1 = tp2; tp2 = tmp;
  }
  if (tp1->ty_class == T_REAL) {
	switch(tp2->ty_class) {
	case T_INTEGER:
	case T_UNSIGNED:
	case T_ENUM:
		return tp1;
	case T_REAL:
		return tp1->ty_size > tp2->ty_size ? tp1 : tp2;
	default:
		error("illegal type combination");
		return 0;
	}
  }
  if (tp2->ty_class == T_POINTER) {
  	p_type tmp = tp1; tp1 = tp2; tp2 = tmp;
  }
  if (tp1->ty_class == T_POINTER) {
	switch(tp2->ty_class) {
	case T_INTEGER:
	case T_UNSIGNED:
	case T_POINTER:
	case T_ENUM:
		return tp1;
	default:
		error("illegal type combination");
		return 0;
	}
  }
  if (tp2->ty_class == T_UNSIGNED) {
  	p_type tmp = tp1; tp1 = tp2; tp2 = tmp;
  }
  if (tp1->ty_class == T_UNSIGNED) {
	switch(tp2->ty_class) {
	case T_INTEGER:
	case T_UNSIGNED:
		if (tp1->ty_size >= tp2->ty_size) return tp1;
		return tp2;
	case T_ENUM:
		return tp1;
	default:
		error("illegal type combination");
		return 0;
	}
  }
  if (tp2->ty_class == T_INTEGER) {
  	p_type tmp = tp1; tp1 = tp2; tp2 = tmp;
  }
  if (tp1->ty_class == T_INTEGER) {
	switch(tp2->ty_class) {
	case T_INTEGER:
		if (tp1->ty_size >= tp2->ty_size) return tp1;
		return tp2;
	case T_ENUM:
		return tp1;
	default:
		error("illegal type combination");
		return 0;
	}
  }
  error("illegal type combination");
  return 0;
}

static int
andor_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  long		l1, l2;
  char		*buf = 0;
  long		size;
  p_type	tp;
  p_type	target_tp = currlang->has_bool_type ? bool_type : int_type;

  if (eval_expr(p->t_args[0], pbuf, psize, ptp) &&
      convert(pbuf, psize, ptp, target_tp, target_tp->ty_size) &&
      eval_expr(p->t_args[1], &buf, &size, &tp) &&
      convert(&buf, &size, &tp, target_tp, target_tp->ty_size)) {
	l1 = get_int(*pbuf, *psize, T_UNSIGNED);
	l2 = get_int(buf, size, T_UNSIGNED);
	put_int(*pbuf,
		*psize,
		p->t_whichoper == E_AND 
			? (long)(l1 && l2) 
			: (long)(l1 || l2));
	free(buf);
	return 1;
  }
  if (buf) free(buf);
  return 0;
}

static int
arith_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  long		l1, l2;
  double	d1, d2;
  char		*buf = 0;
  long		size;
  p_type	tp, balance_tp;

  if (!(eval_expr(p->t_args[0], pbuf, psize, ptp) &&
        eval_expr(p->t_args[1], &buf, &size, &tp))) {
	return 0;
  }
  if ((*ptp)->ty_class == T_POINTER) {
	if (currlang != c_dep ||
	    (p->t_whichoper != E_PLUS && p->t_whichoper != E_MIN)) {
		error("illegal operand type(s)");
		free(buf);
		return 0;
	}
	l1 = get_int(*pbuf, *psize, T_UNSIGNED);
	if (tp->ty_class == T_POINTER) {
		if (p->t_whichoper != E_MIN) {
			error("illegal operand type(s)");
			free(buf);
			return 0;
		}
		l2 = get_int(buf, size, T_UNSIGNED);
		free(buf);
		*pbuf = Realloc(*pbuf, (unsigned) long_size);
		put_int(*pbuf, long_size, (l1 - l2)/(*ptp)->ty_ptrto->ty_size);
		*ptp = long_type;
		return 1;
	}
	if (! convert(&buf, &size, &tp, long_type, long_size)) {
		free(buf);
		return 0;
	}
	l2 = get_int(buf, size, T_INTEGER) * (*ptp)->ty_ptrto->ty_size;
	free(buf);
	buf = 0;
	if (p->t_whichoper == E_PLUS) l1 += l2;
	else l1 -= l2;
	put_int(*pbuf, *psize, l1);
	return 1;
  }
  if ((balance_tp = balance(*ptp, tp)) &&
      convert(pbuf, psize, ptp, balance_tp, balance_tp->ty_size) &&
      convert(&buf, &size, &tp, balance_tp, balance_tp->ty_size)) {
	switch(balance_tp->ty_class) {
	case T_INTEGER:
	case T_ENUM:
	case T_UNSIGNED:
		l1 = get_int(*pbuf, *psize, balance_tp->ty_class);
		l2 = get_int(buf, size, balance_tp->ty_class);
		free(buf);
		buf = 0;
		switch(p->t_whichoper) {
		case E_BAND:
			l1 &= l2;
			break;
		case E_BOR:
			l1 |= l2;
			break;
		case E_BXOR:
			l1 ^= l2;
			break;
		case E_PLUS:
			l1 += l2;
			break;
		case E_MIN:
			l1 -= l2;
			break;
		case E_MUL:
			l1 *= l2;
			break;
		case E_DIV:
		case E_ZDIV:
			if (! l2) {
				error("division by 0");
				return 0;
			}
			if (balance_tp->ty_class == T_INTEGER) {
				if ((l1 < 0) != (l2 < 0)) {
					if (l1 < 0) l1 = - l1;
					else l2 = -l2;
					if (p->t_whichoper == E_DIV) {
					    l1 = -((l1+l2-1)/l2);
					}
					else {
					    l1 = -(l1/l2);
					}
				}
				else l1 /= l2;
			}
			else l1 = (unsigned long) l1 /
				  (unsigned long) l2;
			break;
		case E_MOD:
		case E_ZMOD:
			if (! l2) {
				error("modulo by 0");
				return 0;
			}
			if (balance_tp->ty_class == T_INTEGER) {
				if ((l1 < 0) != (l2 < 0)) {
					if (l1 < 0) l1 = - l1;
					else l2 = -l2;
					if (p->t_whichoper == E_MOD) {
					    l1 = ((l1+l2-1)/l2)*l2 - l1;
					}
					else {
					    l1 = (l1/l2)*l2 - l1;
					}
				}
				else l1 %= l2;
			}
			else l1 = (unsigned long) l1 %
				  (unsigned long) l2;
			break;
		}
		put_int(*pbuf, *psize, l1);
		break;
	case T_REAL:
		d1 = get_real(*pbuf, *psize);
		d2 = get_real(buf, size);
		free(buf);
		buf = 0;
		switch(p->t_whichoper) {
		case E_DIV:
		case E_ZDIV:
			if (d2 == 0.0) {
				error("division by 0.0");
				return 0;
			}
			d1 /= d2;
			break;
		case E_PLUS:
			d1 += d2;
			break;
		case E_MIN:
			d1 -= d2;
			break;
		case E_MUL:
			d1 *= d2;
			break;
		}
		put_real(*pbuf, *psize, d1);
		break;
	default:
		error("illegal operand type(s)");
		free(buf);
		return 0;
	}
	return 1;
  }
  if (buf) free(buf);
  return 0;
}

static int
sft_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  long		l1, l2;
  char		*buf = 0;
  long		size;
  p_type	tp;

  if (eval_expr(p->t_args[0], pbuf, psize, ptp) &&
      eval_expr(p->t_args[1], &buf, &size, &tp) &&
      convert(&buf, &size, &tp, int_type, int_size)) {
	tp = *ptp;
	if (tp->ty_class == T_SUBRANGE) {
		tp = tp->ty_base;
	}
	switch(tp->ty_class) {
	case T_INTEGER:
	case T_ENUM:
	case T_UNSIGNED:
		l1 = get_int(*pbuf, *psize, tp->ty_class);
		l2 = get_int(buf, size, T_INTEGER);
		free(buf);
		buf = 0;
		switch(p->t_whichoper) {
		case E_LSFT:
			l1 <<= (int) l2;
			break;
		case E_RSFT:
			if (tp->ty_class == T_INTEGER) l1 >>= (int) l2;
			else l1 = (unsigned long) l1 >> (int) l2;
			break;
		}
		break;
	default:
		error("illegal operand type(s)");
		free(buf);
		return 0;
	}
	return 1;
  }
  if (buf) free(buf);
  return 0;
}

static int
cmp_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  long		l1, l2;
  double	d1, d2;
  char		*buf = 0;
  long		size;
  p_type	tp, balance_tp;

  if (eval_expr(p->t_args[0], pbuf, psize, ptp) &&
      eval_expr(p->t_args[1], &buf, &size, &tp) &&
      (balance_tp = balance(*ptp, tp)) &&
      convert(pbuf, psize, ptp, balance_tp, balance_tp->ty_size) &&
      convert(&buf, &size, &tp, balance_tp, balance_tp->ty_size)) {
	switch(balance_tp->ty_class) {
	case T_INTEGER:
	case T_ENUM:
	case T_UNSIGNED:
	case T_POINTER:
		l1 = get_int(*pbuf, *psize, balance_tp->ty_class);
		l2 = get_int(buf, size, balance_tp->ty_class);
		free(buf);
		buf = 0;
		switch(p->t_whichoper) {
		case E_EQUAL:
			l1 = l1 == l2;
			break;
		case E_NOTEQUAL:
			l1 = l1 != l2;
			break;
		case E_LTEQUAL:
			if (balance_tp->ty_class == T_INTEGER) {
				l1 = l1 <= l2;
			}
			else	l1 = (unsigned long) l1 <=
				     (unsigned long) l2;
			break;
		case E_LT:
			if (balance_tp->ty_class == T_INTEGER) {
				l1 = l1 < l2;
			}
			else	l1 = (unsigned long) l1 <
				     (unsigned long) l2;
			break;
		case E_GTEQUAL:
			if (balance_tp->ty_class == T_INTEGER) {
				l1 = l1 >= l2;
			}
			else	l1 = (unsigned long) l1 >=
				     (unsigned long) l2;
			break;
		case E_GT:
			if (balance_tp->ty_class == T_INTEGER) {
				l1 = l1 > l2;
			}
			else	l1 = (unsigned long) l1 >
				     (unsigned long) l2;
			break;
		default:
			l1 = 0;
			assert(0);
			break;
		}
		break;
	case T_REAL:
		d1 = get_real(*pbuf, *psize);
		d2 = get_real(buf, size);
		free(buf);
		buf = 0;
		switch(p->t_whichoper) {
		case E_EQUAL:
			l1 = d1 == d2;
			break;
		case E_NOTEQUAL:
			l1 = d1 != d2;
			break;
		case E_LTEQUAL:
			l1 = d1 <= d2;
			break;
		case E_LT:
			l1 = d1 < d2;
			break;
		case E_GTEQUAL:
			l1 = d1 >= d2;
			break;
		case E_GT:
			l1 = d1 > d2;
			break;
		default:
			l1 = 0;
			assert(0);
			break;
		}
		break;
	default:
		error("illegal operand type(s)");
		free(buf);
		return 0;
	}
	if (*psize < int_size) {
		*psize = int_size;
		*pbuf = realloc(*pbuf, (unsigned int) int_size);
		malloc_succeeded(*pbuf);
	}
	else	*psize = int_size;
	if (currlang->has_bool_type) {
		*ptp = bool_type;
	}
	else	*ptp = int_type;
	put_int(*pbuf, *psize, l1);
	return 1;
  }
  if (buf) free(buf);
  return 0;
}

static int
in_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  long		l;
  char		*buf = 0;
  long		size;
  p_type	tp;
  int		sft = int_size == 2 ? 4 : 5;

  if (eval_expr(p->t_args[0], pbuf, psize, ptp) &&
      eval_expr(p->t_args[1], &buf, &size, &tp)) {
	if (tp->ty_class != T_SET) {
		error("right-hand side of IN not a set");
		free(buf);
		return 0;
	}
	if (! convert(pbuf, psize, ptp, tp->ty_setbase, int_size)) {
		free(buf);
		return 0;
	}
	l = get_int(*pbuf, *psize, (*ptp)->ty_class) - tp->ty_setlow;
	l = l >= 0 
	    && l <= (size << 3) 
	    && (((int *) buf)[(int)(l>>sft)] & (1 << (l & ((1 << sft)-1))));
	free(buf);
	*pbuf = realloc(*pbuf, (unsigned) int_size);
	malloc_succeeded(*pbuf);
	*psize = int_size;
	*ptp = currlang->has_bool_type ? bool_type : int_type;
	put_int(*pbuf, *psize, l);
	return 1;
  }
  return 0;
}

static int
array_addr(p, paddr, psize, ptp)
  p_tree	p;
  t_addr	*paddr;
  long		*psize;
  p_type	*ptp;
{
  long		l;
  char		*buf = 0;
  long		size;
  p_type	tp;

  if (eval_desig(p->t_args[0], paddr, psize, ptp) &&
      eval_expr(p->t_args[1], &buf, &size, &tp)) {
	if ((*ptp)->ty_class != T_ARRAY && (*ptp)->ty_class != T_POINTER) {
		error("illegal left-hand side of [");
		free(buf);
		return 0;
	}
	if ((*ptp)->ty_class == T_POINTER) {
		if (! get_bytes(pointer_size, *paddr, (char *) paddr)) {
			free(buf);
			return 0;
		}
		*paddr = get_int((char *) paddr, pointer_size, T_UNSIGNED);
	}
	if (! convert(&buf, &size, &tp, int_type, int_size)) {
		free(buf);
		return 0;
	}
	l = get_int(buf, size, T_INTEGER);
	free(buf);
	buf = 0;
	if ((*ptp)->ty_class == T_ARRAY) {
	    	if (l < (*ptp)->ty_lb || l > (*ptp)->ty_hb) {
			error("array bound error");
			return 0;
		}
		l -= (*ptp)->ty_lb;
		*ptp = (*ptp)->ty_elements;
		l *= (*currlang->arrayelsize)((*ptp)->ty_size);
	}
	else {
		*ptp = (*ptp)->ty_ptrto;
		l *= (*ptp)->ty_size;
	}
	*psize = (*ptp)->ty_size;
	*paddr += l;
	return 1;
  }
  return 0;
}

static int
array_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  t_addr	a;

  if (array_addr(p, &a, psize, ptp)) {
	*pbuf = malloc((unsigned int) *psize);
	malloc_succeeded(*pbuf);
	if (! get_bytes(*psize, a, *pbuf)) {
		return 0;
	}
	return 1;
  }
  return 0;
}

static int
select_addr(p, paddr, psize, ptp)
  p_tree	p;
  t_addr	*paddr;
  long		*psize;
  p_type	*ptp;
{
  register p_type	tp;
  register struct fields *f;
  register int		nf;

  if (eval_desig(p->t_args[0], paddr, psize, ptp)) {
	tp = *ptp;
	if (tp->ty_class != T_STRUCT && tp->ty_class != T_UNION) {
		error("SELECT on non-struct");
		return 0;
	}
	if (p->t_args[1]->t_oper != OP_NAME) {
		error("right-hand side of SELECT not a name");
		return 0;
	}
	for (nf = tp->ty_nfields, f = tp->ty_fields; nf; nf--, f++) {
		if (! strcmp(f->fld_name, p->t_args[1]->t_str)) break;
	}
	if (! nf) {
		error("'%s' not found", p->t_args[1]->t_str);
		return 0;
	}
	
	/* ??? this needs some work for bitfields ??? */
	*paddr += f->fld_pos>>3;
	*psize = f->fld_bitsize >> 3;
	*ptp = f->fld_type;
	return 1;
  }
  return 0;
}

static int
select_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  t_addr	a;
  if (select_addr(p, &a, psize, ptp)) {
	*pbuf = malloc((unsigned int) *psize);
	malloc_succeeded(*pbuf);
	if (! get_bytes(*psize, a, *pbuf)) {
		free(*pbuf);
		*pbuf = 0;
		return 0;
	}
	return 1;
  }
  return 0;
}

static int
derselect_op(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  int	retval;
  t_tree	t;

  t.t_oper = OP_UNOP;
  t.t_whichoper = E_DEREF;
  t.t_args[0] = p->t_args[0];
  p->t_args[0] = &t;
  p->t_whichoper = E_SELECT;
  retval = eval_expr(p, pbuf, psize, ptp);
  p->t_args[0] = t.t_args[0];
  p->t_whichoper = E_DERSELECT;
  return retval;
}

static int (*bin_op[])() = {
  0,
  0,
  0,
  andor_op,
  andor_op,
  arith_op,
  arith_op,
  arith_op,
  arith_op,
  in_op,
  array_op,
  arith_op,
  arith_op,
  arith_op,
  cmp_op,
  cmp_op,
  cmp_op,
  cmp_op,
  cmp_op,
  cmp_op,
  select_op,
  arith_op,
  arith_op,
  arith_op,
  0,
  derselect_op,
  sft_op,
  sft_op,
  0
};

int
eval_expr(p, pbuf, psize, ptp)
  p_tree	p;
  char		**pbuf;
  long		*psize;
  p_type	*ptp;
{
  register p_symbol	sym;
  int		retval = 0;

  *pbuf = 0;

  switch(p->t_oper) {
  case OP_FORMAT:
	if (eval_expr(p->t_args[0], pbuf, psize, ptp)) retval = 1;
	break;
  case OP_NAME:
  case OP_SELECT:
	sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR|CONST|LBOUND|UBOUND);
	if (! sym) return 0;
	if (! get_value(sym, pbuf, psize)) {
		break;
	}
	*ptp = sym->sy_type;
	retval = 1;
	break;

  case OP_INTEGER:
	*pbuf = malloc((unsigned int) long_size);
	malloc_succeeded(*pbuf);
	*psize = long_size;
	*ptp = long_type;
	put_int(*pbuf, long_size, p->t_ival);
	retval = 1;
	break;

  case OP_REAL:
	*pbuf = malloc((unsigned int) double_size);
	malloc_succeeded(*pbuf);
	*psize = double_size;
	*ptp = double_type;
	put_real(*pbuf, double_size, p->t_fval);
	retval = 1;
	break;

  case OP_STRING:
	*psize = strlen(p->t_sval)+1;
	*pbuf = malloc((unsigned int)*psize);
	malloc_succeeded(*pbuf);
	*ptp = string_type;
	strcpy(*pbuf, p->t_sval);
	retval = 1;
	break;

  case OP_UNOP:
	retval = (*un_op[p->t_whichoper])(p, pbuf, psize, ptp);
	break;

  case OP_BINOP:
	retval = (*bin_op[p->t_whichoper])(p, pbuf, psize, ptp);
	break;
  default:
	assert(0);
	break;
  }
  if (! retval) {
	if (*pbuf) {
		free(*pbuf);
		*pbuf = 0;
	}
	*psize = 0;
  }
  else {
	if ((*ptp)->ty_class == T_CROSS) {
		*ptp = (*ptp)->ty_cross;
		if (! *ptp) *ptp = void_type;
	}
  }
  return retval;
}

int
eval_desig(p, paddr, psize, ptp)
  p_tree	p;
  t_addr	*paddr;
  long		*psize;
  p_type	*ptp;
{
  register p_symbol	sym;
  int	retval = 0;
  t_addr a;

  switch(p->t_oper) {
  case OP_NAME:
  case OP_SELECT:
	sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR);
	if (! sym) return 0;
	if (! (a = get_addr(sym, psize))) {
		break;
	}
	*paddr = a;
	*ptp = sym->sy_type;
	retval = 1;
	break;

  case OP_UNOP:
	switch(p->t_whichoper) {
	case E_DEREF:
		if (ptr_addr(p, paddr, psize, ptp)) {
			retval = 1;
		}
		break;
	default:
		print_node(db_out, p, 0);
		fputs(" not a designator\n", db_out);
		break;
	}
	break;

  case OP_BINOP:
	switch(p->t_whichoper) {
	case E_ARRAY:
		if (array_addr(p, paddr, psize, ptp)) {
			retval = 1;
		}
		break;
	case E_SELECT:
		if (select_addr(p, paddr, psize, ptp)) {
			retval = 1;
		}
		break;
	default:
		print_node(db_out, p, 0);
		fputs(" not a designator\n", db_out);
		break;
	}
	break;
  default:
	error("illegal designator");
	break;
  }
  if (! retval) {
	*psize = 0;
  }
  else {
	if ((*ptp)->ty_class == T_CROSS) {
		*ptp = (*ptp)->ty_cross;
		if (! *ptp) {
			*ptp = void_type;
			print_node(db_out, p, 0);
			fputs(" designator has unknown type\n", db_out);
			retval = 0;
			*psize = 0;
		}
	}
  }
  return retval;
}