1`/* Implementation of the FINDLOC intrinsic 2 Copyright (C) 2018-2022 Free Software Foundation, Inc. 3 Contributed by Thomas König <tk@tkoenig.net> 4 5This file is part of the GNU Fortran 95 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#include <assert.h> 28 29#if defined (HAVE_'atype_name`) 30'header1` 31{ 32 index_type count[GFC_MAX_DIMENSIONS]; 33 index_type extent[GFC_MAX_DIMENSIONS]; 34 index_type sstride[GFC_MAX_DIMENSIONS]; 35 index_type dstride; 36 const 'atype_name` *base; 37 index_type * restrict dest; 38 index_type rank; 39 index_type n; 40 index_type sz; 41 42 rank = GFC_DESCRIPTOR_RANK (array); 43 if (rank <= 0) 44 runtime_error ("Rank of array needs to be > 0"); 45 46 if (retarray->base_addr == NULL) 47 { 48 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 49 retarray->dtype.rank = 1; 50 retarray->offset = 0; 51 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 52 } 53 else 54 { 55 if (unlikely (compile_options.bounds_check)) 56 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 57 "FINDLOC"); 58 } 59 60 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 61 dest = retarray->base_addr; 62 63 /* Set the return value. */ 64 for (n = 0; n < rank; n++) 65 dest[n * dstride] = 0; 66 67 sz = 1; 68 for (n = 0; n < rank; n++) 69 { 70 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 71 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 72 sz *= extent[n]; 73 if (extent[n] <= 0) 74 return; 75 } 76 77 for (n = 0; n < rank; n++) 78 count[n] = 0; 79 80 if (back) 81 { 82 base = array->base_addr + (sz - 1) * 'base_mult`'`; 83 84 while (1) 85 { 86 do 87 { 88 if (unlikely('comparison`)) 89 { 90 for (n = 0; n < rank; n++) 91 dest[n * dstride] = extent[n] - count[n]; 92 93 return; 94 } 95 base -= sstride[0] * 'base_mult`'`; 96 } while(++count[0] != extent[0]); 97 98 n = 0; 99 do 100 { 101 /* When we get to the end of a dimension, reset it and increment 102 the next dimension. */ 103 count[n] = 0; 104 /* We could precalculate these products, but this is a less 105 frequently used path so probably not worth it. */ 106 base += sstride[n] * extent[n] * 'base_mult`'`; 107 n++; 108 if (n >= rank) 109 return; 110 else 111 { 112 count[n]++; 113 base -= sstride[n] * 'base_mult`'`; 114 } 115 } while (count[n] == extent[n]); 116 } 117 } 118 else 119 { 120 base = array->base_addr; 121 while (1) 122 { 123 do 124 { 125 if (unlikely('comparison`)) 126 { 127 for (n = 0; n < rank; n++) 128 dest[n * dstride] = count[n] + 1; 129 130 return; 131 } 132 base += sstride[0] * 'base_mult`'`; 133 } while(++count[0] != extent[0]); 134 135 n = 0; 136 do 137 { 138 /* When we get to the end of a dimension, reset it and increment 139 the next dimension. */ 140 count[n] = 0; 141 /* We could precalculate these products, but this is a less 142 frequently used path so probably not worth it. */ 143 base -= sstride[n] * extent[n] * 'base_mult`'`; 144 n++; 145 if (n >= rank) 146 return; 147 else 148 { 149 count[n]++; 150 base += sstride[n] * 'base_mult`'`; 151 } 152 } while (count[n] == extent[n]); 153 } 154 } 155 return; 156} 157 158'header2` 159{ 160 index_type count[GFC_MAX_DIMENSIONS]; 161 index_type extent[GFC_MAX_DIMENSIONS]; 162 index_type sstride[GFC_MAX_DIMENSIONS]; 163 index_type mstride[GFC_MAX_DIMENSIONS]; 164 index_type dstride; 165 const 'atype_name` *base; 166 index_type * restrict dest; 167 GFC_LOGICAL_1 *mbase; 168 index_type rank; 169 index_type n; 170 int mask_kind; 171 index_type sz; 172 173 rank = GFC_DESCRIPTOR_RANK (array); 174 if (rank <= 0) 175 runtime_error ("Rank of array needs to be > 0"); 176 177 if (retarray->base_addr == NULL) 178 { 179 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 180 retarray->dtype.rank = 1; 181 retarray->offset = 0; 182 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 183 } 184 else 185 { 186 if (unlikely (compile_options.bounds_check)) 187 { 188 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 189 "FINDLOC"); 190 bounds_equal_extents ((array_t *) mask, (array_t *) array, 191 "MASK argument", "FINDLOC"); 192 } 193 } 194 195 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 196 197 mbase = mask->base_addr; 198 199 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 200#ifdef HAVE_GFC_LOGICAL_16 201 || mask_kind == 16 202#endif 203 ) 204 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 205 else 206 internal_error (NULL, "Funny sized logical array"); 207 208 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 209 dest = retarray->base_addr; 210 211 /* Set the return value. */ 212 for (n = 0; n < rank; n++) 213 dest[n * dstride] = 0; 214 215 sz = 1; 216 for (n = 0; n < rank; n++) 217 { 218 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 219 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 220 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 221 sz *= extent[n]; 222 if (extent[n] <= 0) 223 return; 224 } 225 226 for (n = 0; n < rank; n++) 227 count[n] = 0; 228 229 if (back) 230 { 231 base = array->base_addr + (sz - 1) * 'base_mult`'`; 232 mbase = mbase + (sz - 1) * mask_kind; 233 while (1) 234 { 235 do 236 { 237 if (unlikely(*mbase && 'comparison`)) 238 { 239 for (n = 0; n < rank; n++) 240 dest[n * dstride] = extent[n] - count[n]; 241 242 return; 243 } 244 base -= sstride[0] * 'base_mult`'`; 245 mbase -= mstride[0]; 246 } while(++count[0] != extent[0]); 247 248 n = 0; 249 do 250 { 251 /* When we get to the end of a dimension, reset it and increment 252 the next dimension. */ 253 count[n] = 0; 254 /* We could precalculate these products, but this is a less 255 frequently used path so probably not worth it. */ 256 base += sstride[n] * extent[n] * 'base_mult`'`; 257 mbase -= mstride[n] * extent[n]; 258 n++; 259 if (n >= rank) 260 return; 261 else 262 { 263 count[n]++; 264 base -= sstride[n] * 'base_mult`'`; 265 mbase += mstride[n]; 266 } 267 } while (count[n] == extent[n]); 268 } 269 } 270 else 271 { 272 base = array->base_addr; 273 while (1) 274 { 275 do 276 { 277 if (unlikely(*mbase && 'comparison`)) 278 { 279 for (n = 0; n < rank; n++) 280 dest[n * dstride] = count[n] + 1; 281 282 return; 283 } 284 base += sstride[0] * 'base_mult`'`; 285 mbase += mstride[0]; 286 } while(++count[0] != extent[0]); 287 288 n = 0; 289 do 290 { 291 /* When we get to the end of a dimension, reset it and increment 292 the next dimension. */ 293 count[n] = 0; 294 /* We could precalculate these products, but this is a less 295 frequently used path so probably not worth it. */ 296 base -= sstride[n] * extent[n] * 'base_mult`'`; 297 mbase -= mstride[n] * extent[n]; 298 n++; 299 if (n >= rank) 300 return; 301 else 302 { 303 count[n]++; 304 base += sstride[n]* 'base_mult`'`; 305 mbase += mstride[n]; 306 } 307 } while (count[n] == extent[n]); 308 } 309 } 310 return; 311} 312 313'header3` 314{ 315 index_type rank; 316 index_type dstride; 317 index_type * restrict dest; 318 index_type n; 319 320 if (mask == NULL || *mask) 321 { 322 findloc0_'atype_code` (retarray, array, value, back'len_arg`); 323 return; 324 } 325 326 rank = GFC_DESCRIPTOR_RANK (array); 327 328 if (rank <= 0) 329 internal_error (NULL, "Rank of array needs to be > 0"); 330 331 if (retarray->base_addr == NULL) 332 { 333 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 334 retarray->dtype.rank = 1; 335 retarray->offset = 0; 336 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 337 } 338 else if (unlikely (compile_options.bounds_check)) 339 { 340 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 341 "FINDLOC"); 342 } 343 344 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 345 dest = retarray->base_addr; 346 for (n = 0; n<rank; n++) 347 dest[n * dstride] = 0 ; 348} 349 350#endif' 351