https://gcc.gnu.org/g:cc8d86ee4680d56eefeb76a8f2f752282e2631e3
commit r16-150-gcc8d86ee4680d56eefeb76a8f2f752282e2631e3
Author: Harald Anlauf <anl...@gmx.de>
Date: Thu Apr 24 21:28:35 2025 +0200
Fortran: fix procedure pointer handling with -fcheck=pointer [PR102900]
PR fortran/102900
gcc/fortran/ChangeLog:
* trans-decl.cc (gfc_generate_function_code): Use sym->result
when generating fake result decl for functions returning
allocatable or pointer results.
* trans-expr.cc (gfc_conv_procedure_call): When checking the
pointer status of an actual argument passed to a non-allocatable,
non-pointer dummy which is of type CLASS, do not check the
class container of the actual if it is just a procedure pointer.
(gfc_trans_pointer_assignment): Fix treatment of assignment to
NULL of a procedure pointer.
gcc/testsuite/ChangeLog:
* gfortran.dg/proc_ptr_52.f90: Add -fcheck=pointer to options.
* gfortran.dg/proc_ptr_57.f90: New test.
Diff:
---
gcc/fortran/trans-decl.cc | 6 +++---
gcc/fortran/trans-expr.cc | 10 +++++----
gcc/testsuite/gfortran.dg/proc_ptr_52.f90 | 1 +
gcc/testsuite/gfortran.dg/proc_ptr_57.f90 | 36 +++++++++++++++++++++++++++++++
4 files changed, 46 insertions(+), 7 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index ee48a820f285..43bd7be54cb7 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -8079,13 +8079,13 @@ gfc_generate_function_code (gfc_namespace * ns)
|| sym->result->ts.u.derived->attr.alloc_comp
|| sym->result->ts.u.derived->attr.pointer_comp))
|| (sym->result->ts.type == BT_CLASS
- && (CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer
+ && (CLASS_DATA (sym->result)->attr.allocatable
+ || CLASS_DATA (sym->result)->attr.class_pointer
|| CLASS_DATA (sym->result)->attr.alloc_comp
|| CLASS_DATA (sym->result)->attr.pointer_comp))))
{
artificial_result_decl = true;
- result = gfc_get_fake_result_decl (sym, 0);
+ result = gfc_get_fake_result_decl (sym->result, 0);
}
if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 19e5669b9ee9..8d9448eb9b6d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8145,7 +8145,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
goto end_pointer_check;
tmp = parmse.expr;
- if (fsym && fsym->ts.type == BT_CLASS)
+ if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
{
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = build_fold_indirect_ref_loc (input_location, tmp);
@@ -10912,9 +10912,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
+ non_proc_ptr_assign
+ = !(gfc_expr_attr (expr1).proc_pointer
+ && ((expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
+ || expr2->expr_type == EXPR_NULL));
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_52.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_52.f90
index cb7cf7040a9d..421d2479cd67 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_52.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_52.f90
@@ -1,4 +1,5 @@
! { dg-do run }
+! { dg-additional-options "-fcheck=pointer" }
!
! Test the fix for PRs93924 & 93925.
!
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_57.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_57.f90
new file mode 100644
index 000000000000..7ecb88f172cb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_57.f90
@@ -0,0 +1,36 @@
+! { dg-do compile }
+! { dg-additional-options "-fcheck=pointer" }
+!
+! PR fortran/102900
+
+module cs
+ implicit none
+ interface
+ function classStar_map_ifc() result(y)
+ import
+ class(*), pointer :: y
+ end function classStar_map_ifc
+ end interface
+
+contains
+
+ function selector()
+ procedure(classStar_map_ifc), pointer :: selector
+ selector => NULL()
+ end function selector
+
+ function selector_result() result(f)
+ procedure(classStar_map_ifc), pointer :: f
+ f => NULL()
+ end function selector_result
+
+ function fun(x) result(y)
+ class(*), pointer :: y
+ class(*), target, intent(in) :: x
+ select type (x)
+ class default
+ y => null()
+ end select
+ end function fun
+
+end module cs
