[Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Paul Richard Thomas]

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

Re: [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Tobias Burnus]

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

Hi Paul,

I do not understand the !UNLIMITED_POLY(fsym) part of the patch.
In particular, your patch causes foo.f90 to fail by wrongly diagnosting:

   Fortran runtime error: Pointer actual argument 'cptr' is not associated

I have only did some light tests – but it seems that just removing
'&& !UNLIMITED_POLY(fsym)' seems to be enough. (But I did not run
the testsuite.)

Hence:
- Please include the attached testcases or some variants of them.
- Check that removing !UNLIMITED_POLY does not cause any regressions

If that works: OK for mainline

Thanks for looking into this issue and working on the patches.

Tobias

On 26.03.21 07:58, Paul Richard Thomas via Fortran wrote:
> 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.
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf

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

! { dg-do compile }
! { dg-options "-fcheck=pointer -fdump-tree-original" }
!
! PR fortran/99602
!

module m
  implicit none
contains
  subroutine wr(y)
    class(*) :: y
    stop 1
  end
end module m

use m
implicit none
integer, pointer :: iptr
class(*), pointer :: cptr

nullify (cptr, iptr)
call wr(iptr)
call wr(cptr)
end

! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" "original" 2 } }
! { dg-final { scan-tree-dump-times "Pointer actual argument 'cptr'" "original" 1 } }
! { dg-final { scan-tree-dump-times "Pointer actual argument 'iptr'" "original" 1 } }

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

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

Re: [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Paul Richard Thomas]

Hi Tobias,

An earlier version of the patch, without the exclusion of unlimited
polymorphic expressions caused several regressions. However, omitting the
exclusion now causes no regressions.  I forgot to go back to this wrinkle.
I have included your testcases with appropriate attribution and pushed as
297363774e6a5dca2f46a85ab086f1d9e59431ac .

Thanks for the review and the additional testcases.

Paul



On Fri, 26 Mar 2021 at 11:22, Tobias Burnus <tobias@codesourcery.com> wrote:

> Hi Paul,
>
> I do not understand the !UNLIMITED_POLY(fsym) part of the patch.
> In particular, your patch causes foo.f90 to fail by wrongly diagnosting:
>
>    Fortran runtime error: Pointer actual argument 'cptr' is not associated
>
> I have only did some light tests – but it seems that just removing
> '&& !UNLIMITED_POLY(fsym)' seems to be enough. (But I did not run
> the testsuite.)
>
> Hence:
> - Please include the attached testcases or some variants of them.
> - Check that removing !UNLIMITED_POLY does not cause any regressions
>
> If that works: OK for mainline
>
> Thanks for looking into this issue and working on the patches.
>
> Tobias
>
> On 26.03.21 07:58, Paul Richard Thomas via Fortran wrote:
> > 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.
> -----------------
> Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München
> Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank
> Thürauf
>


-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein

Re: [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Paul Richard Thomas]

Hi Tobias,

Thanks for the review. I am resisting dg-run for this patch simply because
the testsuite already takes an oppressive amount of time to run. That the
runtime error is present in the code should be sufficient IMHO.

Regards

Paul


On Thu, 18 Mar 2021 at 08:46, Tobias Burnus <tobias@codesourcery.com> wrote:

