From 6c95fe9bc0553743098eeaa739f14b885050fa42 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 16 May 2023 06:35:40 +0100 Subject: [PATCH] Fortran: Fix an assortment of bugs 2023-05-16 Paul Thomas gcc/fortran PR fortran/105152 * interface.cc (gfc_compare_actual_formal): Emit an error if an unlimited polymorphic actual is not matched either to an unlimited or assumed type formal argument. PR fortran/100193 * resolve.cc (resolve_ordinary_assign): Emit an error if the var expression of an ordinary assignment is a proc pointer component. PR fortran/87496 * trans-array.cc (gfc_walk_array_ref): Provide assumed shape arrays coming from interface mapping with a viable arrayspec. PR fortran/103389 * trans-expr.cc (gfc_conv_intrinsic_to_class): Tidy up flagging of unlimited polymorphic 'class_ts'. (gfc_conv_gfc_desc_to_cfi_desc): Assumed type is unlimited polymorphic and should accept any actual type. PR fortran/104429 (gfc_conv_procedure_call): Replace dreadful kludge with a call to gfc_finalize_tree_expr. Avoid dereferencing a void pointer by giving it the pointer type of the actual argument. PR fortran/82774 (alloc_scalar_allocatable_subcomponent): Shorten the function name and replace the symbol argument with the se string length. If a deferred length character length is either not present or is not a variable, give the typespec a variable and assign the string length to that. Use gfc_deferred_strlen to find the hidden string length component. (gfc_trans_subcomponent_assign): Convert the expression before the call to alloc_scalar_allocatable_subcomponent so that a good string length is provided. (gfc_trans_structure_assign): Remove the unneeded derived type symbol from calls to gfc_trans_subcomponent_assign. gcc/testsuite/ PR fortran/105152 * gfortran.dg/pr105152.f90 : New test PR fortran/100193 * gfortran.dg/pr100193.f90 : New test PR fortran/87946 * gfortran.dg/pr87946.f90 : New test PR fortran/103389 * gfortran.dg/pr103389.f90 : New test PR fortran/104429 * gfortran.dg/pr104429.f90 : New test PR fortran/82774 * gfortran.dg/pr82774.f90 : New test --- gcc/fortran/interface.cc | 10 +++ gcc/fortran/resolve.cc | 11 +++ gcc/fortran/trans-array.cc | 6 ++ gcc/fortran/trans-expr.cc | 96 +++++++++++--------------- gcc/testsuite/gfortran.dg/pr100193.f90 | 20 ++++++ gcc/testsuite/gfortran.dg/pr103389.f90 | 23 ++++++ gcc/testsuite/gfortran.dg/pr104429.f90 | 35 ++++++++++ gcc/testsuite/gfortran.dg/pr105152.f90 | 19 +++++ gcc/testsuite/gfortran.dg/pr82774.f90 | 15 ++++ gcc/testsuite/gfortran.dg/pr87946.f90 | 42 +++++++++++ 10 files changed, 223 insertions(+), 54 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr100193.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr103389.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr104429.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr105152.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr82774.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr87946.f90 diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 968ee193c072..ea82056e9e3b 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -3312,6 +3312,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } } + if (UNLIMITED_POLY (a->expr) + && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym))) + { + gfc_error ("Unlimited polymorphic actual argument at %L is not " + "matched with either an unlimited polymorphic or " + "assumed type dummy argument", &a->expr->where); + ok = false; + goto match; + } + /* Special case for character arguments. For allocatable, pointer and assumed-shape dummies, the string length needs to match exactly. */ diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 58f05a3e74ab..90b7fb52b51e 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11165,6 +11165,17 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) lhs = code->expr1; rhs = code->expr2; + if ((lhs->symtree->n.sym->ts.type == BT_DERIVED + || lhs->symtree->n.sym->ts.type == BT_CLASS) + && !lhs->symtree->n.sym->attr.proc_pointer + && gfc_expr_attr (lhs).proc_pointer) + { + gfc_error ("Variable in the ordinary assignment at %L is a procedure " + "pointer component", + &lhs->where); + return false; + } + if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) && rhs->ts.type == BT_CHARACTER && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 785cf504816f..fe7b7ca73dd9 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11471,6 +11471,12 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) break; case AR_FULL: + /* Assumed shape arrays from interface mapping need this fix. */ + if (!ar->as && expr->symtree->n.sym->as) + { + ar->as = gfc_get_array_spec(); + *ar->as = *expr->symtree->n.sym->as; + } newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); newss->info->data.array.ref = ref; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index d902e8f32813..101efc3cc2cd 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -996,6 +996,12 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, tree var; tree tmp; int dim; + bool unlimited_poly; + + unlimited_poly = class_ts.type == BT_CLASS + && class_ts.u.derived->components->ts.type == BT_DERIVED + && class_ts.u.derived->components->ts.u.derived + ->attr.unlimited_polymorphic; /* The intrinsic type needs to be converted to a temporary CLASS object. */ @@ -1067,9 +1073,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, } gcc_assert (class_ts.type == BT_CLASS); - if (class_ts.u.derived->components->ts.type == BT_DERIVED - && class_ts.u.derived->components->ts.u.derived - ->attr.unlimited_polymorphic) + if (unlimited_poly) { ctree = gfc_class_len_get (var); /* When the actual arg is a char array, then set the _len component of the @@ -1116,10 +1120,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); } - else if (class_ts.type == BT_CLASS - && class_ts.u.derived->components - && class_ts.u.derived->components->ts.u - .derived->attr.unlimited_polymorphic) + else if (unlimited_poly) { ctree = gfc_class_len_get (var); gfc_add_modify (&parmse->pre, ctree, @@ -5650,7 +5651,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) itype = CFI_type_other; // FIXME: Or CFI_type_cptr ? break; case BT_CLASS: - if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED) + if (fsym->ts.type == BT_ASSUMED) { // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*) // type specifier is assumed-type and is an unlimited polymorphic @@ -6682,20 +6683,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree zero; - gfc_expr *var; - - /* Borrow the function symbol to make a call to - gfc_add_finalizer_call and then restore it. */ - tmp = e->symtree->n.sym->backend_decl; - e->symtree->n.sym->backend_decl - = TREE_OPERAND (parmse.expr, 0); - e->symtree->n.sym->attr.flavor = FL_VARIABLE; - var = gfc_lval_expr_from_sym (e->symtree->n.sym); - finalized = gfc_add_finalizer_call (&parmse.post, - var); - gfc_free_expr (var); - e->symtree->n.sym->backend_decl = tmp; - e->symtree->n.sym->attr.flavor = FL_PROCEDURE; + /* Finalize the expression. */ + gfc_finalize_tree_expr (&parmse, NULL, + gfc_expr_attr (e), e->rank); + gfc_add_block_to_block (&parmse.post, + &parmse.finalblock); /* Then free the class _data. */ zero = build_int_cst (TREE_TYPE (parmse.expr), 0); @@ -7131,7 +7123,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, types passed to class formals need the _data component. */ tmp = gfc_class_data_get (tmp); if (!CLASS_DATA (fsym)->attr.dimension) - tmp = build_fold_indirect_ref_loc (input_location, tmp); + { + if (UNLIMITED_POLY (fsym)) + { + tree type = gfc_typenode_for_spec (&e->ts); + type = build_pointer_type (type); + tmp = fold_convert (type, tmp); + } + tmp = build_fold_indirect_ref_loc (input_location, tmp); + } } if (e->expr_type == EXPR_OP @@ -8767,11 +8767,9 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Allocate or reallocate scalar component, as necessary. */ static void -alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, - tree comp, - gfc_component *cm, - gfc_expr *expr2, - gfc_symbol *sym) +alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, + gfc_component *cm, gfc_expr *expr2, + tree slen) { tree tmp; tree ptr; @@ -8789,26 +8787,20 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - /* Use the rhs string length and the lhs element size. */ gcc_assert (expr2->ts.type == BT_CHARACTER); - if (!expr2->ts.u.cl->backend_decl) - { - gfc_conv_string_length (expr2->ts.u.cl, expr2, block); - gcc_assert (expr2->ts.u.cl->backend_decl); - } + if (!expr2->ts.u.cl->backend_decl + || !VAR_P (expr2->ts.u.cl->backend_decl)) + expr2->ts.u.cl->backend_decl = gfc_create_var (TREE_TYPE (slen), + "slen"); + gfc_add_modify (block, expr2->ts.u.cl->backend_decl, slen); size = expr2->ts.u.cl->backend_decl; - /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length - component. */ - sprintf (name, "_%s_length", cm->name); - strlen = gfc_find_component (sym, name, true, true, NULL); + gfc_deferred_strlen (cm, &tmp); lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF, gfc_charlen_type_node, TREE_OPERAND (comp, 0), - strlen->backend_decl, NULL_TREE); + tmp, NULL_TREE); tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts)); tmp = TYPE_SIZE_UNIT (tmp); @@ -8881,8 +8873,8 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *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_symbol *sym, bool init) +gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, + gfc_expr * expr, bool init) { gfc_se se; gfc_se lse; @@ -8976,19 +8968,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable && expr->ts.type != BT_CLASS))) { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ assignment() routine, but with the realloc portions removed and different input. */ - alloc_scalar_allocatable_for_subcomponent_assignment (&block, - dest, - cm, - expr, - sym); + alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr, + se.string_length); /* The remainder of these instructions follow the if (cm->attr.pointer) if (!cm->attr.dimension) part above. */ - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer @@ -9252,13 +9242,11 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) if (!c->expr) { gfc_expr *e = gfc_get_null_expr (NULL); - tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived, - init); + tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init); gfc_free_expr (e); } else - tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, - expr->ts.u.derived, init); + tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); diff --git a/gcc/testsuite/gfortran.dg/pr100193.f90 b/gcc/testsuite/gfortran.dg/pr100193.f90 new file mode 100644 index 000000000000..07a3634cb063 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr100193.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +module m + implicit none + type t + procedure(f), pointer, nopass :: g + end type +contains + function f() + character(:), allocatable :: f + f = 'abc' + end + subroutine s + type(t) :: z + z%g = 'x' ! { dg-error "is a procedure pointer" } + if ( z%g() /= 'abc' ) stop + end +end diff --git a/gcc/testsuite/gfortran.dg/pr103389.f90 b/gcc/testsuite/gfortran.dg/pr103389.f90 new file mode 100644 index 000000000000..565551564e39 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr103389.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Contributed by Gerhard Steinmetz +! +program p + type t + integer, allocatable :: a(:) + end type + type(t) :: y + y%a = [1,2] + call s((y)) + if (any (y%a .ne. [3,4])) stop 1 +contains + subroutine s(x) + class(*) :: x + select type (x) + type is (t) + x%a = x%a + 2 + class default + stop 2 + end select + end +end diff --git a/gcc/testsuite/gfortran.dg/pr104429.f90 b/gcc/testsuite/gfortran.dg/pr104429.f90 new file mode 100644 index 000000000000..39761fd59fa6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr104429.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Contributed by Gerhard Steinmetz +! +module m + type t + real :: r + contains + procedure :: op + procedure :: assign + generic :: operator(*) => op + generic :: assignment(=) => assign + end type +contains + function op (x, y) + class(t), allocatable :: op + class(t), intent(in) :: x + real, intent(in) :: y + allocate (op, source = t (x%r * y)) + end + subroutine assign (z, x) + type(t), intent(in) :: x + class(t), intent(out) :: z + z%r = x%r + end +end +program p + use m + class(t), allocatable :: x + real :: y = 2 + allocate (x, source = t (2.0)) + x = x * y + if (int (x%r) .ne. 4) stop 1 + if (allocated (x)) deallocate (x) +end diff --git a/gcc/testsuite/gfortran.dg/pr105152.f90 b/gcc/testsuite/gfortran.dg/pr105152.f90 new file mode 100644 index 000000000000..561b2a6c75d6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105152.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + use iso_c_binding + type, bind(c) :: t + integer(c_int) :: a + end type + interface + function f(x) bind(c) result(z) + import :: c_int, t + type(t) :: x(:) + integer(c_int) :: z + end + end interface + class(*), allocatable :: y(:) + n = f(y) ! { dg-error "either an unlimited polymorphic or assumed type" } +end diff --git a/gcc/testsuite/gfortran.dg/pr82774.f90 b/gcc/testsuite/gfortran.dg/pr82774.f90 new file mode 100644 index 000000000000..81c22ab38286 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr82774.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! Contributed by Steve Kargl +! +program main + implicit none + type stuff + character(:), allocatable :: key + end type stuff + type(stuff) nonsense, total + nonsense = stuff('Xe') + total = stuff(nonsense%key) ! trim nonsense%key made this work + if (nonsense%key /= total%key) call abort + if (len(total%key) /= 2) call abort +end program main diff --git a/gcc/testsuite/gfortran.dg/pr87946.f90 b/gcc/testsuite/gfortran.dg/pr87946.f90 new file mode 100644 index 000000000000..793d37a7f399 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr87946.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Contributed by Gerhard Steinmetz +! +module m + type t + contains + generic :: h => g + procedure, private :: g + end type +contains + function g(x, y) result(z) + class(t), intent(in) :: x + real, intent(in) :: y(:, :) + real :: z(size(y, 2)) + integer :: i + do i = 1, size(y, 2) + z(i) = i + end do + end +end +module m2 + use m + type t2 + class(t), allocatable :: u(:) + end type +end + use m2 + type(t2) :: x + real :: y(1,5) + allocate (x%u(1)) + if (any (int(f (x, y)) .ne. [1,2,3,4,5])) stop 1 + deallocate (x%u) +contains + function f(x, y) result(z) + use m2 + type(t2) :: x + real :: y(:, :) + real :: z(size(y, 2)) + z = x%u(1)%h(y) ! Used to segfault here + end +end -- 2.43.5