/*
 * Copyright (c) 2002, The Tendra Project <http://www.ten15.org/>
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice unmodified, this list of conditions, and the following
 *    disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 *
 *    		 Crown Copyright (c) 1997
 *
 *    This TenDRA(r) Computer Program is subject to Copyright
 *    owned by the United Kingdom Secretary of State for Defence
 *    acting through the Defence Evaluation and Research Agency
 *    (DERA).  It is made available to Recipients with a
 *    royalty-free licence for its use, reproduction, transfer
 *    to other parties and amendment for any purpose not excluding
 *    product development provided that any such use et cetera
 *    shall be deemed to be acceptance of the following conditions:-
 *
 *        (1) Its Recipients shall ensure that this Notice is
 *        reproduced upon any copies or amended versions of it;
 *
 *        (2) Any amended version of it shall be clearly marked to
 *        show both the nature of and the organisation responsible
 *        for the relevant amendment or amendments;
 *
 *        (3) Its onward transfer from a recipient to another
 *        party shall be deemed to be that party's acceptance of
 *        these conditions;
 *
 *        (4) DERA gives no warranty or assurance as to its
 *        quality or suitability for any purpose and DERA accepts
 *        no liability whatsoever in relation to any use to which
 *        it may be put.
 *
 * $TenDRA: tendra/src/producers/common/parse/constant.c,v 1.14 2005/10/11 06:46:38 stefanf Exp $
 */


#include "config.h"
#include "producer.h"

#include "cstring.h"
#include "fmm.h"

#include "c_types.h"
#include "etype_ops.h"
#include "exp_ops.h"
#include "flt_ops.h"
#include "ftype_ops.h"
#include "id_ops.h"
#include "nat_ops.h"
#include "str_ops.h"
#include "type_ops.h"
#include "error.h"
#include "catalog.h"
#include "basetype.h"
#include "cast.h"
#include "char.h"
#include "check.h"
#include "constant.h"
#include "convert.h"
#include "expression.h"
#include "file.h"
#include "inttype.h"
#include "literal.h"
#include "syntax.h"
#include "template.h"
#include "tokdef.h"
#include "ustring.h"


/*
 *    SMALL LITERALS
 *
 *    These arrays are used to hold the small integer literals to avoid
 *    duplication.
 */

NAT small_nat [SMALL_NAT_SIZE];
NAT small_neg_nat [SMALL_NAT_SIZE];


/*
 *    SMALL NUMBERS
 *
 *    These strings are used to hold strings representing the small integer
 *    literals to avoid duplication.
 */

string small_number [SMALL_FLT_SIZE];


/*
 *    CREATE A SMALL NUMBER
 *
 *    This routine returns the element of the arrays small_nat or small_neg_nat
 *    corresponding to the value v, allocating it if necessary.
 */

NAT
make_small_nat(int v)
{
	NAT n;
	if (v >= 0) {
		n = small_nat [v];
		if (IS_NULL_nat (n)) {
			MAKE_nat_small ((unsigned) v, n);
			small_nat [v] = n;
		}
	} else {
		v = -v;
		n = small_neg_nat [v];
		if (IS_NULL_nat (n)) {
			n = make_small_nat (v);
			MAKE_nat_neg (n, n);
			small_neg_nat [v] = n;
		}
	}
	return (n);
}


/*
 *    CONSTANT EVALUATION BUFFERS
 *
 *    These lists are used to hold single digit lists in the constant
 *    evaluation routines to allow for uniform handling of both small and
 *    large literals.
 */

static LIST (unsigned) small_nat_1;
static LIST (unsigned) small_nat_2;


/*
 *    ALLOCATE A DIGIT LIST
 *
 *    This routine allocates a list of digits of length n.  The digits in the
 *    list are initialised to zero.
 */

static LIST (unsigned)
digit_list(unsigned n)
{
	LIST (unsigned) p = NULL_list (unsigned);
	while (n) {
		CONS_unsigned (0, p, p);
		n--;
	}
	return (p);
}


/*
 *    MAKE AN EXTENDED VALUE INTO AN INTEGER CONSTANT
 *
 *    This routine creates an integer constant from an extended value, v.
 */

NAT
make_nat_value(unsigned long v)
{
	NAT n;
	unsigned lo = LO_HALF (v);
	unsigned hi = HI_HALF (v);
	if (hi) {
		LIST (unsigned) p = NULL_list (unsigned);
		CONS_unsigned (hi, p, p);
		CONS_unsigned (lo, p, p);
		MAKE_nat_large (p, n);
	} else if (lo < SMALL_NAT_SIZE) {
		n = small_nat [lo];
		if (IS_NULL_nat (n)) n = make_small_nat ((int) lo);
	} else {
		MAKE_nat_small (lo, n);
	}
	return (n);
}


/*
 *    MAKE AN INTEGER CONSTANT INTO AN EXTENDED VALUE
 *
 *    This routine finds the extended value corresponding to the integer
 *    constant n.  If n is the null constant or does not fit into an extended
 *    value then the maximum extended value is returned.
 */

unsigned long
get_nat_value(NAT n)
{
	if (!IS_NULL_nat (n)) {
		unsigned tag = TAG_nat (n);
		if (tag == nat_small_tag) {
			unsigned val = DEREF_unsigned (nat_small_value (n));
			return (EXTEND_VALUE (val));
		} else if (tag == nat_large_tag) {
			LIST (unsigned) p = DEREF_list (nat_large_values (n));
			if (LENGTH_list (p) == 2) {
				unsigned v1, v2;
				v1 = DEREF_unsigned (HEAD_list (p));
				v2 = DEREF_unsigned (HEAD_list (TAIL_list (p)));
				return (COMBINE_VALUES (v1, v2));
			}
		}
	}
	return (EXTENDED_MAX);
}


/*
 *    MAKE A LIST OF DIGITS INTO AN INTEGER CONSTANT
 *
 *    This routine creates an integer constant from a list of digits, p.
 *    This list may contain initial zero digits, which need to be removed.
 */

NAT
make_large_nat(LIST (unsigned) p)
{
	NAT n;
	LIST (unsigned) q = p;
	LIST (unsigned) r = p;
	
	/* Scan for last nonzero digit */
	while (!IS_NULL_list (q)) {
		unsigned v = DEREF_unsigned (HEAD_list (q));
		if (v != 0) r = q;
		q = TAIL_list (q);
	}
	
	/* Construct result */
	if (EQ_list (r, p)) {
		/* Small values */
		unsigned v = DEREF_unsigned (HEAD_list (p));
		if (v < SMALL_NAT_SIZE) {
			n = make_small_nat ((int) v);
		} else {
			MAKE_nat_small (v, n);
		}
		DESTROY_list (p, SIZE_unsigned);
	} else {
		/* Large values */
		q = TAIL_list (r);
		COPY_list (PTR_TAIL_list (r), NULL_list (unsigned));
		DESTROY_list (q, SIZE_unsigned);
		MAKE_nat_large (p, n);
	}
	return (n);
}


/*
 *    BUILD UP AN INTEGER CONSTANT
 *
 *    This routine multiplies the integer constant n by b and adds d.  It is
 *    used when building up integer constants from strings of digits - b gives
 *    the base and d the digit being added.  b will not be zero, and n will
 *    be a simple constant.  Note that the original value of n is overwritten
 *    with the return value.
 */

