PR fortran/92142 - CFI_setpointer corrupts descriptor

2019-11-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

        libgfortran/
        PR fortran/92142
        * runtime/ISO_Fortran_binding.c (CFI_setpointer): Don't
        override descriptor attribute; with -fcheck, check that
        it is a pointer.

        gcc/testsuite/
        PR fortran/92142
        * gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.c: New.
        * gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.f90: New.
        * gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c: Correct
        upper bounds for case 0.

From-SVN: r278048

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f8e626b..d03a6fd 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2019-11-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
+
+       PR fortran/92142
+       * gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.c: New.
+       * gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.f90: New.
+       * gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c: Correct
+       upper bounds for case 0.
+
 2019-11-11  Thomas Schwinge  <thomas@codesourcery.com>
 
        * gfortran.dg/goacc/common-block-1.f90: Fix OpenACC directives

diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c
index adda3b3..9f06e2d 100644 (file)
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c
@@ -15,7 +15,7 @@ void si(CFI_cdesc_t *this, int flag, int *status)
   bool err;
   CFI_CDESC_T(1) that;
   CFI_index_t lb[] = { 0, 0 };
-  CFI_index_t ub[] = { 4, 1 };
+  CFI_index_t ub[] = { 4, 0 };
   CFI_index_t st[] = { 2, 0 };
   int chksum[] = { 9, 36, 38 };
 
@@ -50,7 +50,7 @@ void si(CFI_cdesc_t *this, int flag, int *status)
 
   if (err)
     {
-      printf("FAIL C: contiguity for flag value %i - is %i\n",flag, value);
+      printf("FAIL C: contiguity for flag value %i - is %i\n", flag, value);
       *status = 10;
       return;
     }

diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.c
new file mode 100644 (file)
index 0000000..cdee0b8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.c
@@ -0,0 +1,40 @@
+/* Test the fix for PR92142. */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+#include <stdlib.h>
+
+int c_setpointer(CFI_cdesc_t *);
+
+int c_setpointer(CFI_cdesc_t *ip)
+{
+  CFI_cdesc_t *yp = NULL;
+  void *auxp = ip->base_addr;
+  int ierr;
+  int status;
+
+  /* Setting up the pointer */
+  ierr = 1;
+  yp = malloc(sizeof(*ip));
+  if (yp == NULL) return ierr;
+  status = CFI_establish(yp, NULL, CFI_attribute_pointer, ip->type, ip->elem_len, ip->rank, NULL);
+  if (status != CFI_SUCCESS) return ierr;
+  if (yp->attribute != CFI_attribute_pointer) return ierr;
+  /* Set the pointer to ip */
+  ierr = 2;
+  status = CFI_setpointer(yp, ip, NULL);
+  if (status != CFI_SUCCESS) return ierr;
+  if (yp->attribute != CFI_attribute_pointer) return ierr;
+  /* Set the pointer to NULL */
+  ierr = 3;
+  status = CFI_setpointer(yp, NULL, NULL);
+  if (status != CFI_SUCCESS) return ierr;
+  if (yp->attribute != CFI_attribute_pointer) return ierr;
+  /* "Set" the ip variable to yp (should not be possible) */
+  ierr = 4;
+  status = CFI_setpointer(ip, yp, NULL);
+  if (status != CFI_INVALID_ATTRIBUTE) return ierr;
+  if (ip->attribute != CFI_attribute_other) return ierr;
+  if (ip->base_addr != auxp) return ierr;
+  return 0;
+}

diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.f90
new file mode 100644 (file)
index 0000000..799f34b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_16.f90
@@ -0,0 +1,25 @@
+! { dg-do run }
+! { dg-additional-options "-fbounds-check" }
+! { dg-additional-sources ISO_Fortran_binding_15.c }
+!
+! Test the fix for PR92142.
+!
+  use, intrinsic :: iso_c_binding, only: c_int
+
+  implicit none
+  
+  interface
+    function c_setpointer(ip) result(ierr) bind(c)
+      use, intrinsic :: iso_c_binding, only: c_int
+      type(*), dimension(..), target :: ip
+      integer(c_int)                 :: ierr
+    end function c_setpointer
+  end interface
+  
+  integer(c_int) :: it = 1
+  
+  if (c_setpointer(it) /= 0) stop 1
+  
+end
+
+! { dg-output "CFI_setpointer: Result shall be the address of a C descriptor for a Fortran pointer." }

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 0684c35..075c986 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,10 @@
+2019-11-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
+
+       PR fortran/92142
+       * runtime/ISO_Fortran_binding.c (CFI_setpointer): Don't
+       override descriptor attribute; with -fcheck, check that
+       it is a pointer.
+
 2019-11-06  Jerry DeLisle  <jvdelisle@gcc.ngu.org>
 
        PR fortran/90374

diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index c71d8e8..ae50057 100644 (file)
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -795,20 +795,29 @@ int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source,
 int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source,
                    const CFI_index_t lower_bounds[])
 {
-  /* Result must not be NULL. */
-  if (unlikely (compile_options.bounds_check) && result == NULL)
+  /* Result must not be NULL and must be a Fortran pointer. */
+  if (unlikely (compile_options.bounds_check))
     {
-      fprintf (stderr, "CFI_setpointer: Result is NULL.\n");
-      return CFI_INVALID_DESCRIPTOR;
+      if (result == NULL)
+       {
+         fprintf (stderr, "CFI_setpointer: Result is NULL.\n");
+         return CFI_INVALID_DESCRIPTOR;
+       }
+      
+      if (result->attribute != CFI_attribute_pointer)
+       {
+         fprintf (stderr, "CFI_setpointer: Result shall be the address of a "
+                  "C descriptor for a Fortran pointer.\n");
+         return CFI_INVALID_ATTRIBUTE;
+       }
     }
-
+      
   /* If source is NULL, the result is a C Descriptor that describes a
    * disassociated pointer. */
   if (source == NULL)
     {
       result->base_addr = NULL;
       result->version  = CFI_VERSION;
-      result->attribute = CFI_attribute_pointer;
     }
   else
     {
@@ -852,7 +861,6 @@ int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source,
 
       /* Assign components to result. */
       result->version = source->version;
-      result->attribute = source->attribute;
 
       /* Dimension information. */
       for (int i = 0; i < source->rank; i++)