Polaris: Expression.cc Source File

Expression.cc Go to the documentation of this file. /// /// \file Expression.cc /// /// Expression - related code: Expression class and all derived classes /// /// #ifdef POLARIS_GNU_PRAGMAS #pragma implementation "expr_funcs.h" #pragma implementation "Expression.h" /// #pragma implementation "StringExpr.h" #pragma implementation "UnaryExpr.h" #pragma implementation "BinaryExpr.h" #pragma implementation "NonBinaryExpr.h" /// #pragma implementation "ArgNumberExpr.h" #pragma implementation "ArrayRefExpr.h" #pragma implementation "CommaExpr.h" #pragma implementation "ComplexExpr.h" #pragma implementation "DoExpr.h" #pragma implementation "EqualExpr.h" #pragma implementation "FormatExpr.h" #pragma implementation "FunctionCallExpr.h" #pragma implementation "HollerithConstExpr.h" #pragma implementation "IDExpr.h" #pragma implementation "IOStarExpr.h" #pragma implementation "InfinityExpr.h" #pragma implementation "IntConstExpr.h" #pragma implementation "IntrinsicCallExpr.h" #pragma implementation "KeyExpr.h" #pragma implementation "LabelExpr.h" #pragma implementation "LambdaCallExpr.h" #pragma implementation "LogicalConstExpr.h" #pragma implementation "OmegaExpr.h" #pragma implementation "GSAExpr.h" #pragma implementation "RealConstExpr.h" #pragma implementation "ReturnStarExpr.h" #pragma implementation "StmtLabelExpr.h" #pragma implementation "StringConstExpr.h" #pragma implementation "SubStringExpr.h" #pragma implementation "TableExpr.h" #pragma implementation "DistributeExpr.h" #endif /// #include <stdio.h> #include <string.h> #include <iostream.h> #include <ctype.h> #include <limits.h> #include <set> /// #include <math.h> extern "C" double ceil(double); extern "C" double floor(double); #include "../BinRep.h" #include "../debug.h" #include "../Collection/List.h" #include "../Collection/Iterator.h" #include "../Collection/Mutator.h" #include "../Collection/RefElement.h" #include "../Collection/RefSet.h" #include "../Directive/Directive.h" #include "../Permutation.h" #include "../String.h" #include "../Statement/Statement.h" #include "../Symtab.h" #include "../Symbol/VariableSymbol.h" #include "../Symbol/FunctionSymbol.h" #include "../Symbol/SubroutineSymbol.h" #include "../Type.h" #include "../ProgramUnit.h" #include "../VDL.h" #include "../utilities/expression_util.h" #include "../utilities/string_util.h" #include "../utilities/switches_util.h" #include "../utilities/symbol_util.h" #include "../p-assert.h" #include "../macros.h" #include "../rotate.h" #include "expr.h" #include "expr_funcs.h" #include "Expression.h" #include "replace.h" #include "StringExpr.h" #include "UnaryExpr.h" #include "BinaryExpr.h" #include "NonBinaryExpr.h" #include "ArgNumberExpr.h" #include "ArrayRefExpr.h" #include "CommaExpr.h" #include "ComplexExpr.h" #include "DoExpr.h" #include "EqualExpr.h" #include "FormatExpr.h" #include "FunctionCallExpr.h" #include "HollerithConstExpr.h" #include "IDExpr.h" #include "IOStarExpr.h" #include "InfinityExpr.h" #include "IntConstExpr.h" #include "IntrinsicCallExpr.h" #include "KeyExpr.h" #include "LabelExpr.h" #include "LambdaCallExpr.h" #include "LogicalConstExpr.h" #include "OmegaExpr.h" #include "GSAExpr.h" #include "RealConstExpr.h" #include "ReturnStarExpr.h" #include "StmtLabelExpr.h" #include "StringConstExpr.h" #include "SubStringExpr.h" #include "TableExpr.h" #include "DistributeExpr.h" #include "../Wildcard/Wildcard.all.h" #include "IntrinsicTable.h" static int subst_field_print = 0; //------------------------------------------------------------------------ /// Expression base class code: /// static char *op_string[NUM_OP_TYPES] = { "DELETED_EXPRESSION_OP", "INTEGER_CONSTANT_OP", "REAL_CONSTANT_OP", "STRING_CONSTANT_OP", "LOGICAL_CONSTANT_OP", "HOLLERITH_CONSTANT_OP", "COMPLEX_OP", "ARRAY_REF_OP", "SUBSTRING_OP", "FUNCTION_CALL_OP", "INTRINSIC_CALL_OP", "LAMBDA_CALL_OP", "ARG_OP", "RETURN_OP", "LABEL_OP", "IO_STAR_OP", "FORMAT_OP", "ID_OP", "U_PLUS_OP", "U_MINUS_OP", "NOT_OP", "EQ_OP", "NE_OP", "LT_OP", "LE_OP", "GT_OP", "GE_OP", "SUB_OP", "DIV_OP", "INTDIV_OP", "RATDIV_OP", "EXP_OP", "CONCAT_OP", "ADD_OP", "MULT_OP", "OR_OP", "AND_OP", "EQV_OP", "NEQV_OP", "DO_OP", "EQUAL_OP", "COMMA_OP", "COLON_OP", "PAREN_OP", "OMEGA_OP", "REPSTAR_OP", "TABLE_ENTRY", "STMT_LABEL_OP", "KEY_OP", "KEYPAIR_OP", "INFINITY_OP", "ALPHA_OP", "GAMMA_OP", "MU_OP", "THETA_OP", "ETA_OP", "DISTRIBUTE_OP", /// ... _ /// ... Wild Card Types "ANY_EXPR_SUBSET_WC", "FORBOL_EXPR_WC", "FORBOL_STMT_WC", "FORBOL_EXPR_PMF_WC", "FORBOL_STMT_PMF_WC", "FORBOL_BLOCK_PMF_WC", "AND_WC", "OR_WC", "NOT_WC", "CONTAINS_WC", "SUCH_THAT_WC", "ANY_WC", "ANY_EXPR_OF_TYPE_WC", "ANY_CONST_WC", "ANY_INT_CONST_WC", "ANY_HOLLERITH_CONST_WC", "ANY_LOGICAL_CONST_WC", "ANY_REAL_CONST_WC", "ANY_STRING_CONST_WC", "ANY_ARRAY_REF_WC", "ANY_BINARY_WC", "ANY_COMMA_WC", "ANY_COMPLEX_WC", "ANY_ID_WC", "ANY_FUNCTION_CALL_WC", "ANY_INTRINSIC_CALL_WC", "ANY_NON_BINARY_WC", "ANY_SUBSTRING_WC", "ANY_UNARY_WC", "ANY_INT_WC", "ANY_REAL_WC" }; void set_subst_field_print() { subst_field_print = 1; } Expression::~Expression() { #ifdef CLASS_INSTANCE_REGISTRY unregister_instance(EXPRESSION, this); #endif if (_overflow) delete _overflow; _overflow = 0; _op = DELETED_EXPRESSION_OP; } void Expression::_ref_error(const char *method) const { cerr << "***Error: Expression: undefined method called:\n" << "Expression object of type " << op_string[op()] << " (number " << op() << ") called method " << method << endl; p_abort("(See above error message)"); } //------------------------------------------------------------------------ Boolean is_commutative(OP_TYPE op) { switch (op) { case ADD_OP: case MULT_OP: case AND_OP: case OR_OP: case EQV_OP: case NEQV_OP: return True; default: return False; } } Boolean is_conjunctive_op(OP_TYPE op) { switch (op) { case AND_OP: case OR_OP: case EQV_OP: case NEQV_OP: return True; default: return False; } } Boolean is_relational_op(OP_TYPE op) { switch (op) { case EQ_OP: case NE_OP: case LT_OP: case LE_OP: case GT_OP: case GE_OP: return True; default: return False; } } /// Used only to act as a return value in cases where control flow cannot /// reach the end of a procedure (in order to avoid a compiler /// warning/error) #define DUMMY_EXPR_REF (*(Expression *)0) /// Declare the following Expression argument field as an alias to another /// field #define ALIAS_ARG(class, alias, alias_to) \ void class::alias(Expression *e) { alias_to(e); } \ Expression &class::alias() const { return alias_to(); } \ Boolean class::alias ## _valid() const { return alias_to ## _valid(); } #define ALIAS_ARG_ASSERT(class, alias, alias_to, req_op, msg) \ void class::alias(Expression *e) { p_assert(e->op() == req_op, msg); \ alias_to(e); } \ Expression &class::alias() const { return alias_to(); } \ Boolean class::alias ## _valid() const { return alias_to ## _valid(); } Boolean is_logical_false(const Expression & e) { return ((e.op() == LOGICAL_CONSTANT_OP) && (e.str_data() == ".FALSE.")); } Boolean is_integer_zero(const Expression & e) { return (e.op() == INTEGER_CONSTANT_OP && e.value() == 0); } Boolean is_integer_one(const Expression & e) { return (e.op() == INTEGER_CONSTANT_OP && e.value() == 1); } Boolean is_integer_constant(const Expression & e) { return (e.op() == INTEGER_CONSTANT_OP); } Boolean is_integer_constant(const Expression & e, int val) { return (e.op() == INTEGER_CONSTANT_OP && e.value() == val); } bool is_phi_function(const Expression & e) { switch (e.op()) { case GAMMA_OP: case MU_OP: case THETA_OP: case ETA_OP: return true; default: return false; } return false; } bool is_pseudo_function(const Expression & e) { switch (e.op()) { case ALPHA_OP: case GAMMA_OP: case MU_OP: case THETA_OP: case ETA_OP: return true; case FUNCTION_CALL_OP: if (!strcmp(e.function().symbol().name_ref(), "<BETA>")) return true; default: return false; } return false; } /// Given a Fortran character constant enclosed in double quotes, convert /// it into a character constant enclosed in single quotes (making all /// necessary syntactic changes) /// The string returned must be deleted using 'delete []' /// Returns 0 if there was an error. (i.e. mismatched quotes, etc.) //////////////////////////////////////////////////////////// static char * double_to_single_quoted(const char *dbl) { int dbl_len = strlen(dbl); /// ... Need a workspace of a most 2*len(dbl) size char *work = new char[2*dbl_len + 1]; work[0] = '\''; /// ... First single quote /// ... Now go through, changing single quotes to single quote pairs, and /// ... changing double quotes pairs to double quotes int work_i, dbl_i; for (work_i = 1, dbl_i = 1; dbl_i < dbl_len - 1; ++work_i, ++dbl_i) { /// ... Everything between the outer quotes switch (dbl[dbl_i]) { case '\'': /// ... Replace with pair work[work_i ++ ] = '\''; work[work_i] = '\''; break; case '"': /// ... Replace pair with single if (dbl_i >= dbl_len - 2 || dbl[dbl_i + 1] != '"' ) { delete work; return 0; /// ... This is not a double quote pair -- error } work[work_i] = '"'; ++dbl_i; /// ... Skip the extra in the pair break; default: work[work_i] = dbl[dbl_i]; break; } } work[work_i] = '\''; /// ... Last single quote work[work_i + 1] = '\000'; /// ... NULL-terminate return work; } //////////////////////////////////////////////////////////////// /// These routines are used to propogate rank information from /// the symbol table to the Types of all Expressions. These /// are called as part of the pre-pass. //////////////////////////////////////////////////////////////// /// Report an error in an intrinsic parameter void report_param_error( Expression & expr, char *intrin, int param_num, char *expected) { cerr << "compute_intrinsic_type: Error found in intrinsic argument" << endl; cerr << "Error found in the Expression " << expr << ". The intrinsic " << intrin << " requires " << expected << " type in parameter number " << param_num << endl; p_abort("report_param_error: Parameter Error (see above)"); } /// Compute the type of expr which is an IntrinsicCallExpr void compute_intrinsic_type(Expression & expr) { IntrinsicTable tab; String intrin = expr.intrinsic().symbol().name_ref(); int index = tab.lookup_intrinsic(intrin); /// ... Check if parameter has been axed (what the hell does this mean?) if (tab.axed(index)) { cerr << "compute_intrinsic_type: Error in expression: " << expr << endl; p_abort("Attempt to call 'axed' intrinsic"); } /// ... Make sure it does not require global special handling if (!tab.special(index)) { /// ... Make sure there are some parameters if (!expr.parameters_valid()) { cerr << "compute_intrinsic_type: Error in expression: " << expr << endl; cerr << "Intrinsic required to have " << tab.num_req_params(index) << " parameters" << endl; p_abort("Invalid number of parameters"); } int num_params = expr.parameters_guarded().arg_list().entries(); /// ... Make sure there are the correct number of parameters /// ... NOTE: if the number of paramters is listed as 0, the number /// ... is variable. if ((num_params < tab.num_req_params(index)) || ((tab.num_params(index) != 0) && (num_params > tab.num_params(index)))) { cerr << "compute_intrinsic_type: Error in expression: " << expr << endl; cerr << "Intrinsic required to have between " << tab.num_req_params(index) << " and " << tab.num_params(index) << " parameters" << endl; p_abort("Invalid number of parameters"); } /// ... Make sure the parameters are of the correct type /// ... NOTE: Should also check if they are the correct rank int i = 0; for (Iterator<Expression> param = expr.parameters_guarded().arg_list(); param.valid(); ++param) { if (!param.current_valid()) { cerr << "compute_intrinsic_type: Error in expression: " << expr << endl; p_abort("Invalid parameter."); } EXPR_TYPE user_type = param.current().type().data_type(); EXPR_TYPE table_type = tab.param_type(index, i); if (user_type != table_type) { /// ... Types don`t match--check exceptions if ((table_type == INT_OR_REAL_TYPES) && ((user_type == INTEGER_TYPE) || (user_type == REAL_TYPE) || (user_type == DOUBLE_PRECISION_TYPE))) { /// ... OK, nothing to do } else if ((table_type == REAL_TYPE) && (user_type = DOUBLE_PRECISION_TYPE)) { /// ... OK, nothing to do } else if ((user_type == REAL_TYPE) && (table_type == DOUBLE_PRECISION_TYPE)) { /// ... OK, nothing to do } else if (table_type == GENERIC_TYPE) { /// ... OK, nothing to do } else { /// ... Problem! cerr << "compute_intrinsic_type: Error in " << "expression: " << expr << endl; cerr << "Type of parameter " << i << " is invalid." << endl; cerr << "Type found = " << user_type << ". Type " << "expected = " << table_type << "." << endl; p_abort("Invalid parameter."); } } int user_rank = param.current().type().rank(); int table_rank = tab.param_req_rank(index, i); if (param.current().type().rank_known() == 1) { /// ... make sure rank is known if (((table_rank == SCALAR) && (user_rank > 0)) || ((table_rank == ARRAY) && (user_rank == 0))) { cerr << "compute_intrinsic_type: Error in " << "expression: " << expr << endl; cerr << "Rank of parameter " << i << " is invalid." << endl; cerr << "Rank found = " << user_rank << ". "; switch (table_rank) { case SCALAR: cerr << "scalar"; break; case ARRAY: cerr << "array"; break; case SCALAR_OR_ARRAY: cerr << "scalar or array"; break; case SPECIAL: cerr << "special"; break; } cerr << " expected." << endl; p_abort("Invalid parameter."); } } i = (i < 3) ? i+1 : 3; /// ... if there are more than 4 params, /// ... type-check using the 4th } /// ... Determine result type -- set the expr`s type. /// ... First, set the type kind EXPR_TYPE table_type; switch (table_type = tab.return_type(index)) { case REAL_TYPE: case INTEGER_TYPE: case COMPLEX_TYPE: case LOGICAL_TYPE: case CHARACTER_TYPE: case DOUBLE_PRECISION_TYPE: { (CASTAWAY(Type &) expr.type()).set(table_type, tab.return_length(index)); } break; case INT_OR_REAL_TYPES: case GENERIC_TYPE: { /// ... The type is taken from the type of the first parameter /// ... unless the special_type flag is up, in which case it /// ... is done on a case by case basis. if (!tab.return_special(index)) expr.type(expr.parameters_guarded().arg_list()[0].type()); else { if (intrin == "ABS") { /// ... 1st param type const Type & param_type = expr.parameters_guarded().arg_list()[0].type(); if ((param_type.data_type() == REAL_TYPE) || (param_type.data_type() == INTEGER_TYPE) || (param_type.data_type() == DOUBLE_PRECISION_TYPE)) { expr.type(param_type); } else if (param_type.data_type() == COMPLEX_TYPE) expr.type( make_type(REAL_TYPE) ); else { report_param_error(expr, "ABS", 1, "INTEGER/REAL/COMPLEX"); } } else if ((intrin == "RESHAPE") || (intrin == "TRANSFER")) { /// ... take type from 2nd argument expr.type( expr.parameters_guarded().arg_list()[ 1].type() ); } else if ((intrin == "MATMUL") || (intrin == "DOTPRODUCT")) { /// ... use rules from table 7.1.4 Type lt = expr.parameters_guarded().arg_list()[0].type(); Type rt = expr.parameters_guarded().arg_list()[1].type(); int lrank = lt.rank(); int rrank = lt.rank(); lt.redimension(0); /// ... make scalar to avoid rt.redimension(0); /// ... rank conflicts if ((intrin == "DOTPRODUCT") && (lt.data_type() == LOGICAL_TYPE) && (rt.data_type() == LOGICAL_TYPE)) { /// ... log * log = log for dotproduct expr.type( make_type(LOGICAL_TYPE) ); } else { expr.type( expr_type(MULT_OP, lt, rt) ); } lt.redimension(lrank); rt.redimension(rrank); } } } break; default: { cerr << "compute_intrinsic_type: Error in " << "expression: " << expr << endl; cerr << "Type found = " << table_type << endl; p_abort( "compute_intrinsic_type: unexpected result type " "found in intrinsic table." ); } break; } /// ... Set the resulting type shape int shape = tab.return_shape(index); if (shape == SCALAR) { (CASTAWAY(Type &) expr.type()).redimension(0); } else if ((shape == ARRAY) || (shape == SCALAR_OR_ARRAY)) { /// ... Take the shape from the shape of the first argument /// ... 1st param type const Type & param_type = expr.parameters_guarded().arg_list()[0].type(); if (param_type.rank_known()) (CASTAWAY(Type &) expr.type()).redimension(param_type.rank()); else (CASTAWAY(Type &) expr.type()).rank_known(False); } else { /// ... shape == SPECIAL /// ... Use rules derived from keywords or match on names /// ... Intrinsic type: INTRINSIC(MASK, DIM) /// ... scalar if DIM absent; else it is rank(MASK) - 1 /// ... * OR * /// ... Intrinsic type: INTRINSIC(ARRAY, DIM, MASK) /// ... scalar if DIM absent /// ... otherwise rank is rank(ARRAY) - 1 /// ... * HANDLED THE SAME * if (((tab.param_key(index, 0) == "MASK") && (tab.param_key(index, 1) == "DIM")) || ((tab.param_key(index, 0) == "ARRAY") && (tab.param_key(index, 1) == "DIM") && (tab.param_key(index, 2) == "MASK"))) { if (num_params == 1) (CASTAWAY(Type &) expr.type()).redimension(0); else { /// ... 1st param type const Type & param_type = expr.parameters_guarded().arg_list()[0].type(); if (param_type.rank_known()) { (CASTAWAY(Type &) expr.type()).redimension( param_type.rank() - 1); } else { (CASTAWAY(Type &) expr.type()).rank_known(False); } } } else if ((tab.param_key(index, 0) == "ARRAY") && (tab.param_key(index, 1) == "MASK")) { /// ... Intrinsic type: INTRINSIC(ARRAY, MASK) /// ... result is an array of rank 1 (CASTAWAY(Type &) expr.type()).redimension(1); } else if ((tab.param_key(index, 0) == "MATRIX_A") && (tab.param_key(index, 1) == "MATRIX_B")) { /// ... MATMUL-style intrinsic int rank_0 = expr.parameters_guarded().arg_list()[0].type().rank(); int rank_1 = expr.parameters_guarded().arg_list()[1].type().rank(); if (((rank_0 == 1) && (rank_1 == 2)) || ((rank_0 == 2) && (rank_1 == 1))) { (CASTAWAY(Type &) expr.type()).redimension(1); } else if ((rank_0 == 2) && (rank_1 == 2)) { (CASTAWAY(Type &) expr.type()).redimension(2); } else { cerr << "compute_intrinsic_type: Error in " << "expression: " << expr << endl; cerr << "First argument has rank " << rank_0 << endl; cerr << "and second argument has rank " << rank_1 << "." << endl; cerr << "Illegal combination for matrix multiplication." << endl; p_abort( "compute_intrinsic_type: illegal parameters " "found in intrinsic MATMUL." ); } } else if ((intrin == "LBOUND") || (intrin == "UNBOUND")) { /// ... Intrinsic violates derived rules--handle case by case /// ... scalar if dim present, else rank 1 if (num_params == 2) /// ... DIM is present (CASTAWAY(Type &) expr.type()).redimension(0); else (CASTAWAY(Type &) expr.type()).redimension(1); } } } else { /// ... intrinsic _DOES_ require global special handling /// ... handle on a case by case basis } } /// Assuming the types of all of expr's subexpressions are complete /// (i.e. contain dimension info), determine expr's complete type. void determine_root_expr_type(Expression & expr) { IntrinsicTable intrin_tab; switch (expr.op()) { case COMPLEX_OP: /// ... Mark as a scalar (CASTAWAY(Type &) expr.type()).redimension(0); break; case ARRAY_REF_OP: { /// ... Rank = # of COLON_OPs in the list of subscripts int rank = 0; for (Iterator<Expression> expr_iter = expr.subscript().arg_list(); expr_iter.valid(); ++expr_iter) { if (!expr_iter.current_valid()) { cerr << "Invalid subscript found in array: " << expr << "while determining type."; p_abort( "determine_root_expr_type: invalid expression" ); } else if (expr_iter.current().op() == COLON_OP) { rank++; } } (CASTAWAY(Type &) expr.type()).redimension(rank); } break; case FUNCTION_CALL_OP: { /// ... Type is the same as the first sub-expression's type if (expr.function().symbol().type().rank_known()) { (CASTAWAY(Type &) expr.type()).redimension( expr.function().symbol().type().rank()); } else { (CASTAWAY(Type &) expr.type()).rank_known(False); } } break; case INTRINSIC_CALL_OP: { /// ... Use the intrinsic table. compute_intrinsic_type(expr); /// ... (CASTAWAY(Type &) expr.type()).rank_known(False); /// ... (CASTAWAY(Type &) expr.type()).set(UNKNOWN_TYPE); } break; case LAMBDA_CALL_OP: /// ... Statement functions must be scalar case ARG_OP: case RETURN_OP: { /// ... Return integer is scalar (CASTAWAY(Type &) expr.type()).redimension(0); } break; case U_PLUS_OP: /// ... unary operations take the type from their case U_MINUS_OP: /// ... sub-expression. case NOT_OP: case PAREN_OP: { if (expr.expr_valid()) expr.type(expr.expr_guarded().type()); else (CASTAWAY(Type &) expr.type()).rank_known(False); } break; case OR_OP: case AND_OP: case EQV_OP: case NEQV_OP: case ADD_OP: case MULT_OP: case CONCAT_OP: { Iterator<Expression> xiter = expr.arg_list(); while (!xiter.current_valid() && xiter.valid()) { ++xiter; if (!xiter.valid()) { cerr << "NonBinary expression with no arguments: " << expr << endl; p_abort("determine_root_expr_type: fatal condition"); } } Type * type_so_far = xiter.current().type_ref(); for ( ++xiter; xiter.valid(); ++xiter ) { if (xiter.current_valid()) { Type new_type = expr_type( expr.op(), *type_so_far, xiter.current().type()); delete type_so_far; type_so_far = new Type(new_type); } } expr.type( *type_so_far ); /// ... silvius: delete type_so_far; } break; case EQ_OP: case NE_OP: case LT_OP: case LE_OP: case GT_OP: case GE_OP: case SUB_OP: case DIV_OP: case INTDIV_OP: case RATDIV_OP: case EXP_OP: case SUBSTRING_OP: case KEYPAIR_OP: { /// ... Infer ranks of BinaryExprs. Determine using type-inference /// ... routines. If a sub-expression does not exist, use the type /// ... of the existing sub-expression. if (expr.left_valid()) { if (expr.right_valid()) { expr.type( expr_type(expr.op(), expr.left_guarded().type(), expr.right_guarded().type())); } else { expr.type( expr.left_guarded().type() ); } } else { if (expr.right_valid()) expr.type( expr.right_guarded().type() ); else { (CASTAWAY(Type &) expr.type()).rank_known(False); } } } break; case LABEL_OP: /// ... Rank makes no sense in these contexts case IO_STAR_OP: case FORMAT_OP: case DO_OP: case EQUAL_OP: case COMMA_OP: case COLON_OP: case OMEGA_OP: case REPSTAR_OP: case TABLE_ENTRY: case STMT_LABEL_OP: case INFINITY_OP: case ALPHA_OP: case GAMMA_OP: case MU_OP: case THETA_OP: case ETA_OP: default: { (CASTAWAY(Type &) expr.type()).rank_known(False); } break; } } /// Determine the appropriate dimensionality of 'expr' based on it's /// sub-expression's or Symbol's type. Update the Type with dimension /// data. WARNING: This routine makes heavy use of casting away /// consts in order to modify the const type expression. void propagate_expr_types(Expression & expr) { if (expr.op() == ID_OP) { /// ... An IDExpr has the same dimensionality as it`s symbol expr.type( expr.symbol().type() ); } else if ((expr.op() == INTEGER_CONSTANT_OP) || (expr.op() == REAL_CONSTANT_OP) || (expr.op() == STRING_CONSTANT_OP) || (expr.op() == LOGICAL_CONSTANT_OP) || (expr.op() == HOLLERITH_CONSTANT_OP)) { /// ... mark constants as scalar (NOTE: this does not handle /// ... array constants) (CASTAWAY(Type &) expr.type()).redimension(0); } else if (expr.arg_list().entries() > 0) { /// ... Determine types of the sub-expressions for (Iterator<Expression> sub_expr_iter = expr.arg_list(); sub_expr_iter.valid(); ++sub_expr_iter) { if (sub_expr_iter.current_valid()) propagate_expr_types(sub_expr_iter.current()); } determine_root_expr_type(expr); } } //////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////// static Boolean is_arithmetic_type(EXPR_TYPE type) { return (type == INTEGER_TYPE) || (type == REAL_TYPE) || (type == DOUBLE_PRECISION_TYPE) || (type == COMPLEX_TYPE); } static Type arithmetic_result_type(const Type & type1, const Type & type2, const int rank) { EXPR_TYPE type1_type = type1.data_type(); EXPR_TYPE type2_type = type2.data_type(); int type1_size = type1.size(); int type2_size = type2.size(); p_assert(is_arithmetic_type(type1_type) && is_arithmetic_type(type2_type), "Both types must be arithmetic"); if (type1_type == type2_type) return make_type(type1_type, max(type1_size, type2_size), rank); switch (type1_type) { case INTEGER_TYPE: if (type2_type == INTEGER_TYPE) return make_type(type1_type, max(type1_size, type2_size), rank); else return make_type(type2_type, type2_size, rank); case REAL_TYPE: if (type2_type == INTEGER_TYPE) return make_type(type1_type, type1_size, rank); else if (type2_type == REAL_TYPE) return make_type(type1_type, max(type1_size, type2_size), rank); else return make_type(type2_type, type2_size, rank); case DOUBLE_PRECISION_TYPE: if ((type2_type == INTEGER_TYPE) || (type2_type == REAL_TYPE)) return make_type(type1_type, type1_size, rank); else if (type2_type == DOUBLE_PRECISION_TYPE) return make_type(type1_type, max(type1_size, type2_size), rank); else return make_type(type2_type, type2_size, rank); case COMPLEX_TYPE: if ((type2_type == INTEGER_TYPE) || (type2_type == REAL_TYPE) || (type2_type == DOUBLE_PRECISION_TYPE)) return make_type(type1_type, type1_size, rank); else return make_type(type2_type, max(type1_size, type2_size), rank); default: cout << type1_type << endl; p_abort("Unknown arithmetic type"); } /// ... this return should never happen return make_type(UNDEFINED_TYPE); } Type string_type(const char *data_string, Boolean ignore_errors GIV(False)) { int hollerith_len_int; int string_len; int len = strlen(data_string); Boolean havdot = False; Boolean havexp = False; Boolean havdbl = False; Boolean havhol = False; Boolean error = False; char *copy_string = upcase_ch(data_string); if ((strcmp(copy_string, ".TRUE.") == 0) || (strcmp(copy_string, ".FALSE.") == 0)) { delete[] copy_string; return make_type(LOGICAL_TYPE); } if ((copy_string[0] == '\'') && (copy_string[len - 1] == '\'')) { /// ... We have a string constant - count up its real length ('' == ') string_len = fortran_string_length(copy_string); delete[] copy_string; return make_type(CHARACTER_TYPE, string_len); } if ((copy_string[0] == '\"') && (copy_string[len - 1] == '\"')) { /// ... We have a string constant with double quotes - /// ... convert to single quotes, then count up its real length ('' == ') char *single_quotes = double_to_single_quoted(copy_string); string_len = fortran_string_length(single_quotes); delete[] copy_string; delete[] single_quotes; return make_type(CHARACTER_TYPE, string_len); } for (int i = 0; i < len; ++i) { if (copy_string[i] == '.') { if (havdot) { error = True; break; } havdot = True; } else if ((copy_string[i] == 'D') || (copy_string[i] == 'E')) { if (havexp) { error = True; break; } havexp = True; if (copy_string[i] == 'D') havdbl = True; } else if (copy_string[i] == 'H') { /// ... If nothing but digits thus far, OK if (!havdot && !havexp && !error && !havhol) { char *hollerith_len = new char[i + 1]; strncpy(hollerith_len, copy_string, i); hollerith_len[i] = '\000'; sscanf(hollerith_len, "%d", &hollerith_len_int); /// ... Match stated length with string length if (len - (i + 1) >= hollerith_len_int) havhol = True; else error = True; } else error = True; } else if (((i == 0) || havexp) && ((copy_string[i] == '-') || (copy_string[i] == '+'))) { /// ... Fine - all is OK, keep going } else if (!isdigit(copy_string[i])) { error = True; } } delete[] copy_string; if (error) { if (ignore_errors) return make_type(UNDEFINED_TYPE); cout << data_string << endl; p_abort("String is not a valid Fortran constant"); } if (havhol) return make_type(CHARACTER_TYPE, hollerith_len_int); if (!havdot && !havexp) return make_type(INTEGER_TYPE); if (havdbl) return make_type(DOUBLE_PRECISION_TYPE); else return make_type(REAL_TYPE); } /// Determine the rank of an intrinsic binary operator using the /// following rule: "The shape of the result of '[x1] op x2' /// is the shape of x2 if op is unary or if x1 is scalar, and is /// the shape of x1 otherwise". (section 7.1.4.2, FORTRAN 8x spec.) /// This results in a failed polaris assertion if the types are /// not in shape conformance. Returning -1 indicates that the /// rank is not known. int compute_rank(const Type & left_type, const Type & right_type, const OP_TYPE op) { if (!left_type.rank_known()) return -1; else if (!right_type.rank_known()) { if (left_type.is_scalar()) return -1; else return left_type.rank(); } else { /// ... both ranks are known if (left_type.is_scalar()) return right_type.rank(); else if (right_type.is_scalar()) return left_type.rank(); else { /// ... They are both arrays if (right_type.rank() != left_type.rank()) { /// ... Types not in shape conformance cerr << "Types in intrinsic operation found" << " not to be in shape conformance" << endl; cerr << "for op number " << (int) op << endl; cerr << "Left: " << left_type << endl; cerr << "Right: " << right_type << endl; p_abort("compute_rank::Violation of FORTRAN standard found"); } return right_type.rank(); } } } Type expr_type(const OP_TYPE op, const Type & left_type, const Type & right_type) { EXPR_TYPE left_type_type, right_type_type; int left_type_size, right_type_size; int op_rank; static int promote_logicals = -1; static int promote_integers = -1; if (promote_logicals < 0) promote_logicals = switch_value("prom_logical"); if (promote_integers < 0) promote_integers = switch_value("prom_integer"); left_type_type = left_type.data_type(); left_type_size = left_type.size(); right_type_type = right_type.data_type(); right_type_size = right_type.size(); op_rank = compute_rank(left_type, right_type, op); if (left_type_type == UNKNOWN_TYPE || right_type_type == UNKNOWN_TYPE) return make_ranked_type(UNKNOWN_TYPE, op_rank); switch (op) { case OR_OP: /// ... NonBinaryExpr operator case AND_OP: /// ... NonBinaryExpr operator case EQV_OP: /// ... NonBinaryExpr operator case NEQV_OP: /// ... NonBinaryExpr operator if ((left_type_type == LOGICAL_TYPE) && (right_type_type == LOGICAL_TYPE)) return make_ranked_type(LOGICAL_TYPE, op_rank); if (promote_integers > 0) { if (((left_type_type == INTEGER_TYPE) && (right_type_type == INTEGER_TYPE)) || ((left_type_type == INTEGER_TYPE) && (right_type_type == LOGICAL_TYPE)) || ((left_type_type == LOGICAL_TYPE) && (right_type_type == INTEGER_TYPE))) return make_ranked_type(LOGICAL_TYPE, op_rank); } cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad type combination"); return make_type(UNDEFINED_TYPE); case KEYPAIR_OP: /// ... BinaryExpr operator return right_type; case EQ_OP: case NE_OP: case LT_OP: case LE_OP: case GT_OP: case GE_OP: if ( (is_arithmetic_type(left_type_type) && is_arithmetic_type(right_type_type)) || ((left_type_type == LOGICAL_TYPE) && (right_type_type == LOGICAL_TYPE)) || (left_type_type == CHARACTER_TYPE) && (right_type_type == CHARACTER_TYPE)) return make_ranked_type(LOGICAL_TYPE, op_rank); cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad type combination"); return make_type(UNDEFINED_TYPE); case ADD_OP: /// ... NonBinaryExpr operator case MULT_OP: /// ... NonBinaryExpr operator case SUB_OP: case DIV_OP: case INTDIV_OP: case RATDIV_OP: case EXP_OP: #if 0 /// ... This is only valid for F77, it is possible in F90. if (((left_type_type == COMPLEX_TYPE) && (right_type_type == DOUBLE_PRECISION_TYPE)) || ((left_type_type == DOUBLE_PRECISION_TYPE) && (right_type_type == COMPLEX_TYPE))) p_abort("DOUBLE PRECISION prohibited with COMPLEX"); #endif if (is_arithmetic_type(left_type_type) && is_arithmetic_type(right_type_type)) return arithmetic_result_type(left_type, right_type, op_rank); if (promote_logicals > 0) { if (left_type_type == LOGICAL_TYPE) { if (right_type_type == LOGICAL_TYPE) { return make_ranked_type(INTEGER_TYPE, op_rank); } else { Type t1 = make_ranked_type(INTEGER_TYPE, left_type.rank()); return arithmetic_result_type(t1, right_type, op_rank); } } else { if (right_type_type == LOGICAL_TYPE) { Type t2 = make_ranked_type(INTEGER_TYPE, right_type.rank()); return arithmetic_result_type(left_type, t2, op_rank); } cout << left_type << ' ' << op << ' ' << right_type << endl; p_abort("Invalid type combination"); } } else { cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad type combination"); return make_type(UNDEFINED_TYPE); } case CONCAT_OP: if ((left_type_type == CHARACTER_TYPE) && (right_type_type == CHARACTER_TYPE)) return make_type(CHARACTER_TYPE, left_type_size + right_type_size, op_rank); cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad type combination"); return make_type(UNDEFINED_TYPE); case COLON_OP: if (((left_type_type == INTEGER_TYPE) || (left_type_type == UNDEFINED_TYPE)) && ((right_type_type == INTEGER_TYPE) || (right_type_type == UNDEFINED_TYPE))) return make_ranked_type(INTEGER_TYPE, op_rank); cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad type combination"); return make_type(UNDEFINED_TYPE); case COMPLEX_OP: return make_type(COMPLEX_TYPE, max(left_type_size, right_type_size), op_rank); case SUBSTRING_OP: return make_type(CHARACTER_TYPE, 0, op_rank); case ARRAY_REF_OP: return make_type(left_type_type, left_type_size, op_rank); case ALPHA_OP: /// ... Treat these as normal operations case GAMMA_OP: /// ... but ignore OMEGA_OP arguments case MU_OP: case THETA_OP: case ETA_OP: if (left_type_type == right_type_type && left_type_size == right_type_size) return Type( left_type ); else if (right_type_type == VOID_TYPE) return Type( left_type ); else if (left_type_type == VOID_TYPE) return Type( right_type); else if (is_arithmetic_type(left_type_type) && is_arithmetic_type(right_type_type)) return arithmetic_result_type(left_type, right_type, op_rank); else if ((left_type_type == CHARACTER_TYPE) && (right_type_type == CHARACTER_TYPE)) return make_type(CHARACTER_TYPE,max(left_type_size,right_type_size), op_rank); else { cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad type combination"); return make_type(UNDEFINED_TYPE); } default: cout << left_type << ' ' << op_string[op] << ' ' << right_type << endl; p_abort("Bad operator"); break; } return make_type(UNDEFINED_TYPE); } Type expr_type(const OP_TYPE op, const List<Expression>&args) { int entries = args.entries(); p_assert( entries > 0, "expr_type(const OP_TYPE, const List<Expression> &): " "args list must be non-empty"); Iterator<Expression> iter = args; Type type_so_far = iter.current().type(); for (++iter; iter.valid(); ++iter) type_so_far = expr_type(op, type_so_far, iter.current().type()); return type_so_far; } List<Expression> * expr_list(Expression * expr1 GIV(0), Expression * expr2 GIV(0), Expression * expr3 GIV(0), Expression * expr4 GIV(0), Expression * expr5 GIV(0), Expression * expr6 GIV(0), Expression * expr7 GIV(0), Expression * expr8 GIV(0), Expression * expr9 GIV(0), Expression * expr10 GIV(0)) { List<Expression> * list = new List<Expression>; # define LIST_EXPR_ADD(expr) if (expr) list->ins_last(expr) LIST_EXPR_ADD(expr1); LIST_EXPR_ADD(expr2); LIST_EXPR_ADD(expr3); LIST_EXPR_ADD(expr4); LIST_EXPR_ADD(expr5); LIST_EXPR_ADD(expr6); LIST_EXPR_ADD(expr7); LIST_EXPR_ADD(expr8); LIST_EXPR_ADD(expr9); LIST_EXPR_ADD(expr10); # undef LIST_EXPR_ADD return list; } Expression * constant(int value) { return new IntConstExpr((int) value); } Expression * constant(const char *data_string) { Type t = string_type(data_string); EXPR_TYPE e = t.data_type(); switch (e) { case LOGICAL_TYPE: return new LogicalConstExpr(data_string); case CHARACTER_TYPE: if (data_string[0] == '\'') return new StringConstExpr(data_string); else if (data_string[0] == '"') { /// ... Convert to single-quoted character constant char *single = double_to_single_quoted(data_string); Expression *string_expr = new StringConstExpr(single); delete [] single; return string_expr; } else return new HollerithConstExpr(data_string); case REAL_TYPE: return new RealConstExpr(REAL_TYPE, data_string); case DOUBLE_PRECISION_TYPE: return new RealConstExpr(DOUBLE_PRECISION_TYPE, data_string); case INTEGER_TYPE: { int value; sscanf((char *) data_string, "%d", &value); return new IntConstExpr(value); } default: cout << e << endl; p_abort("Unexpected type for a constant"); break; } return 0; } Expression * keyword(const char *data_string) { p_assert( data_string, "keyword is null" ); return new KeyExpr( data_string ); } Expression * complex(Expression * real, Expression * imag) { return new ComplexExpr(real, imag); } Expression * array_reference(Expression * array, Expression * subscripts) { p_assert((array != NULL) && (subscripts != NULL), "arg(s) to *arrayref* must be non-NULL"); Expression *expr = new ArrayRefExpr(array->type(), array, subscripts); determine_root_expr_type(*expr); return expr; } static inline Expression * create_nonbinary(List<Expression>*args, OP_TYPE op_type, const char *func_name) { if (args->entries() <= 0) { char buf[1000]; sprintf(buf, "%s(List<Expression> *): args list must be non-empty", func_name); p_abort(buf); } return new NonBinaryExpr(op_type, expr_type(op_type, *args), args); } Expression * add(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *add* must be non-NULL"); return new NonBinaryExpr(ADD_OP, expr_type(ADD_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * add(List<Expression> *args) { return create_nonbinary(args, ADD_OP, "add"); } Expression * sub(Expression *expr1, Expression *expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *sub* must be non-NULL"); return new BinaryExpr(SUB_OP, expr_type(SUB_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * mul(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *mul* must be non-NULL"); return new NonBinaryExpr(MULT_OP, expr_type(MULT_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * mul(List<Expression>*args) { return create_nonbinary(args, MULT_OP, "mul"); } Expression * div(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *div* must be non-NULL"); return new BinaryExpr(DIV_OP, expr_type(DIV_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * exponent(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *exp* must be non-NULL"); return new BinaryExpr(EXP_OP, expr_type(EXP_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * keypair(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *keypair* must be non-NULL"); return new BinaryExpr(KEYPAIR_OP, make_type(VOID_TYPE), expr1, expr2); } Expression * eq(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *eq* must be non-NULL"); return new BinaryExpr(EQ_OP, expr_type(EQ_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * ne(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *ne* must be non-NULL"); return new BinaryExpr(NE_OP, expr_type(NE_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * lt(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *lt* must be non-NULL"); return new BinaryExpr(LT_OP, expr_type(LT_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * le(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *le* must be non-NULL"); return new BinaryExpr(LE_OP, expr_type(LE_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * gt(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *gt* must be non-NULL"); return new BinaryExpr(GT_OP, expr_type(GT_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * ge(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *ge* must be non-NULL"); return new BinaryExpr(GE_OP, expr_type(GE_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * or(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "args to *or* must be non-NULL"); return new NonBinaryExpr(OR_OP, expr_type(OR_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * or(List<Expression> *args) { return create_nonbinary(args, OR_OP, "or"); } Expression * and(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *and* must be non-NULL"); return new NonBinaryExpr(AND_OP, expr_type(AND_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * and(List<Expression> *args) { return create_nonbinary(args, AND_OP, "and"); } Expression * eqv(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *eqv* must be non-NULL"); return new NonBinaryExpr(EQV_OP, expr_type(EQV_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * eqv(List<Expression> *args) { return create_nonbinary(args, EQV_OP, "eqv"); } Expression * neqv(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "arg(s) to *neqv* must be non-NULL"); return new NonBinaryExpr(NEQV_OP, expr_type(NEQV_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * neqv(List<Expression>*args) { return create_nonbinary(args, NEQV_OP, "neqv"); } Expression * function_call(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "both args to *function_call* must be non-NULL"); p_assert(expr1->symbol().intrinsic() == NOT_INTRINSIC, "the symbol argument to function_call() must not be INTRINSIC" ); return new FunctionCallExpr(expr1->symbol().type(), expr1, expr2); } Expression * intrinsic_call(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "both args to *intrinsic_call* must be non-NULL"); p_assert( expr1->symbol().intrinsic() == IS_INTRINSIC, "the symbol argument to intrinsic_call() must be INTRINSIC" ); Expression *expr = new IntrinsicCallExpr(expr1->symbol().type(), expr1, expr2); determine_root_expr_type(*expr); return expr; } Expression * substring(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "both args to *substring* must be non-NULL"); return new SubStringExpr(expr_type(SUBSTRING_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * concat(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) && (expr2 != NULL), "both args to *concat* must be non-NULL"); return new NonBinaryExpr(CONCAT_OP, expr_type(CONCAT_OP, expr1->type(), expr2->type()), expr1, expr2); } Expression * colon(Expression * expr1, Expression * expr2, Expression * expr3 GIV(0)) { p_assert((expr1 != NULL) || (expr2 != NULL), "first two args to *colon* must be non-NULL"); return new NonBinaryExpr(COLON_OP, make_type(VOID_TYPE), expr1, expr2, expr3); } Expression * colon(List<Expression> *args) { return create_nonbinary(args, COLON_OP, "colon"); } Expression * comma (List<Expression> *args) { return new CommaExpr(args); } Expression * comma(Expression *expr1, Expression *expr2, Expression *expr3 GIV(0), Expression *expr4 GIV(0), Expression *expr5 GIV(0)) { p_assert((expr1 != NULL), "arg 1 to *comma* must be non-NULL"); p_assert((expr2 != NULL), "arg 2 to *comma* must be non-NULL"); return new CommaExpr(expr1, expr2, expr3, expr4, expr5); } Expression * comma(Expression * expr1) { p_assert((expr1 != NULL), "arg 1 to *comma* must be non-NULL"); return new CommaExpr(expr1); } Expression * comma() { return new CommaExpr(); } Expression * unary_plus(Expression * expr) { p_assert(expr != NULL, "arg to *uplus* must be non-NULL"); return new UnaryExpr(U_PLUS_OP, expr->type(), expr); } Expression * unary_minus(Expression * expr) { p_assert(expr != NULL, "arg to *uminus* must be non-NULL"); return new UnaryExpr(U_MINUS_OP, expr->type(), expr); } Expression * do_expression(Expression * expr1, Expression * expr2) { p_assert((expr1 != NULL) || (expr2 != NULL), "first two args to *do_expression* must be non-NULL"); return new DoExpr(expr1, expr2); } Expression * equal(Expression * index, Expression * iter_space) { p_assert((index != NULL) || (iter_space != NULL), "first two args to *equal* must be non-NULL"); return new EqualExpr(index->type(), index, iter_space); } Expression * not(Expression * expr) { p_assert(expr != NULL, "arg to *not* must be non-NULL"); return new UnaryExpr(NOT_OP, expr->type(), expr); } Expression * paren(Expression * expr) { p_assert(expr != NULL, "arg to *par* must be non-NULL"); return new UnaryExpr(PAREN_OP, expr->type(), expr); } Expression * id(const char *varname, const ProgramUnit & pgm) { const Symbol *s = pgm.symtab().find_ref(varname); p_assert(s, "Symbol name passed to *id* does not exist in ProgramUnit"); return new IDExpr(s->type(), *s); } Expression * id(const Symbol & symbol) { return new IDExpr(symbol.type(), symbol); } Expression * new_variable(const char *varname, const Type & t, ProgramUnit & pgm) { Symbol *s = new VariableSymbol(varname, t, NOT_FORMAL, NOT_SAVED); pgm.symtab().ins(s); return new IDExpr(s->type(), *s); } Expression * new_function(const char *funname, const Type & t, ProgramUnit & pgm) { Symbol *s = new FunctionSymbol(funname, t, IS_EXTERNAL, NOT_INTRINSIC, NOT_FORMAL); pgm.symtab().ins(s); return new IDExpr(s->type(), *s); } Expression * new_intrinsic(const char *funname, const Type & t, ProgramUnit & pgm) { Symbol *s = new FunctionSymbol(funname, t, NOT_EXTERNAL, IS_INTRINSIC, NOT_FORMAL); pgm.symtab().ins(s); return new IDExpr(s->type(), *s); } Expression * new_subroutine(const char *funname, ProgramUnit & pgm) { Symbol *s = new SubroutineSymbol(funname, IS_EXTERNAL, NOT_INTRINSIC, NOT_FORMAL); pgm.symtab().ins(s); return new IDExpr(s->type(), *s); } Expression * new_array_variable(const char *varname, const Type & t, ProgramUnit & pgm, Expression * bounds1, Expression * bounds2 GIV(0), Expression * bounds3 GIV(0), Expression * bounds4 GIV(0), Expression * bounds5 GIV(0)) { ArrayBounds *ab2 = 0; ArrayBounds *ab3 = 0; ArrayBounds *ab4 = 0; ArrayBounds *ab5 = 0; p_assert(bounds1->op() == COLON_OP, "Array bound 1 is not a COLON expression"); ArrayBounds *ab1 = new ArrayBounds(bounds1->left_guarded().clone(), bounds1->right_guarded().clone()); if (bounds2) { p_assert(bounds2->op() == COLON_OP, "Array bound 2 is not a COLON expression"); ab2 = new ArrayBounds(bounds2->left_guarded().clone(), bounds2->right_guarded().clone()); } if (bounds3) { p_assert(bounds3->op() == COLON_OP, "Array bound 3 is not a COLON expression"); ab3 = new ArrayBounds(bounds3->left_guarded().clone(), bounds3->right_guarded().clone()); } if (bounds4) { p_assert(bounds4->op() == COLON_OP, "Array bound 4 is not a COLON expression"); ab4 = new ArrayBounds(bounds4->left_guarded().clone(), bounds4->right_guarded().clone()); } if (bounds5) { p_assert(bounds5->op() == COLON_OP, "Array bound 5 is not a COLON expression"); ab5 = new ArrayBounds(bounds5->left_guarded().clone(), bounds5->right_guarded().clone()); } Symbol *s = new VariableSymbol(varname, t, NOT_FORMAL, NOT_SAVED, ab1, ab2, ab3, ab4, ab5); pgm.symtab().ins(s); return new IDExpr(s->type(), *s); } Expression * omega() { return new OmegaExpr; } Expression * null_to_omega(Expression * expr) { return (expr) ? expr : omega(); } Expression * infinity(int s GIV(1)) { return new InfinityExpr(s); } //------------------------------------------------------------------------ Expression * alpha(Expression *parameters) { p_assert(parameters, "parameters argument to *alpha* must be non-NULL"); return new GSAExpr(ALPHA_OP, expr_type(ALPHA_OP, parameters->arg_list()), parameters); } Expression * gamma(Expression *gate, Expression *parameters) { p_assert(parameters, "parameters (second) argument to *gamma* must be non-NULL"); return new GSAExpr(GAMMA_OP, expr_type(GAMMA_OP, parameters->arg_list()), parameters, gate); } Expression * mu(Expression *parameters) { p_assert(parameters, "parameter argument to *mu* must be non-NULL"); return new GSAExpr(MU_OP, expr_type(MU_OP, parameters->arg_list()), parameters); } Expression * theta(Expression *parameters) { p_assert(parameters, "parameter argument to *mu* must be non-NULL"); return new GSAExpr(THETA_OP, expr_type(THETA_OP, parameters->arg_list()), parameters); } Expression * eta(Expression *gate, Expression *parameters) { p_assert(parameters, "parameters (second) argument to *eta* must be non-NULL"); return new GSAExpr(ETA_OP, expr_type(ETA_OP, parameters->arg_list()), parameters, gate); } Expression * mu(Expression *parameters, Expression * gate) { p_assert(parameters, "parameter argument to *mu* must be non-NULL"); return new GSAExpr(MU_OP, expr_type(MU_OP, parameters->arg_list()), parameters, gate); } //------------------------------------------------------------------------ static void _cannot_coerce(const Type & from, EXPR_TYPE to) { String from_str, to_str; Type to_type(to); from.format(from_str); to_type.format(to_str); cerr << "\n\nError: coerce(): Tried to coerce from type " << from_str << " to type " << to_str << endl << endl; p_abort("(See above error message)"); } static void _assert_can_coerce(const Type & from, EXPR_TYPE to, EXPR_TYPE from1, EXPR_TYPE from2 = (EXPR_TYPE) (-1), EXPR_TYPE from3 = (EXPR_TYPE) (-1), EXPR_TYPE from4 = (EXPR_TYPE) (-1), EXPR_TYPE from5 = (EXPR_TYPE) (-1)) { EXPR_TYPE f = from.data_type(); if (f == from1 || f == from2 || f == from3 || f == from4 || f == from5) return; _cannot_coerce(from, to); } static Expression * _coerce(Expression * expr, const char *intrin_name, EXPR_TYPE NOTUSED(type), ProgramUnit & pgm) { p_assert(intrin_name, "_coerce(): intrin_name is NULL"); Type result_type;/// ... Select size by default Symbol *intrin_sym = pgm.symtab().find_ref(intrin_name); if (intrin_sym) { p_assert(intrin_sym->intrinsic(), "_coerce(): Intrinsic name already exists in symbol " "table, but is not an intrinsic function"); } else { intrin_sym = &pgm.symtab().ins( new FunctionSymbol(intrin_name, result_type, NOT_EXTERNAL, IS_INTRINSIC, NOT_FORMAL)); } return new IntrinsicCallExpr(intrin_sym->type(), new IDExpr(intrin_sym->type(), *intrin_sym), new CommaExpr(expr)); } Expression * coerce(Expression * expr, EXPR_TYPE type, ProgramUnit & pgm) { if (type == expr->type().data_type()) return expr; else { /// ... const char *intrin_name = 0; switch (type) { case VOID_TYPE: _cannot_coerce(expr->type(), type); return 0; case INTEGER_TYPE: _assert_can_coerce(expr->type(), type, INTEGER_TYPE, REAL_TYPE, DOUBLE_PRECISION_TYPE, COMPLEX_TYPE, CHARACTER_TYPE); if (expr->type().data_type() == CHARACTER_TYPE) return _coerce(expr, "ICHAR", INTEGER_TYPE, pgm); else return _coerce(expr, "INT", INTEGER_TYPE, pgm); case REAL_TYPE: _assert_can_coerce(expr->type(), type, INTEGER_TYPE, REAL_TYPE, DOUBLE_PRECISION_TYPE, COMPLEX_TYPE); return _coerce(expr, "REAL", REAL_TYPE, pgm); case DOUBLE_PRECISION_TYPE: _assert_can_coerce(expr->type(), type, INTEGER_TYPE, REAL_TYPE, DOUBLE_PRECISION_TYPE, COMPLEX_TYPE); return _coerce(expr, "DBLE", DOUBLE_PRECISION_TYPE, pgm); case COMPLEX_TYPE: _assert_can_coerce(expr->type(), type, INTEGER_TYPE, REAL_TYPE, DOUBLE_PRECISION_TYPE, COMPLEX_TYPE); return _coerce(expr, "CMPLX", COMPLEX_TYPE, pgm); case CHARACTER_TYPE: _assert_can_coerce(expr->type(), type, INTEGER_TYPE); return _coerce(expr, "CHAR", CHARACTER_TYPE, pgm); default: _cannot_coerce(expr->type(), type); break; } } return 0; } //------------------------------------------------------------------------ Listable * Expression::listable_clone() const { return clone(); } void Expression::relink_eptrs(ProgramUnit & NOTUSED(p)) { /// ... nothing to do } int Expression::compare(const Expression & ex) const { if (op() != ex.op()) return (((int) op()<(int) ex.op()) ? -1 : 1); const Type & x = type(); const Type & y = ex.type(); if (x.data_type() != y.data_type()) return (((int) x.data_type()<(int) y.data_type()) ? -1 : 1); if (x.size() != y.size()) return ((x.size()<y.size()) ? -1 : 1); return node_compare(ex); } int Expression::node_compare(const Expression & ex) const { if (arg_list().entries() != ex.arg_list().entries()) if (arg_list().entries() > ex.arg_list().entries()) return 1; else return -1; else { int cmp = 0; Iterator<Expression> a_iter = arg_list(); Iterator<Expression> b_iter = ex.arg_list(); for (; a_iter.valid() && b_iter.valid(); ++a_iter, ++b_iter) if ((cmp = a_iter.current().compare(b_iter.current())) != 0) return cmp; } return 0; } const ExprSignature & Expression::update_signature() { _signature_live().clear(); _signature_live().merge( (int) op() ); /// ... Commented out the inclusion of the type in the signature so /// ... as to speed up update_signature(), which simplify() calls a /// ... lot. /// ... _signature_live().merge( (int) type().data_type() ); /// ... _signature_live().merge( type().size() ); for (Iterator<Expression> iter = arg_list(); iter.valid(); ++iter) _signature_live().merge( iter.current().signature() ); return signature(); } const ExprSignature & Expression::create_signature() { for (Iterator<Expression> iter = arg_list(); iter.valid(); ++iter) iter.current().create_signature(); update_signature(); return signature(); } const ExprSignature & Expression::standardize() { for (Iterator<Expression> iter = arg_list(); iter.valid(); ++iter) iter.current().standardize(); if (is_commutative(op())) _sort_expr_list(arg_list()); else if (op() == INTRINSIC_CALL_OP) { const char *intr_name = intrinsic().symbol().name_ref(); if (is_commutative_intrinsic_name(intr_name)) { _sort_expr_list(parameters_guarded().arg_list()); parameters_guarded().update_signature(); } } update_signature(); return signature(); } const Expression & Expression::lambda_expr() const { p_abort("const Expression &lambda_expr() const called for non-LambdaCallExpr"); return DUMMY_EXPR_REF; } Expression & Expression::lambda_expr() { p_abort("Expression &lambda_expr() called for non-LambdaCallExpr"); return DUMMY_EXPR_REF; } void Expression::lambda_expr(Expression *) { p_abort("void lambda_expr(Expression *) called for non-LambdaCallExpr"); } Boolean Expression::args_are_non_null() const { return True; } const List<Expression> & Expression::arg_list() const { static List<Expression> *_empty_arg_list = 0; /// ... List of no arguments if (_empty_arg_list == 0) _empty_arg_list = new List<Expression>; _empty_arg_list->fix_size(); return *_empty_arg_list; } List<Expression> & Expression::arg_list() { static List<Expression> *_empty_arg_list = 0; /// ... List of no arguments if (_empty_arg_list == 0) _empty_arg_list = new List<Expression>; _empty_arg_list->fix_size(); return *_empty_arg_list; } const RefList<Expression> * Expression::arg_refs() const { return new RefList<Expression>; } /// DUMMY FUNCTIONS int Expression::value() const { _ref_error("int value() const"); return 0; } void Expression::value(int NOTUSED(v)) { _ref_error("value(int v)"); } const char * Expression::data_ref() const { return 0; } const String & Expression::str_data() const { _ref_error("const String & str_data() const"); return *((String *)0); } String & Expression::str_data() { _ref_error("String & str_data()"); return *((String *)0); } void Expression::data(const char *NOTUSED(v)) { _ref_error("data(const char *v)"); } const Expression & Expression::real_part() const { _ref_error("const Expression & real_part() const"); return DUMMY_EXPR_REF; } Expression & Expression::real_part() { _ref_error("Expression & real_part()"); return DUMMY_EXPR_REF; } void Expression::real_part(Expression * NOTUSED(e)) { _ref_error("real_part(Expression* e)"); } const Expression & Expression::imaginary_part() const { _ref_error("const Expression & imaginary_part() const"); return DUMMY_EXPR_REF; } Expression & Expression::imaginary_part() { _ref_error("Expression & imaginary_part()"); return DUMMY_EXPR_REF; } void Expression::imaginary_part(Expression * NOTUSED(e)) { _ref_error("imaginary_part(Expression* e)"); } const Expression & Expression::array() const { _ref_error("const Expression & array() const"); return DUMMY_EXPR_REF; } Expression & Expression::array() { _ref_error("Expression & array()"); return DUMMY_EXPR_REF; } void Expression::array(Expression * NOTUSED(e)) { _ref_error("array(Expression* e)"); } const Expression & Expression::subscript() const { _ref_error("const Expression & subscript() const"); return DUMMY_EXPR_REF; } Expression & Expression::subscript() { _ref_error("Expression & subscript()"); return DUMMY_EXPR_REF; } void Expression::subscript(Expression * NOTUSED(e)) { _ref_error("subscript(Expression* e)"); } const Expression & Expression::string() const { _ref_error("const Expression & string() const"); return DUMMY_EXPR_REF; } Expression & Expression::string() { _ref_error("Expression & string()"); return DUMMY_EXPR_REF; } void Expression::string(Expression * NOTUSED(e)) { _ref_error("string(Expression* e)"); } const Expression & Expression::bound() const { _ref_error("const Expression & bound() const"); return DUMMY_EXPR_REF; } Expression & Expression::bound() { _ref_error("Expression & bound()"); return DUMMY_EXPR_REF; } void Expression::bound(Expression * NOTUSED(e)) { _ref_error("bound(Expression* e)"); } const Expression & Expression::left_guarded() const { _ref_error("const Expression & left_guarded() const"); return DUMMY_EXPR_REF; } Expression & Expression::left_guarded() { _ref_error("Expression & left_guarded()"); return DUMMY_EXPR_REF; } void Expression::left(Expression * NOTUSED(e)) { _ref_error("left(Expression* e)"); } Boolean Expression::left_valid() const { return False; }; Expression * Expression::grab_left() { _ref_error("Expression * grab_left()"); return 0; } const Expression & Expression::right_guarded() const { _ref_error("const Expression & right_guarded() const"); return DUMMY_EXPR_REF; } Expression & Expression::right_guarded() { _ref_error("Expression & right_guarded()"); return DUMMY_EXPR_REF; } void Expression::right(Expression * NOTUSED(e)) { _ref_error("right(Expression* e)"); } Boolean Expression::right_valid() const { return False; } Expression * Expression::grab_right() { _ref_error("Expression * grab_right()"); return 0; } const Expression & Expression::function() const { _ref_error("const Expression & function() const"); return DUMMY_EXPR_REF; } Expression & Expression::function() { _ref_error("Expression & function()"); return DUMMY_EXPR_REF; } void Expression::function(Expression * NOTUSED(e)) { _ref_error("function(Expression* e)"); } const Expression & Expression::parameters_guarded() const { _ref_error("const Expression & parameters_guarded() const"); return DUMMY_EXPR_REF; } Expression & Expression::parameters_guarded() { _ref_error("Expression & parameters_guarded()"); return DUMMY_EXPR_REF; } void Expression::parameters(Expression * NOTUSED(e)) { _ref_error("parameters(Expression* e)"); } Boolean Expression::parameters_valid() const { return False; } const Expression & Expression::expr_guarded() const { _ref_error("const Expression & expr_guarded() const"); return DUMMY_EXPR_REF; } Expression & Expression::expr_guarded() { _ref_error("Expression & expr_guarded()"); return DUMMY_EXPR_REF; } void Expression::expr(Expression * NOTUSED(e)) { _ref_error("expr(Expression* e)"); } Boolean Expression::expr_valid() const { return False; } Expression * Expression::grab_expr() { _ref_error("Expression * grab_expr()"); return 0; } const Symbol & Expression::symbol() const { _ref_error("const Symbol & symbol() const"); return *((const Symbol *) 0); } Symbol & Expression::symbol() { _ref_error("Symbol & symbol()"); return *((Symbol *) 0); } void Expression::symbol(const Symbol & NOTUSED(s)) { _ref_error("symbol(Symbol & s)"); } const Expression & Expression::substituted_guarded() const { _ref_error("const Expression & substituted_guarded() const"); return DUMMY_EXPR_REF; } Expression & Expression::substituted_guarded() { _ref_error("Expression & substituted_guarded()"); return DUMMY_EXPR_REF; } void Expression::substituted(Expression * NOTUSED(e)) { _ref_error("substituted(Expression* e)"); } Boolean Expression::substituted_valid() const { return False; } Expression * Expression::grab_substituted() { _ref_error("Expression * grab_substituted() const"); return 0; } const Expression & Expression::iolist() const { _ref_error("const Expression & iolist() const"); return DUMMY_EXPR_REF; } Expression & Expression::iolist() { _ref_error("Expression & iolist()"); return DUMMY_EXPR_REF; } void Expression::iolist(Expression * NOTUSED(e)) { _ref_error("iolist(Expression* e)"); } const Expression & Expression::iterator() const { _ref_error("const Expression & iterator() const"); return DUMMY_EXPR_REF; } Expression & Expression::iterator() { _ref_error("Expression & iterator()"); return DUMMY_EXPR_REF; } void Expression::iterator(Expression * NOTUSED(e)) { _ref_error("iterator(Expression* e)"); } const Expression & Expression::index_id() const { _ref_error("const Expression & index_id() const"); return DUMMY_EXPR_REF; } Expression & Expression::index_id() { _ref_error("Expression & index_id()"); return DUMMY_EXPR_REF; } void Expression::index_id(Expression * NOTUSED(e)) { _ref_error("index_id(Expression* e)"); } const Expression & Expression::iteration_space() const { _ref_error("const Expression & iteration_space() const"); return DUMMY_EXPR_REF; } Expression & Expression::iteration_space() { _ref_error("Expression & iteration_space()"); return DUMMY_EXPR_REF; } void Expression::iteration_space(Expression * NOTUSED(e)) { _ref_error("iteration_space(Expression* e)"); } const Expression & Expression::intrinsic() const { _ref_error("const Expression & intrinsic() const"); return DUMMY_EXPR_REF; } Expression & Expression::intrinsic() { _ref_error("Expression & intrinsic()"); return DUMMY_EXPR_REF; } void Expression::intrinsic(Expression * NOTUSED(e)) { _ref_error("intrinsic(Expression* e)"); } int Expression::entry() const { _ref_error("int entry() const"); return 0; } void Expression::entry(int NOTUSED(e)) { _ref_error("entry(int e)"); } const Format & Expression::format() const { _ref_error("const Format & format() const"); return *((const Format *) 0); } Format & Expression::format() { _ref_error("Format & format()"); return *((Format *) 0); } void Expression::format(Format & NOTUSED(format)) { _ref_error("format(Format & format)"); } const Statement & Expression::stmt() const { _ref_error("const Statement & stmt() const"); return *((const Statement *) 0); } Statement & Expression::stmt() { _ref_error("Statement & stmt()"); return *((Statement *) 0); } void Expression::stmt(Statement & NOTUSED(stmt)) { _ref_error("stmt(Statement & stmt)"); } int Expression::sign() const { _ref_error("int sign() const"); return 0; } void Expression::sign(int NOTUSED(s)) { _ref_error("sign(int s)"); } const Expression & Expression::gate() const { _ref_error("const Expression & gate() const"); return DUMMY_EXPR_REF; } Expression & Expression::gate() { _ref_error("Expression & gate()"); return DUMMY_EXPR_REF; } void Expression::gate(Expression * NOTUSED(e)) { _ref_error("gate(Expression* e)"); } /// This print function is to satisfy Listable::print(...) void Expression::print(ostream & o) const { print_debug(o, subst_field_print); } ostream & operator << (ostream & o, const Expression & e) { e.print_debug(o, subst_field_print); if (e._overflow) o << "{" << *(e._overflow) << "}"; return o; } /// tableEntry takes an integer and returns a pointer to an Expression /// object which represents another entry in the expression table. This /// intermediate table-entry expression object is an intermediate form /// which is only used in converting expressions from table form to /// expression object form and should not be used to represent actual /// expressions. Expression * Expression::tableEntry(int n) { Expression *t = new TableExpr(n); return t; } /// Helper function: used to get the type field. void Expression::get_type(BinRep & typebin, const char *exprname) { if (!typebin.is_string()) { cerr << exprname << "Expr::convert: type field doesn't contain string\n"; p_abort("(See above error message)"); } String s; typebin.to_string(s); if (s == "INTEGER") type(make_type(INTEGER_TYPE)); else if (s == "REAL") type(make_type(REAL_TYPE)); else if (s == "DOUBLE PRECISION") type(make_type(DOUBLE_PRECISION_TYPE)); else if (s == "CHARACTER") type(make_type(CHARACTER_TYPE)); else if (s == "COMPLEX") type(make_type(COMPLEX_TYPE)); else if (s == "LOGICAL") type(make_type(LOGICAL_TYPE)); else if (s == "VOID") type(make_type(VOID_TYPE)); else { cerr << exprname << "Expr::convert: Unrecognized string in 'type' field: " << s << endl; p_abort("(See above error message)"); } } /// Helper function: insert leftovers into the overflow void Expression::make_overflow(Iterator<BinRep> & iter, const char *exname) { warn_overflow_map(exname, iter.current()); if (!_overflow) { _overflow = new BinRep; Set<BinRep> *S = new Set<BinRep>; _overflow->put_set( S ); } _overflow->ins(iter.current()); } /// Helper function: Make sure overflow is empty void Expression::empty_overflow() { if (_overflow) delete _overflow; _overflow = 0; } int Expression::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); BinRep *br = new BinRep( new Set<BinRep> ); List<BinRep> & L = b->find_ref( "expression" )->to_tuple(); L.ins_last( br ); BinRep *bs = new BinRep( new List<BinRep> ); bs->to_tuple().ins_last(new BinRep( "type" )); bs->to_tuple().ins_last(new BinRep( this->type().name_ref() )); br->to_set().ins( bs ); bs->to_tuple().ins_last(new BinRep( "size" )); bs->to_tuple().ins_last(new BinRep( this->type().size() )); br->to_set().ins( bs ); index = L.entries(); vdl.install_expr( *this, index ); return index; } /// Function used for writing expressions, specifies Fortran 77 /// operator-precedence int operator_precedence(const OP_TYPE ot) { switch (ot) { case PAREN_OP: case LAMBDA_CALL_OP: case ARG_OP: return 0; case U_PLUS_OP: case U_MINUS_OP: case SUB_OP: case ADD_OP: return 70; case NOT_OP: return 40; case EQ_OP: case GE_OP: case NE_OP: case LT_OP: case LE_OP: case GT_OP: return 50; case DIV_OP: case INTDIV_OP: case RATDIV_OP: case MULT_OP: return 80; case EXP_OP: return 90; case CONCAT_OP: return 60; case OR_OP: return 20; case AND_OP: return 30; case EQV_OP: case NEQV_OP: return 10; case COMMA_OP: return 1; default: return -1; } } /// print the expression to \'o\', parenthesizing if the precedence /// calls for it. void print_prec(OP_TYPE parent_op, const Expression * e, ostream & o) { if (!e) o << "<UNDEFINED>"; else { int e_prec = operator_precedence(e->op()); int our_prec = operator_precedence(parent_op); Boolean print_with_paren = False; if (e_prec != -1 && our_prec != -1 && (e_prec < our_prec || (e_prec == our_prec && (e->op() != COMMA_OP) && (1 || parent_op == EXP_OP || parent_op == U_MINUS_OP || parent_op == U_PLUS_OP)))) { print_with_paren = True; } switch (e->op()) { case INTEGER_CONSTANT_OP: if (e->value()<0) print_with_paren = True; break; case REAL_CONSTANT_OP: if (e->data_ref()[0] == '-') print_with_paren = True; break; default: /// ... do nothing break; } if (!print_with_paren && dbx_full_parenthesization) { /// ... Override and ADD parentheses only if the following /// ... cases hold. (Pretty much things that are leaves /// ... don't want parentheses for aesthetic and syntax reasons). if (!e->is_wildcard()) { switch (e->op()) { default: /// ... DO override for anything not specifically specified print_with_paren = True; break; case INTEGER_CONSTANT_OP: case REAL_CONSTANT_OP: case STRING_CONSTANT_OP: case LOGICAL_CONSTANT_OP: case HOLLERITH_CONSTANT_OP: case ARRAY_REF_OP: case SUBSTRING_OP: case FUNCTION_CALL_OP: case INTRINSIC_CALL_OP: case LAMBDA_CALL_OP: case ARG_OP: case RETURN_OP: case LABEL_OP: case IO_STAR_OP: case FORMAT_OP: case ID_OP: case KEY_OP: case KEYPAIR_OP: case DO_OP: case EQUAL_OP: case COMMA_OP: /// ... DON'T OVERRIDE FOR THESE LEAF-TYPES break; } } } if (print_with_paren) o << "(" << *e << ")"; else o << *e; } } /// Helper function used to print the given list, sepperating each /// element by c. ot is op_type of parent expr. void print_prec_list(ostream & o, OP_TYPE optype, const List<Expression> &l, const char *c) { Iterator<Expression> iter = l; if (iter.end()) { /// ... An empty COLON list is meaningful. i.e. A(:) if (optype == COLON_OP) o << c; } else { print_prec(optype, &iter.current(), o); iter.next(); if (iter.end()) { /// ... An single element COLON list is meaningful. i.e. A(5:) if (optype == COLON_OP) o << c; } else { for ( ; !iter.end(); iter.next()) { o << c; print_prec(optype, &iter.current(), o); } } } } //----------------------------------------------------------------------------- /// ArgNumberExpr code: /// ArgNumberExpr::~ArgNumberExpr() { /// ... nothing to do } ArgNumberExpr & ArgNumberExpr::operator = (const ArgNumberExpr & e) { if (this != &e) _value = e.value(); return *this; } Expression * ArgNumberExpr::clone() const { return new ArgNumberExpr(*this); } int ArgNumberExpr::structures_OK() const { cerr << "ArgNumber::structures_OK() not implemented"; return True; } int ArgNumberExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "ARG#" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "data" )); br->to_tuple().ins_last(new BinRep( this->value() )); return index; } void ArgNumberExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "ArgNumber"); else if (field == "data") { p_assert( second.is_integer(), "ArgNumber::convert: " "'data' field does not contain an int." ); _value = second.to_integer(); } else if (field != "op" && field != "size") make_overflow(expr_iter, "ArgNumber"); } } void ArgNumberExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << "#" << _value; } //----------------------------------------------------------------------------- /// ArrayRefExpr code: /// /// Note: The following data fields are aliased: /// array = left /// subscript = right ArrayRefExpr::~ArrayRefExpr() { if (_arcs) delete _arcs; } Expression * ArrayRefExpr::clone() const { return new ArrayRefExpr(*this); } ArrayRefExpr & ArrayRefExpr::operator = (const ArrayRefExpr & e) { if (this != &e) { BinaryExpr::operator = (e); _arcs = 0; } return *this; } void ArrayRefExpr::array(Expression * e) { p_assert(e->op() == ID_OP, "ArrayRefExpr::array( ) expression not an IDExpr"); _left(e); } void ArrayRefExpr::subscript(Expression * e) { p_assert(e->op() == COMMA_OP, "ArrayRefExpr::subscript( ) expression not an CommaExpr"); _right(e); } int ArrayRefExpr::structures_OK() const { cerr << "ArrayRefExpr::structures_OK() not implemented"; return True; } int ArrayRefExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "ARRAY_REF" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->array().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->subscript().exchange_expr(vdl))); return index; } void ArrayRefExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "ArrayRef"); else if (field == "size") { p_assert( second.is_integer(), "ArrayRefExpr::convert: " "'size' field contains non-int." ); _type.set(second.to_integer()); } else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep theArg = iter.current(); /// ... first element of args tuple Expression *e1; p_assert( theArg.is_integer(), "ArrayRefExpr::convert: arg field contains non-int." ); e1 = tableEntry(theArg.to_integer()); ++iter; theArg = iter.current(); /// ... Second element of args tuple p_assert( theArg.is_integer(), "ArrayRefExpr::convert: arg field contains non-int." ); Expression *e2 = tableEntry(theArg.to_integer()); _left(e1); _right(e2); } else if (field != "op" && field != "size") make_overflow(expr_iter, "ArrayRefExpr"); } } void ArrayRefExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { print_prec(op(), (_left_valid() ? &_left_guarded() : 0), o); o << "("; print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); o << ")"; } //----------------------------------------------------------------------------- /// BinaryExpr code: /// BinaryExpr::~BinaryExpr() { /// ... nothing to do } Expression * BinaryExpr::clone() const { return new BinaryExpr(*this); } BinaryExpr & BinaryExpr::operator = (const BinaryExpr & e) { if (this != &e) { if (e._left_valid()) _left(e._left_guarded().clone()); else _left(0); if (e._right_valid()) _right(e._right_guarded().clone()); else _right(0); } return *this; } const RefList<Expression>* BinaryExpr::arg_refs() const { RefList<Expression>*args = new RefList<Expression>; if (_left_valid()) args->ins_last(CASTAWAY(Expression &) _left_guarded()); if (_right_valid()) args->ins_last(CASTAWAY(Expression &) _right_guarded()); return (const RefList<Expression> *) args; } void BinaryExpr::left(Expression * e) { _left(e); } const Expression & BinaryExpr::left_guarded() const { return _left_guarded(); } Expression & BinaryExpr::left_guarded() { return _left_guarded(); } Boolean BinaryExpr::left_valid() const { return _left_valid(); } Expression * BinaryExpr::grab_left() { return _grab_left(); } void BinaryExpr::right(Expression * e) { _right(e); } const Expression & BinaryExpr::right_guarded() const { return _right_guarded(); } Expression & BinaryExpr::right_guarded() { return _right_guarded(); } Boolean BinaryExpr::right_valid() const { return _right_valid(); } Expression * BinaryExpr::grab_right() { return _grab_right(); } Boolean BinaryExpr::args_are_non_null() const { return _left_valid() && _right_valid(); } const List<Expression> & BinaryExpr::arg_list() const { return _arg_list; } List<Expression> & BinaryExpr::arg_list() { return _arg_list; } int BinaryExpr::structures_OK() const { cerr << "BinaryExpr::structures_OK() not implemented"; return True; } int BinaryExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); String opcode; switch (op()) { case EQ_OP: opcode = ".EQ."; break; case NE_OP: opcode = ".NE."; break; case LT_OP: opcode = ".LT."; break; case LE_OP: opcode = ".LE."; break; case GT_OP: opcode = ".GT."; break; case GE_OP: opcode = ".GE."; break; case SUB_OP: opcode = "-"; break; case DIV_OP: opcode = "/"; break; case INTDIV_OP: opcode = "/#"; break; case RATDIV_OP: opcode = "/%"; break; case EXP_OP: opcode = "**"; break; case CONCAT_OP: opcode = "/// ... "; break; case REPSTAR_OP: opcode = "REP*"; break; case KEYPAIR_OP: opcode = "KEYPAIR"; break; default: break; } BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( opcode )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->left_guarded().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->right_guarded().exchange_expr(vdl))); return index; } void BinaryExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "Binary"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep theArg = iter.current(); /// ... first element of args tuple Expression *e1 = NULL; if (theArg.is_integer()) e1 = tableEntry(theArg.to_integer()); else if (theArg.is_omega()) e1 = new OmegaExpr; else { p_abort( "BinaryExpr::convert: arg field contains non-int"); } ++iter; theArg = iter.current(); /// ... Second element of args tuple p_assert( theArg.is_integer(), "BinaryExpr::convert: arg field contains non-int." ); Expression *e2 = tableEntry(theArg.to_integer()); _left(e1); _right(e2); } else if (field == "size") { p_assert( second.is_integer(), "BinaryExpr::convert: 'size' field contains non-int."); _type.set(second.to_integer()); } else if (field != "op") make_overflow(expr_iter, "BinaryExpr"); } } void BinaryExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { print_prec(op(), (_left_valid() ? &_left_guarded() : 0), o); switch (op()) { case EQ_OP: o << ".EQ."; break; case NE_OP: o << ".NE."; break; case LT_OP: o << ".LT."; break; case LE_OP: o << ".LE."; break; case GT_OP: o << ".GT."; break; case GE_OP: o << ".GE."; break; case SUB_OP: o << "-"; break; case DIV_OP: o << "/"; break; case INTDIV_OP: o << "/#"; break; case RATDIV_OP: o << "/%"; break; case EXP_OP: o << "**"; break; /// ... precedence different case REPSTAR_OP: o << " * "; break; case KEYPAIR_OP: o << "="; break; default: break; } if (_right_valid() && (op() == SUB_OP || op() == DIV_OP || op() == INTDIV_OP || op() == RATDIV_OP) && (operator_precedence(op()) == operator_precedence(_right_guarded().op()))) o << "(" << _right_guarded() << ")"; else print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); } void BinaryExpr::relink_eptrs(ProgramUnit & p) { if (_left_valid()) _left_guarded().relink_eptrs(p); if (_right_valid()) _right_guarded().relink_eptrs(p); } //----------------------------------------------------------------------------- /// CommaExpr code: /// CommaExpr::~CommaExpr() { /// ... nothing to do } Expression * CommaExpr::clone() const { return new CommaExpr(*this); } CommaExpr & CommaExpr::operator = (const CommaExpr & e) { NonBinaryExpr::operator = (e); return *this; } int CommaExpr::structures_OK() const { cerr << "CommaExpr::structures_OK() not implemented"; return True; } int CommaExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "," )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); for (Iterator<Expression> iter = _arg_list; iter.valid(); ++iter) { bt->to_tuple().ins_last( new BinRep( iter.current().exchange_expr(vdl))); } return index; } void CommaExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "Comma"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); for (BinRep args; iter.valid(); ++iter) { args = iter.current(); p_assert( args.is_integer(), "CommaExpr::convert: " "Non-Binary Op's arg field contains non-int" ); Expression *thug = tableEntry(args.to_integer()); _arg_list.ins_last(thug); } } else if (field != "op" && field != "size") make_overflow(expr_iter, "CommaExpr"); } } void CommaExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { print_prec_list(o, op(), _arg_list, ", "); } //----------------------------------------------------------------------------- /// ComplexExpr code: /// /// Note: The following data fields are aliased: /// real_part = left /// imaginary_part = right ComplexExpr::~ComplexExpr() { /// ... nothing to do } Expression * ComplexExpr::clone() const { return new ComplexExpr(*this); } ComplexExpr & ComplexExpr::operator = (const ComplexExpr & e) { BinaryExpr::operator = (e); return *this; } int ComplexExpr::structures_OK() const { cerr << "ComplexExpr::structures_OK() not implemented"; return True; } int ComplexExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "COMPLEX" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->left_guarded().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->right_guarded().exchange_expr(vdl))); return index; } void ComplexExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") { second.to_string(s); p_assert( s == "COMPLEX", "ComplexExpr::convert: type field not COMPLEX." ); _type = COMPLEX_TYPE; } else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep theArg = iter.current(); /// ... first element of args tuple Expression *e1; p_assert( theArg.is_integer(), "ComplexExpr::convert: arg field contains non-int." ); e1 = tableEntry(theArg.to_integer()); ++iter; theArg = iter.current(); /// ... Second element of args tuple p_assert( theArg.is_integer(), "ComplexExpr::convert: arg field contains non-int." ); Expression *e2 = tableEntry(theArg.to_integer()); _left(e1); _right(e2); } else if (field != "op" && field != "size") make_overflow(expr_iter, "ComplexExpr"); } } void ComplexExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << "("; if (_left_valid()) o << _left_guarded(); else o << "<UNDEFINED>"; o << ", "; if (_right_valid()) o << _right_guarded(); else o << "<UNDEFINED>"; o << ")"; } //----------------------------------------------------------------------------- /// DoExpr code: /// /// Note: The following data fields are aliased: /// iolist = left /// iterator = right DoExpr::~DoExpr() { /// ... nothing to do } DoExpr & DoExpr::operator = (const DoExpr & e) { BinaryExpr::operator = (e); return *this; } Expression * DoExpr::clone() const { return new DoExpr(*this); } void DoExpr::iolist(Expression * e) { p_assert(e->op() == COMMA_OP, "DoExpr:: iolist( ) not a CommaExpr"); _left(e); } const Expression & DoExpr::iolist() const { return _left_guarded(); } Expression & DoExpr::iolist() { return _left_guarded(); } void DoExpr::iterator(Expression * e) { p_assert(e->op() == EQUAL_OP, "DoExpr:: iterator( ) not a EqualExpr"); _right(e); } const Expression & DoExpr::iterator() const { return _right_guarded(); } Expression & DoExpr::iterator() { return _right_guarded(); } int DoExpr::structures_OK() const { cerr << "DoExpr::structures_OK() not implemented"; return True; } int DoExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "DO" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->iolist().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->iterator().exchange_expr(vdl))); return index; } void DoExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "Do"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep theArg = iter.current(); /// ... first element of args tuple Expression *e1; p_assert( theArg.is_integer(), "DoExpr::convert: arg field contains non-int." ); e1 = tableEntry(theArg.to_integer()); ++iter; theArg = iter.current(); /// ... Second element of args tuple p_assert( theArg.is_integer(), "DoExpr::convert: arg field contains non-int." ); Expression *e2 = tableEntry(theArg.to_integer()); _left(e1); _right(e2); } else if (field != "op" && field != "size") make_overflow(expr_iter, "DoExpr"); } } void DoExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << "("; print_prec(op(), (_left_valid() ? &_left_guarded() : 0), o); o << ", "; print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); o << ")"; } //----------------------------------------------------------------------------- /// EqualExpr code: /// /// Note: The following data fields are aliased: /// index_id = left /// iteration_space = right EqualExpr::~EqualExpr() { /// ... nothing to do } Expression * EqualExpr::clone() const { return new EqualExpr(*this); } EqualExpr & EqualExpr::operator = (const EqualExpr & e) { BinaryExpr::operator = (e); return *this; } void EqualExpr::index_id(Expression * e) { p_assert(e->op() == ID_OP, "EqualExpr::index_id( ) not an IDExpr"); _left(e); } const Expression & EqualExpr::index_id() const { return _left_guarded(); } Expression & EqualExpr::index_id() { return _left_guarded(); } void EqualExpr::iteration_space(Expression * e) { p_assert(e->op() == COMMA_OP, "EqualExpr::iteration_space( ) not an CommaExpr"); _right(e); } const Expression & EqualExpr::iteration_space() const { return _right_guarded(); } Expression & EqualExpr::iteration_space() { return _right_guarded(); } int EqualExpr::structures_OK() const { cerr << "EqualExpr::structures_OK() not implemented"; return True; } int EqualExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "=" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->index_id().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->iteration_space().exchange_expr(vdl))); return index; } void EqualExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "Equal"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep theArg = iter.current(); /// ... first element of args tuple p_assert( theArg.is_integer(), "EqualExpr::convert: arg field contains non-int." ); Expression *e1 = tableEntry(theArg.to_integer()); ++iter; theArg = iter.current(); /// ... Second element of args tuple p_assert( theArg.is_integer(), "EqualExpr::convert: arg field contains non-int." ); Expression *e2 = tableEntry(theArg.to_integer()); _left(e1); _right(e2); } else if (field != "op" && field != "size") make_overflow(expr_iter, "EqualExpr"); } } void EqualExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { print_prec(op(), (_left_valid() ? &_left_guarded() : 0), o); o << "="; print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); } //----------------------------------------------------------------------------- /// FormatExpr code: /// /// Note: The following data fields are aliased: /// format = data FormatExpr::~FormatExpr() { /// ... nothing to do } Expression * FormatExpr::clone() const { return new FormatExpr(*this); } const Format & FormatExpr::format() const { return *_format_ptr; } Format & FormatExpr::format() { return *_format_ptr; } void FormatExpr::format(Format & format) { _format_ptr = &format; } int FormatExpr::structures_OK() const { cerr << "FormatExpr::structures_OK() not implemented"; return True; } int FormatExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "FORMAT" )); S.ins( br ); return index; } void FormatExpr::convert(BinRep & NOTUSED(exprSet), Symtab & NOTUSED(symtab)) { /// ... Currently, doesn't exist on setl side -- no need for conversion } void FormatExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << _format_ptr->value(); } void FormatExpr::relink_eptrs(ProgramUnit & p) { p_assert(_format_ptr, "FormatExpr has NULL pointer"); int label = _format_ptr->value(); _format_ptr = p.formats().find_ref(label); p_assert(_format_ptr, "FormatExpr has NULL pointer"); } //----------------------------------------------------------------------------- /// FunctionCallExpr code: /// /// Note: The following data fields are aliased: /// function = left /// parameters = right FunctionCallExpr::~FunctionCallExpr() { /// ... nothing to do } Expression * FunctionCallExpr::clone() const { return new FunctionCallExpr(*this); } FunctionCallExpr & FunctionCallExpr::operator = (const FunctionCallExpr & e) { BinaryExpr::operator = (e); return *this; } void FunctionCallExpr::function(Expression * e) { p_assert(e->op() == ID_OP, "FunctionCallExpr:: function( ) not an IDExpr"); _left(e); } const Expression & FunctionCallExpr::function() const { return _left_guarded(); } Expression & FunctionCallExpr::function() { return _left_guarded(); } void FunctionCallExpr::parameters(Expression * e) { p_assert(e->op() == COMMA_OP || e->op() == OMEGA_OP, "FunctionCallExpr:: parameters( ) not an CommaExpr or OmegaExpr"); _right(e); } const Expression & FunctionCallExpr::parameters_guarded() const { return _right_guarded(); } Expression & FunctionCallExpr::parameters_guarded() { return _right_guarded(); } Boolean FunctionCallExpr::parameters_valid() const { return _right_valid(); } int FunctionCallExpr::structures_OK() const { cerr << "FunctionCallExpr::structures_OK() not implemented"; return True; } int FunctionCallExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "FUNCTION_CALL" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->function().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->parameters_guarded().exchange_expr(vdl))); return index; } void FunctionCallExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "FunctionCall"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep args = iter.current(); p_assert( args.is_integer(), "FunctionCall::convert: " "Call's first arg field contains non-int." ); Expression *e1 = tableEntry(args.to_integer()); _left(e1); ++iter; if (iter.valid()) { args = iter.current(); p_assert( args.is_integer(), "FunctionCall::convert: " "Call's second arg field contains non-int." ); e1 = tableEntry(args.to_integer()); _right(e1); } } else if (field == "size") { p_assert( second.is_integer(), "FunctionCallExpr::convert: 'size' field contains non-int"); _type.set(second.to_integer()); } else if (field != "op") { make_overflow(expr_iter, "FunctionCallExpr"); } } } void FunctionCallExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { print_prec(op(), (_left_valid() ? &_left_guarded() : 0), o); o << "("; print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); o << ")"; } //----------------------------------------------------------------------------- /// HollerithConstExpr code: /// HollerithConstExpr::~HollerithConstExpr() { /// ... nothing to do } Expression * HollerithConstExpr::clone() const { return new HollerithConstExpr(*this); } HollerithConstExpr & HollerithConstExpr::operator = (const HollerithConstExpr & e) { StringExpr::operator = (e); return *this; } int HollerithConstExpr::structures_OK() const { cerr << "HollerithConstExpr::structures_OK() not implemented"; return True; } int HollerithConstExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "HOLLERITH_CONSTANT" )); S.ins( br ); return index; } void HollerithConstExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") { p_assert( second.is_string(), "HollerithConstExpr::convert: " "type field doesn't contain string." ); second.to_string(s); p_assert( s == "CHARACTER", "HollerithConstExpr::convert: " "type field not CHARACTER" ); _type = (CHARACTER_TYPE); } else if (field == "data") { p_assert( second.is_string(), "HollerithConst::convert: " "'data' field does not contain an string." ); second.to_string(_data); } else if (field == "size") { p_assert( second.is_integer(), "HollerithConstExpr::convert: " "'size' field contains non-int." ); _type.set(second.to_integer()); } else if (field != "op") make_overflow(expr_iter, "HollerithConstExpr"); } } //----------------------------------------------------------------------------- /// IDExpr code: /// IDExpr::~IDExpr() { if (_substituted) delete _substituted; if (_arcs) delete _arcs; } Expression * IDExpr::clone() const { return new IDExpr(*this); } IDExpr & IDExpr::operator = (const IDExpr & e) { if (this != &e) { if (_substituted) delete _substituted; _symbol = CASTAWAY(Symbol *) &e.symbol(); if (e.substituted_valid()) _substituted = e.substituted_guarded().clone(); else _substituted = 0; _arcs = 0; } return *this; } const Expression & IDExpr::substituted_guarded() const { p_assert(_substituted, "Guarded method called when field (_substituted) was NULL"); return *_substituted; } Expression & IDExpr::substituted_guarded() { p_assert(_substituted, "Guarded method called when field (_substituted) was NULL"); return *_substituted; } Boolean IDExpr::substituted_valid() const { if (_substituted) return True; else return False; } void IDExpr::substituted(Expression * e) { if (_substituted) delete _substituted; _substituted = e; } Expression * IDExpr::grab_substituted() { Expression *temp = _substituted; _substituted = 0; return temp; } const Symbol & IDExpr::symbol() const { return *_symbol; } Symbol & IDExpr::symbol() { return *_symbol; } void IDExpr::symbol(const Symbol & s) { _symbol = CASTAWAY(Symbol *)&s; } int IDExpr::structures_OK() const { cerr << "ID::structures_OK() not implemented"; return True; } int IDExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "ID" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "name" )); br->to_tuple().ins_last(new BinRep( this->symbol().name_ref() )); S.ins( br ); return index; } void IDExpr::convert(BinRep & exprSet, Symtab & symtab) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "ID"); else if (field == "size") { p_assert( second.is_integer(), "IDExpr::convert: " "'size' field contains non-int" ); _type.set(second.to_integer()); } else if (field == "name") { p_assert( second.is_string(), "IDExpr::convert: " " 'name' field contains non-string" ); String idname; second.to_string(idname); _symbol = symtab.find_ref(idname); if (! _symbol) { cerr << "IDExpr::convert: " << "Symbol table does not contain entry for " << idname << endl; p_abort("(See above error message)"); } } else if (field == "substituted") { p_assert( second.is_integer(), "fillExpr: 'substituted' field contains non-int" ); _substituted = tableEntry(second.to_integer()); } else if (field != "op" && field != "size") make_overflow(expr_iter, "IDExpr"); } } void IDExpr::print_debug(ostream & o, Boolean debug) const { if (! _symbol) o << "(NO SYMBOL)"; else { o << convert_case( _symbol->name_ref() ); } if (debug) { if (_substituted) o << "[" << *_substituted << "]"; } } void IDExpr::relink_eptrs(ProgramUnit & p) { p_assert(_symbol, "IDExpr has NULL pointer"); _symbol = p.symtab().find_ref(_symbol->name_ref()); p_assert(_symbol, "IDExpr has NULL pointer"); } //----------------------------------------------------------------------------- /// IOStarExpr code: /// IOStarExpr::~IOStarExpr() { /// ... nothing to do } Expression * IOStarExpr::clone() const { return new IOStarExpr(*this); } IOStarExpr & IOStarExpr::operator = (const IOStarExpr & NOTUSED(e)) { return *this; } int IOStarExpr::structures_OK() const { cerr << "IOStar::structures_OK() not implemented"; return True; } int IOStarExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "IO*" )); S.ins( br ); return index; } void IOStarExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "IOStar"); else if (field != "op" && field != "size") make_overflow(expr_iter, "IOStarExpr"); } } void IOStarExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << "*"; } //----------------------------------------------------------------------------- /// InfinityExpr code: /// InfinityExpr::~InfinityExpr() { /// ... Nothing to do } Expression * InfinityExpr::clone() const { return new InfinityExpr(*this); } InfinityExpr & InfinityExpr::operator = (const InfinityExpr & other) { _sign = other._sign; return *this; } void InfinityExpr::sign(int s) { _sign = (s >= 0) ? 1: -1; } int InfinityExpr::sign() const { return _sign; } int InfinityExpr::structures_OK() const { if (_sign == 0) { cerr << "InfinityExpr::structures_OK(): Expression has a zero sign.\n"; return False; } else if (type().data_type() != INTEGER_TYPE) { cerr << "InfinityExpr::structures_OK(): " << "Expression has a non-integer type.\n"; return False; } return True; } int InfinityExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "INFINITY" )); S.ins( br ); return index; } void InfinityExpr::convert(BinRep & NOTUSED(exprSet), Symtab & NOTUSED(symtab)) { p_abort( "Cannot read a InfinityExpr object from a binstring."); } void InfinityExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { if (_sign >= 0) o << "Inf"; else o << "-Inf"; } //----------------------------------------------------------------------------- /// IntConstExpr code: /// IntConstExpr::~IntConstExpr() { /// ... nothing to do } int IntConstExpr::value() const { return _value; } void IntConstExpr::value(int v) { _value = v; } Expression * IntConstExpr::clone() const { return new IntConstExpr(*this); } IntConstExpr & IntConstExpr::operator = (const IntConstExpr & e) { if (this != &e) _value = e.value(); return *this; } int IntConstExpr::structures_OK() const { cerr << "IntConstExpr::structures_OK() not implemented"; return True; } int IntConstExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "INTEGER_CONSTANT" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "data" )); br->to_tuple().ins_last(new BinRep( this->value() )); S.ins( br ); return index; } void IntConstExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") { p_assert( second.is_string(), "IntConstExpr::convert: " "type field doesn't contain string" ); second.to_string(s); p_assert( (s == "INTEGER"), "IntConstExpr not of INTEGER type" ); _type = INTEGER_TYPE; } else if (field == "data") { if (!second.is_integer()) { cerr << "IntConstExpr's 'data' field contains non-int in : " << exprSet << endl; p_abort("(See above error message)"); } else _value = second.to_integer(); } else if (field != "op" && field != "size") make_overflow(expr_iter, "IntConstExpr"); } } void IntConstExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << _value; } //----------------------------------------------------------------------------- /// IntrinsicCallExpr code: /// /// Note: The following data fields are aliased: /// intrinsic = left /// parameters = right IntrinsicCallExpr::~IntrinsicCallExpr() { /// ... nothing to do } Expression * IntrinsicCallExpr::clone() const { return new IntrinsicCallExpr(*this); } IntrinsicCallExpr & IntrinsicCallExpr::operator = (const IntrinsicCallExpr & e) { BinaryExpr::operator = (e); return *this; } void IntrinsicCallExpr::intrinsic(Expression * e) { p_assert(e->op() == ID_OP, "IntrinsicCallExpr::Intrinsic( ) not an IDExpr"); _left(e); } const Expression & IntrinsicCallExpr::intrinsic() const { return _left_guarded(); } Expression & IntrinsicCallExpr::intrinsic() { return _left_guarded(); } void IntrinsicCallExpr::parameters(Expression * e) { p_assert(e->op() == COMMA_OP, "IntrinsicCallExpr::Parameters( ) not a CommaExpr"); _right(e); } const Expression & IntrinsicCallExpr::parameters_guarded() const { return _right_guarded(); } Expression & IntrinsicCallExpr::parameters_guarded() { return _right_guarded(); } Boolean IntrinsicCallExpr::parameters_valid() const { return _right_valid(); } int IntrinsicCallExpr::structures_OK() const { cerr << "IntrinsicCallExpr::structures_OK() not implemented"; return True; } int IntrinsicCallExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "INTRINSIC_CALL" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->intrinsic().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->parameters_guarded().exchange_expr(vdl))); return index; } void IntrinsicCallExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "IntrinsicCall"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep & args = iter.current(); p_assert( args.is_integer(), "IntrinsicCall::convert: " "Call's first arg field contains non-int" ); Expression *e1 = tableEntry(args.to_integer()); _left(e1); ++iter; if (iter.valid()) { args = iter.current(); p_assert( (args.is_integer()), "IntrinsicCall::convert: " "Call's second arg field contains non-int" ); e1 = tableEntry(args.to_integer()); _right(e1); } } else if (field != "op" && field != "size") make_overflow(expr_iter, "IntrinsicCall"); } } void IntrinsicCallExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { /// ... Apply translate_special_name to the intrinsic function name, since /// ... it may have a machine-specific form if (_left_valid()) { o << translate_special_name(this->intrinsic().symbol().name_ref()); } else { o << "<UNDEF>"; } o << "("; print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); o << ")"; } //----------------------------------------------------------------------------- /// LabelExpr code: /// /// Note: The following data fields are aliased: /// label = data LabelExpr::~LabelExpr() { /// ... nothing to do } LabelExpr & LabelExpr::operator = (const LabelExpr & e) { _stmt = e._stmt; return *this; } Expression * LabelExpr::clone() const { return new LabelExpr(*this); } const Statement & LabelExpr::stmt() const { return *_stmt; } Statement & LabelExpr::stmt() { return *_stmt; } void LabelExpr::stmt(Statement & stmt) { p_assert(stmt.stmt_class()==LABEL_STMT, "LabelExpr::stmt: attempt to point at non-label"); _stmt = &stmt; } void LabelExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { if (_stmt) { o << _stmt->value(); } else { o << "<UNDEFINED STMT>"; } } int LabelExpr::structures_OK() const { if (!_stmt) { cerr << "LabelExpr::structures_OK(): Found NULL _stmt field\n"; cerr << "In LabelExpr:\n" << flush << *this; return False; } if (!_stmt->structures_OK()) { cerr << "In context of LabelExpr:\n" << flush << *this; return False; } return True; } void LabelExpr::relink_eptrs(ProgramUnit & p) { p_assert(_stmt, "LabelExpr has NULL pointer"); _stmt = p.stmts().find_ref(_stmt->tag()); p_assert(_stmt, "LabelExpr has NULL pointer"); } int LabelExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "LABEL" )); S.ins( br ); return index; } void LabelExpr::convert(BinRep & NOTUSED(exprSet), Symtab & NOTUSED(symtab)) { p_abort( "Internal Error: The conversion of a binstring to an " "Expression came across an old \"label\" op, which was " "believed to no longer be attainable outside of the " "scanner. Please report this bug to the development " "group. To the development group: See the comments " "in the LabelExpr::convert() routine."); /// ... NOTE: See also the p_assert() in ExprTable.cc's get_expr_obj() /// ... The old LabelExpr class to which the "label" op used to /// ... be converted can still be used here. However, the old /// ... LabelExpr contained a string label, /// ... the new one expects a statement label, so the convert /// ... routine must simply be changed to convert the statement label /// ... string into a statement pointer. #if 0 String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "Label"); else if (field == "label") { p_assert( second.is_string(), "LabelExpr::convert: " "'label' field does not contain label" ); second.to_string(_data); } else if (field != "op") make_overflow(expr_iter, "LabelExpr"); } #endif } //----------------------------------------------------------------------------- /// LambdaCallExpr code: /// /// Note: The following data fields are aliased: /// expr = left /// parameters = right; LambdaCallExpr::~LambdaCallExpr() { /// ... nothing to do } Expression * LambdaCallExpr::clone() const { return new LambdaCallExpr(*this); } LambdaCallExpr & LambdaCallExpr::operator = (const LambdaCallExpr & e) { BinaryExpr::operator = (e); return *this; } void LambdaCallExpr::lambda_expr(Expression * e) { _left(e); } const Expression & LambdaCallExpr::lambda_expr() const { return _left_guarded(); } Expression & LambdaCallExpr::lambda_expr() { return _left_guarded(); } void LambdaCallExpr::parameters(Expression * e) { p_assert(e->op() == COMMA_OP, "LambdaCallExpr::parameters( ) not a CommaExpr"); _right(e); } const Expression & LambdaCallExpr::parameters_guarded() const { return _right_guarded(); } Expression & LambdaCallExpr::parameters_guarded() { return _right_guarded(); } Boolean LambdaCallExpr::parameters_valid() const { return _right_valid(); } int LambdaCallExpr::structures_OK() const { cerr << "LambdaCallExpr::structures_OK() not implemented"; return True; } int LambdaCallExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "LAMBDA_CALL" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); bt->to_tuple().ins_last( new BinRep( this->lambda_expr().exchange_expr(vdl))); bt->to_tuple().ins_last( new BinRep( this->parameters_guarded().exchange_expr(vdl))); return index; } void LambdaCallExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "LambdaCall"); else if (field == "args") { Iterator<BinRep> iter = second.to_tuple(); BinRep & args = iter.current(); p_assert( args.is_integer(), "LambdaCall::convert: " "Call's first arg field contains non-int" ); Expression *e1 = tableEntry(args.to_integer()); _left(e1); ++iter; if (iter.valid()) { args = iter.current(); p_assert( args.is_integer(), "LambdaCall::convert: " "Call's second arg field contains non-int" ); e1 = tableEntry(args.to_integer()); _right(e1); } } else if (field != "op" && field != "size") make_overflow(expr_iter, "LambdaCall"); } } void LambdaCallExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { print_prec(op(), (_left_valid() ? &_left_guarded() : 0), o); o << "("; print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); o << ")"; } //----------------------------------------------------------------------------- /// LogicalConstExpr code: /// LogicalConstExpr::~LogicalConstExpr() { /// ... nothing to do } LogicalConstExpr & LogicalConstExpr::operator = (const LogicalConstExpr & e) { StringExpr::operator = (e); return *this; } Expression * LogicalConstExpr::clone() const { return new LogicalConstExpr(*this); } int LogicalConstExpr::structures_OK() const { cerr << "LogicalConstExpr::structures_OK() not implemented"; return True; } int LogicalConstExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "LOGICAL_CONSTANT" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "data" )); br->to_tuple().ins_last(new BinRep( this->data_ref() )); S.ins( br ); return index; } void LogicalConstExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") { p_assert( second.is_string(), "LogicalConstExpr::convert: " "type field doesn't contain string" ); second.to_string(s); p_assert( (s == "LOGICAL"), "LogicalConstExpr::convert: type field not LOGICAL" ); _type = (LOGICAL_TYPE); } else if (field == "data") { p_assert( second.is_string(), "LogicalConst::convert: " "'data' field does not contain an string." ); second.to_string(_data); } else if (field != "op" && field != "size") make_overflow(expr_iter, "LogicalConstExpr"); } } //----------------------------------------------------------------------------- /// KeyExpr code: /// KeyExpr::~KeyExpr() { /// ... nothing to do } KeyExpr & KeyExpr::operator = (const KeyExpr & e) { StringExpr::operator = (e); return *this; } Expression * KeyExpr::clone() const { return new KeyExpr(*this); } int KeyExpr::structures_OK() const { return True; } int KeyExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "KEY" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "data" )); br->to_tuple().ins_last(new BinRep( this->data_ref() )); S.ins( br ); return index; } void KeyExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "data") { p_assert( second.is_string(), "KeyExpr::convert: " "'data' field does not contain an string." ); second.to_string(_data); } else if (field != "op" && field != "size" && field != "type") make_overflow(expr_iter, "KeyExpr"); } } //----------------------------------------------------------------------------- /// NonBinaryExpr code: /// NonBinaryExpr::~NonBinaryExpr() { /// ... nothing to do } Expression * NonBinaryExpr::clone() const { return new NonBinaryExpr(*this); } NonBinaryExpr::NonBinaryExpr(OP_TYPE o, const Type & e, List<Expression> *list) : Expression(o, e) { for (Iterator<Expression>iter = *list; iter.valid(); ++iter) _arg_list.ins_last(list->grab(iter.current())); delete list; } NonBinaryExpr & NonBinaryExpr::operator = (const NonBinaryExpr & e) { if (this != &e) _arg_list = e.arg_list(); return *this; } const List<Expression> & NonBinaryExpr::arg_list() const { return _arg_list; } List<Expression> & NonBinaryExpr::arg_list() { return _arg_list; } const RefList<Expression> * NonBinaryExpr::arg_refs() const { RefList<Expression> *args = new RefList<Expression>; Iterator<Expression> iter((List<Expression>&) _arg_list); for (; iter.valid(); ++iter) args->ins_last(iter.current()); return args; } int NonBinaryExpr::structures_OK() const { cerr << "NonBinaryExpr::structures_OK() not implemented"; return True; } int NonBinaryExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); String opcode; switch (this->op()) { case ADD_OP: opcode = "+"; break; case MULT_OP: opcode = "*"; break; case OR_OP: opcode = ".OR."; break; case AND_OP: opcode = ".AND."; break; case EQV_OP: opcode = ".EQV."; break; case NEQV_OP: opcode = ".NEQV."; break; case COLON_OP: opcode = ":"; break; default: break; } BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( opcode )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "args" )); BinRep *bt = new BinRep(new List<BinRep>); br->to_tuple().ins_last( bt ); S.ins( br ); for (Iterator<Expression> iter = _arg_list; iter.valid(); ++iter) { bt->to_tuple().ins_last( new BinRep( iter.current().exchange_expr(vdl))); } return index; } void NonBinaryExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") get_type(second, "NonBinary"); else if (field == "args") { for (Iterator<BinRep> iter = second.to_tuple(); iter.valid(); ++iter) { BinRep & args = iter.current(); p_assert( args.is_integer() || args.is_omega(), "NonBinaryExpr::convert: " "Non-Binary Op's arg field contains non-int or OM" ); Expression *thug = 0; if (args.is_integer()) thug = tableEntry(args.to_integer()); else if (args.is_omega()) thug = new OmegaExpr; _arg_list.ins_last(thug); } } else if (field != "op" && field != "size") make_overflow(expr_iter, "NonBinaryExpr"); } } void NonBinaryExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { String s; switch (op()) { case CONCAT_OP: s = "/// ... "; break; case COLON_OP: s = ":"; break; case OR_OP: s = ".OR."; break; case AND_OP: s = ".AND."; break; case EQV_OP: s = ".EQV."; break; case NEQV_OP: s = ".NEQV."; break; case ADD_OP: s = "+"; break; case MULT_OP: s = "*"; break; case COMMA_OP: s = ", "; break; default: p_abort("Unknown _OP"); } print_prec_list( o, op(), _arg_list, s); } void NonBinaryExpr::relink_eptrs(ProgramUnit & p) { Iterator<Expression>iter = _arg_list; for (; iter.valid(); ++iter) iter.current().relink_eptrs(p); } //----------------------------------------------------------------------------- /// OmegaExpr code: /// OmegaExpr::~OmegaExpr() { /// ... nothing to do } OmegaExpr & OmegaExpr::operator = (const OmegaExpr & NOTUSED(e)) { return *this; } Expression * OmegaExpr::clone() const { return new OmegaExpr(*this); } int OmegaExpr::structures_OK() const { cerr << "OmegaExpr::structures_OK() not implemented"; return True; } int OmegaExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "OMEGA_EXPR" )); S.ins( br ); return index; } void OmegaExpr::convert(BinRep & NOTUSED(exprSet), Symtab & NOTUSED(symtab)) { /// ... nothing to do } void OmegaExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { o << ""; } //----------------------------------------------------------------------------- /// GSAExpr code: /// /// Note: The following data fields are aliased: /// gate = left /// parameters = right GSAExpr::~GSAExpr() { /// ... nothing to do } Expression * GSAExpr::clone() const { return new GSAExpr(*this); } GSAExpr & GSAExpr::operator = (const GSAExpr & e) { BinaryExpr::operator = (e); return *this; } void GSAExpr::gate(Expression * e) { p_assert(!e || e->op() == OMEGA_OP || e->type().data_type() == LOGICAL_TYPE, "GSAExpr:: gate( ) not an OmegaExpr nor a logical expression "); _left(null_to_omega(e)); } const Expression & GSAExpr::gate() const { return _left_guarded(); } Expression & GSAExpr::gate() { return _left_guarded(); } void GSAExpr::parameters(Expression * e) { p_assert(e->op() == COMMA_OP || e->op() == OMEGA_OP, "GSAExpr:: parameters( ) not an CommaExpr or OmegaExpr"); _right(e); } const Expression & GSAExpr::parameters_guarded() const { return _right_guarded(); } Expression & GSAExpr::parameters_guarded() { return _right_guarded(); } Boolean GSAExpr::parameters_valid() const { return _right_valid(); } int GSAExpr::structures_OK() const { cerr << "GSAExpr::structures_OK() not implemented"; return True; } int GSAExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "GSA_EXPR" )); S.ins( br ); return index; } void GSAExpr::convert(BinRep & NOTUSED(exprSet), Symtab & NOTUSED(symtab)) { p_abort("GSAExpr::convert() not implemented."); } void GSAExpr::print_debug(ostream & o, Boolean NOTUSED(debug)) const { switch (op()) { case ALPHA_OP: o << "ALPHA"; break; case GAMMA_OP: o << "GAMMA"; break; case MU_OP: o << "MU"; break; case THETA_OP: o << "THETA"; break; case ETA_OP: o << "ETA"; break; default: break; } o << "("; if (_left_valid() && _left_guarded().op() != OMEGA_OP) { print_prec(op(), &_left_guarded(), o); o << ", "; } print_prec(op(), (_right_valid() ? &_right_guarded() : 0), o); o << ")"; } //----------------------------------------------------------------------------- /// RealConstExpr code: /// RealConstExpr::~RealConstExpr() { /// ... nothing to do } RealConstExpr & RealConstExpr::operator = (const RealConstExpr & e) { StringExpr::operator = (e); return *this; } Expression * RealConstExpr::clone() const { return new RealConstExpr(*this); } int RealConstExpr::structures_OK() const { cerr << "RealConstExpr::structures_OK() not implemented"; return True; } int RealConstExpr::exchange_expr( VDL & vdl ) { int index = vdl.look_up_expr( *this ); if (index >= 0) return index; index = Expression::exchange_expr( vdl ); BinRep *b = CASTAWAY(BinRep *) vdl.data_ref(); Set<BinRep> & S = b->find_ref( "expression" )->to_tuple()[index-1].to_set(); BinRep *br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "op" )); br->to_tuple().ins_last(new BinRep( "REAL_CONSTANT" )); S.ins( br ); br = new BinRep( new List<BinRep> ); br->to_tuple().ins_last(new BinRep( "data" )); br->to_tuple().ins_last(new BinRep( this->data_ref() )); S.ins( br ); return index; } void RealConstExpr::convert(BinRep & exprSet, Symtab & NOTUSED(symtab)) { String s; BinRep second; /// ... The second argument of tuple pairs empty_overflow(); for (Iterator<BinRep> expr_iter = exprSet.to_set(); expr_iter.valid(); ++expr_iter) { String field; expr_iter.current()[0].to_string(field); second = expr_iter.current()[1]; if (field == "type") { p_assert( second.is_string(), "RealConstExpr: type field doesn't contain string" ); second.to_string(s); if (s == "REAL") _type = REAL_TYPE; else if (s == "DOUBLE PRECISION") _type = DOUBLE_PRECISION_TYPE; else { cerr << "RealConstExpr of unexpected type (" << s << ")\n"; p_abort("(See above error message)"); } } else if (field == "data") { p_assert( second.is_string(), "RealConstExpr::convert: " "'data' field does not contain an string" ); second.to_string(_data); } else if (field != "op" && field != "size") make_overflow(expr_iter, "RealConstExpr"); } } //----------------------------------------------------------------------------- /// ReturnStarExpr code: /// ReturnStarExpr::~ReturnStarExpr() { /// ... nothing to do } Expression * ReturnStarExpr::clone() const { return new ReturnStarExpr(*this); } ReturnStarExpr & ReturnStarExpr::operator = (const ReturnStarExpr & e) { UnaryExpr::operator = (e); return *this; } int ReturnStarExpr::structures_OK() const { cerr << "ReturnStar::structures_OK() not implemented"; return True; } int ReturnStarExpr::exchange_expr( VDL & vdl ) { int<