This patch is straightforward but the isolation of the problem was rather
less so. Many thanks to Juergen for testcase reduction.
Regtested on FC33/x86_64 - OK for master?
Paul
Fortran: Fix problem with runtime pointer chack [PR99602].
2021-03-26 Paul Thomas <pa...@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.
! { 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.reu...@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" } }
! { 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.reu...@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" } }
! { 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.reu...@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/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index bffe0808dff..723ebcc27f8 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 && !UNLIMITED_POLY (fsym))
+ {
+ 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
