Fortran: Fix problem with runtime pointer check [PR99602].

2021-03-28  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/99602
	* trans-expr.c (gfc_conv_procedure_call): Use the _data attrs
	for class expressions and detect proc pointer evaluations by
	the non-null actual argument list.

gcc/testsuite/ChangeLog

	PR fortran/99602
	* gfortran.dg/pr99602.f90: New test.
	* gfortran.dg/pr99602a.f90: New test.
	* gfortran.dg/pr99602b.f90: New test.
	* gfortran.dg/pr99602c.f90: New test.
	* gfortran.dg/pr99602d.f90: New test.

6 files changed, 321 insertions, 8 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index bffe080..2fa17b3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6663,6 +6663,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  char *msg;
 	  tree cond;
 	  tree tmp;
+	  symbol_attribute fsym_attr;
+
+	  if (fsym)
+	    {
+	      if (fsym->ts.type == BT_CLASS)
+		{
+		  fsym_attr = CLASS_DATA (fsym)->attr;
+		  fsym_attr.pointer = fsym_attr.class_pointer;
+		}
+	      else
+		fsym_attr = fsym->attr;
+	    }
 
 	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
 	    attr = gfc_expr_attr (e);
@@ -6685,17 +6697,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tree present, null_ptr, type;
 
 	      if (attr.allocatable
-		  && (fsym == NULL || !fsym->attr.allocatable))
+		  && (fsym == NULL || !fsym_attr.allocatable))
 		msg = xasprintf ("Allocatable actual argument '%s' is not "
 				 "allocated or not present",
 				 e->symtree->n.sym->name);
 	      else if (attr.pointer
-		       && (fsym == NULL || !fsym->attr.pointer))
+		       && (fsym == NULL || !fsym_attr.pointer))
 		msg = xasprintf ("Pointer actual argument '%s' is not "
 				 "associated or not present",
 				 e->symtree->n.sym->name);
-	      else if (attr.proc_pointer
-		       && (fsym == NULL || !fsym->attr.proc_pointer))
+	      else if (attr.proc_pointer && !e->value.function.actual
+		       && (fsym == NULL || !fsym_attr.proc_pointer))
 		msg = xasprintf ("Proc-pointer actual argument '%s' is not "
 				 "associated or not present",
 				 e->symtree->n.sym->name);
@@ -6719,15 +6731,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
           else
 	    {
 	      if (attr.allocatable
-		  && (fsym == NULL || !fsym->attr.allocatable))
+		  && (fsym == NULL || !fsym_attr.allocatable))
 		msg = xasprintf ("Allocatable actual argument '%s' is not "
 				 "allocated", e->symtree->n.sym->name);
 	      else if (attr.pointer
-		       && (fsym == NULL || !fsym->attr.pointer))
+		       && (fsym == NULL || !fsym_attr.pointer))
 		msg = xasprintf ("Pointer actual argument '%s' is not "
 				 "associated", e->symtree->n.sym->name);
-	      else if (attr.proc_pointer
-		       && (fsym == NULL || !fsym->attr.proc_pointer))
+	      else if (attr.proc_pointer && !e->value.function.actual
+		       && (fsym == NULL || !fsym_attr.proc_pointer))
 		msg = xasprintf ("Proc-pointer actual argument '%s' is not "
 				 "associated", e->symtree->n.sym->name);
 	      else
