1 /* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2024 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_1)
30 extern void findloc1_s1 (gfc_array_index_type
* const restrict retarray
,
31 gfc_array_s1
* const restrict array
, GFC_UINTEGER_1
*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_s1
);
37 findloc1_s1 (gfc_array_index_type
* const restrict retarray
,
38 gfc_array_s1
* const restrict array
, GFC_UINTEGER_1
*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_1
* 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
));
114 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
115 runtime_error ("rank of return array incorrect in"
116 " FINDLOC intrinsic: is %ld, should be %ld",
117 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
120 if (unlikely (compile_options
.bounds_check
))
121 bounds_ifunction_return ((array_t
*) retarray
, extent
,
122 "return value", "FINDLOC");
125 for (n
= 0; n
< rank
; n
++)
128 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
133 dest
= retarray
->base_addr
;
136 base
= array
->base_addr
;
137 while (continue_loop
)
139 const GFC_UINTEGER_1
* restrict src
;
145 src
= base
+ (len
- 1) * delta
* len_array
;
146 for (n
= len
; n
> 0; n
--, src
-= delta
* len_array
)
148 if (compare_string (len_array
, (char *) src
, len_value
, (char *) value
) == 0)
158 for (n
= 1; n
<= len
; n
++, src
+= delta
* len_array
)
160 if (compare_string (len_array
, (char *) src
, len_value
, (char *) value
) == 0)
170 base
+= sstride
[0] * len_array
;
173 while (count
[n
] == extent
[n
])
176 base
-= sstride
[n
] * extent
[n
] * len_array
;
177 dest
-= dstride
[n
] * extent
[n
];
187 base
+= sstride
[n
] * len_array
;
193 extern void mfindloc1_s1 (gfc_array_index_type
* const restrict retarray
,
194 gfc_array_s1
* const restrict array
, GFC_UINTEGER_1
*const restrict value
,
195 const index_type
* restrict pdim
, gfc_array_l1
*const restrict mask
,
196 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
);
197 export_proto(mfindloc1_s1
);
200 mfindloc1_s1 (gfc_array_index_type
* const restrict retarray
,
201 gfc_array_s1
* const restrict array
, GFC_UINTEGER_1
*const restrict value
,
202 const index_type
* restrict pdim
, gfc_array_l1
*const restrict mask
,
203 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
)
205 index_type count
[GFC_MAX_DIMENSIONS
];
206 index_type extent
[GFC_MAX_DIMENSIONS
];
207 index_type sstride
[GFC_MAX_DIMENSIONS
];
208 index_type mstride
[GFC_MAX_DIMENSIONS
];
209 index_type dstride
[GFC_MAX_DIMENSIONS
];
210 const GFC_UINTEGER_1
* restrict base
;
211 const GFC_LOGICAL_1
* restrict mbase
;
212 index_type
* restrict dest
;
222 /* Make dim zero based to avoid confusion. */
223 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
226 if (unlikely (dim
< 0 || dim
> rank
))
228 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
229 "is %ld, should be between 1 and %ld",
230 (long int) dim
+ 1, (long int) rank
+ 1);
233 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
237 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
238 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
240 mbase
= mask
->base_addr
;
242 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
244 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
245 #ifdef HAVE_GFC_LOGICAL_16
249 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
251 internal_error (NULL
, "Funny sized logical array");
253 for (n
= 0; n
< dim
; n
++)
255 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
256 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
257 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
262 for (n
= dim
; n
< rank
; n
++)
264 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
265 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
266 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
272 if (retarray
->base_addr
== NULL
)
274 size_t alloc_size
, str
;
276 for (n
= 0; n
< rank
; n
++)
281 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
283 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
287 retarray
->offset
= 0;
288 retarray
->dtype
.rank
= rank
;
290 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
292 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
298 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
299 runtime_error ("rank of return array incorrect in"
300 " FINDLOC intrinsic: is %ld, should be %ld",
301 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
304 if (unlikely (compile_options
.bounds_check
))
305 bounds_ifunction_return ((array_t
*) retarray
, extent
,
306 "return value", "FINDLOC");
309 for (n
= 0; n
< rank
; n
++)
312 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
317 dest
= retarray
->base_addr
;
320 base
= array
->base_addr
;
321 while (continue_loop
)
323 const GFC_UINTEGER_1
* restrict src
;
324 const GFC_LOGICAL_1
* restrict msrc
;
330 src
= base
+ (len
- 1) * delta
* len_array
;
331 msrc
= mbase
+ (len
- 1) * mdelta
;
332 for (n
= len
; n
> 0; n
--, src
-= delta
* len_array
, msrc
-= mdelta
)
334 if (*msrc
&& compare_string (len_array
, (char *) src
, len_value
, (char *) value
) == 0)
345 for (n
= 1; n
<= len
; n
++, src
+= delta
* len_array
, msrc
+= mdelta
)
347 if (*msrc
&& compare_string (len_array
, (char *) src
, len_value
, (char *) value
) == 0)
357 base
+= sstride
[0] * len_array
;
361 while (count
[n
] == extent
[n
])
364 base
-= sstride
[n
] * extent
[n
] * len_array
;
365 mbase
-= mstride
[n
] * extent
[n
];
366 dest
-= dstride
[n
] * extent
[n
];
376 base
+= sstride
[n
] * len_array
;
382 extern void sfindloc1_s1 (gfc_array_index_type
* const restrict retarray
,
383 gfc_array_s1
* const restrict array
, GFC_UINTEGER_1
*const restrict value
,
384 const index_type
* restrict pdim
, GFC_LOGICAL_4
*const restrict mask
,
385 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
);
386 export_proto(sfindloc1_s1
);
389 sfindloc1_s1 (gfc_array_index_type
* const restrict retarray
,
390 gfc_array_s1
* const restrict array
, GFC_UINTEGER_1
*const restrict value
,
391 const index_type
* restrict pdim
, GFC_LOGICAL_4
*const restrict mask
,
392 GFC_LOGICAL_4 back
, gfc_charlen_type len_array
, gfc_charlen_type len_value
)
394 index_type count
[GFC_MAX_DIMENSIONS
];
395 index_type extent
[GFC_MAX_DIMENSIONS
];
396 index_type dstride
[GFC_MAX_DIMENSIONS
];
397 index_type
* restrict dest
;
404 if (mask
== NULL
|| *mask
)
406 findloc1_s1 (retarray
, array
, value
, pdim
, back
, len_array
, len_value
);
409 /* Make dim zero based to avoid confusion. */
410 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
413 if (unlikely (dim
< 0 || dim
> rank
))
415 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
416 "is %ld, should be between 1 and %ld",
417 (long int) dim
+ 1, (long int) rank
+ 1);
420 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
424 for (n
= 0; n
< dim
; n
++)
426 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
432 for (n
= dim
; n
< rank
; n
++)
435 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
442 if (retarray
->base_addr
== NULL
)
444 size_t alloc_size
, str
;
446 for (n
= 0; n
< rank
; n
++)
451 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
453 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
456 retarray
->offset
= 0;
457 retarray
->dtype
.rank
= rank
;
459 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
461 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
467 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
468 runtime_error ("rank of return array incorrect in"
469 " FINDLOC intrinsic: is %ld, should be %ld",
470 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
473 if (unlikely (compile_options
.bounds_check
))
474 bounds_ifunction_return ((array_t
*) retarray
, extent
,
475 "return value", "FINDLOC");
478 for (n
= 0; n
< rank
; n
++)
481 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
485 dest
= retarray
->base_addr
;
488 while (continue_loop
)
495 while (count
[n
] == extent
[n
])
498 dest
-= dstride
[n
] * extent
[n
];