1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2017-2018 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_16)
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 maxloc0_16_s4 (gfc_array_i16
* const restrict retarray
,
48 gfc_array_s4
* const restrict array
, GFC_LOGICAL_4 back
, gfc_charlen_type len
);
49 export_proto(maxloc0_16_s4
);
52 maxloc0_16_s4 (gfc_array_i16
* 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_16
* 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_16
));
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
*maxval
;
112 /* Implementation start. */
114 if (maxval
== NULL
|| (back
? compare_fcn (base
, maxval
, len
) >= 0 :
115 compare_fcn (base
, maxval
, 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 mmaxloc0_16_s4 (gfc_array_i16
* 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(mmaxloc0_16_s4
);
160 mmaxloc0_16_s4 (gfc_array_i16
* 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
];
170 GFC_INTEGER_16
*dest
;
171 const GFC_UINTEGER_4
*base
;
172 GFC_LOGICAL_1
*mbase
;
177 rank
= GFC_DESCRIPTOR_RANK (array
);
179 runtime_error ("Rank of array needs to be > 0");
181 if (retarray
->base_addr
== NULL
)
183 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
- 1, 1);
184 retarray
->dtype
.rank
= 1;
185 retarray
->offset
= 0;
186 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_16
));
190 if (unlikely (compile_options
.bounds_check
))
193 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
195 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
196 "MASK argument", "MAXLOC");
200 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
202 mbase
= mask
->base_addr
;
204 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
205 #ifdef HAVE_GFC_LOGICAL_16
209 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
211 runtime_error ("Funny sized logical array");
213 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
214 dest
= retarray
->base_addr
;
215 for (n
= 0; n
< rank
; n
++)
217 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * len
;
218 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
219 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
223 /* Set the return value. */
224 for (n
= 0; n
< rank
; n
++)
225 dest
[n
* dstride
] = 0;
230 base
= array
->base_addr
;
232 /* Initialize the return value. */
233 for (n
= 0; n
< rank
; n
++)
234 dest
[n
* dstride
] = 0;
237 const GFC_UINTEGER_4
*maxval
;
245 /* Implementation start. */
248 (maxval
== NULL
|| (back
? compare_fcn (base
, maxval
, len
) >= 0:
249 compare_fcn (base
, maxval
, len
) > 0)))
252 for (n
= 0; n
< rank
; n
++)
253 dest
[n
* dstride
] = count
[n
] + 1;
255 /* Implementation end. */
256 /* Advance to the next element. */
260 while (++count
[0] != extent
[0]);
264 /* When we get to the end of a dimension, reset it and increment
265 the next dimension. */
267 /* We could precalculate these products, but this is a less
268 frequently used path so probably not worth it. */
269 base
-= sstride
[n
] * extent
[n
];
270 mbase
-= mstride
[n
] * extent
[n
];
274 /* Break out of the loop. */
285 while (count
[n
] == extent
[n
]);
291 extern void smaxloc0_16_s4 (gfc_array_i16
* const restrict
,
292 gfc_array_s4
* const restrict
, GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
,
293 gfc_charlen_type len
);
294 export_proto(smaxloc0_16_s4
);
297 smaxloc0_16_s4 (gfc_array_i16
* const restrict retarray
,
298 gfc_array_s4
* const restrict array
,
299 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
,
300 gfc_charlen_type len
)
305 GFC_INTEGER_16
*dest
;
310 maxloc0_16_s4 (retarray
, array
, back
, len
);
312 maxloc0_16_s4 (retarray
, array
, len
);
317 rank
= GFC_DESCRIPTOR_RANK (array
);
320 runtime_error ("Rank of array needs to be > 0");
322 if (retarray
->base_addr
== NULL
)
324 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
325 retarray
->dtype
.rank
= 1;
326 retarray
->offset
= 0;
327 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_16
));
329 else if (unlikely (compile_options
.bounds_check
))
331 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
335 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
336 dest
= retarray
->base_addr
;
337 for (n
= 0; n
<rank
; n
++)
338 dest
[n
* dstride
] = 0 ;