NAT
make_nat_literal(NAT n, unsigned b, unsigned d)
{
	NAT res;
	unsigned long lb = EXTEND_VALUE (b);
	
	if (IS_NULL_nat (n)) {
		/* Map null integer to zero */
		unsigned long ld = EXTEND_VALUE (d);
		res = make_nat_value (ld);
		
	} else if (IS_nat_small (n)) {
		/* Small integers */
		unsigned val = DEREF_unsigned (nat_small_value (n));
		unsigned long lv = EXTEND_VALUE (val);
		unsigned long ld = EXTEND_VALUE (d);
		unsigned long lr = lv * lb + ld;
		unsigned r1 = LO_HALF (lr);
		unsigned r2 = HI_HALF (lr);
		
		if (r2 == 0) {
			/* Result remains small */
			if (r1 < SMALL_NAT_SIZE) {
				res = small_nat [r1];
				if (IS_NULL_nat (res)) {
					res = make_small_nat ((int) r1);
				}
			} else if (val < SMALL_NAT_SIZE) {
				MAKE_nat_small (r1, res);
			} else {
				COPY_unsigned (nat_small_value (n), r1);
				res = n;
			}
		} else {
			/* Overflow - create large integer */
			LIST (unsigned) digits = NULL_list (unsigned);
			if (val >= SMALL_NAT_SIZE) {
				unsigned ign;
				DESTROY_nat_small (destroy, ign, n);
				UNUSED (ign);
			}
			CONS_unsigned (r2, digits, digits);
			CONS_unsigned (r1, digits, digits);
			MAKE_nat_large (digits, res);
		}
		
	} else {
		/* Large integers */
		LIST (unsigned) vals = DEREF_list (nat_large_values (n));
		LIST (unsigned) v = vals;
		unsigned carry = d;
		
		/* Scan through digits */
		while (!IS_NULL_list (v)) {
			unsigned val = DEREF_unsigned (HEAD_list (v));
			unsigned long lv = EXTEND_VALUE (val);
			unsigned long lc = EXTEND_VALUE (carry);
			unsigned long lr = lv * lb + lc;
			COPY_unsigned (HEAD_list (v), LO_HALF (lr));
			carry = HI_HALF (lr);
			v = TAIL_list (v);
		}
		
		if (carry) {
			/* Overflow - add an extra digit */
			CONS_unsigned (carry, NULL_list (unsigned), v);
			IGNORE APPEND_list (vals, v);
		}
		res = n;
	}
	return (res);
}


/*
 *    IS AN INTEGER CONSTANT ZERO?
 *
 *    This routine checks whether the integer constant n is zero.
 */

int
is_zero_nat(NAT n)
{
	unsigned val;
	if (!IS_nat_small (n)) return (0);
	val = DEREF_unsigned (nat_small_value (n));
	return (val ? 0 : 1);
}


/*
 *    IS AN INTEGER CONSTANT NEGATIVE?
 *
 *    This routine checks whether the integer constant n is negative.
 */

int
is_negative_nat(NAT n)
{
	return (IS_nat_neg (n));
}


/*
 *    IS AN INTEGER CONSTANT AN ERROR EXPRESSION?
 *
 *    This routine checks whether the integer constant n represents an error
 *    expression.
 */

int
is_error_nat(NAT n)
{
	if (IS_nat_calc (n)) {
		EXP e = DEREF_exp (nat_calc_value (n));
		TYPE t = DEREF_type (exp_type (e));
		return (IS_type_error (t));
	}
	return (0);
}


/*
 *    IS AN INTEGER CONSTANT A CALCULATED VALUE?
 *
 *    This routine checks whether the integer constant n is a calculated
 *    value.
 */

int
is_calc_nat(NAT n)
{
	unsigned tag = TAG_nat (n);
	if (tag == nat_neg_tag) {
		n = DEREF_nat (nat_neg_arg (n));
		tag = TAG_nat (n);
	}
	if (tag == nat_calc_tag || tag == nat_token_tag) return (1);
	return (0);
}


/*
 *    FIND THE VALUE OF A CALCULATED CONSTANT
 *
 *    This routine creates an integer constant expression of type t with
 *    value n.
 */

EXP
calc_nat_value(NAT n, TYPE t)
{
	EXP e;
	TYPE s = t;
	int ch = check_nat_range (s, n);
	if (ch != NAT_FIT) {
		/* n doesn't fit into t */
		int fit = 0;
		string str = NULL_string;
		s = find_literal_type (n, BASE_OCTAL, SUFFIX_NONE, str, &fit);
	}
	MAKE_exp_int_lit (s, n, exp_token_tag, e);
	if (!EQ_type (s, t)) {
		e = make_cast_nat (t, e, KILL_err, CAST_STATIC);
	}
	return (e);
}


/*
 *    SIMPLIFY AN INTEGER CONSTANT EXPRESSION
 *
 *    This routine simplifies the integer constant expression e by replacing
 *    it by the value of a calculated constant.  This is avoided when this
 *    constant may be tokenised.
 */

static EXP
calc_exp_value(EXP e)
{
	NAT n = DEREF_nat (exp_int_lit_nat (e));
	if (IS_nat_calc (n)) {
		/* Calculated value */
		unsigned etag = DEREF_unsigned (exp_int_lit_etag (e));
		if (etag != exp_identifier_tag) {
			/* Preserve enumerators */
			e = DEREF_exp (nat_calc_value (n));
		}
	}
	return (e);
}


/*
 *    NEGATE AN INTEGER CONSTANT
 *
 *    This routine negates the integer constant n.
 */

NAT
negate_nat(NAT n)
{
	if (!IS_NULL_nat (n)) {
		switch (TAG_nat (n)) {
		case nat_small_tag : {
			unsigned val = DEREF_unsigned (nat_small_value (n));
			if (val < SMALL_NAT_SIZE) {
				n = small_neg_nat [val];
				if (IS_NULL_nat (n)) {
					int v = (int) val;
					n = make_small_nat (-v);
				}
				break;
			}
			goto default_lab;
		}
		case nat_neg_tag : {
			n = DEREF_nat (nat_neg_arg (n));
			break;
		}
		case nat_calc_tag : {
			EXP e = DEREF_exp (nat_calc_value (n));
			e = make_uminus_exp (lex_minus, e);
			MAKE_nat_calc (e, n);
			break;
		}
		default :
			default_lab : {
				MAKE_nat_neg (n, n);
				break;
			}
		}
	}
	return (n);
}


/*
 *    COMPARE TWO INTEGER CONSTANTS
 *
 *    This routine compares the integer constants n and m.  It returns 0 if
 *    they are equal, 1 if n > m and -1 if n < m.  A value of 2 or -2 is
 *    returned if the result is target dependent or otherwise indeterminate.
 */

int
compare_nat(NAT n, NAT m)
{
	unsigned tn, tm;
	unsigned vn, vm;
	LIST (unsigned) ln, lm;
	
	/* Check for obvious equality */
	if (EQ_nat (n, m)) return (0);
	if (IS_NULL_nat (n)) return (2);
	if (IS_NULL_nat (m)) return (-2);
	tn = TAG_nat (n);
	tm = TAG_nat (m);
	
	/* Check for tokenised values */
	if (tn == nat_token_tag) {
		if (tm == nat_token_tag) {
			IDENTIFIER in = DEREF_id (nat_token_tok (n));
			IDENTIFIER im = DEREF_id (nat_token_tok (m));
			LIST (TOKEN) pn = DEREF_list (nat_token_args (n));
			LIST (TOKEN) pm = DEREF_list (nat_token_args (m));
			if (eq_token_args (in, im, pn, pm)) return (0);
		}
		return (2);
	}
	if (tm == nat_token_tag) {
		return (2);
	}
	
	/* Check for calculated values */
	if (tn == nat_calc_tag) {
		if (tm == nat_calc_tag) {
			EXP en = DEREF_exp (nat_calc_value (n));
			EXP em = DEREF_exp (nat_calc_value (m));
			if (eq_exp (en, em, 1)) return (0);
		}
		return (2);
	}
	if (tm == nat_calc_tag) {
		return (2);
	}
	
	/* Deal with negation operations */
	if (tn == nat_neg_tag) {
		if (tm == nat_neg_tag) {
			/* Both negative */
			int c;
			n = DEREF_nat (nat_neg_arg (n));
			m = DEREF_nat (nat_neg_arg (m));
			c = compare_nat (n, m);
			return (-c);
		}
		/* n negative, m positive */
		return (-1);
	}
	if (tm == nat_neg_tag) {
		/* m negative, n positive */
		return (1);
	}
	
	/* Now deal with small integers */
	if (tn == nat_small_tag) {
		if (tm == nat_small_tag) {
			/* Both small */
			vn = DEREF_unsigned (nat_small_value (n));
			vm = DEREF_unsigned (nat_small_value (m));
			if (vn == vm) return (0);
			return (vn > vm ? 1 : -1);
		} else {
			/* n small, m large */
			return (-1);
		}
	}
	if (tm == nat_small_tag) {
		/* m small, n large */
		return (1);
	}
	
	/* Now deal with large integers */
	ln = DEREF_list (nat_large_values (n));
	lm = DEREF_list (nat_large_values (m));
	vn = LENGTH_list (ln);
	vm = LENGTH_list (lm);
	if (vn == vm) {
		/* Same length */
		int c = 0;
		while (!IS_NULL_list (ln)) {
			/* Scan through digits */
			vn = DEREF_unsigned (HEAD_list (ln));
			vm = DEREF_unsigned (HEAD_list (lm));
			if (vn != vm) {
				c = (vn > vm ? 1 : -1);
			}
			ln = TAIL_list (ln);
			lm = TAIL_list (lm);
		}
		/* c is set to the most significant difference */
		return (c);
	}
	/* Different lengths */
	return (vn > vm ? 1 : -1);
}


