From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 0F2283858400; Sun, 25 Jul 2021 04:11:09 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 0F2283858400 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: +boi8rcBFk6mmoB2mWQK8jpwJbSsy7i/RZH5WHfL8XjtEAbY73MLi2O7SSXtNgk7E2VhArwlte kHhsVyJ/eodGD0nVjKNyC12gjq9hHz/QZmP21ow8omHSJ5Bb9Fb2sidelTfnjAKCdJAB8Kjj+5 o8xIAR4gaKB6bHMX8N/RtOR9rieNNIzpKRtg0wf0yA3F7UpP7G3b9MyeYYhumdtKA/NTI8zkpO KWjejp5IZLH9Re90HMA/NoEgPKDOA09oSsp9CFNeuPA5Ers6h29qjbLBExLjSOTQAIHnlWJ5n4 q2H6fYoJ8eaNUbgvH9VigFvo X-IronPort-AV: E=Sophos;i="5.84,266,1620720000"; d="scan'208";a="64064339" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa4.mentor.iphmx.com with ESMTP; 24 Jul 2021 20:11:08 -0800 IronPort-SDR: QicrmV0X244w+KZ6sf2IEqX/9yOVyny/ExSeUqMX2gYGZ18aFO1S5G1NJ/5lxGI6jrIALEDlK4 CFouXRD82ROGBQSwo8GIfPH/usizYG5bJjnpUuA4uzglExhsxyjD7rVtJJdR/ezjRkwTPw8FHy f49I7/HHPa6pmdwBm8GDWl+aalQcfudBFDcqJy9xZ91mEw8a+Z6OHayW+phl4LllgnCIxOFvUO PUO9YrfA9icvJrueR3AUTkiti8bhShc0r3v+q5Vw9mhhe4I8CfEB+9G7xq4jHEXIky5X+37cT/ Nro= Subject: Re: [PATCH v2, Fortran] [PR libfortran/101317] Bind(c): Improve error checking in CFI_* functions To: Tobias Burnus , "fortran@gcc.gnu.org" , "gcc-patches@gcc.gnu.org" References: <8fc3b97c-b122-9c2c-4657-4f98cf82973e@codesourcery.com> <1fd11074-9c32-37a6-a957-3fe3e329eb9e@codesourcery.com> From: Sandra Loosemore Message-ID: <28519de9-3fca-7c94-1edf-5d920d3fccdf@codesourcery.com> Date: Sat, 24 Jul 2021 22:11:01 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.10.0 MIME-Version: 1.0 In-Reply-To: Content-Type: multipart/mixed; boundary="------------3205E9BF827E5DE2AC3FD4B7" Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-07.mgc.mentorg.com (147.34.90.207) To svr-orw-mbx-03.mgc.mentorg.com (147.34.90.203) X-Spam-Status: No, score=-9.9 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, NICE_REPLY_A, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Sun, 25 Jul 2021 04:11:13 -0000 --------------3205E9BF827E5DE2AC3FD4B7 Content-Type: text/plain; charset="utf-8"; format=flowed Content-Transfer-Encoding: 8bit On 7/22/21 1:54 AM, Tobias Burnus wrote: > Hi Sandra, > > On 21.07.21 20:01, Sandra Loosemore wrote: >> Hmmm. CFI_establish explicitly says that the elem_len has to be >> greater than zero.  It seems somewhat confusing that it's inconsistent >> with the other functions that take an elem_len argument. > > Congratulation – we have found a bug in the spec, which is also > present in the current draft (21-007). I have now written to J3: > https://mailman.j3-fortran.org/pipermail/j3/2021-July/013189.html That discussion seems to have wandered off into some other direction so I'm not sure whether it really clarifies this problem. For the purposes of this patch I have left in the test for elem_len > 0 in CFI_establish where the standard explicitly has that requirement and removed it from the other functions where I'd added it just to be consistent. >>> How about PRIiPTR + ptrdiff_t instead of %d + (int) cast? At least as >>> positive value, extent may exceed INT_MAX. >> Hmmm, there are similar problems in existing code in other functions >> in this file (e.g., CFI_section). > > I think that you could fix as well. At least for size(array), it is not > uncommon that this exceeds MAX_INT. OK, I have done that throughout the file, and also made the wording change you asked for. While I was at it, I went through all the diagnostic messages in the file and simplified the wording of a few other messages as well, fixed typos and inconsistent capitalization and missing punctuation and things like that. As documentation maintainer I can self-approve those changes but of course I'll address complaints from the Fortran experts with what I've done there. Here's a new patch. For this version I've split off the fixes for the new tests in the TS29113 testsuite and merged them back into a new version of the main patch, which I will be posting soon. -Sandra --------------3205E9BF827E5DE2AC3FD4B7 Content-Type: text/x-patch; charset="UTF-8"; name="pr101317-v2.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="pr101317-v2.patch" commit 4940cf8cd97e718e7e9a89784e1f788d51ce64c2 Author: Sandra Loosemore Date: Thu Jul 15 08:48:45 2021 -0700 [PR libfortran/101317] Bind(c): Improve error checking in CFI_* functions This patch adds additional run-time checking for invalid arguments to CFI_establish and CFI_setpointer. It also changes existing messages throughout the CFI_* functions to use PRIiPTR to format CFI_index_t values instead of casting them to int and using %d (which may not work on targets where int is a smaller type), simplifies wording of some messages, and fixes issues with capitalization, typos, and the like. Additionally some coding standards problems such as >80 character lines are addressed. 2021-07-24 Sandra Loosemore PR libfortran/101317 libgfortran/ * runtime/ISO_Fortran_binding.c: Include . (CFI_address): Tidy error messages and comments. (CFI_allocate): Likewise. (CFI_deallocate): Likewise. (CFI_establish): Likewise. Add new checks for validity of elem_len when it's used, plus type argument and extents. (CFI_is_contiguous): Tidy error messages and comments. (CFI_section): Likewise. Refactor some repetitive code to make it more understandable. (CFI_select_part): Likewise. (CFI_setpointer): Likewise. Check that source is not an unallocated allocatable array or an assumed-size array. gcc/testsuite/ * gfortran.dg/ISO_Fortran_binding_17.f90: Fix typo in error message patterns. diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 index bb30931..5902334 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 @@ -71,7 +71,7 @@ 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)" } +! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -1, lower_bound = 0, upper bound = 4, extent = 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, extent = 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, extent = 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, extent = 4(\n|\r\n|\r)" } diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 31dfdc9..bbf3e79 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "libgfortran.h" #include "ISO_Fortran_binding.h" #include +#include /* for PRIiPTR */ extern void cfi_desc_to_gfc_desc (gfc_array_void *, CFI_cdesc_t **); export_proto(cfi_desc_to_gfc_desc); @@ -150,17 +151,17 @@ void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) if (unlikely (compile_options.bounds_check)) { - /* C Descriptor must not be NULL. */ + /* C descriptor must not be NULL. */ if (dv == NULL) { - fprintf (stderr, "CFI_address: C Descriptor is NULL.\n"); + fprintf (stderr, "CFI_address: C descriptor is NULL.\n"); return NULL; } - /* Base address of C Descriptor must not be NULL. */ + /* Base address of C descriptor must not be NULL. */ if (dv->base_addr == NULL) { - fprintf (stderr, "CFI_address: base address of C Descriptor " + fprintf (stderr, "CFI_address: base address of C descriptor " "must not be NULL.\n"); return NULL; } @@ -184,10 +185,12 @@ void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) { 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); + "lower_bound = %" PRIiPTR ", upper bound = %" PRIiPTR + ", extent = %" PRIiPTR "\n", + i, i, (int)subscripts[i], + (ptrdiff_t)dv->dim[i].lower_bound, + (ptrdiff_t)(dv->dim[i].extent - dv->dim[i].lower_bound), + (ptrdiff_t)dv->dim[i].extent); return NULL; } @@ -205,14 +208,14 @@ CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[], { if (unlikely (compile_options.bounds_check)) { - /* C Descriptor must not be NULL. */ + /* C descriptor must not be NULL. */ if (dv == NULL) { - fprintf (stderr, "CFI_allocate: C Descriptor is NULL.\n"); + fprintf (stderr, "CFI_allocate: C descriptor is NULL.\n"); return CFI_INVALID_DESCRIPTOR; } - /* The C Descriptor must be for an allocatable or pointer object. */ + /* The C descriptor must be for an allocatable or pointer object. */ if (dv->attribute == CFI_attribute_other) { fprintf (stderr, "CFI_allocate: The object of the C descriptor " @@ -220,7 +223,7 @@ CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[], return CFI_INVALID_ATTRIBUTE; } - /* Base address of C Descriptor must be NULL. */ + /* Base address of C descriptor must be NULL. */ if (dv->base_addr != NULL) { fprintf (stderr, "CFI_allocate: Base address of C descriptor " @@ -244,8 +247,9 @@ CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[], if (unlikely (compile_options.bounds_check) && (lower_bounds == NULL || upper_bounds == NULL)) { - fprintf (stderr, "CFI_allocate: If 0 < rank (= %d) upper_bounds[] " - "and lower_bounds[], must not be NULL.\n", dv->rank); + fprintf (stderr, "CFI_allocate: The lower_bounds and " + "upper_bounds arguments must be non-NULL when " + "rank is greater than zero.\n"); return CFI_INVALID_EXTENT; } @@ -274,10 +278,10 @@ CFI_deallocate (CFI_cdesc_t *dv) { if (unlikely (compile_options.bounds_check)) { - /* C Descriptor must not be NULL */ + /* C descriptor must not be NULL */ if (dv == NULL) { - fprintf (stderr, "CFI_deallocate: C Descriptor is NULL.\n"); + fprintf (stderr, "CFI_deallocate: C descriptor is NULL.\n"); return CFI_INVALID_DESCRIPTOR; } @@ -288,10 +292,10 @@ CFI_deallocate (CFI_cdesc_t *dv) return CFI_ERROR_BASE_ADDR_NULL; } - /* C Descriptor must be for an allocatable or pointer variable. */ + /* C descriptor must be for an allocatable or pointer variable. */ if (dv->attribute == CFI_attribute_other) { - fprintf (stderr, "CFI_deallocate: C Descriptor must describe a " + fprintf (stderr, "CFI_deallocate: C descriptor must describe a " "pointer or allocatable object.\n"); return CFI_INVALID_ATTRIBUTE; } @@ -326,14 +330,13 @@ int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute, 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) { - fprintf (stderr, "CFI_establish: If base address is not NULL " - "(base_addr != NULL), the established C descriptor is " - "for a nonallocatable entity (attribute != %d).\n", - CFI_attribute_allocatable); + fprintf (stderr, "CFI_establish: If base address is not NULL, " + "the established C descriptor must be " + "for a nonallocatable entity.\n"); return CFI_INVALID_ATTRIBUTE; } } @@ -342,11 +345,26 @@ int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute, if (type == CFI_type_char || type == CFI_type_ucs4_char || type == CFI_type_struct || type == CFI_type_other) - dv->elem_len = elem_len; + { + /* Note that elem_len has type size_t, which is unsigned. */ + if (unlikely (compile_options.bounds_check) && elem_len == 0) + { + fprintf (stderr, "CFI_establish: The supplied elem_len must " + "be greater than zero.\n"); + return CFI_INVALID_ELEM_LEN; + } + dv->elem_len = elem_len; + } else if (type == CFI_type_cptr) dv->elem_len = sizeof (void *); else if (type == CFI_type_cfunptr) dv->elem_len = sizeof (void (*)(void)); + else if (unlikely (compile_options.bounds_check) && type < 0) + { + fprintf (stderr, "CFI_establish: Invalid type (type = %d).\n", + (int)type); + return CFI_INVALID_TYPE; + } else { /* base_type describes the intrinsic type with kind parameter. */ @@ -376,13 +394,24 @@ int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute, if (unlikely (compile_options.bounds_check) && extents == NULL) { fprintf (stderr, "CFI_establish: Extents must not be NULL " - "(extents != NULL) if rank (= %d) > 0 and base address " - "is not NULL (base_addr != NULL).\n", (int)rank); + "if rank is greater than zero and base address is " + "not NULL.\n"); return CFI_INVALID_EXTENT; } for (int i = 0; i < rank; i++) { + /* The standard requires all dimensions to be nonnegative. + Apparently you can have an extent-zero dimension but can't + construct an assumed-size array with -1 as the extent + of the last dimension. */ + if (unlikely (compile_options.bounds_check) && extents[i] < 0) + { + fprintf (stderr, "CFI_establish: Extents must be nonnegative " + "(extents[%d] = %" PRIiPTR ").\n", + i, (ptrdiff_t)extents[i]); + return CFI_INVALID_EXTENT; + } dv->dim[i].lower_bound = 0; dv->dim[i].extent = extents[i]; if (i == 0) @@ -415,16 +444,16 @@ int CFI_is_contiguous (const CFI_cdesc_t *dv) /* Base address must not be NULL. */ if (dv->base_addr == NULL) { - fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor " + fprintf (stderr, "CFI_is_contiguous: Base address of C descriptor " "is already NULL.\n"); return 0; } /* Must be an array. */ - if (dv->rank == 0) + if (dv->rank <= 0) { - fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an " - "array (0 < dv->rank = %d).\n", dv->rank); + fprintf (stderr, "CFI_is_contiguous: C descriptor must describe " + "an array.\n"); return 0; } } @@ -433,8 +462,8 @@ int CFI_is_contiguous (const CFI_cdesc_t *dv) if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1) return 1; - /* If an array is not contiguous the memory stride is different to the element - * length. */ + /* If an array is not contiguous the memory stride is different to + the element length. */ for (int i = 0; i < dv->rank; i++) { if (i == 0 && dv->dim[i].sm == (CFI_index_t)dv->elem_len) @@ -461,14 +490,13 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, CFI_index_t upper[CFI_MAX_RANK]; CFI_index_t stride[CFI_MAX_RANK]; int zero_count = 0; - bool assumed_size; if (unlikely (compile_options.bounds_check)) { - /* C Descriptors must not be NULL. */ + /* C descriptors must not be NULL. */ if (source == NULL) { - fprintf (stderr, "CFI_section: Source must not be NULL.\n"); + fprintf (stderr, "CFI_section: Source must not be NULL.\n"); return CFI_INVALID_DESCRIPTOR; } @@ -498,8 +526,7 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, allocated allocatable array or an associated pointer array). */ if (source->rank <= 0) { - fprintf (stderr, "CFI_section: Source must describe an array " - "(0 < source->rank, 0 !< %d).\n", source->rank); + fprintf (stderr, "CFI_section: Source must describe an array.\n"); return CFI_INVALID_RANK; } @@ -507,9 +534,9 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, if (result->elem_len != source->elem_len) { fprintf (stderr, "CFI_section: The element lengths of " - "source (source->elem_len = %d) and result " - "(result->elem_len = %d) must be equal.\n", - (int)source->elem_len, (int)result->elem_len); + "source (source->elem_len = %" PRIiPTR ") and result " + "(result->elem_len = %" PRIiPTR ") must be equal.\n", + (ptrdiff_t)source->elem_len, (ptrdiff_t)result->elem_len); return CFI_INVALID_ELEM_LEN; } @@ -561,7 +588,7 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, if (unlikely (compile_options.bounds_check) && source->dim[source->rank - 1].extent == -1) { - fprintf (stderr, "CFI_section: Source must not be an assumed size " + fprintf (stderr, "CFI_section: Source must not be an assumed-size " "array if upper_bounds is NULL.\n"); return CFI_INVALID_EXTENT; } @@ -590,64 +617,70 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, if (unlikely (compile_options.bounds_check) && stride[i] == 0 && lower[i] != upper[i]) { - fprintf (stderr, "CFI_section: If strides[%d] = 0, then the " - "lower bounds, lower_bounds[%d] = %d, and " - "upper_bounds[%d] = %d, must be equal.\n", - i, i, (int)lower_bounds[i], i, (int)upper_bounds[i]); + fprintf (stderr, "CFI_section: If strides[%d] = 0, then " + "lower_bounds[%d] = %" PRIiPTR " and " + "upper_bounds[%d] = %" PRIiPTR " must be equal.\n", + i, i, (ptrdiff_t)lower_bounds[i], i, + (ptrdiff_t)upper_bounds[i]); return CFI_ERROR_OUT_OF_BOUNDS; } } } /* Check that section upper and lower bounds are within the array bounds. */ - for (int i = 0; i < source->rank; i++) - { - assumed_size = (i == source->rank - 1) - && (source->dim[i].extent == -1); - if (unlikely (compile_options.bounds_check) - && lower_bounds != NULL - && (lower[i] < source->dim[i].lower_bound || - (!assumed_size && lower[i] > source->dim[i].lower_bound - + source->dim[i].extent - 1))) - { - fprintf (stderr, "CFI_section: Lower bounds must be within the " - "bounds of the fortran array (source->dim[%d].lower_bound " - "<= lower_bounds[%d] <= source->dim[%d].lower_bound " - "+ source->dim[%d].extent - 1, %d <= %d <= %d).\n", - i, i, i, i, (int)source->dim[i].lower_bound, (int)lower[i], - (int)(source->dim[i].lower_bound - + source->dim[i].extent - 1)); - return CFI_ERROR_OUT_OF_BOUNDS; - } - - if (unlikely (compile_options.bounds_check) - && upper_bounds != NULL - && (upper[i] < source->dim[i].lower_bound - || (!assumed_size - && upper[i] > source->dim[i].lower_bound - + source->dim[i].extent - 1))) - { - fprintf (stderr, "CFI_section: Upper bounds must be within the " - "bounds of the fortran array (source->dim[%d].lower_bound " - "<= upper_bounds[%d] <= source->dim[%d].lower_bound + " - "source->dim[%d].extent - 1, %d !<= %d !<= %d).\n", - i, i, i, i, (int)source->dim[i].lower_bound, (int)upper[i], - (int)(source->dim[i].lower_bound - + source->dim[i].extent - 1)); - return CFI_ERROR_OUT_OF_BOUNDS; - } - - if (unlikely (compile_options.bounds_check) - && upper[i] < lower[i] && stride[i] >= 0) - { - fprintf (stderr, "CFI_section: If the upper bound is smaller than " - "the lower bound for a given dimension (upper[%d] < " - "lower[%d], %d < %d), then he stride for said dimension" - "t must be negative (stride[%d] < 0, %d < 0).\n", - i, i, (int)upper[i], (int)lower[i], i, (int)stride[i]); - return CFI_INVALID_STRIDE; - } - } + if (unlikely (compile_options.bounds_check)) + for (int i = 0; i < source->rank; i++) + { + bool assumed_size + = (i == source->rank - 1 && source->dim[i].extent == -1); + CFI_index_t ub + = source->dim[i].lower_bound + source->dim[i].extent - 1; + if (lower_bounds != NULL + && (lower[i] < source->dim[i].lower_bound + || (!assumed_size && lower[i] > ub))) + { + fprintf (stderr, "CFI_section: Lower bounds must be within " + "the bounds of the Fortran array " + "(source->dim[%d].lower_bound " + "<= lower_bounds[%d] <= source->dim[%d].lower_bound " + "+ source->dim[%d].extent - 1, " + "%" PRIiPTR " <= %" PRIiPTR " <= %" PRIiPTR ").\n", + i, i, i, i, + (ptrdiff_t)source->dim[i].lower_bound, + (ptrdiff_t)lower[i], + (ptrdiff_t)ub); + return CFI_ERROR_OUT_OF_BOUNDS; + } + + if (upper_bounds != NULL + && (upper[i] < source->dim[i].lower_bound + || (!assumed_size && upper[i] > ub))) + { + fprintf (stderr, "CFI_section: Upper bounds must be within " + "the bounds of the Fortran array " + "(source->dim[%d].lower_bound " + "<= upper_bounds[%d] <= source->dim[%d].lower_bound " + "+ source->dim[%d].extent - 1, " + "%" PRIiPTR " !<= %" PRIiPTR " !<= %" PRIiPTR ").\n", + i, i, i, i, + (ptrdiff_t)source->dim[i].lower_bound, + (ptrdiff_t)upper[i], + (ptrdiff_t)ub); + return CFI_ERROR_OUT_OF_BOUNDS; + } + + if (upper[i] < lower[i] && stride[i] >= 0) + { + fprintf (stderr, "CFI_section: If the upper bound is smaller than " + "the lower bound for a given dimension (upper[%d] < " + "lower[%d], %" PRIiPTR " < %" PRIiPTR "), then the " + "stride for said dimension must be negative " + "(stride[%d] < 0, %" PRIiPTR " < 0).\n", + i, i, (ptrdiff_t)upper[i], (ptrdiff_t)lower[i], + i, (ptrdiff_t)stride[i]); + return CFI_INVALID_STRIDE; + } + } /* Set the base address. We have to compute this first in the case where source == result, before we overwrite the dimension data. */ @@ -674,7 +707,7 @@ int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source, { if (unlikely (compile_options.bounds_check)) { - /* C Descriptors must not be NULL. */ + /* C descriptors must not be NULL. */ if (source == NULL) { fprintf (stderr, "CFI_select_part: Source must not be NULL.\n"); @@ -737,8 +770,9 @@ int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source, { fprintf (stderr, "CFI_select_part: Displacement must be within the " "bounds of source (0 <= displacement <= source->elem_len " - "- 1, 0 <= %d <= %d).\n", (int)displacement, - (int)(source->elem_len - 1)); + "- 1, 0 <= %" PRIiPTR " <= %" PRIiPTR ").\n", + (ptrdiff_t)displacement, + (ptrdiff_t)(source->elem_len - 1)); return CFI_ERROR_OUT_OF_BOUNDS; } @@ -749,10 +783,12 @@ int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source, fprintf (stderr, "CFI_select_part: Displacement plus the element " "length of result must be less than or equal to the " "element length of source (displacement + result->elem_len " - "<= source->elem_len, %d + %d = %d <= %d).\n", - (int)displacement, (int)result->elem_len, - (int)(displacement + result->elem_len), - (int)source->elem_len); + "<= source->elem_len, " + "%" PRIiPTR " + %" PRIiPTR " = %" PRIiPTR " <= %" PRIiPTR + ").\n", + (ptrdiff_t)displacement, (ptrdiff_t)result->elem_len, + (ptrdiff_t)(displacement + result->elem_len), + (ptrdiff_t)source->elem_len); return CFI_ERROR_OUT_OF_BOUNDS; } } @@ -792,7 +828,7 @@ int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source, } } - /* If source is NULL, the result is a C Descriptor that describes a + /* If source is NULL, the result is a C descriptor that describes a * disassociated pointer. */ if (source == NULL) { @@ -801,40 +837,56 @@ int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source, } else { - /* Check that element lengths, ranks and types of source and result are - * the same. */ + /* Check that the source is valid and that element lengths, ranks + and types of source and result are the same. */ if (unlikely (compile_options.bounds_check)) { + if (source->base_addr == NULL + && source->attribute == CFI_attribute_allocatable) + { + fprintf (stderr, "CFI_setpointer: The source is an " + "allocatable object but is not allocated.\n"); + return CFI_ERROR_BASE_ADDR_NULL; + } + if (source->rank > 0 + && source->dim[source->rank - 1].extent == -1) + { + fprintf (stderr, "CFI_setpointer: The source is an " + "assumed-size array.\n"); + return CFI_INVALID_EXTENT; + } if (result->elem_len != source->elem_len) { fprintf (stderr, "CFI_setpointer: Element lengths of result " - "(result->elem_len = %d) and source (source->elem_len " - "= %d) must be the same.\n", (int)result->elem_len, - (int)source->elem_len); + "(result->elem_len = %" PRIiPTR ") and source " + "(source->elem_len = %" PRIiPTR ") " + " must be the same.\n", + (ptrdiff_t)result->elem_len, + (ptrdiff_t)source->elem_len); return CFI_INVALID_ELEM_LEN; } if (result->rank != source->rank) { - fprintf (stderr, "CFI_setpointer: Ranks of result (result->rank " - "= %d) and source (source->rank = %d) must be the same." - "\n", result->rank, source->rank); + fprintf (stderr, "CFI_setpointer: Ranks of result " + "(result->rank = %d) and source (source->rank = %d) " + "must be the same.\n", result->rank, source->rank); return CFI_INVALID_RANK; } if (result->type != source->type) { - fprintf (stderr, "CFI_setpointer: Types of result (result->type" - "= %d) and source (source->type = %d) must be the same." - "\n", result->type, source->type); + fprintf (stderr, "CFI_setpointer: Types of result " + "(result->type = %d) and source (source->type = %d) " + "must be the same.\n", result->type, source->type); return CFI_INVALID_TYPE; } } - /* If the source is a disassociated pointer, the result must also describe - * a disassociated pointer. */ - if (source->base_addr == NULL && - source->attribute == CFI_attribute_pointer) + /* If the source is a disassociated pointer, the result must also + describe a disassociated pointer. */ + if (source->base_addr == NULL + && source->attribute == CFI_attribute_pointer) result->base_addr = NULL; else result->base_addr = source->base_addr; --------------3205E9BF827E5DE2AC3FD4B7--