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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 533878768d0c3ac70faa2342634e14e7f80b239a..e1cb45affb1ed9fb6b6fcc10e30905ad4381950c 100644 (file)
--- 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 47a9feed68c140be53d51817fa482b892e4d5ec3..a8ec1ed76b4f79ca4ea8e96c03929d435163fd1c 100644 (file)
--- 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 0a20540b6da765098d6f7850c4082e076c81186f..3e23ca2e31128d736a8034a2429e3fc130368b6a 100644 (file)
--- 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 2934e0ad14b03be887e90972ede22908bb547128..9acf70eb5edc6098fcf4cf62814f041eb5c296d0 100644 (file)
--- 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 c6204bdac7f688870ec99c8f3958b85dde2999ae..f27730a431d335ab88aa3ef7895b8ad944f4e26a 100644 (file)
--- 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 (file)
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 e09b0bb375ad8f5c86b33d12a654e436e607404b..13ca9d91d9e3c5ec3ffbae84e6cb70bf0ffae55c 100644 (file)
--- 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'" }