/*
 *    UNIFY TWO INTEGER LITERALS
 *
 *    This routine unifies the integer literals n and m by defining tokens
 *    if possible.  It returns true if the token is assigned a value.
 */

static int
unify_nat(NAT n, NAT m)
{
	IDENTIFIER id;
	LIST (TOKEN) args;
	switch (TAG_nat (n)) {
	case nat_token_tag : {
		id = DEREF_id (nat_token_tok (n));
		args = DEREF_list (nat_token_args (n));
		break;
	}
	case nat_calc_tag : {
		EXP e = DEREF_exp (nat_calc_value (n));
		if (!IS_exp_token (e)) return (0);
		id = DEREF_id (exp_token_tok (e));
		args = DEREF_list (exp_token_args (e));
		break;
	}
	default : {
		return (0);
	}
	}
	if (IS_NULL_list (args) && defining_token (id)) {
		return (define_nat_token (id, m));
	}
	return (0);
}


/*
 *    ARE TWO INTEGER LITERALS EQUAL?
 *
 *    This routine returns true if the literals n and m are equal.
 */

int
eq_nat(NAT n, NAT m)
{
	if (EQ_nat (n, m)) return (1);
	if (IS_NULL_nat (n) || IS_NULL_nat (m)) return (0);
	if (compare_nat (n, m) == 0) return (1);
	if (force_tokdef || force_template || expand_tokdef) {
		if (unify_nat (n, m)) return (1);
		if (unify_nat (m, n)) return (1);
	}
	return (0);
}


/*
 *    PERFORM A BINARY INTEGER CONSTANT CALCULATION
 *
 *    This routine is used to evaluate the binary operation indicated by tag
 *    on the integer constants a and b, which will be simple literals.  The
 *    permitted operations are '+', '-', '*', '/', '%', '<<', '>>', '&', '|',
 *    and '^'.  The null literal is returned for undefined or implementation
 *    dependent calculations.
 */

