1 2 /* Implementation of the FINDLOC intrinsic 3 Copyright (C) 2018-2019 Free Software Foundation, Inc. 4 Contributed by Thomas König <tk@tkoenig.net> 5 6 This file is part of the GNU Fortran 95 runtime library (libgfortran). 7 8 Libgfortran is free software; you can redistribute it and/or 9 modify it under the terms of the GNU General Public 10 License as published by the Free Software Foundation; either 11 version 3 of the License, or (at your option) any later version. 12 13 Libgfortran is distributed in the hope that it will be useful, 14 but WITHOUT ANY WARRANTY; without even the implied warranty of 15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 GNU General Public License for more details. 17 18 Under Section 7 of GPL version 3, you are granted additional 19 permissions described in the GCC Runtime Library Exception, version 20 3.1, as published by the Free Software Foundation. 21 22 You should have received a copy of the GNU General Public License and 23 a copy of the GCC Runtime Library Exception along with this program; 24 see 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_REAL_4) 31 extern void findloc0_r4 (gfc_array_index_type * const restrict retarray, 32 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 33 GFC_LOGICAL_4); 34 export_proto(findloc0_r4); 35 36 void 37 findloc0_r4 (gfc_array_index_type * const restrict retarray, 38 gfc_array_r4 * const restrict array, GFC_REAL_4 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_REAL_4 *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 167 extern void mfindloc0_r4 (gfc_array_index_type * const restrict retarray, 168 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 169 gfc_array_l1 *const restrict, GFC_LOGICAL_4); 170 export_proto(mfindloc0_r4); 171 172 void 173 mfindloc0_r4 (gfc_array_index_type * const restrict retarray, 174 gfc_array_r4 * const restrict array, GFC_REAL_4 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_REAL_4 *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 330 extern void sfindloc0_r4 (gfc_array_index_type * const restrict retarray, 331 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 332 GFC_LOGICAL_4 *, GFC_LOGICAL_4); 333 export_proto(sfindloc0_r4); 334 335 void 336 sfindloc0_r4 (gfc_array_index_type * const restrict retarray, 337 gfc_array_r4 * const restrict array, GFC_REAL_4 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_r4 (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