1 /* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2023 Free Software Foundation, Inc.
3 Contributed by Thomas König <tk@tkoenig.net>
5 This file is part of the GNU Fortran 95 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_UINTEGER_4)
30 extern void findloc1_s4 (gfc_array_index_type
* const restrict retarray
,
31 gfc_array_s4
* const restrict array
, GFC_UINTEGER_4
*const restrict value
,
32 const index_type
* restrict pdim
, GFC_LOGICAL_4 back
,
33 gfc_charlen_type len_array
, gfc_charlen_type len_value
);
34 export_proto(findloc1_s4
);
37 findloc1_s4 (gfc_array_index_type
* const restrict retarray
,
38 gfc_array_s4
* const restrict array
, GFC_UINTEGER_4
*const restrict value
,
39 const index_type
* restrict pdim
, GFC_LOGICAL_4 back
,
40 gfc_charlen_type len_array
, gfc_charlen_type len_value
)
42 index_type count
[GFC_MAX_DIMENSIONS
];
43 index_type extent
[GFC_MAX_DIMENSIONS
];
44 index_type sstride
[GFC_MAX_DIMENSIONS
];
45 index_type dstride
[GFC_MAX_DIMENSIONS
];
46 const GFC_UINTEGER_4
* restrict base
;
47 index_type
* restrict dest
;
55 /* Make dim zero based to avoid confusion. */
56 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
59 if (unlikely (dim
< 0 || dim
> rank
))
61 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
62 "is %ld, should be between 1 and %ld",
63 (long int) dim
+ 1, (long int) rank
+ 1);
66 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
69 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
71 for (n
= 0; n
< dim
; n
++)
73 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
74 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
79 for (n
= dim
; n
< rank
; n
++)
81 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
82 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
88 if (retarray
->base_addr
== NULL
)
90 size_t alloc_size
, str
;
92 for (n
= 0; n
< rank
; n
++)
97 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
99 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
103 retarray
->offset
= 0;
104 retarray
->dtype
.rank
= rank
;
106 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
108 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
111 /* Make sure we have a zero-sized array. */
112 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
118 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
119 runtime_error ("rank of return array incorrect in"
120 " FINDLOC intrinsic: is %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
124 if (unlikely (compile_options
.bounds_check
))
125 bounds_ifunction_return ((array_t
*) retarray
, extent
,
126 "return value", "FINDLOC");
129 for (n
= 0; n
< rank
; n
++)
132 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
137 dest
= retarray
->base_addr
;
140 base
= array
->base_addr
;
141 while (continue_loop
)
143 const GFC_UINTEGER_4
* restrict src
;
149 src
= base
+ (len
- 1) * delta
* len_array
;
150 for (n
= len
; n
> 0; n
--, src
-= delta
* len_array
)
152 if (compare_string_char4 (len_array
, src
, len_value
, value
) == 0)
162 for (n
= 1; n
<= len
; n
++, src
+= delta
* len_array
)
164 if (compare_string_char4 (len_array
, src
, len_value
, value
) == 0)
174 base
+= sstride
[0] * len_array
;
177 while (count
[n
] == extent
[n
])
180 base
-= sstride
[n
] * extent
[n
] * len_array
;
181 dest
-= dstride
[n
] * extent
[n
];
191 base
+= sstride
[n
] * len_array
;
197 extern void mfindloc1_s4 (gfc_array_index_type
* const restrict retarray
,
198 gfc_array_s4
* const restrict array
, GFC_UINTEGER_4
*const restrict value
,
199 const index_type
* restrict pdim
, gfc_array_l1
*const restrict mask
,
200 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
);
201 export_proto(mfindloc1_s4
);
204 mfindloc1_s4 (gfc_array_index_type
* const restrict retarray
,
205 gfc_array_s4
* const restrict array
, GFC_UINTEGER_4
*const restrict value
,
206 const index_type
* restrict pdim
, gfc_array_l1
*const restrict mask
,
207 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
)
209 index_type count
[GFC_MAX_DIMENSIONS
];
210 index_type extent
[GFC_MAX_DIMENSIONS
];
211 index_type sstride
[GFC_MAX_DIMENSIONS
];
212 index_type mstride
[GFC_MAX_DIMENSIONS
];
213 index_type dstride
[GFC_MAX_DIMENSIONS
];
214 const GFC_UINTEGER_4
* restrict base
;
215 const GFC_LOGICAL_1
* restrict mbase
;
216 index_type
* restrict dest
;
226 /* Make dim zero based to avoid confusion. */
227 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
230 if (unlikely (dim
< 0 || dim
> rank
))
232 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
233 "is %ld, should be between 1 and %ld",
234 (long int) dim
+ 1, (long int) rank
+ 1);
237 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
241 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
242 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
244 mbase
= mask
->base_addr
;
246 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
248 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
249 #ifdef HAVE_GFC_LOGICAL_16
253 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
255 internal_error (NULL
, "Funny sized logical array");
257 for (n
= 0; n
< dim
; n
++)
259 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
260 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
261 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
266 for (n
= dim
; n
< rank
; n
++)
268 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
269 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
270 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
276 if (retarray
->base_addr
== NULL
)
278 size_t alloc_size
, str
;
280 for (n
= 0; n
< rank
; n
++)
285 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
287 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
291 retarray
->offset
= 0;
292 retarray
->dtype
.rank
= rank
;
294 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
296 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
299 /* Make sure we have a zero-sized array. */
300 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
306 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
307 runtime_error ("rank of return array incorrect in"
308 " FINDLOC intrinsic: is %ld, should be %ld",
309 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
312 if (unlikely (compile_options
.bounds_check
))
313 bounds_ifunction_return ((array_t
*) retarray
, extent
,
314 "return value", "FINDLOC");
317 for (n
= 0; n
< rank
; n
++)
320 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
325 dest
= retarray
->base_addr
;
328 base
= array
->base_addr
;
329 while (continue_loop
)
331 const GFC_UINTEGER_4
* restrict src
;
332 const GFC_LOGICAL_1
* restrict msrc
;
338 src
= base
+ (len
- 1) * delta
* len_array
;
339 msrc
= mbase
+ (len
- 1) * mdelta
;
340 for (n
= len
; n
> 0; n
--, src
-= delta
* len_array
, msrc
-= mdelta
)
342 if (*msrc
&& compare_string_char4 (len_array
, src
, len_value
, value
) == 0)
353 for (n
= 1; n
<= len
; n
++, src
+= delta
* len_array
, msrc
+= mdelta
)
355 if (*msrc
&& compare_string_char4 (len_array
, src
, len_value
, value
) == 0)
365 base
+= sstride
[0] * len_array
;
369 while (count
[n
] == extent
[n
])
372 base
-= sstride
[n
] * extent
[n
] * len_array
;
373 mbase
-= mstride
[n
] * extent
[n
];
374 dest
-= dstride
[n
] * extent
[n
];
384 base
+= sstride
[n
] * len_array
;
390 extern void sfindloc1_s4 (gfc_array_index_type
* const restrict retarray
,
391 gfc_array_s4
* const restrict array
, GFC_UINTEGER_4
*const restrict value
,
392 const index_type
* restrict pdim
, GFC_LOGICAL_4
*const restrict mask
,
393 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
);
394 export_proto(sfindloc1_s4
);
397 sfindloc1_s4 (gfc_array_index_type
* const restrict retarray
,
398 gfc_array_s4
* const restrict array
, GFC_UINTEGER_4
*const restrict value
,
399 const index_type
* restrict pdim
, GFC_LOGICAL_4
*const restrict mask
,
400 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
)
402 index_type count
[GFC_MAX_DIMENSIONS
];
403 index_type extent
[GFC_MAX_DIMENSIONS
];
404 index_type dstride
[GFC_MAX_DIMENSIONS
];
405 index_type
* restrict dest
;
412 if (mask
== NULL
|| *mask
)
414 findloc1_s4 (retarray
, array
, value
, pdim
, back
, len_array
, len_value
);
417 /* Make dim zero based to avoid confusion. */
418 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
421 if (unlikely (dim
< 0 || dim
> rank
))
423 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
424 "is %ld, should be between 1 and %ld",
425 (long int) dim
+ 1, (long int) rank
+ 1);
428 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
432 for (n
= 0; n
< dim
; n
++)
434 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
440 for (n
= dim
; n
< rank
; n
++)
443 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
450 if (retarray
->base_addr
== NULL
)
452 size_t alloc_size
, str
;
454 for (n
= 0; n
< rank
; n
++)
459 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
461 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
464 retarray
->offset
= 0;
465 retarray
->dtype
.rank
= rank
;
467 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
469 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
472 /* Make sure we have a zero-sized array. */
473 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
479 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
480 runtime_error ("rank of return array incorrect in"
481 " FINDLOC intrinsic: is %ld, should be %ld",
482 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
485 if (unlikely (compile_options
.bounds_check
))
486 bounds_ifunction_return ((array_t
*) retarray
, extent
,
487 "return value", "FINDLOC");
490 for (n
= 0; n
< rank
; n
++)
493 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
497 dest
= retarray
->base_addr
;
500 while (continue_loop
)
507 while (count
[n
] == extent
[n
])
510 dest
-= dstride
[n
] * extent
[n
];