NAT
binary_nat_op(unsigned tag, NAT a, NAT b)
{
	unsigned vn, vm;
	NAT n = a, m = b;
	NAT res = NULL_nat;
	int sn = 0, sm = 0;
	unsigned ln, lm, la;
	LIST (unsigned) p, q;
	LIST (unsigned) pn, pm;
	
	/* Decompose n */
	if (IS_NULL_nat (n)) return (NULL_nat);
	if (IS_NULL_nat (m)) return (NULL_nat);
	if (IS_nat_neg (n)) {
		n = DEREF_nat (nat_neg_arg (n));
		sn = 1;
	}
	if (IS_nat_small (n)) {
		vn = DEREF_unsigned (nat_small_value (n));
		if (vn == 0) {
			/* Find results if a is zero */
			switch (tag) {
			case exp_plus_tag :
			case exp_or_tag :
			case exp_xor_tag : {
				/* 0 op b = b */
				return (b);
			}
			case exp_minus_tag : {
				/* 0 - b = -b */
				res = negate_nat (b);
				return (res);
			}
			case exp_mult_tag :
			case exp_lshift_tag :
			case exp_rshift_tag :
			case exp_and_tag : {
				/* 0 op b = 0 */
				return (a);
			}
			}
		}
		pn = small_nat_1;
		COPY_unsigned (HEAD_list (pn), vn);
		ln = 1;
	} else {
		vn = 0;
		pn = DEREF_list (nat_large_values (n));
		ln = LENGTH_list (pn);
	}
	
	/* Decompose m */
	if (IS_nat_neg (m)) {
		m = DEREF_nat (nat_neg_arg (m));
		sm = 1;
	}
	if (IS_nat_small (m)) {
		vm = DEREF_unsigned (nat_small_value (m));
		if (vm == 0) {
			/* Find results if b is zero */
			switch (tag) {
			case exp_plus_tag :
			case exp_minus_tag :
			case exp_lshift_tag :
			case exp_rshift_tag :
			case exp_or_tag :
			case exp_xor_tag : {
				/* a op 0 = a */
				return (a);
			}
			case exp_mult_tag :
			case exp_and_tag : {
				/* a op 0 = 0 */
				return (b);
			}
			case exp_div_tag :
			case exp_rem_tag : {
				/* a op 0 undefined */
				return (NULL_nat);
			}
			}
		}
		pm = small_nat_2;
		COPY_unsigned (HEAD_list (pm), vm);
		lm = 1;
	} else {
		vm = 0;
		pm = DEREF_list (nat_large_values (m));
		lm = LENGTH_list (pm);
	}
	
	/* Find the larger of ln and lm */
	la = (ln > lm ? ln : lm);
	
	/* Perform the appropriate calculation */
	switch (tag) {
		
	case exp_plus_tag :
		exp_plus_label : {
			/* Deal with 'a + b' */
			if (sn == sm) {
				/* Same sign */
				if (la == 1) {
					/* Add two small values */
					unsigned long en = EXTEND_VALUE (vn);
					unsigned long em = EXTEND_VALUE (vm);
					unsigned long er = en + em;
					res = make_nat_value (er);
				} else {
					/* Add two large values */
					unsigned carry = 0;
					p = digit_list (la + 1);
					q = p;
					while (!IS_NULL_list (q)) {
						unsigned long en, em, er;
						unsigned long ec = EXTEND_VALUE (carry);
						if (!IS_NULL_list (pn)) {
							vn = DEREF_unsigned (HEAD_list (pn));
							en = EXTEND_VALUE (vn);
							pn = TAIL_list (pn);
						} else {
							en = 0;
						}
						if (!IS_NULL_list (pm)) {
							vm = DEREF_unsigned (HEAD_list (pm));
							em = EXTEND_VALUE (vm);
							pm = TAIL_list (pm);
						} else {
							em = 0;
						}
						er = en + em + ec;
						COPY_unsigned (HEAD_list (q), LO_HALF (er));
						carry = HI_HALF (er);
						q = TAIL_list (q);
					}
					res = make_large_nat (p);
				}
				if (sn) res = negate_nat (res);
			} else {
				/* Different signs - try 'a - (-b)' */
				sm = !sm;
				goto exp_minus_label;
			}
			break;
		}
		
	case exp_minus_tag :
		exp_minus_label : {
			/* Deal with 'a - b' */
			if (sn == sm) {
				/* Same sign */
				int c;
				if (ln == lm) {
					/* Same length */
					c = compare_nat (n, m);
					if (c == 0) {
						/* n - m is zero if n == m */
						res = small_nat [0];
						break;
					}
				} else if (ln < lm) {
					/* Definitely n < m */
					c = -1;
				} else {
					/* Definitely n > m */
					c = 1;
				}
				if (c < 0) {
					/* If n < m, try '(-m) - (-n)' */
					unsigned v = vn;
					vn = vm;
					vm = v;
					p = pn;
					pn = pm;
					pm = p;
					sn = !sn;
				}
				/* Now work out n - m */
				if (la == 1) {
					/* Subtract two small values */
					unsigned long en = EXTEND_VALUE (vn);
					unsigned long em = EXTEND_VALUE (vm);
					unsigned long er = en - em;
					res = make_nat_value (er);
				} else {
					/* Subtract two large values */
					int carry = 0;
					p = digit_list (la);
					q = p;
					while (!IS_NULL_list (q)) {
						unsigned v;
						if (!IS_NULL_list (pn)) {
							vn = DEREF_unsigned (HEAD_list (pn));
							pn = TAIL_list (pn);
						} else {
							vn = 0;
						}
						if (!IS_NULL_list (pm)) {
							vm = DEREF_unsigned (HEAD_list (pm));
							pm = TAIL_list (pm);
						} else {
							vm = 0;
						}
						if (carry) {
							if (vn) {
								vn--;
								carry = 0;
							} else {
								vn = NAT_MASK;
							}
						}
						if (vn < vm) carry = 1;
						v = ((vn - vm) & NAT_MASK);
						COPY_unsigned (HEAD_list (q), v);
						q = TAIL_list (q);
					}
					res = make_large_nat (p);
				}
				if (sn) res = negate_nat (res);
			} else {
				/* Different signs - try 'a + (-b)' */
				sm = !sm;
				goto exp_plus_label;
			}
			break;
		}
		
	case exp_mult_tag : {
		/* Deal with 'a * b' */
		if (ln == 1 && vn == 1) {
			/* Multiply by +/- 1 */
			res = b;
			if (sn) res = negate_nat (res);
			break;
		}
		if (lm == 1 && vm == 1) {
			/* Multiply by +/- 1 */
			res = a;
			if (sm) res = negate_nat (res);
			break;
		}
		if (la == 1) {
			/* Deal with small values */
			unsigned long en = EXTEND_VALUE (vn);
			unsigned long em = EXTEND_VALUE (vm);
			unsigned long er = en * em;
			res = make_nat_value (er);
		} else {
			/* Deal with large values */
			unsigned vs;
			unsigned long en, em, es;
			LIST (unsigned) pr, ps, pt;
			p = digit_list (ln + lm);
			q = p;
			while (!IS_NULL_list (pn)) {
				pr = q;
				vn = DEREF_unsigned (HEAD_list (pn));
				en = EXTEND_VALUE (vn);
				pt = pm;
				while (!IS_NULL_list (pt)) {
					ps = pr;
					vm = DEREF_unsigned (HEAD_list (pt));
					em = en * EXTEND_VALUE (vm);
					while (em) {
						vs = DEREF_unsigned (HEAD_list (ps));
						es = EXTEND_VALUE (vs) + em;
						vs = LO_HALF (es);
						COPY_unsigned (HEAD_list (ps), vs);
						em = EXTEND_VALUE (HI_HALF (es));
						ps = TAIL_list (ps);
					}
					pr = TAIL_list (pr);
					pt = TAIL_list (pt);
				}
				pn = TAIL_list (pn);
				q = TAIL_list (q);
			}
			res = make_large_nat (p);
		}
		if (sn != sm) res = negate_nat (res);
		break;
	}
		
	case exp_div_tag : {
		/* Deal with 'a / b' */
		if (la <= 2) {
			/* Deal with smallish values */
			unsigned long en = get_nat_value (n);
			unsigned long em = get_nat_value (m);
			unsigned long er = en / em;
			if (sn || sm) {
				/* One operand is negative, check remainder */
				unsigned long es = en % em;
				if (es) break;
			}
			res = make_nat_value (er);
			if (sn != sm) res = negate_nat (res);
		}
		/* NOT YET IMPLEMENTED */
		break;
	}
		
	case exp_rem_tag : {
		/* Deal with a % b' */
		if (la <= 2) {
			/* Deal with smallish values */
			unsigned long en = get_nat_value (n);
			unsigned long em = get_nat_value (m);
			unsigned long es = en % em;
			if (sn || sm) {
				/* One operand is negative, check remainder */
				if (es) break;
			}
			res = make_nat_value (es);
		}
		/* NOT YET IMPLEMENTED */
		break;
	}
		
	case exp_lshift_tag : {
		/* Deal with 'a << b' */
		unsigned carry = 0;
		unsigned long en, em;
		if (sn || sm) break;
		em = get_nat_value (m);
		if (em > 4096) {
			/* Only attempt smallish values */
			break;
		}
		lm = (unsigned) (em / NAT_DIGITS);
		em %= NAT_DIGITS;
		la = ln + lm + 1;
		p = digit_list (la);
		q = p;
		while (lm) {
			/* Step over zero digits */
			q = TAIL_list (q);
			lm--;
		}
		while (!IS_NULL_list (pn)) {
			/* Copy remaining digits */
			vn = DEREF_unsigned (HEAD_list (pn));
			if (em) {
				en = EXTEND_VALUE (vn);
				en <<= em;
				vn = (LO_HALF (en) | carry);
				carry = HI_HALF (en);
			}
			COPY_unsigned (HEAD_list (q), vn);
			pn = TAIL_list (pn);
			q = TAIL_list (q);
		}
		/* Copy carry flag */
		COPY_unsigned (HEAD_list (q), carry);
		res = make_large_nat (p);
		break;
	}
		
	case exp_rshift_tag : {
		/* Deal with 'a >> b' */
		unsigned long en, em;
		if (sn || sm) break;
		em = get_nat_value (m);
		while (em >= NAT_DIGITS && ln) {
			/* Shift right one nat digit */
			em -= NAT_DIGITS;
			pn = TAIL_list (pn);
			ln--;
		}
		if (ln == 0) {
			/* Shifted off end */
			res = small_nat [0];
		} else if (ln == 1) {
			/* Remainder fits into a single digit */
			vn = DEREF_unsigned (HEAD_list (pn));
			vn >>= em;
			if (vn < SMALL_NAT_SIZE) {
				res = make_small_nat ((int) vn);
			} else {
				MAKE_nat_small (vn, res);
			}
		} else {
			/* More than one digit left */
			p = digit_list (ln);
			q = p;
			while (!IS_NULL_list (pn)) {
				/* Copy remaining digits */
				vn = DEREF_unsigned (HEAD_list (pn));
				COPY_unsigned (HEAD_list (q), vn);
				pn = TAIL_list (pn);
				q = TAIL_list (q);
			}
			/* Shift further if required */
			if (em) {
				unsigned carry = 0;
				p = REVERSE_list (p);
				q = p;
				while (!IS_NULL_list (q)) {
					vn = DEREF_unsigned (HEAD_list (q));
					en = COMBINE_VALUES (0, vn);
					en >>= em;
					vn = (HI_HALF (en) | carry);
					COPY_unsigned (HEAD_list (q), vn);
					carry = LO_HALF (en);
					q = TAIL_list (q);
				}
				p = REVERSE_list (p);
			}
			res = make_large_nat (p);
		}
		break;
	}
		
	case exp_and_tag :
	case exp_or_tag :
	case exp_xor_tag : {
		/* Deal with 'a & b', 'a | b' and 'a ^ b' */
		if (sn || sm) break;
		if (la <= 2) {
			/* Deal with smallish values */
			unsigned long er;
			unsigned long en = get_nat_value (n);
			unsigned long em = get_nat_value (m);
			if (tag == exp_and_tag) {
				er = (en & em);
			} else if (tag == exp_or_tag) {
				er = (en | em);
			} else {
				er = (en ^ em);
			}
			res = make_nat_value (er);
		} else {
			/* Deal with large values */
			p = digit_list (la);
			q = p;
			while (!IS_NULL_list (q)) {
				unsigned vr;
				if (!IS_NULL_list (pn)) {
					vn = DEREF_unsigned (HEAD_list (pn));
					pn = TAIL_list (pn);
				} else {
					vn = 0;
				}
				if (!IS_NULL_list (pm)) {
					vm = DEREF_unsigned (HEAD_list (pm));
					pm = TAIL_list (pm);
				} else {
					vm = 0;
				}
				if (tag == exp_and_tag) {
					vr = (vn & vm);
				} else if (tag == exp_or_tag) {
					vr = (vn | vm);
				} else {
					vr = (vn ^ vm);
				}
				COPY_unsigned (HEAD_list (q), vr);
				q = TAIL_list (q);
			}
			res = make_large_nat (p);
		}
		break;
	}
	}
	return (res);
}


/*
 *    EVALUATE A CONSTANT EXPRESSION
 *
 *    This routine transforms the integer constant expression e into an
 *    integer constant.  Any errors arising are added to the position
 *    indicated by err.
 */

