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.
This commit is contained in:
Paul Thomas
parent
5a5d23010a
commit
297363774e
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
@ -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" } }
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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" } }
|
||||
|
|
@ -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" } }
|
||||
Loading…
Reference in New Issue