diff --git a/gcc/testsuite/gfortran.dg/pr99602.f90 b/gcc/testsuite/gfortran.dg/pr99602.f90
new file mode 100644
index 0000000..6c8455b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99602.f90
@@ -0,0 +1,94 @@
+! { dg-do compile }
+! { dg-options "-fcheck=pointer -fdump-tree-original" }
+!
+! Test fix of PR99602, where a spurious runtime error was introduced
+! by PR99112. This is the testcase in comment #6 of the PR.
+! PR99602a.f90 turns on the runtime errors by eliminating the pointer
+! attribute from the formal arguments in the abstract interface and
+! prepare_whizard_m2.
+!
+! Contributed by Jeurgen Reuter  <juergen.reuter@desy.de>
+!
+module m
+  implicit none
+  private
+  public :: m_t
+  type :: m_t
+     private
+  end type m_t
+end module m
+
+module m2_testbed
+  use m
+  implicit none
+  private
+  public :: prepare_m2
+  procedure (prepare_m2_proc), pointer :: prepare_m2 => null ()
+
+  abstract interface
+     subroutine prepare_m2_proc (m2)
+       import
+       class(m_t), intent(inout), pointer :: m2
+     end subroutine prepare_m2_proc
+  end interface
+
+end module m2_testbed
+
+module a
+  use m
+  use m2_testbed, only: prepare_m2
+  implicit none
+  private
+  public :: a_1
+
+contains
+
+  subroutine a_1 ()
+    class(m_t), pointer :: mm
+    mm => null ()
+    call prepare_m2 (mm) ! Runtime error triggered here
+  end subroutine a_1
+
+end module a
+
+
+module m2
+  use m
+  implicit none
+  private
+  public :: m2_t
+
+  type, extends (m_t) :: m2_t
+     private
+   contains
+     procedure :: read => m2_read
+  end type m2_t
+contains
+
+  subroutine m2_read (mm)
+    class(m2_t), intent(out), target :: mm
+  end subroutine m2_read
+end module m2
+
+program main
+  use m2_testbed
+  use a, only: a_1
+  implicit none
+  prepare_m2 => prepare_whizard_m2
+  call a_1 ()
+
+contains
+
+  subroutine prepare_whizard_m2 (mm)
+    use m
+    use m2
+    class(m_t), intent(inout), pointer :: mm
+    if (.not. associated (mm))  allocate (m2_t :: mm)
+    select type (mm)
+    type is (m2_t)
+!       call mm%read ()  ! Since mm is passed to non-pointer, this generates the error code.
+    end select
+  end subroutine prepare_whizard_m2
+end program main
+! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 0 "original" } }
+! { dg-final { scan-tree-dump-times "Pointer actual argument" 0 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pr99602a.f90 b/gcc/testsuite/gfortran.dg/pr99602a.f90
new file mode 100644
index 0000000..45063e4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99602a.f90
@@ -0,0 +1,93 @@
+! { dg-do compile }
+! { dg-options "-fcheck=pointer -fdump-tree-original" }
+!
+! Test fix of PR99602, where a spurious runtime error was introduced
+! by PR99112. This is the testcase in comment #6 of the PR.
+! This version of PR99602.f90 turns on the runtime errors by eliminating
+! the pointer attribute from the formal arguments in the abstract interface
+! and prepare_whizard_m2.
+!
+! Contributed by Jeurgen Reuter  <juergen.reuter@desy.de>
+!
+module m
+  implicit none
+  private
+  public :: m_t
+  type :: m_t
+     private
+  end type m_t
+end module m
+
+module m2_testbed
+  use m
+  implicit none
+  private
+  public :: prepare_m2
+  procedure (prepare_m2_proc), pointer :: prepare_m2 => null ()
+
+  abstract interface
+     subroutine prepare_m2_proc (m2)
+       import
+       class(m_t), intent(inout) :: m2
+     end subroutine prepare_m2_proc
+  end interface
+
+end module m2_testbed
+
+module a
+  use m
+  use m2_testbed, only: prepare_m2
+  implicit none
+  private
+  public :: a_1
+
+contains
+
+  subroutine a_1 ()
+    class(m_t), pointer :: mm
+    mm => null ()
+    call prepare_m2 (mm) ! Runtime error triggered here
+  end subroutine a_1
+
+end module a
+
+
+module m2
+  use m
+  implicit none
+  private
+  public :: m2_t
+
+  type, extends (m_t) :: m2_t
+     private
+   contains
+     procedure :: read => m2_read
+  end type m2_t
+contains
+
+  subroutine m2_read (mm)
+    class(m2_t), intent(out), target :: mm
+  end subroutine m2_read
+end module m2
+
+program main
+  use m2_testbed
+  use a, only: a_1
+  implicit none
+  prepare_m2 => prepare_whizard_m2
+  call a_1 ()
+
+contains
+
+  subroutine prepare_whizard_m2 (mm)
+    use m
+    use m2
+    class(m_t), intent(inout) :: mm
+    select type (mm)
+    type is (m2_t)
+       call mm%read ()
+    end select
+  end subroutine prepare_whizard_m2
+end program main
+! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 1 "original" } }
+! { dg-final { scan-tree-dump-times "Pointer actual argument" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pr99602b.f90 b/gcc/testsuite/gfortran.dg/pr99602b.f90
new file mode 100644
index 0000000..ba6d5b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99602b.f90
@@ -0,0 +1,64 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+!
+! Test the fix for PR99602 in which the runtime error,
+! "Proc-pointer actual argument 'model' is not associated" was triggered
+! by the NULL result from model%get_par_data_ptr ("tea ")
+!
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+!
+module model_data
+  type :: model_data_t
+     type(modelpar_real_t), dimension(:), pointer :: par_real => null ()
+   contains
+     procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name
+     procedure :: set => field_data_set
+  end type model_data_t
+
+  type :: modelpar_real_t
+     character (4) :: name
+     real(4) :: value
+  end type modelpar_real_t
+
+  type(modelpar_real_t), target :: names(2) = [modelpar_real_t("foo ", 1.0), &
+                                               modelpar_real_t("bar ", 2.0)]
+  integer :: return_value = 0
+
+contains
+
+  function model_data_get_par_data_ptr_name (model, name) result (ptr)
+    class(model_data_t), intent(in) :: model
+    character (*), intent(in) :: name
+    class(modelpar_real_t), pointer :: ptr
+    integer :: i
+    ptr => null ()
+    do i = 1, size (model%par_real)
+       if (model%par_real(i)%name == name) ptr => model%par_real(i)
+    end do
+  end function model_data_get_par_data_ptr_name
+
+  subroutine field_data_set (this, ptr)
+    class(model_data_t), intent(inout) :: this
+    class(modelpar_real_t), intent(in), pointer :: ptr
+    if (associated (ptr)) then
+      return_value = int (ptr%value)
+    else
+      return_value = -1
+    end if
+  end subroutine
+
+end module model_data
+
+  use model_data
+  class(model_data_t), allocatable :: model
+  class(modelpar_real_t), pointer :: name_ptr
+
+  allocate (model_data_t :: model)
+  model%par_real => names
+
+  call model%set (model%get_par_data_ptr ("bar "))
+  if (return_value .ne. 2) stop 1
+  call model%set (model%get_par_data_ptr ("tea ")) ! Triggered runtime error
+  if (return_value .ne. -1) stop 2
+end
+
diff --git a/gcc/testsuite/gfortran.dg/pr99602c.f90 b/gcc/testsuite/gfortran.dg/pr99602c.f90
new file mode 100644
index 0000000..d16c9ff
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99602c.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }

+! { dg-options "-fcheck=pointer -fdump-tree-original" }

+!

+! PR fortran/99602

+!

+

+module m

+  implicit none

+contains

+  subroutine wr(y)

+    class(*), pointer :: y

+    if (associated (y)) stop 1

+  end

+end module m

+

+use m

+implicit none

+class(*), pointer :: cptr

+

+nullify (cptr)

+call wr(cptr)

+end

+

+! { dg-final { scan-tree-dump-not "_gfortran_runtime_error_at" "original" } }

+! { dg-final { scan-tree-dump-not "Pointer actual argument" "original" } }

diff --git a/gcc/testsuite/gfortran.dg/pr99602d.f90 b/gcc/testsuite/gfortran.dg/pr99602d.f90
new file mode 100644
index 0000000..d16c9ff
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99602d.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }

+! { dg-options "-fcheck=pointer -fdump-tree-original" }

+!

+! PR fortran/99602

+!

+

+module m

+  implicit none

+contains

+  subroutine wr(y)

+    class(*), pointer :: y

+    if (associated (y)) stop 1

+  end

+end module m

+

+use m

+implicit none

+class(*), pointer :: cptr

+

+nullify (cptr)

+call wr(cptr)

+end

+

+! { dg-final { scan-tree-dump-not "_gfortran_runtime_error_at" "original" } }

+! { dg-final { scan-tree-dump-not "Pointer actual argument" "original" } }