From patchwork Tue Nov 12 14:42:23 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1193586 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-513136-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="qvuoWnY4"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 47C9T10LQxz9sPF for ; Wed, 13 Nov 2019 01:42:44 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=CkB5MJZtITXAP9sMKJaGIi5iR6i/tTlVtD3Wy73YfDzXqwaXoj /gvXOu8djceM3byHoJxFgQv32QeBpcltx8pV+WuqO6ltft/l1fWkLT3VLo3oNysQ kYEvE29NaFJWn8GjDJioYPPE23yg6ElcZtp1GWzRHnQeWhATveCOERHcI= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=pJc6VssMrJXDhk2enpEwG9ldOhQ=; b=qvuoWnY4phSk81YcWEga PTpm9A3Loe16GRCkDeOEwQmXnsV5mkB131pPumgJmR9/5um62rmyJZQyynINVror 61jyZaXUK9NgyJKtP2xd/GFpTr+vZI+EAtH3SQhoK+xK3frbZEzOq0ZiTJBWAxLc IE88E9EShEgL9IST7so/L38= Received: (qmail 92908 invoked by alias); 12 Nov 2019 14:42:36 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 92891 invoked by uid 89); 12 Nov 2019 14:42:36 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-21.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, SPF_PASS autolearn=ham version=3.3.1 spammy=quoted, August, august, extent X-HELO: esa2.mentor.iphmx.com Received: from esa2.mentor.iphmx.com (HELO esa2.mentor.iphmx.com) (68.232.141.98) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 12 Nov 2019 14:42:34 +0000 IronPort-SDR: NkrG72r/8wl13tjsTZc5e8ky/By/N49Jgvoc0q2C4tOJ7lbFb+ppUKeD/c9b45ndFpVtMhd6rp F+gmJFf498oFQ94BAeSJY2dVwwNn0WbB66h2heT6tgEybB8y852hsD5HpOlwvC2JndoRrOM7N+ O4fkGfElUFxN0MBvB3aJtIxUArhWEMoSvtZBiuGNPFCp0Rz4bFhaIRakIHVL6/u5xuWObE/wqb edN9FvFj0268Oaa5mdAK+ebPgSqlRe6keEMH54DZAKOwHHkAJMLSQasASAqcO6il4P3j2ERCMV 0+w= Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa2.mentor.iphmx.com with ESMTP; 12 Nov 2019 06:42:29 -0800 IronPort-SDR: tHnW2GzZ7q7JLP6riIw/2G031uAFF6Pofvsnh3zecQseir7hzWJ3/+TtxHblY5AS1iUk5hn9ks DOGQj5bQfVE24LyRR8pr0N0tMTbarLB9b7XCdE+GU0Amr0ZKu4+GnmN+jXPUJTou0y/f6mqlx4 i2Xk+lsUJ/RO0gwSWJlrX6qOBhWglUcCQ1FpTtoPR7wnylUq3hdaIPBgC6VMhQI3d5NCw6h3Gh B8uloBTTn26d2f93hydqrboGVH7nIf4i6GiX8gFG1mvU0g17BXMJftst8vey0uF8hu1930HXkV wvQ= To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] PR fortran/92470 Fixes for CFI_address Message-ID: <7277b261-b0c9-018a-c4f5-c4c9ae0c8362@codesourcery.com> Date: Tue, 12 Nov 2019 15:42:23 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.2.0 MIME-Version: 1.0 X-IsSubscribed: yes 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(
)) == 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 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 #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/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; }