1`/* Implementation of the MAXLOC intrinsic 2 Copyright (C) 2017-2021 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>' 30include(iparm.m4)dnl 31 32`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`) 33 34static inline int 35compare_fcn (const 'atype_name` *a, const 'atype_name` *b, gfc_charlen_type n) 36{ 37 if (sizeof ('atype_name`) == 1) 38 return memcmp (a, b, n); 39 else 40 return memcmp_char4 (a, b, n); 41} 42 43extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict'back_arg`, 44 gfc_charlen_type); 45export_proto('name`'rtype_qual`_'atype_code`); 46 47'rtype_name` 48'name`'rtype_qual`_'atype_code` ('atype` * const restrict array'back_arg`, gfc_charlen_type len) 49{ 50 index_type ret; 51 index_type sstride; 52 index_type extent; 53 const 'atype_name` *src; 54 const 'atype_name` *maxval; 55 index_type i; 56 57 extent = GFC_DESCRIPTOR_EXTENT(array,0); 58 if (extent <= 0) 59 return 0; 60 61 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len; 62 63 ret = 1; 64 src = array->base_addr; 65 maxval = NULL; 66 for (i=1; i<=extent; i++) 67 { 68 if (maxval == NULL || (back ? compare_fcn (src, maxval, len) >= 0 : 69 compare_fcn (src, maxval, len) > 0)) 70 { 71 ret = i; 72 maxval = src; 73 } 74 src += sstride; 75 } 76 return ret; 77} 78 79extern 'rtype_name` m'name`'rtype_qual`_'atype_code` ('atype` * const restrict, 80 gfc_array_l1 *const restrict mask'back_arg`, 81 gfc_charlen_type); 82export_proto(m'name`'rtype_qual`_'atype_code`); 83 84'rtype_name` 85m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, 86 gfc_array_l1 * const restrict mask'back_arg`, 87 gfc_charlen_type len) 88{ 89 index_type ret; 90 index_type sstride; 91 index_type extent; 92 const 'atype_name` *src; 93 const 'atype_name` *maxval; 94 index_type i, j; 95 GFC_LOGICAL_1 *mbase; 96 int mask_kind; 97 index_type mstride; 98 99 extent = GFC_DESCRIPTOR_EXTENT(array,0); 100 if (extent <= 0) 101 return 0; 102 103 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len; 104 105 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 106 mbase = mask->base_addr; 107 108 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 109#ifdef HAVE_GFC_LOGICAL_16 110 || mask_kind == 16 111#endif 112 ) 113 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 114 else 115 internal_error (NULL, "Funny sized logical array"); 116 117 mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0); 118 119 /* Search for the first occurrence of a true element in mask. */ 120 for (j=0; j<extent; j++) 121 { 122 if (*mbase) 123 break; 124 mbase += mstride; 125 } 126 127 if (j == extent) 128 return 0; 129 130 ret = j + 1; 131 src = array->base_addr + j * sstride; 132 maxval = src; 133 134 for (i=j+1; i<=extent; i++) 135 { 136 if (*mbase && (back ? compare_fcn (src, maxval, len) >= 0 : 137 compare_fcn (src, maxval, len) > 0)) 138 { 139 ret = i; 140 maxval = src; 141 } 142 src += sstride; 143 mbase += mstride; 144 } 145 return ret; 146} 147 148extern 'rtype_name` s'name`'rtype_qual`_'atype_code` ('atype` * const restrict, 149 GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type); 150export_proto(s'name`'rtype_qual`_'atype_code`); 151 152'rtype_name` 153s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, 154 GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type len) 155{ 156 if (mask) 157 return 'name`'rtype_qual`_'atype_code` (array, len, back); 158 else 159 return 0; 160} 161 162#endif' 163