void fold_const_expr_if(expr *e, intval *piv, enum constyness *pconst_type)
{
intval vals[3];
enum constyness consts[3];
const_fold(e->expr, &vals[0], &consts[0]);
const_fold(e->rhs, &vals[2], &consts[2]);
if(e->lhs){
const_fold(e->lhs, &vals[1], &consts[1]);
}else{
consts[1] = consts[0];
vals[1] = vals[0];
}
*pconst_type = CONST_NO;
if(consts[0] == CONST_WITH_VAL){
const int idx_from = vals[0].val ? 1 : 2;
if(consts[idx_from] == CONST_WITH_VAL){
memcpy(piv, &vals[idx_from], sizeof *piv);
*pconst_type = CONST_WITH_VAL;
}
}
}
static void static_array_check(
decl *arg_decl, expr *arg_expr)
{
/* if ty_func is x[static %d], check counts */
type *ty_expr = arg_expr->tree_type;
type *ty_decl = decl_is_decayed_array(arg_decl);
consty k_decl;
if(!ty_decl)
return;
assert(ty_decl->type == type_array);
if(!ty_decl->bits.array.is_static)
return;
/* want to check any pointer type */
if(expr_is_null_ptr(arg_expr, NULL_STRICT_ANY_PTR)){
cc1_warn_at(&arg_expr->where,
attr_nonnull,
"passing null-pointer where array expected");
return;
}
if(!ty_decl->bits.array.size)
return;
const_fold(ty_decl->bits.array.size, &k_decl);
if((ty_expr = type_is_decayed_array(ty_expr))){
assert(ty_expr->type == type_array);
if(ty_expr->bits.array.size){
consty k_arg;
const_fold(ty_expr->bits.array.size, &k_arg);
if(k_decl.type == CONST_NUM
&& K_INTEGRAL(k_arg.bits.num)
&& k_arg.bits.num.val.i < k_decl.bits.num.val.i)
{
cc1_warn_at(&arg_expr->where,
static_array_bad,
"array of size %" NUMERIC_FMT_D
" passed where size %" NUMERIC_FMT_D " needed",
k_arg.bits.num.val.i, k_decl.bits.num.val.i);
}
}
}
/* else it's a random pointer, just be quiet */
}
void fold_expr_if(expr *e, symtable *stab)
{
enum constyness is_const;
intval dummy;
fold_expr(e->expr, stab);
const_fold(e->expr, &dummy, &is_const);
if(is_const != CONST_NO)
POSSIBLE_OPT(e->expr, "constant ?: expression");
fold_need_expr(e->expr, "?: expr", 1);
fold_disallow_st_un(e->expr, "?: expr");
if(e->lhs){
fold_expr(e->lhs, stab);
fold_disallow_st_un(e->lhs, "?: lhs");
}
fold_expr(e->rhs, stab);
fold_disallow_st_un(e->rhs, "?: rhs");
e->tree_type = decl_copy(e->rhs->tree_type); /* TODO: check they're the same */
e->freestanding = (e->lhs ? e->lhs : e->expr)->freestanding || e->rhs->freestanding;
}
static int eq_array(type *candidate, void *ctx)
{
struct ctx_array *c = ctx;
consty k;
assert(candidate->type == type_array);
if(candidate->bits.array.is_static != c->is_static)
return 0;
if(candidate->bits.array.is_vla != c->is_vla)
return 0;
if(candidate->bits.array.size == c->sz){
/* including [] */
return 1;
}
if(!candidate->bits.array.size || !c->sz)
return 0;
const_fold(candidate->bits.array.size, &k);
if(k.type == CONST_NUM){
assert(K_INTEGRAL(k.bits.num));
return c->sz_i == k.bits.num.val.i;
}else{
/* vla - just check expression equivalence */
return candidate->bits.array.size == c->sz;
}
}
static void fold_const_expr_if(expr *e, consty *k)
{
consty consts[3];
int res;
const_fold(e->expr, &consts[0]);
const_fold(e->rhs, &consts[2]);
if(e->lhs)
const_fold(e->lhs, &consts[1]);
else
consts[1] = consts[0];
/* only evaluate lhs/rhs' constness if we need to */
if(!CONST_AT_COMPILE_TIME(consts[0].type)){
k->type = CONST_NO;
return;
}
switch(consts[0].type){
case CONST_NUM:
{
numeric *n = &consts[0].bits.num;
res = n->suffix & VAL_FLOATING ? n->val.f : n->val.i;
break;
}
case CONST_ADDR:
case CONST_STRK:
res = 1;
break;
case CONST_NEED_ADDR:
case CONST_NO:
ICE("buh");
}
res = res ? 1 : 2; /* index into consts */
if(!CONST_AT_COMPILE_TIME(consts[res].type)){
k->type = CONST_NO;
}else{
memcpy_safe(k, &consts[res]);
k->nonstandard_const = consts[res == 1 ? 2 : 1].nonstandard_const;
}
}
static void print_expr_val(expr *e)
{
consty k;
const_fold(e, &k);
UCC_ASSERT(k.type == CONST_NUM, "val expected");
UCC_ASSERT((k.bits.num.suffix & VAL_UNSIGNED) == 0, "TODO: unsigned");
if(K_INTEGRAL(k.bits.num))
fprintf(cc1_out, NUMERIC_FMT_D, k.bits.num.val.i);
else
fprintf(cc1_out, NUMERIC_FMT_LD, k.bits.num.val.f);
}
void bitfield_trunc_check(decl *mem, expr *from)
{
consty k;
if(expr_kind(from, cast)){
/* we'll warn about bitfield truncation, prevent warnings
* about cast truncation
*/
from->expr_cast_implicit = 0;
}
const_fold(from, &k);
if(k.type == CONST_NUM){
const sintegral_t kexp = k.bits.num.val.i;
/* highest may be -1 - kexp is zero */
const int highest = integral_high_bit(k.bits.num.val.i, from->tree_type);
const int is_signed = type_is_signed(mem->bits.var.field_width->tree_type);
const_fold(mem->bits.var.field_width, &k);
UCC_ASSERT(k.type == CONST_NUM, "bitfield size not val?");
UCC_ASSERT(K_INTEGRAL(k.bits.num), "fp bitfield size?");
if(highest > (sintegral_t)k.bits.num.val.i
|| (is_signed && highest == (sintegral_t)k.bits.num.val.i))
{
sintegral_t kexp_to = kexp & ~(-1UL << k.bits.num.val.i);
cc1_warn_at(&from->where,
bitfield_trunc,
"truncation in store to bitfield alters value: "
"%" NUMERIC_FMT_D " -> %" NUMERIC_FMT_D,
kexp, kexp_to);
}
}
}
static void sentinel_check(where *w, expr *e, expr **args,
const int variadic, const int nstdargs, symtable *stab)
{
#define ATTR_WARN_RET(w, ...) \
do{ cc1_warn_at(w, attr_sentinel, __VA_ARGS__); return; }while(0)
attribute *attr = func_or_builtin_attr_present(e, attr_sentinel);
int i, nvs;
expr *sentinel;
if(!attr)
return;
if(!variadic)
return; /* warning emitted elsewhere, on the decl */
if(attr->bits.sentinel){
consty k;
FOLD_EXPR(attr->bits.sentinel, stab);
const_fold(attr->bits.sentinel, &k);
if(k.type != CONST_NUM || !K_INTEGRAL(k.bits.num))
die_at(&attr->where, "sentinel attribute not reducible to integer constant");
i = k.bits.num.val.i;
}else{
i = 0;
}
nvs = dynarray_count(args) - nstdargs;
if(nvs == 0)
ATTR_WARN_RET(w, "not enough variadic arguments for a sentinel");
UCC_ASSERT(nvs >= 0, "too few args");
if(i >= nvs)
ATTR_WARN_RET(w, "sentinel index is not a variadic argument");
sentinel = args[(nstdargs + nvs - 1) - i];
/* must be of a pointer type, printf("%p\n", 0) is undefined */
if(!expr_is_null_ptr(sentinel, NULL_STRICT_ANY_PTR))
ATTR_WARN_RET(&sentinel->where, "sentinel argument expected (got %s)",
type_to_str(sentinel->tree_type));
#undef ATTR_WARN_RET
}
static void static_val(enum section_type sec, type *ty, expr *e)
{
consty k;
memset(&k, 0, sizeof k);
const_fold(e, &k);
switch(k.type){
case CONST_NEED_ADDR:
case CONST_NO:
ICE("non-constant expr-%s const=%d%s",
e->f_str(),
k.type,
k.type == CONST_NEED_ADDR ? " (needs addr)" : "");
break;
case CONST_NUM:
if(K_FLOATING(k.bits.num)){
/* asm fp const */
asm_out_fp(sec, ty, k.bits.num.val.f);
}else{
char buf[INTEGRAL_BUF_SIZ];
asm_declare_init_type(sec, ty);
integral_str(buf, sizeof buf, k.bits.num.val.i, e->tree_type);
asm_out_section(sec, "%s", buf);
}
break;
case CONST_ADDR:
asm_declare_init_type(sec, ty);
if(k.bits.addr.is_lbl)
asm_out_section(sec, "%s", k.bits.addr.bits.lbl);
else
asm_out_section(sec, "%ld", k.bits.addr.bits.memaddr);
break;
case CONST_STRK:
stringlit_use(k.bits.str->lit); /* must be before the label access */
asm_declare_init_type(sec, ty);
asm_out_section(sec, "%s", k.bits.str->lit->lbl);
break;
}
/* offset in bytes, no mul needed */
if(k.offset)
asm_out_section(sec, " + %ld", k.offset);
asm_out_section(sec, "\n");
}
void eval_static(Node node) /*;eval_static*/
{
/* Top level evaluation of static expressions and constant folding. The
* recursive procedure const_fold is invoked, and a top-level range
* check on numeric results is performed.
*/
/* If the node type is set to as_ivalue, the the N_VAL field will
* be a Const.
*/
Const result;
result = const_fold(node);
if (result->const_kind != CONST_OM)
check_overflow(node, result);
}
static void ctx_array_init(
struct ctx_array *ctx,
expr *sz,
int is_static, int is_vla)
{
ctx->sz_i = 0;
ctx->sz = sz;
ctx->is_static = is_static;
ctx->is_vla = is_vla;
if(sz){
consty k;
const_fold(sz, &k);
if(K_INTEGRAL(k.bits.num))
ctx->sz_i = k.bits.num.val.i;
}
}
static void const_expr_addr(expr *e, consty *k)
{
if(e->bits.lbl.spel){
int static_ctx = e->bits.lbl.static_ctx; /* global or static */
/*k->sym_lbl = e->bits.lbl.spel;*/
CONST_FOLD_LEAF(k);
k->type = CONST_ADDR;
k->offset = 0;
k->bits.addr.is_lbl = 1;
if(static_ctx){
e->bits.lbl.label->mustgen_spel = out_label_code("goto");
k->bits.addr.bits.lbl = e->bits.lbl.label->mustgen_spel;
}else{
k->bits.addr.bits.lbl = e->bits.lbl.label->spel;
}
}else{
const_fold(e->lhs, k);
switch(k->type){
case CONST_NEED_ADDR:
/* it's a->b, a symbol, etc */
k->type = CONST_ADDR; /* addr is const but with no value */
break;
case CONST_STRK:
case CONST_ADDR:
/* int x[]; int *p = &x;
* already addr, just roll with it.
* lvalue/etc checks are done in fold
*/
break;
default:
k->type = CONST_NO;
break;
}
}
}
unsigned type_align(type *r, const where *from)
{
struct_union_enum_st *sue;
type *test;
attribute *align;
align = type_attr_present(r, attr_aligned);
if(align){
if(align->bits.align){
consty k;
const_fold(align->bits.align, &k);
assert(k.type == CONST_NUM && K_INTEGRAL(k.bits.num));
return k.bits.num.val.i;
}
return platform_align_max();
}
if((sue = type_is_s_or_u(r)))
/* safe - can't have an instance without a ->sue */
return sue->align;
if(type_is(r, type_ptr)
|| type_is(r, type_block))
{
return platform_word_size();
}
if((test = type_is(r, type_btype)))
return btype_align(test->bits.type, from);
if((test = type_is(r, type_array)))
return type_align(test->ref, from);
return 1;
}
void sanitize_boundscheck(
expr *elhs, expr *erhs,
out_ctx *octx,
const out_val *lhs, const out_val *rhs)
{
decl *array_decl = NULL;
type *array_ty;
expr *expr_sz;
consty sz;
const out_val *val;
if(!(cc1_sanitize & CC1_UBSAN))
return;
if(type_is_ptr(elhs->tree_type))
array_decl = expr_to_declref(elhs, NULL), val = rhs;
else if(type_is_ptr(erhs->tree_type))
array_decl = expr_to_declref(erhs, NULL), val = lhs;
if(!array_decl)
return;
if(!(array_ty = type_is(array_decl->ref, type_array)))
return;
expr_sz = array_ty->bits.array.size;
if(!expr_sz)
return;
const_fold(expr_sz, &sz);
if(sz.type != CONST_NUM)
return;
if(!K_INTEGRAL(sz.bits.num))
return;
/* force unsigned compare, which catches negative indexes */
sanitize_assert_order(val, op_le, sz.bits.num.val.i, uintptr_ty(), octx, "bounds");
}
static void fold_const_expr_struct(expr *e, consty *k)
{
/* if lhs is NULL (or some pointer constant),
* const fold to struct offset, (obv. if !dot, which is taken care of in fold) */
ASSERT_NOT_DOT();
const_fold(e->lhs, k);
switch(k->type){
case CONST_NO:
case CONST_NEED_ADDR:
case CONST_STRK:
k->type = CONST_NO;
break;
case CONST_ADDR:
/* not constant unless addressed e.g. &a->b (unless array/func) */
k->type = CONST_ADDR_OR_NEED(e->bits.struct_mem.d);
/* don't touch k->bits.addr info */
/* obviously we offset this */
k->offset += struct_offset(e);
break;
case CONST_NUM:
k->type = CONST_NEED_ADDR; /* e.g. &((A *)0)->b */
/* convert the val to a memaddr */
/* read num.val before we clobber it */
k->bits.addr.bits.memaddr = k->bits.num.val.i + struct_offset(e);
k->offset = 0;
k->bits.addr.is_lbl = 0;
break;
}
}
void fold_expr_if(expr *e, symtable *stab)
{
consty konst;
type *tt_l, *tt_r;
FOLD_EXPR(e->expr, stab);
const_fold(e->expr, &konst);
fold_check_expr(e->expr, FOLD_CHK_NO_ST_UN, "if-expr");
if(e->lhs){
FOLD_EXPR(e->lhs, stab);
fold_check_expr(e->lhs,
FOLD_CHK_NO_ST_UN | FOLD_CHK_ALLOW_VOID,
"if-lhs");
}
FOLD_EXPR(e->rhs, stab);
fold_check_expr(e->rhs,
FOLD_CHK_NO_ST_UN | FOLD_CHK_ALLOW_VOID,
"if-rhs");
/*
Arithmetic Arithmetic Arithmetic type after usual arithmetic conversions
// Structure or union type Compatible structure or union type Structure or union type with all the qualifiers on both operands
void void void
Pointer to compatible type Pointer to compatible type Pointer to type with all the qualifiers specified for the type
Pointer to type NULL pointer (the constant 0) Pointer to type
Pointer to object or incomplete type Pointer to void Pointer to void with all the qualifiers specified for the type
GCC and Clang seem to relax the last rule:
a) resolve if either is any pointer, not just (void *)
b) resolve to a pointer to the incomplete-type
*/
tt_l = (e->lhs ? e->lhs : e->expr)->tree_type;
tt_r = e->rhs->tree_type;
if(type_is_integral(tt_l) && type_is_integral(tt_r)){
expr **middle_op = e->lhs ? &e->lhs : &e->expr;
expr_check_sign("?:", *middle_op, e->rhs, &e->where);
e->tree_type = op_promote_types(
op_unknown,
middle_op, &e->rhs, &e->where, stab);
}else if(type_is_void(tt_l) || type_is_void(tt_r)){
e->tree_type = type_nav_btype(cc1_type_nav, type_void);
}else if(type_cmp(tt_l, tt_r, 0) & TYPE_EQUAL_ANY){
/* pointer to 'compatible' type */
e->tree_type = type_qualify(tt_l,
type_qual(tt_l) | type_qual(tt_r));
}else{
/* brace yourself. */
int l_ptr_null = expr_is_null_ptr(
e->lhs ? e->lhs : e->expr, NULL_STRICT_VOID_PTR);
int r_ptr_null = expr_is_null_ptr(e->rhs, NULL_STRICT_VOID_PTR);
int l_complete = !l_ptr_null && type_is_complete(tt_l);
int r_complete = !r_ptr_null && type_is_complete(tt_r);
if((l_complete && r_ptr_null) || (r_complete && l_ptr_null)){
e->tree_type = l_ptr_null ? tt_r : tt_l;
}else{
int l_ptr = l_ptr_null || type_is(tt_l, type_ptr);
int r_ptr = r_ptr_null || type_is(tt_r, type_ptr);
if(l_ptr || r_ptr){
fold_type_chk_warn(
tt_l, tt_r, &e->where, "?: pointer type mismatch");
/* qualified void * */
e->tree_type = type_qualify(
type_ptr_to(type_nav_btype(cc1_type_nav, type_void)),
type_qual(tt_l) | type_qual(tt_r));
}else{
char buf[TYPE_STATIC_BUFSIZ];
warn_at(&e->where, "conditional type mismatch (%s vs %s)",
type_to_str(tt_l), type_to_str_r(buf, tt_r));
e->tree_type = type_nav_btype(cc1_type_nav, type_void);
}
}
}
e->freestanding = (e->lhs ? e->lhs : e->expr)->freestanding || e->rhs->freestanding;
}
void fold_expr_if(expr *e, symtable *stab)
{
const char *desc = "?:";
consty konst;
type *tt_l, *tt_r;
FOLD_EXPR(e->expr, stab);
const_fold(e->expr, &konst);
fold_check_expr(e->expr, FOLD_CHK_NO_ST_UN, desc);
if(e->lhs){
e->lhs = fold_expr_nonstructdecay(e->lhs, stab);
fold_check_expr(e->lhs,
FOLD_CHK_ALLOW_VOID,
"?: left operand");
}
e->rhs = fold_expr_nonstructdecay(e->rhs, stab);
fold_check_expr(e->rhs,
FOLD_CHK_ALLOW_VOID,
"?: right operand");
e->freestanding = (e->lhs ? e->lhs : e->expr)->freestanding || e->rhs->freestanding;
/*
Arithmetic Arithmetic Arithmetic type after usual arithmetic conversions
Structure or union type Compatible structure or union type Structure or union type with all the qualifiers on both operands
void void void
Pointer to compatible type Pointer to compatible type Pointer to type with all the qualifiers specified for the type
Pointer to type NULL pointer (the constant 0) Pointer to type
Pointer to object or incomplete type Pointer to void Pointer to void with all the qualifiers specified for the type
GCC and Clang seem to relax the last rule:
a) resolve if either is any pointer, not just (void *)
b) resolve to a pointer to the incomplete-type
*/
tt_l = (e->lhs ? e->lhs : e->expr)->tree_type;
tt_r = e->rhs->tree_type;
/* C11 6.5.15 */
if(type_is_arith(tt_l) && type_is_arith(tt_r)){
/* 6.5.15 p4 */
expr **middle_op = e->lhs ? &e->lhs : &e->expr;
expr_check_sign(desc, *middle_op, e->rhs, &e->where);
e->tree_type = op_promote_types(
op_unknown,
middle_op, &e->rhs, stab,
&e->where, desc);
}else if(type_is_void(tt_l) || type_is_void(tt_r)){
e->tree_type = type_nav_btype(cc1_type_nav, type_void);
}else{
const enum type_cmp cmp = type_cmp(tt_l, tt_r, 0);
if((cmp & (TYPE_EQUAL_ANY | TYPE_QUAL_ADD | TYPE_QUAL_SUB))
&& type_is_s_or_u(tt_l))
{
e->f_islval = expr_is_lval_struct;
e->tree_type = type_qualify(tt_l, type_qual(tt_l) | type_qual(tt_r));
}else{
try_pointer_propagate(e, cmp, tt_l, tt_r);
}
}
}
static Const fold_unop(Node node) /*;fold_unop*/
{
Node opn, oplist;
Const result, op1;
int op1_kind;
Symbol sym;
opn = N_AST1(node);
oplist = N_AST2(node);
op1 = const_fold((Node) (N_LIST(oplist))[1]);
if (is_const_om(op1)) return op1;
op1_kind = op1->const_kind;
sym = N_UNQ(opn);
if (sym == symbol_addui) {
/* the "+" can be ignored if it is used as a unary op */
result = op1;
}
else if (sym == symbol_addufl) {
result = op1;
}
else if (sym == symbol_addufx) {
result = op1;
}
else if (sym == symbol_subui ||
sym == symbol_subufl || sym == symbol_subufx) {
if (is_simple_value(op1)) {
if (sym == symbol_subui) {
if (is_const_int(op1)) {
if (INTV(op1) == ADA_MIN_INTEGER) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else {
result = int_const(-INTV(op1));
}
}
else if (is_const_uint(op1))
result = uint_const(int_umin(UINTV(op1)));
else chaos("eval:subui bad type");
}
else if (sym == symbol_subufl) {
const_check(op1, CONST_REAL);
result = real_const(-REALV(op1));
}
}
else {
const_check(op1, CONST_RAT);
result= rat_const(rat_umin(RATV(op1)));
}
}
else if ( sym == symbol_not) {
if (is_simple_value (op1)) {
if (op1_kind == CONST_INT)
result = int_const(1-INTV(op1)); /*bnot in setl */
else chaos("fold_unop: bad kind");
}
else { /*TBSL*/
result = const_new(CONST_OM);
}
}
else if ( sym == symbol_absi ||
sym == symbol_absfl || sym == symbol_absfx) {
if (is_simple_value(op1)) {
if (sym == symbol_absi) {
if (op1_kind == CONST_INT) result = int_const(abs(INTV(op1)));
else if (op1_kind == CONST_UINT)chaos("fold_unit absi in uint");
else chaos("fold_unop: bad kind");
}
else if (sym == symbol_absfl) {
result = real_const(fabs(REALV(op1)));
}
}
else {
result= rat_const(rat_abs(RATV(op1)));
}
}
return result;
}
static Const fold_op(Node node) /*;fold_op*/
{
Node opn, arg1, arg2, oplist;
Const result, op1, op2, tryc;
Symbol sym, op_name;
int *uint;
int rm;
Tuple tup;
int res, overflow;
opn = N_AST1(node);
oplist = N_AST2(node);
tup = N_LIST(oplist);
arg1 = (Node) tup[1];
arg2 = (Node) tup[2];
op1 = const_fold(arg1);
op2 = const_fold(arg2);
op_name = N_UNQ(opn);
/* If either operand raises and exception, so does the operation */
if (N_KIND(arg1) == as_raise) {
copy_attributes(arg1, node);
return const_new(CONST_OM);
}
if (N_KIND(arg2) == as_raise
&& op_name != symbol_andthen && op_name != symbol_orelse) {
copy_attributes(arg2, node);
return const_new(CONST_OM);
}
if (is_const_om(op1) || (is_const_om(op2)
&& (op_name != symbol_in || op_name != symbol_notin))) {
return const_new(CONST_OM);
}
sym = op_name;
if ( sym == symbol_addi || sym == symbol_addfl) {
if (sym == symbol_addi) {
res = word_add(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
else
result = real_const(REALV(op1) + REALV(op2));
}
else if ( sym == symbol_addfx) {
const_check(op1, CONST_RAT);
const_check(op2, CONST_RAT);
result= rat_const(rat_add(RATV(op1), RATV(op2)));
}
else if ( sym == symbol_subi) {
if (is_const_int(op1)) {
if (is_const_int(op2)) {
res = word_sub(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
else {
chaos("fold_op: subi operand types");
}
}
}
else if (sym == symbol_subfl) {
result = real_const(REALV(op1) - REALV(op2));
}
else if ( sym == symbol_subfx) {
const_check(op1, CONST_RAT);
const_check(op2, CONST_RAT);
result= rat_const(rat_sub(RATV(op1), RATV(op2)));
}
else if ( sym == symbol_muli) {
#ifdef TBSL
-- need to check for overflow and convert result back to int if not
-- note that low-level setl is missing calls to check_overflow that
-- are present in high-level and should be in low-level as well
result = int_mul(int_fri(op1), int_fri(op2));
#endif
/* until overflow check in */
const_check(op1, CONST_INT);
const_check(op2, CONST_INT);
res = word_mul(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
static Const const_fold(Node node) /*;const_fold*/
{
/* This recursive procedure evaluates expressions, when static.
* If node is static, its actual value is returned, and the node is
* modified to be an ivalue. Otherwise const_fold returns om, and node
* is untouched. If the static evaluation shows that the expression
* would raise an exception, a ['raise' exception] value is produced
* and placed on the tree.
*/
Fortup ft1;
Node expn, index_list, index, discr_range;
Const result;
Node opn;
Node n2, op_range;
Symbol sym, op_type;
/* */
#define is_simple_value(t) ((t)->const_kind == CONST_INT \
|| (t)->const_kind == CONST_UINT || (t)->const_kind == CONST_REAL)
if (cdebug2 > 3) { }
switch (N_KIND(node)) {
case(as_simple_name):
result = const_val(N_UNQ(node));
break;
case(as_ivalue):
result = (Const) N_VAL(node);
break;
case(as_int_literal):
/* TBSL: assuming int literal already converted check this Const*/
result = (Const) N_VAL(node);
break;
case(as_real_literal):
/*TBSL: assuming real literal already converted */
result = (Const) N_VAL(node);
break;
case(as_string_ivalue):
/* Will be static if required type has static low bound.*/
/* indx := index_type(N_TYPE(node));
* [-, lo_exp, -] := signature(indx);
* * Move this test to the expander, once format of aggregates is known.
* if is_static_expr(lo_exp) then
* lob := N_VAL(lo_exp);
* av := [v : [-, v] in comp_list];
* result := check_null_aggregate(av, lob, indices, node);
* result := ['array_ivalue', [v: [-, v] in comp_list],
* lob, lob + #comp_list - 1];
* else
*/
result = const_new(CONST_OM);
/* end if; */
break;
case(as_character_literal):
result = const_new(CONST_STR);
break;
case(as_un_op):
result = fold_unop(node);
break;
case(as_in):
opn = N_AST1(node);
op_range = N_AST2(node);
result = eval_qual_range(opn, N_TYPE(op_range));
if (is_const_constraint_error(result))
result = test_expr(FALSE);
else if (!is_const_om(result))
result = test_expr(TRUE);
break;
case(as_notin):
opn = N_AST1(node);
n2 = N_AST2(node);
result = eval_qual_range(opn, N_TYPE(n2));
if (is_const_constraint_error(result))
result = test_expr(TRUE);
else if (!is_const_constraint_error(result))
result = test_expr(FALSE);
break;
case(as_op):
result = fold_op(node);
break;
case(as_call):
{
int i;
Tuple arg_list;
Const arg;
opn = N_AST1(node);
result = const_new(CONST_OM); /* in general not static */
arg_list = N_LIST(N_AST2(node)); /* but can fold actuals. */
for (i = 1; i <= tup_size(arg_list); i++)
arg = const_fold((Node)arg_list[i]);
if (N_KIND(opn) == as_simple_name) {
sym = ALIAS(N_UNQ(opn));
if (sym != (Symbol)0 && is_literal(sym))
/* replace call by actual value of literal */
result = eval_lit_map(sym);
}
}
break;
case(as_parenthesis):
/* If the parenthesised expression is evaluable, return
* its value. Otherwise leave it parenthesised.
*/
opn = N_AST1(node);
result = const_fold(opn);
break;
case(as_qual_range):
opn = N_AST1(node);
op_type = N_TYPE(node);
result = eval_qual_range(opn, op_type);
if (is_const_constraint_error(result)) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
break;
case(as_qual_index):
eval_static(N_AST1(node));
result = const_new(CONST_OM);
break;
case(as_attribute):
case(as_range_attribute):
/* use separate procedure for C */
result = fold_attr(node);
break;
case(as_qualify):
if (fold_context)
result = const_fold(N_AST2(node));
else
/* in the context of a conformance check, keep qualification.*/
result = const_new(CONST_OM);
break;
/* Type conversion:
* /TBSL/ These conversions are not properly checked!
*/
case(as_convert):
/* use separate procedure for C */
result = fold_convert(node);
break;
case(as_array_aggregate):
/* This is treated in the expander.*/
result = const_new(CONST_OM);
break;
case(as_record_aggregate):
result = const_new(CONST_OM);
break;
case(as_selector): /*TBSL Case for discriminants needed */
expn = N_AST1(node);
eval_static(expn);
return const_new(CONST_OM);
case(as_slice):
expn = N_AST1(node);
discr_range = N_AST2(node);
eval_static(expn);
eval_static(discr_range);
return const_new(CONST_OM);
case(as_row): /* Not folded for now.*/
/* p1 := check_const_val(op1);
* if is_value(op1) then
* result := ['array_ivalue', [op1(2)], 1, 1];
* else
*/
return const_new(CONST_OM);
case(as_index):
expn = N_AST1(node);
index_list = N_AST2(node);
eval_static(expn);
FORTUP(index = (Node), N_LIST(index_list), ft1)
eval_static(index);
ENDFORTUP(ft1);
return const_new(CONST_OM);
default:
result = const_new(CONST_OM);
}
if (result->const_kind != CONST_OM)
insert_and_prune(node, result);
return result;
}
void fold_const_expr_cast(expr *e, intval *piv, enum constyness *type)
{
const_fold(e->expr, piv, type);
}
