├── .github └── FUNDING.yml ├── .gitignore ├── CMakeLists.txt ├── LICENSE ├── README.md ├── include └── ISO_Fortran_binding.h ├── src ├── CFI_address.c ├── CFI_allocate.c ├── CFI_deallocate.c ├── CFI_establish.c ├── CFI_is_contiguous.c ├── CFI_section.c ├── CFI_select_part.c ├── CFI_setpointer.c └── CMakeLists.txt └── tests ├── CMakeLists.txt ├── test-CFI_address.c ├── test-CFI_deallocate.c ├── test-CFI_establish.c ├── test-CFI_is_contiguous.c ├── test-CFI_section.c ├── test-CFI_select_part.c └── test-CFI_setpointer.c /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | # github: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2] 4 | # patreon: # Replace with a single Patreon username 5 | # open_collective: # Replace with a single Open Collective username 6 | # ko_fi: # Replace with a single Ko-fi username 7 | # tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel 8 | custom: http://www.sourceryinstitute.org/store/p5/Donation.html 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.2) 2 | set(ISO_Fortran_binding_version 1.0.0) 3 | project(ISO_Fortran_binding VERSION "${ISO_Fortran_binding_version}" LANGUAGES C) 4 | 5 | # Set the type/configuration of build to perform 6 | set ( CMAKE_CONFIGURATION_TYPES "Debug" "Release" "MinSizeRel" "RelWithDebInfo" "CodeCoverage" ) 7 | set ( CMAKE_BUILD_TYPE "Release" CACHE STRING "Select which configuration to build." ) 8 | set_property ( CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS ${CMAKE_CONFIGURATION_TYPES} ) 9 | 10 | message( STATUS "Building ISO_Fortran_binding configuration: ${CMAKE_BUILD_TYPE}") 11 | message( STATUS "Running with CMake from: ${CMAKE_COMMAND}" ) 12 | message( STATUS "Current source dir (for ISO_Fortran_binding): ${CMAKE_CURRENT_SOURCE_DIR}") 13 | message( STATUS "Building ISO_Fortran_binding version: ${ISO_Fortran_binding_version}" ) 14 | message( STATUS "Building for target architecture: ${CMAKE_SYSTEM_PROCESSOR}" ) 15 | 16 | #Print an error message on an attempt to build inside the source directory tree: 17 | if ("${CMAKE_CURRENT_SOURCE_DIR}" STREQUAL "${CMAKE_CURRENT_BINARY_DIR}") 18 | message(FATAL_ERROR "ERROR! " 19 | "CMAKE_CURRENT_SOURCE_DIR=${CMAKE_CURRENT_SOURCE_DIR}" 20 | " == CMAKE_CURRENT_BINARY_DIR=${CMAKE_CURRENT_BINARY_DIR}" 21 | "\nThis archive does not support in-source builds:\n" 22 | "You must now delete the CMakeCache.txt file and the CMakeFiles/ directory under " 23 | "the 'src' source directory or you will not be able to configure correctly!" 24 | "\nYou must now run something like:\n" 25 | " $ rm -r CMakeCache.txt CMakeFiles/" 26 | "\n" 27 | "Please create a directory outside the ISO_Fortran_binding source tree and build under that outside directory " 28 | "in a manner such as\n" 29 | " $ mkdir build\n" 30 | " $ cd build\n" 31 | " $ CC=gcc FC=gfortran cmake -DBUILD_TYPE=Release -DCMAKE_INSTALL_PREFIX=/path/to/install/dir /path/to/ISO_Fortran_binding/source/dir \n" 32 | "\nsubstituting the appropriate syntax for your shell (the above line assumes the bash shell)." 33 | ) 34 | endif() 35 | 36 | #Report untested Fortran compiler unless explicitly directed to build all examples. 37 | if ("${CMAKE_C_COMPILER_ID}" MATCHES "GNU" ) 38 | set ( CMAKE_C_FLAGS_CODECOVERAGE "-fprofile-arcs -ftest-coverage -O0" 39 | CACHE STRING "Code coverage C compiler flags") 40 | else() 41 | message(WARNING 42 | "\n" 43 | "Attempting to build with untested C compiler: ${CMAKE_C_COMPILER_ID}. This project uses" 44 | "variable-length arrays, a GCC extension that might not be supported by ${CMAKE_C_COMPILER_ID}." 45 | "Please report any issues at https://github.com/sourceryinstitute/ISO_Fortran_binding/issue\n\n" 46 | ) 47 | endif() 48 | 49 | #--------------------------------------- 50 | # Make sure a minimal C program compiles 51 | #--------------------------------------- 52 | include (CheckCSourceCompiles) 53 | CHECK_C_SOURCE_COMPILES(" 54 | int main(int argc, char** argv) { 55 | return 0; 56 | }" 57 | C_SOURCE_COMPILES) 58 | 59 | if (NOT C_SOURCE_COMPILES) 60 | message(FATAL_ERROR "C compiler doesn't compile a minimal C program." 61 | "Try setting CC to the appropriate C compiler and reconfigure. " 62 | "i.e., `cmake -DCMAKE_C_COMPILER=/path/to/cc ..` or set it by editing the cache using " 63 | "cmake-gui or ccmake." 64 | ) 65 | endif() 66 | 67 | include_directories(include) 68 | add_subdirectory(src) 69 | add_subdirectory(tests) 70 | 71 | install(DIRECTORY include DESTINATION ${CMAKE_INSTALL_PREFIX}) 72 | 73 | add_custom_target(check COMMAND ${CMAKE_CTEST_COMMAND} --output-on-failure) 74 | 75 | enable_testing() 76 | 77 | set( unit_tests 78 | CFI_address 79 | CFI_deallocate 80 | CFI_establish 81 | CFI_is_contiguous 82 | CFI_section 83 | CFI_select_part 84 | CFI_setpointer 85 | ) 86 | foreach(unit_test ${unit_tests}) 87 | add_test("${unit_test}-test" tests/test-${unit_test}) 88 | endforeach() 89 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2018, Sourcery Institute 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | [This document is formatted with GitHub-Flavored Markdown. ]:# 4 | [For better viewing, including hyperlinks, read it online at ]:# 5 | [https://github.com/sourceryinstitute/OpenCoarrays/blob/master/README.md]:# 6 |
7 | 8 | [![Sourcery Institute][sourcery-institute logo]][Sourcery Institute] 9 | 10 | 11 | ISO_Fortran_binding 12 | =================== 13 | 14 | [About](#about-this-library) | [Installing](#build-test-and-install) | [Contributing](#contributing) | [Known Issues](#known-issues) 15 | 16 |
17 | 18 | About this library 19 | ------------------ 20 | ISO_Fortran_binding supports C/Fortran interoperability by providing the [Fortran 2018] `ISO_Fortran_binding.h` C header file, corresponding function definitions, and CMake scripts for building, testing, and installing static and dynamic libraries. C programs may use the provided function to manipulate interoperable Fortran data objects by exploiting metadata describing the type, rank, extents, contiguity, and other information about the object. 21 | 22 | * `CFI_allocate`, `CFI_deallocate`. Allocate or deallocate Fortran allocatable variables. 🐏 23 | * `CFI_establish`. Establish the metadata necessary to access Fortran variables inside a C descriptor `struct`. 24 | * `CFI_address`. If a C descriptor describes a scalar variable, find its address. If it describes an array, find the address of the element with column-major (Fortran ordering) indexing. :house: 25 | * `CFI_is_contiguous`. Determine whether a Fortran array is contiguous. 26 | * `CFI_select_part`. Update a C descriptor to select an element or contiguous elements of a Fortran derived type. The variable whose part is selected could be an array section of derived type. 🚣‍ 27 | * `CFI_section`. Update a C descriptor to select a section of an array. The array can be of interoperable derived types. The array can also be composed of elements of a derived type, i.e., a C descriptor updated by `CFI_select_part`. The array can also be a section. 28 | * `CFI_setpointer`: Update a C descriptor to point at a Fortran variable. 🏹 29 | 30 | [Fortran 2018]: https://j3-fortran.org/doc/year/18/18-007r1.pdf 31 | 32 | 33 | Build, test, and install 34 | ------------------------ 35 | ``` 36 | cd ISO_Fortran_binding 37 | mkdir build 38 | cd build 39 | cmake .. -DCMAKE_INSTALL_PREFIX= 40 | make 41 | ctest 42 | make install 43 | ``` 44 | 45 | Contributing 46 | ------------ 47 | * Please submit questions, suggestions, or bug reports via our Issues page. 48 | * Prior to submitting code via pull requests after 49 | 1. Signing our [Contributor License Agreemnt]. 50 | 2. Reviewing the [GitHub Flow] workflow. 51 | 52 | Known issues 53 | ------------ 54 | This repository uses GNU C language extensions that are not supported by the clang compiler. 55 | 56 | 57 | [About]: #about-this-library 58 | [Installing]: #build-test-and-install 59 | [Contributing]: #contributing 60 | [Known Issues]: #known-issues 61 | [Contributor License Agreemnt]: https://cla-assistant.io/sourceryinstitute/ISO_Fortran_binding 62 | [GitHub Flow]: https://guides.github.com/introduction/flow/ 63 | 64 | [sourcery-institute logo]: http://www.sourceryinstitute.org/uploads/4/9/9/6/49967347/sourcery-logo-rgb-hi-rez-1.png 65 | [Sourcery Institute]: http://www.sourceryinstitute.org 66 | 67 | -------------------------------------------------------------------------------- /include/ISO_Fortran_binding.h: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with C. 4 | Copyright (c) 2018, Sourcery, Inc. 5 | Copyright (c) 2018, Sourcery Institute 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 12 | 3. Neither the names of the copyright holders nor the names of their contributors may be used to endorse or promote products derived from this software without specific prior written permission. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 15 | */ 16 | 17 | #ifndef ISO_FORTRAN_BINDING_H 18 | #define ISO_FORTRAN_BINDING_H 19 | 20 | #ifdef __cplusplus 21 | extern "C" { 22 | #endif 23 | 24 | #include /* Standard ptrdiff_t tand size_t. */ 25 | #include /* Integer types. */ 26 | 27 | /* Constants, defined as macros. */ 28 | #define CFI_VERSION 1 29 | #define CFI_MAX_RANK 15 30 | 31 | /* Attributes. */ 32 | #define CFI_attribute_pointer 0 33 | #define CFI_attribute_allocatable 1 34 | #define CFI_attribute_other 2 35 | 36 | /* Error codes. 37 | CFI_INVALID_STRIDE should be defined in the standard because they are useful to the implementation of the functions. 38 | */ 39 | #define CFI_SUCCESS 0 40 | #define CFI_FAILURE 1 41 | #define CFI_ERROR_BASE_ADDR_NULL 2 42 | #define CFI_ERROR_BASE_ADDR_NOT_NULL 3 43 | #define CFI_INVALID_ELEM_LEN 4 44 | #define CFI_INVALID_RANK 5 45 | #define CFI_INVALID_TYPE 6 46 | #define CFI_INVALID_ATTRIBUTE 7 47 | #define CFI_INVALID_EXTENT 8 48 | #define CFI_INVALID_STRIDE 9 49 | #define CFI_INVALID_DESCRIPTOR 10 50 | #define CFI_ERROR_MEM_ALLOCATION 11 51 | #define CFI_ERROR_OUT_OF_BOUNDS 12 52 | 53 | /* CFI type definitions. */ 54 | typedef ptrdiff_t CFI_index_t; 55 | typedef int8_t CFI_rank_t; 56 | typedef int8_t CFI_attribute_t; 57 | typedef int16_t CFI_type_t; 58 | 59 | /* CFI_dim_t. */ 60 | typedef struct CFI_dim_t 61 | { 62 | CFI_index_t lower_bound; 63 | CFI_index_t extent; 64 | CFI_index_t sm; 65 | } 66 | CFI_dim_t; 67 | 68 | /* CFI_cdesc_t, C descriptors are cast to this structure as follows: 69 | CFI_CDESC_T(CFI_MAX_RANK) foo; 70 | CFI_cdesc_t * bar = (CFI_cdesc_t *) &foo; 71 | */ 72 | typedef struct CFI_cdesc_t 73 | { 74 | void *base_addr; 75 | size_t elem_len; 76 | int version; 77 | CFI_rank_t rank; 78 | CFI_attribute_t attribute; 79 | CFI_type_t type; 80 | CFI_dim_t dim[]; 81 | } 82 | CFI_cdesc_t; 83 | 84 | /* CFI_CDESC_T with an explicit type. */ 85 | #define CFI_CDESC_TYPE_T(r, base_type) \ 86 | struct { \ 87 | base_type *base_addr; \ 88 | size_t elem_len; \ 89 | int version; \ 90 | CFI_rank_t rank; \ 91 | CFI_attribute_t attribute; \ 92 | CFI_type_t type; \ 93 | CFI_dim_t dim[r]; \ 94 | } 95 | #define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void) 96 | 97 | /* CFI function declarations. */ 98 | void *CFI_address (const CFI_cdesc_t *, const CFI_index_t []); 99 | int CFI_allocate (CFI_cdesc_t *, const CFI_index_t [], const CFI_index_t [], 100 | size_t); 101 | int CFI_deallocate (CFI_cdesc_t *); 102 | int CFI_establish (CFI_cdesc_t *, void *, CFI_attribute_t, CFI_type_t, size_t, 103 | CFI_rank_t, const CFI_index_t []); 104 | int CFI_is_contiguous (const CFI_cdesc_t *); 105 | int CFI_section (CFI_cdesc_t *, const CFI_cdesc_t *, const CFI_index_t [], 106 | const CFI_index_t [], const CFI_index_t []); 107 | int CFI_select_part (CFI_cdesc_t *, const CFI_cdesc_t *, size_t, size_t); 108 | int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []); 109 | 110 | /* Types and kind numbers. Allows bitwise and to reveal the intrinsic type of a kind type. It also allows us to find the kind parameter by inverting the bit-shift equation. 111 | CFI_type_kind_shift = 8 112 | CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0 113 | CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0 114 | CFI_type_example = CFI_intrinsic_type + (CFI_type_kind << CFI_type_kind_shift) 115 | 116 | Defining the CFI_type_example. 117 | CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0 << CFI_type_kind_shift 118 | ------------------------- 119 | 1 0 0 0 0 0 0 0 0 0 0 0 + 120 | CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0 121 | ------------------------- 122 | CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 123 | 124 | Finding the intrinsic type with the logical mask. 125 | CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 & 126 | CFI_type_mask = 0 0 0 0 1 1 1 1 1 1 1 1 127 | ------------------------- 128 | CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0 129 | 130 | Using the intrinsic type and kind shift to find the kind value of the type. 131 | CFI_type_kind = (CFI_type_example - CFI_intrinsic_type) >> CFI_type_kind_shift 132 | CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 - 133 | CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0 134 | ------------------------- 135 | 1 0 0 0 0 0 0 0 0 0 0 0 >> CFI_type_kind_shift 136 | ------------------------- 137 | CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0 138 | */ 139 | #define CFI_type_mask 0xFF 140 | #define CFI_type_kind_shift 8 141 | 142 | /* Intrinsic types. Their kind number defines their storage size. */ 143 | #define CFI_type_Integer 1 144 | #define CFI_type_Logical 2 145 | #define CFI_type_Real 3 146 | #define CFI_type_Complex 4 147 | #define CFI_type_Character 5 148 | 149 | /* Types with no kind. */ 150 | #define CFI_type_struct 6 151 | #define CFI_type_cptr 7 152 | #define CFI_type_cfunptr 8 153 | #define CFI_type_other -1 154 | 155 | /* Types with kind parameter. 156 | The kind parameter represents the type's byte size. The exception is kind = 10, which has byte size of 64 but 80 bit precision. Complex variables are double the byte size of their real counterparts. The ucs4_char matches wchar_t if sizeof (wchar_t) == 4. 157 | */ 158 | #define CFI_type_char (CFI_type_Character + (1 << CFI_type_kind_shift)) 159 | #define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift)) 160 | 161 | /* C-Fortran Interoperability types. */ 162 | #define CFI_type_signed_char (CFI_type_Integer + (1 << CFI_type_kind_shift)) 163 | #define CFI_type_short (CFI_type_Integer + (2 << CFI_type_kind_shift)) 164 | #define CFI_type_int (CFI_type_Integer + (4 << CFI_type_kind_shift)) 165 | #define CFI_type_long (CFI_type_Integer + (8 << CFI_type_kind_shift)) 166 | #define CFI_type_long_long (CFI_type_Integer + (8 << CFI_type_kind_shift)) 167 | #define CFI_type_size_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 168 | #define CFI_type_int8_t (CFI_type_Integer + (1 << CFI_type_kind_shift)) 169 | #define CFI_type_int16_t (CFI_type_Integer + (2 << CFI_type_kind_shift)) 170 | #define CFI_type_int32_t (CFI_type_Integer + (4 << CFI_type_kind_shift)) 171 | #define CFI_type_int64_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 172 | #define CFI_type_int_least8_t (CFI_type_Integer + (1 << CFI_type_kind_shift)) 173 | #define CFI_type_int_least16_t (CFI_type_Integer + (2 << CFI_type_kind_shift)) 174 | #define CFI_type_int_least32_t (CFI_type_Integer + (4 << CFI_type_kind_shift)) 175 | #define CFI_type_int_least64_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 176 | #define CFI_type_int_fast8_t (CFI_type_Integer + (1 << CFI_type_kind_shift)) 177 | #define CFI_type_int_fast16_t (CFI_type_Integer + (2 << CFI_type_kind_shift)) 178 | #define CFI_type_int_fast32_t (CFI_type_Integer + (4 << CFI_type_kind_shift)) 179 | #define CFI_type_int_fast64_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 180 | #define CFI_type_intmax_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 181 | #define CFI_type_intptr_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 182 | #define CFI_type_ptrdiff_t (CFI_type_Integer + (8 << CFI_type_kind_shift)) 183 | #define CFI_type_int128_t (CFI_type_Integer + (16 << CFI_type_kind_shift)) 184 | #define CFI_type_int_least128_t (CFI_type_Integer + (16 << CFI_type_kind_shift)) 185 | #define CFI_type_int_fast128_t (CFI_type_Integer + (16 << CFI_type_kind_shift)) 186 | #define CFI_type_Bool (CFI_type_Logical + (1 << CFI_type_kind_shift)) 187 | #define CFI_type_float (CFI_type_Real + (4 << CFI_type_kind_shift)) 188 | #define CFI_type_double (CFI_type_Real + (8 << CFI_type_kind_shift)) 189 | #define CFI_type_long_double (CFI_type_Real + (10 << CFI_type_kind_shift)) 190 | #define CFI_type_float128 (CFI_type_Real + (16 << CFI_type_kind_shift)) 191 | #define CFI_type_float_Complex (CFI_type_Complex + (4 << CFI_type_kind_shift)) 192 | #define CFI_type_double_Complex (CFI_type_Complex + (8 << CFI_type_kind_shift)) 193 | #define CFI_type_long_double_Complex (CFI_type_Complex + (10 << CFI_type_kind_shift)) 194 | #define CFI_type_float128_Complex (CFI_type_Complex + (16 << CFI_type_kind_shift)) 195 | 196 | #ifdef __cplusplus 197 | } 198 | #endif 199 | 200 | #endif /* ISO_FORTRAN_BINDING_H */ 201 | -------------------------------------------------------------------------------- /src/CFI_address.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) 39 | { 40 | /* C Descriptor must not be NULL. */ 41 | if (dv == NULL) 42 | { 43 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: C Descriptor is " 44 | "NULL. (Error No. %d).\n", 45 | CFI_INVALID_DESCRIPTOR); 46 | return NULL; 47 | } 48 | 49 | /* Base address of C Descriptor must not be NULL. */ 50 | if (dv->base_addr == NULL) 51 | { 52 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: base address of C " 53 | "Descriptor must not be NULL. (Error No. %d).\n", 54 | CFI_ERROR_BASE_ADDR_NULL); 55 | return NULL; 56 | } 57 | 58 | /* Return base address if C descriptor is a scalar. */ 59 | if (dv->rank == 0) 60 | { 61 | return dv->base_addr; 62 | } 63 | /* Calculate the appropriate base address if dv is not a scalar. */ 64 | else 65 | { 66 | /* Base address is the C address of the element of the object specified by 67 | * subscripts. */ 68 | void *base_addr; 69 | 70 | /* In order to properly account for Fortran's column major order we need 71 | * to transpose the subscripts, since columns are stored contiguously as 72 | * opposed to rows like C. */ 73 | CFI_index_t *tr_subscripts; 74 | CFI_dim_t * tr_dim; 75 | tr_subscripts = malloc (dv->rank * sizeof (CFI_index_t)); 76 | tr_dim = malloc (dv->rank * sizeof (CFI_dim_t)); 77 | for (int i = 0; i < dv->rank; i++) 78 | { 79 | CFI_index_t idx = dv->rank - i - 1; 80 | tr_subscripts[i] = subscripts[idx]; 81 | tr_dim[i] = dv->dim[idx]; 82 | /* Normalise the subscripts to start counting the address from 0. */ 83 | tr_subscripts[i] -= tr_dim[i].lower_bound; 84 | } 85 | 86 | /* We assume column major order as that is how Fortran stores arrays. We 87 | * calculate the memory address of the specified element via the canonical 88 | * array dimension reduction map and multiplying by the memory stride. */ 89 | CFI_index_t index = tr_subscripts[0] * tr_dim[0].sm; 90 | /* Check that the first subscript is within the bounds of the Fortran 91 | * array. */ 92 | if (subscripts[0] < dv->dim[0].lower_bound || 93 | subscripts[0] > dv->dim[0].lower_bound + dv->dim[0].extent - 1) 94 | { 95 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: subscripts[0], " 96 | "is out of bounds. dim->[0].lower_bound <= " 97 | "subscripts[0] <= dv->dim[0].lower_bound + " 98 | "dv->dim[0].extent - 1 (%ld <= %ld <= %ld). (Error " 99 | "No. %d).\n", 100 | dv->dim[0].lower_bound, subscripts[0], 101 | dv->dim[0].lower_bound + dv->dim[0].extent - 1, 102 | CFI_ERROR_OUT_OF_BOUNDS); 103 | return NULL; 104 | } 105 | 106 | /* Start calculating the memory offset. We use the transposed subscripts 107 | * because we assume the array is coming from Fortran and the address is 108 | * being queried in column-major order. */ 109 | CFI_index_t tmp_index = 1; 110 | for (int i = 1; i < dv->rank; i++) 111 | { 112 | /* Check that the subsequent subscripts are within the bounds of the 113 | * Fortran array. */ 114 | if (subscripts[i] < dv->dim[i].lower_bound || 115 | subscripts[i] > dv->dim[i].lower_bound + dv->dim[i].extent - 1) 116 | { 117 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: " 118 | "subscripts[%d], is out of bounds. " 119 | "dv->dim[%d].lower_bound <= subscripts[%d] <= " 120 | "dv->dim[%d].lower_bound + dv->dim[%d].extent - " 121 | "1 (%ld <= %ld <= %ld). (Error No. %d).\n", 122 | i, i, i, i, i, dv->dim[i].lower_bound, subscripts[i], 123 | dv->dim[i].extent + dv->dim[i].lower_bound - 1, 124 | CFI_ERROR_OUT_OF_BOUNDS); 125 | return NULL; 126 | } 127 | 128 | /* Use the canonical dimension reduction mapping to find the memory 129 | * address of the relevant subscripts. It is assumed the arrays are 130 | * stored in column-major order like in Fortran, and the provided 131 | * subscripts are given as if we were operating on a Fortran array. */ 132 | tmp_index *= 133 | tr_subscripts[i] * tr_dim[i - 1].extent * tr_dim[i - 1].sm; 134 | index += tmp_index; 135 | } 136 | free (tr_subscripts); 137 | free (tr_dim); 138 | 139 | /* There's no way in C to do general arithmetic on a void pointer so we 140 | * cast to a char pointer, do the arithmetic and cast back to a 141 | * void pointer. */ 142 | base_addr = (char *) dv->base_addr + index; 143 | 144 | return base_addr; 145 | } 146 | } 147 | -------------------------------------------------------------------------------- /src/CFI_allocate.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[], 39 | const CFI_index_t upper_bounds[], size_t elem_len) 40 | { 41 | /* C Descriptor must not be NULL. */ 42 | if (dv == NULL) 43 | { 44 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_allocate: C Descriptor is " 45 | "NULL. (Error No. %d).\n", 46 | CFI_INVALID_DESCRIPTOR); 47 | return CFI_INVALID_DESCRIPTOR; 48 | } 49 | 50 | /* Base address of C Descriptor must be NULL. */ 51 | if (dv->base_addr != NULL) 52 | { 53 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_allocate: Base address of C " 54 | "Descriptor must be NULL. (Error No. %d).\n", 55 | CFI_ERROR_BASE_ADDR_NOT_NULL); 56 | return CFI_ERROR_BASE_ADDR_NOT_NULL; 57 | } 58 | 59 | /* The C Descriptor must be for an allocatable or pointer object. */ 60 | if (dv->attribute == CFI_attribute_other) 61 | { 62 | fprintf (stderr, 63 | "ISO_Fortran_binding.c: CFI_allocate: The object of the C " 64 | "Descriptor must be a pointer or allocatable variable. " 65 | "(Error No. %d).\n", 66 | CFI_INVALID_ATTRIBUTE); 67 | return CFI_INVALID_ATTRIBUTE; 68 | } 69 | 70 | /* If the type is a character, the descriptor's element length is replaced 71 | * by the elem_len argument. */ 72 | if (dv->type == CFI_type_char || dv->type == CFI_type_ucs4_char || 73 | dv->type == CFI_type_signed_char) 74 | { 75 | dv->elem_len = elem_len; 76 | } 77 | 78 | /* Dimension information and calculating the array length. */ 79 | size_t arr_len = 1; 80 | /* If rank is greater than 0, lower_bounds and upper_bounds are used. They're 81 | * ignored otherwhise. */ 82 | if (dv->rank > 0) 83 | { 84 | if (lower_bounds == NULL || upper_bounds == NULL) 85 | { 86 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_allocate: If 0 < rank " 87 | "(= %d) upper_bounds[] and lower_bounds[], must not " 88 | "be NULL. (Error No. %d).\n", 89 | dv->rank, CFI_INVALID_EXTENT); 90 | return CFI_INVALID_EXTENT; 91 | } 92 | for (int i = 0; i < dv->rank; i++) 93 | { 94 | dv->dim[i].lower_bound = lower_bounds[i]; 95 | dv->dim[i].extent = upper_bounds[i] - dv->dim[i].lower_bound + 1; 96 | dv->dim[i].sm = dv->elem_len; 97 | arr_len *= dv->dim[i].extent; 98 | } 99 | } 100 | 101 | dv->base_addr = calloc (arr_len, dv->elem_len); 102 | if (dv->base_addr == NULL) 103 | { 104 | printf ("ISO_Fortran_binding.c: CFI_allocate: Failure in memory " 105 | "allocation. (Error no. %d).\n", 106 | CFI_ERROR_MEM_ALLOCATION); 107 | return CFI_ERROR_MEM_ALLOCATION; 108 | } 109 | 110 | return CFI_SUCCESS; 111 | } 112 | -------------------------------------------------------------------------------- /src/CFI_deallocate.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_deallocate (CFI_cdesc_t *dv) 39 | { 40 | /* C Descriptor must not be NULL */ 41 | if (dv == NULL) 42 | { 43 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_deallocate: C Descriptor. " 44 | "is NULL. (Error No. %d).\n", 45 | CFI_INVALID_DESCRIPTOR); 46 | return CFI_INVALID_DESCRIPTOR; 47 | } 48 | 49 | /* Base address must not be NULL. */ 50 | if (dv->base_addr == NULL) 51 | { 52 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_deallocate: Base address is " 53 | "NULL already. (Error No. %d).\n", 54 | CFI_ERROR_BASE_ADDR_NULL); 55 | return CFI_ERROR_BASE_ADDR_NULL; 56 | } 57 | 58 | /* C Descriptor must be for an allocatable or pointer variable. */ 59 | if (dv->attribute == CFI_attribute_other) 60 | { 61 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_deallocate: C Descriptor " 62 | "must describe a pointer or allocatabale object. (Error " 63 | "No. %d).\n", 64 | CFI_INVALID_ATTRIBUTE); 65 | return CFI_INVALID_ATTRIBUTE; 66 | } 67 | 68 | /* Free and nullify memory. */ 69 | free (dv->base_addr); 70 | dv->base_addr = NULL; 71 | 72 | return CFI_SUCCESS; 73 | } 74 | -------------------------------------------------------------------------------- /src/CFI_establish.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute, 39 | CFI_type_t type, size_t elem_len, CFI_rank_t rank, 40 | const CFI_index_t extents[]) 41 | { 42 | /* C descriptor must not be NULL. */ 43 | if (dv == NULL) 44 | { 45 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: C descriptor is " 46 | "NULL. (Error No. %d).\n", 47 | CFI_INVALID_DESCRIPTOR); 48 | return CFI_INVALID_DESCRIPTOR; 49 | } 50 | 51 | /* Rank must be between 0 and CFI_MAX_RANK. */ 52 | if (rank < 0 || rank > CFI_MAX_RANK) 53 | { 54 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: Rank must be " 55 | "between 0 and %d, 0 < rank (0 !< %d). (Error No. " 56 | "%d).\n", 57 | CFI_MAX_RANK, rank, CFI_INVALID_RANK); 58 | return CFI_INVALID_RANK; 59 | } 60 | 61 | /* C Descriptor must not be an allocated allocatable. */ 62 | if (dv->attribute == CFI_attribute_allocatable && dv->base_addr != NULL) 63 | { 64 | fprintf (stderr, 65 | "ISO_Fortran_binding.c: CFI_establish: If the C Descriptor " 66 | "represents an allocatable variable (dv->attribute = %d), its " 67 | "base address must be NULL (dv->base_addr = NULL). (Error No. " 68 | "%d).\n", 69 | CFI_attribute_allocatable, CFI_INVALID_DESCRIPTOR); 70 | return CFI_INVALID_DESCRIPTOR; 71 | } 72 | 73 | /* If base address is not NULL, the established C Descriptor is for a 74 | * nonallocatable entity. */ 75 | if (attribute == CFI_attribute_allocatable && base_addr != NULL) 76 | { 77 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: If base address " 78 | "is not NULL (base_addr != NULL), the established C " 79 | "Descriptor is for a nonallocatable entity (attribute " 80 | "!= %d). (Error No. %d).\n", 81 | CFI_attribute_allocatable, CFI_INVALID_ATTRIBUTE); 82 | return CFI_INVALID_ATTRIBUTE; 83 | } 84 | 85 | dv->base_addr = base_addr; 86 | 87 | /* elem_len is only used if the item is not a type with a kind parameter. */ 88 | if (type == CFI_type_char || type == CFI_type_ucs4_char || 89 | type == CFI_type_signed_char || type == CFI_type_struct || 90 | type == CFI_type_other) 91 | { 92 | dv->elem_len = elem_len; 93 | } 94 | else 95 | { 96 | /* base_type describes the intrinsic type with kind parameter. */ 97 | size_t base_type = type & CFI_type_mask; 98 | /* base_type_size is the size in bytes of the variable as given by its 99 | * kind parameter. */ 100 | size_t base_type_size = (type - base_type) >> CFI_type_kind_shift; 101 | /* Kind types 10 have a size of 64 bytes. */ 102 | if (base_type_size == 10) 103 | { 104 | base_type_size = 64; 105 | } 106 | /* Complex numbers are twice the size of their real counterparts. */ 107 | if (base_type == CFI_type_Complex) 108 | { 109 | base_type_size *= 2; 110 | } 111 | dv->elem_len = base_type_size; 112 | } 113 | 114 | dv->version = CFI_VERSION; 115 | dv->rank = rank; 116 | dv->attribute = attribute; 117 | dv->type = type; 118 | 119 | /* Extents must not be NULL if rank is greater than zero and base_addr is not 120 | * NULL */ 121 | if (rank > 0 && base_addr != NULL) 122 | { 123 | if (extents == NULL) 124 | { 125 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: Extents must " 126 | "not be NULL (extents != NULL) if rank (= %d) > 0 " 127 | "and base address is not NULL (base_addr != NULL). " 128 | "(Error No. %d).\n", 129 | rank, CFI_INVALID_EXTENT); 130 | return CFI_INVALID_EXTENT; 131 | } 132 | for (int i = 0; i < rank; i++) 133 | { 134 | /* If the C Descriptor is for a pointer then the lower bounds of every 135 | * dimension are set to zero. */ 136 | if (attribute == CFI_attribute_pointer) 137 | { 138 | dv->dim[i].lower_bound = 0; 139 | } 140 | else 141 | { 142 | dv->dim[i].lower_bound = 1; 143 | } 144 | dv->dim[i].extent = extents[i]; 145 | dv->dim[i].sm = dv->elem_len; 146 | } 147 | } 148 | 149 | return CFI_SUCCESS; 150 | } 151 | -------------------------------------------------------------------------------- /src/CFI_is_contiguous.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_is_contiguous (const CFI_cdesc_t *dv) 39 | { 40 | /* C descriptor must not be NULL. */ 41 | if (dv == NULL) 42 | { 43 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_is_contiguous: C descriptor " 44 | "is NULL. (Error No. %d).\n", 45 | CFI_INVALID_DESCRIPTOR); 46 | return CFI_INVALID_DESCRIPTOR; 47 | } 48 | 49 | /* Base address must not be NULL. */ 50 | if (dv->base_addr == NULL) 51 | { 52 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_is_contiguous: Base address " 53 | "of C Descriptor is already NULL. (Error No. %d).\n", 54 | CFI_ERROR_BASE_ADDR_NULL); 55 | return CFI_ERROR_BASE_ADDR_NULL; 56 | } 57 | 58 | /* Must be an array. */ 59 | if (dv->rank == 0) 60 | { 61 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_is_contiguous: C Descriptor " 62 | "must describe an array (0 < dv->rank = %d). (Error No. " 63 | "%d).\n", 64 | dv->rank, CFI_INVALID_RANK); 65 | return CFI_INVALID_RANK; 66 | } 67 | 68 | /* If an array is not contiguous the memory stride is different to the element 69 | * length. */ 70 | for (int i = 0; i < dv->rank; i++) 71 | { 72 | if (dv->dim[i].sm != dv->elem_len) 73 | return CFI_FAILURE; 74 | } 75 | 76 | /* Allocatable arrays are always contiguous. */ 77 | if (dv->attribute == CFI_attribute_allocatable) 78 | { 79 | return CFI_SUCCESS; 80 | } 81 | else 82 | { 83 | return CFI_FAILURE; 84 | } 85 | } 86 | -------------------------------------------------------------------------------- /src/CFI_section.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, 39 | const CFI_index_t lower_bounds[], 40 | const CFI_index_t upper_bounds[], const CFI_index_t strides[]) 41 | { 42 | /* C Descriptors must not be NULL. */ 43 | if (source == NULL) 44 | { 45 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Source must not be " 46 | "NULL. (Error No. %d).\n", 47 | CFI_INVALID_DESCRIPTOR); 48 | return CFI_INVALID_DESCRIPTOR; 49 | } 50 | if (result == NULL) 51 | { 52 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Result must not be " 53 | "NULL. (Error No. %d).\n", 54 | CFI_INVALID_DESCRIPTOR); 55 | return CFI_INVALID_DESCRIPTOR; 56 | } 57 | 58 | /* Base address of source must not be NULL. */ 59 | if (source->base_addr == NULL) 60 | { 61 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Base address of " 62 | "source must not be NULL. (Error No. %d).\n", 63 | CFI_ERROR_BASE_ADDR_NULL); 64 | return CFI_ERROR_BASE_ADDR_NULL; 65 | } 66 | 67 | /* Result must not be an allocatable array. */ 68 | if (result->attribute == CFI_attribute_allocatable) 69 | { 70 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Result must not " 71 | "describe an allocatable array. (Error No. %d).\n", 72 | CFI_INVALID_ATTRIBUTE); 73 | return CFI_INVALID_ATTRIBUTE; 74 | } 75 | 76 | /* Source must be some form of array (nonallocatable nonpointer array, 77 | * allocated allocatable array or an associated pointer array). */ 78 | if (source->rank <= 0) 79 | { 80 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Source must " 81 | "describe an array (0 < source->rank, 0 !< %d). (Error No. " 82 | "%d).\n", 83 | source->rank, CFI_INVALID_RANK); 84 | return CFI_INVALID_RANK; 85 | } 86 | 87 | /* Element lengths of source and result must be equal. */ 88 | if (result->elem_len != source->elem_len) 89 | { 90 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: The element " 91 | "lengths of source (source->elem_len = %ld) and result " 92 | "(result->elem_len = %ld) must be equal. (Error No. " 93 | "%d).\n", 94 | source->elem_len, result->elem_len, CFI_INVALID_ELEM_LEN); 95 | return CFI_INVALID_ELEM_LEN; 96 | } 97 | 98 | /* Types must be equal. */ 99 | if (result->type != source->type) 100 | { 101 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Types of source " 102 | "(source->type = %d) and result (result->type = %d) " 103 | "must be equal. (Error No. %d).\n", 104 | source->type, result->type, CFI_INVALID_TYPE); 105 | return CFI_INVALID_TYPE; 106 | } 107 | 108 | /* Stride of zero in the i'th dimension means rank reduction in that 109 | * dimension. */ 110 | int zero_count = 0; 111 | for (int i = 0; i < source->rank; i++) 112 | { 113 | if (strides[i] == 0) 114 | { 115 | zero_count++; 116 | } 117 | } 118 | 119 | /* Rank of result must be equal the the rank of source minus the number of 120 | * zeros in strides. */ 121 | if (result->rank != source->rank - zero_count) 122 | { 123 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Rank of result " 124 | "must be equal to the rank of source minus the number " 125 | "of zeros in strides (result->rank = source->rank - " 126 | "zero_count, %d != %d - %d) (Error No. %d).\n", 127 | result->rank, source->rank, zero_count, CFI_INVALID_RANK); 128 | return CFI_INVALID_RANK; 129 | } 130 | 131 | /* Dimension information. */ 132 | CFI_index_t *lower; 133 | CFI_index_t *upper; 134 | CFI_index_t *stride; 135 | lower = malloc (source->rank * sizeof (CFI_index_t)); 136 | upper = malloc (source->rank * sizeof (CFI_index_t)); 137 | stride = malloc (source->rank * sizeof (CFI_index_t)); 138 | 139 | /* Lower bounds. */ 140 | if (lower_bounds == NULL) 141 | { 142 | for (int i = 0; i < source->rank; i++) 143 | { 144 | lower[i] = source->dim[i].lower_bound; 145 | } 146 | } 147 | else 148 | { 149 | for (int i = 0; i < source->rank; i++) 150 | { 151 | lower[i] = lower_bounds[i]; 152 | } 153 | } 154 | 155 | /* Upper bounds. */ 156 | if (upper_bounds == NULL) 157 | { 158 | if (source->dim[source->rank].extent == -1) 159 | { 160 | fprintf (stderr, 161 | "ISO_Fortran_binding.c: CFI_section: Source must not " 162 | "be an assumed size array if upper_bounds is NULL. (Error " 163 | "No. %d).\n", 164 | CFI_INVALID_EXTENT); 165 | return CFI_INVALID_EXTENT; 166 | } 167 | for (int i = 0; i < source->rank; i++) 168 | { 169 | upper[i] = source->dim[i].lower_bound + source->dim[i].extent - 1; 170 | } 171 | } 172 | else 173 | { 174 | for (int i = 0; i < source->rank; i++) 175 | { 176 | upper[i] = upper_bounds[i]; 177 | } 178 | } 179 | 180 | /* Stride */ 181 | if (strides == NULL) 182 | { 183 | for (int i = 0; i < source->rank; i++) 184 | { 185 | stride[i] = 1; 186 | } 187 | } 188 | else 189 | { 190 | for (int i = 0; i < source->rank; i++) 191 | { 192 | stride[i] = strides[i]; 193 | /* If stride[i] = then lower[i] and upper[i] must be equal. */ 194 | if (stride[i] == 0 && lower[i] != upper[i]) 195 | { 196 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: If " 197 | "strides[%d] = 0, then the lower bounds, " 198 | "lower_bounds[%d] = %ld, and upper_bounds[%d] = " 199 | "%ld, must be equal. (Error No. %d).\n", 200 | i, i, lower_bounds[i], i, upper_bounds[i], 201 | CFI_ERROR_OUT_OF_BOUNDS); 202 | return CFI_ERROR_OUT_OF_BOUNDS; 203 | } 204 | } 205 | } 206 | 207 | /* Check that section upper and lower bounds are within the array bounds. */ 208 | for (int i = 0; i < source->rank; i++) 209 | { 210 | if (lower_bounds != NULL && 211 | (lower[i] < source->dim[i].lower_bound || 212 | lower[i] > source->dim[i].lower_bound + source->dim[i].extent - 1)) 213 | { 214 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Lower bounds " 215 | "must be within the bounds of the fortran array " 216 | "(source->dim[%d].lower_bound <= lower_bounds[%d] " 217 | "<= source->dim[%d].lower_bound + " 218 | "source->dim[%d].extent - 1, %ld <= %ld <= %ld). " 219 | "(Error No. %d).\n", 220 | i, i, i, i, source->dim[i].lower_bound, lower[i], 221 | source->dim[i].lower_bound + source->dim[i].extent - 1, 222 | CFI_ERROR_OUT_OF_BOUNDS); 223 | return CFI_ERROR_OUT_OF_BOUNDS; 224 | } 225 | if (upper_bounds != NULL && 226 | (upper[i] < source->dim[i].lower_bound || 227 | upper[i] > source->dim[i].lower_bound + source->dim[i].extent - 1)) 228 | { 229 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Upper bounds " 230 | "must be within the bounds of the fortran array " 231 | "(source->dim[%d].lower_bound <= upper_bounds[%d] " 232 | "<= source->dim[%d].lower_bound + " 233 | "source->dim[%d].extent - 1, %ld !<= %ld !<= %ld). " 234 | "(Error No. %d).\n", 235 | i, i, i, i, source->dim[i].lower_bound, upper[i], 236 | source->dim[i].lower_bound + source->dim[i].extent - 1, 237 | CFI_ERROR_OUT_OF_BOUNDS); 238 | return CFI_ERROR_OUT_OF_BOUNDS; 239 | } 240 | if (upper[i] < lower[i] && stride[i] >= 0) 241 | { 242 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: If the upper " 243 | "bound is smaller than the lower bound for a given " 244 | "dimension (upper[%d] < lower[%d], %ld < %ld), then " 245 | "the stride for said dimension must be negative " 246 | "(stride[%d] < 0, %ld < 0). (Error No. %d)\n", 247 | i, i, upper[i], lower[i], i, stride[i], CFI_INVALID_STRIDE); 248 | return CFI_INVALID_STRIDE; 249 | } 250 | } 251 | 252 | /* Update the result to describe the array section. */ 253 | /* Set appropriate memory address. */ 254 | result->base_addr = CFI_address (source, lower); 255 | 256 | /* Set the appropriate dimension information that gives us access to the 257 | * data. */ 258 | int aux = 0; 259 | for (int i = 0; i < source->rank; i++) 260 | { 261 | if (stride[i] == 0) 262 | { 263 | aux++; 264 | continue; 265 | } 266 | int idx = i - aux; 267 | result->dim[idx].lower_bound = lower[i]; 268 | result->dim[idx].extent = upper[i] - lower[i] + 1; 269 | result->dim[idx].sm = stride[i] * source->dim[i].sm; 270 | } 271 | 272 | free (lower); 273 | free (upper); 274 | free (stride); 275 | 276 | return CFI_SUCCESS; 277 | } 278 | -------------------------------------------------------------------------------- /src/CFI_select_part.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source, 39 | size_t displacement, size_t elem_len) 40 | { 41 | /* C Descriptors must not be NULL. */ 42 | if (source == NULL) 43 | { 44 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Source must " 45 | "not be NULL. (Error No. %d).\n", 46 | CFI_INVALID_DESCRIPTOR); 47 | return CFI_INVALID_DESCRIPTOR; 48 | } 49 | if (result == NULL) 50 | { 51 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Result must " 52 | "not be NULL. (Error No. %d).\n", 53 | CFI_INVALID_DESCRIPTOR); 54 | return CFI_INVALID_DESCRIPTOR; 55 | } 56 | 57 | /* Attribute of result will be CFI_attribute_other or CFI_attribute_pointer. 58 | */ 59 | if (result->attribute == CFI_attribute_allocatable) 60 | { 61 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Result must " 62 | "not describe an allocatabale object (result->attribute " 63 | "!= %d). (Error No. %d).\n", 64 | CFI_attribute_allocatable, CFI_INVALID_ATTRIBUTE); 65 | return CFI_INVALID_ATTRIBUTE; 66 | } 67 | 68 | /* Base address of source must not be NULL. */ 69 | if (source->base_addr == NULL) 70 | { 71 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Base address " 72 | "of source must not be NULL. (Error No. %d).\n", 73 | CFI_ERROR_BASE_ADDR_NULL); 74 | return CFI_ERROR_BASE_ADDR_NULL; 75 | } 76 | 77 | /* Source and result must have the same rank. */ 78 | if (source->rank != result->rank) 79 | { 80 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Source and " 81 | "result must have the same rank (source->rank = %d, " 82 | "result->rank = %d). (Error No. %d).\n", 83 | source->rank, result->rank, CFI_INVALID_RANK); 84 | return CFI_INVALID_RANK; 85 | } 86 | 87 | /* Nonallocatable nonpointer must not be an assumed size array. */ 88 | if (source->rank > 0 && source->dim[source->rank - 1].extent == -1) 89 | { 90 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Source must " 91 | "not describe an assumed size array " 92 | "(source->dim[%d].extent != -1). (Error No. %d).\n", 93 | source->rank - 1, CFI_INVALID_DESCRIPTOR); 94 | return CFI_INVALID_DESCRIPTOR; 95 | } 96 | 97 | /* Element length. */ 98 | if (result->type == CFI_type_char || result->type == CFI_type_ucs4_char || 99 | result->type == CFI_type_signed_char) 100 | { 101 | result->elem_len = elem_len; 102 | } 103 | 104 | /* Ensure displacement is within the bounds of the element length of source. 105 | */ 106 | if (displacement > source->elem_len - 1) 107 | { 108 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Displacement " 109 | "must be within the bounds of source (0 <= displacement " 110 | "<= source->elem_len - 1, 0 <= %ld <= %ld). (Error No. " 111 | "%d).\n", 112 | displacement, source->elem_len - 1, CFI_ERROR_OUT_OF_BOUNDS); 113 | return CFI_ERROR_OUT_OF_BOUNDS; 114 | } 115 | /* Ensure displacement and element length of result are less than or equal to 116 | * the element length of source. */ 117 | if (displacement + result->elem_len > source->elem_len) 118 | { 119 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Displacement " 120 | "plus the element length of result must be less than or " 121 | "equal to the element length of source (displacement + " 122 | "result->elem_len <= source->elem_len, %ld + %ld = %ld " 123 | "<= %ld). (Error No. %d).\n", 124 | displacement, result->elem_len, displacement + result->elem_len, 125 | source->elem_len, CFI_ERROR_OUT_OF_BOUNDS); 126 | return CFI_ERROR_OUT_OF_BOUNDS; 127 | } 128 | if (result->rank > 0) 129 | { 130 | for (int i = 0; i < result->rank; i++) 131 | { 132 | result->dim[i].lower_bound = source->dim[i].lower_bound; 133 | result->dim[i].extent = source->dim[i].extent; 134 | result->dim[i].sm = 135 | source->dim[i].sm + 136 | displacement * (source->dim[i].sm / source->elem_len - 1); 137 | } 138 | } 139 | 140 | result->base_addr = (char *) source->base_addr + displacement; 141 | return CFI_SUCCESS; 142 | } 143 | -------------------------------------------------------------------------------- /src/CFI_setpointer.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | 38 | int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source, 39 | const CFI_index_t lower_bounds[]) 40 | { 41 | /* Result must not be NULL. */ 42 | if (result == NULL) 43 | { 44 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Result is NULL. " 45 | "(Error No. %d).\n", 46 | CFI_INVALID_DESCRIPTOR); 47 | return CFI_INVALID_DESCRIPTOR; 48 | } 49 | 50 | /* If source is NULL, the result is a C Descriptor that describes a 51 | * disassociated pointer. */ 52 | if (source == NULL) 53 | { 54 | result->base_addr = NULL; 55 | result->version = CFI_VERSION; 56 | result->attribute = CFI_attribute_pointer; 57 | } 58 | else 59 | { 60 | /* Check that element lengths, ranks and types of source and result are 61 | * the same. */ 62 | if (result->elem_len != source->elem_len) 63 | { 64 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Element " 65 | "lengths of result (result->elem_len = %ld) and " 66 | "source (source->elem_len = %ld) must be the same. " 67 | "(Error No. %d).\n", 68 | result->elem_len, source->elem_len, CFI_INVALID_ELEM_LEN); 69 | return CFI_INVALID_ELEM_LEN; 70 | } 71 | 72 | if (result->rank != source->rank) 73 | { 74 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Ranks of " 75 | "result (result->rank = %d) and source " 76 | "(source->rank = %d) must be the same. (Error " 77 | "No. %d).\n", 78 | result->rank, source->rank, CFI_INVALID_RANK); 79 | return CFI_INVALID_RANK; 80 | } 81 | 82 | if (result->type != source->type) 83 | { 84 | fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Types of " 85 | "result (result->type = %d) and source " 86 | "(source->type = %d) must be the same. (Error " 87 | "No. %d).\n", 88 | result->type, source->type, CFI_INVALID_TYPE); 89 | return CFI_INVALID_TYPE; 90 | } 91 | 92 | /* If the source is a disassociated pointer, the result must also describe 93 | * a disassociated pointer. */ 94 | if (source->base_addr == NULL && 95 | source->attribute == CFI_attribute_pointer) 96 | { 97 | result->base_addr = NULL; 98 | } 99 | else 100 | { 101 | result->base_addr = source->base_addr; 102 | } 103 | /* Assign components to result. */ 104 | result->version = source->version; 105 | result->attribute = source->attribute; 106 | 107 | /* Dimension information. */ 108 | for (int i = 0; i < source->rank; i++) 109 | { 110 | if (lower_bounds != NULL) 111 | { 112 | result->dim[i].lower_bound = lower_bounds[i]; 113 | } 114 | else 115 | { 116 | result->dim[i].lower_bound = source->dim[i].lower_bound; 117 | } 118 | result->dim[i].extent = source->dim[i].extent; 119 | result->dim[i].sm = source->dim[i].sm; 120 | } 121 | } 122 | 123 | return CFI_SUCCESS; 124 | } 125 | -------------------------------------------------------------------------------- /src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_library( ISO_Fortran_binding STATIC 2 | CFI_address.c 3 | CFI_allocate.c 4 | CFI_deallocate.c 5 | CFI_establish.c 6 | CFI_is_contiguous.c 7 | CFI_section.c 8 | CFI_select_part.c 9 | CFI_setpointer.c 10 | ) 11 | install(TARGETS ISO_Fortran_binding DESTINATION lib) 12 | -------------------------------------------------------------------------------- /tests/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set( unit_tests 2 | CFI_establish 3 | CFI_deallocate 4 | CFI_is_contiguous 5 | CFI_address 6 | CFI_setpointer 7 | CFI_section 8 | CFI_select_part 9 | ) 10 | foreach(unit_test ${unit_tests}) 11 | add_executable( "test-${unit_test}" "test-${unit_test}.c" ) 12 | target_link_libraries( test-${unit_test} ISO_Fortran_binding ) 13 | endforeach() 14 | -------------------------------------------------------------------------------- /tests/test-CFI_address.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | #include 38 | 39 | int main (void) 40 | { 41 | 42 | CFI_rank_t rank; 43 | CFI_attribute_t attribute; 44 | CFI_type_t type[10] = {CFI_type_Bool, CFI_type_short, 45 | CFI_type_ucs4_char, CFI_type_double, 46 | CFI_type_float128, CFI_type_float128_Complex, 47 | CFI_type_long_double, CFI_type_long_double_Complex, 48 | CFI_type_struct, CFI_type_other}; 49 | size_t elem_len; 50 | int ind; 51 | size_t base_type; 52 | size_t base_type_size; 53 | size_t errno; 54 | 55 | /* Test function establish. */ 56 | /* Fresh descriptor, base address is NULL. */ 57 | /* Loop through type. */ 58 | for (int i = 0; i < 10; i++) 59 | { 60 | elem_len = 0; 61 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 62 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 63 | type[i] == CFI_type_other) 64 | { 65 | base_type = type[i]; 66 | base_type_size = elem_len; 67 | } 68 | else 69 | { 70 | base_type = type[i] & CFI_type_mask; 71 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 72 | } 73 | /* Loop through attribute. */ 74 | for (int j = 1; j <= 3; j++) 75 | { 76 | attribute = j; 77 | /* Loop through rank. */ 78 | for (int k = 0; k <= CFI_MAX_RANK; k++) 79 | { 80 | errno = 1; 81 | rank = k; 82 | CFI_CDESC_T (rank) test1; 83 | /* We do this because C sometimes doesn't make the structures with 84 | * a null base_addr which leads to weird behaviour inside 85 | * CFI_establish. 86 | */ 87 | if (test1.base_addr != NULL) 88 | { 89 | test1.base_addr = NULL; 90 | free (test1.base_addr); 91 | } 92 | ind = CFI_establish ((CFI_cdesc_t *) &test1, NULL, attribute, 93 | type[i], elem_len, rank, NULL); 94 | if (ind != CFI_SUCCESS) 95 | { 96 | goto next_attribute1; 97 | } 98 | if (attribute != test1.attribute) 99 | { 100 | printf ("CFI_establish: failed to assign attribute.\n"); 101 | return 1; 102 | } 103 | if (type[i] != test1.type) 104 | { 105 | printf ("CFI_establish: failed to assign type.\n"); 106 | return 1; 107 | } 108 | if (rank != test1.rank) 109 | { 110 | printf ("CFI_establish: failed to assign rank.\n"); 111 | return 1; 112 | } 113 | elem_len = base_type_size; 114 | if (base_type_size == 10) 115 | { 116 | elem_len = 64; 117 | } 118 | if (base_type == CFI_type_Complex) 119 | { 120 | elem_len *= 2; 121 | } 122 | if (elem_len != test1.elem_len) 123 | { 124 | printf ("CFI_establish: failed to assign element length.\n"); 125 | return 1; 126 | } 127 | } 128 | next_attribute1:; 129 | } 130 | } 131 | 132 | /* Fresh descriptor, base address is not NULL */ 133 | CFI_index_t *extents = NULL; 134 | /* Loop through type. */ 135 | for (int i = 0; i < 10; i++) 136 | { 137 | elem_len = 0; 138 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 139 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 140 | type[i] == CFI_type_other) 141 | { 142 | base_type = type[i]; 143 | base_type_size = elem_len; 144 | } 145 | else 146 | { 147 | base_type = type[i] & CFI_type_mask; 148 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 149 | } 150 | /* Loop through attribute. */ 151 | for (int j = 1; j <= 3; j++) 152 | { 153 | attribute = j; 154 | /* Loop through rank. */ 155 | for (int k = 0; k <= CFI_MAX_RANK; k++) 156 | { 157 | errno = 1; 158 | rank = k; 159 | if (extents != NULL) 160 | { 161 | free (extents); 162 | } 163 | extents = malloc (rank * sizeof (CFI_index_t)); 164 | for (int r = 0; r < rank; r++) 165 | { 166 | extents[r] = r + 1; 167 | } 168 | CFI_CDESC_T (rank) test2; 169 | /* We do this because C sometimes doesn't make the structures with 170 | * a null base_addr which leads to weird behaviour inside 171 | * CFI_establish. 172 | */ 173 | if (test2.base_addr != NULL) 174 | { 175 | test2.base_addr = NULL; 176 | free (test2.base_addr); 177 | } 178 | ind = CFI_establish ((CFI_cdesc_t *) &test2, &ind, attribute, 179 | type[i], elem_len, rank, extents); 180 | if (ind != CFI_SUCCESS) 181 | { 182 | goto next_attribute2; 183 | } 184 | if (attribute != test2.attribute) 185 | { 186 | printf ("CFI_establish: failed to assign attribute.\n"); 187 | return 1; 188 | } 189 | if (type[i] != test2.type) 190 | { 191 | printf ("CFI_establish: failed to assign type.\n"); 192 | return 1; 193 | } 194 | if (rank != test2.rank) 195 | { 196 | printf ("CFI_establish: failed to assign rank.\n"); 197 | return 1; 198 | } 199 | 200 | elem_len = base_type_size; 201 | if (base_type_size == 10) 202 | { 203 | elem_len = 64; 204 | } 205 | if (base_type == CFI_type_Complex) 206 | { 207 | elem_len *= 2; 208 | } 209 | if (elem_len != test2.elem_len) 210 | { 211 | printf ("CFI_establish: failed to assign element length.\n"); 212 | return 1; 213 | } 214 | 215 | for (int r = 0; r < rank; r++) 216 | { 217 | if (extents[r] != test2.dim[r].extent) 218 | { 219 | printf ("CFI_establish: failed to assign dimension " 220 | "extents.\n"); 221 | return 1; 222 | } 223 | } 224 | 225 | if (attribute == CFI_attribute_pointer) 226 | { 227 | for (int r = 0; r < rank; r++) 228 | { 229 | if (test2.dim[r].lower_bound != 0) 230 | { 231 | printf ("CFI_establish: failed to assign dimension " 232 | "lower bounds.\n"); 233 | return 1; 234 | } 235 | } 236 | } 237 | } 238 | next_attribute2:; 239 | } 240 | } 241 | 242 | /* Fresh descriptor, base address is not NULL */ 243 | CFI_index_t *lower = NULL; 244 | CFI_index_t *upper = NULL; 245 | /* Loop through type. */ 246 | for (int i = 0; i < 10; i++) 247 | { 248 | elem_len = 0; 249 | if (type[i] == CFI_type_struct) 250 | { 251 | base_type = type[i]; 252 | base_type_size = 69; 253 | } 254 | else if (type[i] == CFI_type_other) 255 | { 256 | base_type = type[i]; 257 | base_type_size = 666; 258 | } 259 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 260 | type[i] == CFI_type_signed_char) 261 | { 262 | base_type = type[i] & CFI_type_mask; 263 | base_type_size = 3; 264 | } 265 | else 266 | { 267 | base_type = type[i] & CFI_type_mask; 268 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 269 | } 270 | 271 | elem_len = base_type_size; 272 | if (base_type_size == 10) 273 | { 274 | elem_len = 64; 275 | } 276 | if (base_type == CFI_type_Complex) 277 | { 278 | elem_len *= 2; 279 | } 280 | /* Loop through attribute. */ 281 | for (int j = 1; j <= 3; j++) 282 | { 283 | attribute = j; 284 | /* Loop through rank. */ 285 | for (int k = 0; k <= CFI_MAX_RANK; k++) 286 | { 287 | errno = 1; 288 | rank = k; 289 | if (extents != NULL) 290 | { 291 | free (extents); 292 | } 293 | if (lower != NULL) 294 | { 295 | free (lower); 296 | } 297 | if (upper != NULL) 298 | { 299 | free (upper); 300 | } 301 | extents = malloc (rank * sizeof (CFI_index_t)); 302 | lower = malloc (rank * sizeof (CFI_index_t)); 303 | upper = malloc (rank * sizeof (CFI_index_t)); 304 | for (int r = 0; r < rank; r++) 305 | { 306 | extents[r] = 2; 307 | lower[r] = r; 308 | upper[r] = lower[r] + extents[r]; 309 | } 310 | CFI_CDESC_T (rank) test3; 311 | /* We do this because C sometimes doesn't make the structures with 312 | * a null base_addr which leads to weird behaviour inside 313 | * CFI_establish. 314 | */ 315 | if (test3.base_addr != NULL) 316 | { 317 | test3.base_addr = NULL; 318 | free (test3.base_addr); 319 | } 320 | ind = CFI_establish ((CFI_cdesc_t *) &test3, NULL, attribute, 321 | type[i], elem_len, rank, extents); 322 | ind = 323 | CFI_allocate ((CFI_cdesc_t *) &test3, lower, upper, elem_len); 324 | if (ind != CFI_SUCCESS) 325 | { 326 | goto next_attribute3; 327 | } 328 | for (int r = 0; r < rank; r++) 329 | { 330 | if (lower[r] != test3.dim[r].lower_bound) 331 | { 332 | printf ("CFI_allocate: failed to reassign dimension " 333 | "lower bounds.\n"); 334 | return 1; 335 | } 336 | if (upper[r] - test3.dim[r].lower_bound + 1 != 337 | test3.dim[r].extent) 338 | { 339 | printf ("CFI_allocate: failed to reassign dimension " 340 | "extents.\n"); 341 | return 1; 342 | } 343 | if (test3.dim[r].sm != test3.elem_len) 344 | { 345 | printf ( 346 | "CFI_allocate: failed to assign dimension stride.\n"); 347 | return 1; 348 | } 349 | } 350 | if (elem_len != test3.elem_len) 351 | { 352 | printf ("CFI_allocate: failed to reassign element length.\n"); 353 | return 1; 354 | } 355 | } 356 | next_attribute3:; 357 | } 358 | } 359 | 360 | rank = 1; 361 | errno = 1; 362 | CFI_CDESC_T (rank) test4; 363 | base_type = type[3] & CFI_type_mask; 364 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 365 | attribute = CFI_attribute_allocatable; 366 | ind = CFI_establish ((CFI_cdesc_t *) &test4, NULL, attribute, type[3], 367 | elem_len, rank, NULL); 368 | ind = CFI_allocate ((CFI_cdesc_t *) &test4, NULL, NULL, base_type_size); 369 | if (ind != CFI_INVALID_EXTENT) 370 | { 371 | printf ("CFI_allocate: failed to detect invalid extents.\n"); 372 | return 1; 373 | } 374 | 375 | rank = 1; 376 | errno = 1; 377 | CFI_CDESC_T (rank) test5; 378 | base_type = type[3] & CFI_type_mask; 379 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 380 | attribute = CFI_attribute_pointer; 381 | ind = CFI_establish ((CFI_cdesc_t *) &test5, &ind, attribute, type[3], 382 | elem_len, rank, extents); 383 | ind = CFI_allocate ((CFI_cdesc_t *) &test5, NULL, NULL, base_type_size); 384 | if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) 385 | { 386 | printf ("CFI_allocate: failed to detect base address is not NULL.\n"); 387 | return 1; 388 | } 389 | 390 | /* Test CFI_deallocate. */ 391 | rank = 1; 392 | errno = 1; 393 | base_type = type[3] & CFI_type_mask; 394 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 395 | for (int i = 1; i <= 3; i++) 396 | { 397 | attribute = i; 398 | if (extents != NULL) 399 | { 400 | free (extents); 401 | } 402 | if (lower != NULL) 403 | { 404 | free (lower); 405 | } 406 | if (upper != NULL) 407 | { 408 | free (upper); 409 | } 410 | extents = malloc (rank * sizeof (CFI_index_t)); 411 | lower = malloc (rank * sizeof (CFI_index_t)); 412 | upper = malloc (rank * sizeof (CFI_index_t)); 413 | CFI_CDESC_T (rank) test6; 414 | ind = CFI_establish ((CFI_cdesc_t *) &test6, NULL, attribute, type[i], 415 | elem_len, rank, extents); 416 | ind = CFI_allocate ((CFI_cdesc_t *) &test6, lower, upper, base_type_size); 417 | if (ind == CFI_SUCCESS) 418 | { 419 | ind = CFI_deallocate ((CFI_cdesc_t *) &test6); 420 | if (ind != CFI_INVALID_ATTRIBUTE && test6.base_addr != NULL) 421 | { 422 | printf ("CFI_deallocate: failed to deallocate memory.\n"); 423 | return 1; 424 | } 425 | } 426 | } 427 | 428 | /* Test CFI_is_contiguous. */ 429 | int tmp_ind; 430 | base_type = type[3] & CFI_type_mask; 431 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 432 | for (int i = 1; i <= 3; i++) 433 | { 434 | attribute = i; 435 | for (int j = 0; j <= 4; j++) 436 | { 437 | errno = 1; 438 | rank = j; 439 | if (extents != NULL) 440 | { 441 | free (extents); 442 | } 443 | if (lower != NULL) 444 | { 445 | free (lower); 446 | } 447 | if (upper != NULL) 448 | { 449 | free (upper); 450 | } 451 | extents = malloc (rank * sizeof (CFI_index_t)); 452 | lower = malloc (rank * sizeof (CFI_index_t)); 453 | upper = malloc (rank * sizeof (CFI_index_t)); 454 | for (int r = 0; r < rank; r++) 455 | { 456 | extents[r] = 2; 457 | lower[r] = r; 458 | upper[r] = lower[r] + extents[r]; 459 | } 460 | CFI_CDESC_T (rank) test7; 461 | ind = CFI_establish ((CFI_cdesc_t *) &test7, NULL, attribute, type[3], 462 | elem_len, rank, extents); 463 | tmp_ind = CFI_allocate ((CFI_cdesc_t *) &test7, lower, upper, 464 | base_type_size); 465 | if (tmp_ind != CFI_SUCCESS) 466 | { 467 | goto next_attribute4; 468 | } 469 | ind = CFI_is_contiguous ((CFI_cdesc_t *) &test7); 470 | if (ind != CFI_INVALID_RANK && rank == 0 && 471 | tmp_ind != CFI_INVALID_ATTRIBUTE) 472 | { 473 | printf ("CFI_is_contiguous: failed to detect incorrect rank.\n"); 474 | return 1; 475 | } 476 | else if (ind == CFI_ERROR_BASE_ADDR_NULL && test7.base_addr != NULL && 477 | tmp_ind != CFI_SUCCESS) 478 | { 479 | printf ("CFI_is_contiguous: failed to detect base address is not " 480 | "NULL.\n"); 481 | return 1; 482 | } 483 | } 484 | next_attribute4:; 485 | } 486 | 487 | /* Test CFI_address. */ 488 | CFI_index_t *tr_subscripts; 489 | CFI_dim_t * tr_dim; 490 | /* Loop through type. */ 491 | for (int i = 0; i < 10; i++) 492 | { 493 | elem_len = 0; 494 | if (type[i] == CFI_type_struct) 495 | { 496 | base_type = type[i]; 497 | base_type_size = 69; 498 | } 499 | else if (type[i] == CFI_type_other) 500 | { 501 | base_type = type[i]; 502 | base_type_size = 666; 503 | } 504 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 505 | type[i] == CFI_type_signed_char) 506 | { 507 | base_type = type[i] & CFI_type_mask; 508 | base_type_size = 3; 509 | } 510 | else 511 | { 512 | base_type = type[i] & CFI_type_mask; 513 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 514 | } 515 | 516 | elem_len = base_type_size; 517 | if (base_type_size == 10) 518 | { 519 | elem_len = 64; 520 | } 521 | if (base_type == CFI_type_Complex) 522 | { 523 | elem_len *= 2; 524 | } 525 | /* Loop through attribute. */ 526 | for (int j = 1; j <= 3; j++) 527 | { 528 | attribute = j; 529 | /* Loop through rank. */ 530 | for (int k = 1; k <= CFI_MAX_RANK; k++) 531 | { 532 | errno = 1; 533 | rank = k; 534 | CFI_CDESC_T (rank) source; 535 | if (extents != NULL) 536 | { 537 | free (extents); 538 | } 539 | if (lower != NULL) 540 | { 541 | free (lower); 542 | } 543 | if (upper != NULL) 544 | { 545 | free (upper); 546 | } 547 | extents = malloc (rank * sizeof (CFI_index_t)); 548 | lower = malloc (rank * sizeof (CFI_index_t)); 549 | upper = malloc (rank * sizeof (CFI_index_t)); 550 | for (int r = 0; r < rank; r++) 551 | { 552 | extents[r] = rank - r + 1; 553 | lower[r] = rank - r - 3; 554 | upper[r] = lower[r] + extents[r] - 1; 555 | } 556 | ind = CFI_establish ((CFI_cdesc_t *) &source, NULL, 557 | CFI_attribute_allocatable, type[i], elem_len, 558 | rank, extents); 559 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, 560 | elem_len); 561 | if (ind == CFI_SUCCESS) 562 | { 563 | CFI_index_t dif_addr; 564 | CFI_index_t n_entries = 1; 565 | dif_addr = (CFI_index_t) ( 566 | (char *) CFI_address ((CFI_cdesc_t *) &source, upper) - 567 | (char *) CFI_address ((CFI_cdesc_t *) &source, lower)); 568 | for (int r = 0; r < rank; r++) 569 | { 570 | n_entries = n_entries * (upper[r] - lower[r] + 1); 571 | } 572 | tr_subscripts = malloc (rank * sizeof (CFI_index_t)); 573 | tr_dim = malloc (rank * sizeof (CFI_dim_t)); 574 | for (int i = 0; i < rank; i++) 575 | { 576 | CFI_index_t idx = rank - i - 1; 577 | tr_subscripts[i] = upper[idx]; 578 | tr_dim[i] = source.dim[idx]; 579 | /* Normalise the subscripts to start counting the address 580 | * from 0. */ 581 | tr_subscripts[i] -= tr_dim[i].lower_bound; 582 | } 583 | /* We assume column major order as that is how Fortran stores 584 | * arrays. We 585 | * calculate the memory address of the specified element via 586 | * the canonical 587 | * array dimension reduction map and multiplying by the memory 588 | * stride. */ 589 | CFI_index_t index = tr_subscripts[0] * tr_dim[0].sm; 590 | CFI_index_t tmp_index = 1; 591 | for (int i = 1; i < rank; i++) 592 | { 593 | tmp_index *= tr_subscripts[i] * tr_dim[i - 1].extent * 594 | tr_dim[i - 1].sm; 595 | index += tmp_index; 596 | } 597 | free (tr_subscripts); 598 | free (tr_dim); 599 | if (index - dif_addr != 0) 600 | { 601 | printf ("CFI_address: difference in address is not being " 602 | "properly calculated.\n"); 603 | return 1; 604 | } 605 | } 606 | else if (ind == CFI_ERROR_MEM_ALLOCATION) 607 | { 608 | goto next_type; 609 | } 610 | } 611 | } 612 | next_type:; 613 | } 614 | 615 | return 0; 616 | } 617 | -------------------------------------------------------------------------------- /tests/test-CFI_deallocate.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | #include 38 | 39 | int main (void) 40 | { 41 | 42 | CFI_rank_t rank; 43 | CFI_attribute_t attribute; 44 | CFI_type_t type[10] = {CFI_type_Bool, CFI_type_short, 45 | CFI_type_ucs4_char, CFI_type_double, 46 | CFI_type_float128, CFI_type_float128_Complex, 47 | CFI_type_long_double, CFI_type_long_double_Complex, 48 | CFI_type_struct, CFI_type_other}; 49 | size_t elem_len; 50 | int ind; 51 | size_t base_type; 52 | size_t base_type_size; 53 | size_t errno; 54 | 55 | /* Test function establish. */ 56 | /* Fresh descriptor, base address is NULL. */ 57 | /* Loop through type. */ 58 | for (int i = 0; i < 10; i++) 59 | { 60 | elem_len = 0; 61 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 62 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 63 | type[i] == CFI_type_other) 64 | { 65 | base_type = type[i]; 66 | base_type_size = elem_len; 67 | } 68 | else 69 | { 70 | base_type = type[i] & CFI_type_mask; 71 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 72 | } 73 | /* Loop through attribute. */ 74 | for (int j = 1; j <= 3; j++) 75 | { 76 | attribute = j; 77 | /* Loop through rank. */ 78 | for (int k = 0; k <= CFI_MAX_RANK; k++) 79 | { 80 | errno = 1; 81 | rank = k; 82 | CFI_CDESC_T (rank) test1; 83 | /* We do this because C sometimes doesn't make the structures with 84 | * a null base_addr which leads to weird behaviour inside 85 | * CFI_establish. 86 | */ 87 | if (test1.base_addr != NULL) 88 | { 89 | test1.base_addr = NULL; 90 | free (test1.base_addr); 91 | } 92 | ind = CFI_establish ((CFI_cdesc_t *) &test1, NULL, attribute, 93 | type[i], elem_len, rank, NULL); 94 | if (ind != CFI_SUCCESS) 95 | { 96 | goto next_attribute1; 97 | } 98 | if (attribute != test1.attribute) 99 | { 100 | printf ("CFI_establish: failed to assign attribute.\n"); 101 | return 1; 102 | } 103 | if (type[i] != test1.type) 104 | { 105 | printf ("CFI_establish: failed to assign type.\n"); 106 | return 1; 107 | } 108 | if (rank != test1.rank) 109 | { 110 | printf ("CFI_establish: failed to assign rank.\n"); 111 | return 1; 112 | } 113 | elem_len = base_type_size; 114 | if (base_type_size == 10) 115 | { 116 | elem_len = 64; 117 | } 118 | if (base_type == CFI_type_Complex) 119 | { 120 | elem_len *= 2; 121 | } 122 | if (elem_len != test1.elem_len) 123 | { 124 | printf ("CFI_establish: failed to assign element length.\n"); 125 | return 1; 126 | } 127 | } 128 | next_attribute1:; 129 | } 130 | } 131 | 132 | /* Fresh descriptor, base address is not NULL */ 133 | CFI_index_t *extents = NULL; 134 | /* Loop through type. */ 135 | for (int i = 0; i < 10; i++) 136 | { 137 | elem_len = 0; 138 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 139 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 140 | type[i] == CFI_type_other) 141 | { 142 | base_type = type[i]; 143 | base_type_size = elem_len; 144 | } 145 | else 146 | { 147 | base_type = type[i] & CFI_type_mask; 148 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 149 | } 150 | /* Loop through attribute. */ 151 | for (int j = 1; j <= 3; j++) 152 | { 153 | attribute = j; 154 | /* Loop through rank. */ 155 | for (int k = 0; k <= CFI_MAX_RANK; k++) 156 | { 157 | errno = 1; 158 | rank = k; 159 | if (extents != NULL) 160 | { 161 | free (extents); 162 | } 163 | extents = malloc (rank * sizeof (CFI_index_t)); 164 | for (int r = 0; r < rank; r++) 165 | { 166 | extents[r] = r + 1; 167 | } 168 | CFI_CDESC_T (rank) test2; 169 | /* We do this because C sometimes doesn't make the structures with 170 | * a null base_addr which leads to weird behaviour inside 171 | * CFI_establish. 172 | */ 173 | if (test2.base_addr != NULL) 174 | { 175 | test2.base_addr = NULL; 176 | free (test2.base_addr); 177 | } 178 | ind = CFI_establish ((CFI_cdesc_t *) &test2, &ind, attribute, 179 | type[i], elem_len, rank, extents); 180 | if (ind != CFI_SUCCESS) 181 | { 182 | goto next_attribute2; 183 | } 184 | if (attribute != test2.attribute) 185 | { 186 | printf ("CFI_establish: failed to assign attribute.\n"); 187 | return 1; 188 | } 189 | if (type[i] != test2.type) 190 | { 191 | printf ("CFI_establish: failed to assign type.\n"); 192 | return 1; 193 | } 194 | if (rank != test2.rank) 195 | { 196 | printf ("CFI_establish: failed to assign rank.\n"); 197 | return 1; 198 | } 199 | 200 | elem_len = base_type_size; 201 | if (base_type_size == 10) 202 | { 203 | elem_len = 64; 204 | } 205 | if (base_type == CFI_type_Complex) 206 | { 207 | elem_len *= 2; 208 | } 209 | if (elem_len != test2.elem_len) 210 | { 211 | printf ("CFI_establish: failed to assign element length.\n"); 212 | return 1; 213 | } 214 | 215 | for (int r = 0; r < rank; r++) 216 | { 217 | if (extents[r] != test2.dim[r].extent) 218 | { 219 | printf ("CFI_establish: failed to assign dimension " 220 | "extents.\n"); 221 | return 1; 222 | } 223 | } 224 | 225 | if (attribute == CFI_attribute_pointer) 226 | { 227 | for (int r = 0; r < rank; r++) 228 | { 229 | if (test2.dim[r].lower_bound != 0) 230 | { 231 | printf ("CFI_establish: failed to assign dimension " 232 | "lower bounds.\n"); 233 | return 1; 234 | } 235 | } 236 | } 237 | } 238 | next_attribute2:; 239 | } 240 | } 241 | 242 | /* Fresh descriptor, base address is not NULL */ 243 | CFI_index_t *lower = NULL; 244 | CFI_index_t *upper = NULL; 245 | /* Loop through type. */ 246 | for (int i = 0; i < 10; i++) 247 | { 248 | elem_len = 0; 249 | if (type[i] == CFI_type_struct) 250 | { 251 | base_type = type[i]; 252 | base_type_size = 69; 253 | } 254 | else if (type[i] == CFI_type_other) 255 | { 256 | base_type = type[i]; 257 | base_type_size = 666; 258 | } 259 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 260 | type[i] == CFI_type_signed_char) 261 | { 262 | base_type = type[i] & CFI_type_mask; 263 | base_type_size = 3; 264 | } 265 | else 266 | { 267 | base_type = type[i] & CFI_type_mask; 268 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 269 | } 270 | 271 | elem_len = base_type_size; 272 | if (base_type_size == 10) 273 | { 274 | elem_len = 64; 275 | } 276 | if (base_type == CFI_type_Complex) 277 | { 278 | elem_len *= 2; 279 | } 280 | /* Loop through attribute. */ 281 | for (int j = 1; j <= 3; j++) 282 | { 283 | attribute = j; 284 | /* Loop through rank. */ 285 | for (int k = 0; k <= CFI_MAX_RANK; k++) 286 | { 287 | errno = 1; 288 | rank = k; 289 | if (extents != NULL) 290 | { 291 | free (extents); 292 | } 293 | if (lower != NULL) 294 | { 295 | free (lower); 296 | } 297 | if (upper != NULL) 298 | { 299 | free (upper); 300 | } 301 | extents = malloc (rank * sizeof (CFI_index_t)); 302 | lower = malloc (rank * sizeof (CFI_index_t)); 303 | upper = malloc (rank * sizeof (CFI_index_t)); 304 | for (int r = 0; r < rank; r++) 305 | { 306 | extents[r] = 2; 307 | lower[r] = r; 308 | upper[r] = lower[r] + extents[r]; 309 | } 310 | CFI_CDESC_T (rank) test3; 311 | /* We do this because C sometimes doesn't make the structures with 312 | * a null base_addr which leads to weird behaviour inside 313 | * CFI_establish. 314 | */ 315 | if (test3.base_addr != NULL) 316 | { 317 | test3.base_addr = NULL; 318 | free (test3.base_addr); 319 | } 320 | ind = CFI_establish ((CFI_cdesc_t *) &test3, NULL, attribute, 321 | type[i], elem_len, rank, extents); 322 | ind = 323 | CFI_allocate ((CFI_cdesc_t *) &test3, lower, upper, elem_len); 324 | if (ind != CFI_SUCCESS) 325 | { 326 | goto next_attribute3; 327 | } 328 | for (int r = 0; r < rank; r++) 329 | { 330 | if (lower[r] != test3.dim[r].lower_bound) 331 | { 332 | printf ("CFI_allocate: failed to reassign dimension " 333 | "lower bounds.\n"); 334 | return 1; 335 | } 336 | if (upper[r] - test3.dim[r].lower_bound + 1 != 337 | test3.dim[r].extent) 338 | { 339 | printf ("CFI_allocate: failed to reassign dimension " 340 | "extents.\n"); 341 | return 1; 342 | } 343 | if (test3.dim[r].sm != test3.elem_len) 344 | { 345 | printf ( 346 | "CFI_allocate: failed to assign dimension stride.\n"); 347 | return 1; 348 | } 349 | } 350 | if (elem_len != test3.elem_len) 351 | { 352 | printf ("CFI_allocate: failed to reassign element length.\n"); 353 | return 1; 354 | } 355 | } 356 | next_attribute3:; 357 | } 358 | } 359 | 360 | rank = 1; 361 | errno = 1; 362 | CFI_CDESC_T (rank) test4; 363 | base_type = type[3] & CFI_type_mask; 364 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 365 | attribute = CFI_attribute_allocatable; 366 | ind = CFI_establish ((CFI_cdesc_t *) &test4, NULL, attribute, type[3], 367 | elem_len, rank, NULL); 368 | ind = CFI_allocate ((CFI_cdesc_t *) &test4, NULL, NULL, base_type_size); 369 | if (ind != CFI_INVALID_EXTENT) 370 | { 371 | printf ("CFI_allocate: failed to detect invalid extents.\n"); 372 | return 1; 373 | } 374 | 375 | rank = 1; 376 | errno = 1; 377 | CFI_CDESC_T (rank) test5; 378 | base_type = type[3] & CFI_type_mask; 379 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 380 | attribute = CFI_attribute_pointer; 381 | ind = CFI_establish ((CFI_cdesc_t *) &test5, &ind, attribute, type[3], 382 | elem_len, rank, extents); 383 | ind = CFI_allocate ((CFI_cdesc_t *) &test5, NULL, NULL, base_type_size); 384 | if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) 385 | { 386 | printf ("CFI_allocate: failed to detect base address is not NULL.\n"); 387 | return 1; 388 | } 389 | 390 | /* Test CFI_deallocate. */ 391 | rank = 1; 392 | errno = 1; 393 | base_type = type[3] & CFI_type_mask; 394 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 395 | for (int i = 1; i <= 3; i++) 396 | { 397 | attribute = i; 398 | if (extents != NULL) 399 | { 400 | free (extents); 401 | } 402 | if (lower != NULL) 403 | { 404 | free (lower); 405 | } 406 | if (upper != NULL) 407 | { 408 | free (upper); 409 | } 410 | extents = malloc (rank * sizeof (CFI_index_t)); 411 | lower = malloc (rank * sizeof (CFI_index_t)); 412 | upper = malloc (rank * sizeof (CFI_index_t)); 413 | CFI_CDESC_T (rank) test6; 414 | ind = CFI_establish ((CFI_cdesc_t *) &test6, NULL, attribute, type[i], 415 | elem_len, rank, extents); 416 | ind = CFI_allocate ((CFI_cdesc_t *) &test6, lower, upper, base_type_size); 417 | if (ind == CFI_SUCCESS) 418 | { 419 | ind = CFI_deallocate ((CFI_cdesc_t *) &test6); 420 | if (ind != CFI_INVALID_ATTRIBUTE && test6.base_addr != NULL) 421 | { 422 | printf ("CFI_deallocate: failed to deallocate memory.\n"); 423 | return 1; 424 | } 425 | } 426 | } 427 | 428 | return 0; 429 | } 430 | -------------------------------------------------------------------------------- /tests/test-CFI_establish.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | #include 38 | 39 | int main (void) 40 | { 41 | 42 | CFI_rank_t rank; 43 | CFI_attribute_t attribute; 44 | CFI_type_t type[10] = {CFI_type_Bool, CFI_type_short, 45 | CFI_type_ucs4_char, CFI_type_double, 46 | CFI_type_float128, CFI_type_float128_Complex, 47 | CFI_type_long_double, CFI_type_long_double_Complex, 48 | CFI_type_struct, CFI_type_other}; 49 | size_t elem_len; 50 | int ind; 51 | size_t base_type; 52 | size_t base_type_size; 53 | size_t errno; 54 | 55 | /* Test function establish. */ 56 | /* Fresh descriptor, base address is NULL. */ 57 | /* Loop through type. */ 58 | for (int i = 0; i < 10; i++) 59 | { 60 | elem_len = 0; 61 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 62 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 63 | type[i] == CFI_type_other) 64 | { 65 | base_type = type[i]; 66 | base_type_size = elem_len; 67 | } 68 | else 69 | { 70 | base_type = type[i] & CFI_type_mask; 71 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 72 | } 73 | /* Loop through attribute. */ 74 | for (int j = 1; j <= 3; j++) 75 | { 76 | attribute = j; 77 | /* Loop through rank. */ 78 | for (int k = 0; k <= CFI_MAX_RANK; k++) 79 | { 80 | errno = 1; 81 | rank = k; 82 | CFI_CDESC_T (rank) test1; 83 | /* We do this because C sometimes doesn't make the structures with 84 | * a null base_addr which leads to weird behaviour inside 85 | * CFI_establish. 86 | */ 87 | if (test1.base_addr != NULL) 88 | { 89 | test1.base_addr = NULL; 90 | free (test1.base_addr); 91 | } 92 | ind = CFI_establish ((CFI_cdesc_t *) &test1, NULL, attribute, 93 | type[i], elem_len, rank, NULL); 94 | if (ind != CFI_SUCCESS) 95 | { 96 | goto next_attribute1; 97 | } 98 | if (attribute != test1.attribute) 99 | { 100 | printf ("CFI_establish: failed to assign attribute.\n"); 101 | return 1; 102 | } 103 | if (type[i] != test1.type) 104 | { 105 | printf ("CFI_establish: failed to assign type.\n"); 106 | return 1; 107 | } 108 | if (rank != test1.rank) 109 | { 110 | printf ("CFI_establish: failed to assign rank.\n"); 111 | return 1; 112 | } 113 | elem_len = base_type_size; 114 | if (base_type_size == 10) 115 | { 116 | elem_len = 64; 117 | } 118 | if (base_type == CFI_type_Complex) 119 | { 120 | elem_len *= 2; 121 | } 122 | if (elem_len != test1.elem_len) 123 | { 124 | printf ("CFI_establish: failed to assign element length.\n"); 125 | return 1; 126 | } 127 | } 128 | next_attribute1:; 129 | } 130 | } 131 | 132 | /* Fresh descriptor, base address is not NULL */ 133 | CFI_index_t *extents = NULL; 134 | /* Loop through type. */ 135 | for (int i = 0; i < 10; i++) 136 | { 137 | elem_len = 0; 138 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 139 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 140 | type[i] == CFI_type_other) 141 | { 142 | base_type = type[i]; 143 | base_type_size = elem_len; 144 | } 145 | else 146 | { 147 | base_type = type[i] & CFI_type_mask; 148 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 149 | } 150 | /* Loop through attribute. */ 151 | for (int j = 1; j <= 3; j++) 152 | { 153 | attribute = j; 154 | /* Loop through rank. */ 155 | for (int k = 0; k <= CFI_MAX_RANK; k++) 156 | { 157 | errno = 1; 158 | rank = k; 159 | if (extents != NULL) 160 | { 161 | free (extents); 162 | } 163 | extents = malloc (rank * sizeof (CFI_index_t)); 164 | for (int r = 0; r < rank; r++) 165 | { 166 | extents[r] = r + 1; 167 | } 168 | CFI_CDESC_T (rank) test2; 169 | /* We do this because C sometimes doesn't make the structures with 170 | * a null base_addr which leads to weird behaviour inside 171 | * CFI_establish. 172 | */ 173 | if (test2.base_addr != NULL) 174 | { 175 | test2.base_addr = NULL; 176 | free (test2.base_addr); 177 | } 178 | ind = CFI_establish ((CFI_cdesc_t *) &test2, &ind, attribute, 179 | type[i], elem_len, rank, extents); 180 | if (ind != CFI_SUCCESS) 181 | { 182 | goto next_attribute2; 183 | } 184 | if (attribute != test2.attribute) 185 | { 186 | printf ("CFI_establish: failed to assign attribute.\n"); 187 | return 1; 188 | } 189 | if (type[i] != test2.type) 190 | { 191 | printf ("CFI_establish: failed to assign type.\n"); 192 | return 1; 193 | } 194 | if (rank != test2.rank) 195 | { 196 | printf ("CFI_establish: failed to assign rank.\n"); 197 | return 1; 198 | } 199 | 200 | elem_len = base_type_size; 201 | if (base_type_size == 10) 202 | { 203 | elem_len = 64; 204 | } 205 | if (base_type == CFI_type_Complex) 206 | { 207 | elem_len *= 2; 208 | } 209 | if (elem_len != test2.elem_len) 210 | { 211 | printf ("CFI_establish: failed to assign element length.\n"); 212 | return 1; 213 | } 214 | 215 | for (int r = 0; r < rank; r++) 216 | { 217 | if (extents[r] != test2.dim[r].extent) 218 | { 219 | printf ("CFI_establish: failed to assign dimension " 220 | "extents.\n"); 221 | return 1; 222 | } 223 | } 224 | 225 | if (attribute == CFI_attribute_pointer) 226 | { 227 | for (int r = 0; r < rank; r++) 228 | { 229 | if (test2.dim[r].lower_bound != 0) 230 | { 231 | printf ("CFI_establish: failed to assign dimension " 232 | "lower bounds.\n"); 233 | return 1; 234 | } 235 | } 236 | } 237 | } 238 | next_attribute2:; 239 | } 240 | } 241 | 242 | /* Fresh descriptor, base address is not NULL */ 243 | CFI_index_t *lower = NULL; 244 | CFI_index_t *upper = NULL; 245 | /* Loop through type. */ 246 | for (int i = 0; i < 10; i++) 247 | { 248 | elem_len = 0; 249 | if (type[i] == CFI_type_struct) 250 | { 251 | base_type = type[i]; 252 | base_type_size = 69; 253 | } 254 | else if (type[i] == CFI_type_other) 255 | { 256 | base_type = type[i]; 257 | base_type_size = 666; 258 | } 259 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 260 | type[i] == CFI_type_signed_char) 261 | { 262 | base_type = type[i] & CFI_type_mask; 263 | base_type_size = 3; 264 | } 265 | else 266 | { 267 | base_type = type[i] & CFI_type_mask; 268 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 269 | } 270 | 271 | elem_len = base_type_size; 272 | if (base_type_size == 10) 273 | { 274 | elem_len = 64; 275 | } 276 | if (base_type == CFI_type_Complex) 277 | { 278 | elem_len *= 2; 279 | } 280 | /* Loop through attribute. */ 281 | for (int j = 1; j <= 3; j++) 282 | { 283 | attribute = j; 284 | /* Loop through rank. */ 285 | for (int k = 0; k <= CFI_MAX_RANK; k++) 286 | { 287 | errno = 1; 288 | rank = k; 289 | if (extents != NULL) 290 | { 291 | free (extents); 292 | } 293 | if (lower != NULL) 294 | { 295 | free (lower); 296 | } 297 | if (upper != NULL) 298 | { 299 | free (upper); 300 | } 301 | extents = malloc (rank * sizeof (CFI_index_t)); 302 | lower = malloc (rank * sizeof (CFI_index_t)); 303 | upper = malloc (rank * sizeof (CFI_index_t)); 304 | for (int r = 0; r < rank; r++) 305 | { 306 | extents[r] = 2; 307 | lower[r] = r; 308 | upper[r] = lower[r] + extents[r]; 309 | } 310 | CFI_CDESC_T (rank) test3; 311 | /* We do this because C sometimes doesn't make the structures with 312 | * a null base_addr which leads to weird behaviour inside 313 | * CFI_establish. 314 | */ 315 | if (test3.base_addr != NULL) 316 | { 317 | test3.base_addr = NULL; 318 | free (test3.base_addr); 319 | } 320 | ind = CFI_establish ((CFI_cdesc_t *) &test3, NULL, attribute, 321 | type[i], elem_len, rank, extents); 322 | ind = 323 | CFI_allocate ((CFI_cdesc_t *) &test3, lower, upper, elem_len); 324 | if (ind != CFI_SUCCESS) 325 | { 326 | goto next_attribute3; 327 | } 328 | for (int r = 0; r < rank; r++) 329 | { 330 | if (lower[r] != test3.dim[r].lower_bound) 331 | { 332 | printf ("CFI_allocate: failed to reassign dimension " 333 | "lower bounds.\n"); 334 | return 1; 335 | } 336 | if (upper[r] - test3.dim[r].lower_bound + 1 != 337 | test3.dim[r].extent) 338 | { 339 | printf ("CFI_allocate: failed to reassign dimension " 340 | "extents.\n"); 341 | return 1; 342 | } 343 | if (test3.dim[r].sm != test3.elem_len) 344 | { 345 | printf ( 346 | "CFI_allocate: failed to assign dimension stride.\n"); 347 | return 1; 348 | } 349 | } 350 | if (elem_len != test3.elem_len) 351 | { 352 | printf ("CFI_allocate: failed to reassign element length.\n"); 353 | return 1; 354 | } 355 | } 356 | next_attribute3:; 357 | } 358 | } 359 | 360 | rank = 1; 361 | errno = 1; 362 | CFI_CDESC_T (rank) test4; 363 | base_type = type[3] & CFI_type_mask; 364 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 365 | attribute = CFI_attribute_allocatable; 366 | ind = CFI_establish ((CFI_cdesc_t *) &test4, NULL, attribute, type[3], 367 | elem_len, rank, NULL); 368 | ind = CFI_allocate ((CFI_cdesc_t *) &test4, NULL, NULL, base_type_size); 369 | if (ind != CFI_INVALID_EXTENT) 370 | { 371 | printf ("CFI_allocate: failed to detect invalid extents.\n"); 372 | return 1; 373 | } 374 | 375 | rank = 1; 376 | errno = 1; 377 | CFI_CDESC_T (rank) test5; 378 | base_type = type[3] & CFI_type_mask; 379 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 380 | attribute = CFI_attribute_pointer; 381 | ind = CFI_establish ((CFI_cdesc_t *) &test5, &ind, attribute, type[3], 382 | elem_len, rank, extents); 383 | ind = CFI_allocate ((CFI_cdesc_t *) &test5, NULL, NULL, base_type_size); 384 | if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) 385 | { 386 | printf ("CFI_allocate: failed to detect base address is not NULL.\n"); 387 | return 1; 388 | } 389 | 390 | return 0; 391 | } 392 | -------------------------------------------------------------------------------- /tests/test-CFI_is_contiguous.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | #include 38 | 39 | int main (void) 40 | { 41 | 42 | CFI_rank_t rank; 43 | CFI_attribute_t attribute; 44 | CFI_type_t type[10] = {CFI_type_Bool, CFI_type_short, 45 | CFI_type_ucs4_char, CFI_type_double, 46 | CFI_type_float128, CFI_type_float128_Complex, 47 | CFI_type_long_double, CFI_type_long_double_Complex, 48 | CFI_type_struct, CFI_type_other}; 49 | size_t elem_len; 50 | int ind; 51 | size_t base_type; 52 | size_t base_type_size; 53 | size_t errno; 54 | 55 | /* Test function establish. */ 56 | /* Fresh descriptor, base address is NULL. */ 57 | /* Loop through type. */ 58 | for (int i = 0; i < 10; i++) 59 | { 60 | elem_len = 0; 61 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 62 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 63 | type[i] == CFI_type_other) 64 | { 65 | base_type = type[i]; 66 | base_type_size = elem_len; 67 | } 68 | else 69 | { 70 | base_type = type[i] & CFI_type_mask; 71 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 72 | } 73 | /* Loop through attribute. */ 74 | for (int j = 1; j <= 3; j++) 75 | { 76 | attribute = j; 77 | /* Loop through rank. */ 78 | for (int k = 0; k <= CFI_MAX_RANK; k++) 79 | { 80 | errno = 1; 81 | rank = k; 82 | CFI_CDESC_T (rank) test1; 83 | /* We do this because C sometimes doesn't make the structures with 84 | * a null base_addr which leads to weird behaviour inside 85 | * CFI_establish. 86 | */ 87 | if (test1.base_addr != NULL) 88 | { 89 | test1.base_addr = NULL; 90 | free (test1.base_addr); 91 | } 92 | ind = CFI_establish ((CFI_cdesc_t *) &test1, NULL, attribute, 93 | type[i], elem_len, rank, NULL); 94 | if (ind != CFI_SUCCESS) 95 | { 96 | goto next_attribute1; 97 | } 98 | if (attribute != test1.attribute) 99 | { 100 | printf ("CFI_establish: failed to assign attribute.\n"); 101 | return 1; 102 | } 103 | if (type[i] != test1.type) 104 | { 105 | printf ("CFI_establish: failed to assign type.\n"); 106 | return 1; 107 | } 108 | if (rank != test1.rank) 109 | { 110 | printf ("CFI_establish: failed to assign rank.\n"); 111 | return 1; 112 | } 113 | elem_len = base_type_size; 114 | if (base_type_size == 10) 115 | { 116 | elem_len = 64; 117 | } 118 | if (base_type == CFI_type_Complex) 119 | { 120 | elem_len *= 2; 121 | } 122 | if (elem_len != test1.elem_len) 123 | { 124 | printf ("CFI_establish: failed to assign element length.\n"); 125 | return 1; 126 | } 127 | } 128 | next_attribute1:; 129 | } 130 | } 131 | 132 | /* Fresh descriptor, base address is not NULL */ 133 | CFI_index_t *extents = NULL; 134 | /* Loop through type. */ 135 | for (int i = 0; i < 10; i++) 136 | { 137 | elem_len = 0; 138 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 139 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 140 | type[i] == CFI_type_other) 141 | { 142 | base_type = type[i]; 143 | base_type_size = elem_len; 144 | } 145 | else 146 | { 147 | base_type = type[i] & CFI_type_mask; 148 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 149 | } 150 | /* Loop through attribute. */ 151 | for (int j = 1; j <= 3; j++) 152 | { 153 | attribute = j; 154 | /* Loop through rank. */ 155 | for (int k = 0; k <= CFI_MAX_RANK; k++) 156 | { 157 | errno = 1; 158 | rank = k; 159 | if (extents != NULL) 160 | { 161 | free (extents); 162 | } 163 | extents = malloc (rank * sizeof (CFI_index_t)); 164 | for (int r = 0; r < rank; r++) 165 | { 166 | extents[r] = r + 1; 167 | } 168 | CFI_CDESC_T (rank) test2; 169 | /* We do this because C sometimes doesn't make the structures with 170 | * a null base_addr which leads to weird behaviour inside 171 | * CFI_establish. 172 | */ 173 | if (test2.base_addr != NULL) 174 | { 175 | test2.base_addr = NULL; 176 | free (test2.base_addr); 177 | } 178 | ind = CFI_establish ((CFI_cdesc_t *) &test2, &ind, attribute, 179 | type[i], elem_len, rank, extents); 180 | if (ind != CFI_SUCCESS) 181 | { 182 | goto next_attribute2; 183 | } 184 | if (attribute != test2.attribute) 185 | { 186 | printf ("CFI_establish: failed to assign attribute.\n"); 187 | return 1; 188 | } 189 | if (type[i] != test2.type) 190 | { 191 | printf ("CFI_establish: failed to assign type.\n"); 192 | return 1; 193 | } 194 | if (rank != test2.rank) 195 | { 196 | printf ("CFI_establish: failed to assign rank.\n"); 197 | return 1; 198 | } 199 | 200 | elem_len = base_type_size; 201 | if (base_type_size == 10) 202 | { 203 | elem_len = 64; 204 | } 205 | if (base_type == CFI_type_Complex) 206 | { 207 | elem_len *= 2; 208 | } 209 | if (elem_len != test2.elem_len) 210 | { 211 | printf ("CFI_establish: failed to assign element length.\n"); 212 | return 1; 213 | } 214 | 215 | for (int r = 0; r < rank; r++) 216 | { 217 | if (extents[r] != test2.dim[r].extent) 218 | { 219 | printf ("CFI_establish: failed to assign dimension " 220 | "extents.\n"); 221 | return 1; 222 | } 223 | } 224 | 225 | if (attribute == CFI_attribute_pointer) 226 | { 227 | for (int r = 0; r < rank; r++) 228 | { 229 | if (test2.dim[r].lower_bound != 0) 230 | { 231 | printf ("CFI_establish: failed to assign dimension " 232 | "lower bounds.\n"); 233 | return 1; 234 | } 235 | } 236 | } 237 | } 238 | next_attribute2:; 239 | } 240 | } 241 | 242 | /* Fresh descriptor, base address is not NULL */ 243 | CFI_index_t *lower = NULL; 244 | CFI_index_t *upper = NULL; 245 | /* Loop through type. */ 246 | for (int i = 0; i < 10; i++) 247 | { 248 | elem_len = 0; 249 | if (type[i] == CFI_type_struct) 250 | { 251 | base_type = type[i]; 252 | base_type_size = 69; 253 | } 254 | else if (type[i] == CFI_type_other) 255 | { 256 | base_type = type[i]; 257 | base_type_size = 666; 258 | } 259 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 260 | type[i] == CFI_type_signed_char) 261 | { 262 | base_type = type[i] & CFI_type_mask; 263 | base_type_size = 3; 264 | } 265 | else 266 | { 267 | base_type = type[i] & CFI_type_mask; 268 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 269 | } 270 | 271 | elem_len = base_type_size; 272 | if (base_type_size == 10) 273 | { 274 | elem_len = 64; 275 | } 276 | if (base_type == CFI_type_Complex) 277 | { 278 | elem_len *= 2; 279 | } 280 | /* Loop through attribute. */ 281 | for (int j = 1; j <= 3; j++) 282 | { 283 | attribute = j; 284 | /* Loop through rank. */ 285 | for (int k = 0; k <= CFI_MAX_RANK; k++) 286 | { 287 | errno = 1; 288 | rank = k; 289 | if (extents != NULL) 290 | { 291 | free (extents); 292 | } 293 | if (lower != NULL) 294 | { 295 | free (lower); 296 | } 297 | if (upper != NULL) 298 | { 299 | free (upper); 300 | } 301 | extents = malloc (rank * sizeof (CFI_index_t)); 302 | lower = malloc (rank * sizeof (CFI_index_t)); 303 | upper = malloc (rank * sizeof (CFI_index_t)); 304 | for (int r = 0; r < rank; r++) 305 | { 306 | extents[r] = 2; 307 | lower[r] = r; 308 | upper[r] = lower[r] + extents[r]; 309 | } 310 | CFI_CDESC_T (rank) test3; 311 | /* We do this because C sometimes doesn't make the structures with 312 | * a null base_addr which leads to weird behaviour inside 313 | * CFI_establish. 314 | */ 315 | if (test3.base_addr != NULL) 316 | { 317 | test3.base_addr = NULL; 318 | free (test3.base_addr); 319 | } 320 | ind = CFI_establish ((CFI_cdesc_t *) &test3, NULL, attribute, 321 | type[i], elem_len, rank, extents); 322 | ind = 323 | CFI_allocate ((CFI_cdesc_t *) &test3, lower, upper, elem_len); 324 | if (ind != CFI_SUCCESS) 325 | { 326 | goto next_attribute3; 327 | } 328 | for (int r = 0; r < rank; r++) 329 | { 330 | if (lower[r] != test3.dim[r].lower_bound) 331 | { 332 | printf ("CFI_allocate: failed to reassign dimension " 333 | "lower bounds.\n"); 334 | return 1; 335 | } 336 | if (upper[r] - test3.dim[r].lower_bound + 1 != 337 | test3.dim[r].extent) 338 | { 339 | printf ("CFI_allocate: failed to reassign dimension " 340 | "extents.\n"); 341 | return 1; 342 | } 343 | if (test3.dim[r].sm != test3.elem_len) 344 | { 345 | printf ( 346 | "CFI_allocate: failed to assign dimension stride.\n"); 347 | return 1; 348 | } 349 | } 350 | if (elem_len != test3.elem_len) 351 | { 352 | printf ("CFI_allocate: failed to reassign element length.\n"); 353 | return 1; 354 | } 355 | } 356 | next_attribute3:; 357 | } 358 | } 359 | 360 | rank = 1; 361 | errno = 1; 362 | CFI_CDESC_T (rank) test4; 363 | base_type = type[3] & CFI_type_mask; 364 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 365 | attribute = CFI_attribute_allocatable; 366 | ind = CFI_establish ((CFI_cdesc_t *) &test4, NULL, attribute, type[3], 367 | elem_len, rank, NULL); 368 | ind = CFI_allocate ((CFI_cdesc_t *) &test4, NULL, NULL, base_type_size); 369 | if (ind != CFI_INVALID_EXTENT) 370 | { 371 | printf ("CFI_allocate: failed to detect invalid extents.\n"); 372 | return 1; 373 | } 374 | 375 | rank = 1; 376 | errno = 1; 377 | CFI_CDESC_T (rank) test5; 378 | base_type = type[3] & CFI_type_mask; 379 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 380 | attribute = CFI_attribute_pointer; 381 | ind = CFI_establish ((CFI_cdesc_t *) &test5, &ind, attribute, type[3], 382 | elem_len, rank, extents); 383 | ind = CFI_allocate ((CFI_cdesc_t *) &test5, NULL, NULL, base_type_size); 384 | if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) 385 | { 386 | printf ("CFI_allocate: failed to detect base address is not NULL.\n"); 387 | return 1; 388 | } 389 | 390 | /* Test CFI_deallocate. */ 391 | rank = 1; 392 | errno = 1; 393 | base_type = type[3] & CFI_type_mask; 394 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 395 | for (int i = 1; i <= 3; i++) 396 | { 397 | attribute = i; 398 | if (extents != NULL) 399 | { 400 | free (extents); 401 | } 402 | if (lower != NULL) 403 | { 404 | free (lower); 405 | } 406 | if (upper != NULL) 407 | { 408 | free (upper); 409 | } 410 | extents = malloc (rank * sizeof (CFI_index_t)); 411 | lower = malloc (rank * sizeof (CFI_index_t)); 412 | upper = malloc (rank * sizeof (CFI_index_t)); 413 | CFI_CDESC_T (rank) test6; 414 | ind = CFI_establish ((CFI_cdesc_t *) &test6, NULL, attribute, type[i], 415 | elem_len, rank, extents); 416 | ind = CFI_allocate ((CFI_cdesc_t *) &test6, lower, upper, base_type_size); 417 | if (ind == CFI_SUCCESS) 418 | { 419 | ind = CFI_deallocate ((CFI_cdesc_t *) &test6); 420 | if (ind != CFI_INVALID_ATTRIBUTE && test6.base_addr != NULL) 421 | { 422 | printf ("CFI_deallocate: failed to deallocate memory.\n"); 423 | return 1; 424 | } 425 | } 426 | } 427 | 428 | /* Test CFI_is_contiguous. */ 429 | int tmp_ind; 430 | base_type = type[3] & CFI_type_mask; 431 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 432 | for (int i = 1; i <= 3; i++) 433 | { 434 | attribute = i; 435 | for (int j = 0; j <= 4; j++) 436 | { 437 | errno = 1; 438 | rank = j; 439 | if (extents != NULL) 440 | { 441 | free (extents); 442 | } 443 | if (lower != NULL) 444 | { 445 | free (lower); 446 | } 447 | if (upper != NULL) 448 | { 449 | free (upper); 450 | } 451 | extents = malloc (rank * sizeof (CFI_index_t)); 452 | lower = malloc (rank * sizeof (CFI_index_t)); 453 | upper = malloc (rank * sizeof (CFI_index_t)); 454 | for (int r = 0; r < rank; r++) 455 | { 456 | extents[r] = 2; 457 | lower[r] = r; 458 | upper[r] = lower[r] + extents[r]; 459 | } 460 | CFI_CDESC_T (rank) test7; 461 | ind = CFI_establish ((CFI_cdesc_t *) &test7, NULL, attribute, type[3], 462 | elem_len, rank, extents); 463 | tmp_ind = CFI_allocate ((CFI_cdesc_t *) &test7, lower, upper, 464 | base_type_size); 465 | if (tmp_ind != CFI_SUCCESS) 466 | { 467 | goto next_attribute4; 468 | } 469 | ind = CFI_is_contiguous ((CFI_cdesc_t *) &test7); 470 | if (ind != CFI_INVALID_RANK && rank == 0 && 471 | tmp_ind != CFI_INVALID_ATTRIBUTE) 472 | { 473 | printf ("CFI_is_contiguous: failed to detect incorrect rank.\n"); 474 | return 1; 475 | } 476 | else if (ind == CFI_ERROR_BASE_ADDR_NULL && test7.base_addr != NULL && 477 | tmp_ind != CFI_SUCCESS) 478 | { 479 | printf ("CFI_is_contiguous: failed to detect base address is not " 480 | "NULL.\n"); 481 | return 1; 482 | } 483 | } 484 | next_attribute4:; 485 | } 486 | 487 | return 0; 488 | } 489 | -------------------------------------------------------------------------------- /tests/test-CFI_section.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | #include 38 | 39 | int main (void) 40 | { 41 | 42 | CFI_rank_t rank; 43 | CFI_attribute_t attribute; 44 | CFI_type_t type[10] = {CFI_type_Bool, CFI_type_short, 45 | CFI_type_ucs4_char, CFI_type_double, 46 | CFI_type_float128, CFI_type_float128_Complex, 47 | CFI_type_long_double, CFI_type_long_double_Complex, 48 | CFI_type_struct, CFI_type_other}; 49 | size_t elem_len; 50 | int ind; 51 | size_t base_type; 52 | size_t base_type_size; 53 | size_t errno; 54 | 55 | /* Test function establish. */ 56 | /* Fresh descriptor, base address is NULL. */ 57 | /* Loop through type. */ 58 | for (int i = 0; i < 10; i++) 59 | { 60 | elem_len = 0; 61 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 62 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 63 | type[i] == CFI_type_other) 64 | { 65 | base_type = type[i]; 66 | base_type_size = elem_len; 67 | } 68 | else 69 | { 70 | base_type = type[i] & CFI_type_mask; 71 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 72 | } 73 | /* Loop through attribute. */ 74 | for (int j = 1; j <= 3; j++) 75 | { 76 | attribute = j; 77 | /* Loop through rank. */ 78 | for (int k = 0; k <= CFI_MAX_RANK; k++) 79 | { 80 | errno = 1; 81 | rank = k; 82 | CFI_CDESC_T (rank) test1; 83 | /* We do this because C sometimes doesn't make the structures with 84 | * a null base_addr which leads to weird behaviour inside 85 | * CFI_establish. 86 | */ 87 | if (test1.base_addr != NULL) 88 | { 89 | test1.base_addr = NULL; 90 | free (test1.base_addr); 91 | } 92 | ind = CFI_establish ((CFI_cdesc_t *) &test1, NULL, attribute, 93 | type[i], elem_len, rank, NULL); 94 | if (ind != CFI_SUCCESS) 95 | { 96 | goto next_attribute1; 97 | } 98 | if (attribute != test1.attribute) 99 | { 100 | printf ("CFI_establish: failed to assign attribute.\n"); 101 | return 1; 102 | } 103 | if (type[i] != test1.type) 104 | { 105 | printf ("CFI_establish: failed to assign type.\n"); 106 | return 1; 107 | } 108 | if (rank != test1.rank) 109 | { 110 | printf ("CFI_establish: failed to assign rank.\n"); 111 | return 1; 112 | } 113 | elem_len = base_type_size; 114 | if (base_type_size == 10) 115 | { 116 | elem_len = 64; 117 | } 118 | if (base_type == CFI_type_Complex) 119 | { 120 | elem_len *= 2; 121 | } 122 | if (elem_len != test1.elem_len) 123 | { 124 | printf ("CFI_establish: failed to assign element length.\n"); 125 | return 1; 126 | } 127 | } 128 | next_attribute1:; 129 | } 130 | } 131 | 132 | /* Fresh descriptor, base address is not NULL */ 133 | CFI_index_t *extents = NULL; 134 | /* Loop through type. */ 135 | for (int i = 0; i < 10; i++) 136 | { 137 | elem_len = 0; 138 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 139 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 140 | type[i] == CFI_type_other) 141 | { 142 | base_type = type[i]; 143 | base_type_size = elem_len; 144 | } 145 | else 146 | { 147 | base_type = type[i] & CFI_type_mask; 148 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 149 | } 150 | /* Loop through attribute. */ 151 | for (int j = 1; j <= 3; j++) 152 | { 153 | attribute = j; 154 | /* Loop through rank. */ 155 | for (int k = 0; k <= CFI_MAX_RANK; k++) 156 | { 157 | errno = 1; 158 | rank = k; 159 | if (extents != NULL) 160 | { 161 | free (extents); 162 | } 163 | extents = malloc (rank * sizeof (CFI_index_t)); 164 | for (int r = 0; r < rank; r++) 165 | { 166 | extents[r] = r + 1; 167 | } 168 | CFI_CDESC_T (rank) test2; 169 | /* We do this because C sometimes doesn't make the structures with 170 | * a null base_addr which leads to weird behaviour inside 171 | * CFI_establish. 172 | */ 173 | if (test2.base_addr != NULL) 174 | { 175 | test2.base_addr = NULL; 176 | free (test2.base_addr); 177 | } 178 | ind = CFI_establish ((CFI_cdesc_t *) &test2, &ind, attribute, 179 | type[i], elem_len, rank, extents); 180 | if (ind != CFI_SUCCESS) 181 | { 182 | goto next_attribute2; 183 | } 184 | if (attribute != test2.attribute) 185 | { 186 | printf ("CFI_establish: failed to assign attribute.\n"); 187 | return 1; 188 | } 189 | if (type[i] != test2.type) 190 | { 191 | printf ("CFI_establish: failed to assign type.\n"); 192 | return 1; 193 | } 194 | if (rank != test2.rank) 195 | { 196 | printf ("CFI_establish: failed to assign rank.\n"); 197 | return 1; 198 | } 199 | 200 | elem_len = base_type_size; 201 | if (base_type_size == 10) 202 | { 203 | elem_len = 64; 204 | } 205 | if (base_type == CFI_type_Complex) 206 | { 207 | elem_len *= 2; 208 | } 209 | if (elem_len != test2.elem_len) 210 | { 211 | printf ("CFI_establish: failed to assign element length.\n"); 212 | return 1; 213 | } 214 | 215 | for (int r = 0; r < rank; r++) 216 | { 217 | if (extents[r] != test2.dim[r].extent) 218 | { 219 | printf ("CFI_establish: failed to assign dimension " 220 | "extents.\n"); 221 | return 1; 222 | } 223 | } 224 | 225 | if (attribute == CFI_attribute_pointer) 226 | { 227 | for (int r = 0; r < rank; r++) 228 | { 229 | if (test2.dim[r].lower_bound != 0) 230 | { 231 | printf ("CFI_establish: failed to assign dimension " 232 | "lower bounds.\n"); 233 | return 1; 234 | } 235 | } 236 | } 237 | } 238 | next_attribute2:; 239 | } 240 | } 241 | 242 | /* Fresh descriptor, base address is not NULL */ 243 | CFI_index_t *lower = NULL; 244 | CFI_index_t *upper = NULL; 245 | /* Loop through type. */ 246 | for (int i = 0; i < 10; i++) 247 | { 248 | elem_len = 0; 249 | if (type[i] == CFI_type_struct) 250 | { 251 | base_type = type[i]; 252 | base_type_size = 69; 253 | } 254 | else if (type[i] == CFI_type_other) 255 | { 256 | base_type = type[i]; 257 | base_type_size = 666; 258 | } 259 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 260 | type[i] == CFI_type_signed_char) 261 | { 262 | base_type = type[i] & CFI_type_mask; 263 | base_type_size = 3; 264 | } 265 | else 266 | { 267 | base_type = type[i] & CFI_type_mask; 268 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 269 | } 270 | 271 | elem_len = base_type_size; 272 | if (base_type_size == 10) 273 | { 274 | elem_len = 64; 275 | } 276 | if (base_type == CFI_type_Complex) 277 | { 278 | elem_len *= 2; 279 | } 280 | /* Loop through attribute. */ 281 | for (int j = 1; j <= 3; j++) 282 | { 283 | attribute = j; 284 | /* Loop through rank. */ 285 | for (int k = 0; k <= CFI_MAX_RANK; k++) 286 | { 287 | errno = 1; 288 | rank = k; 289 | if (extents != NULL) 290 | { 291 | free (extents); 292 | } 293 | if (lower != NULL) 294 | { 295 | free (lower); 296 | } 297 | if (upper != NULL) 298 | { 299 | free (upper); 300 | } 301 | extents = malloc (rank * sizeof (CFI_index_t)); 302 | lower = malloc (rank * sizeof (CFI_index_t)); 303 | upper = malloc (rank * sizeof (CFI_index_t)); 304 | for (int r = 0; r < rank; r++) 305 | { 306 | extents[r] = 2; 307 | lower[r] = r; 308 | upper[r] = lower[r] + extents[r]; 309 | } 310 | CFI_CDESC_T (rank) test3; 311 | /* We do this because C sometimes doesn't make the structures with 312 | * a null base_addr which leads to weird behaviour inside 313 | * CFI_establish. 314 | */ 315 | if (test3.base_addr != NULL) 316 | { 317 | test3.base_addr = NULL; 318 | free (test3.base_addr); 319 | } 320 | ind = CFI_establish ((CFI_cdesc_t *) &test3, NULL, attribute, 321 | type[i], elem_len, rank, extents); 322 | ind = 323 | CFI_allocate ((CFI_cdesc_t *) &test3, lower, upper, elem_len); 324 | if (ind != CFI_SUCCESS) 325 | { 326 | goto next_attribute3; 327 | } 328 | for (int r = 0; r < rank; r++) 329 | { 330 | if (lower[r] != test3.dim[r].lower_bound) 331 | { 332 | printf ("CFI_allocate: failed to reassign dimension " 333 | "lower bounds.\n"); 334 | return 1; 335 | } 336 | if (upper[r] - test3.dim[r].lower_bound + 1 != 337 | test3.dim[r].extent) 338 | { 339 | printf ("CFI_allocate: failed to reassign dimension " 340 | "extents.\n"); 341 | return 1; 342 | } 343 | if (test3.dim[r].sm != test3.elem_len) 344 | { 345 | printf ( 346 | "CFI_allocate: failed to assign dimension stride.\n"); 347 | return 1; 348 | } 349 | } 350 | if (elem_len != test3.elem_len) 351 | { 352 | printf ("CFI_allocate: failed to reassign element length.\n"); 353 | return 1; 354 | } 355 | } 356 | next_attribute3:; 357 | } 358 | } 359 | 360 | rank = 1; 361 | errno = 1; 362 | CFI_CDESC_T (rank) test4; 363 | base_type = type[3] & CFI_type_mask; 364 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 365 | attribute = CFI_attribute_allocatable; 366 | ind = CFI_establish ((CFI_cdesc_t *) &test4, NULL, attribute, type[3], 367 | elem_len, rank, NULL); 368 | ind = CFI_allocate ((CFI_cdesc_t *) &test4, NULL, NULL, base_type_size); 369 | if (ind != CFI_INVALID_EXTENT) 370 | { 371 | printf ("CFI_allocate: failed to detect invalid extents.\n"); 372 | return 1; 373 | } 374 | 375 | rank = 1; 376 | errno = 1; 377 | CFI_CDESC_T (rank) test5; 378 | base_type = type[3] & CFI_type_mask; 379 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 380 | attribute = CFI_attribute_pointer; 381 | ind = CFI_establish ((CFI_cdesc_t *) &test5, &ind, attribute, type[3], 382 | elem_len, rank, extents); 383 | ind = CFI_allocate ((CFI_cdesc_t *) &test5, NULL, NULL, base_type_size); 384 | if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) 385 | { 386 | printf ("CFI_allocate: failed to detect base address is not NULL.\n"); 387 | return 1; 388 | } 389 | 390 | /* Test CFI_deallocate. */ 391 | rank = 1; 392 | errno = 1; 393 | base_type = type[3] & CFI_type_mask; 394 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 395 | for (int i = 1; i <= 3; i++) 396 | { 397 | attribute = i; 398 | if (extents != NULL) 399 | { 400 | free (extents); 401 | } 402 | if (lower != NULL) 403 | { 404 | free (lower); 405 | } 406 | if (upper != NULL) 407 | { 408 | free (upper); 409 | } 410 | extents = malloc (rank * sizeof (CFI_index_t)); 411 | lower = malloc (rank * sizeof (CFI_index_t)); 412 | upper = malloc (rank * sizeof (CFI_index_t)); 413 | CFI_CDESC_T (rank) test6; 414 | ind = CFI_establish ((CFI_cdesc_t *) &test6, NULL, attribute, type[i], 415 | elem_len, rank, extents); 416 | ind = CFI_allocate ((CFI_cdesc_t *) &test6, lower, upper, base_type_size); 417 | if (ind == CFI_SUCCESS) 418 | { 419 | ind = CFI_deallocate ((CFI_cdesc_t *) &test6); 420 | if (ind != CFI_INVALID_ATTRIBUTE && test6.base_addr != NULL) 421 | { 422 | printf ("CFI_deallocate: failed to deallocate memory.\n"); 423 | return 1; 424 | } 425 | } 426 | } 427 | 428 | /* Test CFI_is_contiguous. */ 429 | int tmp_ind; 430 | base_type = type[3] & CFI_type_mask; 431 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 432 | for (int i = 1; i <= 3; i++) 433 | { 434 | attribute = i; 435 | for (int j = 0; j <= 4; j++) 436 | { 437 | errno = 1; 438 | rank = j; 439 | if (extents != NULL) 440 | { 441 | free (extents); 442 | } 443 | if (lower != NULL) 444 | { 445 | free (lower); 446 | } 447 | if (upper != NULL) 448 | { 449 | free (upper); 450 | } 451 | extents = malloc (rank * sizeof (CFI_index_t)); 452 | lower = malloc (rank * sizeof (CFI_index_t)); 453 | upper = malloc (rank * sizeof (CFI_index_t)); 454 | for (int r = 0; r < rank; r++) 455 | { 456 | extents[r] = 2; 457 | lower[r] = r; 458 | upper[r] = lower[r] + extents[r]; 459 | } 460 | CFI_CDESC_T (rank) test7; 461 | ind = CFI_establish ((CFI_cdesc_t *) &test7, NULL, attribute, type[3], 462 | elem_len, rank, extents); 463 | tmp_ind = CFI_allocate ((CFI_cdesc_t *) &test7, lower, upper, 464 | base_type_size); 465 | if (tmp_ind != CFI_SUCCESS) 466 | { 467 | goto next_attribute4; 468 | } 469 | ind = CFI_is_contiguous ((CFI_cdesc_t *) &test7); 470 | if (ind != CFI_INVALID_RANK && rank == 0 && 471 | tmp_ind != CFI_INVALID_ATTRIBUTE) 472 | { 473 | printf ("CFI_is_contiguous: failed to detect incorrect rank.\n"); 474 | return 1; 475 | } 476 | else if (ind == CFI_ERROR_BASE_ADDR_NULL && test7.base_addr != NULL && 477 | tmp_ind != CFI_SUCCESS) 478 | { 479 | printf ("CFI_is_contiguous: failed to detect base address is not " 480 | "NULL.\n"); 481 | return 1; 482 | } 483 | } 484 | next_attribute4:; 485 | } 486 | 487 | /* Test CFI_address. */ 488 | CFI_index_t *tr_subscripts; 489 | CFI_dim_t * tr_dim; 490 | /* Loop through type. */ 491 | for (int i = 0; i < 10; i++) 492 | { 493 | elem_len = 0; 494 | if (type[i] == CFI_type_struct) 495 | { 496 | base_type = type[i]; 497 | base_type_size = 69; 498 | } 499 | else if (type[i] == CFI_type_other) 500 | { 501 | base_type = type[i]; 502 | base_type_size = 666; 503 | } 504 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 505 | type[i] == CFI_type_signed_char) 506 | { 507 | base_type = type[i] & CFI_type_mask; 508 | base_type_size = 3; 509 | } 510 | else 511 | { 512 | base_type = type[i] & CFI_type_mask; 513 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 514 | } 515 | 516 | elem_len = base_type_size; 517 | if (base_type_size == 10) 518 | { 519 | elem_len = 64; 520 | } 521 | if (base_type == CFI_type_Complex) 522 | { 523 | elem_len *= 2; 524 | } 525 | /* Loop through attribute. */ 526 | for (int j = 1; j <= 3; j++) 527 | { 528 | attribute = j; 529 | /* Loop through rank. */ 530 | for (int k = 1; k <= CFI_MAX_RANK; k++) 531 | { 532 | errno = 1; 533 | rank = k; 534 | CFI_CDESC_T (rank) source; 535 | if (extents != NULL) 536 | { 537 | free (extents); 538 | } 539 | if (lower != NULL) 540 | { 541 | free (lower); 542 | } 543 | if (upper != NULL) 544 | { 545 | free (upper); 546 | } 547 | extents = malloc (rank * sizeof (CFI_index_t)); 548 | lower = malloc (rank * sizeof (CFI_index_t)); 549 | upper = malloc (rank * sizeof (CFI_index_t)); 550 | for (int r = 0; r < rank; r++) 551 | { 552 | extents[r] = rank - r + 1; 553 | lower[r] = rank - r - 3; 554 | upper[r] = lower[r] + extents[r] - 1; 555 | } 556 | ind = CFI_establish ((CFI_cdesc_t *) &source, NULL, 557 | CFI_attribute_allocatable, type[i], elem_len, 558 | rank, extents); 559 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, 560 | elem_len); 561 | if (ind == CFI_SUCCESS) 562 | { 563 | CFI_index_t dif_addr; 564 | CFI_index_t n_entries = 1; 565 | dif_addr = (CFI_index_t) ( 566 | (char *) CFI_address ((CFI_cdesc_t *) &source, upper) - 567 | (char *) CFI_address ((CFI_cdesc_t *) &source, lower)); 568 | for (int r = 0; r < rank; r++) 569 | { 570 | n_entries = n_entries * (upper[r] - lower[r] + 1); 571 | } 572 | tr_subscripts = malloc (rank * sizeof (CFI_index_t)); 573 | tr_dim = malloc (rank * sizeof (CFI_dim_t)); 574 | for (int i = 0; i < rank; i++) 575 | { 576 | CFI_index_t idx = rank - i - 1; 577 | tr_subscripts[i] = upper[idx]; 578 | tr_dim[i] = source.dim[idx]; 579 | /* Normalise the subscripts to start counting the address 580 | * from 0. */ 581 | tr_subscripts[i] -= tr_dim[i].lower_bound; 582 | } 583 | /* We assume column major order as that is how Fortran stores 584 | * arrays. We 585 | * calculate the memory address of the specified element via 586 | * the canonical 587 | * array dimension reduction map and multiplying by the memory 588 | * stride. */ 589 | CFI_index_t index = tr_subscripts[0] * tr_dim[0].sm; 590 | CFI_index_t tmp_index = 1; 591 | for (int i = 1; i < rank; i++) 592 | { 593 | tmp_index *= tr_subscripts[i] * tr_dim[i - 1].extent * 594 | tr_dim[i - 1].sm; 595 | index += tmp_index; 596 | } 597 | free (tr_subscripts); 598 | free (tr_dim); 599 | if (index - dif_addr != 0) 600 | { 601 | printf ("CFI_address: difference in address is not being " 602 | "properly calculated.\n"); 603 | return 1; 604 | } 605 | } 606 | else if (ind == CFI_ERROR_MEM_ALLOCATION) 607 | { 608 | goto next_type; 609 | } 610 | } 611 | } 612 | next_type:; 613 | } 614 | 615 | /* Test CFI_setpointer */ 616 | for (int i = 0; i < CFI_MAX_RANK; i++) 617 | { 618 | rank = i; 619 | errno = 1; 620 | base_type = type[3] & CFI_type_mask; 621 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 622 | attribute = CFI_attribute_other; 623 | CFI_CDESC_T (rank) test8a, test8b; 624 | 625 | if (extents != NULL) 626 | { 627 | free (extents); 628 | } 629 | if (lower != NULL) 630 | { 631 | free (lower); 632 | } 633 | extents = malloc (rank * sizeof (CFI_index_t)); 634 | lower = malloc (rank * sizeof (CFI_index_t)); 635 | for (int r = 0; r < rank; r++) 636 | { 637 | extents[r] = r + 1; 638 | lower[r] = r - 2; 639 | } 640 | ind = CFI_establish ((CFI_cdesc_t *) &test8a, &ind, attribute, type[3], 641 | base_type_size, rank, extents); 642 | for (int r = 0; r < rank; r++) 643 | { 644 | extents[r] = r + 2; 645 | } 646 | ind = CFI_establish ((CFI_cdesc_t *) &test8b, &errno, attribute, type[3], 647 | base_type_size, rank, extents); 648 | ind = CFI_setpointer ((CFI_cdesc_t *) &test8a, (CFI_cdesc_t *) &test8b, 649 | lower); 650 | for (int r = 0; r < rank; r++) 651 | { 652 | if (test8a.dim[r].lower_bound != lower[r]) 653 | { 654 | printf ("CFI_setpointer: failed to reassign lower bounds.\n"); 655 | return 1; 656 | } 657 | if (test8a.dim[r].extent != test8b.dim[r].extent) 658 | { 659 | printf ("CFI_setpointer: failed to reassign extents.\n"); 660 | return 1; 661 | } 662 | if (test8a.dim[r].sm != test8b.dim[r].sm) 663 | { 664 | printf ("CFI_setpointer: failed to reassign memory strides.\n"); 665 | return 1; 666 | } 667 | } 668 | if (test8a.base_addr != test8b.base_addr) 669 | { 670 | printf ("CFI_setpointer: failed to reassign base address.\n"); 671 | return 1; 672 | } 673 | if (test8a.version != test8b.version) 674 | { 675 | printf ("CFI_setpointer: failed to reassign lower bounds.\n"); 676 | return 1; 677 | } 678 | if (test8a.attribute != test8b.attribute) 679 | { 680 | printf ("CFI_setpointer: failed to reassign attribute.\n"); 681 | return 1; 682 | } 683 | } 684 | 685 | /* NULL source. */ 686 | rank = 10; 687 | errno = 1; 688 | base_type = type[3] & CFI_type_mask; 689 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 690 | CFI_CDESC_T (rank) test9; 691 | 692 | if (extents != NULL) 693 | { 694 | free (extents); 695 | } 696 | if (lower != NULL) 697 | { 698 | free (lower); 699 | } 700 | extents = malloc (rank * sizeof (CFI_index_t)); 701 | lower = malloc (rank * sizeof (CFI_index_t)); 702 | for (int r = 0; r < rank; r++) 703 | { 704 | extents[r] = r + 1; 705 | lower[r] = r - 2; 706 | } 707 | ind = CFI_establish ((CFI_cdesc_t *) &test9, &ind, attribute, type[3], 708 | base_type_size, rank, extents); 709 | ind = CFI_setpointer ((CFI_cdesc_t *) &test9, NULL, lower); 710 | if (test9.attribute != CFI_attribute_pointer) 711 | { 712 | printf ("CFI_setpointer: failed to set attribute pointer.\n"); 713 | return 1; 714 | } 715 | if (test9.base_addr != NULL) 716 | { 717 | printf ("CFI_setpointer: failed to set base address to NULL.\n"); 718 | return 1; 719 | } 720 | 721 | rank = 3; 722 | errno = 1; 723 | attribute = CFI_attribute_other; 724 | CFI_CDESC_T (rank) test10a, test10b; 725 | if (extents != NULL) 726 | { 727 | free (extents); 728 | } 729 | if (lower != NULL) 730 | { 731 | free (lower); 732 | } 733 | extents = malloc (rank * sizeof (CFI_index_t)); 734 | lower = malloc (rank * sizeof (CFI_index_t)); 735 | for (int r = 0; r < rank; r++) 736 | { 737 | extents[r] = r + 1; 738 | lower[r] = r - 2; 739 | } 740 | base_type = CFI_type_long & CFI_type_mask; 741 | base_type_size = (CFI_type_long - base_type) >> CFI_type_kind_shift; 742 | ind = CFI_establish ((CFI_cdesc_t *) &test10a, &ind, attribute, CFI_type_long, 743 | base_type_size, rank, extents); 744 | for (int r = 0; r < rank; r++) 745 | { 746 | extents[r] = r + 2; 747 | } 748 | base_type = CFI_type_double & CFI_type_mask; 749 | base_type_size = (CFI_type_double - base_type) >> CFI_type_kind_shift; 750 | ind = CFI_establish ((CFI_cdesc_t *) &test10b, &errno, attribute, 751 | CFI_type_double, base_type_size, rank, extents); 752 | ind = CFI_setpointer ((CFI_cdesc_t *) &test10a, (CFI_cdesc_t *) &test10b, 753 | lower); 754 | if (ind != CFI_INVALID_TYPE) 755 | { 756 | printf ("CFI_setpointer: failed to detect invalid type.\n"); 757 | return 1; 758 | } 759 | 760 | errno = 1; 761 | base_type = CFI_type_other & CFI_type_mask; 762 | base_type_size = 666; 763 | ind = CFI_establish ((CFI_cdesc_t *) &test10a, &ind, attribute, 764 | CFI_type_other, base_type_size, rank, extents); 765 | base_type = CFI_type_other & CFI_type_mask; 766 | base_type_size = 69; 767 | ind = CFI_establish ((CFI_cdesc_t *) &test10b, &errno, attribute, 768 | CFI_type_other, base_type_size, rank, extents); 769 | ind = CFI_setpointer ((CFI_cdesc_t *) &test10a, (CFI_cdesc_t *) &test10b, 770 | lower); 771 | if (ind != CFI_INVALID_ELEM_LEN) 772 | { 773 | printf ("CFI_setpointer: failed to detect invalid element length.\n"); 774 | return 1; 775 | } 776 | 777 | errno = 1; 778 | base_type = type[3] & CFI_type_mask; 779 | base_type_size = (CFI_type_long - base_type) >> CFI_type_kind_shift; 780 | ind = CFI_establish ((CFI_cdesc_t *) &test10a, &ind, attribute, type[3], 781 | base_type_size, rank, extents); 782 | rank++; 783 | CFI_CDESC_T (rank) test10c; 784 | if (extents != NULL) 785 | { 786 | free (extents); 787 | } 788 | if (lower != NULL) 789 | { 790 | free (lower); 791 | } 792 | extents = malloc (rank * sizeof (CFI_index_t)); 793 | lower = malloc (rank * sizeof (CFI_index_t)); 794 | for (int r = 0; r < rank; r++) 795 | { 796 | extents[r] = r + 1; 797 | lower[r] = r - 2; 798 | } 799 | base_type = CFI_type_other & CFI_type_mask; 800 | base_type_size = (CFI_type_long - base_type) >> CFI_type_kind_shift; 801 | ind = CFI_establish ((CFI_cdesc_t *) &test10c, &errno, attribute, type[3], 802 | base_type_size, rank, extents); 803 | ind = CFI_setpointer ((CFI_cdesc_t *) &test10a, (CFI_cdesc_t *) &test10c, 804 | lower); 805 | if (ind != CFI_INVALID_RANK) 806 | { 807 | printf ("CFI_setpointer: failed to detect invalid rank.\n"); 808 | return 1; 809 | } 810 | 811 | /* Test CFI_section */ 812 | CFI_index_t *strides; 813 | /* Loop through type. */ 814 | for (int i = 0; i < 10; i++) 815 | { 816 | elem_len = 0; 817 | if (type[i] == CFI_type_struct) 818 | { 819 | base_type = type[i]; 820 | base_type_size = 69; 821 | } 822 | else if (type[i] == CFI_type_other) 823 | { 824 | base_type = type[i]; 825 | base_type_size = 666; 826 | } 827 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 828 | type[i] == CFI_type_signed_char) 829 | { 830 | base_type = type[i] & CFI_type_mask; 831 | base_type_size = 3; 832 | } 833 | else 834 | { 835 | base_type = type[i] & CFI_type_mask; 836 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 837 | } 838 | elem_len = base_type_size; 839 | if (base_type_size == 10) 840 | { 841 | elem_len = 64; 842 | } 843 | if (base_type == CFI_type_Complex) 844 | { 845 | elem_len *= 2; 846 | } 847 | /* Loop through rank. */ 848 | for (int k = 1; k <= CFI_MAX_RANK; k++) 849 | { 850 | errno = 1; 851 | rank = k; 852 | CFI_CDESC_T (rank) section, source; 853 | if (extents != NULL) 854 | { 855 | free (extents); 856 | } 857 | if (lower != NULL) 858 | { 859 | free (lower); 860 | } 861 | if (upper != NULL) 862 | { 863 | free (upper); 864 | } 865 | if (strides == NULL) 866 | { 867 | free (strides); 868 | } 869 | extents = malloc (rank * sizeof (CFI_index_t)); 870 | lower = malloc (rank * sizeof (CFI_index_t)); 871 | upper = malloc (rank * sizeof (CFI_index_t)); 872 | strides = malloc (rank * sizeof (CFI_index_t)); 873 | for (int r = 0; r < rank; r++) 874 | { 875 | extents[r] = rank - r + 10; 876 | lower[r] = rank - r - 5; 877 | upper[r] = lower[r] + extents[r] - 1; 878 | } 879 | ind = CFI_establish ((CFI_cdesc_t *) &source, NULL, 880 | CFI_attribute_allocatable, type[i], elem_len, 881 | rank, extents); 882 | ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, 883 | CFI_attribute_other, type[i], elem_len, rank, 884 | NULL); 885 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, elem_len); 886 | if (ind != CFI_SUCCESS) 887 | { 888 | goto next_type2; 889 | } 890 | /* Lower is within bounds. */ 891 | for (int r = 0; r < rank; r++) 892 | { 893 | lower[r] = rank - r - 3; 894 | strides[r] = r + 1; 895 | } 896 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 897 | lower, NULL, strides); 898 | if (ind != CFI_SUCCESS) 899 | { 900 | printf ("CFI_section: failed to detect lower bounds are within " 901 | "bounds.\n"); 902 | return 1; 903 | } 904 | /* Lower is below lower bounds. */ 905 | for (int r = 0; r < rank; r++) 906 | { 907 | lower[r] = rank - r - 6; 908 | strides[r] = r + 1; 909 | } 910 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 911 | lower, NULL, strides); 912 | if (ind != CFI_ERROR_OUT_OF_BOUNDS) 913 | { 914 | printf ("CFI_section: failed to detect lower bounds are below " 915 | "bounds.\n"); 916 | return 1; 917 | } 918 | /* Lower is above upper bounds. */ 919 | for (int r = 0; r < rank; r++) 920 | { 921 | lower[r] = upper[r] + 1; 922 | strides[r] = r + 1; 923 | } 924 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 925 | lower, NULL, strides); 926 | if (ind != CFI_ERROR_OUT_OF_BOUNDS) 927 | { 928 | printf ("CFI_section: failed to detect lower bounds are above " 929 | "bounds.\n"); 930 | return 1; 931 | } 932 | for (int r = 0; r < rank; r++) 933 | { 934 | extents[r] = rank - r + 10; 935 | lower[r] = rank - r - 5; 936 | upper[r] = lower[r] + extents[r] - 1; 937 | } 938 | /* Upper is within bounds. */ 939 | for (int r = 0; r < rank; r++) 940 | { 941 | upper[r] = rank - r - 3; 942 | strides[r] = r + 1; 943 | } 944 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 945 | NULL, upper, strides); 946 | if (ind != CFI_SUCCESS) 947 | { 948 | printf ("CFI_section: failed to detect upper bounds are within " 949 | "bounds.\n"); 950 | return 1; 951 | } 952 | /* Upper is below lower bounds. */ 953 | for (int r = 0; r < rank; r++) 954 | { 955 | upper[r] = rank - r - 6; 956 | strides[r] = r + 1; 957 | } 958 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 959 | NULL, upper, strides); 960 | if (ind != CFI_ERROR_OUT_OF_BOUNDS) 961 | { 962 | printf ("CFI_section: failed to detect upper bounds are below " 963 | "bounds.\n"); 964 | return 1; 965 | } 966 | /* Upper is above upper bounds. */ 967 | for (int r = 0; r < rank; r++) 968 | { 969 | upper[r] = lower[r] + extents[r]; 970 | strides[r] = r + 1; 971 | } 972 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 973 | NULL, upper, strides); 974 | if (ind != CFI_ERROR_OUT_OF_BOUNDS) 975 | { 976 | printf ("CFI_section: failed to detect lower bounds are above " 977 | "bounds.\n"); 978 | return 1; 979 | } 980 | for (int r = 0; r < rank; r++) 981 | { 982 | extents[r] = rank - r + 10; 983 | lower[r] = rank - r - 3; 984 | upper[r] = lower[r] + extents[r] - 3; 985 | strides[r] = r + 1; 986 | } 987 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 988 | lower, upper, strides); 989 | for (int i = 0; i < rank; i++) 990 | { 991 | if (section.dim[i].lower_bound != lower[i]) 992 | { 993 | printf ("CFI_section: failed to correctly assign lower " 994 | "bounds.\n"); 995 | return 1; 996 | } 997 | if (section.dim[i].extent != upper[i] - lower[i] + 1) 998 | { 999 | printf ("CFI_section: failed to correctly assign extents.\n"); 1000 | return 1; 1001 | } 1002 | if (section.dim[i].sm != strides[i] * section.elem_len) 1003 | { 1004 | printf ("CFI_section: failed to correctly assign memory " 1005 | "strides.\n"); 1006 | return 1; 1007 | } 1008 | } 1009 | } 1010 | next_type2:; 1011 | } 1012 | 1013 | errno = 1; 1014 | rank = 1; 1015 | CFI_CDESC_T (rank) section, source; 1016 | if (extents != NULL) 1017 | { 1018 | free (extents); 1019 | } 1020 | if (lower != NULL) 1021 | { 1022 | free (lower); 1023 | } 1024 | if (upper != NULL) 1025 | { 1026 | free (upper); 1027 | } 1028 | if (strides != NULL) 1029 | { 1030 | free (strides); 1031 | } 1032 | extents = malloc (rank * sizeof (CFI_index_t)); 1033 | lower = malloc (rank * sizeof (CFI_index_t)); 1034 | upper = malloc (rank * sizeof (CFI_index_t)); 1035 | strides = malloc (rank * sizeof (CFI_index_t)); 1036 | for (int r = 0; r < rank; r++) 1037 | { 1038 | extents[r] = rank - r + 10; 1039 | lower[r] = rank - r - 5; 1040 | upper[r] = lower[r] + extents[r] - 1; 1041 | } 1042 | ind = CFI_establish ((CFI_cdesc_t *) &source, NULL, CFI_attribute_allocatable, 1043 | type[3], elem_len, rank, extents); 1044 | ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, CFI_attribute_other, 1045 | type[3], elem_len, rank, NULL); 1046 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, elem_len); 1047 | if (ind == CFI_SUCCESS) 1048 | { 1049 | for (int r = 0; r < rank; r++) 1050 | { 1051 | lower[r] = rank - r - 3; 1052 | strides[r] = r + 1; 1053 | upper[r] = lower[r] + extents[r] - 3; 1054 | } 1055 | ind = CFI_section ((CFI_cdesc_t *) §ion, NULL, lower, upper, strides); 1056 | if (ind != CFI_INVALID_DESCRIPTOR) 1057 | { 1058 | printf ("CFI_section: failed to detect that source is NULL.\n"); 1059 | return 1; 1060 | } 1061 | ind = CFI_section (NULL, (CFI_cdesc_t *) &source, lower, upper, strides); 1062 | if (ind != CFI_INVALID_DESCRIPTOR) 1063 | { 1064 | printf ("CFI_section: failed to detect that section is NULL.\n"); 1065 | return 1; 1066 | } 1067 | ind = 1068 | CFI_establish ((CFI_cdesc_t *) §ion, NULL, CFI_attribute_allocatable, 1069 | type[3], elem_len, rank, NULL); 1070 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, lower, 1071 | upper, strides); 1072 | if (ind != CFI_INVALID_ATTRIBUTE) 1073 | { 1074 | printf ("CFI_section: failed to detect invalid attribute.\n"); 1075 | return 1; 1076 | } 1077 | ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, CFI_attribute_other, 1078 | type[3], elem_len, rank, NULL); 1079 | ind = CFI_deallocate ((CFI_cdesc_t *) &source); 1080 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, lower, 1081 | upper, strides); 1082 | if (ind != CFI_ERROR_BASE_ADDR_NULL) 1083 | { 1084 | printf ("CFI_section: failed to detect that the base address is NULL.\n"); 1085 | return 1; 1086 | } 1087 | } 1088 | 1089 | CFI_CDESC_T (0) section2, source2; 1090 | ind = CFI_establish ((CFI_cdesc_t *) &source2, &ind, CFI_attribute_other, 1091 | type[3], 0, 0, NULL); 1092 | ind = CFI_establish ((CFI_cdesc_t *) §ion2, &errno, CFI_attribute_other, 1093 | type[3], 0, 0, NULL); 1094 | ind = CFI_section ((CFI_cdesc_t *) §ion2, (CFI_cdesc_t *) &source2, lower, 1095 | upper, strides); 1096 | if (ind != CFI_INVALID_RANK) 1097 | { 1098 | printf ("CFI_section: failed to detect invalid rank.\n"); 1099 | return 1; 1100 | } 1101 | 1102 | ind = CFI_establish ((CFI_cdesc_t *) &source, NULL, CFI_attribute_allocatable, 1103 | type[3], 0, rank, extents); 1104 | ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, CFI_attribute_other, 1105 | type[6], 0, rank, NULL); 1106 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, elem_len); 1107 | if (ind == CFI_SUCCESS) 1108 | { 1109 | for (int r = 0; r < rank; r++) 1110 | { 1111 | lower[r] = rank - r - 3; 1112 | strides[r] = r + 1; 1113 | upper[r] = lower[r] + extents[r] - 3; 1114 | } 1115 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, lower, 1116 | upper, strides); 1117 | if (ind != CFI_INVALID_ELEM_LEN) 1118 | { 1119 | printf ("CFI_section: failed to detect incompatible element lengths " 1120 | "between source and section.\n"); 1121 | return 1; 1122 | } 1123 | ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, CFI_attribute_other, 1124 | CFI_type_long, 0, rank, NULL); 1125 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, lower, 1126 | upper, strides); 1127 | if (ind != CFI_INVALID_TYPE) 1128 | { 1129 | printf ("CFI_section: failed to detect invalid type.\n"); 1130 | return 1; 1131 | } 1132 | } 1133 | 1134 | for (int i = 1; i < CFI_MAX_RANK; i++) 1135 | { 1136 | errno = 1; 1137 | rank = i; 1138 | int ctr = 0; 1139 | CFI_CDESC_T (rank) source; 1140 | if (extents != NULL) 1141 | { 1142 | free (extents); 1143 | } 1144 | if (lower != NULL) 1145 | { 1146 | free (lower); 1147 | } 1148 | if (upper != NULL) 1149 | { 1150 | free (upper); 1151 | } 1152 | if (strides != NULL) 1153 | { 1154 | free (strides); 1155 | } 1156 | extents = malloc (rank * sizeof (CFI_index_t)); 1157 | lower = malloc (rank * sizeof (CFI_index_t)); 1158 | upper = malloc (rank * sizeof (CFI_index_t)); 1159 | strides = malloc (rank * sizeof (CFI_index_t)); 1160 | for (int r = 0; r < rank; r++) 1161 | { 1162 | extents[r] = rank - r + 10; 1163 | lower[r] = rank - r - 5; 1164 | upper[r] = lower[r] + extents[r] - 1; 1165 | } 1166 | ind = 1167 | CFI_establish ((CFI_cdesc_t *) &source, NULL, 1168 | CFI_attribute_allocatable, type[3], 0, rank, extents); 1169 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, elem_len); 1170 | if (ind != CFI_SUCCESS) 1171 | { 1172 | continue; 1173 | } 1174 | for (int r = 0; r < rank; r++) 1175 | { 1176 | lower[r] = rank - r - 3; 1177 | if (r % 2 == 0) 1178 | { 1179 | strides[r] = 0; 1180 | upper[r] = lower[r]; 1181 | ctr++; 1182 | } 1183 | else 1184 | { 1185 | strides[r] = r + 1; 1186 | upper[r] = lower[r] + extents[r] - 3; 1187 | } 1188 | } 1189 | CFI_CDESC_T (rank - ctr) section; 1190 | ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL, CFI_attribute_other, 1191 | type[3], 0, rank - ctr, NULL); 1192 | ind = CFI_section ((CFI_cdesc_t *) §ion, (CFI_cdesc_t *) &source, 1193 | lower, upper, strides); 1194 | ctr = 0; 1195 | for (int r = 0; r < rank; r++) 1196 | { 1197 | if (strides[r] == 0) 1198 | { 1199 | ctr++; 1200 | continue; 1201 | } 1202 | int idx = r - ctr; 1203 | if (section.dim[idx].lower_bound != lower[r]) 1204 | { 1205 | printf ("CFI_section: failed to correctly assign lower bounds in " 1206 | "rank reduction.\n"); 1207 | return 1; 1208 | } 1209 | if (section.dim[idx].extent != upper[r] - lower[r] + 1) 1210 | { 1211 | printf ("CFI_section: failed to correctly assign extents in rank " 1212 | "reduction.\n"); 1213 | return 1; 1214 | } 1215 | if (section.dim[idx].sm != strides[r] * section.elem_len) 1216 | { 1217 | printf ("CFI_section: failed to correctly assign memory strides " 1218 | "in rank reduction.\n"); 1219 | return 1; 1220 | } 1221 | CFI_CDESC_T (rank - ctr - 1) section2; 1222 | ind = CFI_establish ((CFI_cdesc_t *) §ion2, NULL, 1223 | CFI_attribute_other, type[3], 0, rank - ctr - 1, 1224 | NULL); 1225 | ind = CFI_section ((CFI_cdesc_t *) §ion2, (CFI_cdesc_t *) &source, 1226 | lower, upper, strides); 1227 | if (ind != CFI_SUCCESS && ind != CFI_INVALID_RANK) 1228 | { 1229 | printf ("CFI_section: failed to detect invalid rank.\n"); 1230 | return 1; 1231 | } 1232 | } 1233 | } 1234 | 1235 | /* CFI_section negative strides. */ 1236 | errno = 1; 1237 | rank = 8; 1238 | if (extents != NULL) 1239 | { 1240 | free (extents); 1241 | } 1242 | if (lower != NULL) 1243 | { 1244 | free (lower); 1245 | } 1246 | if (upper != NULL) 1247 | { 1248 | free (upper); 1249 | } 1250 | if (strides != NULL) 1251 | { 1252 | free (strides); 1253 | } 1254 | extents = malloc (rank * sizeof (CFI_index_t)); 1255 | lower = malloc (rank * sizeof (CFI_index_t)); 1256 | upper = malloc (rank * sizeof (CFI_index_t)); 1257 | strides = malloc (rank * sizeof (CFI_index_t)); 1258 | for (int r = 0; r < rank; r++) 1259 | { 1260 | extents[r] = rank - r + 10; 1261 | lower[r] = rank - r - 3; 1262 | upper[r] = lower[r] + extents[r] - 3; 1263 | strides[r] = -(r + 1); 1264 | } 1265 | CFI_CDESC_T (rank) section3, source3; 1266 | ind = CFI_establish ((CFI_cdesc_t *) &source3, NULL, 1267 | CFI_attribute_allocatable, type[3], 0, rank, extents); 1268 | ind = CFI_establish ((CFI_cdesc_t *) §ion3, NULL, CFI_attribute_other, 1269 | type[3], 0, rank, NULL); 1270 | ind = CFI_allocate ((CFI_cdesc_t *) &source3, lower, upper, elem_len); 1271 | if (ind == CFI_SUCCESS) 1272 | { 1273 | ind = CFI_section ((CFI_cdesc_t *) §ion3, (CFI_cdesc_t *) &source3, 1274 | upper, lower, strides); 1275 | if (ind != CFI_SUCCESS && ind != CFI_INVALID_STRIDE) 1276 | { 1277 | printf ("CFI_section: failed to detect invalid stride.\n"); 1278 | return 1; 1279 | } 1280 | } 1281 | 1282 | return 0; 1283 | } 1284 | -------------------------------------------------------------------------------- /tests/test-CFI_setpointer.c: -------------------------------------------------------------------------------- 1 | /* 2 | OpenCoarrays is distributed under the OSI-approved BSD 3-clause License: 3 | OpenCoarrays -- ISO_Fortran_binding standard-compliant interoperability with 4 | C. 5 | Copyright (c) 2018, Sourcery, Inc. 6 | Copyright (c) 2018, Sourcery Institute 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright notice, 13 | this list of conditions and the following disclaimer. 14 | 2. Redistributions in binary form must reproduce the above copyright notice, 15 | this list of conditions and the following disclaimer in the documentation 16 | and/or other materials provided with the distribution. 17 | 3. Neither the names of the copyright holders nor the names of their 18 | contributors may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE 25 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | #include "ISO_Fortran_binding.h" 35 | #include 36 | #include 37 | #include 38 | 39 | int main (void) 40 | { 41 | 42 | CFI_rank_t rank; 43 | CFI_attribute_t attribute; 44 | CFI_type_t type[10] = {CFI_type_Bool, CFI_type_short, 45 | CFI_type_ucs4_char, CFI_type_double, 46 | CFI_type_float128, CFI_type_float128_Complex, 47 | CFI_type_long_double, CFI_type_long_double_Complex, 48 | CFI_type_struct, CFI_type_other}; 49 | size_t elem_len; 50 | int ind; 51 | size_t base_type; 52 | size_t base_type_size; 53 | size_t errno; 54 | 55 | /* Test function establish. */ 56 | /* Fresh descriptor, base address is NULL. */ 57 | /* Loop through type. */ 58 | for (int i = 0; i < 10; i++) 59 | { 60 | elem_len = 0; 61 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 62 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 63 | type[i] == CFI_type_other) 64 | { 65 | base_type = type[i]; 66 | base_type_size = elem_len; 67 | } 68 | else 69 | { 70 | base_type = type[i] & CFI_type_mask; 71 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 72 | } 73 | /* Loop through attribute. */ 74 | for (int j = 1; j <= 3; j++) 75 | { 76 | attribute = j; 77 | /* Loop through rank. */ 78 | for (int k = 0; k <= CFI_MAX_RANK; k++) 79 | { 80 | errno = 1; 81 | rank = k; 82 | CFI_CDESC_T (rank) test1; 83 | /* We do this because C sometimes doesn't make the structures with 84 | * a null base_addr which leads to weird behaviour inside 85 | * CFI_establish. 86 | */ 87 | if (test1.base_addr != NULL) 88 | { 89 | test1.base_addr = NULL; 90 | free (test1.base_addr); 91 | } 92 | ind = CFI_establish ((CFI_cdesc_t *) &test1, NULL, attribute, 93 | type[i], elem_len, rank, NULL); 94 | if (ind != CFI_SUCCESS) 95 | { 96 | goto next_attribute1; 97 | } 98 | if (attribute != test1.attribute) 99 | { 100 | printf ("CFI_establish: failed to assign attribute.\n"); 101 | return 1; 102 | } 103 | if (type[i] != test1.type) 104 | { 105 | printf ("CFI_establish: failed to assign type.\n"); 106 | return 1; 107 | } 108 | if (rank != test1.rank) 109 | { 110 | printf ("CFI_establish: failed to assign rank.\n"); 111 | return 1; 112 | } 113 | elem_len = base_type_size; 114 | if (base_type_size == 10) 115 | { 116 | elem_len = 64; 117 | } 118 | if (base_type == CFI_type_Complex) 119 | { 120 | elem_len *= 2; 121 | } 122 | if (elem_len != test1.elem_len) 123 | { 124 | printf ("CFI_establish: failed to assign element length.\n"); 125 | return 1; 126 | } 127 | } 128 | next_attribute1:; 129 | } 130 | } 131 | 132 | /* Fresh descriptor, base address is not NULL */ 133 | CFI_index_t *extents = NULL; 134 | /* Loop through type. */ 135 | for (int i = 0; i < 10; i++) 136 | { 137 | elem_len = 0; 138 | if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 139 | type[i] == CFI_type_signed_char || type[i] == CFI_type_struct || 140 | type[i] == CFI_type_other) 141 | { 142 | base_type = type[i]; 143 | base_type_size = elem_len; 144 | } 145 | else 146 | { 147 | base_type = type[i] & CFI_type_mask; 148 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 149 | } 150 | /* Loop through attribute. */ 151 | for (int j = 1; j <= 3; j++) 152 | { 153 | attribute = j; 154 | /* Loop through rank. */ 155 | for (int k = 0; k <= CFI_MAX_RANK; k++) 156 | { 157 | errno = 1; 158 | rank = k; 159 | if (extents != NULL) 160 | { 161 | free (extents); 162 | } 163 | extents = malloc (rank * sizeof (CFI_index_t)); 164 | for (int r = 0; r < rank; r++) 165 | { 166 | extents[r] = r + 1; 167 | } 168 | CFI_CDESC_T (rank) test2; 169 | /* We do this because C sometimes doesn't make the structures with 170 | * a null base_addr which leads to weird behaviour inside 171 | * CFI_establish. 172 | */ 173 | if (test2.base_addr != NULL) 174 | { 175 | test2.base_addr = NULL; 176 | free (test2.base_addr); 177 | } 178 | ind = CFI_establish ((CFI_cdesc_t *) &test2, &ind, attribute, 179 | type[i], elem_len, rank, extents); 180 | if (ind != CFI_SUCCESS) 181 | { 182 | goto next_attribute2; 183 | } 184 | if (attribute != test2.attribute) 185 | { 186 | printf ("CFI_establish: failed to assign attribute.\n"); 187 | return 1; 188 | } 189 | if (type[i] != test2.type) 190 | { 191 | printf ("CFI_establish: failed to assign type.\n"); 192 | return 1; 193 | } 194 | if (rank != test2.rank) 195 | { 196 | printf ("CFI_establish: failed to assign rank.\n"); 197 | return 1; 198 | } 199 | 200 | elem_len = base_type_size; 201 | if (base_type_size == 10) 202 | { 203 | elem_len = 64; 204 | } 205 | if (base_type == CFI_type_Complex) 206 | { 207 | elem_len *= 2; 208 | } 209 | if (elem_len != test2.elem_len) 210 | { 211 | printf ("CFI_establish: failed to assign element length.\n"); 212 | return 1; 213 | } 214 | 215 | for (int r = 0; r < rank; r++) 216 | { 217 | if (extents[r] != test2.dim[r].extent) 218 | { 219 | printf ("CFI_establish: failed to assign dimension " 220 | "extents.\n"); 221 | return 1; 222 | } 223 | } 224 | 225 | if (attribute == CFI_attribute_pointer) 226 | { 227 | for (int r = 0; r < rank; r++) 228 | { 229 | if (test2.dim[r].lower_bound != 0) 230 | { 231 | printf ("CFI_establish: failed to assign dimension " 232 | "lower bounds.\n"); 233 | return 1; 234 | } 235 | } 236 | } 237 | } 238 | next_attribute2:; 239 | } 240 | } 241 | 242 | /* Fresh descriptor, base address is not NULL */ 243 | CFI_index_t *lower = NULL; 244 | CFI_index_t *upper = NULL; 245 | /* Loop through type. */ 246 | for (int i = 0; i < 10; i++) 247 | { 248 | elem_len = 0; 249 | if (type[i] == CFI_type_struct) 250 | { 251 | base_type = type[i]; 252 | base_type_size = 69; 253 | } 254 | else if (type[i] == CFI_type_other) 255 | { 256 | base_type = type[i]; 257 | base_type_size = 666; 258 | } 259 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 260 | type[i] == CFI_type_signed_char) 261 | { 262 | base_type = type[i] & CFI_type_mask; 263 | base_type_size = 3; 264 | } 265 | else 266 | { 267 | base_type = type[i] & CFI_type_mask; 268 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 269 | } 270 | 271 | elem_len = base_type_size; 272 | if (base_type_size == 10) 273 | { 274 | elem_len = 64; 275 | } 276 | if (base_type == CFI_type_Complex) 277 | { 278 | elem_len *= 2; 279 | } 280 | /* Loop through attribute. */ 281 | for (int j = 1; j <= 3; j++) 282 | { 283 | attribute = j; 284 | /* Loop through rank. */ 285 | for (int k = 0; k <= CFI_MAX_RANK; k++) 286 | { 287 | errno = 1; 288 | rank = k; 289 | if (extents != NULL) 290 | { 291 | free (extents); 292 | } 293 | if (lower != NULL) 294 | { 295 | free (lower); 296 | } 297 | if (upper != NULL) 298 | { 299 | free (upper); 300 | } 301 | extents = malloc (rank * sizeof (CFI_index_t)); 302 | lower = malloc (rank * sizeof (CFI_index_t)); 303 | upper = malloc (rank * sizeof (CFI_index_t)); 304 | for (int r = 0; r < rank; r++) 305 | { 306 | extents[r] = 2; 307 | lower[r] = r; 308 | upper[r] = lower[r] + extents[r]; 309 | } 310 | CFI_CDESC_T (rank) test3; 311 | /* We do this because C sometimes doesn't make the structures with 312 | * a null base_addr which leads to weird behaviour inside 313 | * CFI_establish. 314 | */ 315 | if (test3.base_addr != NULL) 316 | { 317 | test3.base_addr = NULL; 318 | free (test3.base_addr); 319 | } 320 | ind = CFI_establish ((CFI_cdesc_t *) &test3, NULL, attribute, 321 | type[i], elem_len, rank, extents); 322 | ind = 323 | CFI_allocate ((CFI_cdesc_t *) &test3, lower, upper, elem_len); 324 | if (ind != CFI_SUCCESS) 325 | { 326 | goto next_attribute3; 327 | } 328 | for (int r = 0; r < rank; r++) 329 | { 330 | if (lower[r] != test3.dim[r].lower_bound) 331 | { 332 | printf ("CFI_allocate: failed to reassign dimension " 333 | "lower bounds.\n"); 334 | return 1; 335 | } 336 | if (upper[r] - test3.dim[r].lower_bound + 1 != 337 | test3.dim[r].extent) 338 | { 339 | printf ("CFI_allocate: failed to reassign dimension " 340 | "extents.\n"); 341 | return 1; 342 | } 343 | if (test3.dim[r].sm != test3.elem_len) 344 | { 345 | printf ( 346 | "CFI_allocate: failed to assign dimension stride.\n"); 347 | return 1; 348 | } 349 | } 350 | if (elem_len != test3.elem_len) 351 | { 352 | printf ("CFI_allocate: failed to reassign element length.\n"); 353 | return 1; 354 | } 355 | } 356 | next_attribute3:; 357 | } 358 | } 359 | 360 | rank = 1; 361 | errno = 1; 362 | CFI_CDESC_T (rank) test4; 363 | base_type = type[3] & CFI_type_mask; 364 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 365 | attribute = CFI_attribute_allocatable; 366 | ind = CFI_establish ((CFI_cdesc_t *) &test4, NULL, attribute, type[3], 367 | elem_len, rank, NULL); 368 | ind = CFI_allocate ((CFI_cdesc_t *) &test4, NULL, NULL, base_type_size); 369 | if (ind != CFI_INVALID_EXTENT) 370 | { 371 | printf ("CFI_allocate: failed to detect invalid extents.\n"); 372 | return 1; 373 | } 374 | 375 | rank = 1; 376 | errno = 1; 377 | CFI_CDESC_T (rank) test5; 378 | base_type = type[3] & CFI_type_mask; 379 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 380 | attribute = CFI_attribute_pointer; 381 | ind = CFI_establish ((CFI_cdesc_t *) &test5, &ind, attribute, type[3], 382 | elem_len, rank, extents); 383 | ind = CFI_allocate ((CFI_cdesc_t *) &test5, NULL, NULL, base_type_size); 384 | if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) 385 | { 386 | printf ("CFI_allocate: failed to detect base address is not NULL.\n"); 387 | return 1; 388 | } 389 | 390 | /* Test CFI_deallocate. */ 391 | rank = 1; 392 | errno = 1; 393 | base_type = type[3] & CFI_type_mask; 394 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 395 | for (int i = 1; i <= 3; i++) 396 | { 397 | attribute = i; 398 | if (extents != NULL) 399 | { 400 | free (extents); 401 | } 402 | if (lower != NULL) 403 | { 404 | free (lower); 405 | } 406 | if (upper != NULL) 407 | { 408 | free (upper); 409 | } 410 | extents = malloc (rank * sizeof (CFI_index_t)); 411 | lower = malloc (rank * sizeof (CFI_index_t)); 412 | upper = malloc (rank * sizeof (CFI_index_t)); 413 | CFI_CDESC_T (rank) test6; 414 | ind = CFI_establish ((CFI_cdesc_t *) &test6, NULL, attribute, type[i], 415 | elem_len, rank, extents); 416 | ind = CFI_allocate ((CFI_cdesc_t *) &test6, lower, upper, base_type_size); 417 | if (ind == CFI_SUCCESS) 418 | { 419 | ind = CFI_deallocate ((CFI_cdesc_t *) &test6); 420 | if (ind != CFI_INVALID_ATTRIBUTE && test6.base_addr != NULL) 421 | { 422 | printf ("CFI_deallocate: failed to deallocate memory.\n"); 423 | return 1; 424 | } 425 | } 426 | } 427 | 428 | /* Test CFI_is_contiguous. */ 429 | int tmp_ind; 430 | base_type = type[3] & CFI_type_mask; 431 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 432 | for (int i = 1; i <= 3; i++) 433 | { 434 | attribute = i; 435 | for (int j = 0; j <= 4; j++) 436 | { 437 | errno = 1; 438 | rank = j; 439 | if (extents != NULL) 440 | { 441 | free (extents); 442 | } 443 | if (lower != NULL) 444 | { 445 | free (lower); 446 | } 447 | if (upper != NULL) 448 | { 449 | free (upper); 450 | } 451 | extents = malloc (rank * sizeof (CFI_index_t)); 452 | lower = malloc (rank * sizeof (CFI_index_t)); 453 | upper = malloc (rank * sizeof (CFI_index_t)); 454 | for (int r = 0; r < rank; r++) 455 | { 456 | extents[r] = 2; 457 | lower[r] = r; 458 | upper[r] = lower[r] + extents[r]; 459 | } 460 | CFI_CDESC_T (rank) test7; 461 | ind = CFI_establish ((CFI_cdesc_t *) &test7, NULL, attribute, type[3], 462 | elem_len, rank, extents); 463 | tmp_ind = CFI_allocate ((CFI_cdesc_t *) &test7, lower, upper, 464 | base_type_size); 465 | if (tmp_ind != CFI_SUCCESS) 466 | { 467 | goto next_attribute4; 468 | } 469 | ind = CFI_is_contiguous ((CFI_cdesc_t *) &test7); 470 | if (ind != CFI_INVALID_RANK && rank == 0 && 471 | tmp_ind != CFI_INVALID_ATTRIBUTE) 472 | { 473 | printf ("CFI_is_contiguous: failed to detect incorrect rank.\n"); 474 | return 1; 475 | } 476 | else if (ind == CFI_ERROR_BASE_ADDR_NULL && test7.base_addr != NULL && 477 | tmp_ind != CFI_SUCCESS) 478 | { 479 | printf ("CFI_is_contiguous: failed to detect base address is not " 480 | "NULL.\n"); 481 | return 1; 482 | } 483 | } 484 | next_attribute4:; 485 | } 486 | 487 | /* Test CFI_address. */ 488 | CFI_index_t *tr_subscripts; 489 | CFI_dim_t * tr_dim; 490 | /* Loop through type. */ 491 | for (int i = 0; i < 10; i++) 492 | { 493 | elem_len = 0; 494 | if (type[i] == CFI_type_struct) 495 | { 496 | base_type = type[i]; 497 | base_type_size = 69; 498 | } 499 | else if (type[i] == CFI_type_other) 500 | { 501 | base_type = type[i]; 502 | base_type_size = 666; 503 | } 504 | else if (type[i] == CFI_type_char || type[i] == CFI_type_ucs4_char || 505 | type[i] == CFI_type_signed_char) 506 | { 507 | base_type = type[i] & CFI_type_mask; 508 | base_type_size = 3; 509 | } 510 | else 511 | { 512 | base_type = type[i] & CFI_type_mask; 513 | base_type_size = (type[i] - base_type) >> CFI_type_kind_shift; 514 | } 515 | 516 | elem_len = base_type_size; 517 | if (base_type_size == 10) 518 | { 519 | elem_len = 64; 520 | } 521 | if (base_type == CFI_type_Complex) 522 | { 523 | elem_len *= 2; 524 | } 525 | /* Loop through attribute. */ 526 | for (int j = 1; j <= 3; j++) 527 | { 528 | attribute = j; 529 | /* Loop through rank. */ 530 | for (int k = 1; k <= CFI_MAX_RANK; k++) 531 | { 532 | errno = 1; 533 | rank = k; 534 | CFI_CDESC_T (rank) source; 535 | if (extents != NULL) 536 | { 537 | free (extents); 538 | } 539 | if (lower != NULL) 540 | { 541 | free (lower); 542 | } 543 | if (upper != NULL) 544 | { 545 | free (upper); 546 | } 547 | extents = malloc (rank * sizeof (CFI_index_t)); 548 | lower = malloc (rank * sizeof (CFI_index_t)); 549 | upper = malloc (rank * sizeof (CFI_index_t)); 550 | for (int r = 0; r < rank; r++) 551 | { 552 | extents[r] = rank - r + 1; 553 | lower[r] = rank - r - 3; 554 | upper[r] = lower[r] + extents[r] - 1; 555 | } 556 | ind = CFI_establish ((CFI_cdesc_t *) &source, NULL, 557 | CFI_attribute_allocatable, type[i], elem_len, 558 | rank, extents); 559 | ind = CFI_allocate ((CFI_cdesc_t *) &source, lower, upper, 560 | elem_len); 561 | if (ind == CFI_SUCCESS) 562 | { 563 | CFI_index_t dif_addr; 564 | CFI_index_t n_entries = 1; 565 | dif_addr = (CFI_index_t) ( 566 | (char *) CFI_address ((CFI_cdesc_t *) &source, upper) - 567 | (char *) CFI_address ((CFI_cdesc_t *) &source, lower)); 568 | for (int r = 0; r < rank; r++) 569 | { 570 | n_entries = n_entries * (upper[r] - lower[r] + 1); 571 | } 572 | tr_subscripts = malloc (rank * sizeof (CFI_index_t)); 573 | tr_dim = malloc (rank * sizeof (CFI_dim_t)); 574 | for (int i = 0; i < rank; i++) 575 | { 576 | CFI_index_t idx = rank - i - 1; 577 | tr_subscripts[i] = upper[idx]; 578 | tr_dim[i] = source.dim[idx]; 579 | /* Normalise the subscripts to start counting the address 580 | * from 0. */ 581 | tr_subscripts[i] -= tr_dim[i].lower_bound; 582 | } 583 | /* We assume column major order as that is how Fortran stores 584 | * arrays. We 585 | * calculate the memory address of the specified element via 586 | * the canonical 587 | * array dimension reduction map and multiplying by the memory 588 | * stride. */ 589 | CFI_index_t index = tr_subscripts[0] * tr_dim[0].sm; 590 | CFI_index_t tmp_index = 1; 591 | for (int i = 1; i < rank; i++) 592 | { 593 | tmp_index *= tr_subscripts[i] * tr_dim[i - 1].extent * 594 | tr_dim[i - 1].sm; 595 | index += tmp_index; 596 | } 597 | free (tr_subscripts); 598 | free (tr_dim); 599 | if (index - dif_addr != 0) 600 | { 601 | printf ("CFI_address: difference in address is not being " 602 | "properly calculated.\n"); 603 | return 1; 604 | } 605 | } 606 | else if (ind == CFI_ERROR_MEM_ALLOCATION) 607 | { 608 | goto next_type; 609 | } 610 | } 611 | } 612 | next_type:; 613 | } 614 | 615 | /* Test CFI_setpointer */ 616 | for (int i = 0; i < CFI_MAX_RANK; i++) 617 | { 618 | rank = i; 619 | errno = 1; 620 | base_type = type[3] & CFI_type_mask; 621 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 622 | attribute = CFI_attribute_other; 623 | CFI_CDESC_T (rank) test8a, test8b; 624 | 625 | if (extents != NULL) 626 | { 627 | free (extents); 628 | } 629 | if (lower != NULL) 630 | { 631 | free (lower); 632 | } 633 | extents = malloc (rank * sizeof (CFI_index_t)); 634 | lower = malloc (rank * sizeof (CFI_index_t)); 635 | for (int r = 0; r < rank; r++) 636 | { 637 | extents[r] = r + 1; 638 | lower[r] = r - 2; 639 | } 640 | ind = CFI_establish ((CFI_cdesc_t *) &test8a, &ind, attribute, type[3], 641 | base_type_size, rank, extents); 642 | for (int r = 0; r < rank; r++) 643 | { 644 | extents[r] = r + 2; 645 | } 646 | ind = CFI_establish ((CFI_cdesc_t *) &test8b, &errno, attribute, type[3], 647 | base_type_size, rank, extents); 648 | ind = CFI_setpointer ((CFI_cdesc_t *) &test8a, (CFI_cdesc_t *) &test8b, 649 | lower); 650 | for (int r = 0; r < rank; r++) 651 | { 652 | if (test8a.dim[r].lower_bound != lower[r]) 653 | { 654 | printf ("CFI_setpointer: failed to reassign lower bounds.\n"); 655 | return 1; 656 | } 657 | if (test8a.dim[r].extent != test8b.dim[r].extent) 658 | { 659 | printf ("CFI_setpointer: failed to reassign extents.\n"); 660 | return 1; 661 | } 662 | if (test8a.dim[r].sm != test8b.dim[r].sm) 663 | { 664 | printf ("CFI_setpointer: failed to reassign memory strides.\n"); 665 | return 1; 666 | } 667 | } 668 | if (test8a.base_addr != test8b.base_addr) 669 | { 670 | printf ("CFI_setpointer: failed to reassign base address.\n"); 671 | return 1; 672 | } 673 | if (test8a.version != test8b.version) 674 | { 675 | printf ("CFI_setpointer: failed to reassign lower bounds.\n"); 676 | return 1; 677 | } 678 | if (test8a.attribute != test8b.attribute) 679 | { 680 | printf ("CFI_setpointer: failed to reassign attribute.\n"); 681 | return 1; 682 | } 683 | } 684 | 685 | /* NULL source. */ 686 | rank = 10; 687 | errno = 1; 688 | base_type = type[3] & CFI_type_mask; 689 | base_type_size = (type[3] - base_type) >> CFI_type_kind_shift; 690 | CFI_CDESC_T (rank) test9; 691 | 692 | if (extents != NULL) 693 | { 694 | free (extents); 695 | } 696 | if (lower != NULL) 697 | { 698 | free (lower); 699 | } 700 | extents = malloc (rank * sizeof (CFI_index_t)); 701 | lower = malloc (rank * sizeof (CFI_index_t)); 702 | for (int r = 0; r < rank; r++) 703 | { 704 | extents[r] = r + 1; 705 | lower[r] = r - 2; 706 | } 707 | ind = CFI_establish ((CFI_cdesc_t *) &test9, &ind, attribute, type[3], 708 | base_type_size, rank, extents); 709 | ind = CFI_setpointer ((CFI_cdesc_t *) &test9, NULL, lower); 710 | if (test9.attribute != CFI_attribute_pointer) 711 | { 712 | printf ("CFI_setpointer: failed to set attribute pointer.\n"); 713 | return 1; 714 | } 715 | if (test9.base_addr != NULL) 716 | { 717 | printf ("CFI_setpointer: failed to set base address to NULL.\n"); 718 | return 1; 719 | } 720 | 721 | rank = 3; 722 | errno = 1; 723 | attribute = CFI_attribute_other; 724 | CFI_CDESC_T (rank) test10a, test10b; 725 | if (extents != NULL) 726 | { 727 | free (extents); 728 | } 729 | if (lower != NULL) 730 | { 731 | free (lower); 732 | } 733 | extents = malloc (rank * sizeof (CFI_index_t)); 734 | lower = malloc (rank * sizeof (CFI_index_t)); 735 | for (int r = 0; r < rank; r++) 736 | { 737 | extents[r] = r + 1; 738 | lower[r] = r - 2; 739 | } 740 | base_type = CFI_type_long & CFI_type_mask; 741 | base_type_size = (CFI_type_long - base_type) >> CFI_type_kind_shift; 742 | ind = CFI_establish ((CFI_cdesc_t *) &test10a, &ind, attribute, CFI_type_long, 743 | base_type_size, rank, extents); 744 | for (int r = 0; r < rank; r++) 745 | { 746 | extents[r] = r + 2; 747 | } 748 | base_type = CFI_type_double & CFI_type_mask; 749 | base_type_size = (CFI_type_double - base_type) >> CFI_type_kind_shift; 750 | ind = CFI_establish ((CFI_cdesc_t *) &test10b, &errno, attribute, 751 | CFI_type_double, base_type_size, rank, extents); 752 | ind = CFI_setpointer ((CFI_cdesc_t *) &test10a, (CFI_cdesc_t *) &test10b, 753 | lower); 754 | if (ind != CFI_INVALID_TYPE) 755 | { 756 | printf ("CFI_setpointer: failed to detect invalid type.\n"); 757 | return 1; 758 | } 759 | 760 | errno = 1; 761 | base_type = CFI_type_other & CFI_type_mask; 762 | base_type_size = 666; 763 | ind = CFI_establish ((CFI_cdesc_t *) &test10a, &ind, attribute, 764 | CFI_type_other, base_type_size, rank, extents); 765 | base_type = CFI_type_other & CFI_type_mask; 766 | base_type_size = 69; 767 | ind = CFI_establish ((CFI_cdesc_t *) &test10b, &errno, attribute, 768 | CFI_type_other, base_type_size, rank, extents); 769 | ind = CFI_setpointer ((CFI_cdesc_t *) &test10a, (CFI_cdesc_t *) &test10b, 770 | lower); 771 | if (ind != CFI_INVALID_ELEM_LEN) 772 | { 773 | printf ("CFI_setpointer: failed to detect invalid element length.\n"); 774 | return 1; 775 | } 776 | 777 | errno = 1; 778 | base_type = type[3] & CFI_type_mask; 779 | base_type_size = (CFI_type_long - base_type) >> CFI_type_kind_shift; 780 | ind = CFI_establish ((CFI_cdesc_t *) &test10a, &ind, attribute, type[3], 781 | base_type_size, rank, extents); 782 | rank++; 783 | CFI_CDESC_T (rank) test10c; 784 | if (extents != NULL) 785 | { 786 | free (extents); 787 | } 788 | if (lower != NULL) 789 | { 790 | free (lower); 791 | } 792 | extents = malloc (rank * sizeof (CFI_index_t)); 793 | lower = malloc (rank * sizeof (CFI_index_t)); 794 | for (int r = 0; r < rank; r++) 795 | { 796 | extents[r] = r + 1; 797 | lower[r] = r - 2; 798 | } 799 | base_type = CFI_type_other & CFI_type_mask; 800 | base_type_size = (CFI_type_long - base_type) >> CFI_type_kind_shift; 801 | ind = CFI_establish ((CFI_cdesc_t *) &test10c, &errno, attribute, type[3], 802 | base_type_size, rank, extents); 803 | ind = CFI_setpointer ((CFI_cdesc_t *) &test10a, (CFI_cdesc_t *) &test10c, 804 | lower); 805 | if (ind != CFI_INVALID_RANK) 806 | { 807 | printf ("CFI_setpointer: failed to detect invalid rank.\n"); 808 | return 1; 809 | } 810 | 811 | return 0; 812 | } 813 | --------------------------------------------------------------------------------