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