NAT
make_nat_exp(EXP e, ERROR *err)
{
	NAT n;
	TYPE t;
	
	/* Remove any parentheses round e */
	unsigned tag = TAG_exp (e);
	while (tag == exp_paren_tag) {
		e = DEREF_exp (exp_paren_arg (e));
		tag = TAG_exp (e);
	}
	
	/* The result should now be an integer constant */
	if (tag == exp_int_lit_tag) {
		n = DEREF_nat (exp_int_lit_nat (e));
		return (n);
	}
	
	/* Check expression type */
	t = DEREF_type (exp_type (e));
	switch (TAG_type (t)) {
	case type_integer_tag :
	case type_enumerate_tag :
	case type_bitfield_tag : {
		/* Double check for integer constants */
		if (!is_const_exp (e, 0)) {
			add_error (err, ERR_expr_const_bad ());
		}
		break;
	}
	case type_token_tag : {
		/* Allow template types */
		if (!is_templ_type (t)) goto default_lab;
		break;
	}
	case type_error_tag : {
		/* Allow for error propagation */
		break;
	}
	default :
		default_lab : {
			/* Otherwise report an error */
			add_error (err, ERR_expr_const_int (t));
			if (IS_exp_float_lit (e)) {
				/* Evaluate floating point literals */
				FLOAT f = DEREF_flt (exp_float_lit_flt (e));
				n = round_float_lit (f, crt_round_mode);
				if (!IS_NULL_nat (n)) return (n);
			}
			e = make_error_exp (0);
			break;
		}
	}
	MAKE_nat_calc (e, n);
	return (n);
}


/*
 *    FIND THE NUMBER OF BITS IN AN INTEGER
 *
 *    This routine returns the number of bits in the integer n from the
 *    range [0,0xffff].
 */

unsigned
no_bits(unsigned n)
{
	unsigned bits = 0;
	static unsigned char small_bits [16] = {
		0, 1, 2, 2, 3, 3, 3, 3,
		4, 4, 4, 4, 4, 4, 4, 4
	};
	if (n & ((unsigned) 0xfff0)) {
		n >>= 4;
		bits += 4;
		if (n & 0x0ff0) {
			n >>= 4;
			bits += 4;
			if (n & 0x00f0) {
				n >>= 4;
				bits += 4;
			}
		}
	}
	bits += (unsigned) small_bits [n];
	return (bits);
}


/*
 *    FIND THE NUMBER OF BITS IN AN INTEGER CONSTANT
 *
 *    This routine calculates the number of bits in the representation of
 *    the simple integer constant n.  The flag eq is set to false unless
 *    n is exactly a power of 2.
 */

static unsigned
get_nat_bits(NAT n, int *eq)
{
	unsigned val;
	unsigned bits = 0;
	if (IS_nat_small (n)) {
		val = DEREF_unsigned (nat_small_value (n));
	} else {
		LIST (unsigned) vals = DEREF_list (nat_large_values (n));
		for (;;) {
			val = DEREF_unsigned (HEAD_list (vals));
			vals = TAIL_list (vals);
			if (IS_NULL_list (vals)) break;
			if (val) *eq = 0;
			bits += NAT_DIGITS;
		}
	}
	if (val) {
		/* Check the most significant digit */
		if (val & (val - 1)) *eq = 0;
		bits += no_bits (val);
	}
	return (bits);
}


/*
 *    CHECK WHETHER AN INTEGER CONSTANT FITS INTO A TYPE
 *
 *    This routine checks whether the integer constant n fits into the range
 *    of values of the integral, enumeration or bitfield type t.  The value
 *    return is one of the NAT_ constants defined in constant.h.
 */

int
check_nat_range(TYPE t, NAT n)
{
	int eq = 1;
	int neg = 0;
	unsigned msz;
	unsigned bits;
	BASE_TYPE sign;
	
	/* Find type information */
	unsigned sz = find_type_size (t, &msz, &sign);
	int u = (sign == btype_unsigned ? 1 : 0);
	
	/* Deal with complex constants */
	unsigned tag = TAG_nat (n);
	if (tag == nat_neg_tag) {
		n = DEREF_nat (nat_neg_arg (n));
		tag = TAG_nat (n);
		neg = 1;
	}
	if (tag == nat_calc_tag || tag == nat_token_tag) {
		return (NAT_MAYFIT_SIGNED + u);
	}
	
	/* Find the number of bits in the representation of n */
	bits = get_nat_bits (n, &eq);
	if (bits > basetype_info [ntype_ellipsis].max_bits) {
		return (NAT_NEVERFIT_SIGNED + u);
	}
	
	/* Check the type range */
	if (sign == btype_unsigned) {
		/* Unsigned types (eg [0-255]) */
		if (neg) return (NAT_NOFIT_UNSIGNED);
		if (bits <= sz) return (NAT_FIT);
		if (bits > msz) return (NAT_NOFIT_UNSIGNED);
	} else if (sign == btype_signed) {
		/* Symmetric signed types (eg [-127,127]) */
		if (bits < sz) return (NAT_FIT);
		if (bits >= msz) return (NAT_NOFIT_SIGNED);
	} else if (sign == (btype_signed | btype_long)) {
		/* Asymmetric signed types (eg [-128,127]) */
		if (bits < sz) return (NAT_FIT);
		if (bits == sz && neg && eq) return (NAT_FIT);
		if (bits >= msz) return (NAT_NOFIT_SIGNED);
	} else {
		/* Unspecified types */
		if (neg) return (NAT_NOFIT_SIGNED);
		if (bits < sz) return (NAT_FIT);
		if (bits >= msz) return (NAT_NOFIT_SIGNED);
	}
	return (NAT_MAYFIT_SIGNED + u);
}


/*
 *    CHECK A TYPE SIZE
 *
 *    This routine checks whether the integer literal n exceeds the number
 *    of bits in the integral, enumeration or bitfield type t.  It is used,
 *    for example, in checking for overlarge shifts and bitfield sizes.
 *    It returns -1 if n is less than the minimum number of bits, 0 if it
 *    is equal, and 1 otherwise.
 */

int
check_type_size(TYPE t, NAT n)
{
	unsigned sz;
	unsigned msz;
	BASE_TYPE sign;
	unsigned long st, sn;
	switch (TAG_nat (n)) {
	case nat_neg_tag :
	case nat_calc_tag :
	case nat_token_tag : {
		/* Negative and calculated values are alright */
		return (-1);
	}
	}
	sn = get_nat_value (n);
	if (sn == EXTENDED_MAX) return (1);
	sz = find_type_size (t, &msz, &sign);
	UNUSED (sign);
	UNUSED (msz);
	st = EXTEND_VALUE (sz);
	if (sn < st) return (-1);
	if (sn == st) return (0);
	return (1);
}


/*
 *    FIND THE MAXIMUM VALUE FOR A TYPE
 *
 *    This routine returns the maximum value (or the minimum value if neg is
 *    true) which is guaranteed to fit into the type t.  The null constant
 *    is returned if the value can't be determined.  If t is the null type
 *    the maximum value which can fit into any type is returned.
 */

NAT
max_type_value(TYPE t, int neg)
{
	NAT n;
	unsigned sz;
	unsigned msz;
	int zero = 0;
	BASE_TYPE sign;
	if (!IS_NULL_type (t)) {
		sz = find_type_size (t, &msz, &sign);
	} else {
		sz = basetype_info [ntype_ellipsis].max_bits;
		sign = btype_unsigned;
	}
	if (!(sign & btype_signed)) {
		zero = neg;
	}
	if (!(sign & btype_unsigned)) {
		if (sz == 0) zero = 1;
		sz--;
	}
	if (zero) {
		n = small_nat [0];
	} else {
		n = make_nat_value ((unsigned long) sz);
		n = binary_nat_op (exp_lshift_tag, small_nat [1], n);
		if (!IS_NULL_nat (n)) {
			if (!neg || !(sign & btype_long)) {
				n = binary_nat_op (exp_minus_tag, n, small_nat [1]);
			}
			if (neg) n = negate_nat (n);
		}
	}
	return (n);
}




/*
 *    CONSTRUCT A CONSTANT INTEGRAL EXPRESSION
 *
 *    This routine constructs an integer literal expression of type t from
 *    the literal n, performing any appropriate bounds checks.  tag indicates
 *    the operation used to form this result.  The null expression is returned
 *    to indicate that n may not fit into t.
 */

