Regarding the uncontroversial part: CFI_address. This has been reported
by Vipul Parekh a few hours ago and the problem is: The lower bounds
stored in a bind(C) descriptor are either 0 – or, for
pointer/allocatable arrays, the value used during allocation/pointer
association (cf. F2018, 18.5.3, para 3, quoted in the PR).
But CFI_address was always assuming 0.
When fixing it, ISO_Fortran_binding_1.f90 started to fail – and looking
through the code, I run in two problems related to the "lower_bound"s:
(1) CFI_section: Nothing in the standard states, which 'lower_bound's
shall be used for 'result'. Creating a section in Fortran always gives
.true. for "any(lbound(array(<section>)) == 1)" – and the CFI array
descriptors often uses '0' when Fortran has '1'. Another option would be
to propagate the specified array section on to the CFI descriptor (i.e.
the specified lower_bounds if not NULL or the "source"'s lower bounds
(if lower_bound is NULL) – gfortran does the latter.
(2) CFI_establish: For allocatables, it is clear – base_addr == NULL.
For pointers, it is clear as well – it has to be '0' according to the
standard. But for CFI_attribute_other …
I have now asked at
https://mailman.j3-fortran.org/pipermail/j3/2019-November/thread.html#11740
– Bob thinks there might be an issue for (2) but both Bob and Bill claim
that it is well-defined for (1). But I am not convinced. However, as it
is unclear, I have now reverted my local changes and only kept the non
lower_bound changes for CFI_establish/CFI_section.
Additionally, the 'dv' value of CFI_establish is some pointer to memory
which can hold an array descriptor. This memory can contain any garbage
(e.g. via dv = malloc(…) with glibc's MALLOC_PERTURB_ set). Hence, it
does not make sense to check 'dv' for a certain value.
Build + regtested on x86_64-gnu-linux.
OK for the trunk? Should it be backported to GCC 9?
Cheers,
Tobias
2019-12-11 Tobias Burnus <tob...@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(-)
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
index a6353c7cca6..091e754d8f9 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 *)§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;
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 00000000000..b0893cc15e8
--- /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 00000000000..bb309315261
--- /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)" }
diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index ae500571098..7ae2a9351da 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -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;
}
