X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-expr.c;h=42e259354d18b4ba05f79a409bc0b677f525be00;hb=a9601c934b0aa967797b3d43d2b12f7639508fac;hp=b6a825a81257218ee3affd6b5cc45e8bb584dd26;hpb=ff70e44325c390560120b8ab5a8e0043d0403aef;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b6a825a8125..42e259354d1 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,5 +1,6 @@ /* Expression translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -26,15 +27,12 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "convert.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" -#include "gimple.h" +#include "diagnostic-core.h" /* For fatal_error. */ #include "langhooks.h" #include "flags.h" #include "gfortran.h" #include "arith.h" +#include "constructor.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" @@ -126,7 +124,7 @@ gfc_make_safe_expr (gfc_se * se) tree gfc_conv_expr_present (gfc_symbol * sym) { - tree decl; + tree decl, cond; gcc_assert (sym->attr.dummy); @@ -139,8 +137,27 @@ gfc_conv_expr_present (gfc_symbol * sym) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); decl = GFC_DECL_SAVED_DESCRIPTOR (decl); } - return fold_build2 (NE_EXPR, boolean_type_node, decl, - fold_convert (TREE_TYPE (decl), null_pointer_node)); + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl, + fold_convert (TREE_TYPE (decl), null_pointer_node)); + + /* Fortran 2008 allows to pass null pointers and non-associated pointers + as actual argument to denote absent dummies. For array descriptors, + we thus also need to check the array descriptor. */ + if (!sym->attr.pointer && !sym->attr.allocatable + && sym->as && sym->as->type == AS_ASSUMED_SHAPE + && (gfc_option.allow_std & GFC_STD_F2008) != 0) + { + tree tmp; + tmp = build_fold_indirect_ref_loc (input_location, decl); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, tmp); + } + + return cond; } @@ -158,18 +175,20 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) { /* Create a temporary and convert it to the correct type. */ tmp = gfc_get_int_type (kind); - tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr)); + tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, + se->expr)); /* Test for a NULL value. */ - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, - fold_convert (TREE_TYPE (tmp), integer_one_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, + tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); tmp = gfc_evaluate_now (tmp, &se->pre); se->expr = gfc_build_addr_expr (NULL_TREE, tmp); } else { - tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, - fold_convert (TREE_TYPE (se->expr), integer_zero_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), + present, se->expr, + build_zero_cst (TREE_TYPE (se->expr))); tmp = gfc_evaluate_now (tmp, &se->pre); se->expr = tmp; } @@ -177,8 +196,8 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) if (ts.type == BT_CHARACTER) { tmp = build_int_cst (gfc_charlen_type_node, 0); - tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node, - present, se->string_length, tmp); + tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, + present, se->string_length, tmp); tmp = gfc_evaluate_now (tmp, &se->pre); se->string_length = tmp; } @@ -200,12 +219,12 @@ gfc_get_expr_charlen (gfc_expr *e) length = NULL; /* To silence compiler warning. */ - if (is_subref_array (e) && e->ts.cl->length) + if (is_subref_array (e) && e->ts.u.cl->length) { gfc_se tmpse; gfc_init_se (&tmpse, NULL); - gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node); - e->ts.cl->backend_decl = tmpse.expr; + gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node); + e->ts.u.cl->backend_decl = tmpse.expr; return tmpse.expr; } @@ -213,7 +232,7 @@ gfc_get_expr_charlen (gfc_expr *e) expression's length could be the length of the character variable. */ if (e->symtree->n.sym->ts.type == BT_CHARACTER) - length = e->symtree->n.sym->ts.cl->backend_decl; + length = e->symtree->n.sym->ts.u.cl->backend_decl; /* Look through the reference chain for component references. */ for (r = e->ref; r; r = r->next) @@ -222,7 +241,7 @@ gfc_get_expr_charlen (gfc_expr *e) { case REF_COMPONENT: if (r->u.c.component->ts.type == BT_CHARACTER) - length = r->u.c.component->ts.cl->backend_decl; + length = r->u.c.component->ts.u.cl->backend_decl; break; case REF_ARRAY: @@ -242,7 +261,7 @@ gfc_get_expr_charlen (gfc_expr *e) } -/* For each character array constructor subexpression without a ts.cl->length, +/* For each character array constructor subexpression without a ts.u.cl->length, replace it by its first element (if there aren't any elements, the length should already be set to zero). */ @@ -275,13 +294,16 @@ flatten_array_ctors_without_strlen (gfc_expr* e) case EXPR_ARRAY: /* We've found what we're looking for. */ - if (e->ts.type == BT_CHARACTER && !e->ts.cl->length) + if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) { + gfc_constructor *c; gfc_expr* new_expr; + gcc_assert (e->value.constructor); - new_expr = e->value.constructor->expr; - e->value.constructor->expr = NULL; + c = gfc_constructor_first (e->value.constructor); + new_expr = c->expr; + c->expr = NULL; flatten_array_ctors_without_strlen (new_expr); gfc_replace_expr (e, new_expr); @@ -290,7 +312,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* Otherwise, fall through to handle constructor elements. */ case EXPR_STRUCTURE: - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) flatten_array_ctors_without_strlen (c->expr); break; @@ -313,6 +336,11 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) gfc_init_se (&se, NULL); + if (!cl->length + && cl->backend_decl + && TREE_CODE (cl->backend_decl) == VAR_DECL) + return; + /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but "flatten" array constructors by taking their first element; all elements should be the same length or a cl->length should be present. */ @@ -320,7 +348,6 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) { gfc_expr* expr_flat; gcc_assert (expr); - expr_flat = gfc_copy_expr (expr); flatten_array_ctors_without_strlen (expr_flat); gfc_resolve_expr (expr_flat); @@ -338,8 +365,8 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) gcc_assert (cl->length); gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); - se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr, - build_int_cst (gfc_charlen_type_node, 0)); + se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, + se.expr, build_int_cst (gfc_charlen_type_node, 0)); gfc_add_block_to_block (pblock, &se.pre); if (cl->backend_decl) @@ -355,7 +382,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, { tree tmp; tree type; - tree var; tree fault; gfc_se start; gfc_se end; @@ -364,7 +390,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, type = gfc_get_character_type (kind, ref->u.ss.length); type = build_pointer_type (type); - var = NULL_TREE; gfc_init_se (&start, se); gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &start.pre); @@ -373,15 +398,18 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, gfc_conv_string_parameter (se); else { + tmp = start.expr; + STRIP_NOPS (tmp); /* Avoid multiple evaluation of substring start. */ - if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr)) + if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) tmp = se->expr; else - tmp = build_fold_indirect_ref (se->expr); + tmp = build_fold_indirect_ref_loc (input_location, + se->expr); tmp = gfc_build_array_ref (tmp, start.expr, NULL); se->expr = gfc_build_addr_expr (type, tmp); } @@ -395,19 +423,23 @@ 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); } - if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr)) + tmp = end.expr; + STRIP_NOPS (tmp); + if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) end.expr = gfc_evaluate_now (end.expr, &se->pre); if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { - tree nonempty = fold_build2 (LE_EXPR, boolean_type_node, - start.expr, end.expr); + tree nonempty = fold_build2_loc (input_location, 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); + fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + start.expr, + build_int_cst (gfc_charlen_type_node, 1)); + fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, nonempty, fault); if (name) asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' " "is less than one", name); @@ -420,10 +452,10 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, 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); + fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + end.expr, se->string_length); + fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, nonempty, fault); if (name) asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' " "exceeds string length (%%ld)", name); @@ -437,12 +469,20 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, 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)); + /* If the start and end expressions are equal, the length is one. */ + if (ref->u.ss.end + && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0) + tmp = build_int_cst (gfc_charlen_type_node, 1); + else + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, + end.expr, start.expr); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node, + build_int_cst (gfc_charlen_type_node, 1), tmp); + tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, + tmp, build_int_cst (gfc_charlen_type_node, 0)); + } + se->string_length = tmp; } @@ -464,21 +504,24 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = c->backend_decl; gcc_assert (TREE_CODE (field) == FIELD_DECL); decl = se->expr; - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + decl, field, NULL_TREE); se->expr = tmp; - if (c->ts.type == BT_CHARACTER) + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer) { - tmp = c->ts.cl->backend_decl; + tmp = c->ts.u.cl->backend_decl; /* Components must always be constant length. */ gcc_assert (tmp && INTEGER_CST_P (tmp)); se->string_length = tmp; } - if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER) + if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0 + && c->ts.type != BT_CHARACTER) || c->attr.proc_pointer) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } @@ -501,16 +544,23 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) parent.u.c.sym = dt; parent.u.c.component = dt->components; + if (dt->backend_decl == NULL) + gfc_get_derived_type (dt); + if (dt->attr.extension && dt->components) { + if (dt->attr.is_class) + cmp = dt->components; + else + cmp = dt->components->next; /* Return if the component is not in the parent type. */ - for (cmp = dt->components->next; cmp; cmp = cmp->next) + for (; cmp; cmp = cmp->next) if (strcmp (c->name, cmp->name) == 0) return; /* Otherwise build the reference and call self. */ gfc_conv_component_ref (se, &parent); - parent.u.c.sym = dt->components->ts.derived; + parent.u.c.sym = dt->components->ts.u.derived; parent.u.c.component = c; conv_parent_component_references (se, &parent); } @@ -524,7 +574,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; gfc_symbol *sym; - tree parent_decl; + tree parent_decl = NULL_TREE; int parent_flag; bool return_value; bool alternate_entry; @@ -558,7 +608,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) 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 (current_function_decl) + parent_decl = DECL_CONTEXT (current_function_decl); if ((se->expr == parent_decl && return_value) || (sym->ns && sym->ns->proc_name @@ -621,30 +672,35 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && (sym->attr.dummy || sym->attr.function || sym->attr.result)) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } else if (!sym->attr.value) { /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); /* Dereference scalar hidden result. */ if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX && (sym->attr.function || sym->attr.result) && !sym->attr.dimension && !sym->attr.pointer && !sym->attr.always_explicit) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ - if ((sym->attr.pointer || sym->attr.allocatable) + if ((sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym)) && (sym->attr.dummy || sym->attr.function || sym->attr.result || !sym->attr.dimension)) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } ref = expr->ref; @@ -655,10 +711,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { /* 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; + if (sym->attr.entry && !sym->ts.u.cl->backend_decl) + se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl; else - se->string_length = sym->ts.cl->backend_decl; + se->string_length = sym->ts.u.cl->backend_decl; gcc_assert (se->string_length); } @@ -703,7 +759,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) separately. */ if (se->want_pointer) { - if (expr->ts.type == BT_CHARACTER) + if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL)) gfc_conv_string_parameter (se); else se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); @@ -731,10 +787,10 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)). All other unary operators have an equivalent GIMPLE unary operator. */ if (code == TRUTH_NOT_EXPR) - se->expr = fold_build2 (EQ_EXPR, type, operand.expr, - build_int_cst (type, 0)); + se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr, + build_int_cst (type, 0)); else - se->expr = fold_build1 (code, type, operand.expr); + se->expr = fold_build1_loc (input_location, code, type, operand.expr); } @@ -821,7 +877,7 @@ gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) op1 = op0; } - tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1); tmp = gfc_evaluate_now (tmp, &se->pre); if (n < POWI_TABLE_SIZE) @@ -872,27 +928,29 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */ if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE)) { - tmp = fold_build2 (EQ_EXPR, boolean_type_node, - lhs, build_int_cst (TREE_TYPE (lhs), -1)); - cond = fold_build2 (EQ_EXPR, boolean_type_node, - lhs, build_int_cst (TREE_TYPE (lhs), 1)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + lhs, build_int_cst (TREE_TYPE (lhs), -1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + lhs, build_int_cst (TREE_TYPE (lhs), 1)); /* If rhs is even, result = (lhs == 1 || lhs == -1) ? 1 : 0. */ if ((n & 1) == 0) { - tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond); - se->expr = fold_build3 (COND_EXPR, type, - tmp, build_int_cst (type, 1), - build_int_cst (type, 0)); + tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, tmp, cond); + se->expr = fold_build3_loc (input_location, 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 = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1), - build_int_cst (type, 0)); - se->expr = fold_build3 (COND_EXPR, type, - cond, build_int_cst (type, 1), tmp); + tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, + build_int_cst (type, -1), + build_int_cst (type, 0)); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, + cond, build_int_cst (type, 1), tmp); return 1; } @@ -901,7 +959,8 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) if (sgn == -1) { tmp = gfc_build_const (type, integer_one_node); - vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]); + vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp, + vartmp[1]); } se->expr = gfc_conv_powi (se, n, vartmp); @@ -918,9 +977,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) tree gfc_int4_type_node; int kind; int ikind; + int res_ikind_1, res_ikind_2; gfc_se lse; gfc_se rse; - tree fndecl; + tree fndecl = NULL; gfc_init_se (&lse, se); gfc_conv_expr_val (&lse, expr->value.op.op1); @@ -938,6 +998,13 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) gfc_int4_type_node = gfc_get_int_type (4); + /* In case of integer operands with kinds 1 or 2, we call the integer kind 4 + library routine. But in the end, we have to convert the result back + if this case applies -- with res_ikind_K, we keep track whether operand K + falls into this case. */ + res_ikind_1 = -1; + res_ikind_2 = -1; + kind = expr->value.op.op1->ts.kind; switch (expr->value.op.op2->ts.type) { @@ -948,6 +1015,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 1: case 2: rse.expr = convert (gfc_int4_type_node, rse.expr); + res_ikind_2 = ikind; /* Fall through. */ case 4: @@ -970,7 +1038,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 1: case 2: if (expr->value.op.op1->ts.type == BT_INTEGER) - lse.expr = convert (gfc_int4_type_node, lse.expr); + { + lse.expr = convert (gfc_int4_type_node, lse.expr); + res_ikind_1 = kind; + } else gcc_unreachable (); /* Fall through. */ @@ -1018,15 +1089,24 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case 2: - case 3: fndecl = built_in_decls[BUILT_IN_POWIL]; break; + case 3: + /* Use the __builtin_powil() only if real(kind=16) is + actually the C long double type. */ + if (!gfc_real16_is_float128) + fndecl = built_in_decls[BUILT_IN_POWIL]; + break; + default: gcc_unreachable (); } } - else + + /* If we don't have a good builtin for this, go for the + library function. */ + if (!fndecl) fndecl = gfor_fndecl_math_powi[kind][ikind].real; break; @@ -1040,39 +1120,11 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case BT_REAL: - switch (kind) - { - case 4: - fndecl = built_in_decls[BUILT_IN_POWF]; - break; - 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 (); - } + fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind); break; case BT_COMPLEX: - switch (kind) - { - case 4: - fndecl = built_in_decls[BUILT_IN_CPOWF]; - break; - case 8: - fndecl = built_in_decls[BUILT_IN_CPOW]; - break; - case 10: - case 16: - fndecl = built_in_decls[BUILT_IN_CPOWL]; - break; - default: - gcc_unreachable (); - } + fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind); break; default: @@ -1080,7 +1132,17 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; } - se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr); + se->expr = build_call_expr_loc (input_location, + fndecl, 2, lse.expr, rse.expr); + + /* Convert the result back if it is of wrong integer kind. */ + if (res_ikind_1 != -1 && res_ikind_2 != -1) + { + /* We want the maximum of both operand kinds as result. */ + if (res_ikind_1 < res_ikind_2) + res_ikind_1 = res_ikind_2; + se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr); + } } @@ -1092,13 +1154,12 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tree var; tree tmp; - gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node); - if (gfc_can_put_var_on_stack (len)) { /* Create a temporary variable to hold the result. */ - tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, - build_int_cst (gfc_charlen_type_node, 1)); + tmp = fold_build2_loc (input_location, 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); if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) @@ -1114,9 +1175,10 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) /* Allocate a temporary to hold the result. */ var = gfc_create_var (type, "pstr"); tmp = gfc_call_malloc (&se->pre, type, - fold_build2 (MULT_EXPR, TREE_TYPE (len), len, - fold_convert (TREE_TYPE (len), - TYPE_SIZE (type)))); + fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE (type)))); gfc_add_modify (&se->pre, var, tmp); /* Free the temporary afterwards. */ @@ -1151,12 +1213,13 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->pre, &lse.pre); gfc_add_block_to_block (&se->pre, &rse.pre); - type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); + type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); if (len == NULL_TREE) { - len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length), - lse.string_length, rse.string_length); + len = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (lse.string_length), + lse.string_length, rse.string_length); } type = build_pointer_type (type); @@ -1171,7 +1234,8 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) else gcc_unreachable (); - tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr, + tmp = build_call_expr_loc (input_location, + fndecl, 6, len, var, lse.string_length, lse.expr, rse.string_length, rse.expr); gfc_add_expr_to_block (&se->pre, tmp); @@ -1206,8 +1270,9 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) switch (expr->value.op.op) { case INTRINSIC_PARENTHESES: - if (expr->ts.type == BT_REAL - || expr->ts.type == BT_COMPLEX) + if ((expr->ts.type == BT_REAL + || expr->ts.type == BT_COMPLEX) + && gfc_option.flag_protect_parens) { gfc_conv_unary_op (PAREN_EXPR, se, expr); gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr))); @@ -1346,7 +1411,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, rse.string_length, rse.expr, - expr->value.op.op1->ts.kind); + expr->value.op.op1->ts.kind, + code); rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); gfc_add_block_to_block (&lse.post, &rse.post); } @@ -1356,11 +1422,12 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) if (lop) { /* The result of logical ops is always boolean_type_node. */ - tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr); + tmp = fold_build2_loc (input_location, code, boolean_type_node, + lse.expr, rse.expr); se->expr = convert (type, tmp); } else - se->expr = fold_build2 (code, type, lse.expr, rse.expr); + se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr); /* Add the post blocks. */ gfc_add_block_to_block (&se->post, &rse.post); @@ -1369,16 +1436,45 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) /* If a string's length is one, we convert it to a single character. */ -static tree -string_to_single_character (tree len, tree str, int kind) +tree +gfc_string_to_single_character (tree len, tree str, int kind) { - 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) + if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0 + || !POINTER_TYPE_P (TREE_TYPE (str))) + return NULL_TREE; + + if (TREE_INT_CST_LOW (len) == 1) { str = fold_convert (gfc_get_pchar_type (kind), str); - return build_fold_indirect_ref (str); + return build_fold_indirect_ref_loc (input_location, str); + } + + if (kind == 1 + && TREE_CODE (str) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF + && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST + && array_ref_low_bound (TREE_OPERAND (str, 0)) + == TREE_OPERAND (TREE_OPERAND (str, 0), 1) + && TREE_INT_CST_LOW (len) > 1 + && TREE_INT_CST_LOW (len) + == (unsigned HOST_WIDE_INT) + TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) + { + tree ret = fold_convert (gfc_get_pchar_type (kind), str); + ret = build_fold_indirect_ref_loc (input_location, ret); + if (TREE_CODE (ret) == INTEGER_CST) + { + tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); + int i, length = TREE_STRING_LENGTH (string_cst); + const char *ptr = TREE_STRING_POINTER (string_cst); + + for (i = 1; i < length; i++) + if (ptr[i] != ' ') + return NULL_TREE; + + return ret; + } } return NULL_TREE; @@ -1411,7 +1507,8 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) gfc_typespec ts; gfc_clear_ts (&ts); - *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]); + *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, + (int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { /* The expr needs to be compatible with a C int. If the @@ -1425,7 +1522,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { if ((*expr)->ref == NULL) { - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl @@ -1435,7 +1532,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) else { gfc_conv_variable (se, *expr); - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), se->expr), @@ -1445,60 +1542,131 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) } } +/* Helper function for gfc_build_compare_string. Return LEN_TRIM value + if STR is a string literal, otherwise return -1. */ + +static int +gfc_optimize_len_trim (tree len, tree str, int kind) +{ + if (kind == 1 + && TREE_CODE (str) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF + && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST + && array_ref_low_bound (TREE_OPERAND (str, 0)) + == TREE_OPERAND (TREE_OPERAND (str, 0), 1) + && TREE_INT_CST_LOW (len) >= 1 + && TREE_INT_CST_LOW (len) + == (unsigned HOST_WIDE_INT) + TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) + { + tree folded = fold_convert (gfc_get_pchar_type (kind), str); + folded = build_fold_indirect_ref_loc (input_location, folded); + if (TREE_CODE (folded) == INTEGER_CST) + { + tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); + int length = TREE_STRING_LENGTH (string_cst); + const char *ptr = TREE_STRING_POINTER (string_cst); + + for (; length > 0; length--) + if (ptr[length - 1] != ' ') + break; + + return length; + } + } + return -1; +} /* 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, int kind) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind, + enum tree_code code) { tree sc1; tree sc2; - tree tmp; + tree fndecl; gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = string_to_single_character (len1, str1, kind); - sc2 = string_to_single_character (len2, str2, kind); + sc1 = gfc_string_to_single_character (len1, str1, kind); + sc2 = gfc_string_to_single_character (len2, str2, kind); if (sc1 != NULL_TREE && sc2 != NULL_TREE) { /* Deal with single character specially. */ sc1 = fold_convert (integer_type_node, sc1); sc2 = fold_convert (integer_type_node, sc2); - tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); + return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, + sc1, sc2); } - else + + if ((code == EQ_EXPR || code == NE_EXPR) + && optimize + && INTEGER_CST_P (len1) && INTEGER_CST_P (len2)) { - /* Build a call for the comparison. */ - tree fndecl; + /* If one string is a string literal with LEN_TRIM longer + than the length of the second string, the strings + compare unequal. */ + int len = gfc_optimize_len_trim (len1, str1, kind); + if (len > 0 && compare_tree_int (len2, len) < 0) + return integer_one_node; + len = gfc_optimize_len_trim (len2, str2, kind); + if (len > 0 && compare_tree_int (len1, len) < 0) + return integer_one_node; + } - if (kind == 1) - fndecl = gfor_fndecl_compare_string; - else if (kind == 4) - fndecl = gfor_fndecl_compare_string_char4; - else - gcc_unreachable (); + /* Build a call for the comparison. */ + if (kind == 1) + fndecl = gfor_fndecl_compare_string; + else if (kind == 4) + fndecl = gfor_fndecl_compare_string_char4; + else + gcc_unreachable (); - tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2); - } + return build_call_expr_loc (input_location, fndecl, 4, + len1, str1, len2, str2); +} - return tmp; + +/* Return the backend_decl for a procedure pointer component. */ + +static tree +get_proc_ptr_comp (gfc_expr *e) +{ + gfc_se comp_se; + gfc_expr *e2; + expr_t old_type; + + gfc_init_se (&comp_se, NULL); + e2 = gfc_copy_expr (e); + /* We have to restore the expr type later so that gfc_free_expr frees + the exact same thing that was allocated. + TODO: This is ugly. */ + old_type = e2->expr_type; + e2->expr_type = EXPR_VARIABLE; + gfc_conv_expr (&comp_se, e2); + e2->expr_type = old_type; + gfc_free_expr (e2); + return build_fold_addr_expr_loc (input_location, comp_se.expr); } + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; if (gfc_is_proc_ptr_comp (expr, NULL)) - tmp = gfc_get_proc_ptr_comp (se, expr); + tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) { tmp = gfc_get_symbol_decl (sym); if (sym->attr.proc_pointer) - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); } @@ -1599,7 +1767,9 @@ gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym, tree var; type = gfc_typenode_for_spec (&sym->ts); - type = gfc_get_nodesc_array_type (type, sym->as, packed); + type = gfc_get_nodesc_array_type (type, sym->as, packed, + !sym->attr.target && !sym->attr.pointer + && !sym->attr.proc_pointer); var = gfc_create_var (type, "ifm"); gfc_add_modify (block, var, fold_convert (type, data)); @@ -1634,19 +1804,21 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) } else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, dim), - gfc_conv_descriptor_lbound_get (desc, dim)); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, n), - tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, dim), + gfc_conv_descriptor_lbound_get (desc, dim)); + tmp = fold_build2_loc (input_location, 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); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, n), + GFC_TYPE_ARRAY_STRIDE (type, n)); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); } offset = gfc_evaluate_now (offset, block); GFC_TYPE_ARRAY_OFFSET (type) = offset; @@ -1676,6 +1848,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.contiguous = sym->attr.contiguous; + new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; new_sym->attr.flavor = sym->attr.flavor; @@ -1711,16 +1885,16 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, if (sym->ts.type == BT_CHARACTER) { /* Create a copy of the dummy argument's length. */ - new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl); - sm->expr->ts.cl = new_sym->ts.cl; + new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl); + sm->expr->ts.u.cl = new_sym->ts.u.cl; /* 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 && se) + if (!new_sym->ts.u.cl->length && se) { se->string_length = gfc_evaluate_now (se->string_length, &se->pre); - new_sym->ts.cl->backend_decl = se->string_length; + new_sym->ts.u.cl->backend_decl = se->string_length; } } @@ -1738,7 +1912,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, 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); + value = build_fold_indirect_ref_loc (input_location, + se->expr); else value = se->expr; value = fold_convert (tmp, value); @@ -1747,11 +1922,13 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, /* 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); + value = build_fold_indirect_ref_loc (input_location, + 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); + else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) + value = build_fold_indirect_ref_loc (input_location, + se->expr); /* If the argument is an array descriptor, use it to determine information about the actual argument's shape. */ @@ -1759,7 +1936,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) { /* Get the actual argument's descriptor. */ - desc = build_fold_indirect_ref (se->expr); + desc = build_fold_indirect_ref_loc (input_location, + se->expr); /* Create the replacement variable. */ tmp = gfc_conv_descriptor_data_get (desc); @@ -1793,9 +1971,9 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, for (sym = mapping->syms; sym; sym = sym->next) if (sym->new_sym->n.sym->ts.type == BT_CHARACTER - && !sym->new_sym->n.sym->ts.cl->backend_decl) + && !sym->new_sym->n.sym->ts.u.cl->backend_decl) { - expr = sym->new_sym->n.sym->ts.cl->length; + expr = sym->new_sym->n.sym->ts.u.cl->length; gfc_apply_interface_mapping_to_expr (mapping, expr); gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); @@ -1804,7 +1982,7 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, gfc_add_block_to_block (pre, &se.pre); gfc_add_block_to_block (post, &se.post); - sym->new_sym->n.sym->ts.cl->backend_decl = se.expr; + sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr; } } @@ -1814,9 +1992,10 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, static void gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping, - gfc_constructor * c) + gfc_constructor_base base) { - for (; c; c = c->next) + gfc_constructor *c; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { gfc_apply_interface_mapping_to_expr (mapping, c->expr); if (c->iterator) @@ -1891,16 +2070,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) case GFC_ISYM_LEN: /* TODO figure out why this condition is necessary. */ if (sym->attr.function - && (arg1->ts.cl->length == NULL - || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT - && arg1->ts.cl->length->expr_type != EXPR_VARIABLE))) + && (arg1->ts.u.cl->length == NULL + || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT + && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE))) return false; - new_expr = gfc_copy_expr (arg1->ts.cl->length); + new_expr = gfc_copy_expr (arg1->ts.u.cl->length); break; case GFC_ISYM_SIZE: - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -1924,7 +2103,9 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) return false; } - tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1)); + tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), + gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1)); tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d])); if (new_expr) new_expr = gfc_multiply (new_expr, tmp); @@ -1938,7 +2119,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) /* TODO These implementations of lbound and ubound do not limit if the size < 0, according to F95's 13.14.53 and 13.14.113. */ - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2009,11 +2190,11 @@ gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr, if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER) { - expr->value.function.esym->ts.cl->length - = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length); + expr->value.function.esym->ts.u.cl->length + = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length); gfc_apply_interface_mapping_to_expr (mapping, - expr->value.function.esym->ts.cl->length); + expr->value.function.esym->ts.u.cl->length); } } @@ -2034,10 +2215,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, return; /* Copying an expression does not copy its length, so do that here. */ - if (expr->ts.type == BT_CHARACTER && expr->ts.cl) + if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl) { - expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl); - gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length); + expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl); + gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length); } /* Apply the mapping to any references. */ @@ -2122,8 +2303,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping, an actual argument derived type array is copied and then returned after the function call. */ void -gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, - int g77, sym_intent intent) +gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, + sym_intent intent, bool formal_ptr) { gfc_se lse; gfc_se rse; @@ -2136,8 +2317,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, tree tmp_index; tree tmp; tree base_type; + tree size; stmtblock_t body; int n; + int dimen; gcc_assert (expr->expr_type == EXPR_VARIABLE); @@ -2157,8 +2340,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, gfc_conv_ss_startstride (&loop); /* Build an ss for the temporary. */ - if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl) - gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre); + if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl) + gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre); base_type = gfc_typenode_for_spec (&expr->ts); if (GFC_ARRAY_TYPE_P (base_type) @@ -2170,7 +2353,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, loop.temp_ss->data.temp.type = base_type; if (expr->ts.type == BT_CHARACTER) - loop.temp_ss->string_length = expr->ts.cl->backend_decl; + loop.temp_ss->string_length = expr->ts.u.cl->backend_decl; else loop.temp_ss->string_length = NULL; @@ -2204,11 +2387,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, 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); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); @@ -2266,45 +2448,51 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, outside the innermost loop, so the overall transfer could be optimized further. */ info = &rse.ss->data.info; + dimen = info->dimen; tmp_index = gfc_index_zero_node; - for (n = info->dimen - 1; n > 0; n--) + for (n = 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 = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + tmp, rse.loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, tmp_index); + + tmp_str = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + rse.loop->to[n-1], rse.loop->from[n-1]); + tmp_str = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp_str, gfc_index_one_node); + + tmp_index = fold_build2_loc (input_location, 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]); + tmp_index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + tmp_index, rse.loop->from[0]); gfc_add_modify (&rse.loop->code[0], offset, tmp_index); - tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type, - rse.loop->loopvar[0], offset); + tmp_index = fold_build2_loc (input_location, 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); + tmp = build_fold_indirect_ref_loc (input_location, + info->data); rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL); if (expr->ts.type == BT_CHARACTER) - rse.string_length = expr->ts.cl->backend_decl; + rse.string_length = expr->ts.u.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); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ @@ -2326,7 +2514,47 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, /* Pass the string length to the argument expression. */ if (expr->ts.type == BT_CHARACTER) - parmse->string_length = expr->ts.cl->backend_decl; + parmse->string_length = expr->ts.u.cl->backend_decl; + + /* Determine the offset for pointer formal arguments and set the + lbounds to one. */ + if (formal_ptr) + { + size = gfc_index_one_node; + offset = gfc_index_zero_node; + for (n = 0; n < dimen; n++) + { + tmp = gfc_conv_descriptor_ubound_get (parmse->expr, + gfc_rank_cst[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&parmse->pre, + parmse->expr, + gfc_rank_cst[n], + tmp); + gfc_conv_descriptor_lbound_set (&parmse->pre, + parmse->expr, + gfc_rank_cst[n], + gfc_index_one_node); + size = gfc_evaluate_now (size, &parmse->pre); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, size); + offset = gfc_evaluate_now (offset, &parmse->pre); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + rse.loop->to[n], rse.loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + } + + gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr, + offset); + } /* We want either the address for the data or the address of the descriptor, depending on the mode of passing array arguments. */ @@ -2362,6 +2590,211 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* Takes a derived type expression and returns the address of a temporary + class object of the 'declared' type. */ +static void +gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) +{ + gfc_component *cmp; + gfc_symbol *vtab; + gfc_symbol *declared = class_ts.u.derived; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The derived type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + cmp = gfc_find_component (declared, "_vptr", true, true); + ctree = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + + /* Remember the vtab corresponds to the derived type + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + cmp = gfc_find_component (declared, "_data", true, true); + ctree = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + parmse->ss = NULL; + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + parmse->ss = ss; + gfc_conv_expr (parmse, e); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); +} + + +/* The following routine generates code for the intrinsic + procedures from the ISO_C_BINDING module: + * C_LOC (function) + * C_FUNLOC (function) + * C_F_POINTER (subroutine) + * C_F_PROCPOINTER (subroutine) + * C_ASSOCIATED (function) + One exception which is not handled here is C_F_POINTER with non-scalar + arguments. Returns 1 if the call was replaced by inline code (else: 0). */ + +static int +conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, + gfc_actual_arglist * arg) +{ + gfc_symbol *fsym; + gfc_ss *argss; + + if (sym->intmod_sym_id == ISOCBINDING_LOC) + { + if (arg->expr->rank == 0) + gfc_conv_expr_reference (se, arg->expr); + else + { + int f; + /* This is really the actual arg because no formal arglist is + created for C_LOC. */ + fsym = arg->expr->symtree->n.sym; + + /* We should want it to do g77 calling convention. */ + f = (fsym != NULL) + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as->type != AS_ASSUMED_SHAPE; + f = f || !sym->attr.always_explicit; + + argss = gfc_walk_expr (arg->expr); + gfc_conv_array_parameter (se, arg->expr, argss, f, + NULL, NULL, NULL); + } + + /* TODO -- the following two lines shouldn't be necessary, but if + they're removed, a bug is exposed later in the code path. + This workaround was thus introduced, but will have to be + removed; please see PR 35150 for details about the issue. */ + se->expr = convert (pvoid_type_node, se->expr); + se->expr = gfc_evaluate_now (se->expr, &se->pre); + + return 1; + } + else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) + { + arg->expr->ts.type = sym->ts.u.derived->ts.type; + arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; + arg->expr->ts.kind = sym->ts.u.derived->ts.kind; + gfc_conv_expr_reference (se, arg->expr); + + return 1; + } + else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER + && arg->next->expr->rank == 0) + || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) + { + /* Convert c_f_pointer if fptr is a scalar + and convert c_f_procpointer. */ + gfc_se cptrse; + gfc_se fptrse; + + gfc_init_se (&cptrse, NULL); + gfc_conv_expr (&cptrse, arg->expr); + gfc_add_block_to_block (&se->pre, &cptrse.pre); + gfc_add_block_to_block (&se->post, &cptrse.post); + + gfc_init_se (&fptrse, NULL); + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER + || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) + fptrse.want_pointer = 1; + + gfc_conv_expr (&fptrse, arg->next->expr); + gfc_add_block_to_block (&se->pre, &fptrse.pre); + gfc_add_block_to_block (&se->post, &fptrse.post); + + if (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); + + return 1; + } + else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) + { + gfc_se arg1se; + gfc_se arg2se; + + /* Build the addr_expr for the first argument. The argument is + already an *address* so we don't need to set want_pointer in + the gfc_se. */ + gfc_init_se (&arg1se, NULL); + gfc_conv_expr (&arg1se, arg->expr); + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + + /* See if we were given two arguments. */ + if (arg->next == NULL) + /* Only given one arg so generate a null and do a + not-equal comparison against the first arg. */ + se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + arg1se.expr, + fold_convert (TREE_TYPE (arg1se.expr), + null_pointer_node)); + else + { + tree eq_expr; + tree not_null_expr; + + /* Given two arguments so build the arg2se from second arg. */ + gfc_init_se (&arg2se, NULL); + gfc_conv_expr (&arg2se, arg->next->expr); + gfc_add_block_to_block (&se->pre, &arg2se.pre); + gfc_add_block_to_block (&se->post, &arg2se.post); + + /* Generate test to compare that the two args are equal. */ + eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + arg1se.expr, arg2se.expr); + /* Generate test to ensure that the first arg is not null. */ + not_null_expr = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + arg1se.expr, null_pointer_node); + + /* Finally, the generated test must check that both arg1 is not + NULL and that it is equal to the second arg. */ + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + not_null_expr, eq_expr); + } + + return 1; + } + + /* Nothing was done. */ + return 0; +} + /* 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. @@ -2369,12 +2802,12 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) int gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, - gfc_actual_arglist * arg, gfc_expr * expr, - tree append_args) + gfc_actual_arglist * args, gfc_expr * expr, + VEC(tree,gc) *append_args) { gfc_interface_mapping mapping; - tree arglist; - tree retargs; + VEC(tree,gc) *arglist; + VEC(tree,gc) *retargs; tree tmp; tree fntype; gfc_se parmse; @@ -2385,8 +2818,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree type; tree var; tree len; - tree stringargs; + VEC(tree,gc) *stringargs; + tree result = NULL; gfc_formal_arglist *formal; + gfc_actual_arglist *arg; int has_alternate_specifier = 0; bool need_interface_mapping; bool callee_alloc; @@ -2397,135 +2832,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t post; enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; + int arglen; - arglist = NULL_TREE; - retargs = NULL_TREE; - stringargs = NULL_TREE; + arglist = NULL; + retargs = NULL; + stringargs = NULL; var = NULL_TREE; len = NULL_TREE; gfc_clear_ts (&ts); - if (sym->from_intmod == INTMOD_ISO_C_BINDING) - { - if (sym->intmod_sym_id == ISOCBINDING_LOC) - { - if (arg->expr->rank == 0) - gfc_conv_expr_reference (se, arg->expr); - else - { - int f; - /* This is really the actual arg because no formal arglist is - created for C_LOC. */ - fsym = arg->expr->symtree->n.sym; - - /* We should want it to do g77 calling convention. */ - f = (fsym != NULL) - && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as->type != AS_ASSUMED_SHAPE; - f = f || !sym->attr.always_explicit; - - argss = gfc_walk_expr (arg->expr); - gfc_conv_array_parameter (se, arg->expr, argss, f, - NULL, NULL, NULL); - } - - /* TODO -- the following two lines shouldn't be necessary, but - they're removed a bug is exposed later in the codepath. - This is workaround was thus introduced, but will have to be - removed; please see PR 35150 for details about the issue. */ - se->expr = convert (pvoid_type_node, se->expr); - se->expr = gfc_evaluate_now (se->expr, &se->pre); - - return 0; - } - else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) - { - arg->expr->ts.type = sym->ts.derived->ts.type; - arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type; - arg->expr->ts.kind = sym->ts.derived->ts.kind; - gfc_conv_expr_reference (se, arg->expr); - - return 0; - } - else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER - && arg->next->expr->rank == 0) - || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) - { - /* Convert c_f_pointer if fptr is a scalar - and convert c_f_procpointer. */ - gfc_se cptrse; - gfc_se fptrse; - - gfc_init_se (&cptrse, NULL); - gfc_conv_expr (&cptrse, arg->expr); - gfc_add_block_to_block (&se->pre, &cptrse.pre); - gfc_add_block_to_block (&se->post, &cptrse.post); - - gfc_init_se (&fptrse, NULL); - if (sym->intmod_sym_id == ISOCBINDING_F_POINTER - || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) - fptrse.want_pointer = 1; - - gfc_conv_expr (&fptrse, arg->next->expr); - gfc_add_block_to_block (&se->pre, &fptrse.pre); - gfc_add_block_to_block (&se->post, &fptrse.post); - - if (gfc_is_proc_ptr_comp (arg->next->expr, NULL)) - tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component); - else - tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl); - se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr, - fold_convert (tmp, cptrse.expr)); - - return 0; - } - else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) - { - gfc_se arg1se; - gfc_se arg2se; - - /* Build the addr_expr for the first argument. The argument is - already an *address* so we don't need to set want_pointer in - the gfc_se. */ - gfc_init_se (&arg1se, NULL); - gfc_conv_expr (&arg1se, arg->expr); - gfc_add_block_to_block (&se->pre, &arg1se.pre); - gfc_add_block_to_block (&se->post, &arg1se.post); - - /* See if we were given two arguments. */ - if (arg->next == NULL) - /* Only given one arg so generate a null and do a - not-equal comparison against the first arg. */ - se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr, - fold_convert (TREE_TYPE (arg1se.expr), - null_pointer_node)); - else - { - tree eq_expr; - tree not_null_expr; - - /* Given two arguments so build the arg2se from second arg. */ - gfc_init_se (&arg2se, NULL); - gfc_conv_expr (&arg2se, arg->next->expr); - gfc_add_block_to_block (&se->pre, &arg2se.pre); - gfc_add_block_to_block (&se->post, &arg2se.post); - - /* Generate test to compare that the two args are equal. */ - eq_expr = fold_build2 (EQ_EXPR, boolean_type_node, - arg1se.expr, arg2se.expr); - /* Generate test to ensure that the first arg is not null. */ - not_null_expr = fold_build2 (NE_EXPR, boolean_type_node, - arg1se.expr, null_pointer_node); - - /* Finally, the generated test must check that both arg1 is not - NULL and that it is equal to the second arg. */ - se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - not_null_expr, eq_expr); - } - - return 0; - } - } + if (sym->from_intmod == INTMOD_ISO_C_BINDING + && conv_isocbinding_procedure (se, sym, args)) + return 0; gfc_is_proc_ptr_comp (expr, &comp); @@ -2534,18 +2852,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (!sym->attr.elemental) { gcc_assert (se->ss->type == GFC_SS_FUNCTION); - if (se->ss->useflags) - { + if (se->ss->useflags) + { gcc_assert ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) || (comp && comp->attr.dimension)); - gcc_assert (se->loop != NULL); + gcc_assert (se->loop != NULL); - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); - return 0; - } + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + return 0; + } } info = &se->ss->data.info; } @@ -2554,22 +2871,35 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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) - || (comp && comp->attr.dimension) - || (!comp && sym->attr.dimension)); - formal = sym->formal; + if (!comp) + { + formal = sym->formal; + need_interface_mapping = sym->attr.dimension || + (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type + != EXPR_CONSTANT); + } + else + { + formal = comp->formal; + need_interface_mapping = comp->attr.dimension || + (comp->ts.type == BT_CHARACTER + && comp->ts.u.cl->length + && comp->ts.u.cl->length->expr_type + != EXPR_CONSTANT); + } + /* Evaluate the arguments. */ - for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + for (arg = args; 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 @@ -2578,23 +2908,40 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else if (arg->label) { - has_alternate_specifier = 1; - continue; + 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) + if (arg->missing_arg_type == BT_CHARACTER) parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } + else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer) + { + /* Pass a NULL pointer to denote an absent arg. */ + gcc_assert (fsym->attr.optional && !fsym->attr.allocatable); + 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 (fsym && fsym->ts.type == BT_CLASS + && e->ts.type == BT_DERIVED) + { + /* The derived type needs to be converted to a temporary + CLASS object. */ + gfc_init_se (&parmse, se); + gfc_conv_derived_to_class (&parmse, e, fsym->ts); + } 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); + gfc_init_se (&parmse, se); + gfc_conv_expr_reference (&parmse, e); parm_kind = ELEMENTAL; } else @@ -2604,7 +2951,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) - { + { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.cray_pointee && fsym && fsym->attr.flavor == FL_PROCEDURE) @@ -2636,14 +2983,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, through arg->name. */ conv_arglist_function (&parmse, arg->expr, arg->name); else if ((e->expr_type == EXPR_FUNCTION) - && e->symtree->n.sym->attr.pointer - && fsym && fsym->attr.target) + && ((e->value.function.esym + && e->value.function.esym->result->attr.pointer) + || (!e->value.function.esym + && e->symtree->n.sym->attr.pointer)) + && fsym && fsym->attr.target) { gfc_conv_expr (&parmse, e); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } else if (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym->result + && e->symtree->n.sym->result != e->symtree->n.sym && e->symtree->n.sym->result->attr.proc_pointer) { /* Functions returning procedure pointers. */ @@ -2654,12 +3005,48 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { gfc_conv_expr_reference (&parmse, e); + + /* 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) + { + stmtblock_t block; + + gfc_init_block (&block); + tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, + true, NULL); + gfc_add_expr_to_block (&block, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, parmse.expr, + null_pointer_node); + gfc_add_expr_to_block (&block, tmp); + + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + + gfc_add_expr_to_block (&se->pre, tmp); + } + if (fsym && e->expr_type != EXPR_NULL && ((fsym->attr.pointer && fsym->attr.flavor != FL_PROCEDURE) || (fsym->attr.proc_pointer && !(e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.dummy)))) + && e->symtree->n.sym->attr.dummy)) + || (e->expr_type == EXPR_VARIABLE + && gfc_is_proc_ptr_comp (e, NULL)) + || fsym->attr.allocatable)) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -2677,11 +3064,52 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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; + bool f; f = (fsym != NULL) && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as->type != AS_ASSUMED_SHAPE; - f = f || !sym->attr.always_explicit; + && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE; + if (comp) + f = f || !comp->attr.always_explicit; + else + f = f || !sym->attr.always_explicit; + + /* If the argument is a function call that may not create + a temporary for the result, we have to check that we + can do it, i.e. that there is no alias between this + argument and another one. */ + if (gfc_get_noncopying_intrinsic_argument (e) != NULL) + { + gfc_expr *iarg; + sym_intent intent; + + if (fsym != NULL) + intent = fsym->attr.intent; + else + intent = INTENT_UNKNOWN; + + if (gfc_check_fncall_dependency (e, intent, sym, args, + NOT_ELEMENTAL)) + parmse.force_tmp = 1; + + iarg = e->value.function.actual->expr; + + /* Temporary needed if aliasing due to host association. */ + if (sym->attr.contained + && !sym->attr.pure + && !sym->attr.implicit_pure + && !sym->attr.use_assoc + && iarg->expr_type == EXPR_VARIABLE + && sym->ns == iarg->symtree->n.sym->ns) + parmse.force_tmp = 1; + + /* Ditto within module. */ + if (sym->attr.use_assoc + && !sym->attr.pure + && !sym->attr.implicit_pure + && iarg->expr_type == EXPR_VARIABLE + && sym->module == iarg->symtree->n.sym->module) + parmse.force_tmp = 1; + } if (e->expr_type == EXPR_VARIABLE && is_subref_array (e)) @@ -2690,21 +3118,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, is converted to a temporary, which is passed and then written back after the procedure call. */ gfc_conv_subref_array_arg (&parmse, e, f, - fsym ? fsym->attr.intent : INTENT_INOUT); + fsym ? fsym->attr.intent : INTENT_INOUT, + fsym && fsym->attr.pointer); else gfc_conv_array_parameter (&parmse, e, argss, f, fsym, sym->name, NULL); - /* 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); - } - + /* 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_loc (input_location, + parmse.expr); + tmp = gfc_trans_dealloc_allocated (tmp); + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->pre, tmp); + } } } @@ -2716,9 +3152,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (e && (fsym == NULL || fsym->attr.optional)) { /* If an optional argument is itself an optional dummy argument, - check its presence and substitute a null if absent. */ + check its presence and substitute a null if absent. This is + only needed when passing an array to an elemental procedure + as then array elements are accessed - or no NULL pointer is + allowed and a "1" or "0" should be passed if not present. + When passing a non-array-descriptor full array to a + non-array-descriptor dummy, no check is needed. For + array-descriptor actual to array-descriptor dummy, see + PR 41911 for why a check has to be inserted. + fsym == NULL is checked as intrinsics required the descriptor + but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional) + && e->symtree->n.sym->attr.optional + && ((e->rank > 0 && sym->attr.elemental) + || e->representation.length || e->ts.type == BT_CHARACTER + || (e->rank > 0 + && (fsym == NULL + || (fsym-> as + && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_DEFERRED)))))) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); } @@ -2731,11 +3183,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && 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 - && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT) + && e->symtree->n.sym->ts.u.cl->length != NULL + && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); - parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl; + gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); + parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; } } @@ -2749,12 +3201,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, deallocated for 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 + && e->ts.u.derived->attr.alloc_comp && !(e->symtree && e->symtree->n.sym->attr.pointer) && (e->expr_type != EXPR_VARIABLE && !e->rank)) { int parm_rank; - tmp = build_fold_indirect_ref (parmse.expr); + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); parm_rank = e->rank; switch (parm_kind) { @@ -2764,7 +3217,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, break; case (SCALAR_POINTER): - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); break; } @@ -2774,11 +3228,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree local_tmp; local_tmp = gfc_evaluate_now (tmp, &se->pre); - local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank); + local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank); gfc_add_expr_to_block (&se->post, local_tmp); } - tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); + tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank); gfc_add_expr_to_block (&se->post, tmp); } @@ -2788,45 +3242,34 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL) { - symbol_attribute *attr; + symbol_attribute attr; char *msg; tree cond; - if (e->expr_type == EXPR_VARIABLE) - attr = &e->symtree->n.sym->attr; - else if (e->expr_type == EXPR_FUNCTION) - { - /* For intrinsic functions, the gfc_attr are not available. */ - if (e->symtree->n.sym->attr.generic && e->value.function.isym) - goto end_pointer_check; - - if (e->symtree->n.sym->attr.generic) - attr = &e->value.function.esym->attr; - else - attr = &e->symtree->n.sym->result->attr; - } + if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) + attr = gfc_expr_attr (e); else goto end_pointer_check; - if (attr->optional) + if (attr.optional) { /* If the actual argument is an optional pointer/allocatable and the formal argument takes an nonpointer optional value, it is invalid to pass a non-present argument on, even though there is no technical reason for this in gfortran. See Fortran 2003, Section 12.4.1.6 item (7)+(8). */ - tree present, nullptr, type; + tree present, null_ptr, type; - if (attr->allocatable + if (attr.allocatable && (fsym == NULL || !fsym->attr.allocatable)) asprintf (&msg, "Allocatable actual argument '%s' is not " "allocated or not present", e->symtree->n.sym->name); - else if (attr->pointer + else if (attr.pointer && (fsym == NULL || !fsym->attr.pointer)) asprintf (&msg, "Pointer actual argument '%s' is not " "associated or not present", e->symtree->n.sym->name); - else if (attr->proc_pointer + else if (attr.proc_pointer && (fsym == NULL || !fsym->attr.proc_pointer)) asprintf (&msg, "Proc-pointer actual argument '%s' is not " "associated or not present", @@ -2836,25 +3279,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, present = gfc_conv_expr_present (e->symtree->n.sym); type = TREE_TYPE (present); - present = fold_build2 (EQ_EXPR, boolean_type_node, present, - fold_convert (type, null_pointer_node)); + present = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, present, + fold_convert (type, + null_pointer_node)); type = TREE_TYPE (parmse.expr); - nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (type, null_pointer_node)); - cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, - present, nullptr); + null_ptr = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, parmse.expr, + fold_convert (type, + null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + boolean_type_node, present, null_ptr); } else { - if (attr->allocatable + if (attr.allocatable && (fsym == NULL || !fsym->attr.allocatable)) asprintf (&msg, "Allocatable actual argument '%s' is not " "allocated", e->symtree->n.sym->name); - else if (attr->pointer + else if (attr.pointer && (fsym == NULL || !fsym->attr.pointer)) asprintf (&msg, "Pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); - else if (attr->proc_pointer + else if (attr.proc_pointer && (fsym == NULL || !fsym->attr.proc_pointer)) asprintf (&msg, "Proc-pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); @@ -2862,9 +3309,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, goto end_pointer_check; - cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (TREE_TYPE (parmse.expr), - null_pointer_node)); + cond = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, parmse.expr, + fold_convert (TREE_TYPE (parmse.expr), + null_pointer_node)); } gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, @@ -2877,18 +3325,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) - stringargs = gfc_chainon_list (stringargs, parmse.string_length); + VEC_safe_push (tree, gc, stringargs, parmse.string_length); - arglist = gfc_chainon_list (arglist, parmse.expr); + VEC_safe_push (tree, gc, arglist, parmse.expr); } gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); - ts = sym->ts; + if (comp) + ts = comp->ts; + else + ts = sym->ts; + if (ts.type == BT_CHARACTER && sym->attr.is_bind_c) se->string_length = build_int_cst (gfc_charlen_type_node, 1); else if (ts.type == BT_CHARACTER) { - if (sym->ts.cl->length == NULL) + if (ts.u.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 @@ -2897,43 +3349,44 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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); + cl.backend_decl = VEC_index (tree, stringargs, 0); 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; + cl.backend_decl = formal->sym->ts.u.cl->backend_decl; } } - else + else { tree tmp; /* 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); + gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length); else - gfc_conv_expr (&parmse, sym->ts.cl->length); + gfc_conv_expr (&parmse, ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); tmp = fold_convert (gfc_charlen_type_node, parmse.expr); - tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, - build_int_cst (gfc_charlen_type_node, 0)); + tmp = fold_build2_loc (input_location, MAX_EXPR, + gfc_charlen_type_node, tmp, + build_int_cst (gfc_charlen_type_node, 0)); cl.backend_decl = tmp; } /* Set up a charlen structure for it. */ cl.next = NULL; cl.length = NULL; - ts.cl = &cl; + ts.u.cl = &cl; len = cl.backend_decl; } - byref = (comp && comp->attr.dimension) + byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER)) || (!comp && gfc_return_by_reference (sym)); if (byref) { @@ -2945,9 +3398,34 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))))) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + + /* If the lhs of an assignment x = f(..) is allocatable and + f2003 is allowed, we must do the automatic reallocation. + TODO - deal with intrinsics, without using a temporary. */ + if (gfc_option.flag_realloc_lhs + && se->ss && se->ss->loop_chain + && se->ss->loop_chain->is_alloc_lhs + && !expr->value.function.isym + && sym->result->as != NULL) + { + /* Evaluate the bounds of the result, if known. */ + gfc_set_loop_bounds_from_array_spec (&mapping, se, + sym->result->as); - retargs = gfc_chainon_list (retargs, se->expr); + /* Perform the automatic reallocation. */ + tmp = gfc_alloc_allocatable_for_assignment (se->loop, + expr, NULL); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Pass the temporary as the first argument. */ + result = info->descriptor; + } + else + result = build_fold_indirect_ref_loc (input_location, + se->expr); + VEC_safe_push (tree, gc, retargs, se->expr); } else if (comp && comp->attr.dimension) { @@ -2960,6 +3438,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Evaluate the bounds of the result, if known. */ gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as); + /* If the lhs of an assignment x = f(..) is allocatable and + f2003 is allowed, we must not generate the function call + here but should just send back the results of the mapping. + This is signalled by the function ss being flagged. */ + if (gfc_option.flag_realloc_lhs + && se->ss && se->ss->is_alloc_lhs) + { + gfc_free_interface_mapping (&mapping); + return has_alternate_specifier; + } + /* 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. */ @@ -2969,11 +3458,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - retargs = gfc_chainon_list (retargs, tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); + VEC_safe_push (tree, gc, retargs, tmp); } - else if (sym->result->attr.dimension) + else if (!comp && sym->result->attr.dimension) { gcc_assert (se->loop && info); @@ -2984,6 +3473,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Evaluate the bounds of the result, if known. */ gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as); + /* If the lhs of an assignment x = f(..) is allocatable and + f2003 is allowed, we must not generate the function call + here but should just send back the results of the mapping. + This is signalled by the function ss being flagged. */ + if (gfc_option.flag_realloc_lhs + && se->ss && se->ss->is_alloc_lhs) + { + gfc_free_interface_mapping (&mapping); + return has_alternate_specifier; + } + /* 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. */ @@ -2993,29 +3493,36 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - retargs = gfc_chainon_list (retargs, tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); + VEC_safe_push (tree, gc, retargs, tmp); } else if (ts.type == BT_CHARACTER) { /* Pass the string length. */ - type = gfc_get_character_type (ts.kind, ts.cl); + type = gfc_get_character_type (ts.kind, ts.u.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) + if ((!comp && (sym->attr.pointer || sym->attr.allocatable)) + || (comp && (comp->attr.pointer || comp->attr.allocatable))) { var = gfc_create_var (type, "pstr"); - /* Provide an address expression for the function arguments. */ + if ((!comp && sym->attr.allocatable) + || (comp && comp->attr.allocatable)) + gfc_add_modify (&se->pre, var, + fold_convert (TREE_TYPE (var), + null_pointer_node)); + + /* Provide an address expression for the function arguments. */ var = gfc_build_addr_expr (NULL_TREE, var); } else var = gfc_conv_string_tmp (se, type, len); - retargs = gfc_chainon_list (retargs, var); + VEC_safe_push (tree, gc, retargs, var); } else { @@ -3023,25 +3530,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, type = gfc_get_complex_type (ts.kind); var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx")); - retargs = gfc_chainon_list (retargs, var); + VEC_safe_push (tree, gc, retargs, var); } /* Add the string length to the argument list. */ if (ts.type == BT_CHARACTER) - retargs = gfc_chainon_list (retargs, len); + VEC_safe_push (tree, gc, retargs, len); } gfc_free_interface_mapping (&mapping); + /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */ + arglen = (VEC_length (tree, arglist) + + VEC_length (tree, stringargs) + VEC_length (tree, append_args)); + VEC_reserve_exact (tree, gc, retargs, arglen); + /* Add the return arguments. */ - arglist = chainon (retargs, arglist); + VEC_splice (tree, retargs, arglist); /* Add the hidden string length parameters to the arguments. */ - arglist = chainon (arglist, stringargs); + VEC_splice (tree, retargs, 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); + if (!VEC_empty (tree, append_args)) + VEC_splice (tree, retargs, append_args); + arglist = retargs; /* Generate the actual call. */ conv_function_val (se, sym, expr); @@ -3065,15 +3578,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } fntype = TREE_TYPE (TREE_TYPE (se->expr)); - se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist); + se->expr = build_call_vec (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 + if (!se->want_pointer && !byref + && (sym->attr.pointer || sym->attr.allocatable) && !gfc_is_proc_ptr_comp (expr, NULL)) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); /* f2c calling conventions require a scalar default real function to return a double precision result. Convert this back to default @@ -3100,15 +3615,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (!se->direct_byref) { - if (sym->attr.dimension || (comp && comp->attr.dimension)) + if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension)) { if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { /* Check the data pointer hasn't been modified. This would happen in a function returning a pointer. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); - tmp = fold_build2 (NE_EXPR, boolean_type_node, - tmp, info->data); + tmp = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + tmp, info->data); gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL, gfc_msg_fault); } @@ -3116,11 +3632,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Bundle in the string length. */ se->string_length = len; } - else if (sym->ts.type == BT_CHARACTER) + else if (ts.type == BT_CHARACTER) { /* Dereference for character pointer results. */ - if (sym->attr.pointer || sym->attr.allocatable) - se->expr = build_fold_indirect_ref (var); + if ((!comp && (sym->attr.pointer || sym->attr.allocatable)) + || (comp && (comp->attr.pointer || comp->attr.allocatable))) + se->expr = build_fold_indirect_ref_loc (input_location, var); else se->expr = var; @@ -3128,15 +3645,44 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else { - gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c); - se->expr = build_fold_indirect_ref (var); + gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c); + se->expr = build_fold_indirect_ref_loc (input_location, var); } } } /* Follow the function call with the argument post block. */ if (byref) - gfc_add_block_to_block (&se->pre, &post); + { + gfc_add_block_to_block (&se->pre, &post); + + /* Transformational functions of derived types with allocatable + components must have the result allocatable components copied. */ + arg = expr->value.function.actual; + if (result && arg && expr->rank + && expr->value.function.isym + && expr->value.function.isym->transformational + && arg->expr->ts.type == BT_DERIVED + && arg->expr->ts.u.derived->attr.alloc_comp) + { + tree tmp2; + /* Copy the allocatable components. We have to use a + temporary here to prevent source allocatable components + from being corrupted. */ + tmp2 = gfc_evaluate_now (result, &se->pre); + tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived, + result, tmp2, expr->rank); + gfc_add_expr_to_block (&se->pre, tmp); + tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2), + expr->rank); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Finally free the temporary's data field. */ + tmp = gfc_conv_descriptor_data_get (tmp2); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL); + gfc_add_expr_to_block (&se->pre, tmp); + } + } else gfc_add_block_to_block (&se->post, &post); @@ -3154,7 +3700,8 @@ fill_with_spaces (tree start, tree type, tree size) /* For a simple char type, we can call memset(). */ if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) - return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start, + return build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMSET], 3, start, build_int_cst (gfc_get_int_type (gfc_c_int_kind), lang_hooks.to_target_charset (' ')), size); @@ -3178,24 +3725,25 @@ fill_with_spaces (tree start, tree type, tree size) gfc_init_block (&loop); /* Exit condition. */ - cond = fold_build2 (LE_EXPR, boolean_type_node, i, - fold_convert (sizetype, integer_zero_node)); + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i, + build_zero_cst (sizetype)); tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&loop, tmp); /* Assignment. */ - gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el), - build_int_cst (type, - lang_hooks.to_target_charset (' '))); + gfc_add_modify (&loop, + fold_build1_loc (input_location, INDIRECT_REF, type, el), + build_int_cst (type, lang_hooks.to_target_charset (' '))); /* Increment loop variables. */ - gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i, - TYPE_SIZE_UNIT (type))); - gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR, - TREE_TYPE (el), el, - TYPE_SIZE_UNIT (type))); + gfc_add_modify (&loop, i, + fold_build2_loc (input_location, MINUS_EXPR, sizetype, i, + TYPE_SIZE_UNIT (type))); + gfc_add_modify (&loop, el, + fold_build2_loc (input_location, POINTER_PLUS_EXPR, + TREE_TYPE (el), el, TYPE_SIZE_UNIT (type))); /* Making the loop... actually loop! */ tmp = gfc_finish_block (&loop); @@ -3233,7 +3781,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = string_to_single_character (slen, src, skind); + ssc = gfc_string_to_single_character (slen, src, skind); } else { @@ -3244,7 +3792,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = string_to_single_character (slen, dest, dkind); + dsc = gfc_string_to_single_character (dlen, dest, dkind); } else { @@ -3252,12 +3800,6 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, dsc = dest; } - if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) - ssc = string_to_single_character (slen, src, skind); - if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) - dsc = string_to_single_character (dlen, dest, dkind); - - /* Assign directly if the types are compatible. */ if (dsc != NULL_TREE && ssc != NULL_TREE && TREE_TYPE (dsc) == TREE_TYPE (ssc)) @@ -3267,8 +3809,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, } /* Do nothing if the destination length is zero. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, dlen, - build_int_cst (size_type_node, 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen, + build_int_cst (size_type_node, 0)); /* The following code was previously in _gfortran_copy_string: @@ -3296,37 +3838,42 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* For non-default character kinds, we have to multiply the string length by the base type size. */ chartype = gfc_get_char_type (dkind); - slen = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, slen), - fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype))); - dlen = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, dlen), - fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype))); - - if (dlength) + slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, slen), + fold_convert (size_type_node, + TYPE_SIZE_UNIT (chartype))); + dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, dlen), + fold_convert (size_type_node, + TYPE_SIZE_UNIT (chartype))); + + if (dlength && POINTER_TYPE_P (TREE_TYPE (dest))) dest = fold_convert (pvoid_type_node, dest); else dest = gfc_build_addr_expr (pvoid_type_node, dest); - if (slength) + if (slength && POINTER_TYPE_P (TREE_TYPE (src))) src = fold_convert (pvoid_type_node, src); else src = gfc_build_addr_expr (pvoid_type_node, src); /* 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], + cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen, + dlen); + tmp2 = build_call_expr_loc (input_location, + 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], + tmp3 = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMMOVE], 3, dest, src, slen); - tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest, - fold_convert (sizetype, slen)); + tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest), + dest, fold_convert (sizetype, slen)); tmp4 = fill_with_spaces (tmp4, chartype, - fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), - dlen, slen)); + fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE(dlen), dlen, slen)); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); @@ -3334,9 +3881,10 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, 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 (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, + tmp2, tmp3); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } @@ -3379,35 +3927,42 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) gcc_assert (fargs->sym->attr.dimension == 0); fsym = fargs->sym; - /* Create a temporary to hold the value. */ - type = gfc_typenode_for_spec (&fsym->ts); - temp_vars[n] = gfc_create_var (type, fsym->name); - if (fsym->ts.type == BT_CHARACTER) { /* Copy string arguments. */ - tree arglen; + tree arglen; - gcc_assert (fsym->ts.cl && fsym->ts.cl->length - && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length + && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT); - arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - tmp = gfc_build_addr_expr (build_pointer_type (type), - temp_vars[n]); + /* Create a temporary to hold the value. */ + if (fsym->ts.u.cl->backend_decl == NULL_TREE) + fsym->ts.u.cl->backend_decl + = gfc_conv_constant_to_tree (fsym->ts.u.cl->length); - gfc_conv_expr (&rse, args->expr); - gfc_conv_string_parameter (&rse); - gfc_add_block_to_block (&se->pre, &lse.pre); - gfc_add_block_to_block (&se->pre, &rse.pre); + type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl); + temp_vars[n] = gfc_create_var (type, fsym->name); - gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind, + arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + + gfc_conv_expr (&rse, args->expr); + gfc_conv_string_parameter (&rse); + gfc_add_block_to_block (&se->pre, &lse.pre); + gfc_add_block_to_block (&se->pre, &rse.pre); + + gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind, rse.string_length, rse.expr, fsym->ts.kind); - gfc_add_block_to_block (&se->pre, &lse.post); - gfc_add_block_to_block (&se->pre, &rse.post); + gfc_add_block_to_block (&se->pre, &lse.post); + gfc_add_block_to_block (&se->pre, &rse.post); } else { /* For everything else, just evaluate the expression. */ + + /* Create a temporary to hold the value. */ + type = gfc_typenode_for_spec (&fsym->ts); + temp_vars[n] = gfc_create_var (type, fsym->name); + gfc_conv_expr (&lse, args->expr); gfc_add_block_to_block (&se->pre, &lse.pre); @@ -3426,22 +3981,22 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) if (sym->ts.type == BT_CHARACTER) { - gfc_conv_const_charlen (sym->ts.cl); + gfc_conv_const_charlen (sym->ts.u.cl); /* Force the expression to the correct length. */ if (!INTEGER_CST_P (se->string_length) || tree_int_cst_lt (se->string_length, - sym->ts.cl->backend_decl)) + sym->ts.u.cl->backend_decl)) { - type = gfc_get_character_type (sym->ts.kind, sym->ts.cl); + type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl); tmp = gfc_create_var (type, sym->name); tmp = gfc_build_addr_expr (build_pointer_type (type), tmp); - gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp, + gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp, sym->ts.kind, se->string_length, se->expr, sym->ts.kind); se->expr = tmp; } - se->string_length = sym->ts.cl->backend_decl; + se->string_length = sym->ts.u.cl->backend_decl; } /* Restore the original variables. */ @@ -3451,22 +4006,6 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) } -/* Return the backend_decl for a procedure pointer component. */ - -tree -gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e) -{ - gfc_se comp_se; - gfc_expr *e2; - gfc_init_se (&comp_se, NULL); - e2 = gfc_copy_expr (e); - e2->expr_type = EXPR_VARIABLE; - gfc_conv_expr (&comp_se, e2); - comp_se.expr = build_fold_addr_expr (comp_se.expr); - return gfc_evaluate_now (comp_se.expr, &se->pre); -} - - /* Translate a function expression. */ static void @@ -3494,8 +4033,44 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) if (!sym) sym = expr->symtree->n.sym; - gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, - NULL_TREE); + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL); +} + + +/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ + +static bool +is_zero_initializer_p (gfc_expr * expr) +{ + if (expr->expr_type != EXPR_CONSTANT) + return false; + + /* We ignore constants with prescribed memory representations for now. */ + if (expr->representation.string) + return false; + + 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 (mpc_realref (expr->value.complex)) + && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0 + && mpfr_zero_p (mpc_imagref (expr->value.complex)) + && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0; + + default: + break; + } + return false; } @@ -3506,7 +4081,6 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR); gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); } @@ -3516,11 +4090,11 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) tree gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, - bool array, bool pointer) + bool array, bool pointer, bool procptr) { gfc_se se; - if (!(expr || pointer)) + if (!(expr || pointer || procptr)) return NULL_TREE; /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR @@ -3528,43 +4102,74 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, used as initialization expressions). If so, we need to modify the 'expr' to be that for a (void *). */ if (expr != NULL && expr->ts.type == BT_DERIVED - && expr->ts.is_iso_c && expr->ts.derived) + && expr->ts.is_iso_c && expr->ts.u.derived) { - gfc_symbol *derived = expr->ts.derived; - - expr = gfc_int_expr (0); + gfc_symbol *derived = expr->ts.u.derived; /* The derived symbol has already been converted to a (void *). Use its kind. */ + expr = gfc_get_int_expr (derived->ts.kind, NULL, 0); expr->ts.f90_type = derived->ts.f90_type; - expr->ts.kind = derived->ts.kind; + + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, expr); + gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); + return se.expr; } - if (array) + if (array && !procptr) { + tree ctor; /* Arrays need special handling. */ if (pointer) - return gfc_build_null_descriptor (type); + ctor = gfc_build_null_descriptor (type); + /* Special case assigning an array to zero. */ + else if (is_zero_initializer_p (expr)) + ctor = build_constructor (type, NULL); else - return gfc_conv_array_initializer (type, expr); + ctor = gfc_conv_array_initializer (type, expr); + TREE_STATIC (ctor) = 1; + return ctor; + } + else if (pointer || procptr) + { + if (!expr || expr->expr_type == EXPR_NULL) + return fold_convert (type, null_pointer_node); + else + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); + return se.expr; + } } - else if (pointer) - return fold_convert (type, null_pointer_node); else { switch (ts->type) { case BT_DERIVED: + case BT_CLASS: gfc_init_se (&se, NULL); - gfc_conv_structure (&se, expr, 1); + if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) + gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); + else + gfc_conv_structure (&se, expr, 1); + gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); + TREE_STATIC (se.expr) = 1; return se.expr; case BT_CHARACTER: - return gfc_conv_string_init (ts->cl->backend_decl,expr); + { + tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr); + TREE_STATIC (ctor) = 1; + return ctor; + } default: gfc_init_se (&se, NULL); gfc_conv_constant (&se, expr); + gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } } @@ -3648,11 +4253,11 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_tmp_array_ref (&lse); if (cm->ts.type == BT_CHARACTER) - lse.string_length = cm->ts.cl->backend_decl; + lse.string_length = cm->ts.u.cl->backend_decl; gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -3674,6 +4279,150 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) } +static tree +gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, + gfc_expr * expr) +{ + gfc_se se; + gfc_ss *rss; + stmtblock_t block; + tree offset; + int n; + tree tmp; + tree tmp2; + gfc_array_spec *as; + gfc_expr *arg = NULL; + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + + /* Get the descriptor for the expressions. */ + rss = gfc_walk_expr (expr); + se.want_pointer = 0; + gfc_conv_expr_descriptor (&se, expr, rss); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_modify (&block, dest, se.expr); + + /* Deal with arrays of derived types with allocatable components. */ + if (cm->ts.type == BT_DERIVED + && cm->ts.u.derived->attr.alloc_comp) + tmp = gfc_copy_alloc_comp (cm->ts.u.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); + + if (expr->expr_type != EXPR_VARIABLE) + gfc_conv_descriptor_data_set (&block, se.expr, + null_pointer_node); + + /* We need to know if the argument of a conversion function is a + variable, so that the correct lower bound can be used. */ + if (expr->expr_type == EXPR_FUNCTION + && expr->value.function.isym + && expr->value.function.isym->conversion + && expr->value.function.actual->expr + && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE) + arg = expr->value.function.actual->expr; + + /* Obtain the array spec of full array references. */ + if (arg) + as = gfc_get_full_arrayspec_from_expr (arg); + else + as = gfc_get_full_arrayspec_from_expr (expr); + + /* Shift the lbound and ubound of temporaries to being unity, + rather than zero, based. Always calculate the offset. */ + offset = gfc_conv_descriptor_offset_get (dest); + gfc_add_modify (&block, offset, gfc_index_zero_node); + tmp2 =gfc_create_var (gfc_array_index_type, NULL); + + for (n = 0; n < expr->rank; n++) + { + tree span; + tree lbound; + + /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9. + TODO It looks as if gfc_conv_expr_descriptor should return + the correct bounds and that the following should not be + necessary. This would simplify gfc_conv_intrinsic_bound + as well. */ + if (as && as->lower[n]) + { + gfc_se lbse; + gfc_init_se (&lbse, NULL); + gfc_conv_expr (&lbse, as->lower[n]); + gfc_add_block_to_block (&block, &lbse.pre); + lbound = gfc_evaluate_now (lbse.expr, &block); + } + else if (as && arg) + { + tmp = gfc_get_symbol_decl (arg->symtree->n.sym); + lbound = gfc_conv_descriptor_lbound_get (tmp, + gfc_rank_cst[n]); + } + else if (as) + lbound = gfc_conv_descriptor_lbound_get (dest, + gfc_rank_cst[n]); + else + lbound = gfc_index_one_node; + + lbound = fold_convert (gfc_array_index_type, lbound); + + /* Shift the bounds and set the offset accordingly. */ + tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); + span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + span, lbound); + gfc_conv_descriptor_ubound_set (&block, dest, + gfc_rank_cst[n], tmp); + gfc_conv_descriptor_lbound_set (&block, dest, + gfc_rank_cst[n], lbound); + + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_lbound_get (dest, + gfc_rank_cst[n]), + gfc_conv_descriptor_stride_get (dest, + gfc_rank_cst[n])); + gfc_add_modify (&block, tmp2, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + offset, tmp2); + gfc_conv_descriptor_offset_set (&block, dest, tmp); + } + + if (arg) + { + /* If a conversion expression has a null data pointer + argument, nullify the allocatable component. */ + tree non_null_expr; + tree null_expr; + + if (arg->symtree->n.sym->attr.allocatable + || arg->symtree->n.sym->attr.pointer) + { + non_null_expr = gfc_finish_block (&block); + gfc_start_block (&block); + gfc_conv_descriptor_data_set (&block, dest, + null_pointer_node); + null_expr = gfc_finish_block (&block); + tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl); + tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + return build3_v (COND_EXPR, tmp, + null_expr, non_null_expr); + } + } + + return gfc_finish_block (&block); +} + + /* Assign a single component of a derived type constructor. */ static tree @@ -3684,8 +4433,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_ss *rss; stmtblock_t block; tree tmp; - tree offset; - int n; gfc_start_block (&block); @@ -3719,97 +4466,21 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_add_block_to_block (&block, &se.post); } } - else if (cm->attr.dimension) + else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL) + { + /* NULL initialization for CLASS components. */ + tmp = gfc_trans_structure_assign (dest, + gfc_class_null_initializer (&cm->ts)); + gfc_add_expr_to_block (&block, tmp); + } + else if (cm->attr.dimension && !cm->attr.proc_pointer) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); else if (cm->attr.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 (&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); - + tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &se.post); - - if (expr->expr_type != EXPR_VARIABLE) - 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_get (dest); - gfc_add_modify (&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) - { - tree span; - tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); - span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, - gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - span, gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n], - tmp); - gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n], - gfc_index_one_node); - } - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - gfc_conv_descriptor_lbound_get (dest, - gfc_rank_cst[n]), - gfc_conv_descriptor_stride_get (dest, - gfc_rank_cst[n])); - gfc_add_modify (&block, tmp2, tmp); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); - gfc_conv_descriptor_offset_set (&block, dest, tmp); - } - - if (expr->expr_type == EXPR_FUNCTION - && expr->value.function.isym - && expr->value.function.isym->conversion - && expr->value.function.actual->expr - && expr->value.function.actual->expr->expr_type - == EXPR_VARIABLE) - { - /* If a conversion expression has a null data pointer - argument, nullify the allocatable component. */ - gfc_symbol *s; - tree non_null_expr; - tree null_expr; - s = expr->value.function.actual->expr->symtree->n.sym; - if (s->attr.allocatable || s->attr.pointer) - { - non_null_expr = gfc_finish_block (&block); - gfc_start_block (&block); - gfc_conv_descriptor_data_set (&block, dest, - null_pointer_node); - null_expr = gfc_finish_block (&block); - tmp = gfc_conv_descriptor_data_get (s->backend_decl); - tmp = build2 (EQ_EXPR, boolean_type_node, tmp, - fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - return build3_v (COND_EXPR, tmp, null_expr, - non_null_expr); - } - } } else { @@ -3843,9 +4514,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&se, expr); if (cm->ts.type == BT_CHARACTER) - lse.string_length = cm->ts.cl->backend_decl; + lse.string_length = cm->ts.u.cl->backend_decl; lse.expr = dest; - tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -3863,16 +4534,35 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) tree tmp; gfc_start_block (&block); - cm = expr->ts.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + cm = expr->ts.u.derived->components; + + if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING + && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR + || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) + { + gfc_se se, lse; + + gcc_assert (cm->backend_decl == NULL); + gfc_init_se (&se, NULL); + gfc_init_se (&lse, NULL); + gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr); + lse.expr = dest; + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), se.expr)); + + return gfc_finish_block (&block); + } + + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { /* Skip absent members in default initializers. */ if (!c->expr) continue; field = cm->backend_decl; - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - dest, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + dest, field, NULL_TREE); tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr); gfc_add_expr_to_block (&block, tmp); } @@ -3899,15 +4589,16 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!init) { /* Create a temporary variable and fill it in. */ - se->expr = gfc_create_var (type, expr->ts.derived->name); + se->expr = gfc_create_var (type, expr->ts.u.derived->name); tmp = gfc_trans_structure_assign (se->expr, expr); gfc_add_expr_to_block (&se->pre, tmp); return; } - cm = expr->ts.derived->components; + cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { /* Skip absent members in default initializers and allocatable components. Although the latter have a default initializer @@ -3916,12 +4607,30 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->backend_decl), cm->attr.dimension, - cm->attr.pointer || cm->attr.proc_pointer); + if (strcmp (cm->name, "_size") == 0) + { + val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } + else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL + && strcmp (cm->name, "_extends") == 0) + { + tree vtab; + gfc_symbol *vtabs; + vtabs = cm->initializer->symtree->n.sym; + vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); + } + else + { + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (cm->backend_decl), + cm->attr.dimension, cm->attr.pointer, + cm->attr.proc_pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } } se->expr = build_constructor (type, v); if (init) @@ -3965,6 +4674,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) /* Substitute a scalar expression evaluated outside the scalarization loop. */ se->expr = se->ss->data.scalar.expr; + if (se->ss->type == GFC_SS_REFERENCE) + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); se->string_length = se->ss->string_length; gfc_advance_se_ss_chain (se); return; @@ -3975,11 +4686,13 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) null_pointer_node. C_PTR and C_FUNPTR are converted to match the typespec for the C_PTR and C_FUNPTR symbols, which has already been updated to be an integer with a kind equal to the size of a (void *). */ - if (expr->ts.type == BT_DERIVED && expr->ts.derived - && expr->ts.derived->attr.is_iso_c) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived + && expr->ts.u.derived->attr.is_iso_c) { - if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR - || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) + if (expr->expr_type == EXPR_VARIABLE + && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR + || expr->symtree->n.sym->intmod_sym_id + == ISOCBINDING_NULL_FUNPTR)) { /* Set expr_type to EXPR_NULL, which will result in null_pointer_node being used below. */ @@ -3989,9 +4702,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) { /* Update the type/kind of the expression to be what the new type/kind are for the updated symbols of C_PTR/C_FUNPTR. */ - expr->ts.type = expr->ts.derived->ts.type; - expr->ts.f90_type = expr->ts.derived->ts.f90_type; - expr->ts.kind = expr->ts.derived->ts.kind; + expr->ts.type = expr->ts.u.derived->ts.type; + expr->ts.f90_type = expr->ts.u.derived->ts.f90_type; + expr->ts.kind = expr->ts.u.derived->ts.kind; } } @@ -4085,9 +4798,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (se->ss && se->ss->expr == expr && se->ss->type == GFC_SS_REFERENCE) { - se->expr = se->ss->data.scalar.expr; - se->string_length = se->ss->string_length; - gfc_advance_se_ss_chain (se); + /* Returns a reference to the scalar evaluated outside the loop + for this case. */ + gfc_conv_expr (se, expr); return; } @@ -4113,8 +4826,12 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } if (expr->expr_type == EXPR_FUNCTION - && expr->symtree->n.sym->attr.pointer - && !expr->symtree->n.sym->attr.dimension) + && ((expr->value.function.esym + && expr->value.function.esym->result->attr.pointer + && !expr->value.function.esym->result->attr.dimension) + || (!expr->value.function.esym + && expr->symtree->n.sym->attr.pointer + && !expr->symtree->n.sym->attr.dimension))) { se->want_pointer = 1; gfc_conv_expr (se, expr); @@ -4189,18 +4906,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (expr1->symtree->n.sym->attr.proc_pointer && expr1->symtree->n.sym->attr.dummy) - lse.expr = build_fold_indirect_ref (lse.expr); + lse.expr = build_fold_indirect_ref_loc (input_location, + lse.expr); if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer && expr2->symtree->n.sym->attr.dummy) - rse.expr = build_fold_indirect_ref (rse.expr); + rse.expr = build_fold_indirect_ref_loc (input_location, + rse.expr); gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); /* Check character lengths if character expression. The test is only really added if -fbounds-check is enabled. */ - if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL) + if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL + && !expr1->symtree->n.sym->attr.proc_pointer + && !gfc_is_proc_ptr_comp (expr1, NULL)) { gcc_assert (expr2->ts.type == BT_CHARACTER); gcc_assert (lse.string_length && rse.string_length); @@ -4217,21 +4938,46 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) } else { + gfc_ref* remap; + bool rank_remap; tree strlen_lhs; tree strlen_rhs = NULL_TREE; - /* Array pointer. */ + /* Array pointer. Find the last reference on the LHS and if it is an + array section ref, we're dealing with bounds remapping. In this case, + set it to AR_FULL so that gfc_conv_expr_descriptor does + not see it and process the bounds remapping afterwards explicitely. */ + for (remap = expr1->ref; remap; remap = remap->next) + if (!remap->next && remap->type == REF_ARRAY + && remap->u.ar.type == AR_SECTION) + { + remap->u.ar.type = AR_FULL; + break; + } + rank_remap = (remap && remap->u.ar.end[0]); + gfc_conv_expr_descriptor (&lse, expr1, lss); strlen_lhs = lse.string_length; - switch (expr2->expr_type) + desc = lse.expr; + + if (expr2->expr_type == EXPR_NULL) { - 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. */ + } + else if (rank_remap) + { + /* If we are rank-remapping, just get the RHS's descriptor and + process this later on. */ + gfc_init_se (&rse, NULL); + rse.direct_byref = 1; + rse.byref_noassign = 1; + gfc_conv_expr_descriptor (&rse, expr2, rss); + strlen_rhs = rse.string_length; + } + else if (expr2->expr_type == EXPR_VARIABLE) + { + /* Assign directly to the LHS's descriptor. */ lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2, rss); strlen_rhs = lse.string_length; @@ -4250,13 +4996,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&lse.post, &rse.pre); gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); } - - break; - - default: + } + else + { /* 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; @@ -4264,10 +5008,130 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_expr_descriptor (&lse, expr2, rss); strlen_rhs = lse.string_length; gfc_add_modify (&lse.pre, desc, tmp); - break; } gfc_add_block_to_block (&block, &lse.pre); + if (rank_remap) + gfc_add_block_to_block (&block, &rse.pre); + + /* If we do bounds remapping, update LHS descriptor accordingly. */ + if (remap) + { + int dim; + gcc_assert (remap->u.ar.dimen == expr1->rank); + + if (rank_remap) + { + /* Do rank remapping. We already have the RHS's descriptor + converted in rse and now have to build the correct LHS + descriptor for it. */ + + tree dtype, data; + tree offs, stride; + tree lbound, ubound; + + /* Set dtype. */ + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_get_dtype (TREE_TYPE (desc)); + gfc_add_modify (&block, dtype, tmp); + + /* Copy data pointer. */ + data = gfc_conv_descriptor_data_get (rse.expr); + gfc_conv_descriptor_data_set (&block, desc, data); + + /* Copy offset but adjust it such that it would correspond + to a lbound of zero. */ + offs = gfc_conv_descriptor_offset_get (rse.expr); + for (dim = 0; dim < expr2->rank; ++dim) + { + stride = gfc_conv_descriptor_stride_get (rse.expr, + gfc_rank_cst[dim]); + lbound = gfc_conv_descriptor_lbound_get (rse.expr, + gfc_rank_cst[dim]); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, lbound); + offs = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offs, tmp); + } + gfc_conv_descriptor_offset_set (&block, desc, offs); + + /* Set the bounds as declared for the LHS and calculate strides as + well as another offset update accordingly. */ + stride = gfc_conv_descriptor_stride_get (rse.expr, + gfc_rank_cst[0]); + for (dim = 0; dim < expr1->rank; ++dim) + { + gfc_se lower_se; + gfc_se upper_se; + + gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]); + + /* Convert declared bounds. */ + gfc_init_se (&lower_se, NULL); + gfc_init_se (&upper_se, NULL); + gfc_conv_expr (&lower_se, remap->u.ar.start[dim]); + gfc_conv_expr (&upper_se, remap->u.ar.end[dim]); + + gfc_add_block_to_block (&block, &lower_se.pre); + gfc_add_block_to_block (&block, &upper_se.pre); + + lbound = fold_convert (gfc_array_index_type, lower_se.expr); + ubound = fold_convert (gfc_array_index_type, upper_se.expr); + + lbound = gfc_evaluate_now (lbound, &block); + ubound = gfc_evaluate_now (ubound, &block); + + gfc_add_block_to_block (&block, &lower_se.post); + gfc_add_block_to_block (&block, &upper_se.post); + + /* Set bounds in descriptor. */ + gfc_conv_descriptor_lbound_set (&block, desc, + gfc_rank_cst[dim], lbound); + gfc_conv_descriptor_ubound_set (&block, desc, + gfc_rank_cst[dim], ubound); + + /* Set stride. */ + stride = gfc_evaluate_now (stride, &block); + gfc_conv_descriptor_stride_set (&block, desc, + gfc_rank_cst[dim], stride); + + /* Update offset. */ + offs = gfc_conv_descriptor_offset_get (desc); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, lbound, stride); + offs = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offs, tmp); + offs = gfc_evaluate_now (offs, &block); + gfc_conv_descriptor_offset_set (&block, desc, offs); + + /* Update stride. */ + tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, tmp); + } + } + else + { + /* Bounds remapping. Just shift the lower bounds. */ + + gcc_assert (expr1->rank == expr2->rank); + + for (dim = 0; dim < remap->u.ar.dimen; ++dim) + { + gfc_se lbound_se; + + gcc_assert (remap->u.ar.start[dim]); + gcc_assert (!remap->u.ar.end[dim]); + gfc_init_se (&lbound_se, NULL); + gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]); + + gfc_add_block_to_block (&block, &lbound_se.pre); + gfc_conv_shift_descriptor_lbound (&block, desc, + dim, lbound_se.expr); + gfc_add_block_to_block (&block, &lbound_se.post); + } + } + } /* Check string lengths if applicable. The check is only really added to the output code if -fbounds-check is enabled. */ @@ -4279,8 +5143,32 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) strlen_lhs, strlen_rhs, &block); } + /* If rank remapping was done, check with -fcheck=bounds that + the target is at least as large as the pointer. */ + if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) + { + tree lsize, rsize; + tree fault; + const char* msg; + + lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank); + rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank); + + lsize = gfc_evaluate_now (lsize, &block); + rsize = gfc_evaluate_now (rsize, &block); + fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + rsize, lsize); + + msg = _("Target of rank remapping is too small (%ld < %ld)"); + gfc_trans_runtime_check (true, false, fault, &block, &expr2->where, + msg, rsize, lsize); + } + gfc_add_block_to_block (&block, &lse.post); + if (rank_remap) + gfc_add_block_to_block (&block, &rse.post); } + return gfc_finish_block (&block); } @@ -4323,11 +5211,12 @@ gfc_conv_string_parameter (gfc_se * se) /* Generate code for assignment of scalar variables. Includes character - strings and derived types with allocatable components. */ + strings and derived types with allocatable components. + If you know that the LHS has no allocations, set dealloc to false. */ tree gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool l_is_temp, bool r_is_var) + bool l_is_temp, bool r_is_var, bool dealloc) { stmtblock_t block; tree tmp; @@ -4358,16 +5247,16 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen, rse->expr, ts.kind); } - else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) + else if (ts.type == BT_DERIVED && ts.u.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, - gfc_build_addr_expr (NULL_TREE, lse->expr), - gfc_build_addr_expr (NULL_TREE, rse->expr)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_build_addr_expr (NULL_TREE, lse->expr), + gfc_build_addr_expr (NULL_TREE, rse->expr)); cond = gfc_evaluate_now (cond, &lse->pre); } @@ -4375,10 +5264,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, the same as the rhs. This must be done following the assignment to prevent deallocating data that could be used in the rhs expression. */ - if (!l_is_temp) + if (!l_is_temp && dealloc) { tmp = gfc_evaluate_now (lse->expr, &lse->pre); - tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); if (r_is_var) tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); @@ -4395,19 +5284,27 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, same as the lhs. */ if (r_is_var) { - tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); + tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0); tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); gfc_add_expr_to_block (&block, tmp); } } + else if (ts.type == BT_DERIVED || ts.type == BT_CLASS) + { + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (lse->expr), rse->expr); + gfc_add_modify (&block, lse->expr, tmp); + } else { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); gfc_add_modify (&block, lse->expr, - fold_convert (TREE_TYPE (lse->expr), rse->expr)); + fold_convert (TREE_TYPE (lse->expr), rse->expr)); } gfc_add_block_to_block (&block, &lse->post); @@ -4417,57 +5314,56 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, } -/* Try to translate array(:) = func (...), where func is a transformational - array function, without using a temporary. Returns NULL is this isn't the - case. */ +/* There are quite a lot of restrictions on the optimisation in using an + array function assign without a temporary. */ -static tree -gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +static bool +arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) { - gfc_se se; - gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; bool c = false; - gfc_component *comp = NULL; + gfc_symbol *sym = expr1->symtree->n.sym; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) - return NULL; + return true; - /* Elemental functions don't need a temporary anyway. */ + /* Elemental functions are scalarized so that they don't need a + temporary in gfc_trans_assignment_1, so return a true. Otherwise, + they would need special treatment in gfc_trans_arrayfunc_assign. */ if (expr2->value.function.esym != NULL && expr2->value.function.esym->attr.elemental) - return NULL; + return true; - /* Fail if rhs is not FULL or a contiguous section. */ + /* Need a temporary if rhs is not FULL or a contiguous section. */ if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) - return NULL; + return true; - /* Fail if EXPR1 can't be expressed as a descriptor. */ + /* Need a temporary if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) - return NULL; + return true; /* Functions returning pointers need temporaries. */ if (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable) - return NULL; + return true; /* 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 (expr1->ts.u.cl->length == NULL + || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) + return true; - if (expr2->ts.cl->length == NULL - || expr2->ts.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + if (expr2->ts.u.cl->length == NULL + || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) + return true; - if (mpz_cmp (expr1->ts.cl->length->value.integer, - expr2->ts.cl->length->value.integer) != 0) - return NULL; + if (mpz_cmp (expr1->ts.u.cl->length->value.integer, + expr2->ts.u.cl->length->value.integer) != 0) + return true; } /* Check that no LHS component references appear during an array @@ -4481,7 +5377,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (ref->type == REF_ARRAY) seen_array_ref= true; else if (ref->type == REF_COMPONENT && seen_array_ref) - return NULL; + return true; } /* Check for a dependency. */ @@ -4489,6 +5385,158 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) expr2->value.function.esym, expr2->value.function.actual, NOT_ELEMENTAL)) + return true; + + /* If we have reached here with an intrinsic function, we do not + need a temporary. */ + if (expr2->value.function.isym) + return false; + + /* If the LHS is a dummy, we need a temporary if it is not + INTENT(OUT). */ + if (sym->attr.dummy && sym->attr.intent != INTENT_OUT) + return true; + + /* If the lhs has been host_associated, is in common, a pointer or is + a target and the function is not using a RESULT variable, aliasing + can occur and a temporary is needed. */ + if ((sym->attr.host_assoc + || sym->attr.in_common + || sym->attr.pointer + || sym->attr.cray_pointee + || sym->attr.target) + && expr2->symtree != NULL + && expr2->symtree->n.sym == expr2->symtree->n.sym->result) + return true; + + /* A PURE function can unconditionally be called without a temporary. */ + if (expr2->value.function.esym != NULL + && expr2->value.function.esym->attr.pure) + return false; + + /* Implicit_pure functions are those which could legally be declared + to be PURE. */ + if (expr2->value.function.esym != NULL + && expr2->value.function.esym->attr.implicit_pure) + return false; + + if (!sym->attr.use_assoc + && !sym->attr.in_common + && !sym->attr.pointer + && !sym->attr.target + && !sym->attr.cray_pointee + && expr2->value.function.esym) + { + /* A temporary is not needed if the function is not contained and + the variable is local or host associated and not a pointer or + a target. */ + if (!expr2->value.function.esym->attr.contained) + return false; + + /* A temporary is not needed if the lhs has never been host + associated and the procedure is contained. */ + else if (!sym->attr.host_assoc) + return false; + + /* A temporary is not needed if the variable is local and not + a pointer, a target or a result. */ + if (sym->ns->parent + && expr2->value.function.esym->ns == sym->ns->parent) + return false; + } + + /* Default to temporary use. */ + return true; +} + + +/* Provide the loop info so that the lhs descriptor can be built for + reallocatable assignments from extrinsic function calls. */ + +static void +realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss) +{ + gfc_loopinfo loop; + /* Signal that the function call should not be made by + gfc_conv_loop_setup. */ + se->ss->is_alloc_lhs = 1; + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, *ss); + gfc_add_ss_to_loop (&loop, se->ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, where); + gfc_copy_loopinfo_to_se (se, &loop); + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + se->ss->is_alloc_lhs = 0; +} + + +static void +realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank) +{ + tree desc; + tree tmp; + tree offset; + int n; + + /* Use the allocation done by the library. */ + desc = build_fold_indirect_ref_loc (input_location, se->expr); + tmp = gfc_conv_descriptor_data_get (desc); + tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp)); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node); + /* Unallocated, the descriptor does not have a dtype. */ + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + + offset = gfc_index_zero_node; + tmp = gfc_index_one_node; + /* Now reset the bounds from zero based to unity based. */ + for (n = 0 ; n < rank; n++) + { + /* Accumulate the offset. */ + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, tmp); + /* Now do the bounds. */ + gfc_conv_descriptor_offset_set (&se->post, desc, tmp); + tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_conv_descriptor_lbound_set (&se->post, desc, + gfc_rank_cst[n], + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&se->post, desc, + gfc_rank_cst[n], tmp); + + /* The extent for the next contribution to offset. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + } + gfc_conv_descriptor_offset_set (&se->post, desc, offset); +} + + + +/* Try to translate array(:) = func (...), where func is a transformational + array function, without using a temporary. Returns NULL if this isn't the + case. */ + +static tree +gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se se; + gfc_ss *ss; + gfc_component *comp = NULL; + + if (arrayfunc_assign_needs_temporary (expr1, expr2)) return NULL; /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic @@ -4505,52 +5553,51 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_start_block (&se.pre); se.want_pointer = 1; - gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL); + gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL); + + if (expr1->ts.type == BT_DERIVED + && expr1->ts.u.derived->attr.alloc_comp) + { + tree tmp; + tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr, + expr1->rank); + gfc_add_expr_to_block (&se.pre, tmp); + } se.direct_byref = 1; se.ss = gfc_walk_expr (expr2); gcc_assert (se.ss != gfc_ss_terminator); + + /* Reallocate on assignment needs the loopinfo for extrinsic functions. + This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs. + Clearly, this cannot be done for an allocatable function result, since + the shape of the result is unknown and, in any case, the function must + correctly take care of the reallocation internally. For intrinsic + calls, the array data is freed and the library takes care of allocation. + TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment + to the library. */ + if (gfc_option.flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && !gfc_expr_attr (expr1).codimension + && !gfc_is_coindexed (expr1) + && !(expr2->value.function.esym + && expr2->value.function.esym->result->attr.allocatable)) + { + if (!expr2->value.function.isym) + { + realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss); + ss->is_alloc_lhs = 1; + } + else + realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank); + } + gfc_conv_function_expr (&se, expr2); gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); } -/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ - -static bool -is_zero_initializer_p (gfc_expr * expr) -{ - if (expr->expr_type != EXPR_CONSTANT) - return false; - - /* We ignore constants with prescribed memory representations for now. */ - if (expr->representation.string) - return false; - - 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 (mpc_realref (expr->value.complex)) - && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0 - && mpfr_zero_p (mpc_imagref (expr->value.complex)) - && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0; - - default: - break; - } - return false; -} /* Try to efficiently translate array(:) = 0. Return NULL if this can't be done. */ @@ -4577,21 +5624,22 @@ gfc_trans_zero_assign (gfc_expr * expr) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, - fold_convert (gfc_array_index_type, tmp)); + len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len, + fold_convert (gfc_array_index_type, tmp)); /* If we are zeroing a local array avoid taking its address by emitting a = {} instead. */ if (!POINTER_TYPE_P (TREE_TYPE (dest))) - return build2 (MODIFY_EXPR, void_type_node, - dest, build_constructor (TREE_TYPE (dest), NULL)); + return build2_loc (input_location, MODIFY_EXPR, void_type_node, + dest, build_constructor (TREE_TYPE (dest), NULL)); /* Convert arguments to the correct types. */ 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], + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMSET], 3, dest, integer_zero_node, len); return fold_convert (void_type_node, tmp); } @@ -4619,7 +5667,8 @@ gfc_build_memcpy_call (tree dst, tree src, tree len) 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); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len); return fold_convert (void_type_node, tmp); } @@ -4654,15 +5703,15 @@ gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2) if (!dlen || TREE_CODE (dlen) != INTEGER_CST) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); - dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen, - fold_convert (gfc_array_index_type, tmp)); + dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + dlen, fold_convert (gfc_array_index_type, tmp)); slen = GFC_TYPE_ARRAY_SIZE (stype); if (!slen || TREE_CODE (slen) != INTEGER_CST) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype)); - slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen, - fold_convert (gfc_array_index_type, tmp)); + slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + slen, fold_convert (gfc_array_index_type, tmp)); /* Sanity check that they are the same. This should always be the case, as we should already have checked for conformance. */ @@ -4707,8 +5756,8 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); - len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, - fold_convert (gfc_array_index_type, tmp)); + len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len, + fold_convert (gfc_array_index_type, tmp)); stype = gfc_typenode_for_spec (&expr2->ts); src = gfc_build_constant_array_constructor (expr2, stype); @@ -4721,11 +5770,35 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) } +/* Tells whether the expression is to be treated as a variable reference. */ + +static bool +expr_is_variable (gfc_expr *expr) +{ + gfc_expr *arg; + + if (expr->expr_type == EXPR_VARIABLE) + return true; + + arg = gfc_get_noncopying_intrinsic_argument (expr); + if (arg) + { + gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); + return expr_is_variable (arg); + } + + return false; +} + + /* Subroutine of gfc_trans_assignment that actually scalarizes the - assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */ + assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. + init_flag indicates initialization expressions and dealloc that no + deallocate prior assignment is needed (if in doubt, set true). */ static tree -gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) +gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, + bool dealloc) { gfc_se lse; gfc_se rse; @@ -4739,6 +5812,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) bool l_is_temp; bool scalar_to_array; tree string_length; + int n; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -4748,6 +5822,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) /* Walk the lhs. */ lss = gfc_walk_expr (expr1); + if (gfc_is_reallocatable_lhs (expr1) + && !(expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym != NULL)) + lss->is_alloc_lhs = 1; rss = NULL; if (lss != gfc_ss_terminator) { @@ -4784,6 +5862,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) /* Calculate the bounds of the scalarization. */ gfc_conv_ss_startstride (&loop); + /* Enable loop reversal. */ + for (n = 0; n < loop.dimen; n++) + loop.reverse[n] = GFC_REVERSE_NOT_SET; /* Resolve any data dependencies in the statement. */ gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ @@ -4827,7 +5908,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) if (l_is_temp) { gfc_conv_tmp_array_ref (&lse); - gfc_advance_se_ss_chain (&lse); if (expr2->ts.type == BT_CHARACTER) lse.string_length = string_length; } @@ -4838,20 +5918,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) to arrays must be done with a deep copy and the rhs temporary must have its components deallocated afterwards. */ scalar_to_array = (expr2->ts.type == BT_DERIVED - && expr2->ts.derived->attr.alloc_comp - && expr2->expr_type != EXPR_VARIABLE + && expr2->ts.u.derived->attr.alloc_comp + && !expr_is_variable (expr2) && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); - if (scalar_to_array) + if (scalar_to_array && dealloc) { - tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0); + tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0); gfc_add_expr_to_block (&loop.post, tmp); } tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp || init_flag, - (expr2->expr_type == EXPR_VARIABLE) - || scalar_to_array); + expr_is_variable (expr2) || scalar_to_array, + dealloc); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -4878,7 +5958,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) lse.ss = lss; gfc_conv_tmp_array_ref (&rse); - gfc_advance_se_ss_chain (&rse); gfc_conv_expr (&lse, expr1); gcc_assert (lse.ss == gfc_ss_terminator @@ -4888,10 +5967,21 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) rse.string_length = string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - false, false); + false, false, dealloc); gfc_add_expr_to_block (&body, tmp); } + /* Allocate or reallocate lhs of allocatable array. */ + if (gfc_option.flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && !gfc_expr_attr (expr1).codimension + && !gfc_is_coindexed (expr1)) + { + tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); + if (tmp != NULL_TREE) + gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp); + } + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop, &body); @@ -4934,7 +6024,7 @@ copyable_array_p (gfc_expr * expr) return false; case BT_DERIVED: - return !expr->ts.derived->attr.alloc_comp; + return !expr->ts.u.derived->attr.alloc_comp; default: break; @@ -4946,10 +6036,18 @@ copyable_array_p (gfc_expr * expr) /* Translate an assignment. */ tree -gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) +gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, + bool dealloc) { tree tmp; + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + gfc_error ("Assignment to deferred-length character variable at %L " + "not implemented", &expr1->where); + return NULL_TREE; + } + /* Special case a single function returning an array. */ if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) { @@ -4989,17 +6087,116 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) } /* Fallback to the scalarizer to generate explicit loops. */ - return gfc_trans_assignment_1 (expr1, expr2, init_flag); + return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc); } tree gfc_trans_init_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, true); + return gfc_trans_assignment (code->expr1, code->expr2, true, false); } tree gfc_trans_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, false); + return gfc_trans_assignment (code->expr1, code->expr2, false, true); +} + + +/* Special case for initializing a polymorphic dummy with INTENT(OUT). + A MEMCPY is needed to copy the full data from the default initializer + of the dynamic type. */ + +tree +gfc_trans_class_init_assign (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + gfc_se dst,src,memsz; + gfc_expr *lhs,*rhs,*sz; + + gfc_start_block (&block); + + lhs = gfc_copy_expr (code->expr1); + gfc_add_data_component (lhs); + + rhs = gfc_copy_expr (code->expr1); + gfc_add_vptr_component (rhs); + gfc_add_def_init_component (rhs); + + sz = gfc_copy_expr (code->expr1); + gfc_add_vptr_component (sz); + gfc_add_size_component (sz); + + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_init_se (&memsz, NULL); + gfc_conv_expr (&dst, lhs); + gfc_conv_expr (&src, rhs); + gfc_conv_expr (&memsz, sz); + gfc_add_block_to_block (&block, &src.pre); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate an assignment to a CLASS object + (pointer or ordinary assignment). */ + +tree +gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) +{ + stmtblock_t block; + tree tmp; + gfc_expr *lhs; + gfc_expr *rhs; + + gfc_start_block (&block); + + if (expr2->ts.type != BT_CLASS) + { + /* Insert an additional assignment which sets the '_vptr' field. */ + gfc_symbol *vtab = NULL; + gfc_symtree *st; + + lhs = gfc_copy_expr (expr1); + gfc_add_vptr_component (lhs); + + if (expr2->ts.type == BT_DERIVED) + vtab = gfc_find_derived_vtab (expr2->ts.u.derived); + else if (expr2->expr_type == EXPR_NULL) + vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + gcc_assert (vtab); + + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; + + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + + /* Do the actual CLASS assignment. */ + if (expr2->ts.type == BT_CLASS) + op = EXEC_ASSIGN; + else + gfc_add_data_component (expr1); + + if (op == EXEC_ASSIGN) + tmp = gfc_trans_assignment (expr1, expr2, false, true); + else if (op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assignment (expr1, expr2); + else + gcc_unreachable(); + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); }