1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2017-2021 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
33 #if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
35 #define HAVE_BACK_ARG 1
38 compare_fcn (const GFC_UINTEGER_4
*a
, const GFC_UINTEGER_4
*b
, gfc_charlen_type n
)
40 if (sizeof (GFC_UINTEGER_4
) == 1)
41 return memcmp (a
, b
, n
);
43 return memcmp_char4 (a
, b
, n
);
47 extern void minloc0_8_s4 (gfc_array_i8
* const restrict retarray
,
48 gfc_array_s4
* const restrict array
, GFC_LOGICAL_4 back
, gfc_charlen_type len
);
49 export_proto(minloc0_8_s4
);
52 minloc0_8_s4 (gfc_array_i8
* const restrict retarray
,
53 gfc_array_s4
* const restrict array
, GFC_LOGICAL_4 back
, gfc_charlen_type len
)
55 index_type count
[GFC_MAX_DIMENSIONS
];
56 index_type extent
[GFC_MAX_DIMENSIONS
];
57 index_type sstride
[GFC_MAX_DIMENSIONS
];
59 const GFC_UINTEGER_4
*base
;
60 GFC_INTEGER_8
* restrict dest
;
64 rank
= GFC_DESCRIPTOR_RANK (array
);
66 runtime_error ("Rank of array needs to be > 0");
68 if (retarray
->base_addr
== NULL
)
70 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
71 retarray
->dtype
.rank
= 1;
73 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_8
));
77 if (unlikely (compile_options
.bounds_check
))
78 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
82 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
83 dest
= retarray
->base_addr
;
84 for (n
= 0; n
< rank
; n
++)
86 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * len
;
87 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
91 /* Set the return value. */
92 for (n
= 0; n
< rank
; n
++)
93 dest
[n
* dstride
] = 0;
98 base
= array
->base_addr
;
100 /* Initialize the return value. */
101 for (n
= 0; n
< rank
; n
++)
102 dest
[n
* dstride
] = 1;
105 const GFC_UINTEGER_4
*minval
;
112 /* Implementation start. */
114 if (minval
== NULL
|| (back
? compare_fcn (base
, minval
, len
) <= 0 :
115 compare_fcn (base
, minval
, len
) < 0))
118 for (n
= 0; n
< rank
; n
++)
119 dest
[n
* dstride
] = count
[n
] + 1;
121 /* Implementation end. */
122 /* Advance to the next element. */
125 while (++count
[0] != extent
[0]);
129 /* When we get to the end of a dimension, reset it and increment
130 the next dimension. */
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
];
138 /* Break out of the loop. */
148 while (count
[n
] == extent
[n
]);
154 extern void mminloc0_8_s4 (gfc_array_i8
* const restrict
,
155 gfc_array_s4
* const restrict
, gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
,
156 gfc_charlen_type len
);
157 export_proto(mminloc0_8_s4
);
160 mminloc0_8_s4 (gfc_array_i8
* const restrict retarray
,
161 gfc_array_s4
* const restrict array
,
162 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
,
163 gfc_charlen_type len
)
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
];
171 const GFC_UINTEGER_4
*base
;
172 GFC_LOGICAL_1
*mbase
;
180 minloc0_8_s4 (retarray
, array
, back
, len
);
182 minloc0_8_s4 (retarray
, array
, len
);
187 rank
= GFC_DESCRIPTOR_RANK (array
);
189 runtime_error ("Rank of array needs to be > 0");
191 if (retarray
->base_addr
== NULL
)
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
));
200 if (unlikely (compile_options
.bounds_check
))
203 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
205 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
206 "MASK argument", "MINLOC");
210 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
212 mbase
= mask
->base_addr
;
214 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
215 #ifdef HAVE_GFC_LOGICAL_16
219 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
221 runtime_error ("Funny sized logical array");
223 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
224 dest
= retarray
->base_addr
;
225 for (n
= 0; n
< rank
; n
++)
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
);
233 /* Set the return value. */
234 for (n
= 0; n
< rank
; n
++)
235 dest
[n
* dstride
] = 0;
240 base
= array
->base_addr
;
242 /* Initialize the return value. */
243 for (n
= 0; n
< rank
; n
++)
244 dest
[n
* dstride
] = 0;
247 const GFC_UINTEGER_4
*minval
;
255 /* Implementation start. */
258 (minval
== NULL
|| (back
? compare_fcn (base
, minval
, len
) <= 0 :
259 compare_fcn (base
, minval
, len
) < 0)))
262 for (n
= 0; n
< rank
; n
++)
263 dest
[n
* dstride
] = count
[n
] + 1;
265 /* Implementation end. */
266 /* Advance to the next element. */
270 while (++count
[0] != extent
[0]);
274 /* When we get to the end of a dimension, reset it and increment
275 the next dimension. */
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
];
284 /* Break out of the loop. */
295 while (count
[n
] == extent
[n
]);
301 extern void sminloc0_8_s4 (gfc_array_i8
* const restrict
,
302 gfc_array_s4
* const restrict
, GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
,
303 gfc_charlen_type len
);
304 export_proto(sminloc0_8_s4
);
307 sminloc0_8_s4 (gfc_array_i8
* const restrict retarray
,
308 gfc_array_s4
* const restrict array
,
309 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
,
310 gfc_charlen_type len
)
317 if (mask
== NULL
|| *mask
)
320 minloc0_8_s4 (retarray
, array
, back
, len
);
322 minloc0_8_s4 (retarray
, array
, len
);
327 rank
= GFC_DESCRIPTOR_RANK (array
);
330 runtime_error ("Rank of array needs to be > 0");
332 if (retarray
->base_addr
== NULL
)
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
));
339 else if (unlikely (compile_options
.bounds_check
))
341 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
345 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
346 dest
= retarray
->base_addr
;
347 for (n
= 0; n
<rank
; n
++)
348 dest
[n
* dstride
] = 0 ;