Rev 2 | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
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.
*/
#include "config.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
PROTO_N ( ( n ) )
PROTO_T ( 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
PROTO_N ( ( n ) )
PROTO_T ( 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
PROTO_N ( ( n ) )
PROTO_T ( 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
PROTO_N ( ( sh, n, val ) )
PROTO_T ( node *sh X long n X 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
PROTO_N ( ( p, pn ) )
PROTO_T ( node *p X 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
PROTO_N ( ( sh, pn, pm ) )
PROTO_T ( node *sh X long *pn X 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
PROTO_N ( ( n ) )
PROTO_T ( 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_copy ( 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
PROTO_N ( ( val ) )
PROTO_T ( char *val )
{
int i, n = ( int ) strlen ( val ) ;
char *res = string_copy ( 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
PROTO_N ( ( op, err, sh, a, b ) )
PROTO_T ( long op X long err X node *sh X long a X 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
PROTO_N ( ( tst, a, b ) )
PROTO_T ( long tst X long a X 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
PROTO_N ( ( p ) )
PROTO_T ( 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
PROTO_N ( ( p ) )
PROTO_T ( 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
PROTO_N ( ( p ) )
PROTO_T ( 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
PROTO_N ( ( p ) )
PROTO_T ( 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
PROTO_N ( ( p ) )
PROTO_T ( 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
PROTO_N ( ( p ) )
PROTO_T ( 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
PROTO_Z ()
{
long i ;
unsigned long m = 0 ;
var_max = BYTESIZE * ( long ) sizeof ( long ) ;
var_mask = alloc_nof ( 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 ;
}