PR fortran/92470 Fixes for CFI_address

        libgfortran/
        PR fortran/92470
        * runtime/ISO_Fortran_binding.c (CFI_address): Handle non-zero
        lower_bound; update error message.
        (CFI_allocate): Fix comment typo.
        (CFI_establish): Fix identation, fix typos, don't check values of 'dv'
        argument.

        gcc/testsuite/
        PR fortran/92470
        * gfortran.dg/ISO_Fortran_binding_17.c: New.
        * gfortran.dg/ISO_Fortran_binding_17.f90: New.
        * gfortran.dg/ISO_Fortran_binding_1.c (elemental_mult_c, allocate_c,
        section_c, select_part_c): Update for CFI_{address} changes;
        add asserts.

From-SVN: r278101

4 files changed, 153 insertions, 14 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 584ccd7..3ee50a6 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2019-11-12  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/92470
+	* gfortran.dg/ISO_Fortran_binding_17.c: New.
+	* gfortran.dg/ISO_Fortran_binding_17.f90: New.
+	* gfortran.dg/ISO_Fortran_binding_1.c (elemental_mult_c, allocate_c,
+	section_c, select_part_c): Update for CFI_{address} changes;
+	add asserts.
+
 2019-11-12  Martin Sebor  <msebor@redhat.com>
 
 	PR tree-optimization/92412
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
index a6353c7..091e754 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
@@ -1,6 +1,7 @@
 /* Test F2008 18.5: ISO_Fortran_binding.h functions.  */
 
 #include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <assert.h>
 #include <stdio.h>
 #include <stdlib.h>
 #include <complex.h>
@@ -33,13 +34,34 @@ int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc,
       || c_desc->rank != 2)
     return err;
 
-  for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
-    for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
-      {
-	res_addr = CFI_address (a_desc, idx);
-	*res_addr = *(int*)CFI_address (b_desc, idx)
-		    * *(int*)CFI_address (c_desc, idx);
-      }
+  if (a_desc->attribute == CFI_attribute_other)
+    {
+      assert (a_desc->dim[0].lower_bound == 0);
+      assert (a_desc->dim[1].lower_bound == 0);
+      for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
+	for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
+	  {
+	    res_addr = CFI_address (a_desc, idx);
+	    *res_addr = *(int*)CFI_address (b_desc, idx)
+			* *(int*)CFI_address (c_desc, idx);
+	  }
+    }
+  else
+    {
+      assert (a_desc->attribute == CFI_attribute_allocatable
+	      || a_desc->attribute == CFI_attribute_pointer);
+      for (idx[0] = a_desc->dim[0].lower_bound;
+	   idx[0] < a_desc->dim[0].extent + a_desc->dim[0].lower_bound;
+	   idx[0]++)
+	for (idx[1] = a_desc->dim[1].lower_bound;
+	     idx[1] < a_desc->dim[1].extent + a_desc->dim[1].lower_bound;
+	     idx[1]++)
+	  {
+	    res_addr = CFI_address (a_desc, idx);
+	    *res_addr = *(int*)CFI_address (b_desc, idx)
+			* *(int*)CFI_address (c_desc, idx);
+	  }
+    }
 
   return 0;
 }
@@ -57,15 +79,16 @@ int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[])
   CFI_index_t idx[2];
   int *res_addr;
 
+  if (da->attribute == CFI_attribute_other) return err;
   if (CFI_allocate(da, lower, upper, 0)) return err;
+  assert (da->dim[0].lower_bound == lower[0]);
+  assert (da->dim[1].lower_bound == lower[1]);
 
-
-  for (idx[0] = 0; idx[0] < da->dim[0].extent; idx[0]++)
-    for (idx[1] = 0; idx[1] < da->dim[1].extent; idx[1]++)
+  for (idx[0] = lower[0]; idx[0] < da->dim[0].extent + lower[0]; idx[0]++)
+    for (idx[1] = lower[1]; idx[1] < da->dim[1].extent + lower[1]; idx[1]++)
       {
 	res_addr = CFI_address (da, idx);
-	*res_addr = (int)((idx[0] + da->dim[0].lower_bound)
-			  * (idx[1] + da->dim[1].lower_bound));
+	*res_addr = (int)(idx[0] * idx[1]);
       }
 
   return 0;
@@ -118,10 +141,11 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
 			  CFI_type_float, 0, 1, NULL);
       if (ind) return -1.0;
       ind = CFI_section((CFI_cdesc_t *)&section, source, lower, NULL, strides);
+      assert (section.dim[0].lower_bound == lower[0]);
       if (ind) return -2.0;
 
       /* Sum over the section  */
-      for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
+      for (idx[0] = lower[0]; idx[0] < section.dim[0].extent + lower[0]; idx[0]++)
         ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
       return ans;
     }
