|
131
|
1 /* Implementation of the MAXLOC intrinsic
|
|
145
|
2 Copyright (C) 2017-2020 Free Software Foundation, Inc.
|
|
131
|
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
|
|
145
|
33 #if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1)
|
|
131
|
34
|
|
|
35 static inline int
|
|
145
|
36 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
|
131
|
37 {
|
|
145
|
38 if (sizeof (GFC_UINTEGER_1) == 1)
|
|
131
|
39 return memcmp (a, b, n);
|
|
|
40 else
|
|
|
41 return memcmp_char4 (a, b, n);
|
|
|
42
|
|
|
43 }
|
|
|
44
|
|
|
45 #define INITVAL 0
|
|
|
46
|
|
145
|
47 extern void maxval0_s1 (GFC_UINTEGER_1 * restrict,
|
|
131
|
48 gfc_charlen_type,
|
|
|
49 gfc_array_s1 * const restrict array, gfc_charlen_type);
|
|
|
50 export_proto(maxval0_s1);
|
|
|
51
|
|
|
52 void
|
|
145
|
53 maxval0_s1 (GFC_UINTEGER_1 * restrict ret,
|
|
131
|
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];
|
|
145
|
60 const GFC_UINTEGER_1 *base;
|
|
131
|
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
|
|
145
|
86 const GFC_UINTEGER_1 *retval;
|
|
131
|
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
|
|
145
|
133 extern void mmaxval0_s1 (GFC_UINTEGER_1 * restrict,
|
|
131
|
134 gfc_charlen_type, gfc_array_s1 * const restrict array,
|
|
|
135 gfc_array_l1 * const restrict mask, gfc_charlen_type len);
|
|
|
136 export_proto(mmaxval0_s1);
|
|
|
137
|
|
|
138 void
|
|
145
|
139 mmaxval0_s1 (GFC_UINTEGER_1 * const restrict ret,
|
|
131
|
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];
|
|
145
|
147 const GFC_UINTEGER_1 *base;
|
|
131
|
148 GFC_LOGICAL_1 *mbase;
|
|
|
149 int rank;
|
|
|
150 index_type n;
|
|
|
151 int mask_kind;
|
|
|
152
|
|
145
|
153 if (mask == NULL)
|
|
|
154 {
|
|
|
155 maxval0_s1 (ret, xlen, array, len);
|
|
|
156 return;
|
|
|
157 }
|
|
|
158
|
|
131
|
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
|
|
145
|
194 const GFC_UINTEGER_1 *retval;
|
|
131
|
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
|
|
145
|
245 extern void smaxval0_s1 (GFC_UINTEGER_1 * restrict,
|
|
131
|
246 gfc_charlen_type,
|
|
|
247 gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
|
|
|
248 export_proto(smaxval0_s1);
|
|
|
249
|
|
|
250 void
|
|
145
|
251 smaxval0_s1 (GFC_UINTEGER_1 * restrict ret,
|
|
131
|
252 gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
|
|
|
253 GFC_LOGICAL_4 *mask, gfc_charlen_type len)
|
|
|
254
|
|
|
255 {
|
|
145
|
256 if (mask == NULL || *mask)
|
|
131
|
257 {
|
|
|
258 maxval0_s1 (ret, xlen, array, len);
|
|
|
259 return;
|
|
|
260 }
|
|
|
261 memset (ret, INITVAL, sizeof (*ret) * len);
|
|
|
262 }
|
|
|
263
|
|
|
264 #endif
|
