[Patch, Fortran] PR 84273: Reject allocatable passed-object dummy argument (proc_ptr_47.f90)

[Janus Weil]

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  <janus@gcc.gnu.org>

    PR fortran/84273
    * resolve.c (resolve_component): Fix checks of passed argument in
    procedure-pointer components.


2018-02-09  Janus Weil  <janus@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.
-------------- next part --------------
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