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