commit a2e189aeb165781fe741f942e00bf073a496af92 Author: Sandra Loosemore Date: Sat Jul 17 16:12:18 2021 -0700 [PR libfortran/101310] Bind(c): Fix bugs in CFI_section CFI_section was incorrectly adjusting the base pointer for the result array twice in different ways. It was also overwriting the array dimension info in the result descriptor before computing the base address offset from the source descriptor, which caused problems if the two descriptors are the same. This patch fixes both problems and makes the code simpler, too. A consequence of this patch is that the result array is now 0-based in all dimensions instead of starting at the numbering to match the first element of the source array. The Fortran standard only specifies the shape of the result array, not its lower bounds, so this is permitted and probably less confusing for users as well as implementors. 2021-07-17 Sandra Loosemore PR libfortran/101310 libgfortran/ * runtime/ISO_Fortran_binding.c (CFI_section): Fix the base address computation and simplify the code. gcc/testsuite/ * gfortran.dg/ISO_Fortran_binding_1.c (section_c): Remove incorrect assertions. * gfortran.dg/ts29113/library/section-3.f90: Fix indexing bugs. * gfortran.dg/ts29113/library/section-3p.f90: Likewise. * gfortran.dg/ts29113/library/section-4-c.c: New file. * gfortran.dg/ts29113/library/section-4.f90: New file. diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c index 9da5d85..bb56ca0 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c @@ -142,11 +142,12 @@ 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] = lower[0]; idx[0] < section.dim[0].extent + lower[0]; idx[0]++) + for (idx[0] = section.dim[0].lower_bound; + idx[0] < section.dim[0].extent + section.dim[0].lower_bound; + idx[0]++) ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); return ans; } @@ -164,11 +165,12 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str) 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] = lower[0]; idx[0] < section.dim[0].extent + lower[0]; idx[0]++) + for (idx[0] = section.dim[0].lower_bound; + idx[0] < section.dim[0].extent + section.dim[0].lower_bound; + idx[0]++) ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); return ans; } diff --git a/gcc/testsuite/gfortran.dg/ts29113/library/section-3.f90 b/gcc/testsuite/gfortran.dg/ts29113/library/section-3.f90 index 6811891..e51c084 100644 --- a/gcc/testsuite/gfortran.dg/ts29113/library/section-3.f90 +++ b/gcc/testsuite/gfortran.dg/ts29113/library/section-3.f90 @@ -40,12 +40,12 @@ program testit end do end do - call test (aa, 3, 1, 3, 20, 1, 1) ! full slice 0 - call test (aa, 1, 8, 10, 8, 1, 1) ! full slice 1 - call test (aa, 3, 5, 3, 14, 1, 3) ! partial slice 0 - call test (aa, 2, 8, 10, 8, 2, 1) ! partial slice 1 - call test (aa, 3, 14, 3, 5, 1, -3) ! backwards slice 0 - call test (aa, 10, 8, 2, 8, -2, 1) ! backwards slice 1 + call test (aa, 3, 1, 3, 20, 0, 1) ! full slice 0 + call test (aa, 1, 8, 10, 8, 1, 0) ! full slice 1 + call test (aa, 3, 5, 3, 14, 0, 3) ! partial slice 0 + call test (aa, 2, 8, 10, 8, 2, 0) ! partial slice 1 + call test (aa, 3, 14, 3, 5, 0, -3) ! backwards slice 0 + call test (aa, 10, 8, 2, 8, -2, 0) ! backwards slice 1 contains diff --git a/gcc/testsuite/gfortran.dg/ts29113/library/section-3p.f90 b/gcc/testsuite/gfortran.dg/ts29113/library/section-3p.f90 index a6a9c7d..a44e1c8 100644 --- a/gcc/testsuite/gfortran.dg/ts29113/library/section-3p.f90 +++ b/gcc/testsuite/gfortran.dg/ts29113/library/section-3p.f90 @@ -41,28 +41,28 @@ program testit end do ! Zero lower bound - call test (aa, 0, 0, 2, 0, 2, 19, 1, 1) ! full slice 0 - call test (aa, 0, 0, 0, 7, 9, 7, 1, 1) ! full slice 1 - call test (aa, 0, 0, 2, 4, 2, 13, 1, 3) ! partial slice 0 - call test (aa, 0, 0, 1, 7, 9, 7, 2, 1) ! partial slice 1 - call test (aa, 0, 0, 2, 13, 2, 4, 1, -3) ! backwards slice 0 - call test (aa, 0, 0, 9, 7, 1, 7, -2, 1) ! backwards slice 1 + call test (aa, 0, 0, 2, 0, 2, 19, 0, 1) ! full slice 0 + call test (aa, 0, 0, 0, 7, 9, 7, 1, 0) ! full slice 1 + call test (aa, 0, 0, 2, 4, 2, 13, 0, 3) ! partial slice 0 + call test (aa, 0, 0, 1, 7, 9, 7, 2, 0) ! partial slice 1 + call test (aa, 0, 0, 2, 13, 2, 4, 0, -3) ! backwards slice 0 + call test (aa, 0, 0, 9, 7, 1, 7, -2, 0) ! backwards slice 1 ! Lower bound 1 - call test (aa, 1, 1, 3, 1, 3, 20, 1, 1) ! full slice 0 - call test (aa, 1, 1, 1, 8, 10, 8, 1, 1) ! full slice 1 - call test (aa, 1, 1, 3, 5, 3, 14, 1, 3) ! partial slice 0 - call test (aa, 1, 1, 2, 8, 10, 8, 2, 1) ! partial slice 1 - call test (aa, 1, 1, 3, 14, 3, 5, 1, -3) ! backwards slice 0 - call test (aa, 1, 1, 10, 8, 2, 8, -2, 1) ! backwards slice 1 + call test (aa, 1, 1, 3, 1, 3, 20, 0, 1) ! full slice 0 + call test (aa, 1, 1, 1, 8, 10, 8, 1, 0) ! full slice 1 + call test (aa, 1, 1, 3, 5, 3, 14, 0, 3) ! partial slice 0 + call test (aa, 1, 1, 2, 8, 10, 8, 2, 0) ! partial slice 1 + call test (aa, 1, 1, 3, 14, 3, 5, 0, -3) ! backwards slice 0 + call test (aa, 1, 1, 10, 8, 2, 8, -2, 0) ! backwards slice 1 ! Some other lower bound - call test (aa, 2, 3, 4, 3, 4, 22, 1, 1) ! full slice 0 - call test (aa, 2, 3, 2, 10, 11, 10, 1, 1) ! full slice 1 - call test (aa, 2, 3, 4, 7, 4, 16, 1, 3) ! partial slice 0 - call test (aa, 2, 3, 1, 10, 11, 10, 2, 1) ! partial slice 1 - call test (aa, 2, 3, 4, 16, 4, 7, 1, -3) ! backwards slice 0 - call test (aa, 2, 3, 11, 10, 3, 10, -2, 1) ! backwards slice 1 + call test (aa, 2, 3, 4, 3, 4, 22, 0, 1) ! full slice 0 + call test (aa, 2, 3, 2, 10, 11, 10, 1, 0) ! full slice 1 + call test (aa, 2, 3, 4, 7, 4, 16, 0, 3) ! partial slice 0 + call test (aa, 2, 3, 3, 10, 11, 10, 2, 0) ! partial slice 1 + call test (aa, 2, 3, 4, 16, 4, 7, 0, -3) ! backwards slice 0 + call test (aa, 2, 3, 11, 10, 3, 10, -2, 0) ! backwards slice 1 contains @@ -108,16 +108,16 @@ contains if (ubound (rr, 1) .ne. (ub1 - lb1)/s1 + 1) stop 113 o1 = 1 do i1 = lb1, ub1, s1 - if (rr(o1)%x .ne. lb0) stop 114 - if (rr(o1)%y .ne. i1) stop 114 + if (rr(o1)%x .ne. lb0 - lo0 + 1) stop 114 + if (rr(o1)%y .ne. i1 - lo1 + 1) stop 114 o1 = o1 + 1 end do else if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113 o0 = 1 do i0 = lb0, ub0, s0 - if (rr(o0)%x .ne. i0) stop 114 - if (rr(o0)%y .ne. lb1) stop 114 + if (rr(o0)%x .ne. i0 - lo0 + 1) stop 114 + if (rr(o0)%y .ne. lb1 - lo1 + 1) stop 114 o0 = o0 + 1 end do end if diff --git a/gcc/testsuite/gfortran.dg/ts29113/library/section-4-c.c b/gcc/testsuite/gfortran.dg/ts29113/library/section-4-c.c new file mode 100644 index 0000000..7725443 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ts29113/library/section-4-c.c @@ -0,0 +1,101 @@ +#include +#include + +#include "ISO_Fortran_binding.h" +#include "../dump-descriptors.h" + +struct m { + int i, j, k, l; +}; + +extern void ctest (void); + +#define IMAX 6 +#define JMAX 8 +#define KMAX 10 +#define LMAX 12 + +static struct m buffer[LMAX][KMAX][JMAX][IMAX]; + +static void +check_element (struct m *mp, int i, int j, int k, int l) +{ +#if 0 + fprintf (stderr, "expected (%d, %d, %d, %d), got (%d, %d, %d, %d)\n", + i, j, k, l, mp->i, mp->j, mp->k, mp->l); +#endif + if (mp->i != i || mp->j != j || mp->k != k || mp->l != l) + abort (); +} + +void +ctest (void) +{ + CFI_CDESC_T(4) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(4) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + CFI_index_t extents[4] = { IMAX, JMAX, KMAX, LMAX }; + CFI_index_t lb[4], ub[4], s[4]; + int i, j, k, l; + int ii, jj, kk, ll; + + /* Initialize the buffer to uniquely label each element. */ + for (i = 0; i < IMAX; i++) + for (j = 0; j < JMAX; j++) + for (k = 0; k < KMAX; k++) + for (l = 0; l < LMAX; l++) + { + buffer[l][k][j][i].i = i; + buffer[l][k][j][i].j = j; + buffer[l][k][j][i].k = k; + buffer[l][k][j][i].l = l; + } + + /* Establish the source array. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)buffer, + CFI_attribute_pointer, CFI_type_struct, + sizeof (struct m), 4, extents)); + + /* Try taking a degenerate section (single element). */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, + CFI_attribute_pointer, CFI_type_struct, + sizeof (struct m), 0, NULL)); + lb[0] = 3; lb[1] = 4; lb[2] = 5; lb[3] = 6; + ub[0] = 3; ub[1] = 4; ub[2] = 5; ub[3] = 6; + s[0] = 0; s[1] = 0; s[2] = 0; s[3] = 0; + check_CFI_status ("CFI_section", + CFI_section (result, source, lb, ub, s)); + dump_CFI_cdesc_t (result); + check_element ((struct m *)result->base_addr, 3, 4, 5, 6); + + /* Try taking a 2d chunk out of the 4d array. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, + CFI_attribute_pointer, CFI_type_struct, + sizeof (struct m), 2, NULL)); + lb[0] = 1; lb[1] = 2; lb[2] = 3; lb[3] = 4; + ub[0] = 1; ub[1] = JMAX - 2; ub[2] = 3; ub[3] = LMAX - 2; + s[0] = 0; s[1] = 2; s[2] = 0; s[3] = 3; + check_CFI_status ("CFI_section", + CFI_section (result, source, lb, ub, s)); + dump_CFI_cdesc_t (result); + + i = lb[0]; + k = lb[2]; + for (j = lb[1], jj = result->dim[0].lower_bound; + j <= ub[1]; + j += s[1], jj++) + for (l = lb[3], ll = result->dim[1].lower_bound; + l <= ub[3]; + l += s[3], ll++) + { + CFI_index_t subscripts[2]; + subscripts[0] = jj; + subscripts[1] = ll; + check_element ((struct m *) CFI_address (result, subscripts), + i, j, k, l); + } +} diff --git a/gcc/testsuite/gfortran.dg/ts29113/library/section-4.f90 b/gcc/testsuite/gfortran.dg/ts29113/library/section-4.f90 new file mode 100644 index 0000000..ee4b01a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ts29113/library/section-4.f90 @@ -0,0 +1,23 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "section-4-c.c ../dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests various scenarios with using CFI_section to extract +! a section with rank less than the source array. Everything interesting +! happens on the C side. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + use iso_c_binding + end subroutine + + end interface + + call ctest () + +end program diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 38e1b6e..9326195 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -685,29 +685,22 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, } } + /* Set the base address. We have to compute this first in the case + where source == result, before we overwrite the dimension data. */ + result->base_addr = CFI_address (source, lower); + /* Set the appropriate dimension information that gives us access to the * data. */ - int aux = 0; - for (int i = 0; i < source->rank; i++) + for (int i = 0, o = 0; i < source->rank; i++) { if (stride[i] == 0) - { - aux++; - /* Adjust 'lower' for the base address offset. */ - lower[i] = lower[i] - source->dim[i].lower_bound; - continue; - } - int idx = i - aux; - result->dim[idx].lower_bound = lower[i]; - result->dim[idx].extent = 1 + (upper[i] - lower[i])/stride[i]; - result->dim[idx].sm = stride[i] * source->dim[i].sm; - /* Adjust 'lower' for the base address offset. */ - lower[idx] = lower[idx] - source->dim[i].lower_bound; + continue; + result->dim[o].lower_bound = 0; + result->dim[o].extent = 1 + (upper[i] - lower[i])/stride[i]; + result->dim[o].sm = stride[i] * source->dim[i].sm; + o++; } - /* Set the base address. */ - result->base_addr = CFI_address (source, lower); - return CFI_SUCCESS; }