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_8)
34 compare_fcn (const GFC_INTEGER_1
*a
, const GFC_INTEGER_1
*b
, gfc_charlen_type n
)
36 if (sizeof (GFC_INTEGER_1
) == 1)
37 return memcmp (a
, b
, n
);
39 return memcmp_char4 (a
, b
, n
);
42 extern void maxloc1_8_s1 (gfc_array_i8
* const restrict
,
43 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
45 export_proto(maxloc1_8_s1
);
48 maxloc1_8_s1 (gfc_array_i8
* const restrict retarray
,
49 gfc_array_s1
* const restrict array
,
50 const index_type
* const restrict pdim
, gfc_charlen_type string_len
)
52 index_type count
[GFC_MAX_DIMENSIONS
];
53 index_type extent
[GFC_MAX_DIMENSIONS
];
54 index_type sstride
[GFC_MAX_DIMENSIONS
];
55 index_type dstride
[GFC_MAX_DIMENSIONS
];
56 const GFC_INTEGER_1
* restrict base
;
57 GFC_INTEGER_8
* restrict dest
;
65 /* Make dim zero based to avoid confusion. */
66 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
69 if (unlikely (dim
< 0 || dim
> rank
))
71 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
72 "is %ld, should be between 1 and %ld",
73 (long int) dim
+ 1, (long int) rank
+ 1);
76 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
79 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
81 for (n
= 0; n
< dim
; n
++)
83 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
84 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
89 for (n
= dim
; n
< rank
; n
++)
91 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1) * string_len
;
92 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
98 if (retarray
->base_addr
== NULL
)
100 size_t alloc_size
, str
;
102 for (n
= 0; n
< rank
; n
++)
107 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
109 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
113 retarray
->offset
= 0;
114 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
116 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
118 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_8
));
121 /* Make sure we have a zero-sized array. */
122 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
129 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
130 runtime_error ("rank of return array incorrect in"
131 " MAXLOC intrinsic: is %ld, should be %ld",
132 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
135 if (unlikely (compile_options
.bounds_check
))
136 bounds_ifunction_return ((array_t
*) retarray
, extent
,
137 "return value", "MAXLOC");
140 for (n
= 0; n
< rank
; n
++)
143 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
148 base
= array
->base_addr
;
149 dest
= retarray
->base_addr
;
152 while (continue_loop
)
154 const GFC_INTEGER_1
* restrict src
;
155 GFC_INTEGER_8 result
;
159 const GFC_INTEGER_1
*maxval
;
166 for (n
= 0; n
< len
; n
++, src
+= delta
)
169 if (compare_fcn (src
, maxval
, string_len
) > 0)
172 result
= (GFC_INTEGER_8
)n
+ 1;
179 /* Advance to the next element. */
184 while (count
[n
] == extent
[n
])
186 /* When we get to the end of a dimension, reset it and increment
187 the next dimension. */
189 /* We could precalculate these products, but this is a less
190 frequently used path so probably not worth it. */
191 base
-= sstride
[n
] * extent
[n
];
192 dest
-= dstride
[n
] * extent
[n
];
196 /* Break out of the loop. */
211 extern void mmaxloc1_8_s1 (gfc_array_i8
* const restrict
,
212 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
213 gfc_array_l1
* const restrict
, gfc_charlen_type
);
214 export_proto(mmaxloc1_8_s1
);
217 mmaxloc1_8_s1 (gfc_array_i8
* const restrict retarray
,
218 gfc_array_s1
* const restrict array
,
219 const index_type
* const restrict pdim
,
220 gfc_array_l1
* const restrict mask
, gfc_charlen_type string_len
)
222 index_type count
[GFC_MAX_DIMENSIONS
];
223 index_type extent
[GFC_MAX_DIMENSIONS
];
224 index_type sstride
[GFC_MAX_DIMENSIONS
];
225 index_type dstride
[GFC_MAX_DIMENSIONS
];
226 index_type mstride
[GFC_MAX_DIMENSIONS
];
227 GFC_INTEGER_8
* restrict dest
;
228 const GFC_INTEGER_1
* restrict base
;
229 const GFC_LOGICAL_1
* restrict mbase
;
239 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
242 if (unlikely (dim
< 0 || dim
> rank
))
244 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
245 "is %ld, should be between 1 and %ld",
246 (long int) dim
+ 1, (long int) rank
+ 1);
249 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
253 mbase
= mask
->base_addr
;
255 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
257 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
258 #ifdef HAVE_GFC_LOGICAL_16
262 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
264 runtime_error ("Funny sized logical array");
266 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
) * string_len
;
267 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
269 for (n
= 0; n
< dim
; n
++)
271 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
) * string_len
;
272 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
273 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
279 for (n
= dim
; n
< rank
; n
++)
281 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1) * string_len
;
282 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
283 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
289 if (retarray
->base_addr
== NULL
)
291 size_t alloc_size
, str
;
293 for (n
= 0; n
< rank
; n
++)
298 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
300 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
304 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
306 retarray
->offset
= 0;
307 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
311 /* Make sure we have a zero-sized array. */
312 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
316 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_8
));
321 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
322 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
324 if (unlikely (compile_options
.bounds_check
))
326 bounds_ifunction_return ((array_t
*) retarray
, extent
,
327 "return value", "MAXLOC");
328 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
329 "MASK argument", "MAXLOC");
333 for (n
= 0; n
< rank
; n
++)
336 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
341 dest
= retarray
->base_addr
;
342 base
= array
->base_addr
;
346 const GFC_INTEGER_1
* restrict src
;
347 const GFC_LOGICAL_1
* restrict msrc
;
348 GFC_INTEGER_8 result
;
353 const GFC_INTEGER_1
*maxval
;
356 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
362 result
= (GFC_INTEGER_8
)n
+ 1;
366 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
368 if (*msrc
&& compare_fcn (src
, maxval
, string_len
) > 0)
371 result
= (GFC_INTEGER_8
)n
+ 1;
377 /* Advance to the next element. */
383 while (count
[n
] == extent
[n
])
385 /* When we get to the end of a dimension, reset it and increment
386 the next dimension. */
388 /* We could precalculate these products, but this is a less
389 frequently used path so probably not worth it. */
390 base
-= sstride
[n
] * extent
[n
];
391 mbase
-= mstride
[n
] * extent
[n
];
392 dest
-= dstride
[n
] * extent
[n
];
396 /* Break out of the loop. */
412 extern void smaxloc1_8_s1 (gfc_array_i8
* const restrict
,
413 gfc_array_s1
* const restrict
, const index_type
* const restrict
,
414 GFC_LOGICAL_4
*, gfc_charlen_type
);
415 export_proto(smaxloc1_8_s1
);
418 smaxloc1_8_s1 (gfc_array_i8
* const restrict retarray
,
419 gfc_array_s1
* const restrict array
,
420 const index_type
* const restrict pdim
,
421 GFC_LOGICAL_4
* mask
, gfc_charlen_type string_len
)
423 index_type count
[GFC_MAX_DIMENSIONS
];
424 index_type extent
[GFC_MAX_DIMENSIONS
];
425 index_type dstride
[GFC_MAX_DIMENSIONS
];
426 GFC_INTEGER_8
* restrict dest
;
434 maxloc1_8_s1 (retarray
, array
, pdim
, string_len
);
437 /* Make dim zero based to avoid confusion. */
439 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
441 if (unlikely (dim
< 0 || dim
> rank
))
443 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
444 "is %ld, should be between 1 and %ld",
445 (long int) dim
+ 1, (long int) rank
+ 1);
448 for (n
= 0; n
< dim
; n
++)
450 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
) * string_len
;
456 for (n
= dim
; n
< rank
; n
++)
459 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1) * string_len
;
465 if (retarray
->base_addr
== NULL
)
467 size_t alloc_size
, str
;
469 for (n
= 0; n
< rank
; n
++)
474 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
476 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
480 retarray
->offset
= 0;
481 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
483 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
487 /* Make sure we have a zero-sized array. */
488 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
492 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_8
));
496 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
497 runtime_error ("rank of return array incorrect in"
498 " MAXLOC intrinsic: is %ld, should be %ld",
499 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
502 if (unlikely (compile_options
.bounds_check
))
504 for (n
=0; n
< rank
; n
++)
506 index_type ret_extent
;
508 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
509 if (extent
[n
] != ret_extent
)
510 runtime_error ("Incorrect extent in return value of"
511 " MAXLOC intrinsic in dimension %ld:"
512 " is %ld, should be %ld", (long int) n
+ 1,
513 (long int) ret_extent
, (long int) extent
[n
]);
518 for (n
= 0; n
< rank
; n
++)
521 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
524 dest
= retarray
->base_addr
;
532 while (count
[n
] == extent
[n
])
534 /* When we get to the end of a dimension, reset it and increment
535 the next dimension. */
537 /* We could precalculate these products, but this is a less
538 frequently used path so probably not worth it. */
539 dest
-= dstride
[n
] * extent
[n
];