Hi all,
the attached patch fixes some checking code for PASS arguments in
procedure-pointer components, which does not properly account for the
fact that the PASS argument needs to be polymorphic.
[The reason for this issue is probably that PPCs were mostly
implemented before polymorphism was available. The corresponding
pass-arg checks for TBPs are ok.]
The patch also fixes an invalid test case (which was detected thanks
to Neil Carlson). It regtests cleanly on x86_64-linux-gnu. Ok for
trunk?
Cheers,
Janus
2018-02-09 Janus Weil <ja...@gcc.gnu.org>
PR fortran/84273
* resolve.c (resolve_component): Fix checks of passed argument in
procedure-pointer components.
2018-02-09 Janus Weil <ja...@gcc.gnu.org>
PR fortran/84273
* gfortran.dg/proc_ptr_47.f90: Fix invalid test case.
* gfortran.dg/proc_ptr_comp_pass_4.f90: Fix and extend test case.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 257498)
+++ gcc/fortran/resolve.c (working copy)
@@ -13703,8 +13703,8 @@ resolve_component (gfc_component *c, gfc_symbol *s
return false;
}
- /* Check for C453. */
- if (me_arg->attr.dimension)
+ /* Check for F03:C453. */
+ if (CLASS_DATA (me_arg)->attr.dimension)
{
gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"must be scalar", me_arg->name, c->name, me_arg->name,
@@ -13713,7 +13713,7 @@ resolve_component (gfc_component *c, gfc_symbol *s
return false;
}
- if (me_arg->attr.pointer)
+ if (CLASS_DATA (me_arg)->attr.class_pointer)
{
gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"may not have the POINTER attribute", me_arg->name,
@@ -13722,7 +13722,7 @@ resolve_component (gfc_component *c, gfc_symbol *s
return false;
}
- if (me_arg->attr.allocatable)
+ if (CLASS_DATA (me_arg)->attr.allocatable)
{
gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"may not be ALLOCATABLE", me_arg->name, c->name,
Index: gcc/testsuite/gfortran.dg/proc_ptr_47.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_47.f90 (revision 257498)
+++ gcc/testsuite/gfortran.dg/proc_ptr_47.f90 (working copy)
@@ -21,13 +21,9 @@
contains
function foo(A)
- class(AA), allocatable :: A
+ class(AA) :: A
type(AA) foo
- if (.not.allocated (A)) then
- allocate (A, source = AA (2, foo))
- endif
-
select type (A)
type is (AA)
foo = AA (3, foo)
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 (revision 257498)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 (working copy)
@@ -37,22 +37,23 @@ module m
type :: t8
procedure(foo8), pass, pointer :: f8 ! { dg-error "must be of the derived
type" }
+ procedure(foo9), pass, pointer :: f9 ! { dg-error "Non-polymorphic
passed-object dummy argument" }
end type
contains
subroutine foo1 (x1,y1)
- type(t1) :: x1(:)
+ class(t1) :: x1(:)
type(t1) :: y1
end subroutine
subroutine foo2 (x2,y2)
- type(t2),pointer :: x2
+ class(t2),pointer :: x2
type(t2) :: y2
end subroutine
subroutine foo3 (x3,y3)
- type(t3),allocatable :: x3
+ class(t3),allocatable :: x3
type(t3) :: y3
end subroutine
@@ -69,4 +70,8 @@ contains
integer :: i
end function
+ subroutine foo9(x)
+ type(t8) :: x
+ end subroutine
+
end module m