EXP
make_int_exp(TYPE t, unsigned tag, NAT n)
{
	EXP e;
	int ch = check_nat_range (t, n);
	if (ch == NAT_FIT) {
		MAKE_exp_int_lit (t, n, tag, e);
	} else {
		e = NULL_exp;
	}
	return (e);
}


/*
 *    CHECK ARRAY BOUNDS
 *
 *    This routine checks an array index operation indicated by op (which
 *    can be '[]', '+' or '-') for the array type t and the constant integer
 *    index expression a.  Note that a must be less than the array bound for
 *    '[]', but may be equal to the bound for the other operations (this is
 *    the 'one past the end' rule).
 */

void
check_bounds(int op, TYPE t, EXP a)
{
	if (IS_exp_int_lit (a)) {
		int ok = 0;
		NAT n = DEREF_nat (type_array_size (t));
		NAT m = DEREF_nat (exp_int_lit_nat (a));
		
		/* Unbound arrays do not give an error */
		if (IS_NULL_nat (n)) return;
		
		/* Calculated indexes are alright */
		if (is_calc_nat (m)) return;
		
		/* Check the bounds */
		if (op == lex_minus) m = negate_nat (m);
		if (!IS_nat_neg (m)) {
			if (!is_calc_nat (n)) {
				int c = compare_nat (m, n);
				if (c < 0) ok = 1;
				if (c == 0 && op != lex_array_Hop) ok = 1;
			}
		}
		
		/* Report the error */
		if (!ok) report (crt_loc, ERR_expr_add_array (m, t, op));
	}
	return;
}


/*
 *    EVALUATE A CONSTANT CAST OPERATION
 *
 *    This routine is used to cast the integer constant expression a to the
 *    integral, bitfield, or enumeration type t.  The argument cast indicated
 *    whether the cast used is implicit or explicit (see cast.h).  Any errors
 *    arising are added to err.
 */

EXP
make_cast_nat(TYPE t, EXP a, ERROR *err, unsigned cast)
{
	EXP e;
	int ch;
	unsigned etag = exp_cast_tag;
	NAT n = DEREF_nat (exp_int_lit_nat (a));
	if (cast == CAST_IMPLICIT) {
		etag = DEREF_unsigned (exp_int_lit_etag (a));
	}
	ch = check_nat_range (t, n);
	if (ch != NAT_FIT) {
		/* n may not fit into t */
		a = calc_exp_value (a);
		MAKE_exp_cast (t, CONV_INT_INT, a, e);
		MAKE_nat_calc (e, n);
	}
	MAKE_exp_int_lit (t, n, etag, e);
	UNUSED (err);
	return (e);
}


/*
 *    EVALUATE A CONSTANT UNARY OPERATION
 *
 *    This routine is used to evaluate the unary operation indicated by tag
 *    on the integer constant expression a.  Any necessary operand conversions
 *    and arithmetic type conversions have already been performed on a.  The
 *    permitted operations are '!', '-' and '~'.
 */

EXP
make_unary_nat(unsigned tag, EXP a)
{
	EXP e;
	TYPE t = DEREF_type (exp_type (a));
	NAT n = DEREF_nat (exp_int_lit_nat (a));
	
	/* Can only evaluate result if n is not calculated */
	if (!is_calc_nat (n)) {
		switch (tag) {
		case exp_not_tag : {
			/* Deal with '!a' */
			unsigned p = test_bool_exp (a);
			if (p == BOOL_UNKNOWN) break;
			e = make_bool_exp (BOOL_NEGATE (p), tag);
			return (e);
		}
		case exp_abs_tag : {
			/* Deal with 'abs (a)' */
			int c = compare_nat (n, small_nat [0]);
			if (c == 0 || c == 1) return (a);
			if (c == -1) goto negate_lab;
			break;
		}
		case exp_negate_tag :
			negate_lab : {
				/* Deal with '-a' */
				n = negate_nat (n);
				e = make_int_exp (t, tag, n);
				if (!IS_NULL_exp (e)) return (e);
				break;
			}
		case exp_compl_tag : {
			/* Deal with '~a' */
			/* NOT YET IMPLEMENTED */
			break;
		}
		}
	}
	
	/* Calculated case */
	a = calc_exp_value (a);
	MAKE_exp_negate_etc (tag, t, a, e);
	MAKE_nat_calc (e, n);
	MAKE_exp_int_lit (t, n, tag, e);
	return (e);
}


/*
 *    CHECK A CHARACTER LITERAL CONSTANT
 *
 *    This routine checks whether the integer constant expression a represents
 *    one of the decimal character literals, '0', '1', ..., '9'.  If so it
 *    returns the corresponding value in the range [0,9].  Otherwise it
 *    returns -1.
 */

static int
eval_char_nat(EXP a, unsigned *k)
{
	unsigned tag = TAG_exp (a);
	if (tag == exp_int_lit_tag) {
		NAT n = DEREF_nat (exp_int_lit_nat (a));
		if (IS_nat_calc (n)) {
			a = DEREF_exp (nat_calc_value (n));
			tag = TAG_exp (a);
		}
	}
	if (tag == exp_char_lit_tag) {
		int d = DEREF_int (exp_char_lit_digit (a));
		STRING str = DEREF_str (exp_char_lit_str (a));
		*k = DEREF_unsigned (str_simple_kind (str));
		return (d);
	}
	if (tag == exp_cast_tag) {
		a = DEREF_exp (exp_cast_arg (a));
		return (eval_char_nat (a, k));
	}
	return (-1);
}


/*
 *    ADD A VALUE TO A CHARACTER LITERAL CONSTANT
 *
 *    This routine adds or subtracts (depending on the value of tag) the
 *    value n to the decimal character literal d, casting the result to
 *    type t.  The null expression is returned if the result is not a
 *    character literal.  For example, this routine is used to evaluate
 *    '4' + 3 as '7' regardless of the underlying character set.  This
 *    wouldn't be terribly important, but certain validation set suites
 *    use 6 + '0' - '6' as a null pointer constant!
 */

static EXP
make_char_nat(TYPE t, unsigned tag, int d, unsigned kind, NAT n)
{
	int neg = (tag == exp_minus_tag ? 1 : 0);
	if (IS_nat_neg (n)) {
		/* Negate if necessary */
		n = DEREF_nat (nat_neg_arg (n));
		neg = !neg;
	}
	if (IS_nat_small (n)) {
		unsigned v = DEREF_unsigned (nat_small_value (n));
		if (v < 10) {
			int m = (int) v;
			if (neg) m = -m;
			d += m;
			if (d >= 0 && d < 10) {
				/* Construct the result */
				EXP e;
				STRING str;
				character s [2];
				ERROR err = NULL_err;
				s [0] = (character) (d + char_zero);
				s [1] = 0;
				MAKE_str_simple (1, ustring_copy (s), kind, str);
				e = make_string_exp (str);
				e = make_cast_nat (t, e, &err, CAST_STATIC);
				if (!IS_NULL_err (err)) report (crt_loc, err);
				return (e);
			}
		}
	}
	return (NULL_exp);
}


/*
 *    EVALUATE A CONSTANT BINARY OPERATION
 *
 *    This routine is used to evaluate the binary operation indicated by tag
 *    on the integer constant expressions a and b.  Any necessary operand
 *    conversions and arithmetic type conversions have already been performed
 *    on a and b.  The permitted operations are '+', '-', '*', '/', '%', '<<',
 *    '>>', '&', '|', '^', '&&' and '||'.
 */

