re PR fortran/54667 ([OOP] gimplification failure with c_f_pointer)

2012-09-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54667
	* intrinsic.texi (C_F_POINTER): Fix description.
	* resolve.c (gfc_iso_c_sub_interface): Add a check for FPTR argument
	of C_F_POINTER. Modify two error messages. Cleanup.

2012-09-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54667
	* gfortran.dg/c_funloc_tests_6.f90: Modified error message.
	* gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
	* gfortran.dg/c_f_pointer_tests_5.f90: New.

From-SVN: r191870

7 files changed, 62 insertions, 26 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5338787..e1cb45a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2012-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54667
+	* intrinsic.texi (C_F_POINTER): Fix description.
+	* resolve.c (gfc_iso_c_sub_interface): Add a check for FPTR argument
+	of C_F_POINTER. Modify two error messages. Cleanup.
+
 2012-09-24  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/54618
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 47a9fee..a8ec1ed 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -2362,9 +2362,8 @@ end program main
 
 @table @asis
 @item @emph{Description}:
-@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} Assign the target the C pointer
-@var{CPTR} to the Fortran pointer @var{FPTR} and specify its
-shape.
+@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} assigns the target of the C pointer
+@var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape.
 
 @item @emph{Standard}:
 Fortran 2003 and later
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0a20540..3e23ca2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3532,36 +3532,45 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
 	{
 	  if (c->ext.actual != NULL && c->ext.actual->next != NULL)
 	    {
-	      if (c->ext.actual->expr->ts.type != BT_DERIVED
-		  || c->ext.actual->expr->ts.u.derived->intmod_sym_id
-		     != ISOCBINDING_PTR)
+	      gfc_actual_arglist *arg1 = c->ext.actual;
+	      gfc_actual_arglist *arg2 = c->ext.actual->next;
+	      gfc_actual_arglist *arg3 = c->ext.actual->next->next;
+
+	      /* Check first argument (CPTR).  */
+	      if (arg1->expr->ts.type != BT_DERIVED
+		  || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
+		{
+		  gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
+			     "the type C_PTR", &arg1->expr->where);
+		  m = MATCH_ERROR;
+		}
+
+	      /* Check second argument (FPTR).  */
+	      if (arg2->expr->ts.type == BT_CLASS)
 		{
-		  gfc_error ("Argument at %L to C_F_POINTER shall have the type"
-			     " C_PTR", &c->ext.actual->expr->where);
+		  gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
+			     "polymorphic", &arg2->expr->where);
 		  m = MATCH_ERROR;
 		}
 
-	      /* Make sure we got a third arg if the second arg has non-zero
-		 rank.	We must also check that the type and rank are
+	      /* Make sure we got a third arg (SHAPE) if the second arg has
+		 non-zero rank. We must also check that the type and rank are
 		 correct since we short-circuit this check in
 		 gfc_procedure_use() (called above to sort actual args).  */
-	      if (c->ext.actual->next->expr->rank != 0)
+	      if (arg2->expr->rank != 0)
 		{
-		  if(c->ext.actual->next->next == NULL 
-		     || c->ext.actual->next->next->expr == NULL)
+		  if (arg3 == NULL || arg3->expr == NULL)
 		    {
 		      m = MATCH_ERROR;
-		      gfc_error ("Missing SHAPE parameter for call to %s "
-				 "at %L", sym->name, &(c->loc));
+		      gfc_error ("Missing SHAPE argument for call to %s at %L", 
+				 sym->name, &c->loc);
 		    }
-		  else if (c->ext.actual->next->next->expr->ts.type
-			   != BT_INTEGER
-			   || c->ext.actual->next->next->expr->rank != 1)
+		  else if (arg3->expr->ts.type != BT_INTEGER
+			   || arg3->expr->rank != 1)
 		    {
 		      m = MATCH_ERROR;
-		      gfc_error ("SHAPE parameter for call to %s at %L must "
-				 "be a rank 1 INTEGER array", sym->name,
-				 &(c->loc));
+		      gfc_error ("SHAPE argument for call to %s at %L must be "
+				 "a rank 1 INTEGER array", sym->name, &c->loc);
 		    }
 		}
 	    }
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2934e0a..9acf70e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2012-09-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54667
+	* gfortran.dg/c_funloc_tests_6.f90: Modified error message.
+	* gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
+	* gfortran.dg/c_f_pointer_tests_5.f90: New.
+
 2012-09-30  Janus Weil  <janus@gcc.gnu.org> 
 
 	* gfortran.dg/allocate_derived_1.f90: Re-enable class array checks,
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90
index c6204bd..f27730a 100644
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90
@@ -1,7 +1,7 @@
 ! { dg-do compile }
-! verify that the compiler catches the error in the call to c_f_pointer 
-! because it is missing the required SHAPE parameter.  the SHAPE parameter 
-! is optional, in general, but must exist if given a fortran pointer 
+! Verify that the compiler catches the error in the call to c_f_pointer 
+! because it is missing the required SHAPE argument. The SHAPE argument 
+! is optional, in general, but must exist if given a Fortran pointer 
 ! to a non-zero rank object.  --Rickett, 09.26.06
 module c_f_pointer_shape_test
 contains
@@ -13,7 +13,8 @@ contains
     type(c_ptr), value :: cPtr
     
     myArrayPtr => myArray
-    call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE parameter" }
+    call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE argument" }
   end subroutine test_0
 end module c_f_pointer_shape_test
 
+! { dg-final { cleanup-modules "c_f_pointer_shape_test" } }
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90
new file mode 100644
index 0000000..05a3d8b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+!
+! PR 54667: [OOP] gimplification failure with c_f_pointer
+!
+! Contributed by Andrew Benson <abensonca@gmail.com>
+
+use, intrinsic :: ISO_C_Binding
+type :: nc
+end type
+type(c_ptr) :: cSelf
+class(nc), pointer :: self
+call c_f_pointer(cSelf, self)  ! { dg-error "must not be polymorphic" }
+end
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
index e09b0bb..13ca9d9 100644
--- a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
+++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
@@ -23,7 +23,7 @@ procedure(integer), pointer :: fint
 cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." })
 cfp = c_loc (int)   ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
 
-call c_f_pointer (cfp, int)     ! { dg-error "Argument at .1. to C_F_POINTER shall have the type C_PTR" }
+call c_f_pointer (cfp, int)     ! { dg-error "Argument CPTR to C_F_POINTER at .1. shall have the type C_PTR" }
 call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" }
 
 cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" }