inline const COOMatrix::value_type* COOMatrix::val() const {
return const_val();
}
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;
}
