172613Skris 272613Skris/* Implementation of the FINDLOC intrinsic 372613Skris Copyright (C) 2018-2020 Free Software Foundation, Inc. 476866Skris Contributed by Thomas K��nig <tk@tkoenig.net> 572613Skris 672613SkrisThis file is part of the GNU Fortran 95 runtime library (libgfortran). 772613Skris 872613SkrisLibgfortran is free software; you can redistribute it and/or 972613Skrismodify it under the terms of the GNU General Public 1072613SkrisLicense as published by the Free Software Foundation; either 11160814Ssimonversion 3 of the License, or (at your option) any later version. 1272613Skris 1372613SkrisLibgfortran is distributed in the hope that it will be useful, 1472613Skrisbut WITHOUT ANY WARRANTY; without even the implied warranty of 1572613SkrisMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1672613SkrisGNU General Public License for more details. 1772613Skris 1872613SkrisUnder Section 7 of GPL version 3, you are granted additional 1972613Skrispermissions described in the GCC Runtime Library Exception, version 2072613Skris3.1, as published by the Free Software Foundation. 2172613Skris 2272613SkrisYou should have received a copy of the GNU General Public License and 2372613Skrisa copy of the GCC Runtime Library Exception along with this program; 2472613Skrissee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 2572613Skris<http://www.gnu.org/licenses/>. */ 2672613Skris 2772613Skris#include "libgfortran.h" 2872613Skris#include <assert.h> 2972613Skris 3072613Skris#if defined (HAVE_GFC_UINTEGER_4) 3172613Skrisextern void findloc0_s4 (gfc_array_index_type * const restrict retarray, 3272613Skris gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value, 3389837Skris GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value); 3489837Skris 3589837Skrisexport_proto(findloc0_s4); 3689837Skris 3789837Skrisvoid 3872613Skrisfindloc0_s4 (gfc_array_index_type * const restrict retarray, 3989837Skris gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value, 4089837Skris GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value) 4189837Skris{ 4289837Skris index_type count[GFC_MAX_DIMENSIONS]; 4389837Skris index_type extent[GFC_MAX_DIMENSIONS]; 4489837Skris index_type sstride[GFC_MAX_DIMENSIONS]; 4572613Skris index_type dstride; 4672613Skris const GFC_UINTEGER_4 *base; 4772613Skris index_type * restrict dest; 4872613Skris index_type rank; 4972613Skris index_type n; 5072613Skris index_type sz; 51269682Sjkim 52269682Sjkim rank = GFC_DESCRIPTOR_RANK (array); 53269682Sjkim if (rank <= 0) 54269682Sjkim runtime_error ("Rank of array needs to be > 0"); 55269682Sjkim 56269682Sjkim if (retarray->base_addr == NULL) 57269682Sjkim { 58269682Sjkim GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 59269682Sjkim retarray->dtype.rank = 1; 60269682Sjkim retarray->offset = 0; 6172613Skris retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 6272613Skris } 6372613Skris else 6472613Skris { 6572613Skris if (unlikely (compile_options.bounds_check)) 6672613Skris bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 6772613Skris "FINDLOC"); 6872613Skris } 6972613Skris 7072613Skris dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 7172613Skris dest = retarray->base_addr; 7272613Skris 7389837Skris /* Set the return value. */ 7472613Skris for (n = 0; n < rank; n++) 7572613Skris dest[n * dstride] = 0; 7672613Skris 77 sz = 1; 78 for (n = 0; n < rank; n++) 79 { 80 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 81 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 82 sz *= extent[n]; 83 if (extent[n] <= 0) 84 return; 85 } 86 87 for (n = 0; n < rank; n++) 88 count[n] = 0; 89 90 if (back) 91 { 92 base = array->base_addr + (sz - 1) * len_array; 93 94 while (1) 95 { 96 do 97 { 98 if (unlikely(compare_string_char4 (len_array, base, len_value, value) == 0)) 99 { 100 for (n = 0; n < rank; n++) 101 dest[n * dstride] = extent[n] - count[n]; 102 103 return; 104 } 105 base -= sstride[0] * len_array; 106 } while(++count[0] != extent[0]); 107 108 n = 0; 109 do 110 { 111 /* When we get to the end of a dimension, reset it and increment 112 the next dimension. */ 113 count[n] = 0; 114 /* We could precalculate these products, but this is a less 115 frequently used path so probably not worth it. */ 116 base += sstride[n] * extent[n] * len_array; 117 n++; 118 if (n >= rank) 119 return; 120 else 121 { 122 count[n]++; 123 base -= sstride[n] * len_array; 124 } 125 } while (count[n] == extent[n]); 126 } 127 } 128 else 129 { 130 base = array->base_addr; 131 while (1) 132 { 133 do 134 { 135 if (unlikely(compare_string_char4 (len_array, base, len_value, value) == 0)) 136 { 137 for (n = 0; n < rank; n++) 138 dest[n * dstride] = count[n] + 1; 139 140 return; 141 } 142 base += sstride[0] * len_array; 143 } while(++count[0] != extent[0]); 144 145 n = 0; 146 do 147 { 148 /* When we get to the end of a dimension, reset it and increment 149 the next dimension. */ 150 count[n] = 0; 151 /* We could precalculate these products, but this is a less 152 frequently used path so probably not worth it. */ 153 base -= sstride[n] * extent[n] * len_array; 154 n++; 155 if (n >= rank) 156 return; 157 else 158 { 159 count[n]++; 160 base += sstride[n] * len_array; 161 } 162 } while (count[n] == extent[n]); 163 } 164 } 165 return; 166} 167 168extern void mfindloc0_s4 (gfc_array_index_type * const restrict retarray, 169 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value, 170 gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array, 171 gfc_charlen_type len_value); 172export_proto(mfindloc0_s4); 173 174void 175mfindloc0_s4 (gfc_array_index_type * const restrict retarray, 176 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value, 177 gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back, 178 gfc_charlen_type len_array, gfc_charlen_type len_value) 179{ 180 index_type count[GFC_MAX_DIMENSIONS]; 181 index_type extent[GFC_MAX_DIMENSIONS]; 182 index_type sstride[GFC_MAX_DIMENSIONS]; 183 index_type mstride[GFC_MAX_DIMENSIONS]; 184 index_type dstride; 185 const GFC_UINTEGER_4 *base; 186 index_type * restrict dest; 187 GFC_LOGICAL_1 *mbase; 188 index_type rank; 189 index_type n; 190 int mask_kind; 191 index_type sz; 192 193 rank = GFC_DESCRIPTOR_RANK (array); 194 if (rank <= 0) 195 runtime_error ("Rank of array needs to be > 0"); 196 197 if (retarray->base_addr == NULL) 198 { 199 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 200 retarray->dtype.rank = 1; 201 retarray->offset = 0; 202 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 203 } 204 else 205 { 206 if (unlikely (compile_options.bounds_check)) 207 { 208 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 209 "FINDLOC"); 210 bounds_equal_extents ((array_t *) mask, (array_t *) array, 211 "MASK argument", "FINDLOC"); 212 } 213 } 214 215 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 216 217 mbase = mask->base_addr; 218 219 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 220#ifdef HAVE_GFC_LOGICAL_16 221 || mask_kind == 16 222#endif 223 ) 224 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 225 else 226 internal_error (NULL, "Funny sized logical array"); 227 228 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 229 dest = retarray->base_addr; 230 231 /* Set the return value. */ 232 for (n = 0; n < rank; n++) 233 dest[n * dstride] = 0; 234 235 sz = 1; 236 for (n = 0; n < rank; n++) 237 { 238 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 239 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 240 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 241 sz *= extent[n]; 242 if (extent[n] <= 0) 243 return; 244 } 245 246 for (n = 0; n < rank; n++) 247 count[n] = 0; 248 249 if (back) 250 { 251 base = array->base_addr + (sz - 1) * len_array; 252 mbase = mbase + (sz - 1) * mask_kind; 253 while (1) 254 { 255 do 256 { 257 if (unlikely(*mbase && compare_string_char4 (len_array, base, len_value, value) == 0)) 258 { 259 for (n = 0; n < rank; n++) 260 dest[n * dstride] = extent[n] - count[n]; 261 262 return; 263 } 264 base -= sstride[0] * len_array; 265 mbase -= mstride[0]; 266 } while(++count[0] != extent[0]); 267 268 n = 0; 269 do 270 { 271 /* When we get to the end of a dimension, reset it and increment 272 the next dimension. */ 273 count[n] = 0; 274 /* We could precalculate these products, but this is a less 275 frequently used path so probably not worth it. */ 276 base += sstride[n] * extent[n] * len_array; 277 mbase -= mstride[n] * extent[n]; 278 n++; 279 if (n >= rank) 280 return; 281 else 282 { 283 count[n]++; 284 base -= sstride[n] * len_array; 285 mbase += mstride[n]; 286 } 287 } while (count[n] == extent[n]); 288 } 289 } 290 else 291 { 292 base = array->base_addr; 293 while (1) 294 { 295 do 296 { 297 if (unlikely(*mbase && compare_string_char4 (len_array, base, len_value, value) == 0)) 298 { 299 for (n = 0; n < rank; n++) 300 dest[n * dstride] = count[n] + 1; 301 302 return; 303 } 304 base += sstride[0] * len_array; 305 mbase += mstride[0]; 306 } while(++count[0] != extent[0]); 307 308 n = 0; 309 do 310 { 311 /* When we get to the end of a dimension, reset it and increment 312 the next dimension. */ 313 count[n] = 0; 314 /* We could precalculate these products, but this is a less 315 frequently used path so probably not worth it. */ 316 base -= sstride[n] * extent[n] * len_array; 317 mbase -= mstride[n] * extent[n]; 318 n++; 319 if (n >= rank) 320 return; 321 else 322 { 323 count[n]++; 324 base += sstride[n]* len_array; 325 mbase += mstride[n]; 326 } 327 } while (count[n] == extent[n]); 328 } 329 } 330 return; 331} 332 333extern void sfindloc0_s4 (gfc_array_index_type * const restrict retarray, 334 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value, 335 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array, 336 gfc_charlen_type len_value); 337export_proto(sfindloc0_s4); 338 339void 340sfindloc0_s4 (gfc_array_index_type * const restrict retarray, 341 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value, 342 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array, 343 gfc_charlen_type len_value) 344{ 345 index_type rank; 346 index_type dstride; 347 index_type * restrict dest; 348 index_type n; 349 350 if (mask == NULL || *mask) 351 { 352 findloc0_s4 (retarray, array, value, back, len_array, len_value); 353 return; 354 } 355 356 rank = GFC_DESCRIPTOR_RANK (array); 357 358 if (rank <= 0) 359 internal_error (NULL, "Rank of array needs to be > 0"); 360 361 if (retarray->base_addr == NULL) 362 { 363 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 364 retarray->dtype.rank = 1; 365 retarray->offset = 0; 366 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 367 } 368 else if (unlikely (compile_options.bounds_check)) 369 { 370 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 371 "FINDLOC"); 372 } 373 374 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 375 dest = retarray->base_addr; 376 for (n = 0; n<rank; n++) 377 dest[n * dstride] = 0 ; 378} 379 380#endif 381 382 383 384