From: Paul Thomas Date: Mon, 14 Jan 2013 17:59:07 +0000 (+0000) Subject: re PR fortran/55618 (Failures with ISO_Varying_String test suite) X-Git-Tag: releases/gcc-4.6.4~192 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b0df054fb4c9bb5b241ea40dca94309fef5b260c;p=thirdparty%2Fgcc.git re PR fortran/55618 (Failures with ISO_Varying_String test suite) 2013-01-14 Paul Thomas PR fortran/55618 * trans-expr.c (gfc_conv_procedure_call): Dereference scalar character function arguments to elemental procedures in scalarization loops. 2013-01-14 Paul Thomas PR fortran/55618 * gfortran.dg/elemental_scalar_args_2.f90: New test. From-SVN: r195159 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e4151590b808..914e6d9ff123 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2013-01-14 Paul Thomas + + PR fortran/55618 + * trans-expr.c (gfc_conv_procedure_call): Dereference scalar + character function arguments to elemental procedures in + scalarization loops. + 2013-01-08 Mikael Morin PR fortran/42769 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3b7ea79b9d49..e10924a02267 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -177,7 +177,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) 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_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); @@ -214,9 +214,9 @@ gfc_get_expr_charlen (gfc_expr *e) gfc_ref *r; tree length; - gcc_assert (e->expr_type == EXPR_VARIABLE + gcc_assert (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER); - + length = NULL; /* To silence compiler warning. */ if (is_subref_array (e) && e->ts.u.cl->length) @@ -278,8 +278,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) { case EXPR_OP: - flatten_array_ctors_without_strlen (e->value.op.op1); - flatten_array_ctors_without_strlen (e->value.op.op2); + flatten_array_ctors_without_strlen (e->value.op.op1); + flatten_array_ctors_without_strlen (e->value.op.op2); break; case EXPR_COMPCALL: @@ -639,7 +639,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se_expr = gfc_get_fake_result_decl (sym, parent_flag); /* Similarly for alternate entry points. */ - else if (alternate_entry + else if (alternate_entry && (sym->ns->proc_name->backend_decl == current_function_decl || parent_flag)) { @@ -675,7 +675,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* Dereference the expression, where needed. Since characters - are entirely different from other types, they are treated + are entirely different from other types, they are treated separately. */ if (sym->ts.type == BT_CHARACTER) { @@ -704,7 +704,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable || gfc_is_associate_pointer (sym)) @@ -774,7 +774,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL)) gfc_conv_string_parameter (se); - else + else se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); } } @@ -856,11 +856,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] = 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */ }; -/* If n is larger than lookup table's max index, we use the "window +/* If n is larger than lookup table's max index, we use the "window method". */ #define POWI_WINDOW_SIZE 3 -/* Recursive function to expand the power operator. The temporary +/* 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, unsigned HOST_WIDE_INT n, tree * tmpvar) @@ -923,7 +923,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree 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); sgn = tree_int_cst_sgn (rhs); @@ -1034,7 +1034,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: ikind = 0; break; - + case 8: ikind = 1; break; @@ -1062,7 +1062,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: kind = 0; break; - + case 8: kind = 1; break; @@ -1078,7 +1078,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - + switch (expr->value.op.op1->ts.type) { case BT_INTEGER: @@ -1096,7 +1096,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 0: fndecl = built_in_decls[BUILT_IN_POWIF]; break; - + case 1: fndecl = built_in_decls[BUILT_IN_POWI]; break; @@ -1106,7 +1106,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case 3: - /* Use the __builtin_powil() only if real(kind=16) is + /* Use the __builtin_powil() only if real(kind=16) is actually the C long double type. */ if (!gfc_real16_is_float128) fndecl = built_in_decls[BUILT_IN_POWIL]; @@ -1117,7 +1117,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) } } - /* If we don't have a good builtin for this, go for the + /* If we don't have a good builtin for this, go for the library function. */ if (!fndecl) fndecl = gfor_fndecl_math_powi[kind][ikind].real; @@ -1524,7 +1524,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) (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 + /* 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; @@ -1937,8 +1937,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) value = build_fold_indirect_ref_loc (input_location, se->expr); - - /* For character(*), use the actual argument's descriptor. */ + + /* For character(*), use the actual argument's descriptor. */ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) value = build_fold_indirect_ref_loc (input_location, se->expr); @@ -2348,7 +2348,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, rss = gfc_walk_expr (expr); gcc_assert (rss != gfc_ss_terminator); - + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, rss); @@ -2511,7 +2511,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); gfc_add_expr_to_block (&body, tmp); - + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop2, &body); @@ -2538,7 +2538,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, if (formal_ptr) { size = gfc_index_one_node; - offset = gfc_index_zero_node; + offset = gfc_index_zero_node; for (n = 0; n < dimen; n++) { tmp = gfc_conv_descriptor_ubound_get (parmse->expr, @@ -2608,7 +2608,7 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) /* Takes a derived type expression and returns the address of a temporary - class object of the 'declared' type. */ + class object of the 'declared' type. */ static void gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts) @@ -2681,7 +2681,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, { gfc_symbol *fsym; gfc_ss *argss; - + if (sym->intmod_sym_id == ISOCBINDING_LOC) { if (arg->expr->rank == 0) @@ -2698,7 +2698,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, && !(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); @@ -2719,7 +2719,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, 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 @@ -2744,12 +2744,12 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&fptrse, arg->next->expr); gfc_add_block_to_block (&se->pre, &fptrse.pre); gfc_add_block_to_block (&se->post, &fptrse.post); - + if (arg->next->expr->symtree->n.sym->attr.proc_pointer && arg->next->expr->symtree->n.sym->attr.dummy) fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr); - + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr), fptrse.expr, @@ -2783,7 +2783,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, { 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); @@ -2807,7 +2807,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - + /* Nothing was done. */ return 0; } @@ -2959,6 +2959,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* An elemental function inside a scalarized loop. */ gfc_init_se (&parmse, se); gfc_conv_expr_reference (&parmse, e); + if (e->ts.type == BT_CHARACTER && !e->rank + && e->expr_type == EXPR_FUNCTION) + parmse.expr = build_fold_indirect_ref_loc (input_location, + parmse.expr); parm_kind = ELEMENTAL; } else @@ -3023,7 +3027,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { gfc_conv_expr_reference (&parmse, e); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* 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) @@ -3094,7 +3098,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* If the argument is a function call that may not create a temporary for the result, we have to check that we - can do it, i.e. that there is no alias between this + can do it, i.e. that there is no alias between this argument and another one. */ if (gfc_get_noncopying_intrinsic_argument (e) != NULL) { @@ -3143,7 +3147,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, argss, f, fsym, sym->name, NULL); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* 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) @@ -3160,7 +3164,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); } - } + } } /* The case with fsym->attr.optional is that of a user subroutine @@ -3186,7 +3190,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && ((e->rank > 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER || (e->rank > 0 - && (fsym == NULL + && (fsym == NULL || (fsym-> as && (fsym->as->type == AS_ASSUMED_SHAPE || fsym->as->type == AS_DEFERRED)))))) @@ -3339,7 +3343,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } - + gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, msg); gfc_free (msg); @@ -3406,7 +3410,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); - + tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, tmp, @@ -4132,7 +4136,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) /* Build a static initializer. EXPR is the expression for the initial value. - The other parameters describe the variable of the component being + The other parameters describe the variable of the component being initialized. EXPR may be null. */ tree @@ -4163,7 +4167,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } - + if (array && !procptr) { tree ctor; @@ -4221,7 +4225,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, } } } - + static tree gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) { @@ -4275,7 +4279,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) cm->as->lower[n]->value.integer); mpz_add_ui (lss->shape[n], lss->shape[n], 1); } - + /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, lss); gfc_add_ss_to_loop (&loop, rss); @@ -4341,7 +4345,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_start_block (&block); gfc_init_se (&se, NULL); - /* Get the descriptor for the expressions. */ + /* Get the descriptor for the expressions. */ rss = gfc_walk_expr (expr); se.want_pointer = 0; gfc_conv_expr_descriptor (&se, expr, rss); @@ -4596,7 +4600,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) fold_convert (TREE_TYPE (lse.expr), se.expr)); return gfc_finish_block (&block); - } + } for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c), cm = cm->next) @@ -4678,7 +4682,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) } } se->expr = build_constructor (type, v); - if (init) + if (init) TREE_CONSTANT (se->expr) = 1; } @@ -4752,7 +4756,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) expr->ts.kind = expr->ts.u.derived->ts.kind; } } - + switch (expr->expr_type) { case EXPR_OP: @@ -5009,7 +5013,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) for (remap = expr1->ref; remap; remap = remap->next) if (!remap->next && remap->type == REF_ARRAY && remap->u.ar.type == AR_SECTION) - { + { remap->u.ar.type = AR_FULL; break; } @@ -5307,7 +5311,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { cond = NULL_TREE; - + /* Are the rhs and the lhs the same? */ if (r_is_var) { @@ -5403,7 +5407,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) /* Functions returning pointers or allocatables need temporaries. */ c = expr2->value.function.esym - ? (expr2->value.function.esym->attr.pointer + ? (expr2->value.function.esym->attr.pointer || expr2->value.function.esym->attr.allocatable) : (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable); @@ -5694,7 +5698,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) correctly take care of the reallocation internally. For intrinsic calls, the array data is freed and the library takes care of allocation. TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment - to the library. */ + to the library. */ if (gfc_option.flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && !gfc_expr_attr (expr1).codimension @@ -5967,7 +5971,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, gfc_init_se (&lse, NULL); lse.want_pointer = 1; gfc_conv_expr (&lse, expr1); - + jump_label1 = gfc_build_label_decl (NULL_TREE); jump_label2 = gfc_build_label_decl (NULL_TREE); @@ -6405,7 +6409,7 @@ gfc_trans_class_init_assign (gfc_code *code) gfc_add_block_to_block (&block, &src.pre); tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); gfc_add_expr_to_block (&block, tmp); - + return gfc_finish_block (&block); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bd16b01f7d49..dc7243714516 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2013-01-14 Paul Thomas + + PR fortran/55618 + * gfortran.dg/elemental_scalar_args_2.f90: New test. + 2013-01-08 Mikael Morin PR fortran/42769 diff --git a/gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 b/gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 new file mode 100644 index 000000000000..c2b5df8d18b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Test the fix for PR55618, in which character scalar function arguments to +! elemental functions would gain an extra indirect reference thus causing +! failures in Vst17.f95, Vst 30.f95 and Vst31.f95 in the iso_varying_string +! testsuite, where elemental tests are done. +! +! Reported by Tobias Burnus +! + integer, dimension (2) :: i = [1,2] + integer :: j = 64 + character (len = 2) :: chr1 = "lm" + character (len = 1), dimension (2) :: chr2 = ["r", "s"] + if (any (foo (i, bar()) .ne. ["a", "b"])) call abort ! This would fail + if (any (foo (i, "xy") .ne. ["x", "y"])) call abort ! OK - not a function + if (any (foo (i, chr1) .ne. ["l", "m"])) call abort ! ditto + if (any (foo (i, char (j)) .ne. ["A", "B"])) call abort ! This would fail + if (any (foo (i, chr2) .ne. ["s", "u"])) call abort ! OK - not a scalar + if (any (foo (i, bar2()) .ne. ["e", "g"])) call abort ! OK - not a scalar function +contains + elemental character(len = 1) function foo (arg1, arg2) + integer, intent (in) :: arg1 + character(len = *), intent (in) :: arg2 + if (len (arg2) > 1) then + foo = arg2(arg1:arg1) + else + foo = char (ichar (arg2) + arg1) + end if + end function + character(len = 2) function bar () + bar = "ab" + end function + function bar2 () result(res) + character (len = 1), dimension(2) :: res + res = ["d", "e"] + end function +end