From: Janus Weil <janus@gcc.gnu.org>
Date: Mon, 12 Feb 2018 17:11:58 +0000 (+0100)
Subject: re PR fortran/84273 ([F03] Reject allocatable passed-object dummy argument (proc_ptr_... 
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=24abcc441ab1c0e8705e43189efff80daa36acfb;p=gcc.git

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

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 43500f1b873..6f416b31e4f 100644
--- 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 429c1c481ca..01e2c38952c 100644
--- 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 bf841258f41..c4ae3e34ab6 100644
--- 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 43084f67e40..80a78f3852d 100644
--- 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 b0e7a772723..1632e274821 100644
--- 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