From: Tobias Burnus Date: Tue, 12 Nov 2019 19:33:10 +0000 (+0000) Subject: PR fortran/92470 Fixes for CFI_address X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fde7112d79174947596b4697f254f169f0b11811;p=gcc.git 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 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 584ccd7e143..3ee50a6eaec 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2019-11-12 Tobias Burnus + + 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 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 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 #include #include #include @@ -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 +#include +#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/ChangeLog b/libgfortran/ChangeLog index 075c9860c80..1abdd6a4f24 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2019-11-12 Tobias Burnus + + 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. + 2019-11-11 José Rui Faustino de Sousa PR fortran/92142 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; }