X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-expr.c;h=570e07b5a06c135b32ea27628902403b9e5fb1fe;hb=989adef3b44d84f7b46c259ba46911460de87c51;hp=89bc3c28537f1fac0310410750669363097ed98f;hpb=079d3acc65d13efea2f7767b5ff131d4b9c6c446;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 89bc3c28537..b76a3245d89 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,6 +1,6 @@ /* Expression translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software - Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -26,15 +26,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 "tree-gimple.h" #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" @@ -115,7 +112,7 @@ gfc_make_safe_expr (gfc_se * se) /* We need a temporary for this result. */ var = gfc_create_var (TREE_TYPE (se->expr), NULL); - gfc_add_modify_expr (&se->pre, var, se->expr); + gfc_add_modify (&se->pre, var, se->expr); se->expr = var; } @@ -139,8 +136,8 @@ gfc_conv_expr_present (gfc_symbol * sym) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); decl = GFC_DECL_SAVED_DESCRIPTOR (decl); } - return build2 (NE_EXPR, boolean_type_node, decl, - fold_convert (TREE_TYPE (decl), null_pointer_node)); + return fold_build2 (NE_EXPR, boolean_type_node, decl, + fold_convert (TREE_TYPE (decl), null_pointer_node)); } @@ -158,12 +155,14 @@ 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, integer_one_node); + tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, + fold_convert (TREE_TYPE (tmp), integer_one_node)); tmp = gfc_evaluate_now (tmp, &se->pre); - se->expr = build_fold_addr_expr (tmp); + se->expr = gfc_build_addr_expr (NULL_TREE, tmp); } else { @@ -176,8 +175,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 = build3 (COND_EXPR, gfc_charlen_type_node, present, - se->string_length, tmp); + tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node, + present, se->string_length, tmp); tmp = gfc_evaluate_now (tmp, &se->pre); se->string_length = tmp; } @@ -199,12 +198,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; } @@ -212,7 +211,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) @@ -221,7 +220,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: @@ -240,24 +239,113 @@ gfc_get_expr_charlen (gfc_expr *e) return 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). */ + +static void +flatten_array_ctors_without_strlen (gfc_expr* e) +{ + gfc_actual_arglist* arg; + gfc_constructor* c; + + if (!e) + return; + + switch (e->expr_type) + { + + case EXPR_OP: + flatten_array_ctors_without_strlen (e->value.op.op1); + flatten_array_ctors_without_strlen (e->value.op.op2); + break; + + case EXPR_COMPCALL: + /* TODO: Implement as with EXPR_FUNCTION when needed. */ + gcc_unreachable (); + + case EXPR_FUNCTION: + for (arg = e->value.function.actual; arg; arg = arg->next) + flatten_array_ctors_without_strlen (arg->expr); + break; + + case EXPR_ARRAY: + + /* We've found what we're looking for. */ + if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) + { + gfc_constructor *c; + gfc_expr* new_expr; + + gcc_assert (e->value.constructor); + + 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); + break; + } + + /* Otherwise, fall through to handle constructor elements. */ + case EXPR_STRUCTURE: + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + flatten_array_ctors_without_strlen (c->expr); + break; + + default: + break; + + } +} + /* Generate code to initialize a string length variable. Returns the - value. */ + value. For array constructors, cl->length might be NULL and in this case, + the first element of the constructor is needed. expr is the original + expression so we can access it but can be NULL if this is not needed. */ void -gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock) +gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) { gfc_se se; gfc_init_se (&se, NULL); + + /* 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. */ + if (!cl->length) + { + 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); + + gfc_conv_expr (&se, expr_flat); + gfc_add_block_to_block (pblock, &se.pre); + cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); + + gfc_free_expr (expr_flat); + return; + } + + /* Convert cl->length. */ + + 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)); gfc_add_block_to_block (pblock, &se.pre); if (cl->backend_decl) - gfc_add_modify_expr (pblock, cl->backend_decl, se.expr); + gfc_add_modify (pblock, cl->backend_decl, se.expr); else cl->backend_decl = gfc_evaluate_now (se.expr, pblock); } @@ -269,7 +357,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; @@ -278,7 +365,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); @@ -287,15 +373,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); } @@ -309,10 +398,12 @@ 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 (flag_bounds_check) + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { tree nonempty = fold_build2 (LE_EXPR, boolean_type_node, start.expr, end.expr); @@ -328,7 +419,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, else asprintf (&msg, "Substring out of bounds: lower bound (%%ld)" "is less than one"); - gfc_trans_runtime_check (fault, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, start.expr)); gfc_free (msg); @@ -344,7 +435,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, else asprintf (&msg, "Substring out of bounds: upper bound (%%ld) " "exceeds string length (%%ld)"); - gfc_trans_runtime_check (fault, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, end.expr), fold_convert (long_integer_type_node, se->string_length)); @@ -352,9 +443,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, } 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); + end.expr, start.expr); + tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, + build_int_cst (gfc_charlen_type_node, 1), tmp); tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, build_int_cst (gfc_charlen_type_node, 0)); se->string_length = tmp; @@ -378,23 +469,67 @@ 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 = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); + tmp = fold_build3 (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->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER) - se->expr = build_fold_indirect_ref (se->expr); + 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_loc (input_location, + se->expr); } +/* This function deals with component references to components of the + parent type for derived type extensons. */ +static void +conv_parent_component_references (gfc_se * se, gfc_ref * ref) +{ + gfc_component *c; + gfc_component *cmp; + gfc_symbol *dt; + gfc_ref parent; + + dt = ref->u.c.sym; + c = ref->u.c.component; + + /* Build a gfc_ref to recursively call gfc_conv_component_ref. */ + parent.type = REF_COMPONENT; + parent.next = NULL; + 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; 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.u.derived; + parent.u.c.component = c; + conv_parent_component_references (se, &parent); + } +} + /* Return the contents of a variable. Also handles reference/pointer variables (all Fortran pointer references are implicit). */ @@ -480,11 +615,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) else if (sym->attr.flavor == FL_PROCEDURE && se->expr != current_function_decl) { - gcc_assert (se->want_pointer); - if (!sym->attr.dummy) + if (!sym->attr.dummy && !sym->attr.proc_pointer) { gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL); - se->expr = build_fold_addr_expr (se->expr); + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); } return; } @@ -501,20 +635,24 @@ 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) - se->expr = build_fold_indirect_ref (se->expr); + && !sym->attr.dimension && !sym->attr.pointer + && !sym->attr.always_explicit) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ @@ -523,7 +661,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) || 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; @@ -534,10 +673,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); } @@ -561,6 +700,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_COMPONENT: + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (se, ref); + gfc_conv_component_ref (se, ref); break; @@ -579,10 +721,10 @@ 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 = build_fold_addr_expr (se->expr); + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); } } @@ -607,10 +749,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 = build2 (EQ_EXPR, type, operand.expr, - build_int_cst (type, 0)); + se->expr = fold_build2 (EQ_EXPR, type, operand.expr, + build_int_cst (type, 0)); else - se->expr = build1 (code, type, operand.expr); + se->expr = fold_build1 (code, type, operand.expr); } @@ -748,25 +890,27 @@ 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 = build2 (EQ_EXPR, boolean_type_node, lhs, - build_int_cst (TREE_TYPE (lhs), -1)); - cond = build2 (EQ_EXPR, boolean_type_node, lhs, - build_int_cst (TREE_TYPE (lhs), 1)); + 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)); /* If rhs is even, result = (lhs == 1 || lhs == -1) ? 1 : 0. */ if ((n & 1) == 0) { - tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond); - se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1), - build_int_cst (type, 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)); return 1; } /* If rhs is odd, result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */ - tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1), - build_int_cst (type, 0)); - se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp); + 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); return 1; } @@ -775,7 +919,7 @@ 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] = build2 (RDIV_EXPR, type, tmp, vartmp[1]); + vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]); } se->expr = gfc_conv_powi (se, n, vartmp); @@ -935,16 +1079,14 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) switch (kind) { case 4: - fndecl = gfor_fndecl_math_cpowf; + fndecl = built_in_decls[BUILT_IN_CPOWF]; break; case 8: - fndecl = gfor_fndecl_math_cpow; + fndecl = built_in_decls[BUILT_IN_CPOW]; break; case 10: - fndecl = gfor_fndecl_math_cpowl10; - break; case 16: - fndecl = gfor_fndecl_math_cpowl16; + fndecl = built_in_decls[BUILT_IN_CPOWL]; break; default: gcc_unreachable (); @@ -956,7 +1098,8 @@ 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); } @@ -968,15 +1111,18 @@ 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 = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); - tmp = build_array_type (gfc_character1_type_node, tmp); + + if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) + tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); + else + tmp = build_array_type (TREE_TYPE (type), tmp); + var = gfc_create_var (tmp, "str"); var = gfc_build_addr_expr (type, var); } @@ -984,8 +1130,11 @@ 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, len); - gfc_add_modify_expr (&se->pre, var, tmp); + tmp = gfc_call_malloc (&se->pre, type, + fold_build2 (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. */ tmp = gfc_call_free (convert (pvoid_type_node, var)); @@ -1002,15 +1151,12 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) static void gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) { - gfc_se lse; - gfc_se rse; - tree len; - tree type; - tree var; - tree tmp; + gfc_se lse, rse; + tree len, type, var, tmp, fndecl; gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER - && expr->value.op.op2->ts.type == BT_CHARACTER); + && expr->value.op.op2->ts.type == BT_CHARACTER); + gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind); gfc_init_se (&lse, se); gfc_conv_expr (&lse, expr->value.op.op1); @@ -1022,7 +1168,7 @@ 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) { @@ -1035,9 +1181,15 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) var = gfc_conv_string_tmp (se, type, len); /* Do the actual concatenation. */ - tmp = build_call_expr (gfor_fndecl_concat_string, 6, - len, var, - lse.string_length, lse.expr, + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_concat_string; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_concat_string_char4; + else + gcc_unreachable (); + + 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); @@ -1069,10 +1221,20 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) checkstring = 0; lop = 0; - switch (expr->value.op.operator) + switch (expr->value.op.op) { - case INTRINSIC_UPLUS: case INTRINSIC_PARENTHESES: + 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))); + return; + } + + /* Fallthrough. */ + case INTRINSIC_UPLUS: gfc_conv_expr (se, expr->value.op.op1); return; @@ -1202,7 +1364,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) gfc_conv_string_parameter (&rse); lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, - rse.string_length, rse.expr); + rse.string_length, rse.expr, + expr->value.op.op1->ts.kind); rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); gfc_add_block_to_block (&lse.post, &rse.post); } @@ -1226,15 +1389,16 @@ 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 -gfc_to_single_character (tree len, tree str) +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) + && TREE_INT_CST_HIGH (len) == 0) { - str = fold_convert (pchar_type_node, str); - return build_fold_indirect_ref (str); + str = fold_convert (gfc_get_pchar_type (kind), str); + return build_fold_indirect_ref_loc (input_location, + str); } return NULL_TREE; @@ -1265,8 +1429,10 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) if ((*expr)->expr_type == EXPR_CONSTANT) { 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 @@ -1280,18 +1446,21 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { if ((*expr)->ref == NULL) { - se->expr = gfc_to_single_character + se->expr = string_to_single_character (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (pchar_type_node, + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl - ((*expr)->symtree->n.sym))); + ((*expr)->symtree->n.sym)), + (*expr)->ts.kind); } else { gfc_conv_variable (se, *expr); - se->expr = gfc_to_single_character + se->expr = string_to_single_character (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (pchar_type_node, se->expr)); + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + se->expr), + (*expr)->ts.kind); } } } @@ -1302,7 +1471,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) subtraction of them. Otherwise, we build a library call. */ tree -gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) { tree sc1; tree sc2; @@ -1311,31 +1480,65 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = gfc_to_single_character (len1, str1); - sc2 = gfc_to_single_character (len2, str2); + sc1 = string_to_single_character (len1, str1, kind); + sc2 = string_to_single_character (len2, str2, kind); - /* Deal with single character specially. */ 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); } - else - /* Build a call for the comparison. */ - tmp = build_call_expr (gfor_fndecl_compare_string, 4, - len1, str1, len2, str2); + else + { + /* Build a call for the comparison. */ + tree fndecl; + + 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_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; + gfc_init_se (&comp_se, NULL); + e2 = gfc_copy_expr (e); + e2->expr_type = EXPR_VARIABLE; + gfc_conv_expr (&comp_se, e2); + gfc_free_expr (e2); + return build_fold_addr_expr_loc (input_location, comp_se.expr); +} + + static void -gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) +conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; - if (sym->attr.dummy) + if (gfc_is_proc_ptr_comp (expr, NULL)) + 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_loc (input_location, + tmp); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); } @@ -1345,61 +1548,27 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) sym->backend_decl = gfc_get_extern_function_decl (sym); tmp = sym->backend_decl; + if (sym->attr.cray_pointee) - tmp = convert (build_pointer_type (TREE_TYPE (tmp)), - gfc_get_symbol_decl (sym->cp_pointer)); + { + /* TODO - make the cray pointee a pointer to a procedure, + assign the pointer to it and use it for the call. This + will do for now! */ + tmp = convert (build_pointer_type (TREE_TYPE (tmp)), + gfc_get_symbol_decl (sym->cp_pointer)); + tmp = gfc_evaluate_now (tmp, &se->pre); + } + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) { gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); - tmp = build_fold_addr_expr (tmp); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); } } se->expr = tmp; } -/* Translate the call for an elemental subroutine call used in an operator - assignment. This is a simplified version of gfc_conv_function_call. */ - -tree -gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym) -{ - tree args; - tree tmp; - gfc_se se; - stmtblock_t block; - - /* Only elemental subroutines with two arguments. */ - gcc_assert (sym->attr.elemental && sym->attr.subroutine); - gcc_assert (sym->formal->next->next == NULL); - - gfc_init_block (&block); - - gfc_add_block_to_block (&block, &lse->pre); - gfc_add_block_to_block (&block, &rse->pre); - - /* Build the argument list for the call, including hidden string lengths. */ - args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr)); - args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr)); - if (lse->string_length != NULL_TREE) - args = gfc_chainon_list (args, lse->string_length); - if (rse->string_length != NULL_TREE) - args = gfc_chainon_list (args, rse->string_length); - - /* Build the function call. */ - gfc_init_se (&se, NULL); - gfc_conv_function_val (&se, sym); - tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr))); - tmp = build_call_list (tmp, se.expr, args); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &lse->post); - gfc_add_block_to_block (&block, &rse->post); - - return gfc_finish_block (&block); -} - - /* Initialize MAPPING. */ void @@ -1423,9 +1592,10 @@ gfc_free_interface_mapping (gfc_interface_mapping * mapping) for (sym = mapping->syms; sym; sym = nextsym) { nextsym = sym->next; - gfc_free_symbol (sym->new->n.sym); + sym->new_sym->n.sym->formal = NULL; + gfc_free_symbol (sym->new_sym->n.sym); gfc_free_expr (sym->expr); - gfc_free (sym->new); + gfc_free (sym->new_sym); gfc_free (sym); } for (cl = mapping->charlens; cl; cl = nextcl) @@ -1444,14 +1614,14 @@ static gfc_charlen * gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping, gfc_charlen * cl) { - gfc_charlen *new; + gfc_charlen *new_charlen; - new = gfc_get_charlen (); - new->next = mapping->charlens; - new->length = gfc_copy_expr (cl->length); + new_charlen = gfc_get_charlen (); + new_charlen->next = mapping->charlens; + new_charlen->length = gfc_copy_expr (cl->length); - mapping->charlens = new; - return new; + mapping->charlens = new_charlen; + return new_charlen; } @@ -1469,10 +1639,12 @@ 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_expr (block, var, fold_convert (type, data)); + gfc_add_modify (block, var, fold_convert (type, data)); return var; } @@ -1498,15 +1670,15 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE) { GFC_TYPE_ARRAY_LBOUND (type, n) - = gfc_conv_descriptor_lbound (desc, dim); + = gfc_conv_descriptor_lbound_get (desc, dim); GFC_TYPE_ARRAY_UBOUND (type, n) - = gfc_conv_descriptor_ubound (desc, dim); + = gfc_conv_descriptor_ubound_get (desc, dim); } else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) { tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound (desc, dim), - gfc_conv_descriptor_lbound (desc, dim)); + 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); @@ -1543,13 +1715,24 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, /* Create a new symbol to represent the actual argument. */ new_sym = gfc_new_symbol (sym->name, NULL); new_sym->ts = sym->ts; + new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + 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; new_sym->attr.function = sym->attr.function; + /* Ensure that the interface is available and that + descriptors are passed for array actual arguments. */ + if (sym->attr.flavor == FL_PROCEDURE) + { + new_sym->formal = expr->symtree->n.sym->formal; + new_sym->attr.always_explicit + = expr->symtree->n.sym->attr.always_explicit; + } + /* Create a fake symtree for it. */ root = NULL; new_symtree = gfc_new_symtree (&root, sym->name); @@ -1557,10 +1740,10 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, gcc_assert (new_symtree == root); /* Create a dummy->actual mapping. */ - sm = gfc_getmem (sizeof (*sm)); + sm = XCNEW (gfc_interface_sym_mapping); sm->next = mapping->syms; sm->old = sym; - sm->new = new_symtree; + sm->new_sym = new_symtree; sm->expr = gfc_copy_expr (expr); mapping->syms = sm; @@ -1571,16 +1754,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; } } @@ -1598,7 +1781,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); @@ -1607,11 +1791,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. */ @@ -1619,7 +1805,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); @@ -1652,19 +1839,19 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, gfc_se se; for (sym = mapping->syms; sym; sym = sym->next) - if (sym->new->n.sym->ts.type == BT_CHARACTER - && !sym->new->n.sym->ts.cl->backend_decl) + if (sym->new_sym->n.sym->ts.type == BT_CHARACTER + && !sym->new_sym->n.sym->ts.u.cl->backend_decl) { - expr = sym->new->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); - + se.expr = fold_convert (gfc_charlen_type_node, se.expr); se.expr = gfc_evaluate_now (se.expr, &se.pre); gfc_add_block_to_block (pre, &se.pre); gfc_add_block_to_block (post, &se.post); - sym->new->n.sym->ts.cl->backend_decl = se.expr; + sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr; } } @@ -1674,9 +1861,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) @@ -1723,8 +1911,9 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, /* Convert intrinsic function calls into result expressions. */ + static bool -gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping) +gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) { gfc_symbol *sym; gfc_expr *new_expr; @@ -1738,7 +1927,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping) else arg2 = NULL; - sym = arg1->symtree->n.sym; + sym = arg1->symtree->n.sym; if (sym->attr.dummy) return false; @@ -1750,15 +1939,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->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) @@ -1775,7 +1965,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping) for (; d < dup; d++) { gfc_expr *tmp; - tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1)); + + if (!sym->as->upper[d] || !sym->as->lower[d]) + { + gfc_free_expr (new_expr); + return false; + } + + 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); @@ -1789,7 +1988,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) @@ -1800,9 +1999,15 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping) gcc_unreachable (); if (expr->value.function.isym->id == GFC_ISYM_LBOUND) - new_expr = gfc_copy_expr (sym->as->lower[d]); + { + if (sym->as->lower[d]) + new_expr = gfc_copy_expr (sym->as->lower[d]); + } else - new_expr = gfc_copy_expr (sym->as->upper[d]); + { + if (sym->as->upper[d]) + new_expr = gfc_copy_expr (sym->as->upper[d]); + } break; default: @@ -1854,11 +2059,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); } } @@ -1879,10 +2084,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. */ @@ -1890,12 +2095,12 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, /* ...and to the expression's symbol, if it has one. */ /* TODO Find out why the condition on expr->symtree had to be moved into - the loop rather than being ouside it, as originally. */ + the loop rather than being outside it, as originally. */ for (sym = mapping->syms; sym; sym = sym->next) if (expr->symtree && sym->old == expr->symtree->n.sym) { - if (sym->new->n.sym->backend_decl) - expr->symtree = sym->new; + if (sym->new_sym->n.sym->backend_decl) + expr->symtree = sym->new_sym; else if (sym->expr) gfc_replace_expr (expr, gfc_copy_expr (sym->expr)); } @@ -1927,9 +2132,9 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, for (sym = mapping->syms; sym; sym = sym->next) if (sym->old == expr->value.function.esym) { - expr->value.function.esym = sym->new->n.sym; + expr->value.function.esym = sym->new_sym->n.sym; gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping); - expr->value.function.esym->result = sym->new->n.sym; + expr->value.function.esym->result = sym->new_sym->n.sym; } break; @@ -1937,6 +2142,11 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, case EXPR_STRUCTURE: gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor); break; + + case EXPR_COMPCALL: + case EXPR_PPC: + gcc_unreachable (); + break; } return; @@ -1962,8 +2172,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; @@ -1976,8 +2186,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); @@ -1997,8 +2209,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, &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) @@ -2010,7 +2222,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; @@ -2022,7 +2234,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, gfc_add_ss_to_loop (&loop, loop.temp_ss); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); /* Pass the temporary descriptor back to the caller. */ info = &loop.temp_ss->data.info; @@ -2048,7 +2260,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, 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); @@ -2087,7 +2299,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, gfc_conv_ss_startstride (&loop2); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop2); + gfc_conv_loop_setup (&loop2, &expr->where); gfc_copy_loopinfo_to_se (&lse, &loop2); gfc_copy_loopinfo_to_se (&rse, &loop2); @@ -2106,9 +2318,10 @@ 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]; @@ -2128,23 +2341,24 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp_index, rse.loop->from[0]); - gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index); + 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); /* 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. */ @@ -2166,14 +2380,50 @@ 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 (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 (MINUS_EXPR, gfc_array_index_type, + offset, size); + offset = gfc_evaluate_now (offset, &parmse->pre); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + rse.loop->to[n], rse.loop->from[n]); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + size = fold_build2 (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. */ if (g77) parmse->expr = gfc_conv_descriptor_data_get (parmse->expr); else - parmse->expr = build_fold_addr_expr (parmse->expr); + parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); return; } @@ -2202,13 +2452,214 @@ 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 (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, true); + gcc_assert (vtab); + gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, 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 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + 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 (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 (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 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. */ + Return nonzero, if the call has alternate specifiers. + 'expr' is only needed for procedure pointer components. */ int -gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, - gfc_actual_arglist * arg, tree append_args) +gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, + gfc_actual_arglist * arg, gfc_expr * expr, + tree append_args) { gfc_interface_mapping mapping; tree arglist; @@ -2224,6 +2675,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, tree var; tree len; tree stringargs; + tree result = NULL; gfc_formal_arglist *formal; int has_alternate_specifier = 0; bool need_interface_mapping; @@ -2234,111 +2686,38 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_symbol *fsym; stmtblock_t post; enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; + gfc_component *comp = NULL; arglist = NULL_TREE; retargs = NULL_TREE; stringargs = NULL_TREE; 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); - } + if (sym->from_intmod == INTMOD_ISO_C_BINDING + && conv_isocbinding_procedure (se, sym, arg)) + return 0; - 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_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 = 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 = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, - arg2se.expr); - /* Generate test to ensure that the first arg is not null. */ - not_null_expr = 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 = build2 (TRUTH_AND_EXPR, boolean_type_node, - not_null_expr, eq_expr); - } + gfc_is_proc_ptr_comp (expr, &comp); - return 0; - } - } - if (se->ss != NULL) { if (!sym->attr.elemental) { gcc_assert (se->ss->type == GFC_SS_FUNCTION); - if (se->ss->useflags) - { - gcc_assert (gfc_return_by_reference (sym) - && sym->result->attr.dimension); - gcc_assert (se->loop != NULL); - - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); - return 0; - } + 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); + + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); + return 0; + } } info = &se->ss->data.info; } @@ -2347,21 +2726,34 @@ gfc_conv_function_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) - || 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) { 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 @@ -2370,23 +2762,31 @@ gfc_conv_function_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 (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 @@ -2396,8 +2796,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) - { - if (fsym && fsym->attr.value) + { + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.cray_pointee + && fsym && fsym->attr.flavor == FL_PROCEDURE) + { + /* The Cray pointer needs to be converted to a pointer to + a type given by the expression. */ + gfc_conv_expr (&parmse, e); + type = build_pointer_type (TREE_TYPE (parmse.expr)); + tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer); + parmse.expr = convert (type, tmp); + } + else if (fsym && fsym->attr.value) { if (fsym->ts.type == BT_CHARACTER && fsym->ts.is_c_interop @@ -2417,24 +2828,74 @@ gfc_conv_function_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. */ gfc_conv_expr (&parmse, e); - parmse.expr = build_fold_addr_expr (parmse.expr); + if (fsym && fsym->attr.proc_pointer) + parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } else { gfc_conv_expr_reference (&parmse, e); - if (fsym && fsym->attr.pointer - && fsym->attr.flavor != FL_PROCEDURE - && e->expr_type != EXPR_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) + { + 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 (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 (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->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 this level of indirection. */ parm_kind = SCALAR_POINTER; - parmse.expr = build_fold_addr_expr (parmse.expr); + parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } } } @@ -2446,11 +2907,14 @@ gfc_conv_function_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; + if (comp) + f = f || !comp->attr.always_explicit; + else + f = f || !sym->attr.always_explicit; if (e->expr_type == EXPR_VARIABLE && is_subref_array (e)) @@ -2459,20 +2923,28 @@ gfc_conv_function_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); - - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is - allocated on entry, it must be deallocated. */ - if (fsym && fsym->attr.allocatable - && fsym->attr.intent == INTENT_OUT) - { - tmp = build_fold_indirect_ref (parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp); - gfc_add_expr_to_block (&se->pre, tmp); - } + gfc_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_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 (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); + } } } @@ -2484,9 +2956,23 @@ gfc_conv_function_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->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_DEFERRED)))) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); } @@ -2499,10 +2985,11 @@ gfc_conv_function_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.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; } } @@ -2513,17 +3000,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&post, &parmse.post); /* Allocated allocatable components of derived types must be - deallocated for INTENT(OUT) dummy arguments and non-variable - scalars. Non-variable arrays are dealt with in trans-array.c - (gfc_conv_array_parameter). */ + 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 - && ((formal && formal->sym->attr.intent == INTENT_OUT) - || - (e->expr_type != EXPR_VARIABLE && !e->rank))) + && 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) { @@ -2533,27 +3019,116 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, break; case (SCALAR_POINTER): - tmp = build_fold_indirect_ref (tmp); - break; - case (ARRAY): - tmp = parmse.expr; + tmp = build_fold_indirect_ref_loc (input_location, + tmp); break; } - tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); - if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) - tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym), - tmp, build_empty_stmt ()); - - if (e->expr_type != EXPR_VARIABLE) - /* Don't deallocate non-variables until they have been used. */ - gfc_add_expr_to_block (&se->post, tmp); - else + if (e->expr_type == EXPR_OP + && e->value.op.op == INTRINSIC_PARENTHESES + && e->value.op.op1->expr_type == EXPR_VARIABLE) { - gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT); - gfc_add_expr_to_block (&se->pre, tmp); + tree local_tmp; + local_tmp = gfc_evaluate_now (tmp, &se->pre); + 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.u.derived, tmp, parm_rank); + + gfc_add_expr_to_block (&se->post, tmp); + } + + /* Add argument checking of passing an unallocated/NULL actual to + a nonallocatable/nonpointer dummy. */ + + if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL) + { + 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; + } + else + goto end_pointer_check; + + 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, null_ptr, type; + + 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 + && (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 + && (fsym == NULL || !fsym->attr.proc_pointer)) + asprintf (&msg, "Proc-pointer actual argument '%s' is not " + "associated or not present", + e->symtree->n.sym->name); + else + goto end_pointer_check; + + 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)); + type = TREE_TYPE (parmse.expr); + null_ptr = 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, null_ptr); + } + else + { + 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 + && (fsym == NULL || !fsym->attr.pointer)) + asprintf (&msg, "Pointer actual argument '%s' is not " + "associated", e->symtree->n.sym->name); + 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); + else + goto end_pointer_check; + + + cond = fold_build2 (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, + msg); + gfc_free (msg); + } + end_pointer_check: + /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ @@ -2564,10 +3139,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); - ts = sym->ts; - if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c) + 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 @@ -2582,19 +3163,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, 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); @@ -2607,27 +3188,55 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* 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 = gfc_return_by_reference (sym); + byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER)) + || (!comp && gfc_return_by_reference (sym)); if (byref) { if (se->direct_byref) { - /* Sometimes, too much indirection can be applied; eg. for + /* Sometimes, too much indirection can be applied; e.g. for function_result = array_valued_recursive_function. */ if (TREE_TYPE (TREE_TYPE (se->expr)) && 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); + result = build_fold_indirect_ref_loc (input_location, + se->expr); retargs = gfc_chainon_list (retargs, se->expr); } - else if (sym->result->attr.dimension) + else if (comp && comp->attr.dimension) + { + gcc_assert (se->loop && info); + + /* Set the type of the array. */ + tmp = gfc_typenode_for_spec (&comp->ts); + info->dimen = se->loop->dimen; + + /* Evaluate the bounds of the result, if known. */ + gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as); + + /* Create a temporary to store the result. In case the function + returns a pointer, the temporary will be a shallow copy and + mustn't be deallocated. */ + callee_alloc = comp->attr.allocatable || comp->attr.pointer; + gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp, + NULL_TREE, false, !comp->attr.pointer, + callee_alloc, &se->ss->expr->where); + + /* Pass the temporary as the first argument. */ + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); + retargs = gfc_chainon_list (retargs, tmp); + } + else if (!comp && sym->result->attr.dimension) { gcc_assert (se->loop && info); @@ -2643,27 +3252,35 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, mustn't be deallocated. */ callee_alloc = sym->attr.allocatable || sym->attr.pointer; gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp, - false, !sym->attr.pointer, callee_alloc); + NULL_TREE, false, !sym->attr.pointer, + callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = build_fold_addr_expr (tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); retargs = gfc_chainon_list (retargs, tmp); } else if (ts.type == BT_CHARACTER) { /* Pass the string length. */ - type = gfc_get_character_type (ts.kind, ts.cl); + type = 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"); + 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 = build_fold_addr_expr (var); + var = gfc_build_addr_expr (NULL_TREE, var); } else var = gfc_conv_string_tmp (se, type, len); @@ -2675,7 +3292,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX); type = gfc_get_complex_type (ts.kind); - var = build_fold_addr_expr (gfc_create_var (type, "cmplx")); + var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx")); retargs = gfc_chainon_list (retargs, var); } @@ -2697,7 +3314,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, arglist = chainon (arglist, append_args); /* Generate the actual call. */ - gfc_conv_function_val (se, sym); + conv_function_val (se, sym, expr); /* If there are alternate return labels, function type should be integer. Can't modify the type in place though, since it can be shared @@ -2711,7 +3328,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, TREE_TYPE (sym->backend_decl) = build_function_type (integer_type_node, TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); - se->expr = build_fold_addr_expr (sym->backend_decl); + se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl); } else TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node; @@ -2724,8 +3341,11 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, something like x = f() where f is pointer valued, we have to dereference the result. */ - if (!se->want_pointer && !byref && sym->attr.pointer) - se->expr = build_fold_indirect_ref (se->expr); + if (!se->want_pointer && !byref + && (sym->attr.pointer || sym->attr.allocatable) + && !gfc_is_proc_ptr_comp (expr, NULL)) + 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 @@ -2752,26 +3372,28 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, if (!se->direct_byref) { - if (sym->attr.dimension) + if (sym->attr.dimension || (comp && comp->attr.dimension)) { - if (flag_bounds_check) + 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); - gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault); + gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL, + gfc_msg_fault); } se->expr = info->descriptor; /* 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; @@ -2779,15 +3401,44 @@ gfc_conv_function_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); @@ -2795,11 +3446,79 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } +/* Fill a character string with spaces. */ + +static tree +fill_with_spaces (tree start, tree type, tree size) +{ + stmtblock_t block, loop; + tree i, el, exit_label, cond, tmp; + + /* For a simple char type, we can call memset(). */ + if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) + 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); + + /* Otherwise, we use a loop: + for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type)) + *el = (type) ' '; + */ + + /* Initialize variables. */ + gfc_init_block (&block); + i = gfc_create_var (sizetype, "i"); + gfc_add_modify (&block, i, fold_convert (sizetype, size)); + el = gfc_create_var (build_pointer_type (type), "el"); + gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start)); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + + /* Loop body. */ + gfc_init_block (&loop); + + /* Exit condition. */ + cond = fold_build2 (LE_EXPR, boolean_type_node, i, + fold_convert (sizetype, integer_zero_node)); + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3 (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 (' '))); + + /* 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))); + + /* Making the loop... actually loop! */ + tmp = gfc_finish_block (&loop); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + + return gfc_finish_block (&block); +} + + /* Generate code to copy a string. */ void gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, - tree slength, tree src) + int dkind, tree slength, tree src, int skind) { tree tmp, dlen, slen; tree dsc; @@ -2809,12 +3528,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tree tmp2; tree tmp3; tree tmp4; + tree chartype; stmtblock_t tempblock; + gcc_assert (dkind == skind); + if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = gfc_to_single_character (slen, src); + ssc = string_to_single_character (slen, src, skind); } else { @@ -2825,7 +3547,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 = gfc_to_single_character (slen, dest); + dsc = string_to_single_character (slen, dest, dkind); } else { @@ -2834,14 +3556,16 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, } if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) - ssc = gfc_to_single_character (slen, src); + ssc = string_to_single_character (slen, src, skind); if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) - dsc = gfc_to_single_character (dlen, dest); + dsc = string_to_single_character (dlen, dest, dkind); - if (dsc != NULL_TREE && ssc != NULL_TREE) + /* Assign directly if the types are compatible. */ + if (dsc != NULL_TREE && ssc != NULL_TREE + && TREE_TYPE (dsc) == TREE_TYPE (ssc)) { - gfc_add_modify_expr (block, dsc, ssc); + gfc_add_modify (block, dsc, ssc); return; } @@ -2872,6 +3596,16 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, We're now doing it here for better optimization, but the logic is the same. */ + /* 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) dest = fold_convert (pvoid_type_node, dest); else @@ -2884,21 +3618,20 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* 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], + 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 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, - tmp4, - build_int_cst (gfc_get_int_type (gfc_c_int_kind), - lang_hooks.to_target_charset (' ')), - fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), - dlen, slen)); + tmp4 = fill_with_spaces (tmp4, chartype, + fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), + dlen, slen)); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); @@ -2907,7 +3640,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* 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 ()); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } @@ -2959,8 +3693,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) /* Copy string arguments. */ 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), @@ -2971,8 +3705,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) 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, tmp, rse.string_length, - rse.expr); + gfc_trans_string_copy (&se->pre, arglen, tmp, 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); } @@ -2982,7 +3716,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) gfc_conv_expr (&lse, args->expr); gfc_add_block_to_block (&se->pre, &lse.pre); - gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr); + gfc_add_modify (&se->pre, temp_vars[n], lse.expr); gfc_add_block_to_block (&se->pre, &lse.post); } @@ -2997,21 +3731,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, - se->string_length, se->expr); + 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. */ @@ -3047,7 +3782,46 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) sym = expr->value.function.esym; if (!sym) sym = expr->symtree->n.sym; - gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE); + + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, + NULL_TREE); +} + + +/* 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; } @@ -3080,16 +3854,18 @@ 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); + return se.expr; } if (array) @@ -3097,6 +3873,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, /* Arrays need special handling. */ if (pointer) return gfc_build_null_descriptor (type); + /* Special case assigning an array to zero. */ + else if (is_zero_initializer_p (expr)) + return build_constructor (type, NULL); else return gfc_conv_array_initializer (type, expr); } @@ -3107,12 +3886,16 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, 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); return se.expr; case BT_CHARACTER: - return gfc_conv_string_init (ts->cl->backend_decl,expr); + return gfc_conv_string_init (ts->u.cl->backend_decl,expr); default: gfc_init_se (&se, NULL); @@ -3184,7 +3967,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_ss_startstride (&loop); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); /* Setup the gfc_se structures. */ gfc_copy_loopinfo_to_se (&lse, &loop); @@ -3200,11 +3983,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); @@ -3226,6 +4009,149 @@ 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 (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, 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 (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 (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 (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 @@ -3236,16 +4162,14 @@ 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); - if (cm->pointer) + if (cm->attr.pointer) { gfc_init_se (&se, NULL); /* Pointer component. */ - if (cm->dimension) + if (cm->attr.dimension) { /* Array pointer. */ if (expr->expr_type == EXPR_NULL) @@ -3266,72 +4190,26 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) se.want_pointer = 1; gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify_expr (&block, dest, + gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest), se.expr)); gfc_add_block_to_block (&block, &se.post); } } - else if (cm->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) { - if (cm->allocatable && expr->expr_type == EXPR_NULL) + if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - else if (cm->allocatable) + 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_expr (&block, dest, tmp); - - if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) - tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, - cm->as->rank); - else - tmp = gfc_duplicate_allocatable (dest, se.expr, - TREE_TYPE(cm->backend_decl), - cm->as->rank); - + tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &se.post); - gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); - - /* Shift the lbound and ubound of temporaries to being unity, rather - than zero, based. Calculate the offset for all cases. */ - offset = gfc_conv_descriptor_offset (dest); - gfc_add_modify_expr (&block, offset, gfc_index_zero_node); - tmp2 =gfc_create_var (gfc_array_index_type, NULL); - for (n = 0; n < expr->rank; n++) - { - if (expr->expr_type != EXPR_VARIABLE - && expr->expr_type != EXPR_CONSTANT) - { - tree span; - tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]); - span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, - gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n])); - gfc_add_modify_expr (&block, tmp, - fold_build2 (PLUS_EXPR, - gfc_array_index_type, - span, gfc_index_one_node)); - tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]); - gfc_add_modify_expr (&block, tmp, gfc_index_one_node); - } - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - gfc_conv_descriptor_lbound (dest, - gfc_rank_cst[n]), - gfc_conv_descriptor_stride (dest, - gfc_rank_cst[n])); - gfc_add_modify_expr (&block, tmp2, tmp); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); - gfc_add_modify_expr (&block, offset, tmp); - } } else { @@ -3345,8 +4223,10 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); - gfc_add_modify_expr (&block, dest, + gfc_add_block_to_block (&block, &se.pre); + gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest), se.expr)); + gfc_add_block_to_block (&block, &se.post); } else { @@ -3363,9 +4243,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); @@ -3383,28 +4263,30 @@ 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; + 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; + continue; - /* Update the type/kind of the expression if it represents either - C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may - be the first place reached for initializing output variables that - have components of type C_PTR/C_FUNPTR that are initialized. */ - if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived - && c->expr->ts.derived->attr.is_iso_c) - { - c->expr->expr_type = EXPR_NULL; - c->expr->ts.type = c->expr->ts.derived->ts.type; - c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type; - c->expr->ts.kind = c->expr->ts.derived->ts.kind; + /* Handle c_null_(fun)ptr. */ + if (c && c->expr && c->expr->ts.is_iso_c) + { + field = cm->backend_decl; + tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), + dest, field, NULL_TREE); + tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + gfc_add_expr_to_block (&block, tmp); + continue; } - + field = cm->backend_decl; - tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE); + tmp = fold_build3 (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); } @@ -3431,35 +4313,51 @@ 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 of EXPR_NULL,... by default, the static nullify is not needed since this is done every time we come into scope. */ - if (!c->expr || cm->allocatable) + if (!c->expr || cm->attr.allocatable) continue; - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->backend_decl), cm->dimension, cm->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) - { - TREE_CONSTANT(se->expr) = 1; - TREE_INVARIANT(se->expr) = 1; - } + TREE_CONSTANT (se->expr) = 1; } @@ -3474,8 +4372,10 @@ gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); - se->expr = gfc_build_string_const (expr->value.character.length, - expr->value.character.string); + se->expr = gfc_build_wide_string_const (expr->ts.kind, + expr->value.character.length, + expr->value.character.string); + se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1; @@ -3497,6 +4397,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; @@ -3507,8 +4409,8 @@ 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) @@ -3521,9 +4423,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; } } @@ -3591,7 +4493,7 @@ gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) if (se->post.head) { val = gfc_create_var (TREE_TYPE (se->expr), NULL); - gfc_add_modify_expr (&se->pre, val, se->expr); + gfc_add_modify (&se->pre, val, se->expr); se->expr = val; gfc_add_block_to_block (&se->pre, &se->post); } @@ -3617,9 +4519,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; } @@ -3637,7 +4539,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (se->post.head) { var = gfc_create_var (TREE_TYPE (se->expr), NULL); - gfc_add_modify_expr (&se->pre, var, se->expr); + gfc_add_modify (&se->pre, var, se->expr); gfc_add_block_to_block (&se->pre, &se->post); se->expr = var; } @@ -3645,13 +4547,17 @@ 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); var = gfc_create_var (TREE_TYPE (se->expr), NULL); - gfc_add_modify_expr (&se->pre, var, se->expr); + gfc_add_modify (&se->pre, var, se->expr); se->expr = var; return; } @@ -3664,7 +4570,8 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) { tree tmp = se->expr; STRIP_TYPE_NOPS (tmp); - var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp)); + var = build_decl (input_location, + CONST_DECL, NULL, TREE_TYPE (tmp)); DECL_INITIAL (var) = tmp; TREE_STATIC (var) = 1; pushdecl (var); @@ -3672,19 +4579,19 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) else { var = gfc_create_var (TREE_TYPE (se->expr), NULL); - gfc_add_modify_expr (&se->pre, var, se->expr); + gfc_add_modify (&se->pre, var, se->expr); } gfc_add_block_to_block (&se->pre, &se->post); /* Take the address of that value. */ - se->expr = build_fold_addr_expr (var); + se->expr = gfc_build_addr_expr (NULL_TREE, var); } tree gfc_trans_pointer_assign (gfc_code * code) { - return gfc_trans_pointer_assignment (code->expr, code->expr2); + return gfc_trans_pointer_assignment (code->expr1, code->expr2); } @@ -3702,7 +4609,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) tree tmp; tree decl; - gfc_start_block (&block); gfc_init_se (&lse, NULL); @@ -3718,17 +4624,47 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&rse, NULL); rse.want_pointer = 1; gfc_conv_expr (&rse, expr2); + + if (expr1->symtree->n.sym->attr.proc_pointer + && expr1->symtree->n.sym->attr.dummy) + 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_loc (input_location, + rse.expr); + gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); - gfc_add_modify_expr (&block, lse.expr, + + /* 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 + && !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); + gfc_trans_same_strlen_check ("pointer assignment", &expr1->where, + lse.string_length, rse.string_length, + &block); + } + + gfc_add_modify (&block, lse.expr, fold_convert (TREE_TYPE (lse.expr), rse.expr)); + gfc_add_block_to_block (&block, &rse.post); gfc_add_block_to_block (&block, &lse.post); } else { + tree strlen_lhs; + tree strlen_rhs = NULL_TREE; + /* Array pointer. */ gfc_conv_expr_descriptor (&lse, expr1, lss); + strlen_lhs = lse.string_length; switch (expr2->expr_type) { case EXPR_NULL: @@ -3738,8 +4674,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) case EXPR_VARIABLE: /* Assign directly to the pointer's descriptor. */ - lse.direct_byref = 1; + lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2, rss); + strlen_rhs = lse.string_length; /* If this is a subreference array pointer assignment, use the rhs descriptor element size for the lhs span. */ @@ -3752,8 +4689,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) tmp = gfc_get_element_type (TREE_TYPE (rse.expr)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); if (!INTEGER_CST_P (tmp)) - gfc_add_block_to_block (&lse.post, &rse.pre); - gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp); + gfc_add_block_to_block (&lse.post, &rse.pre); + gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); } break; @@ -3767,10 +4704,23 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) lse.expr = tmp; lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2, rss); - gfc_add_modify_expr (&lse.pre, desc, tmp); + strlen_rhs = lse.string_length; + gfc_add_modify (&lse.pre, desc, tmp); break; - } + } + gfc_add_block_to_block (&block, &lse.pre); + + /* Check string lengths if applicable. The check is only really added + to the output code if -fbounds-check is enabled. */ + if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL) + { + gcc_assert (expr2->ts.type == BT_CHARACTER); + gcc_assert (strlen_lhs && strlen_rhs); + gfc_trans_same_strlen_check ("pointer assignment", &expr1->where, + strlen_lhs, strlen_rhs, &block); + } + gfc_add_block_to_block (&block, &lse.post); } return gfc_finish_block (&block); @@ -3778,7 +4728,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) /* Makes sure se is suitable for passing as a function string parameter. */ -/* TODO: Need to check all callers fo this function. It may be abused. */ +/* TODO: Need to check all callers of this function. It may be abused. */ void gfc_conv_string_parameter (gfc_se * se) @@ -3787,15 +4737,18 @@ gfc_conv_string_parameter (gfc_se * se) if (TREE_CODE (se->expr) == STRING_CST) { - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + type = TREE_TYPE (TREE_TYPE (se->expr)); + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); return; } - type = TREE_TYPE (se->expr); - if (TYPE_STRING_FLAG (type)) + if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) { if (TREE_CODE (se->expr) != INDIRECT_REF) - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + { + type = TREE_TYPE (se->expr); + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); + } else { type = gfc_get_character_type_len (gfc_default_character_kind, @@ -3812,11 +4765,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; @@ -3844,9 +4798,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, rlen = rse->string_length; } - gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr); + 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; @@ -3854,8 +4809,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, if (r_is_var) { cond = fold_build2 (EQ_EXPR, boolean_type_node, - build_fold_addr_expr (lse->expr), - build_fold_addr_expr (rse->expr)); + gfc_build_addr_expr (NULL_TREE, lse->expr), + gfc_build_addr_expr (NULL_TREE, rse->expr)); cond = gfc_evaluate_now (cond, &lse->pre); } @@ -3863,37 +4818,46 @@ 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 (), tmp); + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), + tmp); gfc_add_expr_to_block (&lse->post, tmp); } gfc_add_block_to_block (&block, &rse->pre); gfc_add_block_to_block (&block, &lse->pre); - gfc_add_modify_expr (&block, lse->expr, + gfc_add_modify (&block, lse->expr, fold_convert (TREE_TYPE (lse->expr), rse->expr)); /* Do a deep copy if the rhs is a variable, if it is not the same as the lhs. */ if (r_is_var) { - tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); - tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + 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 (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_expr (&block, lse->expr, - fold_convert (TREE_TYPE (lse->expr), rse->expr)); + gfc_add_modify (&block, lse->expr, + fold_convert (TREE_TYPE (lse->expr), rse->expr)); } gfc_add_block_to_block (&block, &lse->post); @@ -3914,6 +4878,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; + bool c = false; + gfc_component *comp = NULL; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) @@ -3924,6 +4890,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) && expr2->value.function.esym->attr.elemental) return NULL; + /* Fail if rhs is not FULL or a contiguous section. */ + if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) + return NULL; + /* Fail if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) return NULL; @@ -3937,16 +4907,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) 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) + if (expr1->ts.u.cl->length == NULL + || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) return NULL; - if (expr2->ts.cl->length == NULL - || expr2->ts.cl->length->expr_type != EXPR_CONSTANT) + if (expr2->ts.u.cl->length == NULL + || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) return NULL; - if (mpz_cmp (expr1->ts.cl->length->value.integer, - expr2->ts.cl->length->value.integer) != 0) + if (mpz_cmp (expr1->ts.u.cl->length->value.integer, + expr2->ts.u.cl->length->value.integer) != 0) return NULL; } @@ -3967,14 +4937,17 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) /* Check for a dependency. */ if (gfc_check_fncall_dependency (expr1, INTENT_OUT, expr2->value.function.esym, - expr2->value.function.actual)) + expr2->value.function.actual, + NOT_ELEMENTAL)) return NULL; /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ gcc_assert (expr2->value.function.isym - || (gfc_return_by_reference (expr2->value.function.esym) - && expr2->value.function.esym->result->attr.dimension)); + || (gfc_is_proc_ptr_comp (expr2, &comp) + && comp && comp->attr.dimension) + || (!comp && gfc_return_by_reference (expr2->value.function.esym) + && expr2->value.function.esym->result->attr.dimension)); ss = gfc_walk_expr (expr1); gcc_assert (ss != gfc_ss_terminator); @@ -3982,7 +4955,16 @@ 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); + 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); @@ -3993,41 +4975,6 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) return gfc_finish_block (&se.pre); } -/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ - -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 (expr->value.complex.r) - && MPFR_SIGN (expr->value.complex.r) >= 0 - && mpfr_zero_p (expr->value.complex.i) - && MPFR_SIGN (expr->value.complex.i) >= 0; - - default: - break; - } - return false; -} /* Try to efficiently translate array(:) = 0. Return NULL if this can't be done. */ @@ -4057,15 +5004,19 @@ gfc_trans_zero_assign (gfc_expr * expr) len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, fold_convert (gfc_array_index_type, tmp)); - /* Convert arguments to the correct types. */ + /* If we are zeroing a local array avoid taking its address by emitting + a = {} instead. */ if (!POINTER_TYPE_P (TREE_TYPE (dest))) - dest = gfc_build_addr_expr (pvoid_type_node, dest); - else - dest = fold_convert (pvoid_type_node, dest); + return build2 (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); } @@ -4074,7 +5025,7 @@ gfc_trans_zero_assign (gfc_expr * expr) /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy that constructs the call to __builtin_memcpy. */ -static tree +tree gfc_build_memcpy_call (tree dst, tree src, tree len) { tree tmp; @@ -4093,7 +5044,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); } @@ -4196,10 +5148,13 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) /* 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; @@ -4211,6 +5166,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) stmtblock_t block; stmtblock_t body; bool l_is_temp; + bool scalar_to_array; + tree string_length; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -4223,6 +5180,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) rss = NULL; if (lss != gfc_ss_terminator) { + /* Allow the scalarizer to workshare array assignments. */ + if (ompws_flags & OMPWS_WORKSHARE_FLAG) + ompws_flags |= OMPWS_SCALARIZER_WS; + /* The assignment needs scalarization. */ lss_section = lss; @@ -4255,7 +5216,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) /* Resolve any data dependencies in the statement. */ gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr2->where); /* Setup the gfc_se structures. */ gfc_copy_loopinfo_to_se (&lse, &loop); @@ -4286,17 +5247,40 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) /* Translate the expression. */ gfc_conv_expr (&rse, expr2); + /* Stabilize a string length for temporaries. */ + if (expr2->ts.type == BT_CHARACTER) + string_length = gfc_evaluate_now (rse.string_length, &rse.pre); + else + string_length = NULL_TREE; + 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; } else gfc_conv_expr (&lse, expr1); + /* Assignments of scalar derived types with allocatable components + 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.u.derived->attr.alloc_comp + && expr2->expr_type != EXPR_VARIABLE + && !gfc_is_constant_expr (expr2) + && expr1->rank && !expr2->rank); + if (scalar_to_array && dealloc) + { + 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); + (expr2->expr_type == EXPR_VARIABLE) + || scalar_to_array, dealloc); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -4329,8 +5313,11 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); + if (expr2->ts.type == BT_CHARACTER) + 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); } @@ -4360,7 +5347,7 @@ copyable_array_p (gfc_expr * expr) if (expr->rank < 1 || !expr->ref || expr->ref->next) return false; - if (!gfc_full_array_ref_p (expr->ref)) + if (!gfc_full_array_ref_p (expr->ref, NULL)) return false; /* Next check that it's of a simple enough type. */ @@ -4376,7 +5363,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; @@ -4388,7 +5375,8 @@ 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; @@ -4431,17 +5419,195 @@ 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->expr, 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->expr, code->expr2, false); + return gfc_trans_assignment (code->expr1, code->expr2, false, true); +} + + +/* Generate code to assign typebound procedures to a derived vtab. */ +void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt, + gfc_symbol *vtab) +{ + gfc_component *cmp; + tree vtb; + tree ctree; + tree proc; + tree cond = NULL_TREE; + stmtblock_t body; + bool seen_extends; + + /* Point to the first procedure pointer. */ + cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true); + + seen_extends = (cmp != NULL); + + vtb = gfc_get_symbol_decl (vtab); + + if (seen_extends) + { + cmp = cmp->next; + if (!cmp) + return; + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + vtb, cmp->backend_decl, NULL_TREE); + cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree, + build_int_cst (TREE_TYPE (ctree), 0)); + } + else + { + cmp = vtab->ts.u.derived->components; + } + + gfc_init_block (&body); + for (; cmp; cmp = cmp->next) + { + gfc_symbol *target = NULL; + + /* Generic procedure - build its vtab. */ + if (cmp->ts.type == BT_DERIVED && !cmp->tb) + { + gfc_symbol *vt = cmp->ts.interface; + + if (vt == NULL) + { + /* Use association loses the interface. Obtain the vtab + by name instead. */ + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name, + cmp->name); + gfc_find_symbol (name, vtab->ns, 0, &vt); + if (vt == NULL) + continue; + } + + gfc_trans_assign_vtab_procs (&body, dt, vt); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + vtb, cmp->backend_decl, NULL_TREE); + proc = gfc_get_symbol_decl (vt); + proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc); + gfc_add_modify (&body, ctree, proc); + continue; + } + + /* This is required when typebound generic procedures are called + with derived type targets. The specific procedures do not get + added to the vtype, which remains "empty". */ + if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym) + target = cmp->tb->u.specific->n.sym; + else + { + gfc_symtree *st; + st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL); + if (st->n.tb && st->n.tb->u.specific) + target = st->n.tb->u.specific->n.sym; + } + + if (!target) + continue; + + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + vtb, cmp->backend_decl, NULL_TREE); + proc = gfc_get_symbol_decl (target); + proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc); + gfc_add_modify (&body, ctree, proc); + } + + proc = gfc_finish_block (&body); + + if (seen_extends) + proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (block, proc); +} + + +/* Translate an assignment to a CLASS object + (pointer or ordinary assignment). */ + +tree +gfc_trans_class_assign (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + gfc_expr *lhs; + gfc_expr *rhs; + + gfc_start_block (&block); + + if (code->op == EXEC_INIT_ASSIGN) + { + /* Special case for initializing a CLASS variable on allocation. + A MEMCPY is needed to copy the full data of the dynamic type, + which may be different from the declared type. */ + gfc_se dst,src; + tree memsz; + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_add_component_ref (code->expr1, "$data"); + gfc_conv_expr (&dst, code->expr1); + gfc_conv_expr (&src, code->expr2); + gfc_add_block_to_block (&block, &src.pre); + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); + } + + if (code->expr2->ts.type != BT_CLASS) + { + /* Insert an additional assignment which sets the '$vptr' field. */ + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$vptr"); + if (code->expr2->ts.type == BT_DERIVED) + { + gfc_symbol *vtab; + gfc_symtree *st; + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true); + gcc_assert (vtab); + gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab); + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, NULL, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; + } + else if (code->expr2->expr_type == EXPR_NULL) + rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + else + gcc_unreachable (); + + 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 (code->expr2->ts.type == BT_CLASS) + code->op = EXEC_ASSIGN; + else + gfc_add_component_ref (code->expr1, "$data"); + + if (code->op == EXEC_ASSIGN) + tmp = gfc_trans_assign (code); + else if (code->op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assign (code); + else + gcc_unreachable(); + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); }