EXP
make_binary_nat(unsigned tag, EXP a, EXP b)
{
	EXP e;
	int calc = 1;
	NAT res = NULL_nat;
	TYPE t = DEREF_type (exp_type (a));
	NAT n = DEREF_nat (exp_int_lit_nat (a));
	NAT m = DEREF_nat (exp_int_lit_nat (b));
	
	/* Examine simple cases */
	switch (tag) {
	case exp_plus_tag : {
		/* Deal with 'a + b' */
		if (is_zero_nat (n)) {
			res = m;
		} else if (is_zero_nat (m)) {
			res = n;
		}
		break;
	}
	case exp_minus_tag : {
		/* Deal with 'a - b' */
		int c = compare_nat (n, m);
		if (c == 0 && !overflow_exp (a)) {
			res = small_nat [0];
		} else if (is_zero_nat (n)) {
			e = make_unary_nat (exp_negate_tag, b);
			return (e);
		} else if (is_zero_nat (m)) {
			res = n;
		}
		break;
	}
	case exp_mult_tag : {
		/* Deal with 'a * b' */
		if (is_zero_nat (n) && !overflow_exp (b)) {
			res = n;
		} else if (is_zero_nat (m) && !overflow_exp (a)) {
			res = m;
		}
		if (EQ_nat (n, small_nat [1])) {
			res = m;
		} else if (EQ_nat (m, small_nat [1])) {
			res = n;
		}
		break;
	}
	case exp_max_tag : {
		/* Deal with 'max (a, b)' */
		int c = compare_nat (n, m);
		if ((c == 0 || c == 1) && !overflow_exp (b)) {
			res = n;
		} else if (c == -1 && !overflow_exp (a)) {
			res = m;
		}
		calc = 0;
		break;
	}
	case exp_min_tag : {
		/* Deal with 'min (a, b)' */
		int c = compare_nat (n, m);
		if ((c == 0 || c == 1) && !overflow_exp (a)) {
			res = m;
		} else if (c == -1 && !overflow_exp (b)) {
			res = n;
		}
		calc = 0;
		break;
	}
	case exp_log_and_tag : {
		/* Deal with 'a && b' */
		unsigned p = test_bool_exp (a);
		unsigned q = test_bool_exp (b);
		if (p == BOOL_TRUE && q == BOOL_TRUE) {
			/* EMPTY */
		} else if (p == BOOL_FALSE && !overflow_exp (b)) {
			/* EMPTY */
		} else if (q == BOOL_FALSE && !overflow_exp (a)) {
			p = BOOL_FALSE;
		} else {
			calc = 0;
			break;
		}
		e = make_bool_exp (p, tag);
		return (e);
	}
	case exp_log_or_tag : {
		/* Deal with 'a || b' */
		unsigned p = test_bool_exp (a);
		unsigned q = test_bool_exp (b);
		if (p == BOOL_FALSE && q == BOOL_FALSE) {
			/* EMPTY */
		} else if (p == BOOL_TRUE && !overflow_exp (b)) {
			/* EMPTY */
		} else if (q == BOOL_TRUE && !overflow_exp (a)) {
			p = BOOL_TRUE;
		} else {
			calc = 0;
			break;
		}
		e = make_bool_exp (p, tag);
		return (e);
	}
	}
	
	/* Return result if known (either n, m or 0) */
	if (!IS_NULL_nat (res)) {
		MAKE_exp_int_lit (t, res, tag, e);
		return (e);
	}
	
	/* Can only evaluate result if n and m are not calculated */
	if (calc && !is_calc_nat (n) && !is_calc_nat (m)) {
		res = binary_nat_op (tag, n, m);
		if (!IS_NULL_nat (res)) {
			e = make_int_exp (t, tag, res);
			if (!IS_NULL_exp (e)) return (e);
		}
	}
	
	/* Check for digit characters */
	if (tag == exp_plus_tag || tag == exp_minus_tag) {
		unsigned ka, kb;
		int da = eval_char_nat (a, &ka);
		int db = eval_char_nat (b, &kb);
		if (da >= 0) {
			if (db >= 0 && tag == exp_minus_tag) {
				/* Difference of two digits */
				res = make_small_nat (da - db);
				e = make_int_exp (t, tag, res);
				if (!IS_NULL_exp (e)) return (e);
			} else {
				/* Digit plus or minus value */
				e = make_char_nat (t, tag, da, ka, m);
				if (!IS_NULL_exp (e)) return (e);
			}
		} else if (db >= 0 && tag == exp_plus_tag) {
			/* Digit plus value */
			e = make_char_nat (t, tag, db, kb, n);
			if (!IS_NULL_exp (e)) return (e);
		}
	}
	
	/* Calculated case */
	a = calc_exp_value (a);
	b = calc_exp_value (b);
	MAKE_exp_plus_etc (tag, t, a, b, e);
	MAKE_nat_calc (e, res);
	MAKE_exp_int_lit (t, res, tag, e);
	return (e);
}


/*
 *    EVALUATE A CONSTANT TEST OPERATION
 *
 *    This routine is used to convert the integer constant expression a to
 *    a boolean.
 */

EXP
make_test_nat(EXP a)
{
	EXP e;
	NAT n = DEREF_nat (exp_int_lit_nat (a));
	if (!is_calc_nat (n)) {
		/* Zero is false, non-zero is true */
		unsigned tag = DEREF_unsigned (exp_int_lit_etag (a));
		unsigned b = BOOL_NEGATE (is_zero_nat (n));
		e = make_bool_exp (b, tag);
	} else {
		/* Calculated case */
		TYPE t = DEREF_type (exp_type (a));
		if (check_int_type (t, btype_bool)) {
			e = a;
		} else {
			a = calc_exp_value (a);
			MAKE_exp_test (type_bool, ntest_not_eq, a, e);
			MAKE_nat_calc (e, n);
			MAKE_exp_int_lit (type_bool, n, exp_test_tag, e);
		}
	}
	return (e);
}


/*
 *    EVALUATE A CONSTANT COMPARISON OPERATION
 *
 *    This routine is used to evaluate the comparison operation indicated by
 *    op on the integer constant expressions a and b.  Any necessary operand
 *    conversions and arithmetic type conversions have already been performed
 *    on a and b.
 */

EXP
make_compare_nat(NTEST op, EXP a, EXP b)
{
	EXP e;
	NAT n = DEREF_nat (exp_int_lit_nat (a));
	NAT m = DEREF_nat (exp_int_lit_nat (b));
	int c = compare_nat (n, m);
	if (c == 0) {
		/* n and m are definitely equal */
		if (!overflow_exp (a)) {
			unsigned cond = BOOL_FALSE;
			switch (op) {
			case ntest_eq :
			case ntest_less_eq :
			case ntest_greater_eq : {
				cond = BOOL_TRUE;
				break;
			}
			}
			e = make_bool_exp (cond, exp_compare_tag);
			return (e);
		}
	} else if (c == 1) {
		/* n is definitely greater than m */
		if (!overflow_exp (a) && !overflow_exp (b)) {
			unsigned cond = BOOL_FALSE;
			switch (op) {
			case ntest_not_eq :
			case ntest_greater :
			case ntest_greater_eq : {
				cond = BOOL_TRUE;
				break;
			}
			}
			e = make_bool_exp (cond, exp_compare_tag);
			return (e);
		}
	} else if (c == -1) {
		/* n is definitely less than m */
		if (!overflow_exp (a) && !overflow_exp (b)) {
			unsigned cond = BOOL_FALSE;
			switch (op) {
			case ntest_not_eq :
			case ntest_less :
			case ntest_less_eq : {
				cond = BOOL_TRUE;
				break;
			}
			}
			e = make_bool_exp (cond, exp_compare_tag);
			return (e);
		}
	}
	
	/* Calculated values require further calculation */
	a = calc_exp_value (a);
	b = calc_exp_value (b);
	MAKE_exp_compare (type_bool, op, a, b, e);
	MAKE_nat_calc (e, n);
	MAKE_exp_int_lit (type_bool, n, exp_compare_tag, e);
	return (e);
}


/*
 *    EVALUATE A CONSTANT CONDITIONAL OPERATION
 *
 *    This routine is used to evaluate the conditional operation 'a ? b : c'
 *    when a, b and c are all integer constant expressions.  Any necessary
 *    operand conversions and arithmetic type conversions have already been
 *    performed on a, b and c.
 */

EXP
make_cond_nat(EXP a, EXP b, EXP c)
{
	EXP e;
	TYPE t = DEREF_type (exp_type (b));
	NAT n = DEREF_nat (exp_int_lit_nat (b));
	NAT m = DEREF_nat (exp_int_lit_nat (c));
	unsigned p = test_bool_exp (a);
	if (p == BOOL_TRUE && !overflow_exp (c)) {
		/* EMPTY */
	} else if (p == BOOL_FALSE && !overflow_exp (b)) {
		n = m;
	} else {
		/* Calculated case */
		b = calc_exp_value (b);
		c = calc_exp_value (c);
		MAKE_exp_if_stmt (t, a, b, c, NULL_id, e);
		MAKE_nat_calc (e, n);
	}
	MAKE_exp_int_lit (t, n, exp_if_stmt_tag, e);
	return (e);
}


