X-Git-Url: http://review.tizen.org/git/?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-expr.c;h=839d768318e7b9ff5a663fb8ee63df4d81581c1f;hb=5039610b9630459799b24f64fb9ffdd810b8eee9;hp=9d48ed4a6488c492ffad3c5070e628f3892eda7b;hpb=ec09945c8ead3030ccf7739a685513e64e2e3539;p=platform%2Fupstream%2Fgcc.git diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9d48ed4..839d768 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,5 +1,5 @@ /* Expression translation - Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -17,8 +17,8 @@ for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ /* trans-expr.c-- generate GENERIC trees for gfc_expr. */ @@ -31,6 +31,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "toplev.h" #include "real.h" #include "tree-gimple.h" +#include "langhooks.h" #include "flags.h" #include "gfortran.h" #include "trans.h" @@ -39,8 +40,11 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "trans-array.h" /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ #include "trans-stmt.h" +#include "dependency.h" static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); +static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, + gfc_expr *); /* Copy the scalarization loop variables. */ @@ -139,6 +143,32 @@ gfc_conv_expr_present (gfc_symbol * sym) } +/* Converts a missing, dummy argument into a null or zero. */ + +void +gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts) +{ + tree present; + tree tmp; + + present = gfc_conv_expr_present (arg->symtree->n.sym); + tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, + fold_convert (TREE_TYPE (se->expr), integer_zero_node)); + + tmp = gfc_evaluate_now (tmp, &se->pre); + se->expr = tmp; + if (ts.type == BT_CHARACTER) + { + tmp = build_int_cst (gfc_charlen_type_node, 0); + tmp = build3 (COND_EXPR, gfc_charlen_type_node, present, + se->string_length, tmp); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->string_length = tmp; + } + return; +} + + /* Get the character length of an expression, looking through gfc_refs if necessary. */ @@ -205,13 +235,16 @@ gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock) static void -gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind) +gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, + const char *name, locus *where) { tree tmp; tree type; tree var; + tree fault; gfc_se start; gfc_se end; + char *msg; type = gfc_get_character_type (kind, ref->u.ss.length); type = build_pointer_type (type); @@ -229,7 +262,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind) if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) tmp = se->expr; else - tmp = gfc_build_indirect_ref (se->expr); + tmp = build_fold_indirect_ref (se->expr); tmp = gfc_build_array_ref (tmp, start.expr); se->expr = gfc_build_addr_expr (type, tmp); } @@ -243,12 +276,47 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind) gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &end.pre); } - tmp = - build2 (MINUS_EXPR, gfc_charlen_type_node, - fold_convert (gfc_charlen_type_node, integer_one_node), - start.expr); - tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp); - se->string_length = fold (tmp); + if (flag_bounds_check) + { + tree nonempty = fold_build2 (LE_EXPR, boolean_type_node, + start.expr, end.expr); + + /* Check lower bound. */ + fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr, + build_int_cst (gfc_charlen_type_node, 1)); + fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, + nonempty, fault); + if (name) + asprintf (&msg, "Substring out of bounds: lower bound of '%s' " + "is less than one", name); + else + asprintf (&msg, "Substring out of bounds: lower bound " + "is less than one"); + gfc_trans_runtime_check (fault, msg, &se->pre, where); + gfc_free (msg); + + /* Check upper bound. */ + fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr, + se->string_length); + fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, + nonempty, fault); + if (name) + asprintf (&msg, "Substring out of bounds: upper bound of '%s' " + "exceeds string length", name); + else + asprintf (&msg, "Substring out of bounds: upper bound " + "exceeds string length"); + gfc_trans_runtime_check (fault, msg, &se->pre, where); + gfc_free (msg); + } + + tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, + build_int_cst (gfc_charlen_type_node, 1), + start.expr); + tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp); + tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, + build_int_cst (gfc_charlen_type_node, 0)); + se->string_length = tmp; } @@ -281,8 +349,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) se->string_length = tmp; } - if (c->pointer && c->dimension == 0) - se->expr = gfc_build_indirect_ref (se->expr); + if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER) + se->expr = build_fold_indirect_ref (se->expr); } @@ -294,6 +362,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; gfc_symbol *sym; + tree parent_decl; + int parent_flag; + bool return_value; + bool alternate_entry; + bool entry_master; sym = expr->symtree->n.sym; if (se->ss != NULL) @@ -305,7 +378,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* A scalarized term. We already know the descriptor. */ se->expr = se->ss->data.info.descriptor; se->string_length = se->ss->string_length; - ref = se->ss->data.info.ref; + for (ref = se->ss->data.info.ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) + break; } else { @@ -313,32 +388,49 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = gfc_get_symbol_decl (sym); + /* Deal with references to a parent results or entries by storing + the current_function_decl and moving to the parent_decl. */ + return_value = sym->attr.function && sym->result == sym; + alternate_entry = sym->attr.function && sym->attr.entry + && sym->result == sym; + entry_master = sym->attr.result + && sym->ns->proc_name->attr.entry_master + && !gfc_return_by_reference (sym->ns->proc_name); + parent_decl = DECL_CONTEXT (current_function_decl); + + if ((se->expr == parent_decl && return_value) + || (sym->ns && sym->ns->proc_name + && parent_decl + && sym->ns->proc_name->backend_decl == parent_decl + && (alternate_entry || entry_master))) + parent_flag = 1; + else + parent_flag = 0; + /* Special case for assigning the return value of a function. Self recursive functions must have an explicit return value. */ - if (se->expr == current_function_decl && sym->attr.function - && (sym->result == sym)) - se_expr = gfc_get_fake_result_decl (sym); + if (return_value && (se->expr == current_function_decl || parent_flag)) + se_expr = gfc_get_fake_result_decl (sym, parent_flag); /* Similarly for alternate entry points. */ - else if (sym->attr.function && sym->attr.entry - && (sym->result == sym) - && sym->ns->proc_name->backend_decl == current_function_decl) + else if (alternate_entry + && (sym->ns->proc_name->backend_decl == current_function_decl + || parent_flag)) { gfc_entry_list *el = NULL; for (el = sym->ns->entries; el; el = el->next) if (sym == el->sym) { - se_expr = gfc_get_fake_result_decl (sym); + se_expr = gfc_get_fake_result_decl (sym, parent_flag); break; } } - else if (sym->attr.result - && sym->ns->proc_name->backend_decl == current_function_decl - && sym->ns->proc_name->attr.entry_master - && !gfc_return_by_reference (sym->ns->proc_name)) - se_expr = gfc_get_fake_result_decl (sym); + else if (entry_master + && (sym->ns->proc_name->backend_decl == current_function_decl + || parent_flag)) + se_expr = gfc_get_fake_result_decl (sym, parent_flag); if (se_expr) se->expr = se_expr; @@ -351,7 +443,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) if (!sym->attr.dummy) { gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL); - se->expr = gfc_build_addr_expr (NULL, se->expr); + se->expr = build_fold_addr_expr (se->expr); } return; } @@ -362,33 +454,40 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) separately. */ if (sym->ts.type == BT_CHARACTER) { - /* Dereference character pointer dummy arguments + /* Dereference character pointer dummy arguments or results. */ if ((sym->attr.pointer || sym->attr.allocatable) - && ((sym->attr.dummy) - || (sym->attr.function - || sym->attr.result))) - se->expr = gfc_build_indirect_ref (se->expr); + && (sym->attr.dummy + || sym->attr.function + || sym->attr.result)) + se->expr = build_fold_indirect_ref (se->expr); + + /* A character with VALUE attribute needs an address + expression. */ + if (sym->attr.value) + se->expr = build_fold_addr_expr (se->expr); + } - else + else if (!sym->attr.value) { - /* Dereference non-charcter scalar dummy arguments. */ - if ((sym->attr.dummy) && (!sym->attr.dimension)) - se->expr = gfc_build_indirect_ref (se->expr); + /* Dereference non-character scalar dummy arguments. */ + if (sym->attr.dummy && !sym->attr.dimension) + se->expr = build_fold_indirect_ref (se->expr); /* Dereference scalar hidden result. */ - if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX) + if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX && (sym->attr.function || sym->attr.result) - && (!sym->attr.dimension)) - se->expr = gfc_build_indirect_ref (se->expr); + && !sym->attr.dimension && !sym->attr.pointer) + se->expr = build_fold_indirect_ref (se->expr); /* Dereference non-character pointer variables. - These must be dummys or results or scalars. */ + These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable) - && ((sym->attr.dummy) - || (sym->attr.function || sym->attr.result) - || (!sym->attr.dimension))) - se->expr = gfc_build_indirect_ref (se->expr); + && (sym->attr.dummy + || sym->attr.function + || sym->attr.result + || !sym->attr.dimension)) + se->expr = build_fold_indirect_ref (se->expr); } ref = expr->ref; @@ -397,7 +496,12 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* For character variables, also get the length. */ if (sym->ts.type == BT_CHARACTER) { - se->string_length = sym->ts.cl->backend_decl; + /* If the character length of an entry isn't set, get the length from + the master function instead. */ + if (sym->attr.entry && !sym->ts.cl->backend_decl) + se->string_length = sym->ns->proc_name->ts.cl->backend_decl; + else + se->string_length = sym->ts.cl->backend_decl; gcc_assert (se->string_length); } @@ -416,7 +520,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && ref->next == NULL && (se->descriptor_only)) return; - gfc_conv_array_ref (se, &ref->u.ar); + gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where); /* Return a pointer to an element. */ break; @@ -425,7 +529,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_SUBSTRING: - gfc_conv_substring (se, ref, expr->ts.kind); + gfc_conv_substring (se, ref, expr->ts.kind, + expr->symtree->name, &expr->where); break; default: @@ -441,10 +546,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) if (expr->ts.type == BT_CHARACTER) gfc_conv_string_parameter (se); else - se->expr = gfc_build_addr_expr (NULL, se->expr); + se->expr = build_fold_addr_expr (se->expr); } - if (se->ss != NULL) - gfc_advance_se_ss_chain (se); } @@ -469,7 +572,7 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) All other unary operators have an equivalent GIMPLE unary operator. */ if (code == TRUTH_NOT_EXPR) se->expr = build2 (EQ_EXPR, type, operand.expr, - convert (type, integer_zero_node)); + build_int_cst (type, 0)); else se->expr = build1 (code, type, operand.expr); @@ -599,28 +702,24 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE)) { tmp = build2 (EQ_EXPR, boolean_type_node, lhs, - fold_convert (TREE_TYPE (lhs), integer_minus_one_node)); + build_int_cst (TREE_TYPE (lhs), -1)); cond = build2 (EQ_EXPR, boolean_type_node, lhs, - convert (TREE_TYPE (lhs), integer_one_node)); + build_int_cst (TREE_TYPE (lhs), 1)); /* If rhs is even, result = (lhs == 1 || lhs == -1) ? 1 : 0. */ if ((n & 1) == 0) { tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond); - se->expr = build3 (COND_EXPR, type, tmp, - convert (type, integer_one_node), - convert (type, integer_zero_node)); + se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1), + build_int_cst (type, 0)); return 1; } /* If rhs is odd, result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */ - tmp = build3 (COND_EXPR, type, tmp, - convert (type, integer_minus_one_node), - convert (type, integer_zero_node)); - se->expr = build3 (COND_EXPR, type, cond, - convert (type, integer_one_node), - tmp); + tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1), + build_int_cst (type, 0)); + se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp); return 1; } @@ -649,10 +748,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) gfc_se lse; gfc_se rse; tree fndecl; - tree tmp; gfc_init_se (&lse, se); gfc_conv_expr_val (&lse, expr->value.op.op1); + lse.expr = gfc_evaluate_now (lse.expr, &lse.pre); gfc_add_block_to_block (&se->pre, &lse.pre); gfc_init_se (&rse, se); @@ -686,6 +785,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) ikind = 1; break; + case 16: + ikind = 2; + break; + default: gcc_unreachable (); } @@ -707,6 +810,14 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) kind = 1; break; + case 10: + kind = 2; + break; + + case 16: + kind = 3; + break; + default: gcc_unreachable (); } @@ -714,6 +825,8 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) switch (expr->value.op.op1->ts.type) { case BT_INTEGER: + if (kind == 3) /* Case 16 was not handled properly above. */ + kind = 2; fndecl = gfor_fndecl_math_powi[kind][ikind].integer; break; @@ -739,6 +852,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 8: fndecl = built_in_decls[BUILT_IN_POW]; break; + case 10: + case 16: + fndecl = built_in_decls[BUILT_IN_POWL]; + break; default: gcc_unreachable (); } @@ -753,6 +870,12 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 8: fndecl = gfor_fndecl_math_cpow; break; + case 10: + fndecl = gfor_fndecl_math_cpowl10; + break; + case 16: + fndecl = gfor_fndecl_math_cpowl16; + break; default: gcc_unreachable (); } @@ -763,9 +886,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; } - tmp = gfc_chainon_list (NULL_TREE, lse.expr); - tmp = gfc_chainon_list (tmp, rse.expr); - se->expr = fold (gfc_build_function_call (fndecl, tmp)); + se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr); } @@ -776,7 +897,6 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { tree var; tree tmp; - tree args; gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node); @@ -784,7 +904,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { /* Create a temporary variable to hold the result. */ tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, - convert (gfc_charlen_type_node, integer_one_node)); + build_int_cst (gfc_charlen_type_node, 1)); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); tmp = build_array_type (gfc_character1_type_node, tmp); var = gfc_create_var (tmp, "str"); @@ -794,15 +914,13 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { /* Allocate a temporary to hold the result. */ var = gfc_create_var (type, "pstr"); - args = gfc_chainon_list (NULL_TREE, len); - tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args); + tmp = build_call_expr (gfor_fndecl_internal_malloc, 1, len); tmp = convert (type, tmp); gfc_add_modify_expr (&se->pre, var, tmp); /* Free the temporary afterwards. */ tmp = convert (pvoid_type_node, var); - args = gfc_chainon_list (NULL_TREE, tmp); - tmp = gfc_build_function_call (gfor_fndecl_internal_free, args); + tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp); gfc_add_expr_to_block (&se->post, tmp); } @@ -821,7 +939,6 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) tree len; tree type; tree var; - tree args; tree tmp; gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER @@ -850,14 +967,10 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) var = gfc_conv_string_tmp (se, type, len); /* Do the actual concatenation. */ - args = NULL_TREE; - args = gfc_chainon_list (args, len); - args = gfc_chainon_list (args, var); - args = gfc_chainon_list (args, lse.string_length); - args = gfc_chainon_list (args, lse.expr); - args = gfc_chainon_list (args, rse.string_length); - args = gfc_chainon_list (args, rse.expr); - tmp = gfc_build_function_call (gfor_fndecl_concat_string, args); + tmp = build_call_expr (gfor_fndecl_concat_string, 6, + len, var, + lse.string_length, lse.expr, + rse.string_length, rse.expr); gfc_add_expr_to_block (&se->pre, tmp); /* Add the cleanup for the operands. */ @@ -868,7 +981,6 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) se->string_length = len; } - /* Translates an op expression. Common (binary) cases are handled by this function, others are passed on. Recursion is used in either case. We use the fact that (op1.ts == op2.ts) (except for the power @@ -893,6 +1005,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) switch (expr->value.op.operator) { case INTRINSIC_UPLUS: + case INTRINSIC_PARENTHESES: gfc_conv_expr (se, expr->value.op.op1); return; @@ -1010,23 +1123,15 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) gfc_conv_expr (&rse, expr->value.op.op2); gfc_add_block_to_block (&se->pre, &rse.pre); - /* For string comparisons we generate a library call, and compare the return - value with 0. */ if (checkstring) { gfc_conv_string_parameter (&lse); gfc_conv_string_parameter (&rse); - tmp = NULL_TREE; - tmp = gfc_chainon_list (tmp, lse.string_length); - tmp = gfc_chainon_list (tmp, lse.expr); - tmp = gfc_chainon_list (tmp, rse.string_length); - tmp = gfc_chainon_list (tmp, rse.expr); - - /* Build a call for the comparison. */ - lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp); - gfc_add_block_to_block (&lse.post, &rse.post); + lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, + rse.string_length, rse.expr); rse.expr = integer_zero_node; + gfc_add_block_to_block (&lse.post, &rse.post); } type = gfc_typenode_for_spec (&expr->ts); @@ -1045,6 +1150,55 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->post, &lse.post); } +/* If a string's length is one, we convert it to a single character. */ + +static tree +gfc_to_single_character (tree len, tree str) +{ + gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); + + if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1 + && TREE_INT_CST_HIGH (len) == 0) + { + str = fold_convert (pchar_type_node, str); + return build_fold_indirect_ref (str); + } + + return NULL_TREE; +} + +/* Compare two strings. If they are all single characters, the result is the + subtraction of them. Otherwise, we build a library call. */ + +tree +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) +{ + tree sc1; + tree sc2; + tree type; + tree tmp; + + gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); + + type = gfc_get_int_type (gfc_default_integer_kind); + + sc1 = gfc_to_single_character (len1, str1); + sc2 = gfc_to_single_character (len2, str2); + + /* Deal with single character specially. */ + if (sc1 != NULL_TREE && sc2 != NULL_TREE) + { + sc1 = fold_convert (type, sc1); + sc2 = fold_convert (type, sc2); + tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2); + } + else + /* Build a call for the comparison. */ + tmp = build_call_expr (gfor_fndecl_compare_string, 4, + len1, str1, len2, str2); + return tmp; +} static void gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) @@ -1056,8 +1210,6 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) tmp = gfc_get_symbol_decl (sym); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); - - se->expr = tmp; } else { @@ -1065,264 +1217,1185 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) sym->backend_decl = gfc_get_extern_function_decl (sym); tmp = sym->backend_decl; - gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); - se->expr = gfc_build_addr_expr (NULL, tmp); + if (sym->attr.cray_pointee) + tmp = convert (build_pointer_type (TREE_TYPE (tmp)), + gfc_get_symbol_decl (sym->cp_pointer)); + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = build_fold_addr_expr (tmp); + } } + se->expr = tmp; } -/* Generate code for a procedure call. Note can return se->post != NULL. - If se->direct_byref is set then se->expr contains the return parameter. */ +/* Translate the call for an elemental subroutine call used in an operator + assignment. This is a simplified version of gfc_conv_function_call. */ -void -gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, - gfc_actual_arglist * arg) +tree +gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym) { - tree arglist; + tree args; tree tmp; - tree fntype; - gfc_se parmse; - gfc_ss *argss; - gfc_ss_info *info; - int byref; - tree type; - tree var; - tree len; - tree stringargs; - gfc_formal_arglist *formal; + gfc_se se; + stmtblock_t block; - arglist = NULL_TREE; - stringargs = NULL_TREE; - var = NULL_TREE; - len = NULL_TREE; + /* Only elemental subroutines with two arguments. */ + gcc_assert (sym->attr.elemental && sym->attr.subroutine); + gcc_assert (sym->formal->next->next == NULL); - /* Obtain the string length now because it is needed often below. */ - if (sym->ts.type == BT_CHARACTER) + gfc_init_block (&block); + + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + /* Build the argument list for the call, including hidden string lengths. */ + args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr)); + args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr)); + if (lse->string_length != NULL_TREE) + args = gfc_chainon_list (args, lse->string_length); + if (rse->string_length != NULL_TREE) + args = gfc_chainon_list (args, rse->string_length); + + /* Build the function call. */ + gfc_init_se (&se, NULL); + gfc_conv_function_val (&se, sym); + tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr))); + tmp = build_call_list (tmp, se.expr, args); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &lse->post); + gfc_add_block_to_block (&block, &rse->post); + + return gfc_finish_block (&block); +} + + +/* Initialize MAPPING. */ + +void +gfc_init_interface_mapping (gfc_interface_mapping * mapping) +{ + mapping->syms = NULL; + mapping->charlens = NULL; +} + + +/* Free all memory held by MAPPING (but not MAPPING itself). */ + +void +gfc_free_interface_mapping (gfc_interface_mapping * mapping) +{ + gfc_interface_sym_mapping *sym; + gfc_interface_sym_mapping *nextsym; + gfc_charlen *cl; + gfc_charlen *nextcl; + + for (sym = mapping->syms; sym; sym = nextsym) { - gcc_assert (sym->ts.cl && sym->ts.cl->length - && sym->ts.cl->length->expr_type == EXPR_CONSTANT); - len = gfc_conv_mpz_to_tree - (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind); + nextsym = sym->next; + gfc_free_symbol (sym->new->n.sym); + gfc_free (sym->new); + gfc_free (sym); } - - if (se->ss != NULL) + for (cl = mapping->charlens; cl; cl = nextcl) { - if (!sym->attr.elemental) - { - gcc_assert (se->ss->type == GFC_SS_FUNCTION); - if (se->ss->useflags) - { - gcc_assert (gfc_return_by_reference (sym) - && sym->result->attr.dimension); - gcc_assert (se->loop != NULL); + nextcl = cl->next; + gfc_free_expr (cl->length); + gfc_free (cl); + } +} - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); - /* Bundle in the string length. */ - se->string_length=len; - return; - } - } - info = &se->ss->data.info; - } - else - info = NULL; +/* Return a copy of gfc_charlen CL. Add the returned structure to + MAPPING so that it will be freed by gfc_free_interface_mapping. */ - byref = gfc_return_by_reference (sym); - if (byref) - { - if (se->direct_byref) - { - arglist = gfc_chainon_list (arglist, se->expr); +static gfc_charlen * +gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping, + gfc_charlen * cl) +{ + gfc_charlen *new; - /* Add string length to argument list. */ - if (sym->ts.type == BT_CHARACTER) - { - sym->ts.cl->backend_decl = len; - arglist = gfc_chainon_list (arglist, - convert (gfc_charlen_type_node, len)); - } - } - else if (sym->result->attr.dimension) - { - gcc_assert (se->loop && se->ss); + new = gfc_get_charlen (); + new->next = mapping->charlens; + new->length = gfc_copy_expr (cl->length); - /* Set the type of the array. */ - tmp = gfc_typenode_for_spec (&sym->ts); - info->dimen = se->loop->dimen; + mapping->charlens = new; + return new; +} - /* Allocate a temporary to store the result. */ - gfc_trans_allocate_temp_array (se->loop, info, tmp); - /* Zero the first stride to indicate a temporary. */ - tmp = - gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]); - gfc_add_modify_expr (&se->pre, tmp, - convert (TREE_TYPE (tmp), integer_zero_node)); +/* A subroutine of gfc_add_interface_mapping. Return a descriptorless + array variable that can be used as the actual argument for dummy + argument SYM. Add any initialization code to BLOCK. PACKED is as + for gfc_get_nodesc_array_type and DATA points to the first element + in the passed array. */ - /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL, tmp); - arglist = gfc_chainon_list (arglist, tmp); +static tree +gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym, + int packed, tree data) +{ + tree type; + tree var; - /* Add string length to argument list. */ - if (sym->ts.type == BT_CHARACTER) - { - sym->ts.cl->backend_decl = len; - arglist = gfc_chainon_list (arglist, - convert (gfc_charlen_type_node, len)); - } + type = gfc_typenode_for_spec (&sym->ts); + type = gfc_get_nodesc_array_type (type, sym->as, packed); - } - else if (sym->ts.type == BT_CHARACTER) - { + var = gfc_create_var (type, "ifm"); + gfc_add_modify_expr (block, var, fold_convert (type, data)); - /* Pass the string length. */ - sym->ts.cl->backend_decl = len; - type = gfc_get_character_type (sym->ts.kind, sym->ts.cl); - type = build_pointer_type (type); + return var; +} - /* Return an address to a char[4]* temporary for character pointers. */ - if (sym->attr.pointer || sym->attr.allocatable) - { - /* Build char[4] * pstr. */ - tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, - convert (gfc_charlen_type_node, integer_one_node)); - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); - tmp = build_array_type (gfc_character1_type_node, tmp); - var = gfc_create_var (build_pointer_type (tmp), "pstr"); - /* Provide an address expression for the function arguments. */ - var = gfc_build_addr_expr (NULL, var); - } - else - { - var = gfc_conv_string_tmp (se, type, len); - } - arglist = gfc_chainon_list (arglist, var); - arglist = gfc_chainon_list (arglist, - convert (gfc_charlen_type_node, len)); +/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds + and offset of descriptorless array type TYPE given that it has the same + size as DESC. Add any set-up code to BLOCK. */ + +static void +gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) +{ + int n; + tree dim; + tree offset; + tree tmp; + + offset = gfc_index_zero_node; + for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++) + { + dim = gfc_rank_cst[n]; + GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n); + if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE) + { + GFC_TYPE_ARRAY_LBOUND (type, n) + = gfc_conv_descriptor_lbound (desc, dim); + GFC_TYPE_ARRAY_UBOUND (type, n) + = gfc_conv_descriptor_ubound (desc, dim); } - else + else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) { - gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX); - - type = gfc_get_complex_type (sym->ts.kind); - var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx")); - arglist = gfc_chainon_list (arglist, var); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound (desc, dim), + gfc_conv_descriptor_lbound (desc, dim)); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, n), + tmp); + tmp = gfc_evaluate_now (tmp, block); + GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; } + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, n), + GFC_TYPE_ARRAY_STRIDE (type, n)); + offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp); } + offset = gfc_evaluate_now (offset, block); + GFC_TYPE_ARRAY_OFFSET (type) = offset; +} - formal = sym->formal; - /* Evaluate the arguments. */ - for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + +/* Extend MAPPING so that it maps dummy argument SYM to the value stored + in SE. The caller may still use se->expr and se->string_length after + calling this function. */ + +void +gfc_add_interface_mapping (gfc_interface_mapping * mapping, + gfc_symbol * sym, gfc_se * se) +{ + gfc_interface_sym_mapping *sm; + tree desc; + tree tmp; + tree value; + gfc_symbol *new_sym; + gfc_symtree *root; + gfc_symtree *new_symtree; + + /* Create a new symbol to represent the actual argument. */ + new_sym = gfc_new_symbol (sym->name, NULL); + new_sym->ts = sym->ts; + new_sym->attr.referenced = 1; + new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.pointer = sym->attr.pointer; + new_sym->attr.allocatable = sym->attr.allocatable; + new_sym->attr.flavor = sym->attr.flavor; + + /* Create a fake symtree for it. */ + root = NULL; + new_symtree = gfc_new_symtree (&root, sym->name); + new_symtree->n.sym = new_sym; + gcc_assert (new_symtree == root); + + /* Create a dummy->actual mapping. */ + sm = gfc_getmem (sizeof (*sm)); + sm->next = mapping->syms; + sm->old = sym; + sm->new = new_symtree; + mapping->syms = sm; + + /* Stabilize the argument's value. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); + + if (sym->ts.type == BT_CHARACTER) { - if (arg->expr == NULL) - { + /* Create a copy of the dummy argument's length. */ + new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl); - if (se->ignore_optional) - { - /* Some intrinsics have already been resolved to the correct - parameters. */ - continue; - } - else if (arg->label) - { - has_alternate_specifier = 1; - continue; - } - else - { - /* Pass a NULL pointer for an absent arg. */ - gfc_init_se (&parmse, NULL); - parmse.expr = null_pointer_node; - if (arg->missing_arg_type == BT_CHARACTER) - { - stringargs = - gfc_chainon_list (stringargs, - convert (gfc_charlen_type_node, - integer_zero_node)); - } - } - } - else if (se->ss && se->ss->useflags) + /* If the length is specified as "*", record the length that + the caller is passing. We should use the callee's length + in all other cases. */ + if (!new_sym->ts.cl->length) { - /* An elemental function inside a scalarized loop. */ - gfc_init_se (&parmse, se); - gfc_conv_expr_reference (&parmse, arg->expr); + se->string_length = gfc_evaluate_now (se->string_length, &se->pre); + new_sym->ts.cl->backend_decl = se->string_length; } + } + + /* Use the passed value as-is if the argument is a function. */ + if (sym->attr.flavor == FL_PROCEDURE) + value = se->expr; + + /* If the argument is either a string or a pointer to a string, + convert it to a boundless character type. */ + else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER) + { + tmp = gfc_get_character_type_len (sym->ts.kind, NULL); + tmp = build_pointer_type (tmp); + if (sym->attr.pointer) + value = build_fold_indirect_ref (se->expr); else + value = se->expr; + value = fold_convert (tmp, value); + } + + /* If the argument is a scalar, a pointer to an array or an allocatable, + dereference it. */ + else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) + value = build_fold_indirect_ref (se->expr); + + /* For character(*), use the actual argument's descriptor. */ + else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length) + value = build_fold_indirect_ref (se->expr); + + /* If the argument is an array descriptor, use it to determine + information about the actual argument's shape. */ + else if (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) + { + /* Get the actual argument's descriptor. */ + desc = build_fold_indirect_ref (se->expr); + + /* Create the replacement variable. */ + tmp = gfc_conv_descriptor_data_get (desc); + value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp); + + /* Use DESC to work out the upper bounds, strides and offset. */ + gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc); + } + else + /* Otherwise we have a packed array. */ + value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr); + + new_sym->backend_decl = value; +} + + +/* Called once all dummy argument mappings have been added to MAPPING, + but before the mapping is used to evaluate expressions. Pre-evaluate + the length of each argument, adding any initialization code to PRE and + any finalization code to POST. */ + +void +gfc_finish_interface_mapping (gfc_interface_mapping * mapping, + stmtblock_t * pre, stmtblock_t * post) +{ + gfc_interface_sym_mapping *sym; + gfc_expr *expr; + gfc_se se; + + for (sym = mapping->syms; sym; sym = sym->next) + if (sym->new->n.sym->ts.type == BT_CHARACTER + && !sym->new->n.sym->ts.cl->backend_decl) + { + expr = sym->new->n.sym->ts.cl->length; + gfc_apply_interface_mapping_to_expr (mapping, expr); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + + se.expr = gfc_evaluate_now (se.expr, &se.pre); + gfc_add_block_to_block (pre, &se.pre); + gfc_add_block_to_block (post, &se.post); + + sym->new->n.sym->ts.cl->backend_decl = se.expr; + } +} + + +/* Like gfc_apply_interface_mapping_to_expr, but applied to + constructor C. */ + +static void +gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping, + gfc_constructor * c) +{ + for (; c; c = c->next) + { + gfc_apply_interface_mapping_to_expr (mapping, c->expr); + if (c->iterator) { - /* A scalar or transformational function. */ - gfc_init_se (&parmse, NULL); - argss = gfc_walk_expr (arg->expr); + gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start); + gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end); + gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step); + } + } +} - if (argss == gfc_ss_terminator) - { - gfc_conv_expr_reference (&parmse, arg->expr); - if (formal && formal->sym->attr.pointer - && arg->expr->expr_type != EXPR_NULL) - { - /* Scalar pointer dummy args require an extra level of - indirection. The null pointer already contains - this level of indirection. */ - parmse.expr = gfc_build_addr_expr (NULL, parmse.expr); - } + +/* Like gfc_apply_interface_mapping_to_expr, but applied to + reference REF. */ + +static void +gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, + gfc_ref * ref) +{ + int n; + + for (; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + for (n = 0; n < ref->u.ar.dimen; n++) + { + gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]); + gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]); + gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]); + } + gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset); + break; + + case REF_COMPONENT: + break; + + case REF_SUBSTRING: + gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start); + gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end); + break; + } +} + + +/* EXPR is a copy of an expression that appeared in the interface + associated with MAPPING. Walk it recursively looking for references to + dummy arguments that MAPPING maps to actual arguments. Replace each such + reference with a reference to the associated actual argument. */ + +static void +gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, + gfc_expr * expr) +{ + gfc_interface_sym_mapping *sym; + gfc_actual_arglist *actual; + + if (!expr) + return; + + /* Copying an expression does not copy its length, so do that here. */ + if (expr->ts.type == BT_CHARACTER && expr->ts.cl) + { + expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl); + gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length); + } + + /* Apply the mapping to any references. */ + gfc_apply_interface_mapping_to_ref (mapping, expr->ref); + + /* ...and to the expression's symbol, if it has one. */ + if (expr->symtree) + for (sym = mapping->syms; sym; sym = sym->next) + if (sym->old == expr->symtree->n.sym) + expr->symtree = sym->new; + + /* ...and to subexpressions in expr->value. */ + switch (expr->expr_type) + { + case EXPR_VARIABLE: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_SUBSTRING: + break; + + case EXPR_OP: + gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1); + gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2); + break; + + case EXPR_FUNCTION: + for (sym = mapping->syms; sym; sym = sym->next) + if (sym->old == expr->value.function.esym) + expr->value.function.esym = sym->new->n.sym; + + for (actual = expr->value.function.actual; actual; actual = actual->next) + gfc_apply_interface_mapping_to_expr (mapping, actual->expr); + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor); + break; + } +} + + +/* Evaluate interface expression EXPR using MAPPING. Store the result + in SE. */ + +void +gfc_apply_interface_mapping (gfc_interface_mapping * mapping, + gfc_se * se, gfc_expr * expr) +{ + expr = gfc_copy_expr (expr); + gfc_apply_interface_mapping_to_expr (mapping, expr); + gfc_conv_expr (se, expr); + se->expr = gfc_evaluate_now (se->expr, &se->pre); + gfc_free_expr (expr); +} + +/* Returns a reference to a temporary array into which a component of + an actual argument derived type array is copied and then returned + after the function call. + TODO Get rid of this kludge, when array descriptors are capable of + handling arrays with a bigger stride in bytes than size. */ + +void +gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, + int g77, sym_intent intent) +{ + gfc_se lse; + gfc_se rse; + gfc_ss *lss; + gfc_ss *rss; + gfc_loopinfo loop; + gfc_loopinfo loop2; + gfc_ss_info *info; + tree offset; + tree tmp_index; + tree tmp; + tree base_type; + stmtblock_t body; + int n; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + /* Walk the argument expression. */ + rss = gfc_walk_expr (expr); + + gcc_assert (rss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, rss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop); + + /* Build an ss for the temporary. */ + base_type = gfc_typenode_for_spec (&expr->ts); + if (GFC_ARRAY_TYPE_P (base_type) + || GFC_DESCRIPTOR_TYPE_P (base_type)) + base_type = gfc_get_element_type (base_type); + + loop.temp_ss = gfc_get_ss ();; + loop.temp_ss->type = GFC_SS_TEMP; + loop.temp_ss->data.temp.type = base_type; + + if (expr->ts.type == BT_CHARACTER) + { + gfc_ref *char_ref = expr->ref; + + for (; char_ref; char_ref = char_ref->next) + if (char_ref->type == REF_SUBSTRING) + { + gfc_se tmp_se; + + expr->ts.cl = gfc_get_charlen (); + expr->ts.cl->next = char_ref->u.ss.length->next; + char_ref->u.ss.length->next = expr->ts.cl; + + gfc_init_se (&tmp_se, NULL); + gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end, + gfc_array_index_type); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp_se.expr, gfc_index_one_node); + tmp = gfc_evaluate_now (tmp, &parmse->pre); + gfc_init_se (&tmp_se, NULL); + gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start, + gfc_array_index_type); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp, tmp_se.expr); + expr->ts.cl->backend_decl = tmp; + + break; + } + loop.temp_ss->data.temp.type + = gfc_typenode_for_spec (&expr->ts); + loop.temp_ss->string_length = expr->ts.cl->backend_decl; + } + + loop.temp_ss->data.temp.dimen = loop.dimen; + loop.temp_ss->next = gfc_ss_terminator; + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, loop.temp_ss); + + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop); + + /* Pass the temporary descriptor back to the caller. */ + info = &loop.temp_ss->data.info; + parmse->expr = info->descriptor; + + /* Setup the gfc_se structures. */ + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_copy_loopinfo_to_se (&rse, &loop); + + rse.ss = rss; + lse.ss = loop.temp_ss; + gfc_mark_ss_chain_used (rss, 1); + gfc_mark_ss_chain_used (loop.temp_ss, 1); + + /* Start the scalarized loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* Translate the expression. */ + gfc_conv_expr (&rse, expr); + + gfc_conv_tmp_array_ref (&lse); + gfc_advance_se_ss_chain (&lse); + + if (intent != INTENT_OUT) + { + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false); + gfc_add_expr_to_block (&body, tmp); + gcc_assert (rse.ss == gfc_ss_terminator); + gfc_trans_scalarizing_loops (&loop, &body); + } + else + { + /* Make sure that the temporary declaration survives by merging + all the loop declarations into the current context. */ + for (n = 0; n < loop.dimen; n++) + { + gfc_merge_block_scope (&body); + body = loop.code[loop.order[n]]; + } + gfc_merge_block_scope (&body); + } + + /* Add the post block after the second loop, so that any + freeing of allocated memory is done at the right time. */ + gfc_add_block_to_block (&parmse->pre, &loop.pre); + + /**********Copy the temporary back again.*********/ + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + /* Walk the argument expression. */ + lss = gfc_walk_expr (expr); + rse.ss = loop.temp_ss; + lse.ss = lss; + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop2); + gfc_add_ss_to_loop (&loop2, lss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop2); + + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop2); + + gfc_copy_loopinfo_to_se (&lse, &loop2); + gfc_copy_loopinfo_to_se (&rse, &loop2); + + gfc_mark_ss_chain_used (lss, 1); + gfc_mark_ss_chain_used (loop.temp_ss, 1); + + /* Declare the variable to hold the temporary offset and start the + scalarized loop body. */ + offset = gfc_create_var (gfc_array_index_type, NULL); + gfc_start_scalarized_body (&loop2, &body); + + /* Build the offsets for the temporary from the loop variables. The + temporary array has lbounds of zero and strides of one in all + dimensions, so this is very simple. The offset is only computed + outside the innermost loop, so the overall transfer could be + optimized further. */ + info = &rse.ss->data.info; + + tmp_index = gfc_index_zero_node; + for (n = info->dimen - 1; n > 0; n--) + { + tree tmp_str; + tmp = rse.loop->loopvar[n]; + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp, rse.loop->from[n]); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp, tmp_index); + + tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type, + rse.loop->to[n-1], rse.loop->from[n-1]); + tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp_str, gfc_index_one_node); + + tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type, + tmp, tmp_str); + } + + tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp_index, rse.loop->from[0]); + gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index); + + tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type, + rse.loop->loopvar[0], offset); + + /* Now use the offset for the reference. */ + tmp = build_fold_indirect_ref (info->data); + rse.expr = gfc_build_array_ref (tmp, tmp_index); + + if (expr->ts.type == BT_CHARACTER) + rse.string_length = expr->ts.cl->backend_decl; + + gfc_conv_expr (&lse, expr); + + gcc_assert (lse.ss == gfc_ss_terminator); + + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); + gfc_add_expr_to_block (&body, tmp); + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop2, &body); + + /* Wrap the whole thing up by adding the second loop to the post-block + and following it by the post-block of the first loop. In this way, + if the temporary needs freeing, it is done after use! */ + if (intent != INTENT_IN) + { + gfc_add_block_to_block (&parmse->post, &loop2.pre); + gfc_add_block_to_block (&parmse->post, &loop2.post); + } + + gfc_add_block_to_block (&parmse->post, &loop.post); + + gfc_cleanup_loop (&loop); + gfc_cleanup_loop (&loop2); + + /* Pass the string length to the argument expression. */ + if (expr->ts.type == BT_CHARACTER) + parmse->string_length = expr->ts.cl->backend_decl; + + /* We want either the address for the data or the address of the descriptor, + depending on the mode of passing array arguments. */ + if (g77) + parmse->expr = gfc_conv_descriptor_data_get (parmse->expr); + else + parmse->expr = build_fold_addr_expr (parmse->expr); + + return; +} + +/* Is true if an array reference is followed by a component or substring + reference. */ + +bool +is_aliased_array (gfc_expr * e) +{ + gfc_ref * ref; + bool seen_array; + + seen_array = false; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT) + seen_array = true; + + if (seen_array + && ref->type != REF_ARRAY) + return seen_array; + } + return false; +} + +/* Generate the code for argument list functions. */ + +static void +conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) +{ + tree type = NULL_TREE; + /* Pass by value for g77 %VAL(arg), pass the address + indirectly for %LOC, else by reference. Thus %REF + is a "do-nothing" and %LOC is the same as an F95 + pointer. */ + if (strncmp (name, "%VAL", 4) == 0) + { + gfc_conv_expr (se, expr); + /* %VAL converts argument to default kind. */ + switch (expr->ts.type) + { + case BT_REAL: + type = gfc_get_real_type (gfc_default_real_kind); + se->expr = fold_convert (type, se->expr); + break; + case BT_COMPLEX: + type = gfc_get_complex_type (gfc_default_complex_kind); + se->expr = fold_convert (type, se->expr); + break; + case BT_INTEGER: + type = gfc_get_int_type (gfc_default_integer_kind); + se->expr = fold_convert (type, se->expr); + break; + case BT_LOGICAL: + type = gfc_get_logical_type (gfc_default_logical_kind); + se->expr = fold_convert (type, se->expr); + break; + /* This should have been resolved away. */ + case BT_UNKNOWN: case BT_CHARACTER: case BT_DERIVED: + case BT_PROCEDURE: case BT_HOLLERITH: + gfc_internal_error ("Bad type in conv_arglist_function"); + } + + } + else if (strncmp (name, "%LOC", 4) == 0) + { + gfc_conv_expr_reference (se, expr); + se->expr = gfc_build_addr_expr (NULL, se->expr); + } + else if (strncmp (name, "%REF", 4) == 0) + gfc_conv_expr_reference (se, expr); + else + gfc_error ("Unknown argument list function at %L", &expr->where); +} + + +/* Generate code for a procedure call. Note can return se->post != NULL. + If se->direct_byref is set then se->expr contains the return parameter. + Return nonzero, if the call has alternate specifiers. */ + +int +gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, + gfc_actual_arglist * arg, tree append_args) +{ + gfc_interface_mapping mapping; + tree arglist; + tree retargs; + tree tmp; + tree fntype; + gfc_se parmse; + gfc_ss *argss; + gfc_ss_info *info; + int byref; + int parm_kind; + tree type; + tree var; + tree len; + tree stringargs; + gfc_formal_arglist *formal; + int has_alternate_specifier = 0; + bool need_interface_mapping; + bool callee_alloc; + gfc_typespec ts; + gfc_charlen cl; + gfc_expr *e; + gfc_symbol *fsym; + stmtblock_t post; + enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; + + arglist = NULL_TREE; + retargs = NULL_TREE; + stringargs = NULL_TREE; + var = NULL_TREE; + len = NULL_TREE; + + if (se->ss != NULL) + { + if (!sym->attr.elemental) + { + gcc_assert (se->ss->type == GFC_SS_FUNCTION); + if (se->ss->useflags) + { + gcc_assert (gfc_return_by_reference (sym) + && sym->result->attr.dimension); + gcc_assert (se->loop != NULL); + + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); + return 0; } + } + info = &se->ss->data.info; + } + else + info = NULL; + + gfc_init_block (&post); + gfc_init_interface_mapping (&mapping); + need_interface_mapping = ((sym->ts.type == BT_CHARACTER + && sym->ts.cl->length + && sym->ts.cl->length->expr_type + != EXPR_CONSTANT) + || sym->attr.dimension); + formal = sym->formal; + /* Evaluate the arguments. */ + for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + { + e = arg->expr; + fsym = formal ? formal->sym : NULL; + parm_kind = MISSING; + if (e == NULL) + { + + if (se->ignore_optional) + { + /* Some intrinsics have already been resolved to the correct + parameters. */ + continue; + } + else if (arg->label) + { + has_alternate_specifier = 1; + continue; + } + else + { + /* Pass a NULL pointer for an absent arg. */ + gfc_init_se (&parmse, NULL); + parmse.expr = null_pointer_node; + if (arg->missing_arg_type == BT_CHARACTER) + parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); + } + } + else if (se->ss && se->ss->useflags) + { + /* An elemental function inside a scalarized loop. */ + gfc_init_se (&parmse, se); + gfc_conv_expr_reference (&parmse, e); + parm_kind = ELEMENTAL; + } + else + { + /* A scalar or transformational function. */ + gfc_init_se (&parmse, NULL); + argss = gfc_walk_expr (e); + + if (argss == gfc_ss_terminator) + { + parm_kind = SCALAR; + if (fsym && fsym->attr.value) + { + gfc_conv_expr (&parmse, e); + } + else if (arg->name && arg->name[0] == '%') + /* Argument list functions %VAL, %LOC and %REF are signalled + through arg->name. */ + conv_arglist_function (&parmse, arg->expr, arg->name); + else + { + gfc_conv_expr_reference (&parmse, e); + if (fsym && fsym->attr.pointer + && e->expr_type != EXPR_NULL) + { + /* Scalar pointer dummy args require an extra level of + indirection. The null pointer already contains + this level of indirection. */ + parm_kind = SCALAR_POINTER; + parmse.expr = build_fold_addr_expr (parmse.expr); + } + } + } else { - /* If the procedure requires an explicit interface, the - actual argument is passed according to the - corresponding formal argument. If the corresponding - formal argument is a POINTER or assumed shape, we do - not use g77's calling convention, and pass the - address of the array descriptor instead. Otherwise we - use g77's calling convention. */ + /* If the procedure requires an explicit interface, the actual + argument is passed according to the corresponding formal + argument. If the corresponding formal argument is a POINTER, + ALLOCATABLE or assumed shape, we do not use g77's calling + convention, and pass the address of the array descriptor + instead. Otherwise we use g77's calling convention. */ int f; - f = (formal != NULL) - && !formal->sym->attr.pointer - && formal->sym->as->type != AS_ASSUMED_SHAPE; + f = (fsym != NULL) + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - gfc_conv_array_parameter (&parmse, arg->expr, argss, f); + + if (e->expr_type == EXPR_VARIABLE + && is_aliased_array (e)) + /* The actual argument is a component reference to an + array of derived types. In this case, the argument + is converted to a temporary, which is passed and then + written back after the procedure call. */ + gfc_conv_aliased_arg (&parmse, e, f, + fsym ? fsym->attr.intent : INTENT_INOUT); + else + gfc_conv_array_parameter (&parmse, e, argss, f); + + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + allocated on entry, it must be deallocated. */ + if (fsym && fsym->attr.allocatable + && fsym->attr.intent == INTENT_OUT) + { + tmp = build_fold_indirect_ref (parmse.expr); + tmp = gfc_trans_dealloc_allocated (tmp); + gfc_add_expr_to_block (&se->pre, tmp); + } + } } - gfc_add_block_to_block (&se->pre, &parmse.pre); - gfc_add_block_to_block (&se->post, &parmse.post); + if (fsym) + { + if (e) + { + /* If an optional argument is itself an optional dummy + argument, check its presence and substitute a null + if absent. */ + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && fsym->attr.optional) + gfc_conv_missing_dummy (&parmse, e, fsym->ts); + + /* If an INTENT(OUT) dummy of derived type has a default + initializer, it must be (re)initialized here. */ + if (fsym->attr.intent == INTENT_OUT + && fsym->ts.type == BT_DERIVED + && fsym->value) + { + gcc_assert (!fsym->attr.allocatable); + tmp = gfc_trans_assignment (e, fsym->value, false); + gfc_add_expr_to_block (&se->pre, tmp); + } + + /* Obtain the character length of an assumed character + length procedure from the typespec. */ + if (fsym->ts.type == BT_CHARACTER + && parmse.string_length == NULL_TREE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->symtree->n.sym->ts.cl->length != NULL) + { + gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); + parmse.string_length + = e->symtree->n.sym->ts.cl->backend_decl; + } + } + + if (need_interface_mapping) + gfc_add_interface_mapping (&mapping, fsym, &parmse); + } + + gfc_add_block_to_block (&se->pre, &parmse.pre); + gfc_add_block_to_block (&post, &parmse.post); + + /* Allocated allocatable components of derived types must be + deallocated for INTENT(OUT) dummy arguments and non-variable + scalars. Non-variable arrays are dealt with in trans-array.c + (gfc_conv_array_parameter). */ + if (e && e->ts.type == BT_DERIVED + && e->ts.derived->attr.alloc_comp + && ((formal && formal->sym->attr.intent == INTENT_OUT) + || + (e->expr_type != EXPR_VARIABLE && !e->rank))) + { + int parm_rank; + tmp = build_fold_indirect_ref (parmse.expr); + parm_rank = e->rank; + switch (parm_kind) + { + case (ELEMENTAL): + case (SCALAR): + parm_rank = 0; + break; + + case (SCALAR_POINTER): + tmp = build_fold_indirect_ref (tmp); + break; + case (ARRAY): + tmp = parmse.expr; + break; + } + + tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) + tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym), + tmp, build_empty_stmt ()); + + if (e->expr_type != EXPR_VARIABLE) + /* Don't deallocate non-variables until they have been used. */ + gfc_add_expr_to_block (&se->post, tmp); + else + { + gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT); + gfc_add_expr_to_block (&se->pre, tmp); + } + } + + /* Character strings are passed as two parameters, a length and a + pointer. */ + if (parmse.string_length != NULL_TREE) + stringargs = gfc_chainon_list (stringargs, parmse.string_length); + + arglist = gfc_chainon_list (arglist, parmse.expr); + } + gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); + + ts = sym->ts; + if (ts.type == BT_CHARACTER) + { + if (sym->ts.cl->length == NULL) + { + /* Assumed character length results are not allowed by 5.1.1.5 of the + standard and are trapped in resolve.c; except in the case of SPREAD + (and other intrinsics?) and dummy functions. In the case of SPREAD, + we take the character length of the first argument for the result. + For dummies, we have to look through the formal argument list for + this function and use the character length found there.*/ + if (!sym->attr.dummy) + cl.backend_decl = TREE_VALUE (stringargs); + else + { + formal = sym->ns->proc_name->formal; + for (; formal; formal = formal->next) + if (strcmp (formal->sym->name, sym->name) == 0) + cl.backend_decl = formal->sym->ts.cl->backend_decl; + } + } + else + { + /* Calculate the length of the returned string. */ + gfc_init_se (&parmse, NULL); + if (need_interface_mapping) + gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length); + else + gfc_conv_expr (&parmse, sym->ts.cl->length); + gfc_add_block_to_block (&se->pre, &parmse.pre); + gfc_add_block_to_block (&se->post, &parmse.post); + cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr); + } + + /* Set up a charlen structure for it. */ + cl.next = NULL; + cl.length = NULL; + ts.cl = &cl; + + len = cl.backend_decl; + } + + byref = gfc_return_by_reference (sym); + if (byref) + { + if (se->direct_byref) + retargs = gfc_chainon_list (retargs, se->expr); + else if (sym->result->attr.dimension) + { + gcc_assert (se->loop && info); + + /* Set the type of the array. */ + tmp = gfc_typenode_for_spec (&ts); + info->dimen = se->loop->dimen; + + /* Evaluate the bounds of the result, if known. */ + gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as); + + /* Create a temporary to store the result. In case the function + returns a pointer, the temporary will be a shallow copy and + mustn't be deallocated. */ + callee_alloc = sym->attr.allocatable || sym->attr.pointer; + gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp, + false, !sym->attr.pointer, callee_alloc); + + /* Pass the temporary as the first argument. */ + tmp = info->descriptor; + tmp = build_fold_addr_expr (tmp); + retargs = gfc_chainon_list (retargs, tmp); + } + else if (ts.type == BT_CHARACTER) + { + /* Pass the string length. */ + type = gfc_get_character_type (ts.kind, ts.cl); + type = build_pointer_type (type); + + /* Return an address to a char[0:len-1]* temporary for + character pointers. */ + if (sym->attr.pointer || sym->attr.allocatable) + { + /* Build char[0:len-1] * pstr. */ + tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, + build_int_cst (gfc_charlen_type_node, 1)); + tmp = build_range_type (gfc_array_index_type, + gfc_index_zero_node, tmp); + tmp = build_array_type (gfc_character1_type_node, tmp); + var = gfc_create_var (build_pointer_type (tmp), "pstr"); + + /* Provide an address expression for the function arguments. */ + var = build_fold_addr_expr (var); + } + else + var = gfc_conv_string_tmp (se, type, len); + + retargs = gfc_chainon_list (retargs, var); + } + else + { + gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX); - /* Character strings are passed as two parameters, a length and a - pointer. */ - if (parmse.string_length != NULL_TREE) - stringargs = gfc_chainon_list (stringargs, parmse.string_length); + type = gfc_get_complex_type (ts.kind); + var = build_fold_addr_expr (gfc_create_var (type, "cmplx")); + retargs = gfc_chainon_list (retargs, var); + } - arglist = gfc_chainon_list (arglist, parmse.expr); + /* Add the string length to the argument list. */ + if (ts.type == BT_CHARACTER) + retargs = gfc_chainon_list (retargs, len); } + gfc_free_interface_mapping (&mapping); + + /* Add the return arguments. */ + arglist = chainon (retargs, arglist); /* Add the hidden string length parameters to the arguments. */ arglist = chainon (arglist, stringargs); + /* We may want to append extra arguments here. This is used e.g. for + calls to libgfortran_matmul_??, which need extra information. */ + if (append_args != NULL_TREE) + arglist = chainon (arglist, append_args); + /* Generate the actual call. */ gfc_conv_function_val (se, sym); /* If there are alternate return labels, function type should be - integer. */ - if (has_alternate_specifier) - TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node; + integer. Can't modify the type in place though, since it can be shared + with other functions. */ + if (has_alternate_specifier + && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node) + { + gcc_assert (! sym->attr.dummy); + TREE_TYPE (sym->backend_decl) + = build_function_type (integer_type_node, + TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); + se->expr = build_fold_addr_expr (sym->backend_decl); + } fntype = TREE_TYPE (TREE_TYPE (se->expr)); - se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr, - arglist, NULL_TREE); - - if (sym->result) - sym = sym->result; + se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist); /* If we have a pointer function, but we don't want a pointer, e.g. something like x = f() where f is pointer valued, we have to dereference the result. */ if (!se->want_pointer && !byref && sym->attr.pointer) - se->expr = gfc_build_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref (se->expr); /* f2c calling conventions require a scalar default real function to return a double precision result. Convert this back to default @@ -1355,9 +2428,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, { /* Check the data pointer hasn't been modified. This would happen in a function returning a pointer. */ - tmp = gfc_conv_descriptor_data (info->descriptor); - tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data); - gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre); + tmp = gfc_conv_descriptor_data_get (info->descriptor); + tmp = fold_build2 (NE_EXPR, boolean_type_node, + tmp, info->data); + gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL); } se->expr = info->descriptor; /* Bundle in the string length. */ @@ -1367,7 +2441,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, { /* Dereference for character pointer results. */ if (sym->attr.pointer || sym->attr.allocatable) - se->expr = gfc_build_indirect_ref (var); + se->expr = build_fold_indirect_ref (var); else se->expr = var; @@ -1376,27 +2450,102 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, else { gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c); - se->expr = gfc_build_indirect_ref (var); + se->expr = build_fold_indirect_ref (var); } } } + + /* Follow the function call with the argument post block. */ + if (byref) + gfc_add_block_to_block (&se->pre, &post); + else + gfc_add_block_to_block (&se->post, &post); + + return has_alternate_specifier; } /* Generate code to copy a string. */ static void -gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest, - tree slen, tree src) +gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, + tree slength, tree src) { - tree tmp; + tree tmp, dlen, slen; + tree dsc; + tree ssc; + tree cond; + tree cond2; + tree tmp2; + tree tmp3; + tree tmp4; + stmtblock_t tempblock; + + dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); + slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); + + /* Deal with single character specially. */ + dsc = gfc_to_single_character (dlen, dest); + ssc = gfc_to_single_character (slen, src); + if (dsc != NULL_TREE && ssc != NULL_TREE) + { + gfc_add_modify_expr (block, dsc, ssc); + return; + } - tmp = NULL_TREE; - tmp = gfc_chainon_list (tmp, dlen); - tmp = gfc_chainon_list (tmp, dest); - tmp = gfc_chainon_list (tmp, slen); - tmp = gfc_chainon_list (tmp, src); - tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp); + /* Do nothing if the destination length is zero. */ + cond = fold_build2 (GT_EXPR, boolean_type_node, dlen, + build_int_cst (gfc_charlen_type_node, 0)); + + /* The following code was previously in _gfortran_copy_string: + + // The two strings may overlap so we use memmove. + void + copy_string (GFC_INTEGER_4 destlen, char * dest, + GFC_INTEGER_4 srclen, const char * src) + { + if (srclen >= destlen) + { + // This will truncate if too long. + memmove (dest, src, destlen); + } + else + { + memmove (dest, src, srclen); + // Pad with spaces. + memset (&dest[srclen], ' ', destlen - srclen); + } + } + + We're now doing it here for better optimization, but the logic + is the same. */ + + /* Truncate string if source is too long. */ + cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen); + tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], + 3, dest, src, dlen); + + /* Else copy and pad with spaces. */ + tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], + 3, dest, src, slen); + + tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest, + fold_convert (pchar_type_node, slen)); + tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, + tmp4, + build_int_cst (gfc_get_int_type (gfc_c_int_kind), + lang_hooks.to_target_charset (' ')), + fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), + dlen, slen)); + + gfc_init_block (&tempblock); + gfc_add_expr_to_block (&tempblock, tmp3); + gfc_add_expr_to_block (&tempblock, tmp4); + tmp3 = gfc_finish_block (&tempblock); + + /* The whole copy_string function is there. */ + tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ()); gfc_add_expr_to_block (block, tmp); } @@ -1536,7 +2685,7 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) sym = expr->value.function.esym; if (!sym) sym = expr->symtree->n.sym; - gfc_conv_function_call (se, sym, expr->value.function.actual); + gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE); } @@ -1671,9 +2820,12 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_start_scalarized_body (&loop, &body); gfc_conv_tmp_array_ref (&lse); + if (cm->ts.type == BT_CHARACTER) + lse.string_length = cm->ts.cl->backend_decl; + gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -1694,17 +2846,22 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) return gfc_finish_block (&block); } + /* Assign a single component of a derived type constructor. */ static tree gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { gfc_se se; + gfc_se lse; gfc_ss *rss; stmtblock_t block; tree tmp; + tree offset; + int n; gfc_start_block (&block); + if (cm->pointer) { gfc_init_se (&se, NULL); @@ -1713,12 +2870,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* Array pointer. */ if (expr->expr_type == EXPR_NULL) - { - dest = gfc_conv_descriptor_data (dest); - tmp = fold_convert (TREE_TYPE (se.expr), - null_pointer_node); - gfc_add_modify_expr (&block, dest, tmp); - } + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); else { rss = gfc_walk_expr (expr); @@ -1742,20 +2894,88 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) } else if (cm->dimension) { - tmp = gfc_trans_subarray_assign (dest, cm, expr); - gfc_add_expr_to_block (&block, tmp); + if (cm->allocatable && expr->expr_type == EXPR_NULL) + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + else if (cm->allocatable) + { + tree tmp2; + + gfc_init_se (&se, NULL); + + rss = gfc_walk_expr (expr); + se.want_pointer = 0; + gfc_conv_expr_descriptor (&se, expr, rss); + gfc_add_block_to_block (&block, &se.pre); + + tmp = fold_convert (TREE_TYPE (dest), se.expr); + gfc_add_modify_expr (&block, dest, tmp); + + if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) + tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, + cm->as->rank); + else + tmp = gfc_duplicate_allocatable (dest, se.expr, + TREE_TYPE(cm->backend_decl), + cm->as->rank); + + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &se.post); + gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); + + /* Shift the lbound and ubound of temporaries to being unity, rather + than zero, based. Calculate the offset for all cases. */ + offset = gfc_conv_descriptor_offset (dest); + gfc_add_modify_expr (&block, offset, gfc_index_zero_node); + tmp2 =gfc_create_var (gfc_array_index_type, NULL); + for (n = 0; n < expr->rank; n++) + { + if (expr->expr_type != EXPR_VARIABLE + && expr->expr_type != EXPR_CONSTANT) + { + tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]); + gfc_add_modify_expr (&block, tmp, + fold_build2 (PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node)); + tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]); + gfc_add_modify_expr (&block, tmp, gfc_index_one_node); + } + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_lbound (dest, + gfc_rank_cst[n]), + gfc_conv_descriptor_stride (dest, + gfc_rank_cst[n])); + gfc_add_modify_expr (&block, tmp2, tmp); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); + gfc_add_modify_expr (&block, offset, tmp); + } + } + else + { + tmp = gfc_trans_subarray_assign (dest, cm, expr); + gfc_add_expr_to_block (&block, tmp); + } } else if (expr->ts.type == BT_DERIVED) { - /* Nested derived type. */ - tmp = gfc_trans_structure_assign (dest, expr); - gfc_add_expr_to_block (&block, tmp); + if (expr->expr_type != EXPR_STRUCTURE) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + gfc_add_modify_expr (&block, dest, + fold_convert (TREE_TYPE (dest), se.expr)); + } + else + { + /* Nested constructors. */ + tmp = gfc_trans_structure_assign (dest, expr); + gfc_add_expr_to_block (&block, tmp); + } } else { /* Scalar component. */ - gfc_se lse; - gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -1763,7 +2983,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) if (cm->ts.type == BT_CHARACTER) lse.string_length = cm->ts.cl->backend_decl; lse.expr = dest; - tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -1804,11 +3024,10 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) { gfc_constructor *c; gfc_component *cm; - tree head; - tree tail; tree val; tree type; tree tmp; + VEC(constructor_elt,gc) *v = NULL; gcc_assert (se->ss == NULL); gcc_assert (expr->expr_type == EXPR_STRUCTURE); @@ -1823,32 +3042,24 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) return; } - head = build1 (CONSTRUCTOR, type, NULL_TREE); - tail = NULL_TREE; - cm = expr->ts.derived->components; + for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { - /* Skip absent members in default initializers. */ - if (!c->expr) + /* Skip absent members in default initializers and allocatable + components. Although the latter have a default initializer + of EXPR_NULL,... by default, the static nullify is not needed + since this is done every time we come into scope. */ + if (!c->expr || cm->allocatable) continue; val = gfc_conv_initializer (c->expr, &cm->ts, TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer); - /* Build a TREE_CHAIN to hold it. */ - val = tree_cons (cm->backend_decl, val, NULL_TREE); - - /* Add it to the list. */ - if (tail == NULL_TREE) - TREE_OPERAND(head, 0) = tail = val; - else - { - TREE_CHAIN (tail) = val; - tail = val; - } + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } - se->expr = head; + se->expr = build_constructor (type, v); } @@ -1868,11 +3079,13 @@ gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1; - gfc_conv_substring(se,ref,expr->ts.kind); + gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where); } -/* Entry point for expression translation. */ +/* Entry point for expression translation. Evaluates a scalar quantity. + EXPR is the expression to be translated, and SE is the state structure if + called from within the scalarized. */ void gfc_conv_expr (gfc_se * se, gfc_expr * expr) @@ -1928,15 +3141,20 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) } } +/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs + of an assignment. */ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr) { gfc_conv_expr (se, expr); - /* AFAICS all numeric lvalues have empty post chains. If not we need to + /* All numeric lvalues should have empty post chains. If not we need to figure out a way of rewriting an lvalue so that it has no post chain. */ - gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head); + gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head); } +/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for + numeric expressions. Used for scalar values where inserting cleanup code + is inconvenient. */ void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) { @@ -1948,9 +3166,12 @@ gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) { val = gfc_create_var (TREE_TYPE (se->expr), NULL); gfc_add_modify_expr (&se->pre, val, se->expr); + se->expr = val; + gfc_add_block_to_block (&se->pre, &se->post); } } +/* Helper to translate and expression and convert it to a particular type. */ void gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type) { @@ -2002,8 +3223,11 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) /* Create a temporary var to hold the value. */ if (TREE_CONSTANT (se->expr)) { - var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr)); - DECL_INITIAL (var) = se->expr; + tree tmp = se->expr; + STRIP_TYPE_NOPS (tmp); + var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp)); + DECL_INITIAL (var) = tmp; + TREE_STATIC (var) = 1; pushdecl (var); } else @@ -2014,7 +3238,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->pre, &se->post); /* Take the address of that value. */ - se->expr = gfc_build_addr_expr (NULL, var); + se->expr = build_fold_addr_expr (var); } @@ -2035,6 +3259,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_ss *lss; gfc_ss *rss; stmtblock_t block; + tree desc; + tree tmp; gfc_start_block (&block); @@ -2062,17 +3288,30 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { /* Array pointer. */ gfc_conv_expr_descriptor (&lse, expr1, lss); - /* Implement Nullify. */ - if (expr2->expr_type == EXPR_NULL) - { - lse.expr = gfc_conv_descriptor_data (lse.expr); - rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node); - gfc_add_modify_expr (&block, lse.expr, rse.expr); - } - else - { + switch (expr2->expr_type) + { + case EXPR_NULL: + /* Just set the data pointer to null. */ + gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node); + break; + + case EXPR_VARIABLE: + /* Assign directly to the pointer's descriptor. */ lse.direct_byref = 1; - gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_conv_expr_descriptor (&lse, expr2, rss); + break; + + default: + /* Assign to a temporary descriptor and then copy that + temporary to the pointer. */ + desc = lse.expr; + tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp"); + + lse.expr = tmp; + lse.direct_byref = 1; + gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_add_modify_expr (&lse.pre, desc, tmp); + break; } gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &lse.post); @@ -2109,16 +3348,19 @@ gfc_conv_string_parameter (gfc_se * se) /* Generate code for assignment of scalar variables. Includes character - strings. */ + strings and derived types with allocatable components. */ tree -gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) +gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, + bool l_is_temp, bool r_is_var) { stmtblock_t block; + tree tmp; + tree cond; gfc_init_block (&block); - if (type == BT_CHARACTER) + if (ts.type == BT_CHARACTER) { gcc_assert (lse->string_length != NULL_TREE && rse->string_length != NULL_TREE); @@ -2132,6 +3374,44 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) gfc_trans_string_copy (&block, lse->string_length, lse->expr, rse->string_length, rse->expr); } + else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) + { + cond = NULL_TREE; + + /* Are the rhs and the lhs the same? */ + if (r_is_var) + { + cond = fold_build2 (EQ_EXPR, boolean_type_node, + build_fold_addr_expr (lse->expr), + build_fold_addr_expr (rse->expr)); + cond = gfc_evaluate_now (cond, &lse->pre); + } + + /* Deallocate the lhs allocated components as long as it is not + the same as the rhs. */ + if (!l_is_temp) + { + tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0); + if (r_is_var) + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + gfc_add_expr_to_block (&lse->pre, tmp); + } + + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + gfc_add_modify_expr (&block, lse->expr, + fold_convert (TREE_TYPE (lse->expr), rse->expr)); + + /* Do a deep copy if the rhs is a variable, if it is not the + same as the lhs. */ + if (r_is_var) + { + tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + gfc_add_expr_to_block (&block, tmp); + } + } else { gfc_add_block_to_block (&block, &lse->pre); @@ -2157,17 +3437,62 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { gfc_se se; gfc_ss *ss; + gfc_ref * ref; + bool seen_array_ref; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) return NULL; /* Elemental functions don't need a temporary anyway. */ - if (expr2->symtree->n.sym->attr.elemental) + if (expr2->value.function.esym != NULL + && expr2->value.function.esym->attr.elemental) + return NULL; + + /* Fail if EXPR1 can't be expressed as a descriptor. */ + if (gfc_ref_needs_temporary_p (expr1->ref)) + return NULL; + + /* Functions returning pointers need temporaries. */ + if (expr2->symtree->n.sym->attr.pointer + || expr2->symtree->n.sym->attr.allocatable) return NULL; + /* Character array functions need temporaries unless the + character lengths are the same. */ + if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0) + { + if (expr1->ts.cl->length == NULL + || expr1->ts.cl->length->expr_type != EXPR_CONSTANT) + return NULL; + + if (expr2->ts.cl->length == NULL + || expr2->ts.cl->length->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpz_cmp (expr1->ts.cl->length->value.integer, + expr2->ts.cl->length->value.integer) != 0) + return NULL; + } + + /* Check that no LHS component references appear during an array + reference. This is needed because we do not have the means to + span any arbitrary stride with an array descriptor. This check + is not needed for the rhs because the function result has to be + a complete type. */ + seen_array_ref = false; + for (ref = expr1->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + seen_array_ref= true; + else if (ref->type == REF_COMPONENT && seen_array_ref) + return NULL; + } + /* Check for a dependency. */ - if (gfc_check_fncall_dependency (expr1, expr2)) + if (gfc_check_fncall_dependency (expr1, INTENT_OUT, + expr2->value.function.esym, + expr2->value.function.actual)) return NULL; /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic @@ -2193,12 +3518,206 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) return gfc_finish_block (&se.pre); } +/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ -/* Translate an assignment. Most of the code is concerned with - setting up the scalarizer. */ +static bool +is_zero_initializer_p (gfc_expr * expr) +{ + if (expr->expr_type != EXPR_CONSTANT) + return false; + /* We ignore Hollerith constants for the time being. */ + if (expr->from_H) + return false; -tree -gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) + switch (expr->ts.type) + { + case BT_INTEGER: + return mpz_cmp_si (expr->value.integer, 0) == 0; + + case BT_REAL: + return mpfr_zero_p (expr->value.real) + && MPFR_SIGN (expr->value.real) >= 0; + + case BT_LOGICAL: + return expr->value.logical == 0; + + case BT_COMPLEX: + return mpfr_zero_p (expr->value.complex.r) + && MPFR_SIGN (expr->value.complex.r) >= 0 + && mpfr_zero_p (expr->value.complex.i) + && MPFR_SIGN (expr->value.complex.i) >= 0; + + default: + break; + } + return false; +} + +/* Try to efficiently translate array(:) = 0. Return NULL if this + can't be done. */ + +static tree +gfc_trans_zero_assign (gfc_expr * expr) +{ + tree dest, len, type; + tree tmp; + gfc_symbol *sym; + + sym = expr->symtree->n.sym; + dest = gfc_get_symbol_decl (sym); + + type = TREE_TYPE (dest); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (!GFC_ARRAY_TYPE_P (type)) + return NULL_TREE; + + /* Determine the length of the array. */ + len = GFC_TYPE_ARRAY_SIZE (type); + if (!len || TREE_CODE (len) != INTEGER_CST) + return NULL_TREE; + + len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + + /* Convert arguments to the correct types. */ + if (!POINTER_TYPE_P (TREE_TYPE (dest))) + dest = gfc_build_addr_expr (pvoid_type_node, dest); + else + dest = fold_convert (pvoid_type_node, dest); + len = fold_convert (size_type_node, len); + + /* Construct call to __builtin_memset. */ + tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET], + 3, dest, integer_zero_node, len); + return fold_convert (void_type_node, tmp); +} + + +/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy + that constructs the call to __builtin_memcpy. */ + +static tree +gfc_build_memcpy_call (tree dst, tree src, tree len) +{ + tree tmp; + + /* Convert arguments to the correct types. */ + if (!POINTER_TYPE_P (TREE_TYPE (dst))) + dst = gfc_build_addr_expr (pvoid_type_node, dst); + else + dst = fold_convert (pvoid_type_node, dst); + + if (!POINTER_TYPE_P (TREE_TYPE (src))) + src = gfc_build_addr_expr (pvoid_type_node, src); + else + src = fold_convert (pvoid_type_node, src); + + len = fold_convert (size_type_node, len); + + /* Construct call to __builtin_memcpy. */ + tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len); + return fold_convert (void_type_node, tmp); +} + + +/* Try to efficiently translate dst(:) = src(:). Return NULL if this + can't be done. EXPR1 is the destination/lhs and EXPR2 is the + source/rhs, both are gfc_full_array_ref_p which have been checked for + dependencies. */ + +static tree +gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2) +{ + tree dst, dlen, dtype; + tree src, slen, stype; + + dst = gfc_get_symbol_decl (expr1->symtree->n.sym); + src = gfc_get_symbol_decl (expr2->symtree->n.sym); + + dtype = TREE_TYPE (dst); + if (POINTER_TYPE_P (dtype)) + dtype = TREE_TYPE (dtype); + stype = TREE_TYPE (src); + if (POINTER_TYPE_P (stype)) + stype = TREE_TYPE (stype); + + if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype)) + return NULL_TREE; + + /* Determine the lengths of the arrays. */ + dlen = GFC_TYPE_ARRAY_SIZE (dtype); + if (!dlen || TREE_CODE (dlen) != INTEGER_CST) + return NULL_TREE; + dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen, + TYPE_SIZE_UNIT (gfc_get_element_type (dtype))); + + slen = GFC_TYPE_ARRAY_SIZE (stype); + if (!slen || TREE_CODE (slen) != INTEGER_CST) + return NULL_TREE; + slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen, + TYPE_SIZE_UNIT (gfc_get_element_type (stype))); + + /* Sanity check that they are the same. This should always be + the case, as we should already have checked for conformance. */ + if (!tree_int_cst_equal (slen, dlen)) + return NULL_TREE; + + return gfc_build_memcpy_call (dst, src, dlen); +} + + +/* Try to efficiently translate array(:) = (/ ... /). Return NULL if + this can't be done. EXPR1 is the destination/lhs for which + gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */ + +static tree +gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) +{ + unsigned HOST_WIDE_INT nelem; + tree dst, dtype; + tree src, stype; + tree len; + + nelem = gfc_constant_array_constructor_p (expr2->value.constructor); + if (nelem == 0) + return NULL_TREE; + + dst = gfc_get_symbol_decl (expr1->symtree->n.sym); + dtype = TREE_TYPE (dst); + if (POINTER_TYPE_P (dtype)) + dtype = TREE_TYPE (dtype); + if (!GFC_ARRAY_TYPE_P (dtype)) + return NULL_TREE; + + /* Determine the lengths of the array. */ + len = GFC_TYPE_ARRAY_SIZE (dtype); + if (!len || TREE_CODE (len) != INTEGER_CST) + return NULL_TREE; + + /* Confirm that the constructor is the same size. */ + if (compare_tree_int (len, nelem) != 0) + return NULL_TREE; + + len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, + TYPE_SIZE_UNIT (gfc_get_element_type (dtype))); + + stype = gfc_typenode_for_spec (&expr2->ts); + src = gfc_build_constant_array_constructor (expr2, stype); + + stype = TREE_TYPE (src); + if (POINTER_TYPE_P (stype)) + stype = TREE_TYPE (stype); + + return gfc_build_memcpy_call (dst, src, len); +} + + +/* Subroutine of gfc_trans_assignment that actually scalarizes the + assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */ + +static tree +gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) { gfc_se lse; gfc_se rse; @@ -2209,14 +3728,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) tree tmp; stmtblock_t block; stmtblock_t body; - - /* Special case a single function returning an array. */ - if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) - { - tmp = gfc_trans_arrayfunc_assign (expr1, expr2); - if (tmp) - return tmp; - } + bool l_is_temp; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -2259,7 +3771,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) /* Calculate the bounds of the scalarization. */ gfc_conv_ss_startstride (&loop); /* Resolve any data dependencies in the statement. */ - gfc_conv_resolve_dependencies (&loop, lss_section, rss); + gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ gfc_conv_loop_setup (&loop); @@ -2287,10 +3799,12 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) else gfc_init_block (&body); + l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); + /* Translate the expression. */ gfc_conv_expr (&rse, expr2); - if (lss != gfc_ss_terminator && loop.temp_ss != NULL) + if (l_is_temp) { gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); @@ -2298,7 +3812,9 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) else gfc_conv_expr (&lse, expr1); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + l_is_temp || init_flag, + expr2->expr_type == EXPR_VARIABLE); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -2311,7 +3827,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); - if (loop.temp_ss != NULL) + if (l_is_temp) { gfc_trans_scalarized_loop_boundary (&loop, &body); @@ -2331,9 +3847,11 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + false, false); gfc_add_expr_to_block (&body, tmp); } + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop, &body); @@ -2347,8 +3865,104 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) return gfc_finish_block (&block); } + +/* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */ + +static bool +copyable_array_p (gfc_expr * expr) +{ + /* First check it's an array. */ + if (expr->rank < 1 || !expr->ref) + return false; + + /* Next check that it's of a simple enough type. */ + switch (expr->ts.type) + { + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + case BT_LOGICAL: + return true; + + case BT_CHARACTER: + return false; + + case BT_DERIVED: + return !expr->ts.derived->attr.alloc_comp; + + default: + break; + } + + return false; +} + +/* Translate an assignment. */ + +tree +gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) +{ + tree tmp; + + /* Special case a single function returning an array. */ + if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) + { + tmp = gfc_trans_arrayfunc_assign (expr1, expr2); + if (tmp) + return tmp; + } + + /* Special case assigning an array to zero. */ + if (expr1->expr_type == EXPR_VARIABLE + && expr1->rank > 0 + && expr1->ref + && gfc_full_array_ref_p (expr1->ref) + && is_zero_initializer_p (expr2)) + { + tmp = gfc_trans_zero_assign (expr1); + if (tmp) + return tmp; + } + + /* Special case copying one array to another. */ + if (expr1->expr_type == EXPR_VARIABLE + && copyable_array_p (expr1) + && gfc_full_array_ref_p (expr1->ref) + && expr2->expr_type == EXPR_VARIABLE + && copyable_array_p (expr2) + && gfc_full_array_ref_p (expr2->ref) + && gfc_compare_types (&expr1->ts, &expr2->ts) + && !gfc_check_dependency (expr1, expr2, 0)) + { + tmp = gfc_trans_array_copy (expr1, expr2); + if (tmp) + return tmp; + } + + /* Special case initializing an array from a constant array constructor. */ + if (expr1->expr_type == EXPR_VARIABLE + && copyable_array_p (expr1) + && gfc_full_array_ref_p (expr1->ref) + && expr2->expr_type == EXPR_ARRAY + && gfc_compare_types (&expr1->ts, &expr2->ts)) + { + tmp = gfc_trans_array_constructor_copy (expr1, expr2); + if (tmp) + return tmp; + } + + /* Fallback to the scalarizer to generate explicit loops. */ + return gfc_trans_assignment_1 (expr1, expr2, init_flag); +} + +tree +gfc_trans_init_assign (gfc_code * code) +{ + return gfc_trans_assignment (code->expr, code->expr2, true); +} + tree gfc_trans_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr, code->expr2); + return gfc_trans_assignment (code->expr, code->expr2, false); }