1 2/* Implementation of the FINDLOC intrinsic 3 Copyright (C) 2018-2020 Free Software Foundation, Inc. 4 Contributed by Thomas K��nig <tk@tkoenig.net> 5 6This file is part of the GNU Fortran 95 runtime library (libgfortran). 7 8Libgfortran is free software; you can redistribute it and/or 9modify it under the terms of the GNU General Public 10License as published by the Free Software Foundation; either 11version 3 of the License, or (at your option) any later version. 12 13Libgfortran is distributed in the hope that it will be useful, 14but WITHOUT ANY WARRANTY; without even the implied warranty of 15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16GNU General Public License for more details. 17 18Under Section 7 of GPL version 3, you are granted additional 19permissions described in the GCC Runtime Library Exception, version 203.1, as published by the Free Software Foundation. 21 22You should have received a copy of the GNU General Public License and 23a copy of the GCC Runtime Library Exception along with this program; 24see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 25<http://www.gnu.org/licenses/>. */ 26 27#include "libgfortran.h" 28#include <assert.h> 29 30#if defined (HAVE_GFC_COMPLEX_16) 31extern void findloc0_c16 (gfc_array_index_type * const restrict retarray, 32 gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value, 33 GFC_LOGICAL_4); 34export_proto(findloc0_c16); 35 36void 37findloc0_c16 (gfc_array_index_type * const restrict retarray, 38 gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value, 39 GFC_LOGICAL_4 back) 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; 45 const GFC_COMPLEX_16 *base; 46 index_type * restrict dest; 47 index_type rank; 48 index_type n; 49 index_type sz; 50 51 rank = GFC_DESCRIPTOR_RANK (array); 52 if (rank <= 0) 53 runtime_error ("Rank of array needs to be > 0"); 54 55 if (retarray->base_addr == NULL) 56 { 57 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 58 retarray->dtype.rank = 1; 59 retarray->offset = 0; 60 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 61 } 62 else 63 { 64 if (unlikely (compile_options.bounds_check)) 65 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 66 "FINDLOC"); 67 } 68 69 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 70 dest = retarray->base_addr; 71 72 /* Set the return value. */ 73 for (n = 0; n < rank; n++) 74 dest[n * dstride] = 0; 75 76 sz = 1; 77 for (n = 0; n < rank; n++) 78 { 79 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 80 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 81 sz *= extent[n]; 82 if (extent[n] <= 0) 83 return; 84 } 85 86 for (n = 0; n < rank; n++) 87 count[n] = 0; 88 89 if (back) 90 { 91 base = array->base_addr + (sz - 1) * 1; 92 93 while (1) 94 { 95 do 96 { 97 if (unlikely(*base == value)) 98 { 99 for (n = 0; n < rank; n++) 100 dest[n * dstride] = extent[n] - count[n]; 101 102 return; 103 } 104 base -= sstride[0] * 1; 105 } while(++count[0] != extent[0]); 106 107 n = 0; 108 do 109 { 110 /* When we get to the end of a dimension, reset it and increment 111 the next dimension. */ 112 count[n] = 0; 113 /* We could precalculate these products, but this is a less 114 frequently used path so probably not worth it. */ 115 base += sstride[n] * extent[n] * 1; 116 n++; 117 if (n >= rank) 118 return; 119 else 120 { 121 count[n]++; 122 base -= sstride[n] * 1; 123 } 124 } while (count[n] == extent[n]); 125 } 126 } 127 else 128 { 129 base = array->base_addr; 130 while (1) 131 { 132 do 133 { 134 if (unlikely(*base == value)) 135 { 136 for (n = 0; n < rank; n++) 137 dest[n * dstride] = count[n] + 1; 138 139 return; 140 } 141 base += sstride[0] * 1; 142 } while(++count[0] != extent[0]); 143 144 n = 0; 145 do 146 { 147 /* When we get to the end of a dimension, reset it and increment 148 the next dimension. */ 149 count[n] = 0; 150 /* We could precalculate these products, but this is a less 151 frequently used path so probably not worth it. */ 152 base -= sstride[n] * extent[n] * 1; 153 n++; 154 if (n >= rank) 155 return; 156 else 157 { 158 count[n]++; 159 base += sstride[n] * 1; 160 } 161 } while (count[n] == extent[n]); 162 } 163 } 164 return; 165} 166 167extern void mfindloc0_c16 (gfc_array_index_type * const restrict retarray, 168 gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value, 169 gfc_array_l1 *const restrict, GFC_LOGICAL_4); 170export_proto(mfindloc0_c16); 171 172void 173mfindloc0_c16 (gfc_array_index_type * const restrict retarray, 174 gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value, 175 gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back) 176{ 177 index_type count[GFC_MAX_DIMENSIONS]; 178 index_type extent[GFC_MAX_DIMENSIONS]; 179 index_type sstride[GFC_MAX_DIMENSIONS]; 180 index_type mstride[GFC_MAX_DIMENSIONS]; 181 index_type dstride; 182 const GFC_COMPLEX_16 *base; 183 index_type * restrict dest; 184 GFC_LOGICAL_1 *mbase; 185 index_type rank; 186 index_type n; 187 int mask_kind; 188 index_type sz; 189 190 rank = GFC_DESCRIPTOR_RANK (array); 191 if (rank <= 0) 192 runtime_error ("Rank of array needs to be > 0"); 193 194 if (retarray->base_addr == NULL) 195 { 196 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 197 retarray->dtype.rank = 1; 198 retarray->offset = 0; 199 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 200 } 201 else 202 { 203 if (unlikely (compile_options.bounds_check)) 204 { 205 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 206 "FINDLOC"); 207 bounds_equal_extents ((array_t *) mask, (array_t *) array, 208 "MASK argument", "FINDLOC"); 209 } 210 } 211 212 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 213 214 mbase = mask->base_addr; 215 216 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 217#ifdef HAVE_GFC_LOGICAL_16 218 || mask_kind == 16 219#endif 220 ) 221 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 222 else 223 internal_error (NULL, "Funny sized logical array"); 224 225 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 226 dest = retarray->base_addr; 227 228 /* Set the return value. */ 229 for (n = 0; n < rank; n++) 230 dest[n * dstride] = 0; 231 232 sz = 1; 233 for (n = 0; n < rank; n++) 234 { 235 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 236 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 237 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 238 sz *= extent[n]; 239 if (extent[n] <= 0) 240 return; 241 } 242 243 for (n = 0; n < rank; n++) 244 count[n] = 0; 245 246 if (back) 247 { 248 base = array->base_addr + (sz - 1) * 1; 249 mbase = mbase + (sz - 1) * mask_kind; 250 while (1) 251 { 252 do 253 { 254 if (unlikely(*mbase && *base == value)) 255 { 256 for (n = 0; n < rank; n++) 257 dest[n * dstride] = extent[n] - count[n]; 258 259 return; 260 } 261 base -= sstride[0] * 1; 262 mbase -= mstride[0]; 263 } while(++count[0] != extent[0]); 264 265 n = 0; 266 do 267 { 268 /* When we get to the end of a dimension, reset it and increment 269 the next dimension. */ 270 count[n] = 0; 271 /* We could precalculate these products, but this is a less 272 frequently used path so probably not worth it. */ 273 base += sstride[n] * extent[n] * 1; 274 mbase -= mstride[n] * extent[n]; 275 n++; 276 if (n >= rank) 277 return; 278 else 279 { 280 count[n]++; 281 base -= sstride[n] * 1; 282 mbase += mstride[n]; 283 } 284 } while (count[n] == extent[n]); 285 } 286 } 287 else 288 { 289 base = array->base_addr; 290 while (1) 291 { 292 do 293 { 294 if (unlikely(*mbase && *base == value)) 295 { 296 for (n = 0; n < rank; n++) 297 dest[n * dstride] = count[n] + 1; 298 299 return; 300 } 301 base += sstride[0] * 1; 302 mbase += mstride[0]; 303 } while(++count[0] != extent[0]); 304 305 n = 0; 306 do 307 { 308 /* When we get to the end of a dimension, reset it and increment 309 the next dimension. */ 310 count[n] = 0; 311 /* We could precalculate these products, but this is a less 312 frequently used path so probably not worth it. */ 313 base -= sstride[n] * extent[n] * 1; 314 mbase -= mstride[n] * extent[n]; 315 n++; 316 if (n >= rank) 317 return; 318 else 319 { 320 count[n]++; 321 base += sstride[n]* 1; 322 mbase += mstride[n]; 323 } 324 } while (count[n] == extent[n]); 325 } 326 } 327 return; 328} 329 330extern void sfindloc0_c16 (gfc_array_index_type * const restrict retarray, 331 gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value, 332 GFC_LOGICAL_4 *, GFC_LOGICAL_4); 333export_proto(sfindloc0_c16); 334 335void 336sfindloc0_c16 (gfc_array_index_type * const restrict retarray, 337 gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value, 338 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) 339{ 340 index_type rank; 341 index_type dstride; 342 index_type * restrict dest; 343 index_type n; 344 345 if (mask == NULL || *mask) 346 { 347 findloc0_c16 (retarray, array, value, back); 348 return; 349 } 350 351 rank = GFC_DESCRIPTOR_RANK (array); 352 353 if (rank <= 0) 354 internal_error (NULL, "Rank of array needs to be > 0"); 355 356 if (retarray->base_addr == NULL) 357 { 358 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 359 retarray->dtype.rank = 1; 360 retarray->offset = 0; 361 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 362 } 363 else if (unlikely (compile_options.bounds_check)) 364 { 365 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 366 "FINDLOC"); 367 } 368 369 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 370 dest = retarray->base_addr; 371 for (n = 0; n<rank; n++) 372 dest[n * dstride] = 0 ; 373} 374 375#endif 376