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
;
69 /* Make dim zero based to avoid confusion. */
70 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
73 if (unlikely (dim
< 0 || dim
> rank
))
75 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
76 "is %ld, should be between 1 and %ld",
77 (long int) dim
+ 1, (long int) rank
+ 1);
80 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
83 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
85 for (n
= 0; n
< dim
; n
++)
87 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
88 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
93 for (n
= dim
; n
< rank
; n
++)
95 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1) * string_len
;
96 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
102 if (retarray
->base_addr
== NULL
)
104 size_t alloc_size
, str
;
106 for (n
= 0; n
< rank
; n
++)
111 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
113 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
117 retarray
->offset
= 0;
118 retarray
->dtype
.rank
= rank
;
120 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
122 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
125 /* Make sure we have a zero-sized array. */
126 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
133 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
134 runtime_error ("rank of return array incorrect in"
135 " MAXLOC intrinsic: is %ld, should be %ld",
136 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
139 if (unlikely (compile_options
.bounds_check
))
140 bounds_ifunction_return ((array_t
*) retarray
, extent
,
141 "return value", "MAXLOC");
144 for (n
= 0; n
< rank
; n
++)
147 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
152 base
= array
->base_addr
;
153 dest
= retarray
->base_addr
;
156 while (continue_loop
)
158 const GFC_INTEGER_1
* restrict src
;
159 GFC_INTEGER_4 result
;
163 const GFC_INTEGER_1
*maxval
;
170 for (n
= 0; n
< len
; n
++, src
+= delta
)
173 if (maxval
== NULL
|| (back
? compare_fcn (src
, maxval
, string_len
) >= 0 :
174 compare_fcn (src
, maxval
, string_len
) > 0))
177 result
= (GFC_INTEGER_4
)n
+ 1;
184 /* Advance to the next element. */
189 while (count
[n
] == extent
[n
])
191 /* When we get to the end of a dimension, reset it and increment
192 the next dimension. */
194 /* We could precalculate these products, but this is a less
195 frequently used path so probably not worth it. */
196 base
-= sstride
[n
] * extent
[n
];
197 dest
-= dstride
[n
] * extent
[n
];
201 /* Break out of the loop. */
216 extern void mmaxloc1_4_s1 (gfc_array_i4
* const restrict
,
217 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
218 gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
, gfc_charlen_type
);
219 export_proto(mmaxloc1_4_s1
);
222 mmaxloc1_4_s1 (gfc_array_i4
* const restrict retarray
,
223 gfc_array_s1
* const restrict array
,
224 const index_type
* const restrict pdim
,
225 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
,
226 gfc_charlen_type string_len
)
228 index_type count
[GFC_MAX_DIMENSIONS
];
229 index_type extent
[GFC_MAX_DIMENSIONS
];
230 index_type sstride
[GFC_MAX_DIMENSIONS
];
231 index_type dstride
[GFC_MAX_DIMENSIONS
];
232 index_type mstride
[GFC_MAX_DIMENSIONS
];
233 GFC_INTEGER_4
* restrict dest
;
234 const GFC_INTEGER_1
* restrict base
;
235 const GFC_LOGICAL_1
* restrict mbase
;
245 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
248 if (unlikely (dim
< 0 || dim
> rank
))
250 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
251 "is %ld, should be between 1 and %ld",
252 (long int) dim
+ 1, (long int) rank
+ 1);
255 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
259 mbase
= mask
->base_addr
;
261 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
263 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
264 #ifdef HAVE_GFC_LOGICAL_16
268 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
270 runtime_error ("Funny sized logical array");
272 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
273 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
275 for (n
= 0; n
< dim
; n
++)
277 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
278 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
279 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
285 for (n
= dim
; n
< rank
; n
++)
287 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1) * string_len
;
288 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
289 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
295 if (retarray
->base_addr
== NULL
)
297 size_t alloc_size
, str
;
299 for (n
= 0; n
< rank
; n
++)
304 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
306 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
310 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
312 retarray
->offset
= 0;
313 retarray
->dtype
.rank
= rank
;
317 /* Make sure we have a zero-sized array. */
318 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
322 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
327 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
328 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
330 if (unlikely (compile_options
.bounds_check
))
332 bounds_ifunction_return ((array_t
*) retarray
, extent
,
333 "return value", "MAXLOC");
334 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
335 "MASK argument", "MAXLOC");
339 for (n
= 0; n
< rank
; n
++)
342 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
347 dest
= retarray
->base_addr
;
348 base
= array
->base_addr
;
352 const GFC_INTEGER_1
* restrict src
;
353 const GFC_LOGICAL_1
* restrict msrc
;
354 GFC_INTEGER_4 result
;
359 const GFC_INTEGER_1
*maxval
;
362 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
368 result
= (GFC_INTEGER_4
)n
+ 1;
372 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
374 if (*msrc
&& (back
? compare_fcn (src
, maxval
, string_len
) >= 0 :
375 compare_fcn (src
, maxval
, string_len
) > 0))
378 result
= (GFC_INTEGER_4
)n
+ 1;
384 /* Advance to the next element. */
390 while (count
[n
] == extent
[n
])
392 /* When we get to the end of a dimension, reset it and increment
393 the next dimension. */
395 /* We could precalculate these products, but this is a less
396 frequently used path so probably not worth it. */
397 base
-= sstride
[n
] * extent
[n
];
398 mbase
-= mstride
[n
] * extent
[n
];
399 dest
-= dstride
[n
] * extent
[n
];
403 /* Break out of the loop. */
419 extern void smaxloc1_4_s1 (gfc_array_i4
* const restrict
,
420 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
421 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
, gfc_charlen_type
);
422 export_proto(smaxloc1_4_s1
);
425 smaxloc1_4_s1 (gfc_array_i4
* const restrict retarray
,
426 gfc_array_s1
* const restrict array
,
427 const index_type
* const restrict pdim
,
428 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
, gfc_charlen_type string_len
)
430 index_type count
[GFC_MAX_DIMENSIONS
];
431 index_type extent
[GFC_MAX_DIMENSIONS
];
432 index_type dstride
[GFC_MAX_DIMENSIONS
];
433 GFC_INTEGER_4
* restrict dest
;
442 maxloc1_4_s1 (retarray
, array
, pdim
, back
, string_len
);
444 maxloc1_4_s1 (retarray
, array
, pdim
, string_len
);
448 /* Make dim zero based to avoid confusion. */
450 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
452 if (unlikely (dim
< 0 || dim
> rank
))
454 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
455 "is %ld, should be between 1 and %ld",
456 (long int) dim
+ 1, (long int) rank
+ 1);
459 for (n
= 0; n
< dim
; n
++)
461 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
) * string_len
;
467 for (n
= dim
; n
< rank
; n
++)
470 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1) * string_len
;
476 if (retarray
->base_addr
== NULL
)
478 size_t alloc_size
, str
;
480 for (n
= 0; n
< rank
; n
++)
485 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
487 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
491 retarray
->offset
= 0;
492 retarray
->dtype
.rank
= rank
;
494 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
498 /* Make sure we have a zero-sized array. */
499 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
503 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
507 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
508 runtime_error ("rank of return array incorrect in"
509 " MAXLOC intrinsic: is %ld, should be %ld",
510 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
513 if (unlikely (compile_options
.bounds_check
))
515 for (n
=0; n
< rank
; n
++)
517 index_type ret_extent
;
519 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
520 if (extent
[n
] != ret_extent
)
521 runtime_error ("Incorrect extent in return value of"
522 " MAXLOC intrinsic in dimension %ld:"
523 " is %ld, should be %ld", (long int) n
+ 1,
524 (long int) ret_extent
, (long int) extent
[n
]);
529 for (n
= 0; n
< rank
; n
++)
532 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
535 dest
= retarray
->base_addr
;
543 while (count
[n
] == extent
[n
])
545 /* When we get to the end of a dimension, reset it and increment
546 the next dimension. */
548 /* We could precalculate these products, but this is a less
549 frequently used path so probably not worth it. */
550 dest
-= dstride
[n
] * extent
[n
];