/*
* 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;
}
syntax highlighted by Code2HTML, v. 0.9.1