1 /* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2021 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_INTEGER_16)
30 extern void findloc1_i16 (gfc_array_index_type
* const restrict retarray
,
31 gfc_array_i16
* const restrict array
, GFC_INTEGER_16 value
,
32 const index_type
* restrict pdim
, GFC_LOGICAL_4 back
);
33 export_proto(findloc1_i16
);
36 findloc1_i16 (gfc_array_index_type
* const restrict retarray
,
37 gfc_array_i16
* const restrict array
, GFC_INTEGER_16 value
,
38 const index_type
* restrict pdim
, GFC_LOGICAL_4 back
)
40 index_type count
[GFC_MAX_DIMENSIONS
];
41 index_type extent
[GFC_MAX_DIMENSIONS
];
42 index_type sstride
[GFC_MAX_DIMENSIONS
];
43 index_type dstride
[GFC_MAX_DIMENSIONS
];
44 const GFC_INTEGER_16
* restrict base
;
45 index_type
* restrict dest
;
53 /* Make dim zero based to avoid confusion. */
54 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
57 if (unlikely (dim
< 0 || dim
> rank
))
59 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
60 "is %ld, should be between 1 and %ld",
61 (long int) dim
+ 1, (long int) rank
+ 1);
64 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
67 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
69 for (n
= 0; n
< dim
; n
++)
71 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
72 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
77 for (n
= dim
; n
< rank
; n
++)
79 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
80 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
86 if (retarray
->base_addr
== NULL
)
88 size_t alloc_size
, str
;
90 for (n
= 0; n
< rank
; n
++)
95 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
97 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
101 retarray
->offset
= 0;
102 retarray
->dtype
.rank
= rank
;
104 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
106 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
109 /* Make sure we have a zero-sized array. */
110 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
116 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
117 runtime_error ("rank of return array incorrect in"
118 " FINDLOC intrinsic: is %ld, should be %ld",
119 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
122 if (unlikely (compile_options
.bounds_check
))
123 bounds_ifunction_return ((array_t
*) retarray
, extent
,
124 "return value", "FINDLOC");
127 for (n
= 0; n
< rank
; n
++)
130 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
135 dest
= retarray
->base_addr
;
138 base
= array
->base_addr
;
139 while (continue_loop
)
141 const GFC_INTEGER_16
* restrict src
;
147 src
= base
+ (len
- 1) * delta
* 1;
148 for (n
= len
; n
> 0; n
--, src
-= delta
* 1)
160 for (n
= 1; n
<= len
; n
++, src
+= delta
* 1)
172 base
+= sstride
[0] * 1;
175 while (count
[n
] == extent
[n
])
178 base
-= sstride
[n
] * extent
[n
] * 1;
179 dest
-= dstride
[n
] * extent
[n
];
189 base
+= sstride
[n
] * 1;
195 extern void mfindloc1_i16 (gfc_array_index_type
* const restrict retarray
,
196 gfc_array_i16
* const restrict array
, GFC_INTEGER_16 value
,
197 const index_type
* restrict pdim
, gfc_array_l1
*const restrict mask
,
199 export_proto(mfindloc1_i16
);
202 mfindloc1_i16 (gfc_array_index_type
* const restrict retarray
,
203 gfc_array_i16
* const restrict array
, GFC_INTEGER_16 value
,
204 const index_type
* restrict pdim
, gfc_array_l1
*const restrict mask
,
207 index_type count
[GFC_MAX_DIMENSIONS
];
208 index_type extent
[GFC_MAX_DIMENSIONS
];
209 index_type sstride
[GFC_MAX_DIMENSIONS
];
210 index_type mstride
[GFC_MAX_DIMENSIONS
];
211 index_type dstride
[GFC_MAX_DIMENSIONS
];
212 const GFC_INTEGER_16
* restrict base
;
213 const GFC_LOGICAL_1
* restrict mbase
;
214 index_type
* restrict dest
;
224 /* Make dim zero based to avoid confusion. */
225 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
228 if (unlikely (dim
< 0 || dim
> rank
))
230 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
231 "is %ld, should be between 1 and %ld",
232 (long int) dim
+ 1, (long int) rank
+ 1);
235 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
239 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
240 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
242 mbase
= mask
->base_addr
;
244 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
246 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
247 #ifdef HAVE_GFC_LOGICAL_16
251 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
253 internal_error (NULL
, "Funny sized logical array");
255 for (n
= 0; n
< dim
; n
++)
257 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
258 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
259 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
264 for (n
= dim
; n
< rank
; n
++)
266 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
267 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
268 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
274 if (retarray
->base_addr
== NULL
)
276 size_t alloc_size
, str
;
278 for (n
= 0; n
< rank
; n
++)
283 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
285 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
289 retarray
->offset
= 0;
290 retarray
->dtype
.rank
= rank
;
292 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
294 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
297 /* Make sure we have a zero-sized array. */
298 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
304 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
305 runtime_error ("rank of return array incorrect in"
306 " FINDLOC intrinsic: is %ld, should be %ld",
307 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
310 if (unlikely (compile_options
.bounds_check
))
311 bounds_ifunction_return ((array_t
*) retarray
, extent
,
312 "return value", "FINDLOC");
315 for (n
= 0; n
< rank
; n
++)
318 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
323 dest
= retarray
->base_addr
;
326 base
= array
->base_addr
;
327 while (continue_loop
)
329 const GFC_INTEGER_16
* restrict src
;
330 const GFC_LOGICAL_1
* restrict msrc
;
336 src
= base
+ (len
- 1) * delta
* 1;
337 msrc
= mbase
+ (len
- 1) * mdelta
;
338 for (n
= len
; n
> 0; n
--, src
-= delta
* 1, msrc
-= mdelta
)
340 if (*msrc
&& *src
== value
)
351 for (n
= 1; n
<= len
; n
++, src
+= delta
* 1, msrc
+= mdelta
)
353 if (*msrc
&& *src
== value
)
363 base
+= sstride
[0] * 1;
367 while (count
[n
] == extent
[n
])
370 base
-= sstride
[n
] * extent
[n
] * 1;
371 mbase
-= mstride
[n
] * extent
[n
];
372 dest
-= dstride
[n
] * extent
[n
];
382 base
+= sstride
[n
] * 1;
388 extern void sfindloc1_i16 (gfc_array_index_type
* const restrict retarray
,
389 gfc_array_i16
* const restrict array
, GFC_INTEGER_16 value
,
390 const index_type
* restrict pdim
, GFC_LOGICAL_4
*const restrict mask
,
392 export_proto(sfindloc1_i16
);
395 sfindloc1_i16 (gfc_array_index_type
* const restrict retarray
,
396 gfc_array_i16
* const restrict array
, GFC_INTEGER_16 value
,
397 const index_type
* restrict pdim
, GFC_LOGICAL_4
*const restrict mask
,
400 index_type count
[GFC_MAX_DIMENSIONS
];
401 index_type extent
[GFC_MAX_DIMENSIONS
];
402 index_type dstride
[GFC_MAX_DIMENSIONS
];
403 index_type
* restrict dest
;
410 if (mask
== NULL
|| *mask
)
412 findloc1_i16 (retarray
, array
, value
, pdim
, back
);
415 /* Make dim zero based to avoid confusion. */
416 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
419 if (unlikely (dim
< 0 || dim
> rank
))
421 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
422 "is %ld, should be between 1 and %ld",
423 (long int) dim
+ 1, (long int) rank
+ 1);
426 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
430 for (n
= 0; n
< dim
; n
++)
432 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
438 for (n
= dim
; n
< rank
; n
++)
441 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
448 if (retarray
->base_addr
== NULL
)
450 size_t alloc_size
, str
;
452 for (n
= 0; n
< rank
; n
++)
457 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
459 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
462 retarray
->offset
= 0;
463 retarray
->dtype
.rank
= rank
;
465 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
467 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (index_type
));
470 /* Make sure we have a zero-sized array. */
471 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
477 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
478 runtime_error ("rank of return array incorrect in"
479 " FINDLOC intrinsic: is %ld, should be %ld",
480 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
483 if (unlikely (compile_options
.bounds_check
))
484 bounds_ifunction_return ((array_t
*) retarray
, extent
,
485 "return value", "FINDLOC");
488 for (n
= 0; n
< rank
; n
++)
491 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
495 dest
= retarray
->base_addr
;
498 while (continue_loop
)
505 while (count
[n
] == extent
[n
])
508 dest
-= dstride
[n
] * extent
[n
];