/*
* 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/tools/tnc/eval.c,v 1.7 2005/09/21 16:59:15 stefanf Exp $
*/
#include "config.h"
#include "cstring.h"
#include "fmm.h"
#include "types.h"
#include "eval.h"
#include "node.h"
#include "shape.h"
#include "table.h"
#include "tdf.h"
#include "utility.h"
/*
* CREATE A NAT CORRESPONDING TO THE VALUE n
*
* This routine creates a node corresponding to the nat with value n.
*/
node *
make_nat(long n)
{
node *p = new_node ();
p->cons = cons_no (SORT_nat, ENC_make_nat);
p->son = new_node ();
p->son->cons = make_construct (SORT_small_tdfint);
p->son->cons->encoding = n;
return (p);
}
/*
* CREATE AN INTEGER CORRESPONDING TO THE VALUE n
*
* This routine creates a node corresponding to the sign bit and the
* value of n.
*/
node *
make_int(long n)
{
node *p = new_node ();
if (n < 0) {
p->cons = &true_cons;
n = -n;
} else {
p->cons = &false_cons;
}
p->bro = new_node ();
p->bro->cons = make_construct (SORT_small_tdfint);
p->bro->cons->encoding = n;
return (p);
}
/*
* CREATE A SIGNED_NAT CORRESPONDING TO THE VALUE n
*
* This routine creates a node corresponding to the signed_nat with value n.
*/
static node *
make_signed_nat(long n)
{
node *p = new_node ();
p->cons = cons_no (SORT_signed_nat, ENC_make_signed_nat);
p->son = make_int (n);
return (p);
}
/*
* CREATE A MAKE_INT EXPRESSION CORRESPONDING TO THE VALUE n
*
* This routine creates a node corresponding to a make_int expression of
* shape sh and value n or val.
*/
static node *
make_int_exp(node *sh, long n, char *val)
{
node *p = new_node ();
p->cons = cons_no (SORT_exp, ENC_make_int);
p->son = copy_node (sh->son);
p->son->bro = make_signed_nat (n);
if (val) {
/* Assign large values */
node *r = p->son->bro->son->bro;
r->cons = make_construct (SORT_tdfint);
r->cons->name = val;
}
p->shape = sh;
return (p);
}
/*
* IS A NODE A CONSTANT?
*
* This routine checks whether the node p represents a small integer
* constant. If so it returns the value of the constant via pn.
*/
static boolean
is_constant(node *p, long *pn)
{
if (p) {
sortname s = p->cons->sortnum;
long n = p->cons->encoding;
if (s == SORT_exp && n == ENC_make_int) {
p = p->son->bro;
s = p->cons->sortnum;
n = p->cons->encoding;
}
if (s == SORT_signed_nat && n == ENC_make_signed_nat) {
/* Allow signed integer literals */
long negate = p->son->cons->encoding;
p = p->son->bro;
s = p->cons->sortnum;
n = p->cons->encoding;
if (negate) n = -n;
} else if (s == SORT_nat && n == ENC_make_nat) {
/* Allow integer literals */
p = p->son;
s = p->cons->sortnum;
n = p->cons->encoding;
} else if (s == SORT_bool) {
/* Allow boolean literals */
if (n == ENC_false) {
*pn = 0;
return (1);
}
if (n == ENC_true) {
*pn = 1;
return (1);
}
}
if (s == SORT_small_tdfint) {
/* Small constant found */
*pn = n;
return (1);
}
}
return (0);
}
/*
* INTEGER TYPE MASKS
*
* These values give the maximum values for the various known integral
* types.
*/
static long var_max = 32;
static unsigned long *var_mask;
/*
* IS A SHAPE A KNOWN INTEGRAL TYPE?
*
* This routine checks whether the shape sh represents a known integral
* type. If so it returns the sign via pn and the size via pm.
*/
static boolean
is_var_width(node *sh, long *pn, long *pm)
{
if (sh && sh->cons->encoding == ENC_integer) {
if (sh->son->cons->encoding == ENC_var_width) {
node *q = sh->son->son;
if (is_constant (q, pn)) {
if (is_constant (q->bro, pm)) {
return (1);
}
}
}
}
return (0);
}
/*
* CALCULATE 1 << n
*
* This routine calculates '1 << n' as a string of octal digits.
*/
static char *
shift_one(long n)
{
long i;
char buff [100];
switch (n % 3) {
case 0 : buff [0] = '1' ; break;
case 1 : buff [0] = '2' ; break;
case 2 : buff [0] = '4' ; break;
}
for (i = 0 ; i < n / 3 ; i++) {
buff [ i + 1 ] = '0';
}
return (string_ncopy (buff, (int) (i + 1)));
}
/*
* CALCULATE val - 1
*
* This routine calculates 'val - 1' for the string of octal digits val,
* returning the result as a string of octal digits.
*/
static char *
minus_one(char *val)
{
int i, n = (int) strlen (val);
char *res = string_ncopy (val, n);
for (i = n - 1 ; i >= 0 ; i--) {
char c = res [i];
if (c != '0') {
res [i] = c - 1;
break;
}
res [i] = '7';
}
if (res [0] == '0') res++;
return (res);
}
/*
* EVALUATE A CONSTANT EXPRESSION
*
* This routine evaluates the constant expression given by the operation
* op applied to the operands a and b in the type indicated by the shape
* sh. err gives the associated overflow error treatment, if any. The
* routine returns null if the value cannot be calculated.
*/
static node *
eval_exp(long op, long err, node *sh, long a, long b)
{
long c = 0;
long sz = 0;
long sgn = 0;
char *val = null;
/* Check result shape */
if (!is_var_width (sh, &sgn, &sz)) return (null);
if (!sgn && (a < 0 || b < 0)) return (null);
if (sz < 1) return (null);
if (sz > var_max) {
if (sz < 256) {
/* Evaluate some special cases */
if (op == ENC_shift_left && a == 1) {
if (!sgn && b < sz) val = shift_one (b);
} else if (op == ENC_negate && a == 1) {
if (!sgn && err == ENC_wrap) {
val = shift_one (sz);
val = minus_one (val);
}
} else if (op == ENC_minus && a == 0 && b == 1) {
if (!sgn && err == ENC_wrap) {
val = shift_one (sz);
val = minus_one (val);
}
}
if (val) return (make_int_exp (sh, c, val));
}
return (null);
}
/* Evaluate result */
switch (op) {
case ENC_abs : {
c = a;
if (c < 0) c = -a;
break;
}
case ENC_and : {
if (a < 0 || b < 0) return (null);
c = (a & b);
break;
}
case ENC_change_variety : {
c = a;
break;
}
case ENC_div0 :
case ENC_div1 :
case ENC_div2 : {
if (a < 0 || b <= 0) return (null);
c = a / b;
break;
}
case ENC_maximum : {
c = (a >= b ? a : b);
break;
}
case ENC_minimum : {
c = (a < b ? a : b);
break;
}
case ENC_minus : {
c = a - b;
break;
}
case ENC_mult : {
c = a * b;
break;
}
case ENC_negate : {
c = -a;
break;
}
case ENC_not : {
if (sgn || err != ENC_wrap) return (null);
c = ~a;
break;
}
case ENC_or : {
if (a < 0 || b < 0) return (null);
c = (a | b);
break;
}
case ENC_plus : {
c = a + b;
break;
}
case ENC_rem0 :
case ENC_rem1 :
case ENC_rem2 : {
if (a < 0 || b <= 0) return (null);
c = a % b;
break;
}
case ENC_shift_left : {
if (sgn || err != ENC_wrap) return (null);
if (b < var_max) {
unsigned long ua = (unsigned long) a;
unsigned long ub = (unsigned long) b;
c = (long) (ua << ub);
} else {
c = 0;
}
break;
}
case ENC_shift_right : {
if (sgn || err != ENC_wrap) return (null);
if (b < var_max) {
unsigned long ua = (unsigned long) a;
unsigned long ub = (unsigned long) b;
c = (long) (ua >> ub);
} else {
c = 0;
}
break;
}
case ENC_xor : {
if (a < 0 || b < 0) return (null);
c = (a ^ b);
break;
}
case ENC_power :
case ENC_rotate_left :
case ENC_rotate_right :
default : {
/* NOT YET IMPLEMENTED */
return (null);
}
}
/* Check for overflow */
if (sgn) {
long v = (long) var_mask [ sz - 1 ];
if (c < -(v + 1) || c > v) return (null);
} else {
unsigned long uc;
unsigned long uv = var_mask [ sz ];
if (c < 0) {
if (err != ENC_wrap) return (null);
uc = (unsigned long) -c;
uc = ((uv - uc + 1) & uv);
if (uc > var_mask [ var_max - 1 ]) {
val = ulong_to_octal (uc);
uc = 0;
}
} else {
uc = (unsigned long) c;
if (uc > uv) {
if (err != ENC_wrap) return (null);
uc &= uv;
}
}
c = (long) uc;
}
/* Create the result */
return (make_int_exp (sh, c, val));
}
/*
* EVALUATE A CONSTANT CONDITION
*
* This routine evaluates the condition tst for the values a and b. It
* returns 0 if the test is false, 1 if it is true and -1 if it cannot
* be evaluated.
*/
static int
eval_test(long tst, long a, long b)
{
int res = 0;
switch (tst) {
case ENC_equal :
case ENC_not_less_than_and_not_great : {
if (a == b) res = 1;
break;
}
case ENC_not_equal :
case ENC_less_than_or_greater_than : {
if (a != b) res = 1;
break;
}
case ENC_greater_than :
case ENC_not_less_than_or_equal : {
if (a > b) res = 1;
break;
}
case ENC_greater_than_or_equal :
case ENC_not_less_than : {
if (a >= b) res = 1;
break;
}
case ENC_less_than :
case ENC_not_greater_than_or_equal : {
if (a < b) res = 1;
break;
}
case ENC_less_than_or_equal :
case ENC_not_greater_than : {
if (a <= b) res = 1;
break;
}
default : {
res = -1;
break;
}
}
return (res);
}
/*
* EVALUATE A DECREMENT EXPRESSION
*
* This routine evaluates 'p - 1' for the expression node p. It returns
* null if the value cannot be evaluated.
*/
static node *
eval_decr(node *p)
{
if (p->cons->encoding == ENC_make_int) {
node *sh = p->shape;
if (sh == null) sh = sh_integer (p->son);
p = p->son->bro;
if (p->cons->encoding == ENC_make_signed_nat) {
if (!p->son->cons->encoding) {
p = p->son->bro;
if (p->cons->sortnum == SORT_tdfint) {
long c = 0;
char *val = minus_one (p->cons->name);
if (fits_ulong (val, 1)) {
c = (long) octal_to_ulong (val);
val = null;
}
return (make_int_exp (sh, c, val));
}
}
}
}
return (null);
}
/*
* EVALUATE A NODE
*
* This routine evaluates the node p. p will not be null.
*/
static node *
eval_node(node *p)
{
sortname s = p->cons->sortnum;
long n = p->cons->encoding;
if (s > 0 && n == sort_conds [s]) {
/* Conditional constructs */
long m = 0;
if (is_constant (p->son, &m)) {
p = p->son->bro;
if (m == 0) p = p->bro;
return (p->son);
}
}
if (s == SORT_exp) {
long m1 = 0, m2 = 0;
switch (n) {
case ENC_make_int : {
/* Make sure that constants have a shape */
if (p->shape == null) p->shape = sh_integer (p->son);
break;
}
case ENC_change_variety : {
/* Allow for change_variety */
node *r = p->son->bro;
if (p->shape == null) p->shape = sh_integer (r);
if (is_constant (r->bro, &m1)) {
long err = p->son->cons->encoding;
node *q = eval_exp (n, err, p->shape, m1, m2);
if (q) p = q;
}
break;
}
case ENC_integer_test : {
/* Allow for integer_test */
node *r = p->son->bro->bro->bro;
if (is_constant (r, &m1)) {
if (is_constant (r->bro, &m2)) {
long tst = p->son->bro->cons->encoding;
int res = eval_test (tst, m1, m2);
if (res == 0) {
node *q = new_node ();
q->cons = cons_no (SORT_exp, ENC_goto);
q->son = copy_node (p->son->bro->bro);
return (q);
}
if (res == 1) {
node *q = new_node ();
q->cons = cons_no (SORT_exp, ENC_make_top);
return (q);
}
}
}
break;
}
case ENC_conditional : {
/* Allow for conditional */
node *r = p->son->bro;
if (is_constant (r->bro, &m2)) {
if (is_constant (r, &m1)) {
/* First branch terminates */
return (copy_node (r));
}
if (r->cons->encoding == ENC_goto) {
if (eq_node (p->son, r->son)) {
/* First branch is a jump */
return (copy_node (r->bro));
}
}
}
break;
}
case ENC_sequence : {
/* Allow for sequence */
boolean reached = 1;
node *q = null;
node *r = p->son->son;
while (r != null) {
if (is_constant (r, &m1)) {
if (reached) q = r;
} else if (r->cons->encoding == ENC_goto) {
if (reached) q = r;
reached = 0;
} else if (r->cons->encoding == ENC_make_top) {
if (reached) q = r;
} else {
return (p);
}
r = r->bro;
}
r = p->son->bro;
if (is_constant (r, &m1)) {
if (reached) q = r;
} else if (r->cons->encoding == ENC_goto) {
if (reached) q = r;
} else if (r->cons->encoding == ENC_make_top) {
if (reached) q = r;
} else {
return (p);
}
q = copy_node (q);
return (q);
}
case ENC_not : {
/* Unary operations */
node *r = p->son;
if (is_constant (r, &m1)) {
long err = ENC_wrap;
node *q = eval_exp (n, err, r->shape, m1, m2);
if (q) p = q;
}
break;
}
case ENC_abs :
case ENC_negate : {
/* Unary operations with error treatment */
node *r = p->son->bro;
if (is_constant (r, &m1)) {
long err = p->son->cons->encoding;
node *q = eval_exp (n, err, r->shape, m1, m2);
if (q) p = q;
}
break;
}
case ENC_and :
case ENC_maximum :
case ENC_minimum :
case ENC_or :
case ENC_rotate_left :
case ENC_rotate_right :
case ENC_shift_right :
case ENC_xor : {
/* Binary operations */
node *r = p->son;
if (is_constant (r, &m1)) {
if (is_constant (r->bro, &m2)) {
long err = ENC_wrap;
node *q = eval_exp (n, err, r->shape, m1, m2);
if (q) p = q;
}
}
break;
}
case ENC_minus :
case ENC_mult :
case ENC_plus :
case ENC_power :
case ENC_shift_left : {
/* Binary operations with error treatment */
node *r = p->son->bro;
if (is_constant (r->bro, &m2)) {
if (is_constant (r, &m1)) {
long err = p->son->cons->encoding;
node *q = eval_exp (n, err, r->shape, m1, m2);
if (q) p = q;
} else if (n == ENC_minus && m2 == 1) {
node *q = eval_decr (r);
if (q) p = q;
}
}
break;
}
case ENC_div0 :
case ENC_div1 :
case ENC_div2 :
case ENC_rem0 :
case ENC_rem1 :
case ENC_rem2 : {
/* Binary operations with two error treatments */
node *r = p->son->bro->bro;
if (is_constant (r, &m1)) {
if (is_constant (r->bro, &m2)) {
long err = p->son->bro->cons->encoding;
node *q = eval_exp (n, err, r->shape, m1, m2);
if (q) p = q;
}
}
break;
}
}
} else if (s == SORT_nat) {
if (n == ENC_computed_nat) {
long m = 0;
if (is_constant (p->son, &m)) {
if (m >= 0) return (make_nat (m));
}
}
} else if (s == SORT_signed_nat) {
if (n == ENC_computed_signed_nat) {
long m = 0;
if (is_constant (p->son, &m)) {
return (make_signed_nat (m));
}
if (p->son->cons->encoding == ENC_make_int) {
return (copy_node (p->son->son->bro));
}
} else if (n == ENC_snat_from_nat) {
long m1 = 0, m2 = 0;
if (is_constant (p->son, &m1)) {
if (is_constant (p->son->bro, &m2)) {
if (m1) m2 = -m2;
return (make_signed_nat (m2));
}
}
}
}
return (p);
}
/*
* RECURSIVELY EVALUATE A NODE
*
* This routine recursively calls eval_node to evaluate the node p and
* all its subnodes.
*/
static node *
eval_fully(node *p)
{
if (p) {
node *q = p->bro;
p->son = eval_fully (p->son);
p = eval_node (p);
p->bro = eval_fully (q);
}
return (p);
}
/*
* EVALUATE A TOKEN DEFINITION
*
* This routine evaluates the definition of the token p.
*/
static void
eval_tokdef(construct *p)
{
if (p->encoding != -1) {
tok_info *info = get_tok_info (p);
info->def = eval_fully (info->def);
}
return;
}
/*
* EVALUATE AN ALIGNMENT TAG DEFINITION
*
* This routine evaluates the definition of the alignment tag p.
*/
static void
eval_aldef(construct *p)
{
if (p->encoding != -1) {
al_tag_info *info = get_al_tag_info (p);
info->def = eval_fully (info->def);
}
return;
}
/*
* EVALUATE A TAG DECLARATION AND DEFINITION
*
* This routine evaluates the declaration and definition of the tag p.
*/
static void
eval_tagdef(construct *p)
{
if (p->encoding != -1) {
tag_info *info = get_tag_info (p);
info->dec = eval_fully (info->dec);
info->def = eval_fully (info->def);
}
return;
}
/*
* EVALUATE ALL TOKEN DEFINITIONS
*
* This routine evaluates all token, alignment tag and tag definitions.
*/
void
eval_all(void)
{
long i;
unsigned long m = 0;
var_max = BYTESIZE * (long) sizeof (long);
var_mask = xalloc (sizeof (unsigned long) * (var_max + 1));
var_mask [0] = 0;
for (i = 1 ; i <= var_max ; i++) {
m = 2 * m + 1;
var_mask [i] = m;
}
init_shapes ();
apply_to_all (eval_tokdef, SORT_token);
apply_to_all (eval_aldef, SORT_al_tag);
apply_to_all (eval_tagdef, SORT_tag);
return;
}
syntax highlighted by Code2HTML, v. 0.9.1