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 --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index ee48a820f2857c4ca14db5624c2e2e68f41947c6..43bd7be54cb798ff9633ae7f39391c923e442bc9 100644 (file)
--- 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 19e5669b9ee99c1545fbd60cd85489aa67242b05..8d9448eb9b6d11af4564fe4910726cb53445698e 100644 (file)
--- 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 cb7cf7040a9d5303091b98e87096e91d3558795e..421d2479cd67a592bcf84e191dc49a52c925b488 100644 (file)
--- 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 (file)
index 0000000..7ecb88f
--- /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