1/* Implementation of the ANY intrinsic 2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24<http://www.gnu.org/licenses/>. */ 25 26#include "libgfortran.h" 27 28 29#if defined (HAVE_GFC_LOGICAL_4) 30 31 32extern void any_l4 (gfc_array_l4 * const restrict, 33 gfc_array_l1 * const restrict, const index_type * const restrict); 34export_proto(any_l4); 35 36void 37any_l4 (gfc_array_l4 * const restrict retarray, 38 gfc_array_l1 * const restrict array, 39 const index_type * const restrict pdim) 40{ 41 index_type count[GFC_MAX_DIMENSIONS]; 42 index_type extent[GFC_MAX_DIMENSIONS]; 43 index_type sstride[GFC_MAX_DIMENSIONS]; 44 index_type dstride[GFC_MAX_DIMENSIONS]; 45 const GFC_LOGICAL_1 * restrict base; 46 GFC_LOGICAL_4 * restrict dest; 47 index_type rank; 48 index_type n; 49 index_type len; 50 index_type delta; 51 index_type dim; 52 int src_kind; 53 int continue_loop; 54 55 /* Make dim zero based to avoid confusion. */ 56 dim = (*pdim) - 1; 57 rank = GFC_DESCRIPTOR_RANK (array) - 1; 58 59 src_kind = GFC_DESCRIPTOR_SIZE (array); 60 61 len = GFC_DESCRIPTOR_EXTENT(array,dim); 62 if (len < 0) 63 len = 0; 64 65 delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 66 67 for (n = 0; n < dim; n++) 68 { 69 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); 70 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 71 72 if (extent[n] < 0) 73 extent[n] = 0; 74 } 75 for (n = dim; n < rank; n++) 76 { 77 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); 78 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); 79 80 if (extent[n] < 0) 81 extent[n] = 0; 82 } 83 84 if (retarray->base_addr == NULL) 85 { 86 size_t alloc_size, str; 87 88 for (n = 0; n < rank; n++) 89 { 90 if (n == 0) 91 str = 1; 92 else 93 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 94 95 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 96 97 } 98 99 retarray->offset = 0; 100 retarray->dtype.rank = rank; 101 102 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 103 104 if (alloc_size == 0) 105 { 106 /* Make sure we have a zero-sized array. */ 107 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 108 return; 109 } 110 else 111 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_LOGICAL_4)); 112 } 113 else 114 { 115 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 116 runtime_error ("rank of return array incorrect in" 117 " ANY intrinsic: is %ld, should be %ld", 118 (long int) GFC_DESCRIPTOR_RANK (retarray), 119 (long int) rank); 120 121 if (unlikely (compile_options.bounds_check)) 122 { 123 for (n=0; n < rank; n++) 124 { 125 index_type ret_extent; 126 127 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 128 if (extent[n] != ret_extent) 129 runtime_error ("Incorrect extent in return value of" 130 " ANY intrinsic in dimension %d:" 131 " is %ld, should be %ld", (int) n + 1, 132 (long int) ret_extent, (long int) extent[n]); 133 } 134 } 135 } 136 137 for (n = 0; n < rank; n++) 138 { 139 count[n] = 0; 140 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 141 if (extent[n] <= 0) 142 return; 143 } 144 145 base = array->base_addr; 146 147 if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 148#ifdef HAVE_GFC_LOGICAL_16 149 || src_kind == 16 150#endif 151 ) 152 { 153 if (base) 154 base = GFOR_POINTER_TO_L1 (base, src_kind); 155 } 156 else 157 internal_error (NULL, "Funny sized logical array in ANY intrinsic"); 158 159 dest = retarray->base_addr; 160 161 continue_loop = 1; 162 while (continue_loop) 163 { 164 const GFC_LOGICAL_1 * restrict src; 165 GFC_LOGICAL_4 result; 166 src = base; 167 { 168 169 result = 0; 170 if (len <= 0) 171 *dest = 0; 172 else 173 { 174 for (n = 0; n < len; n++, src += delta) 175 { 176 177 /* Return true if any of the elements are set. */ 178 if (*src) 179 { 180 result = 1; 181 break; 182 } 183 } 184 *dest = result; 185 } 186 } 187 /* Advance to the next element. */ 188 count[0]++; 189 base += sstride[0]; 190 dest += dstride[0]; 191 n = 0; 192 while (count[n] == extent[n]) 193 { 194 /* When we get to the end of a dimension, reset it and increment 195 the next dimension. */ 196 count[n] = 0; 197 /* We could precalculate these products, but this is a less 198 frequently used path so probably not worth it. */ 199 base -= sstride[n] * extent[n]; 200 dest -= dstride[n] * extent[n]; 201 n++; 202 if (n >= rank) 203 { 204 /* Break out of the loop. */ 205 continue_loop = 0; 206 break; 207 } 208 else 209 { 210 count[n]++; 211 base += sstride[n]; 212 dest += dstride[n]; 213 } 214 } 215 } 216} 217 218#endif 219