2019-12-11 Tobias Burnus <tobias@codesourcery.com>
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.
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c | 56 ++++++++++++----
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.c | 25 +++++++
.../gfortran.dg/ISO_Fortran_binding_17.f90 | 77 ++++++++++++++++++++++
libgfortran/runtime/ISO_Fortran_binding.c | 40 +++++------
4 files changed, 160 insertions(+), 38 deletions(-)
@@ -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 *)§ion, 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*)§ion, 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 *)§ion, 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*)§ion, 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;
new file mode 100644
@@ -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;
+}
new file mode 100644
@@ -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)" }
@@ -177,19 +177,21 @@ void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[])
specified by subscripts. */
for (i = 0; i < dv->rank; i++)
{
+ CFI_index_t idx = subscripts[i] - dv->dim[i].lower_bound;
if (unlikely (compile_options.bounds_check)
- && ((dv->dim[i].extent != -1
- && subscripts[i] >= dv->dim[i].extent)
- || subscripts[i] < 0))
+ && ((dv->dim[i].extent != -1 && idx >= dv->dim[i].extent)
+ || idx < 0))
{
- fprintf (stderr, "CFI_address: subscripts[%d], is out of "
- "bounds. dv->dim[%d].extent = %d subscripts[%d] "
- "= %d.\n", i, i, (int)dv->dim[i].extent, i,
- (int)subscripts[i]);
+ fprintf (stderr, "CFI_address: subscripts[%d] is out of "
+ "bounds. For dimension = %d, subscripts = %d, "
+ "lower_bound = %d, upper bound = %d, extend = %d\n",
+ i, i, (int)subscripts[i], (int)dv->dim[i].lower_bound,
+ (int)(dv->dim[i].extent - dv->dim[i].lower_bound),
+ (int)dv->dim[i].extent);
return NULL;
}
- base_addr = base_addr + (CFI_index_t)(subscripts[i] * dv->dim[i].sm);
+ base_addr = base_addr + (CFI_index_t)(idx * dv->dim[i].sm);
}
}
@@ -228,7 +230,7 @@ CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[],
}
/* If the type is a character, the descriptor's element length is replaced
- * by the elem_len argument. */
+ by the elem_len argument. */
if (dv->type == CFI_type_char || dv->type == CFI_type_ucs4_char ||
dv->type == CFI_type_signed_char)
dv->elem_len = elem_len;
@@ -237,7 +239,7 @@ CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[],
size_t arr_len = 1;
/* If rank is greater than 0, lower_bounds and upper_bounds are used. They're
- * ignored otherwhise. */
+ ignored otherwise. */
if (dv->rank > 0)
{
if (unlikely (compile_options.bounds_check)
@@ -325,20 +327,10 @@ int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute,
{
fprintf (stderr, "CFI_establish: Rank must be between 0 and %d, "
"0 < rank (0 !< %d).\n", CFI_MAX_RANK, (int)rank);
- return CFI_INVALID_RANK;
- }
-
- /* C Descriptor must not be an allocated allocatable. */
- if (dv->attribute == CFI_attribute_allocatable && dv->base_addr != NULL)
- {
- fprintf (stderr, "CFI_establish: If the C Descriptor represents an "
- "allocatable variable (dv->attribute = %d), its base "
- "address must be NULL (dv->base_addr = NULL).\n",
- CFI_attribute_allocatable);
- return CFI_INVALID_DESCRIPTOR;
+ return CFI_INVALID_RANK;
}
- /* If base address is not NULL, the established C Descriptor is for a
+ /* If base address is not NULL, the established C Descriptor is for a
nonallocatable entity. */
if (attribute == CFI_attribute_allocatable && base_addr != NULL)
{
@@ -382,13 +374,13 @@ int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute,
dv->type = type;
/* Extents must not be NULL if rank is greater than zero and base_addr is not
- * NULL */
+ NULL */
if (rank > 0 && base_addr != NULL)
{
if (unlikely (compile_options.bounds_check) && extents == NULL)
{
fprintf (stderr, "CFI_establish: Extents must not be NULL "
- "(extents != NULL) if rank (= %d) > 0 nd base address"
+ "(extents != NULL) if rank (= %d) > 0 and base address "
"is not NULL (base_addr != NULL).\n", (int)rank);
return CFI_INVALID_EXTENT;
}