From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1431) id 842693858D28; Wed, 21 Jun 2023 16:06:09 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 842693858D28 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1687363569; bh=pVWFE14h9RP4V8n40GkaGWLluPKj4iiDO7YkzJmOb6M=; h=From:To:Subject:Date:From; b=X2ux3l0GxDlr5ZvtO0vS2eRrXdu9dkCN8lBIw5zURIiP19t4PRHK+1YZJDl4FP1wC xaFRlo1nuudZrDdKT/2JOmHcHxYWaORpvzyNvp+b6U1v52IgwpR9AbVcKFJJ0WAdwT 6Q9aezOok+UoEXJdS/BwLvQx0sYxmR/k+xc705UU= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Paul Thomas To: gcc-cvs@gcc.gnu.org Subject: [gcc r14-2022] Fortran: Fix some bugs in associate [PR87477] X-Act-Checkin: gcc X-Git-Author: Paul Thomas X-Git-Refname: refs/heads/master X-Git-Oldrev: caf0892eea67349d9a1e44590c3440768136fe2b X-Git-Newrev: 577223aebc7acdd31e62b33c1682fe54a622ae27 Message-Id: <20230621160609.842693858D28@sourceware.org> Date: Wed, 21 Jun 2023 16:06:09 +0000 (GMT) List-Id: https://gcc.gnu.org/g:577223aebc7acdd31e62b33c1682fe54a622ae27 commit r14-2022-g577223aebc7acdd31e62b33c1682fe54a622ae27 Author: Paul Thomas Date: Wed Jun 21 17:05:58 2023 +0100 Fortran: Fix some bugs in associate [PR87477] 2023-06-21 Paul Thomas gcc/fortran PR fortran/87477 PR fortran/88688 PR fortran/94380 PR fortran/107900 PR fortran/110224 * decl.cc (char_len_param_value): Fix memory leak. (resolve_block_construct): Remove unnecessary static decls. * expr.cc (gfc_is_ptr_fcn): New function. (gfc_check_vardef_context): Use it to permit pointer function result selectors to be used for associate names in variable definition context. * gfortran.h: Prototype for gfc_is_ptr_fcn. * match.cc (build_associate_name): New function. (gfc_match_select_type): Use the new function to replace inline version and to build a new associate name for the case where the supplied associate name is already used for that purpose. * resolve.cc (resolve_assoc_var): Call gfc_is_ptr_fcn to allow associate names with pointer function targets to be used in variable definition context. * trans-decl.cc (gfc_get_symbol_decl): Unlimited polymorphic variables need deferred initialisation of the vptr. (gfc_trans_deferred_vars): Do the vptr initialisation. * trans-stmt.cc (trans_associate_var): Ensure that a pointer associate name points to the target of the selector and not the selector itself. gcc/testsuite/ PR fortran/87477 PR fortran/107900 * gfortran.dg/pr107900.f90 : New test PR fortran/110224 * gfortran.dg/pr110224.f90 : New test PR fortran/88688 * gfortran.dg/pr88688.f90 : New test PR fortran/94380 * gfortran.dg/pr94380.f90 : New test PR fortran/95398 * gfortran.dg/pr95398.f90 : Set -std=f2008, bump the line numbers in the error tests by two and change the text in two. Diff: --- gcc/fortran/decl.cc | 2 ++ gcc/fortran/expr.cc | 26 ++++++++++++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/match.cc | 60 ++++++++++++++++++++++++-------- gcc/fortran/resolve.cc | 7 ++-- gcc/fortran/trans-decl.cc | 33 ++++++++++++++++++ gcc/fortran/trans-stmt.cc | 20 ++++++----- gcc/testsuite/gfortran.dg/pr107900.f90 | 49 +++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pr110224.f90 | 29 ++++++++++++++++ gcc/testsuite/gfortran.dg/pr88688.f90 | 62 ++++++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pr94380.f90 | 18 ++++++++++ gcc/testsuite/gfortran.dg/pr95398.f90 | 8 +++-- 12 files changed, 286 insertions(+), 29 deletions(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index d09c8bc97d9..844345df77e 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1086,6 +1086,8 @@ char_len_param_value (gfc_expr **expr, bool *deferred) p = gfc_copy_expr (*expr); if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1)) gfc_replace_expr (*expr, p); + else + gfc_free_expr (p); if ((*expr)->expr_type == EXPR_FUNCTION) { diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index d5cfbe0cc55..c960dfeabd9 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -812,6 +812,16 @@ gfc_has_vector_index (gfc_expr *e) } +bool +gfc_is_ptr_fcn (gfc_expr *e) +{ + return e != NULL && e->expr_type == EXPR_FUNCTION + && (gfc_expr_attr (e).pointer + || (e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.class_pointer)); +} + + /* Copy a shape array. */ mpz_t * @@ -6470,6 +6480,22 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } return false; } + else if (context && gfc_is_ptr_fcn (assoc->target)) + { + if (!gfc_notify_std (GFC_STD_F2018, "%qs at %L associated to " + "pointer function target being used in a " + "variable definition context (%s)", name, + &e->where, context)) + return false; + else if (gfc_has_vector_index (e)) + { + gfc_error ("%qs at %L associated to vector-indexed target" + " cannot be used in a variable definition" + " context (%s)", + name, &e->where, context); + return false; + } + } /* Target must be allowed to appear in a variable definition context. */ if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a58c60e9828..30631abd788 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3659,6 +3659,7 @@ bool gfc_is_constant_expr (gfc_expr *); bool gfc_simplify_expr (gfc_expr *, int); bool gfc_try_simplify_expr (gfc_expr *, int); bool gfc_has_vector_index (gfc_expr *); +bool gfc_is_ptr_fcn (gfc_expr *); gfc_expr *gfc_get_expr (void); gfc_expr *gfc_get_array_expr (bt type, int kind, locus *); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 1203787fe77..ca64e59029e 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -6379,6 +6379,39 @@ build_class_sym: } +/* Build the associate name */ +static int +build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2) +{ + gfc_expr *expr1 = *e1; + gfc_expr *expr2 = *e2; + gfc_symbol *sym; + + /* For the case where the associate name is already an associate name. */ + if (!expr2) + expr2 = expr1; + expr1 = gfc_get_expr (); + expr1->expr_type = EXPR_VARIABLE; + expr1->where = expr2->where; + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + return 1; + + sym = expr1->symtree->n.sym; + if (expr2->ts.type == BT_UNKNOWN) + sym->attr.untyped = 1; + else + copy_ts_from_selector_to_associate (expr1, expr2); + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = 1; + + *e1 = expr1; + *e2 = expr2; + return 0; +} + + /* Push the current selector onto the SELECT TYPE stack. */ static void @@ -6534,7 +6567,6 @@ gfc_match_select_type (void) match m; char name[GFC_MAX_SYMBOL_LEN + 1]; bool class_array; - gfc_symbol *sym; gfc_namespace *ns = gfc_current_ns; m = gfc_match_label (); @@ -6556,24 +6588,11 @@ gfc_match_select_type (void) m = gfc_match (" %n => %e", name, &expr2); if (m == MATCH_YES) { - expr1 = gfc_get_expr (); - expr1->expr_type = EXPR_VARIABLE; - expr1->where = expr2->where; - if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + if (build_associate_name (name, &expr1, &expr2)) { m = MATCH_ERROR; goto cleanup; } - - sym = expr1->symtree->n.sym; - if (expr2->ts.type == BT_UNKNOWN) - sym->attr.untyped = 1; - else - copy_ts_from_selector_to_associate (expr1, expr2); - - sym->attr.flavor = FL_VARIABLE; - sym->attr.referenced = 1; - sym->attr.class_ok = 1; } else { @@ -6620,6 +6639,17 @@ gfc_match_select_type (void) goto cleanup; } + /* Prevent an existing associate name from reuse here by pushing expr1 to + expr2 and building a new associate name. */ + if (!expr2 && expr1->symtree->n.sym->assoc + && !expr1->symtree->n.sym->attr.select_type_temporary + && !expr1->symtree->n.sym->attr.select_rank_temporary + && build_associate_name (expr1->symtree->n.sym->name, &expr1, &expr2)) + { + m = MATCH_ERROR; + goto cleanup; + } + new_st.op = EXEC_SELECT_TYPE; new_st.expr1 = expr1; new_st.expr2 = expr2; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 50b49d0cb83..82e6ac53aa1 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -9254,9 +9254,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) gcc_assert (sym->ts.type != BT_UNKNOWN); /* See if this is a valid association-to-variable. */ - sym->assoc->variable = (target->expr_type == EXPR_VARIABLE - && !parentheses - && !gfc_has_vector_subscript (target)); + sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE + && !parentheses + && !gfc_has_vector_subscript (target)) + || gfc_is_ptr_fcn (target)); /* Finally resolve if this is an array or not. */ if (sym->attr.dimension && target->rank == 0) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index e6a4337c0d2..18589e17843 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1875,6 +1875,15 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !(sym->attr.use_assoc && !intrinsic_array_parameter))) gfc_defer_symbol_init (sym); + /* Set the vptr of unlimited polymorphic pointer variables so that + they do not cause segfaults in select type, when the selector + is an intrinsic type. Arrays are captured above. */ + if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym) + && CLASS_DATA (sym)->attr.class_pointer + && !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy + && sym->attr.flavor == FL_VARIABLE && !sym->assoc) + gfc_defer_symbol_init (sym); + if (sym->ts.type == BT_CHARACTER && sym->attr.allocatable && !sym->attr.dimension @@ -1906,6 +1915,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); } + gfc_finish_var_decl (decl, sym); if (sym->ts.type == BT_CHARACTER) @@ -4652,6 +4662,29 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->assoc) continue; + /* Set the vptr of unlimited polymorphic pointer variables so that + they do not cause segfaults in select type, when the selector + is an intrinsic type. */ + if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym) + && sym->attr.flavor == FL_VARIABLE && !sym->assoc + && !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer) + { + gfc_symbol *vtab; + gfc_init_block (&tmpblock); + vtab = gfc_find_vtab (&sym->ts); + if (!vtab->backend_decl) + { + if (!vtab->attr.referenced) + gfc_set_sym_referenced (vtab); + gfc_get_symbol_decl (vtab); + } + tmp = gfc_class_vptr_get (sym->backend_decl); + gfc_add_modify (&tmpblock, tmp, + gfc_build_addr_expr (TREE_TYPE (tmp), + vtab->backend_decl)); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + } + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived && sym->ts.u.derived->attr.pdt_type) diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index dcabeca0078..7e768343a57 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -2139,11 +2139,14 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tree ctree = gfc_get_class_from_expr (se.expr); tmp = TREE_TYPE (sym->backend_decl); - /* Coarray scalar component expressions can emerge from - the front end as array elements of the _data field. */ + /* F2018:19.5.1.6 "If a selector has the POINTER attribute, + it shall be associated; the associate name is associated + with the target of the pointer and does not have the + POINTER attribute." */ if (sym->ts.type == BT_CLASS - && e->ts.type == BT_CLASS && e->rank == 0 - && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree) + && e->ts.type == BT_CLASS && e->rank == 0 && ctree + && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) + || CLASS_DATA (e)->attr.class_pointer)) { tree stmp; tree dtmp; @@ -2153,10 +2156,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) ctree = gfc_create_var (dtmp, "class"); stmp = gfc_class_data_get (se.expr); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))); - - /* Set the fields of the target class variable. */ - stmp = gfc_conv_descriptor_data_get (stmp); + /* Coarray scalar component expressions can emerge from + the front end as array elements of the _data field. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))) + stmp = gfc_conv_descriptor_data_get (stmp); dtmp = gfc_class_data_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp); @@ -2170,6 +2173,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) dtmp = gfc_class_len_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp); + need_len_assign = false; } se.expr = ctree; } diff --git a/gcc/testsuite/gfortran.dg/pr107900.f90 b/gcc/testsuite/gfortran.dg/pr107900.f90 new file mode 100644 index 00000000000..2bd80a7d5a8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr107900.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Contributed by Karl Kaiser +! +program test + + class(*), pointer :: ptr1, ptr2(:) + integer, target :: i = 42 + integer :: check = 0 +! First with associate name and no selector in select types + associate (c => ptr1) + select type (c) ! Segfault - vptr not set + type is (integer) + stop 1 + class default + check = 1 + end select + end associate +! Now do the same with the array version + associate (c => ptr2) + select type (d =>c) ! Segfault - vptr not set + type is (integer) + stop 2 + class default + check = check + 10 + end select + end associate + +! And now with the associate name and selector + associate (c => ptr1) + select type (d => c) ! Segfault - vptr not set + type is (integer) + stop 3 + class default + check = check + 100 + end select + end associate +! Now do the same with the array version +! ptr2 => NULL() !This did not fix the problem + associate (c => ptr2) + select type (d => c) ! Segfault - vptr not set + type is (integer) + stop 4 + class default + check = check + 1000 + end select + end associate + if (check .ne. 1111) stop 5 +end program test diff --git a/gcc/testsuite/gfortran.dg/pr110224.f90 b/gcc/testsuite/gfortran.dg/pr110224.f90 new file mode 100644 index 00000000000..186bbf5fe27 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr110224.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! Contributed by Neil Carlson +! +module mod + type :: foo + real, pointer :: var + contains + procedure :: var_ptr + end type +contains + function var_ptr(this) result(ref) + class(foo) :: this + real, pointer :: ref + ref => this%var + end function +end module +program main + use mod + type(foo) :: x + allocate (x%var, source = 2.0) + associate (var => x%var_ptr()) + var = 1.0 + end associate + if (x%var .ne. 1.0) stop 1 + x%var_ptr() = 2.0 + if (x%var .ne. 2.0) stop 2 + deallocate (x%var) +end program diff --git a/gcc/testsuite/gfortran.dg/pr88688.f90 b/gcc/testsuite/gfortran.dg/pr88688.f90 new file mode 100644 index 00000000000..3d65118aaf0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr88688.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! +! Contributed by Thomas Fanning +! +! +module mod + + type test + class(*), pointer :: ptr + contains + procedure :: setref + end type + +contains + + subroutine setref(my,ip) + implicit none + class(test) :: my + integer, pointer :: ip + my%ptr => ip + end subroutine + + subroutine set7(ptr) + implicit none + class(*), pointer :: ptr + select type (ptr) + type is (integer) + ptr = 7 + end select + end subroutine + +end module +!--------------------------------------- + +!--------------------------------------- +program bug +use mod +implicit none + + integer, pointer :: i, j + type(test) :: tp + class(*), pointer :: lp + + allocate(i,j) + i = 3; j = 4 + + call tp%setref(i) + select type (ap => tp%ptr) + class default + call tp%setref(j) + lp => ap + call set7(lp) + end select + +! gfortran used to give i=3 and j=7 because the associate name was not pointing +! to the target of tp%ptr as required by F2018:19.5.1.6 but, rather, to the +! selector itself. + if (i .ne. 7) stop 1 + if (j .ne. 4) stop 2 + +end program +!--------------------------------------- diff --git a/gcc/testsuite/gfortran.dg/pr94380.f90 b/gcc/testsuite/gfortran.dg/pr94380.f90 new file mode 100644 index 00000000000..e29594f2ff9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr94380.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Contributed by Vladimir Nikishkin +! +module test + type testtype + class(*), allocatable :: t + end type testtype +contains + subroutine testproc( x ) + class(testtype) :: x + associate ( temp => x%t) + select type (temp) + type is (integer) + end select + end associate + end subroutine testproc +end module test diff --git a/gcc/testsuite/gfortran.dg/pr95398.f90 b/gcc/testsuite/gfortran.dg/pr95398.f90 index 81cc076c15c..7576f3844b2 100644 --- a/gcc/testsuite/gfortran.dg/pr95398.f90 +++ b/gcc/testsuite/gfortran.dg/pr95398.f90 @@ -1,5 +1,7 @@ ! { dg-do compile } +! { dg-options "-std=f2008" } + program test implicit none @@ -46,8 +48,8 @@ program test end -! { dg-error "cannot be used in a variable definition context .assignment." " " { target *-*-* } 21 } -! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 23 } -! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 } +! { dg-error "being used in a variable definition context .assignment." " " { target *-*-* } 23 } +! { dg-error "being used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 25 } ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 } +! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 39 }