re PR fortran/84273 ([F03] Reject allocatable passed-object dummy argument (proc_ptr_...

2018-02-12  Janus Weil  <janus@gcc.gnu.org>

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

2018-02-12  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.

From-SVN: r257590

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 43500f1b87362dbb41fdec46c1bc154bd3afdf9e..6f416b31e4ffea50ed5e6d6ef2f60d6b955498ba 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2018-02-12  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/84273
+       * resolve.c (resolve_component): Fix checks of passed argument in
+       procedure-pointer components.
+
 2018-02-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        PR fortran/35299

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 429c1c481cafae082540912ecb30224f628a5a92..01e2c38952c6f2b633b0d7c6d95ae784af8c3b69 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -13706,8 +13706,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
           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,
@@ -13716,7 +13716,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
           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,
@@ -13725,7 +13725,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
           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,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index bf841258f417b4c7d6a94043edfa630fa2e7172a..c4ae3e34ab6ae0ae7a6fb8c058c9c6302f7b3eb5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2018-02-12  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.
+
 2018-02-12  Tamar Christina  <tamar.christina@arm.com>
 
        PR target/82641

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
index 43084f67e40141541a20058164ff5e3a83a2b14c..80a78f3852d18816702197876e5215b9a04b6a6b 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
@@ -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)

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
index b0e7a772723dce13db603024e9271bd0c86046b0..1632e2748218557740c2af03529838def4e84334 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
@@ -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