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"
29 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
31 #define HAVE_BACK_ARG 1
37 compare_fcn (const GFC_INTEGER_1
*a
, const GFC_INTEGER_1
*b
, gfc_charlen_type n
)
39 if (sizeof (GFC_INTEGER_1
) == 1)
40 return memcmp (a
, b
, n
);
42 return memcmp_char4 (a
, b
, n
);
45 extern void maxloc1_4_s1 (gfc_array_i4
* const restrict
,
46 gfc_array_s1
* const restrict
, const index_type
* const restrict
, GFC_LOGICAL_4 back
,
48 export_proto(maxloc1_4_s1
);
51 maxloc1_4_s1 (gfc_array_i4
* const restrict retarray
,
52 gfc_array_s1
* const restrict array
,
53 const index_type
* const restrict pdim
, GFC_LOGICAL_4 back
,
54 gfc_charlen_type string_len
)
56 index_type count
[GFC_MAX_DIMENSIONS
];
57 index_type extent
[GFC_MAX_DIMENSIONS
];
58 index_type sstride
[GFC_MAX_DIMENSIONS
];
59 index_type dstride
[GFC_MAX_DIMENSIONS
];
60 const GFC_INTEGER_1
* restrict base
;
61 GFC_INTEGER_4
* restrict dest
;
73 /* Make dim zero based to avoid confusion. */
74 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
77 if (unlikely (dim
< 0 || dim
> rank
))
79 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
80 "is %ld, should be between 1 and %ld",
81 (long int) dim
+ 1, (long int) rank
+ 1);
84 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
87 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
89 for (n
= 0; n
< dim
; n
++)
91 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
92 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
97 for (n
= dim
; n
< rank
; n
++)
99 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1) * string_len
;
100 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
106 if (retarray
->base_addr
== NULL
)
108 size_t alloc_size
, str
;
110 for (n
= 0; n
< rank
; n
++)
115 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
117 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
121 retarray
->offset
= 0;
122 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
124 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
126 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
129 /* Make sure we have a zero-sized array. */
130 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
137 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
138 runtime_error ("rank of return array incorrect in"
139 " MAXLOC intrinsic: is %ld, should be %ld",
140 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
143 if (unlikely (compile_options
.bounds_check
))
144 bounds_ifunction_return ((array_t
*) retarray
, extent
,
145 "return value", "MAXLOC");
148 for (n
= 0; n
< rank
; n
++)
151 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
156 base
= array
->base_addr
;
157 dest
= retarray
->base_addr
;
160 while (continue_loop
)
162 const GFC_INTEGER_1
* restrict src
;
163 GFC_INTEGER_4 result
;
167 const GFC_INTEGER_1
*maxval
;
174 for (n
= 0; n
< len
; n
++, src
+= delta
)
177 if (compare_fcn (src
, maxval
, string_len
) > 0)
180 result
= (GFC_INTEGER_4
)n
+ 1;
187 /* Advance to the next element. */
192 while (count
[n
] == extent
[n
])
194 /* When we get to the end of a dimension, reset it and increment
195 the next dimension. */
197 /* We could precalculate these products, but this is a less
198 frequently used path so probably not worth it. */
199 base
-= sstride
[n
] * extent
[n
];
200 dest
-= dstride
[n
] * extent
[n
];
204 /* Break out of the loop. */
219 extern void mmaxloc1_4_s1 (gfc_array_i4
* const restrict
,
220 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
221 gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
, gfc_charlen_type
);
222 export_proto(mmaxloc1_4_s1
);
225 mmaxloc1_4_s1 (gfc_array_i4
* const restrict retarray
,
226 gfc_array_s1
* const restrict array
,
227 const index_type
* const restrict pdim
,
228 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
,
229 gfc_charlen_type string_len
)
231 index_type count
[GFC_MAX_DIMENSIONS
];
232 index_type extent
[GFC_MAX_DIMENSIONS
];
233 index_type sstride
[GFC_MAX_DIMENSIONS
];
234 index_type dstride
[GFC_MAX_DIMENSIONS
];
235 index_type mstride
[GFC_MAX_DIMENSIONS
];
236 GFC_INTEGER_4
* restrict dest
;
237 const GFC_INTEGER_1
* restrict base
;
238 const GFC_LOGICAL_1
* restrict mbase
;
251 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
254 if (unlikely (dim
< 0 || dim
> rank
))
256 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
257 "is %ld, should be between 1 and %ld",
258 (long int) dim
+ 1, (long int) rank
+ 1);
261 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
265 mbase
= mask
->base_addr
;
267 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
269 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
270 #ifdef HAVE_GFC_LOGICAL_16
274 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
276 runtime_error ("Funny sized logical array");
278 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
279 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
281 for (n
= 0; n
< dim
; n
++)
283 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
284 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
285 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
291 for (n
= dim
; n
< rank
; n
++)
293 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1) * string_len
;
294 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
295 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
301 if (retarray
->base_addr
== NULL
)
303 size_t alloc_size
, str
;
305 for (n
= 0; n
< rank
; n
++)
310 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
312 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
316 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
318 retarray
->offset
= 0;
319 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
323 /* Make sure we have a zero-sized array. */
324 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
328 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
333 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
334 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
336 if (unlikely (compile_options
.bounds_check
))
338 bounds_ifunction_return ((array_t
*) retarray
, extent
,
339 "return value", "MAXLOC");
340 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
341 "MASK argument", "MAXLOC");
345 for (n
= 0; n
< rank
; n
++)
348 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
353 dest
= retarray
->base_addr
;
354 base
= array
->base_addr
;
358 const GFC_INTEGER_1
* restrict src
;
359 const GFC_LOGICAL_1
* restrict msrc
;
360 GFC_INTEGER_4 result
;
365 const GFC_INTEGER_1
*maxval
;
368 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
374 result
= (GFC_INTEGER_4
)n
+ 1;
378 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
380 if (*msrc
&& compare_fcn (src
, maxval
, string_len
) > 0)
383 result
= (GFC_INTEGER_4
)n
+ 1;
389 /* Advance to the next element. */
395 while (count
[n
] == extent
[n
])
397 /* When we get to the end of a dimension, reset it and increment
398 the next dimension. */
400 /* We could precalculate these products, but this is a less
401 frequently used path so probably not worth it. */
402 base
-= sstride
[n
] * extent
[n
];
403 mbase
-= mstride
[n
] * extent
[n
];
404 dest
-= dstride
[n
] * extent
[n
];
408 /* Break out of the loop. */
424 extern void smaxloc1_4_s1 (gfc_array_i4
* const restrict
,
425 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
426 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
, gfc_charlen_type
);
427 export_proto(smaxloc1_4_s1
);
430 smaxloc1_4_s1 (gfc_array_i4
* const restrict retarray
,
431 gfc_array_s1
* const restrict array
,
432 const index_type
* const restrict pdim
,
433 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
, gfc_charlen_type string_len
)
435 index_type count
[GFC_MAX_DIMENSIONS
];
436 index_type extent
[GFC_MAX_DIMENSIONS
];
437 index_type dstride
[GFC_MAX_DIMENSIONS
];
438 GFC_INTEGER_4
* restrict dest
;
447 maxloc1_4_s1 (retarray
, array
, pdim
, back
, string_len
);
449 maxloc1_4_s1 (retarray
, array
, pdim
, string_len
);
453 /* Make dim zero based to avoid confusion. */
455 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
457 if (unlikely (dim
< 0 || dim
> rank
))
459 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
460 "is %ld, should be between 1 and %ld",
461 (long int) dim
+ 1, (long int) rank
+ 1);
464 for (n
= 0; n
< dim
; n
++)
466 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
) * string_len
;
472 for (n
= dim
; n
< rank
; n
++)
475 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1) * string_len
;
481 if (retarray
->base_addr
== NULL
)
483 size_t alloc_size
, str
;
485 for (n
= 0; n
< rank
; n
++)
490 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
492 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
496 retarray
->offset
= 0;
497 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
499 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
503 /* Make sure we have a zero-sized array. */
504 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
508 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
512 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
513 runtime_error ("rank of return array incorrect in"
514 " MAXLOC intrinsic: is %ld, should be %ld",
515 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
518 if (unlikely (compile_options
.bounds_check
))
520 for (n
=0; n
< rank
; n
++)
522 index_type ret_extent
;
524 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
525 if (extent
[n
] != ret_extent
)
526 runtime_error ("Incorrect extent in return value of"
527 " MAXLOC intrinsic in dimension %ld:"
528 " is %ld, should be %ld", (long int) n
+ 1,
529 (long int) ret_extent
, (long int) extent
[n
]);
534 for (n
= 0; n
< rank
; n
++)
537 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
540 dest
= retarray
->base_addr
;
548 while (count
[n
] == extent
[n
])
550 /* When we get to the end of a dimension, reset it and increment
551 the next dimension. */
553 /* We could precalculate these products, but this is a less
554 frequently used path so probably not worth it. */
555 dest
-= dstride
[n
] * extent
[n
];