public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated
@ 2021-03-26  6:58 Paul Richard Thomas
  2021-03-26 11:22 ` Tobias Burnus
  0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2021-03-26  6:58 UTC (permalink / raw)
  To: fortran, gcc-patches; +Cc: Jürgen Reuter

[-- Attachment #1: Type: text/plain, Size: 640 bytes --]

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  <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.

[-- Attachment #2: pr99602a.f90 --]
[-- Type: text/x-fortran, Size: 1941 bytes --]

! { 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" } }

[-- Attachment #3: pr99602.f90 --]
[-- Type: text/x-fortran, Size: 2068 bytes --]

! { 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" } }

[-- Attachment #4: pr99602b.f90 --]
[-- Type: text/x-fortran, Size: 1927 bytes --]

! { 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


[-- Attachment #5: submit.diff --]
[-- Type: text/x-patch, Size: 2561 bytes --]

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

^ permalink raw reply	[flat|nested] 7+ messages in thread
* [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated
@ 2021-03-16 16:42 Paul Richard Thomas
  2021-03-16 17:08 ` Tobias Burnus
  0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2021-03-16 16:42 UTC (permalink / raw)
  To: fortran, gcc-patches; +Cc: Harald Anlauf, Juergen Reuter

[-- Attachment #1: Type: text/plain, Size: 665 bytes --]

Hi Everybody,

Although this is 'obvious' I thought that I should post it because I
believe that it was triggered by the fix for PR99602 but I just do not have
the bandwidth at the moment to test that. The ChangeLog together with the
patch is more than sufficient explanation.

Regtests OK on FC33/x86_64. OK for 11-branch?

Paul

Fortran: Fix runtime errors for class actual arguments [PR99602].

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

gcc/fortran
PR fortran/99602
* trans-array.c (gfc_conv_procedure_call): For class formal
arguments, use the _data field attributes for runtime errors.

gcc/testsuite/
PR fortran/99602
* gfortran.dg/pr99602.f90: New test.

[-- Attachment #2: pr99602.f90 --]
[-- Type: text/x-fortran, Size: 1838 bytes --]

! { 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.
!
! 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 ()
    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" } }

[-- Attachment #3: submit.diff --]
[-- Type: text/x-patch, Size: 2371 bytes --]

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index bffe0808dff..0cf17008b05 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6663,6 +6663,15 @@ 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;
+	      else
+		fsym_attr = fsym->attr;
+	    }
 
 	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
 	    attr = gfc_expr_attr (e);
@@ -6685,17 +6694,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))
+		       && (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 +6728,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))
+		       && (fsym == NULL || !fsym_attr.proc_pointer))
 		msg = xasprintf ("Proc-pointer actual argument '%s' is not "
 				 "associated", e->symtree->n.sym->name);
 	      else

^ permalink raw reply	[flat|nested] 7+ messages in thread
end of thread, other threads:[~2021-03-29  9:15 UTC | newest]

Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-03-26  6:58 [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated Paul Richard Thomas
2021-03-26 11:22 ` Tobias Burnus
2021-03-29  9:15   ` Paul Richard Thomas
  -- strict thread matches above, loose matches on Subject: below --
2021-03-16 16:42 Paul Richard Thomas
2021-03-16 17:08 ` Tobias Burnus
2021-03-18  8:46   ` Tobias Burnus
2021-03-18 13:22     ` Paul Richard Thomas

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).