re PR fortran/57834 (C_F_POINTER (only with -std=): accepts only explicit- and assume...

2013-07-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/57834
        * check.c (is_c_interoperable): Add special case for
        * c_f_pointer.
        (explicit-size, gfc_check_c_f_pointer, gfc_check_c_loc): Update
        call.

2013-07-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/57834
        * gfortran.dg/c_f_pointer_tests_8.f90: New.

From-SVN: r200794

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6cbfdae..283521a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,12 @@
 2013-07-08  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/57834
+       * check.c (is_c_interoperable): Add special case for c_f_pointer.
+       (explicit-size, gfc_check_c_f_pointer, gfc_check_c_loc): Update
+       call.
+
+2013-07-08  Tobias Burnus  <burnus@net-b.de>
+
        PR fortran/50554
        * io.c (match_inquire_element): Add missing do-var check.
 

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index e531deb..4024cd4 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3650,10 +3650,11 @@ gfc_check_sizeof (gfc_expr *arg)
    otherwise, it is set to NULL.  The msg string can be used in diagnostics.
    If c_loc is true, character with len > 1 are allowed (cf. Fortran
    2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
-   arrays are permitted.  */
+   arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
+   are permitted. */
 
 static bool
-is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc)
+is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
 {
   *msg = NULL;
 
@@ -3734,7 +3735,8 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc)
          *msg = "Only whole-arrays are interoperable";
          return false;
        }
-      if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE)
+      if (!c_f_ptr && ar->as->type != AS_EXPLICIT
+         && ar->as->type != AS_ASSUMED_SIZE)
        {
          *msg = "Only explicit-size and assumed-size arrays are interoperable";
          return false;
@@ -3750,7 +3752,7 @@ gfc_check_c_sizeof (gfc_expr *arg)
 {
   const char *msg;
 
-  if (!is_c_interoperable (arg, &msg, false))
+  if (!is_c_interoperable (arg, &msg, false, false))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
                 "interoperable data entity: %s",
@@ -3900,7 +3902,7 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
       return false;
     }
 
-  if (!is_c_interoperable (fptr, &msg, false) && fptr->rank)
+  if (!is_c_interoperable (fptr, &msg, false, true))
     return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
                           "at %L to C_F_POINTER: %s", &fptr->where, msg);
 
@@ -4029,7 +4031,7 @@ gfc_check_c_loc (gfc_expr *x)
       return false;
     }
 
-  if (!is_c_interoperable (x, &msg, true))
+  if (!is_c_interoperable (x, &msg, true, false))
     {
       if (x->ts.type == BT_CLASS)
        {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a6291f1..3e66433 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2013-07-08  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/57834
+       * gfortran.dg/c_f_pointer_tests_8.f90: New.
+
+2013-07-08  Tobias Burnus  <burnus@net-b.de>
+
        PR fortran/50554
        * gfortran.dg/do_check_9.f90: New.
 

diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_8.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_8.f90
new file mode 100644 (file)
index 0000000..d82c9ea
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_8.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/57834
+!
+! (Gave a bogus warning before.)
+!
+program main
+
+    use iso_c_binding
+    use iso_fortran_env
+
+    implicit none
+
+    interface
+        function strerror(errno) bind(C, NAME = 'strerror')
+            import
+            type(C_PTR) :: strerror
+            integer(C_INT), value :: errno
+        end function
+    end interface
+
+    integer :: i
+    type(C_PTR) :: cptr
+    character(KIND=C_CHAR), pointer :: str(:)
+
+    cptr = strerror(INT(42, KIND = C_INT))
+    call C_F_POINTER(cptr, str, [255])
+
+    do i = 1, SIZE(str)
+        if (str(i) == C_NULL_CHAR) exit
+        write (ERROR_UNIT, '(A1)', ADVANCE = 'NO') str(i:i)
+    enddo
+
+    write (ERROR_UNIT, '(1X)')
+
+end program main