X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-expr.c;h=570e07b5a06c135b32ea27628902403b9e5fb1fe;hb=989adef3b44d84f7b46c259ba46911460de87c51;hp=04736d5a1da8a3dc57783ca90c461f0ca128cf08;hpb=53e605661a7855bf12153c4dc68df9d9745957df;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 04736d5a1da..b76a3245d89 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,5 +1,6 @@ /* Expression translation - Copyright (C) 2002, 2003, 2004, 2005, 2006 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 @@ -7,7 +8,7 @@ This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY @@ -16,9 +17,8 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301, USA. */ +along with GCC; see the file COPYING3. If not see +. */ /* trans-expr.c-- generate GENERIC trees for gfc_expr. */ @@ -26,14 +26,12 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #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" @@ -114,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; } @@ -138,30 +136,47 @@ 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)); } /* Converts a missing, dummy argument into a null or zero. */ void -gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts) +gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) { tree present; tree tmp; present = gfc_conv_expr_present (arg->symtree->n.sym); - tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, - fold_convert (TREE_TYPE (se->expr), integer_zero_node)); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->expr = tmp; + if (kind > 0) + { + /* Create a temporary and convert it to the correct type. */ + tmp = gfc_get_int_type (kind); + tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, + se->expr)); + + /* Test for a NULL value. */ + tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, + fold_convert (TREE_TYPE (tmp), integer_one_node)); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->expr = gfc_build_addr_expr (NULL_TREE, tmp); + } + else + { + tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, + fold_convert (TREE_TYPE (se->expr), integer_zero_node)); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->expr = tmp; + } + if (ts.type == BT_CHARACTER) { tmp = build_int_cst (gfc_charlen_type_node, 0); - tmp = build3 (COND_EXPR, gfc_charlen_type_node, present, - se->string_length, tmp); + tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node, + present, se->string_length, tmp); tmp = gfc_evaluate_now (tmp, &se->pre); se->string_length = tmp; } @@ -183,11 +198,20 @@ gfc_get_expr_charlen (gfc_expr *e) length = NULL; /* To silence compiler warning. */ + 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.u.cl->length, gfc_charlen_type_node); + e->ts.u.cl->backend_decl = tmpse.expr; + return tmpse.expr; + } + /* First candidate: if the variable is of type CHARACTER, the 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) @@ -196,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: @@ -207,6 +231,7 @@ gfc_get_expr_charlen (gfc_expr *e) /* We should never got substring references here. These will be broken down by the scalarizer. */ gcc_unreachable (); + break; } } @@ -214,23 +239,115 @@ 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_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock) +gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) { gfc_se se; - tree tmp; 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); - tmp = cl->backend_decl; - gfc_add_modify_expr (pblock, tmp, se.expr); + if (cl->backend_decl) + gfc_add_modify (pblock, cl->backend_decl, se.expr); + else + cl->backend_decl = gfc_evaluate_now (se.expr, pblock); } @@ -240,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; @@ -249,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); @@ -258,12 +373,19 @@ 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 (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 = gfc_build_array_ref (tmp, start.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); } @@ -276,7 +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 (flag_bounds_check) + tmp = end.expr; + STRIP_NOPS (tmp); + if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) + end.expr = gfc_evaluate_now (end.expr, &se->pre); + + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { tree nonempty = fold_build2 (LE_EXPR, boolean_type_node, start.expr, end.expr); @@ -287,12 +414,14 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, nonempty, fault); if (name) - asprintf (&msg, "Substring out of bounds: lower bound of '%s' " + asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' " "is less than one", name); else - asprintf (&msg, "Substring out of bounds: lower bound " + asprintf (&msg, "Substring out of bounds: lower bound (%%ld)" "is less than one"); - gfc_trans_runtime_check (fault, msg, &se->pre, where); + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, + fold_convert (long_integer_type_node, + start.expr)); gfc_free (msg); /* Check upper bound. */ @@ -301,19 +430,22 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, nonempty, fault); if (name) - asprintf (&msg, "Substring out of bounds: upper bound of '%s' " - "exceeds string length", name); + asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' " + "exceeds string length (%%ld)", name); else - asprintf (&msg, "Substring out of bounds: upper bound " - "exceeds string length"); - gfc_trans_runtime_check (fault, msg, &se->pre, where); + asprintf (&msg, "Substring out of bounds: upper bound (%%ld) " + "exceeds string length (%%ld)"); + 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)); gfc_free (msg); } tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, - build_int_cst (gfc_charlen_type_node, 1), - start.expr); - tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp); + 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; @@ -337,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). */ @@ -439,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; } @@ -460,25 +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); - - /* A character with VALUE attribute needs an address - expression. */ - if (sym->attr.value) - se->expr = build_fold_addr_expr (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. */ @@ -487,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; @@ -498,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); } @@ -525,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; @@ -543,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); } } @@ -571,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); } @@ -634,7 +812,7 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] = /* Recursive function to expand the power operator. The temporary values are put in tmpvar. The function returns tmpvar[1] ** n. */ static tree -gfc_conv_powi (gfc_se * se, int n, tree * tmpvar) +gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) { tree op0; tree op1; @@ -681,15 +859,25 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) tree tmp; tree type; tree vartmp[POWI_TABLE_SIZE]; - int n; + HOST_WIDE_INT m; + unsigned HOST_WIDE_INT n; int sgn; + /* If exponent is too large, we won't expand it anyway, so don't bother + with large integer values. */ + if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs))) + return 0; + + m = double_int_to_shwi (TREE_INT_CST (rhs)); + /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care + of the asymmetric range of the integer type. */ + n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m); + type = TREE_TYPE (lhs); - n = abs (TREE_INT_CST_LOW (rhs)); sgn = tree_int_cst_sgn (rhs); - if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size) - && (n > 2 || n < -1)) + if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) + || optimize_size) && (m > 2 || m < -1)) return 0; /* rhs == 0 */ @@ -698,28 +886,31 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) se->expr = gfc_build_const (type, integer_one_node); return 1; } + /* 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; } @@ -728,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); @@ -748,7 +939,6 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) gfc_se lse; gfc_se rse; tree fndecl; - tree tmp; gfc_init_se (&lse, se); gfc_conv_expr_val (&lse, expr->value.op.op1); @@ -760,9 +950,9 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->pre, &rse.pre); if (expr->value.op.op2->ts.type == BT_INTEGER - && expr->value.op.op2->expr_type == EXPR_CONSTANT) + && expr->value.op.op2->expr_type == EXPR_CONSTANT) if (gfc_conv_cst_int_power (se, lse.expr, rse.expr)) - return; + return; gfc_int4_type_node = gfc_get_int_type (4); @@ -832,7 +1022,30 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case BT_REAL: - fndecl = gfor_fndecl_math_powi[kind][ikind].real; + /* Use builtins for real ** int4. */ + if (ikind == 0) + { + switch (kind) + { + case 0: + fndecl = built_in_decls[BUILT_IN_POWIF]; + break; + + case 1: + fndecl = built_in_decls[BUILT_IN_POWI]; + break; + + case 2: + case 3: + fndecl = built_in_decls[BUILT_IN_POWIL]; + break; + + default: + gcc_unreachable (); + } + } + else + fndecl = gfor_fndecl_math_powi[kind][ikind].real; break; case BT_COMPLEX: @@ -866,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 (); @@ -887,9 +1098,8 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; } - tmp = gfc_chainon_list (NULL_TREE, lse.expr); - tmp = gfc_chainon_list (tmp, rse.expr); - se->expr = build_function_call_expr (fndecl, tmp); + se->expr = build_call_expr_loc (input_location, + fndecl, 2, lse.expr, rse.expr); } @@ -900,9 +1110,6 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { tree var; tree tmp; - tree args; - - gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node); if (gfc_can_put_var_on_stack (len)) { @@ -910,7 +1117,12 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) 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); } @@ -918,15 +1130,14 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { /* Allocate a temporary to hold the result. */ var = gfc_create_var (type, "pstr"); - args = gfc_chainon_list (NULL_TREE, len); - tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args); - tmp = convert (type, tmp); - 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 = convert (pvoid_type_node, var); - args = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (gfor_fndecl_internal_free, args); + tmp = gfc_call_free (convert (pvoid_type_node, var)); gfc_add_expr_to_block (&se->post, tmp); } @@ -940,16 +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 args; - 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); @@ -961,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) { @@ -974,14 +1181,16 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) var = gfc_conv_string_tmp (se, type, len); /* Do the actual concatenation. */ - args = NULL_TREE; - args = gfc_chainon_list (args, len); - args = gfc_chainon_list (args, var); - args = gfc_chainon_list (args, lse.string_length); - args = gfc_chainon_list (args, lse.expr); - args = gfc_chainon_list (args, rse.string_length); - args = gfc_chainon_list (args, rse.expr); - tmp = build_function_call_expr (gfor_fndecl_concat_string, args); + 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); /* Add the cleanup for the operands. */ @@ -1006,17 +1215,26 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) enum tree_code code; gfc_se lse; gfc_se rse; - tree type; - tree tmp; + tree tmp, type; int lop; int checkstring; 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; @@ -1071,6 +1289,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) /* EQV and NEQV only work on logicals, but since we represent them as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */ case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: case INTRINSIC_EQV: code = EQ_EXPR; checkstring = 1; @@ -1078,6 +1297,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) break; case INTRINSIC_NE: + case INTRINSIC_NE_OS: case INTRINSIC_NEQV: code = NE_EXPR; checkstring = 1; @@ -1085,24 +1305,28 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) break; case INTRINSIC_GT: + case INTRINSIC_GT_OS: code = GT_EXPR; checkstring = 1; lop = 1; break; case INTRINSIC_GE: + case INTRINSIC_GE_OS: code = GE_EXPR; checkstring = 1; lop = 1; break; case INTRINSIC_LT: + case INTRINSIC_LT_OS: code = LT_EXPR; checkstring = 1; lop = 1; break; case INTRINSIC_LE: + case INTRINSIC_LE_OS: code = LE_EXPR; checkstring = 1; lop = 1; @@ -1140,8 +1364,9 @@ 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.expr = integer_zero_node; + 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); } @@ -1150,7 +1375,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) if (lop) { /* The result of logical ops is always boolean_type_node. */ - tmp = fold_build2 (code, type, lse.expr, rse.expr); + tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr); se->expr = convert (type, tmp); } else @@ -1164,69 +1389,156 @@ 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; } + +void +gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) +{ + + if (sym->backend_decl) + { + /* This becomes the nominal_type in + function.c:assign_parm_find_data_types. */ + TREE_TYPE (sym->backend_decl) = unsigned_char_type_node; + /* This becomes the passed_type in + function.c:assign_parm_find_data_types. C promotes char to + integer for argument passing. */ + DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node; + + DECL_BY_REFERENCE (sym->backend_decl) = 0; + } + + if (expr != NULL) + { + /* If we have a constant character expression, make it into an + integer. */ + if ((*expr)->expr_type == EXPR_CONSTANT) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + *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 + conversion fails, then the 2 causes an ICE. */ + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (*expr, &ts, 2); + } + } + else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE) + { + if ((*expr)->ref == NULL) + { + se->expr = string_to_single_character + (build_int_cst (integer_type_node, 1), + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + gfc_get_symbol_decl + ((*expr)->symtree->n.sym)), + (*expr)->ts.kind); + } + else + { + gfc_conv_variable (se, *expr); + se->expr = string_to_single_character + (build_int_cst (integer_type_node, 1), + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + se->expr), + (*expr)->ts.kind); + } + } + } +} + + /* Compare two strings. If they are all single characters, the result is the subtraction of them. Otherwise, we build a library call. */ tree -gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) { tree sc1; tree sc2; - tree type; tree tmp; gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - type = gfc_get_int_type (gfc_default_integer_kind); + sc1 = string_to_single_character (len1, str1, kind); + sc2 = string_to_single_character (len2, str2, kind); - sc1 = gfc_to_single_character (len1, str1); - sc2 = gfc_to_single_character (len2, str2); - - /* Deal with single character specially. */ if (sc1 != NULL_TREE && sc2 != NULL_TREE) { - sc1 = fold_convert (type, sc1); - sc2 = fold_convert (type, sc2); - tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2); + /* 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 + else { - tmp = NULL_TREE; - tmp = gfc_chainon_list (tmp, len1); - tmp = gfc_chainon_list (tmp, str1); - tmp = gfc_chainon_list (tmp, len2); - tmp = gfc_chainon_list (tmp, str2); - /* Build a call for the comparison. */ - tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp); + 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); } @@ -1236,13 +1548,21 @@ 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; @@ -1272,8 +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); - gfc_free (sym->new); + sym->new_sym->n.sym->formal = NULL; + gfc_free_symbol (sym->new_sym->n.sym); + gfc_free_expr (sym->expr); + gfc_free (sym->new_sym); gfc_free (sym); } for (cl = mapping->charlens; cl; cl = nextcl) @@ -1292,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; } @@ -1311,16 +1633,18 @@ gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping, static tree gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym, - int packed, tree data) + gfc_packed packed, tree data) { tree type; 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; } @@ -1346,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); @@ -1377,7 +1701,8 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) void gfc_add_interface_mapping (gfc_interface_mapping * mapping, - gfc_symbol * sym, gfc_se * se) + gfc_symbol * sym, gfc_se * se, + gfc_expr *expr) { gfc_interface_sym_mapping *sm; tree desc; @@ -1390,11 +1715,23 @@ 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; @@ -1403,30 +1740,36 @@ 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; /* Stabilize the argument's value. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); + if (!sym->attr.function && se) + se->expr = gfc_evaluate_now (se->expr, &se->pre); 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); + 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) + 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; } } + if (!se) + return; + /* Use the passed value as-is if the argument is a function. */ if (sym->attr.flavor == FL_PROCEDURE) value = se->expr; @@ -1438,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); @@ -1447,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. */ @@ -1459,18 +1805,21 @@ 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); - value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp); + value = gfc_get_interface_mapping_array (&se->pre, sym, + PACKED_NO, tmp); /* Use DESC to work out the upper bounds, strides and offset. */ gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc); } else /* Otherwise we have a packed array. */ - value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr); + value = gfc_get_interface_mapping_array (&se->pre, sym, + PACKED_FULL, se->expr); new_sym->backend_decl = value; } @@ -1490,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; } } @@ -1512,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) @@ -1560,6 +1910,164 @@ 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_symbol *sym; + gfc_expr *new_expr; + gfc_expr *arg1; + gfc_expr *arg2; + int d, dup; + + arg1 = expr->value.function.actual->expr; + if (expr->value.function.actual->next) + arg2 = expr->value.function.actual->next->expr; + else + arg2 = NULL; + + sym = arg1->symtree->n.sym; + + if (sym->attr.dummy) + return false; + + new_expr = NULL; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_LEN: + /* TODO figure out why this condition is necessary. */ + if (sym->attr.function + && (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.u.cl->length); + break; + + case GFC_ISYM_SIZE: + if (!sym->as || sym->as->rank == 0) + return false; + + if (arg2 && arg2->expr_type == EXPR_CONSTANT) + { + dup = mpz_get_si (arg2->value.integer); + d = dup - 1; + } + else + { + dup = sym->as->rank; + d = 0; + } + + for (; d < dup; d++) + { + gfc_expr *tmp; + + 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); + else + new_expr = tmp; + } + break; + + case GFC_ISYM_LBOUND: + case GFC_ISYM_UBOUND: + /* 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 || sym->as->rank == 0) + return false; + + if (arg2 && arg2->expr_type == EXPR_CONSTANT) + d = mpz_get_si (arg2->value.integer) - 1; + else + /* TODO: If the need arises, this could produce an array of + ubound/lbounds. */ + gcc_unreachable (); + + if (expr->value.function.isym->id == GFC_ISYM_LBOUND) + { + if (sym->as->lower[d]) + new_expr = gfc_copy_expr (sym->as->lower[d]); + } + else + { + if (sym->as->upper[d]) + new_expr = gfc_copy_expr (sym->as->upper[d]); + } + break; + + default: + break; + } + + gfc_apply_interface_mapping_to_expr (mapping, new_expr); + if (!new_expr) + return false; + + gfc_replace_expr (expr, new_expr); + return true; +} + + +static void +gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr, + gfc_interface_mapping * mapping) +{ + gfc_formal_arglist *f; + gfc_actual_arglist *actual; + + actual = expr->value.function.actual; + f = map_expr->symtree->n.sym->formal; + + for (; f && actual; f = f->next, actual = actual->next) + { + if (!actual->expr) + continue; + + gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr); + } + + if (map_expr->symtree->n.sym->attr.dimension) + { + int d; + gfc_array_spec *as; + + as = gfc_copy_array_spec (map_expr->symtree->n.sym->as); + + for (d = 0; d < as->rank; d++) + { + gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]); + gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]); + } + + expr->value.function.esym->as = as; + } + + if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER) + { + 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.u.cl->length); + } +} + + /* EXPR is a copy of an expression that appeared in the interface associated with MAPPING. Walk it recursively looking for references to dummy arguments that MAPPING maps to actual arguments. Replace each such @@ -1576,22 +2084,28 @@ 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. */ gfc_apply_interface_mapping_to_ref (mapping, expr->ref); /* ...and to the expression's symbol, if it has one. */ - if (expr->symtree) - for (sym = mapping->syms; sym; sym = sym->next) - if (sym->old == expr->symtree->n.sym) - expr->symtree = sym->new; + /* TODO Find out why the condition on expr->symtree had to be moved into + 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_sym->n.sym->backend_decl) + expr->symtree = sym->new_sym; + else if (sym->expr) + gfc_replace_expr (expr, gfc_copy_expr (sym->expr)); + } - /* ...and to subexpressions in expr->value. */ + /* ...and to subexpressions in expr->value. */ switch (expr->expr_type) { case EXPR_VARIABLE: @@ -1606,21 +2120,38 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, break; case EXPR_FUNCTION: - for (sym = mapping->syms; sym; sym = sym->next) - if (sym->old == expr->value.function.esym) - expr->value.function.esym = sym->new->n.sym; - for (actual = expr->value.function.actual; actual; actual = actual->next) gfc_apply_interface_mapping_to_expr (mapping, actual->expr); + + if (expr->value.function.esym == NULL + && expr->value.function.isym != NULL + && expr->value.function.actual->expr->symtree + && gfc_map_intrinsic_function (expr, mapping)) + break; + + for (sym = mapping->syms; sym; sym = sym->next) + if (sym->old == expr->value.function.esym) + { + 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_sym->n.sym; + } break; case EXPR_ARRAY: case EXPR_STRUCTURE: gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor); break; - } -} - + + case EXPR_COMPCALL: + case EXPR_PPC: + gcc_unreachable (); + break; + } + + return; +} + /* Evaluate interface expression EXPR using MAPPING. Store the result in SE. */ @@ -1636,15 +2167,13 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping, gfc_free_expr (expr); } + /* Returns a reference to a temporary array into which a component of an actual argument derived type array is copied and then returned - after the function call. - TODO Get rid of this kludge, when array descriptors are capable of - handling aliased arrays. */ - -static void -gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, - int g77, sym_intent intent) + after the function call. */ +void +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; @@ -1657,8 +2186,10 @@ gfc_conv_aliased_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); @@ -1678,6 +2209,9 @@ gfc_conv_aliased_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.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) || GFC_DESCRIPTOR_TYPE_P (base_type)) @@ -1688,38 +2222,11 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, loop.temp_ss->data.temp.type = base_type; if (expr->ts.type == BT_CHARACTER) - { - gfc_ref *char_ref = expr->ref; - - for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next) - if (char_ref->type == REF_SUBSTRING) - { - gfc_se tmp_se; - - expr->ts.cl = gfc_get_charlen (); - expr->ts.cl->next = char_ref->u.ss.length->next; - char_ref->u.ss.length->next = expr->ts.cl; - - gfc_init_se (&tmp_se, NULL); - gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end, - gfc_array_index_type); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp_se.expr, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, &parmse->pre); - gfc_init_se (&tmp_se, NULL); - gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start, - gfc_array_index_type); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - tmp, tmp_se.expr); - expr->ts.cl->backend_decl = tmp; - - break; - } - loop.temp_ss->data.temp.type - = gfc_typenode_for_spec (&expr->ts); - loop.temp_ss->string_length = expr->ts.cl->backend_decl; - } + loop.temp_ss->string_length = expr->ts.u.cl->backend_decl; + else + loop.temp_ss->string_length = NULL; + parmse->string_length = loop.temp_ss->string_length; loop.temp_ss->data.temp.dimen = loop.dimen; loop.temp_ss->next = gfc_ss_terminator; @@ -1727,7 +2234,7 @@ gfc_conv_aliased_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; @@ -1753,7 +2260,7 @@ gfc_conv_aliased_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); @@ -1792,7 +2299,7 @@ gfc_conv_aliased_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); @@ -1811,9 +2318,10 @@ gfc_conv_aliased_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]; @@ -1833,23 +2341,24 @@ gfc_conv_aliased_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); - rse.expr = gfc_build_array_ref (tmp, tmp_index); + 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. */ @@ -1871,48 +2380,286 @@ gfc_conv_aliased_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; } -/* Is true if an array reference is followed by a component or substring - reference. */ -static bool -is_aliased_array (gfc_expr * e) +/* Generate the code for argument list functions. */ + +static void +conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) { - gfc_ref * ref; - bool seen_array; + /* Pass by value for g77 %VAL(arg), pass the address + indirectly for %LOC, else by reference. Thus %REF + is a "do-nothing" and %LOC is the same as an F95 + pointer. */ + if (strncmp (name, "%VAL", 4) == 0) + gfc_conv_expr (se, expr); + else if (strncmp (name, "%LOC", 4) == 0) + { + gfc_conv_expr_reference (se, expr); + se->expr = gfc_build_addr_expr (NULL, se->expr); + } + else if (strncmp (name, "%REF", 4) == 0) + gfc_conv_expr_reference (se, expr); + else + gfc_error ("Unknown argument list function at %L", &expr->where); +} + + +/* 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); +} + - seen_array = false; - for (ref = e->ref; ref; ref = ref->next) +/* 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 (ref->type == REF_ARRAY - && ref->u.ar.type != AR_ELEMENT) - seen_array = true; + 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); - if (seen_array - && ref->type != REF_ARRAY) - return seen_array; + return 1; } - return false; + 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; @@ -1928,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; @@ -1938,29 +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 + && conv_isocbinding_procedure (se, sym, arg)) + return 0; + + gfc_is_proc_ptr_comp (expr, &comp); 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; } @@ -1969,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 @@ -1992,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 @@ -2019,22 +2797,105 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, if (argss == gfc_ss_terminator) { - parm_kind = SCALAR; - 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 + && fsym->ns->proc_name != NULL + && fsym->ns->proc_name->attr.is_bind_c) + { + parmse.expr = NULL; + gfc_conv_scalar_char_value (fsym, &parmse, &e); + if (parmse.expr == NULL) + gfc_conv_expr (&parmse, e); + } + else + gfc_conv_expr (&parmse, e); + } + else if (arg->name && arg->name[0] == '%') + /* Argument list functions %VAL, %LOC and %REF are signalled + through arg->name. */ + conv_arglist_function (&parmse, arg->expr, arg->name); + else if ((e->expr_type == EXPR_FUNCTION) + && ((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); + 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 - && 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); } } } @@ -2046,94 +2907,109 @@ 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_aliased_array (e)) + && is_subref_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ - gfc_conv_aliased_arg (&parmse, e, f, - fsym ? fsym->attr.intent : INTENT_INOUT); + gfc_conv_subref_array_arg (&parmse, e, f, + 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 = e->symtree->n.sym->backend_decl; - if (e->symtree->n.sym->attr.dummy) - tmp = build_fold_indirect_ref (tmp); - 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); + } } } - if (fsym) + /* The case with fsym->attr.optional is that of a user subroutine + with an interface indicating an optional argument. When we call + an intrinsic subroutine, however, fsym is NULL, but we might still + have an optional argument, so we proceed to the substitution + just in case. */ + if (e && (fsym == NULL || fsym->attr.optional)) { - if (e) - { - /* If an optional argument is itself an optional dummy - argument, check its presence and substitute a null - if absent. */ - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional - && fsym->attr.optional) - gfc_conv_missing_dummy (&parmse, e, fsym->ts); - - /* If an INTENT(OUT) dummy of derived type has a default - initializer, it must be (re)initialized here. */ - if (fsym->attr.intent == INTENT_OUT - && fsym->ts.type == BT_DERIVED - && fsym->value) - { - gcc_assert (!fsym->attr.allocatable); - tmp = gfc_trans_assignment (e, fsym->value, false); - gfc_add_expr_to_block (&se->pre, tmp); - } + /* If an optional argument is itself an optional dummy argument, + 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->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); + } - /* Obtain the character length of an assumed character - length procedure from the typespec. */ - if (fsym->ts.type == BT_CHARACTER - && parmse.string_length == NULL_TREE - && e->ts.type == BT_PROCEDURE - && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.cl->length != NULL) - { - gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); - parmse.string_length - = e->symtree->n.sym->ts.cl->backend_decl; - } + if (fsym && e) + { + /* Obtain the character length of an assumed character length + length procedure from the typespec. */ + if (fsym->ts.type == BT_CHARACTER + && parmse.string_length == NULL_TREE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->symtree->n.sym->ts.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.u.cl); + parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; } - - if (need_interface_mapping) - gfc_add_interface_mapping (&mapping, fsym, &parmse); } + if (fsym && need_interface_mapping && e) + gfc_add_interface_mapping (&mapping, fsym, &parmse, e); + gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&post, &parmse.post); /* Allocated allocatable components of derived types must be - deallocated for INTENT(OUT) dummy arguments and non-variable - scalars. Non-variable arrays are dealt with in trans-array.c - (gfc_conv_array_parameter). */ + 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) { @@ -2143,41 +3019,136 @@ 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_OP + && e->value.op.op == INTRINSIC_PARENTHESES + && e->value.op.op1->expr_type == EXPR_VARIABLE) + { + 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 (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 (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 { - gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT); - gfc_add_expr_to_block (&se->pre, tmp); + 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. */ - if (parmse.string_length != NULL_TREE) + pointer - except for Bind(c) which only passes the pointer. */ + if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) stringargs = gfc_chainon_list (stringargs, parmse.string_length); arglist = gfc_chainon_list (arglist, parmse.expr); } gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); - ts = sym->ts; - if (ts.type == BT_CHARACTER) + if (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 @@ -2192,36 +3163,80 @@ 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); - cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr); + + tmp = fold_convert (gfc_charlen_type_node, parmse.expr); + tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, + build_int_cst (gfc_charlen_type_node, 0)); + cl.backend_decl = tmp; } /* Set up a charlen structure for it. */ cl.next = NULL; cl.length = NULL; - ts.cl = &cl; + ts.u.cl = &cl; len = cl.backend_decl; } - byref = 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) - retargs = gfc_chainon_list (retargs, se->expr); - else if (sym->result->attr.dimension) + { + /* 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_loc (input_location, + se->expr); + + result = build_fold_indirect_ref_loc (input_location, + se->expr); + retargs = gfc_chainon_list (retargs, se->expr); + } + 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); @@ -2237,34 +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, - true); + 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))) { - /* Build char[0:len-1] * pstr. */ - tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, - build_int_cst (gfc_charlen_type_node, 1)); - tmp = build_range_type (gfc_array_index_type, - gfc_index_zero_node, tmp); - tmp = build_array_type (gfc_character1_type_node, tmp); - var = gfc_create_var (build_pointer_type (tmp), "pstr"); + 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); @@ -2276,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); } @@ -2298,30 +3314,38 @@ 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 - with other functions. */ + with other functions. For dummy arguments, the typing is done to + to this result, even if it has to be repeated for each call. */ if (has_alternate_specifier && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node) { - gcc_assert (! sym->attr.dummy); - TREE_TYPE (sym->backend_decl) - = build_function_type (integer_type_node, - TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); - se->expr = build_fold_addr_expr (sym->backend_decl); + if (!sym->attr.dummy) + { + TREE_TYPE (sym->backend_decl) + = build_function_type (integer_type_node, + TYPE_ARG_TYPES (TREE_TYPE (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; } fntype = TREE_TYPE (TREE_TYPE (se->expr)); - se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr, - arglist, NULL_TREE); + se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist); /* If we have a pointer function, but we don't want a pointer, e.g. something like x = f() where f is pointer valued, we have to dereference the result. */ - if (!se->want_pointer && !byref && sym->attr.pointer) - se->expr = 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 @@ -2348,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, gfc_msg_fault, &se->pre, NULL); + 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; @@ -2375,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); @@ -2391,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. */ -static void +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; @@ -2405,23 +3528,50 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tree tmp2; tree tmp3; tree tmp4; + tree chartype; stmtblock_t tempblock; - dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); + gcc_assert (dkind == skind); + + if (slength != NULL_TREE) + { + slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); + ssc = string_to_single_character (slen, src, skind); + } + else + { + slen = build_int_cst (size_type_node, 1); + ssc = src; + } + + if (dlength != NULL_TREE) + { + dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); + dsc = string_to_single_character (slen, dest, dkind); + } + else + { + dlen = build_int_cst (size_type_node, 1); + dsc = dest; + } + + if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) + ssc = string_to_single_character (slen, src, skind); + if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) + dsc = string_to_single_character (dlen, dest, dkind); + - /* Deal with single character specially. */ - dsc = gfc_to_single_character (dlen, dest); - ssc = gfc_to_single_character (slen, src); - if (dsc != NULL_TREE && ssc != NULL_TREE) + /* 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; } /* Do nothing if the destination length is zero. */ cond = fold_build2 (GT_EXPR, boolean_type_node, dlen, - build_int_cst (gfc_charlen_type_node, 0)); + build_int_cst (size_type_node, 0)); /* The following code was previously in _gfortran_copy_string: @@ -2445,29 +3595,43 @@ 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 + dest = gfc_build_addr_expr (pvoid_type_node, dest); + + if (slength) + src = fold_convert (pvoid_type_node, src); + else + src = gfc_build_addr_expr (pvoid_type_node, src); + /* Truncate string if source is too long. */ cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen); - tmp2 = gfc_chainon_list (NULL_TREE, dest); - tmp2 = gfc_chainon_list (tmp2, src); - tmp2 = gfc_chainon_list (tmp2, dlen); - tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2); + tmp2 = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMMOVE], + 3, dest, src, dlen); /* Else copy and pad with spaces. */ - tmp3 = gfc_chainon_list (NULL_TREE, dest); - tmp3 = gfc_chainon_list (tmp3, src); - tmp3 = gfc_chainon_list (tmp3, slen); - tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3); - - tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest, - fold_convert (pchar_type_node, slen)); - tmp4 = gfc_chainon_list (NULL_TREE, tmp4); - tmp4 = gfc_chainon_list (tmp4, build_int_cst - (gfc_get_int_type (gfc_c_int_kind), - lang_hooks.to_target_charset (' '))); - tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), - dlen, slen)); - tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4); + 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 = 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); @@ -2476,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); } @@ -2528,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), @@ -2540,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); } @@ -2551,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); } @@ -2566,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. */ @@ -2616,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; } @@ -2644,11 +3849,33 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, if (!(expr || pointer)) return NULL_TREE; + /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR + (these are the only two iso_c_binding derived types that can be + 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.u.derived) + { + 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; + + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, expr); + return se.expr; + } + if (array) { /* 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); } @@ -2659,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); @@ -2736,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); @@ -2752,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); @@ -2778,26 +4009,167 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) } -/* Assign a single component of a derived type constructor. */ - static tree -gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) +gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, + gfc_expr * expr) { gfc_se se; - gfc_se lse; gfc_ss *rss; stmtblock_t block; - tree tmp; tree offset; int n; + tree tmp; + tree tmp2; + gfc_array_spec *as; + gfc_expr *arg = NULL; gfc_start_block (&block); + gfc_init_se (&se, NULL); - if (cm->pointer) - { + /* 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 +gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) +{ + gfc_se se; + gfc_se lse; + gfc_ss *rss; + stmtblock_t block; + tree tmp; + + gfc_start_block (&block); + + 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) @@ -2818,75 +4190,32 @@ 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) - { - tree tmp2; - - gfc_init_se (&se, NULL); - - rss = gfc_walk_expr (expr); - se.want_pointer = 0; - gfc_conv_expr_descriptor (&se, expr, rss); - gfc_add_block_to_block (&block, &se.pre); - - tmp = fold_convert (TREE_TYPE (dest), se.expr); - gfc_add_modify_expr (&block, dest, tmp); - - if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) - tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, - cm->as->rank); - else - tmp = gfc_duplicate_allocatable (dest, se.expr, - TREE_TYPE(cm->backend_decl), - cm->as->rank); - - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &se.post); - gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); - - /* Shift the lbound and ubound of temporaries to being unity, rather - than zero, based. Calculate the offset for all cases. */ - offset = gfc_conv_descriptor_offset (dest); - gfc_add_modify_expr (&block, offset, gfc_index_zero_node); - tmp2 =gfc_create_var (gfc_array_index_type, NULL); - for (n = 0; n < expr->rank; n++) - { - if (expr->expr_type != EXPR_VARIABLE - && expr->expr_type != EXPR_CONSTANT) - { - tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]); - gfc_add_modify_expr (&block, tmp, - fold_build2 (PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node)); - tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]); - gfc_add_modify_expr (&block, tmp, gfc_index_one_node); - } - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - gfc_conv_descriptor_lbound (dest, - gfc_rank_cst[n]), - gfc_conv_descriptor_stride (dest, - gfc_rank_cst[n])); - gfc_add_modify_expr (&block, tmp2, tmp); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); - gfc_add_modify_expr (&block, offset, tmp); - } - } + else if (cm->attr.allocatable) + { + tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); + gfc_add_expr_to_block (&block, tmp); + } else - { + { tmp = gfc_trans_subarray_assign (dest, cm, expr); gfc_add_expr_to_block (&block, tmp); - } + } } else if (expr->ts.type == BT_DERIVED) { @@ -2894,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 { @@ -2912,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); @@ -2932,15 +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; + + /* 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); } @@ -2967,30 +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; } @@ -3003,14 +4370,17 @@ gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) ref = expr->ref; - gcc_assert (ref->type == REF_SUBSTRING); + gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); + + se->expr = gfc_build_wide_string_const (expr->ts.kind, + expr->value.character.length, + expr->value.character.string); - se->expr = gfc_build_string_const(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; + TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1; - gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where); + if (ref) + gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where); } @@ -3027,11 +4397,38 @@ 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; } + /* We need to convert the expressions for the iso_c_binding derived types. + C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to + 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.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) + { + /* Set expr_type to EXPR_NULL, which will result in + null_pointer_node being used below. */ + expr->expr_type = EXPR_NULL; + } + else + { + /* 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.u.derived->ts.type; + expr->ts.f90_type = expr->ts.u.derived->ts.f90_type; + expr->ts.kind = expr->ts.u.derived->ts.kind; + } + } + switch (expr->expr_type) { case EXPR_OP: @@ -3096,13 +4493,13 @@ 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); } } -/* Helper to translate and expression and convert it to a particular type. */ +/* Helper to translate an expression and convert it to a particular type. */ void gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type) { @@ -3122,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; } @@ -3142,13 +4539,30 @@ 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; } return; } + if (expr->expr_type == EXPR_FUNCTION + && ((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 (&se->pre, var, se->expr); + se->expr = var; + return; + } + + gfc_conv_expr (se, expr); /* Create a temporary var to hold the value. */ @@ -3156,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); @@ -3164,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); } @@ -3192,6 +4607,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) stmtblock_t block; tree desc; tree tmp; + tree decl; gfc_start_block (&block); @@ -3208,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: @@ -3228,8 +4674,25 @@ 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. */ + if (expr1->symtree->n.sym->attr.subref_array_pointer) + { + decl = expr1->symtree->n.sym->backend_decl; + gfc_init_se (&rse, NULL); + rse.descriptor_only = 1; + gfc_conv_expr (&rse, 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 (&lse.post, GFC_DECL_SPAN(decl), tmp); + } + break; default: @@ -3241,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); @@ -3252,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) @@ -3261,15 +4737,25 @@ 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))) { - gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF); - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + if (TREE_CODE (se->expr) != INDIRECT_REF) + { + 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, + se->string_length); + type = build_pointer_type (type); + se->expr = gfc_build_addr_expr (type, se->expr); + } } gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr))); @@ -3279,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; @@ -3293,19 +4780,28 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, if (ts.type == BT_CHARACTER) { - gcc_assert (lse->string_length != NULL_TREE - && rse->string_length != NULL_TREE); + tree rlen = NULL; + tree llen = NULL; - gfc_conv_string_parameter (lse); - gfc_conv_string_parameter (rse); + if (lse->string_length != NULL_TREE) + { + gfc_conv_string_parameter (lse); + gfc_add_block_to_block (&block, &lse->pre); + llen = lse->string_length; + } - gfc_add_block_to_block (&block, &lse->pre); - gfc_add_block_to_block (&block, &rse->pre); + if (rse->string_length != NULL_TREE) + { + gcc_assert (rse->string_length != NULL_TREE); + gfc_conv_string_parameter (rse); + gfc_add_block_to_block (&block, &rse->pre); + rlen = rse->string_length; + } - gfc_trans_string_copy (&block, lse->string_length, lse->expr, - rse->string_length, 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; @@ -3313,43 +4809,55 @@ 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); } /* Deallocate the lhs allocated components as long as it is not - the same as the rhs. */ - if (!l_is_temp) + 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 && dealloc) { - tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0); + tmp = gfc_evaluate_now (lse->expr, &lse->pre); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); if (r_is_var) - tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); - gfc_add_expr_to_block (&lse->pre, 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, &lse->pre); + 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); @@ -3370,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)) @@ -3380,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; @@ -3393,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; } @@ -3423,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); @@ -3438,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); @@ -3450,11 +4976,185 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) } -/* Translate an assignment. Most of the code is concerned with - setting up the scalarizer. */ +/* Try to efficiently translate array(:) = 0. Return NULL if this + can't be done. */ + +static tree +gfc_trans_zero_assign (gfc_expr * expr) +{ + tree dest, len, type; + tree tmp; + gfc_symbol *sym; + + sym = expr->symtree->n.sym; + dest = gfc_get_symbol_decl (sym); + + type = TREE_TYPE (dest); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (!GFC_ARRAY_TYPE_P (type)) + return NULL_TREE; + + /* Determine the length of the array. */ + len = GFC_TYPE_ARRAY_SIZE (type); + if (!len || TREE_CODE (len) != INTEGER_CST) + return NULL_TREE; + + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, + fold_convert (gfc_array_index_type, tmp)); + + /* If we are zeroing a local array avoid taking its address by emitting + a = {} instead. */ + if (!POINTER_TYPE_P (TREE_TYPE (dest))) + return build2 (MODIFY_EXPR, void_type_node, + dest, build_constructor (TREE_TYPE (dest), NULL)); + + /* 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_loc (input_location, + built_in_decls[BUILT_IN_MEMSET], + 3, dest, integer_zero_node, len); + return fold_convert (void_type_node, tmp); +} + + +/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy + that constructs the call to __builtin_memcpy. */ tree -gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) +gfc_build_memcpy_call (tree dst, tree src, tree len) +{ + tree tmp; + + /* Convert arguments to the correct types. */ + if (!POINTER_TYPE_P (TREE_TYPE (dst))) + dst = gfc_build_addr_expr (pvoid_type_node, dst); + else + dst = fold_convert (pvoid_type_node, dst); + + if (!POINTER_TYPE_P (TREE_TYPE (src))) + src = gfc_build_addr_expr (pvoid_type_node, src); + else + src = fold_convert (pvoid_type_node, src); + + len = fold_convert (size_type_node, len); + + /* Construct call to __builtin_memcpy. */ + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len); + return fold_convert (void_type_node, tmp); +} + + +/* Try to efficiently translate dst(:) = src(:). Return NULL if this + can't be done. EXPR1 is the destination/lhs and EXPR2 is the + source/rhs, both are gfc_full_array_ref_p which have been checked for + dependencies. */ + +static tree +gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2) +{ + tree dst, dlen, dtype; + tree src, slen, stype; + tree tmp; + + dst = gfc_get_symbol_decl (expr1->symtree->n.sym); + src = gfc_get_symbol_decl (expr2->symtree->n.sym); + + dtype = TREE_TYPE (dst); + if (POINTER_TYPE_P (dtype)) + dtype = TREE_TYPE (dtype); + stype = TREE_TYPE (src); + if (POINTER_TYPE_P (stype)) + stype = TREE_TYPE (stype); + + if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype)) + return NULL_TREE; + + /* Determine the lengths of the arrays. */ + dlen = GFC_TYPE_ARRAY_SIZE (dtype); + if (!dlen || TREE_CODE (dlen) != INTEGER_CST) + return NULL_TREE; + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); + dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen, + fold_convert (gfc_array_index_type, tmp)); + + slen = GFC_TYPE_ARRAY_SIZE (stype); + if (!slen || TREE_CODE (slen) != INTEGER_CST) + return NULL_TREE; + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype)); + slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen, + fold_convert (gfc_array_index_type, tmp)); + + /* Sanity check that they are the same. This should always be + the case, as we should already have checked for conformance. */ + if (!tree_int_cst_equal (slen, dlen)) + return NULL_TREE; + + return gfc_build_memcpy_call (dst, src, dlen); +} + + +/* Try to efficiently translate array(:) = (/ ... /). Return NULL if + this can't be done. EXPR1 is the destination/lhs for which + gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */ + +static tree +gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) +{ + unsigned HOST_WIDE_INT nelem; + tree dst, dtype; + tree src, stype; + tree len; + tree tmp; + + nelem = gfc_constant_array_constructor_p (expr2->value.constructor); + if (nelem == 0) + return NULL_TREE; + + dst = gfc_get_symbol_decl (expr1->symtree->n.sym); + dtype = TREE_TYPE (dst); + if (POINTER_TYPE_P (dtype)) + dtype = TREE_TYPE (dtype); + if (!GFC_ARRAY_TYPE_P (dtype)) + return NULL_TREE; + + /* Determine the lengths of the array. */ + len = GFC_TYPE_ARRAY_SIZE (dtype); + if (!len || TREE_CODE (len) != INTEGER_CST) + return NULL_TREE; + + /* Confirm that the constructor is the same size. */ + if (compare_tree_int (len, nelem) != 0) + return NULL_TREE; + + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); + len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, + fold_convert (gfc_array_index_type, tmp)); + + stype = gfc_typenode_for_spec (&expr2->ts); + src = gfc_build_constant_array_constructor (expr2, stype); + + stype = TREE_TYPE (src); + if (POINTER_TYPE_P (stype)) + stype = TREE_TYPE (stype); + + return gfc_build_memcpy_call (dst, src, len); +} + + +/* Subroutine of gfc_trans_assignment that actually scalarizes the + assignment. EXPR1 is the destination/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, + bool dealloc) { gfc_se lse; gfc_se rse; @@ -3466,14 +5166,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) stmtblock_t block; stmtblock_t body; bool l_is_temp; - - /* Special case a single function returning an array. */ - if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) - { - tmp = gfc_trans_arrayfunc_assign (expr1, expr2); - if (tmp) - return tmp; - } + bool scalar_to_array; + tree string_length; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -3486,6 +5180,10 @@ gfc_trans_assignment (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; @@ -3518,7 +5216,7 @@ gfc_trans_assignment (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); @@ -3549,17 +5247,40 @@ gfc_trans_assignment (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) @@ -3592,8 +5313,11 @@ gfc_trans_assignment (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); } @@ -3610,14 +5334,280 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) return gfc_finish_block (&block); } + +/* Check whether EXPR is a copyable array. */ + +static bool +copyable_array_p (gfc_expr * expr) +{ + if (expr->expr_type != EXPR_VARIABLE) + return false; + + /* First check it's an array. */ + if (expr->rank < 1 || !expr->ref || expr->ref->next) + return false; + + if (!gfc_full_array_ref_p (expr->ref, NULL)) + return false; + + /* Next check that it's of a simple enough type. */ + switch (expr->ts.type) + { + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + case BT_LOGICAL: + return true; + + case BT_CHARACTER: + return false; + + case BT_DERIVED: + return !expr->ts.u.derived->attr.alloc_comp; + + default: + break; + } + + return false; +} + +/* Translate an assignment. */ + +tree +gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, + bool dealloc) +{ + tree tmp; + + /* Special case a single function returning an array. */ + if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) + { + tmp = gfc_trans_arrayfunc_assign (expr1, expr2); + if (tmp) + return tmp; + } + + /* Special case assigning an array to zero. */ + if (copyable_array_p (expr1) + && is_zero_initializer_p (expr2)) + { + tmp = gfc_trans_zero_assign (expr1); + if (tmp) + return tmp; + } + + /* Special case copying one array to another. */ + if (copyable_array_p (expr1) + && copyable_array_p (expr2) + && gfc_compare_types (&expr1->ts, &expr2->ts) + && !gfc_check_dependency (expr1, expr2, 0)) + { + tmp = gfc_trans_array_copy (expr1, expr2); + if (tmp) + return tmp; + } + + /* Special case initializing an array from a constant array constructor. */ + if (copyable_array_p (expr1) + && expr2->expr_type == EXPR_ARRAY + && gfc_compare_types (&expr1->ts, &expr2->ts)) + { + tmp = gfc_trans_array_constructor_copy (expr1, expr2); + if (tmp) + return tmp; + } + + /* Fallback to the scalarizer to generate explicit loops. */ + return gfc_trans_assignment_1 (expr1, expr2, init_flag, 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); }