From 7c81ff02a943cda82cc1a82b36ae8ab14470b00a Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 13 May 2024 07:27:20 +0100 Subject: Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363] 2024-05-13 Paul Thomas gcc/fortran PR fortran/113363 * trans-array.cc (gfc_array_init_size): Use the expr3 dtype so that the correct element size is used. * trans-expr.cc (gfc_conv_procedure_call): Remove restriction that ss and ss->loop be present for the finalization of class array function results. (trans_class_assignment): Use free and malloc, rather than realloc, for character expressions assigned to unlimited poly entities. * trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for the assignment of an unlimited polymorphic 'source'. gcc/testsuite/ PR fortran/113363 * gfortran.dg/pr113363.f90: New test. (cherry picked from commit 2d0eeb529d400e61197a09c56011be976dd81ef0) --- gcc/fortran/trans-array.cc | 5 ++ gcc/fortran/trans-expr.cc | 34 ++++++++------ gcc/fortran/trans-stmt.cc | 40 ++++++++++++++++ gcc/testsuite/gfortran.dg/pr113363.f90 | 86 ++++++++++++++++++++++++++++++++++ 4 files changed, 151 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr113363.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index f38e872..9557cd1 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -5795,6 +5795,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); } + else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc))) + { + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc)); + } else { tmp = gfc_conv_descriptor_dtype (descriptor); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 6b75c14..657f1cb 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7984,8 +7984,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, call the finalization function of the temporary. Note that the nullification of allocatable components needed by the result is done in gfc_trans_assignment_1. */ - if (expr && ((gfc_is_class_array_function (expr) - && se->ss && se->ss->loop) + if (expr && (gfc_is_class_array_function (expr) || gfc_is_alloc_class_scalar_function (expr)) && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) && expr->must_finalize) @@ -11705,18 +11704,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, /* Reallocate if dynamic types are different. */ gfc_init_block (&re_alloc); - tmp = fold_convert (pvoid_type_node, class_han); - re = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_REALLOC), 2, - tmp, size); - re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp, - re); - tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, rhs_vptr, old_vptr); - re = fold_build3_loc (input_location, COND_EXPR, void_type_node, - tmp, re, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&re_alloc, re); - + if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER) + { + gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han)); + gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE); + } + else + { + tmp = fold_convert (pvoid_type_node, class_han); + re = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_REALLOC), + 2, tmp, size); + re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), + tmp, re); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, rhs_vptr, old_vptr); + re = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, re, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&re_alloc, re); + } tree realloc_expr = lhs->ts.type == BT_CLASS ? gfc_finish_block (&re_alloc) : build_empty_stmt (input_location); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index caa7b59..11a8a9c 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -7059,6 +7059,46 @@ gfc_trans_allocate (gfc_code * code) gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); flag_realloc_lhs = 0; + /* The handling of code->expr3 above produces a derived type of + type "STAR", whose size defaults to size(void*). In order to + have the right type information for the assignment, we must + reconstruct an unlimited polymorphic rhs. */ + if (UNLIMITED_POLY (code->expr3) + && e3rhs && e3rhs->ts.type == BT_DERIVED + && !strcmp (e3rhs->ts.u.derived->name, "STAR")) + { + gfc_ref *ref; + gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF); + tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts), + "e3"); + gfc_add_modify (&block, tmp, + gfc_get_class_from_expr (expr3_vptr)); + rhs->symtree->n.sym->backend_decl = tmp; + rhs->ts = code->expr3->ts; + rhs->symtree->n.sym->ts = rhs->ts; + for (ref = init_expr->ref; ref; ref = ref->next) + { + /* Copy over the lhs _data component ref followed by the + full array reference for source expressions with rank. + Otherwise, just copy the _data component ref. */ + if (code->expr3->rank + && ref && ref->next && !ref->next->next) + { + rhs->ref = gfc_copy_ref (ref); + break; + } + else if ((init_expr->rank && !code->expr3->rank + && ref && ref->next && !ref->next->next) + || (ref && !ref->next)) + { + rhs->ref = gfc_copy_ref (ref); + gfc_free_ref_list (rhs->ref->next); + rhs->ref->next = NULL; + break; + } + } + } + /* Set the symbol to be artificial so that the result is not finalized. */ init_expr->symtree->n.sym->attr.artificial = 1; tmp = gfc_trans_assignment (init_expr, rhs, true, false, true, diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90 b/gcc/testsuite/gfortran.dg/pr113363.f90 new file mode 100644 index 0000000..99d4f20 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr113363.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! Test the fix for comment 1 in PR113363, which failed as in comments below. +! Contributed by Harald Anlauf +program p + implicit none + class(*), allocatable :: x(:), y + character(*), parameter :: arr(2) = ["hello ","bye "], & + sca = "Have a nice day" + character(10) :: const + +! Bug was detected in polymorphic array function results + allocate(x, source = foo ()) + call check1 (x, arr) ! Wrong output "6 hello e" + deallocate (x) + x = foo () + call check1 (x, arr) ! Wrong output "0 " + associate (var => foo ()) ! OK after r14-9489-g3fd46d859cda10 + call check1 (var, arr) ! Now OK - outputs: "6 hello bye " + end associate + +! Check scalar function results ! All OK + allocate (y, source = bar()) + call check2 (y, sca) + deallocate (y) + y = bar () + call check2 (y, sca) + deallocate (y) + associate (var => bar ()) + call check2 (var, sca) + end associate + +! Finally variable expressions... + allocate (y, source = x(1)) ! Gave zero length here + call check2 (y, "hello") + y = x(2) ! Segfaulted here + call check2 (y, "bye ") + associate (var => x(2)) ! Gave zero length here + call check2 (var, "bye ") + end associate + +! ...and constant expressions ! All OK + deallocate(y) + allocate (y, source = "abcde") + call check2 (y, "abcde") + const = "hijklmnopq" + y = const + call check2 (y, "hijklmnopq") + associate (var => "mnopq") + call check2 (var, "mnopq") + end associate + deallocate (x, y) + +contains + + function foo() result(res) + class(*), allocatable :: res(:) + res = arr + end function foo + + function bar() result(res) + class(*), allocatable :: res + res = sca + end function bar + + subroutine check1 (x, carg) + class(*), intent(in) :: x(:) + character(*) :: carg(:) + select type (x) + type is (character(*)) + if (any (x .ne. carg)) stop 1 + class default + stop 2 + end select + end subroutine check1 + + subroutine check2 (x, carg) + class(*), intent(in) :: x + character(*) :: carg + select type (x) + type is (character(*)) + if (x .ne. carg) stop 3 + class default + stop 4 + end select + end subroutine check2 +end -- cgit v1.1