Hi Harald,
Fixing the original testcase in this PR turned out to be slightly more
involved than I expected. However, it resulted in an open door to fix
some other PRs and the attached much larger patch.
This time, I did remember to include the testcases in the .diff :-)
I believe that, between the Change.Logs and the comments, it is
reasonably self-explanatory.
OK for trunk?
Regards
Paul
Fortran: Fix some bugs in associate [PR87477]
2023-06-20 Paul Thomas <pa...@gcc.gnu.org>
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 --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 e7be7fddc64..0e4b5440393 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6377,6 +6377,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
@@ -6532,7 +6565,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 ();
@@ -6554,24 +6586,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
{
@@ -6618,6 +6637,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 <kaiserkar...@yahoo.com>
+!
+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 <neil.n.carl...@gmail.com>
+!
+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 <thfann...@gmail.com>
+!
+!
+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 <lockyw...@gmail.com>
+!
+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 }