@@ -138,10 +162,12 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
       if (ind) return -1.0;
       ind = CFI_section((CFI_cdesc_t *)&section, source,
 			lower, upper, strides);
+      assert (section.rank == 1);
+      assert (section.dim[0].lower_bound == lower[0]);
       if (ind) return -2.0;
 
       /* Sum over the section  */
-      for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
+      for (idx[0] = lower[0]; idx[0] < section.dim[0].extent + lower[0]; idx[0]++)
         ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
       return ans;
     }
@@ -166,6 +192,8 @@ double select_part_c (CFI_cdesc_t * source)
 		      CFI_type_double_Complex, sizeof(double _Complex),
 		      2, extent);
   (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
+  assert (comp_cdesc->dim[0].lower_bound == 0);
+  assert (comp_cdesc->dim[1].lower_bound == 0);
 
   /* Sum over comp_cdesc[4,:]  */
   size = comp_cdesc->dim[1].extent;
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.c
new file mode 100644
index 0000000..b0893cc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.c
@@ -0,0 +1,25 @@
+/* PR fortran/92470  - to be used with ISO_Fortran_binding_17.f90 */
+
+#include <stdio.h>
+#include <assert.h>
+#include "ISO_Fortran_binding.h"
+
+void Csub(const CFI_cdesc_t *, size_t, CFI_index_t invalid);
+
+void Csub(const CFI_cdesc_t * dv, size_t locd, CFI_index_t invalid) {
+
+   CFI_index_t lb[1];
+   lb[0] = dv->dim[0].lower_bound;
+   size_t ld = (size_t)CFI_address(dv, lb);
+
+   if (ld != locd)
+     printf ("In C function: CFI_address of dv = %I64x\n", ld);
+   assert( ld == locd );
+
+   lb[0] = invalid;
+   /* Shall return NULL and produce stderr diagnostic with -fcheck=array.  */
+   ld = (size_t)CFI_address(dv, lb);
+   assert (ld == 0);
+
+   return;
+}
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90
new file mode 100644
index 0000000..bb30931
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+! { dg-additional-sources ISO_Fortran_binding_17.c }
+! { dg-options "-fcheck=all" }
+! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! PR fortran/92470
+!
+! https://github.com/j3-fortran/fortran_proposals/issues/57#issuecomment-552680503
+!
+! Unit Test #: Test-1.F2018-2.7.5
+! Author     : FortranFan
+! Reference  : The New Features of Fortran 2018, John Reid, August 2, 2018
+!              ISO/IEC JTC1/SC22/WG5 N2161
+! Description:
+! Test item 2.7.5 Fortran subscripting
+! void *CFI_address(const CFI_cdesc_t *dv, const CFI_index_t subscripts[]);
+! that returns the C address of a scalar or of an element of an array using
+! Fortran sub-scripting.
+!
+   use, intrinsic :: iso_c_binding, only: c_int, c_size_t, c_loc
+   implicit none
+
+   integer, parameter :: LB_A = -2
+   integer, parameter :: UB_A = 1
+   character(len=*), parameter :: fmtg = "(*(g0,1x))"
+   character(len=*), parameter :: fmth = "(g0,1x,z0)"
+
+   blk1: block
+      interface
+         subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub")
+            import :: c_size_t
+            type(*), intent(in) :: a(:)
+            integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx
+         end subroutine
+      end interface
+
+      integer(c_int), target :: a( LB_A:UB_A )
+      integer(c_size_t) :: loc_a
+
+      print fmtg, "Block 1"
+
+      loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a)
+      print fmth, "Address of a: ", loc_a
+
+      call Csub(a, loc_a, -1_c_size_t) ! LB starts at 0
+      call Csub(a, loc_a, 5_c_size_t)  ! 4 elements + 1
+      print *
+   end block blk1
+
+   blk2: block
+      interface
+         subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub")
+            import :: c_int, c_size_t
+            integer(kind=c_int), allocatable, intent(in) :: a(:)
+            integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx
+         end subroutine
+      end interface
+
+      integer(c_int), allocatable, target :: a(:)
+      integer(c_size_t) :: loc_a
+
+      print fmtg, "Block 2"
+
+      allocate( a( LB_A:UB_A ) )
+      loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a )
+      print fmth, "Address of a: ", loc_a
+
+      call Csub(a, loc_a, LB_A-1_c_size_t)
+      call Csub(a, loc_a, UB_A+1_c_size_t)
+      print *
+   end block blk2
+end
+
+! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -1, lower_bound = 0, upper bound = 4, extend = 4(\n|\r\n|\r)" }
+! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 5, lower_bound = 0, upper bound = 4, extend = 4(\n|\r\n|\r).*" }
+! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -3, lower_bound = -2, upper bound = 6, extend = 4(\n|\r\n|\r)" }
+! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 2, lower_bound = -2, upper bound = 6, extend = 4(\n|\r\n|\r)" }