/*
 *    DOES ONE EXPRESSION DIVIDE ANOTHER?
 *
 *    This routine returns true if a and b are both integer constant
 *    expressions and b divides a.
 */

int
divides_nat(EXP a, EXP b)
{
	if (IS_exp_int_lit (a) && IS_exp_int_lit (b)) {
		unsigned long vn, vm;
		NAT n = DEREF_nat (exp_int_lit_nat (a));
		NAT m = DEREF_nat (exp_int_lit_nat (b));
		if (IS_nat_neg (n)) n = DEREF_nat (nat_neg_arg (n));
		if (IS_nat_neg (m)) m = DEREF_nat (nat_neg_arg (m));
		vn = get_nat_value (n);
		vm = get_nat_value (m);
		if (vm == 0) return (1);
		if (vn == EXTENDED_MAX || vm == EXTENDED_MAX) return (0);
		if ((vn % vm) == 0) return (1);
	}
	return (0);
}


/*
 *    EVALUATE A CONSTANT CONDITION
 *
 *    This routine evaluates the boolean expression e, returning BOOL_FALSE,
 *    BOOL_TRUE or BOOL_UNKNOWN depending on whether it is always false,
 *    always true, or constant, but indeterminate.  BOOL_INVALID is returned
 *    for non-constant expressions.
 */

unsigned
eval_const_cond(EXP e)
{
	if (!IS_NULL_exp (e)) {
		switch (TAG_exp (e)) {
		case exp_int_lit_tag : {
			/* Boolean constants */
			unsigned b = test_bool_exp (e);
			return (b);
		}
		case exp_not_tag : {
			/* Logical negation */
			EXP a = DEREF_exp (exp_not_arg (e));
			unsigned b = eval_const_cond (a);
			if (b == BOOL_FALSE) return (BOOL_TRUE);
			if (b == BOOL_TRUE) return (BOOL_FALSE);
			return (b);
		}
		case exp_log_and_tag : {
			/* Logical and */
			EXP a1 = DEREF_exp (exp_log_and_arg1 (e));
			EXP a2 = DEREF_exp (exp_log_and_arg2 (e));
			unsigned b1 = eval_const_cond (a1);
			unsigned b2 = eval_const_cond (a2);
			if (b1 == BOOL_FALSE || b2 == BOOL_FALSE) {
				return (BOOL_FALSE);
			}
			if (b1 == BOOL_TRUE && b2 == BOOL_TRUE) {
				return (BOOL_TRUE);
			}
			if (b1 == BOOL_INVALID) return (BOOL_INVALID);
			if (b2 == BOOL_INVALID) return (BOOL_INVALID);
			return (BOOL_UNKNOWN);
		}
		case exp_log_or_tag : {
			/* Logical or */
			EXP a1 = DEREF_exp (exp_log_or_arg1 (e));
			EXP a2 = DEREF_exp (exp_log_or_arg2 (e));
			unsigned b1 = eval_const_cond (a1);
			unsigned b2 = eval_const_cond (a2);
			if (b1 == BOOL_TRUE || b2 == BOOL_TRUE) {
				return (BOOL_TRUE);
			}
			if (b1 == BOOL_FALSE && b2 == BOOL_FALSE) {
				return (BOOL_FALSE);
			}
			if (b1 == BOOL_INVALID) return (BOOL_INVALID);
			if (b2 == BOOL_INVALID) return (BOOL_INVALID);
			return (BOOL_UNKNOWN);
		}
		case exp_test_tag : {
			/* Test against zero */
			EXP a = DEREF_exp (exp_test_arg (e));
			NTEST op = DEREF_ntest (exp_test_tst (e));
			if (IS_exp_null (a)) {
				/* Null pointers */
				if (op == ntest_eq) return (BOOL_TRUE);
				if (op == ntest_not_eq) return (BOOL_FALSE);
			}
			break;
		}
		case exp_location_tag : {
			/* Conditions can contain locations */
			EXP a = DEREF_exp (exp_location_arg (e));
			return (eval_const_cond (a));
		}
		}
		if (is_const_exp (e, -1)) return (BOOL_UNKNOWN);
	}
	return (BOOL_INVALID);
}


/*
 *    IS AN INTEGER CONSTANT EXPRESSION ZERO?
 *
 *    This routine checks whether the expression a is a zero integer constant.
 *    It is used to identify circumstances when zero is actually the null
 *    pointer etc.
 */

int
is_zero_exp(EXP a)
{
	if (!IS_NULL_exp (a) && IS_exp_int_lit (a)) {
		NAT n = DEREF_nat (exp_int_lit_nat (a));
		return (is_zero_nat (n));
	}
	return (0);
}


/*
 *    IS AN EXPRESSION A NULL POINTER CONSTANT?
 *
 *    This routine checks whether the expression a is a null pointer
 *    constant.  Some expressions have special rules for them.
 */

int
is_npc_exp(EXP a)
{
	if (IS_exp_null (a) && DEREF_int (exp_null_ptr_const (a))) return (1);
	return (is_zero_exp (a));
}


/*
 *    IS AN INTEGER CONSTANT A LITERAL?
 *
 *    This routine checks whether the integer constant expression a is an
 *    integer literal or is the result of a constant evaluation.  This
 *    information is recorded in the etag field of the expression.  It
 *    returns 2 if the literal was precisely '0'.
 */

int
is_literal(EXP a)
{
	if (IS_exp_int_lit (a)) {
		unsigned etag = DEREF_unsigned (exp_int_lit_etag (a));
		if (etag == exp_int_lit_tag) return (1);
		if (etag == exp_null_tag) return (2);
		if (etag == exp_identifier_tag) return (1);
	}
	return (0);
}


/*
 *    FIND A SMALL FLOATING POINT LITERAL
 *
 *    This routine returns the nth literal associated with the floating point
 *    type t.  The null literal is returned if n is too large.
 */

FLOAT
get_float(TYPE t, int n)
{
	FLOAT_TYPE ft = DEREF_ftype (type_floating_rep (t));
	LIST (FLOAT) fp = DEREF_list (ftype_small (ft));
	while (!IS_NULL_list (fp)) {
		if (n == 0) {
			FLOAT flt = DEREF_flt (HEAD_list (fp));
			return (flt);
		}
		n--;
		fp = TAIL_list (fp);
	}
	return (NULL_flt);
}


/*
 *    INITIALISE A FLOATING POINT TYPE
 *
 *    This routine initialises the floating point type ft by creating its
 *    list of small literal values.
 */

void
init_float(FLOAT_TYPE ft)
{
	int n;
	NAT z = small_nat [0];
	string fp = small_number [0];
	LIST (FLOAT) p = NULL_list (FLOAT);
	for (n = SMALL_FLT_SIZE - 1; n >= 0; n--) {
		FLOAT f;
		string ip = small_number [n];
		MAKE_flt_simple (ip, fp, z, f);
		CONS_flt (f, p, p);
	}
	COPY_list (ftype_small (ft), p);
	return;
}


/*
 *    INITIALISE CONSTANT EVALUATION ROUTINES
 *
 *    This routine initialises the small_nat array and the buffers used in
 *    the constant evaluation routines.
 */

void
init_constant(void)
{
	int n = 0;
	while (n < SMALL_NAT_ALLOC) {
		IGNORE make_small_nat (n);
		IGNORE make_small_nat (-n);
		n++;
	}
	while (n < SMALL_NAT_SIZE) {
		small_nat [n] = NULL_nat;
		small_neg_nat [n] = NULL_nat;
		n++;
	}
	small_neg_nat [0] = small_nat [0];
	CONS_unsigned (0, NULL_list (unsigned), small_nat_1);
	CONS_unsigned (0, NULL_list (unsigned), small_nat_2);
	small_number [0] = ustrlit ("0");
	small_number [1] = ustrlit ("1");
	return;
}