> Hi Paul, hi all fortran@/gcc-patch@ reader,
>
> it looks as if you replied with your patch submission to the wrong email
> address – and your re-submission ended up at
> https://gcc.gnu.org/PR99602#c17
>
> On 16.03.21 18:08, Tobias Burnus wrote:
> > On 16.03.21 17:42, Paul Richard Thomas via Gcc-patches wrote:
> >> Fortran: Fix runtime errors for class actual arguments [PR99602].
> >> * trans-array.c (gfc_conv_procedure_call): For class formal
> >> arguments, use the _data field attributes for runtime errors.
> >> * gfortran.dg/pr99602.f90: New test.
> > Shouldn't there be also a testcase which triggers this run-time error?
>
> Note: The new submission consists of a new testcase (now two) and the
> actual patch; the new testcase removes 'pointer' from the dummy argument
> of prepare_m2_proc/prepare_whizard_m2 and checks via the
> -ftree-original-dump that there is now run-time check code inserted when
> passing a (nullified) pointer to a nonpointer dummy argument.
>
> Compared to previous patch, 'fsym_attr.pointer =
> fsym_attr.class_pointer' is new, before it was 'fsym_attr.pointer =
> fsym_attr.pointer'.
>
> Paul Richard Thomas wrote in PR99602:
>
> > Good morning all,
> >
> > I have attached the revised patch and an additional testcase. I had
> totally
> > forgotten about the class pointer gotcha.
> >
> > OK for master?
> >
> > Paul
> >
> > Fortran: Fix runtime errors for class actual arguments [PR99602  <
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99602>].
>
> LGTM – thanks for the patch.
>
> I am wondering whether the second testcase should be a 'dg-do run' test
> instead of 'compile' to ensure that the error is indeed triggered
> (currently, it only checks the tree dump that a check is inserted). What
> do you think? [If you do so, you need a dg-shouldfail + dg-output, cf.
> e.g. pointer_check_5.f90.]
>
> Thanks,
>
> Tobias
>
> -----------------
> Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München
> Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank
> Thürauf
>


-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein

Re: [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Tobias Burnus]

Hi Paul, hi all fortran@/gcc-patch@ reader,

it looks as if you replied with your patch submission to the wrong email
address – and your re-submission ended up at https://gcc.gnu.org/PR99602#c17

On 16.03.21 18:08, Tobias Burnus wrote:
> On 16.03.21 17:42, Paul Richard Thomas via Gcc-patches wrote:
>> Fortran: Fix runtime errors for class actual arguments [PR99602].
>> * trans-array.c (gfc_conv_procedure_call): For class formal
>> arguments, use the _data field attributes for runtime errors.
>> * gfortran.dg/pr99602.f90: New test.
> Shouldn't there be also a testcase which triggers this run-time error?

Note: The new submission consists of a new testcase (now two) and the
actual patch; the new testcase removes 'pointer' from the dummy argument
of prepare_m2_proc/prepare_whizard_m2 and checks via the
-ftree-original-dump that there is now run-time check code inserted when
passing a (nullified) pointer to a nonpointer dummy argument.

Compared to previous patch, 'fsym_attr.pointer =
fsym_attr.class_pointer' is new, before it was 'fsym_attr.pointer =
fsym_attr.pointer'.

Paul Richard Thomas wrote in PR99602:

> Good morning all,
>
> I have attached the revised patch and an additional testcase. I had totally
> forgotten about the class pointer gotcha.
>
> OK for master?
>
> Paul
>
> Fortran: Fix runtime errors for class actual arguments [PR99602  <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99602>].

LGTM – thanks for the patch.

I am wondering whether the second testcase should be a 'dg-do run' test
instead of 'compile' to ensure that the error is indeed triggered
(currently, it only checks the tree dump that a check is inserted). What
do you think? [If you do so, you need a dg-shouldfail + dg-output, cf.
e.g. pointer_check_5.f90.]

Thanks,

Tobias

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf

Re: [Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Tobias Burnus]

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

Hi Paul,

On 16.03.21 17:42, Paul Richard Thomas via Gcc-patches wrote:
> Fortran: Fix runtime errors for class actual arguments [PR99602].
> * trans-array.c (gfc_conv_procedure_call): For class formal
> arguments, use the _data field attributes for runtime errors.
> * gfortran.dg/pr99602.f90: New test.

Shouldn't there be also a testcase which triggers this run-time error?

I might have messed up my testcase, but I think it should trigger?
(Attached is an attempt to pass the nullified pointer as actual argument
to a non-pointer argument; otherwise it is the same testcase as before.)

Otherwise, at a glance, it looked sensible.

Tobias

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf

[-- Attachment #2: pr99602-2.f90 --]
[-- Type: text/x-fortran, Size: 1848 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
     integer :: ii(100)
  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
    !if (.not. associated (mm))  allocate (m2_t :: mm)
    mm%ii = 100
    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" } }

[Patch, fortran] PR99602 - [11 regression] runtime error: pointer actual argument not associated

[Paul Richard Thomas]

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