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);
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);
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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
+
--- /dev/null
+! { dg-do compile }\r
+! { dg-options "-fcheck=pointer -fdump-tree-original" }\r
+!\r
+! PR fortran/99602\r
+!\r
+\r
+module m\r
+ implicit none\r
+contains\r
+ subroutine wr(y)\r
+ class(*), pointer :: y\r
+ if (associated (y)) stop 1\r
+ end\r
+end module m\r
+\r
+use m\r
+implicit none\r
+class(*), pointer :: cptr\r
+\r
+nullify (cptr)\r
+call wr(cptr)\r
+end\r
+\r
+! { dg-final { scan-tree-dump-not "_gfortran_runtime_error_at" "original" } }\r
+! { dg-final { scan-tree-dump-not "Pointer actual argument" "original" } }\r
--- /dev/null
+! { dg-do compile }\r
+! { dg-options "-fcheck=pointer -fdump-tree-original" }\r
+!\r
+! PR fortran/99602\r
+!\r
+\r
+module m\r
+ implicit none\r
+contains\r
+ subroutine wr(y)\r
+ class(*), pointer :: y\r
+ if (associated (y)) stop 1\r
+ end\r
+end module m\r
+\r
+use m\r
+implicit none\r
+class(*), pointer :: cptr\r
+\r
+nullify (cptr)\r
+call wr(cptr)\r
+end\r
+\r
+! { dg-final { scan-tree-dump-not "_gfortran_runtime_error_at" "original" } }\r
+! { dg-final { scan-tree-dump-not "Pointer actual argument" "original" } }\r
projects / platform / upstream / gcc.git / commitdiff