1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2017-2023 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see 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_UINTEGER_1)
34
35 static inline int
36 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
37 {
38 if (sizeof (GFC_UINTEGER_1) == 1)
39 return memcmp (a, b, n);
40 else
41 return memcmp_char4 (a, b, n);
42
43 }
44
45 #define INITVAL 255
46
47 extern void minval0_s1 (GFC_UINTEGER_1 * restrict,
48 gfc_charlen_type,
49 gfc_array_s1 * const restrict array, gfc_charlen_type);
50 export_proto(minval0_s1);
51
52 void
53 minval0_s1 (GFC_UINTEGER_1 * restrict ret,
54 gfc_charlen_type xlen,
55 gfc_array_s1 * const restrict array, gfc_charlen_type len)
56 {
57 index_type count[GFC_MAX_DIMENSIONS];
58 index_type extent[GFC_MAX_DIMENSIONS];
59 index_type sstride[GFC_MAX_DIMENSIONS];
60 const GFC_UINTEGER_1 *base;
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 assert (xlen == len);
69
70 /* Initialize return value. */
71 memset (ret, INITVAL, sizeof(*ret) * len);
72
73 for (n = 0; n < rank; n++)
74 {
75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
76 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
77 count[n] = 0;
78 if (extent[n] <= 0)
79 return;
80 }
81
82 base = array->base_addr;
83
84 {
85
86 const GFC_UINTEGER_1 *retval;
87 retval = ret;
88
89 while (base)
90 {
91 do
92 {
93 /* Implementation start. */
94
95 if (compare_fcn (base, retval, len) < 0)
96 {
97 retval = base;
98 }
99 /* Implementation end. */
100 /* Advance to the next element. */
101 base += sstride[0];
102 }
103 while (++count[0] != extent[0]);
104 n = 0;
105 do
106 {
107 /* When we get to the end of a dimension, reset it and increment
108 the next dimension. */
109 count[n] = 0;
110 /* We could precalculate these products, but this is a less
111 frequently used path so probably not worth it. */
112 base -= sstride[n] * extent[n];
113 n++;
114 if (n >= rank)
115 {
116 /* Break out of the loop. */
117 base = NULL;
118 break;
119 }
120 else
121 {
122 count[n]++;
123 base += sstride[n];
124 }
125 }
126 while (count[n] == extent[n]);
127 }
128 memcpy (ret, retval, len * sizeof (*ret));
129 }
130 }
131
132
133 extern void mminval0_s1 (GFC_UINTEGER_1 * restrict,
134 gfc_charlen_type, gfc_array_s1 * const restrict array,
135 gfc_array_l1 * const restrict mask, gfc_charlen_type len);
136 export_proto(mminval0_s1);
137
138 void
139 mminval0_s1 (GFC_UINTEGER_1 * const restrict ret,
140 gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
141 gfc_array_l1 * const restrict mask, gfc_charlen_type len)
142 {
143 index_type count[GFC_MAX_DIMENSIONS];
144 index_type extent[GFC_MAX_DIMENSIONS];
145 index_type sstride[GFC_MAX_DIMENSIONS];
146 index_type mstride[GFC_MAX_DIMENSIONS];
147 const GFC_UINTEGER_1 *base;
148 GFC_LOGICAL_1 *mbase;
149 int rank;
150 index_type n;
151 int mask_kind;
152
153 if (mask == NULL)
154 {
155 minval0_s1 (ret, xlen, array, len);
156 return;
157 }
158
159 rank = GFC_DESCRIPTOR_RANK (array);
160 if (rank <= 0)
161 runtime_error ("Rank of array needs to be > 0");
162
163 assert (xlen == len);
164
165 /* Initialize return value. */
166 memset (ret, INITVAL, sizeof(*ret) * len);
167
168 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
169
170 mbase = mask->base_addr;
171
172 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
173 #ifdef HAVE_GFC_LOGICAL_16
174 || mask_kind == 16
175 #endif
176 )
177 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
178 else
179 runtime_error ("Funny sized logical array");
180
181 for (n = 0; n < rank; n++)
182 {
183 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
184 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
185 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
186 count[n] = 0;
187 if (extent[n] <= 0)
188 return;
189 }
190
191 base = array->base_addr;
192 {
193
194 const GFC_UINTEGER_1 *retval;
195
196 retval = ret;
197
198 while (base)
199 {
200 do
201 {
202 /* Implementation start. */
203
204 if (*mbase && compare_fcn (base, retval, len) < 0)
205 {
206 retval = base;
207 }
208 /* Implementation end. */
209 /* Advance to the next element. */
210 base += sstride[0];
211 mbase += mstride[0];
212 }
213 while (++count[0] != extent[0]);
214 n = 0;
215 do
216 {
217 /* When we get to the end of a dimension, reset it and increment
218 the next dimension. */
219 count[n] = 0;
220 /* We could precalculate these products, but this is a less
221 frequently used path so probably not worth it. */
222 base -= sstride[n] * extent[n];
223 mbase -= mstride[n] * extent[n];
224 n++;
225 if (n >= rank)
226 {
227 /* Break out of the loop. */
228 base = NULL;
229 break;
230 }
231 else
232 {
233 count[n]++;
234 base += sstride[n];
235 mbase += mstride[n];
236 }
237 }
238 while (count[n] == extent[n]);
239 }
240 memcpy (ret, retval, len * sizeof (*ret));
241 }
242 }
243
244
245 extern void sminval0_s1 (GFC_UINTEGER_1 * restrict,
246 gfc_charlen_type,
247 gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
248 export_proto(sminval0_s1);
249
250 void
251 sminval0_s1 (GFC_UINTEGER_1 * restrict ret,
252 gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
253 GFC_LOGICAL_4 *mask, gfc_charlen_type len)
254
255 {
256 if (mask == NULL || *mask)
257 {
258 minval0_s1 (ret, xlen, array, len);
259 return;
260 }
261 memset (ret, INITVAL, sizeof (*ret) * len);
262 }
263
264 #endif