1 /* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2023 Free Software Foundation, Inc.
3 Contributed by Thomas König <tk@tkoenig.net>
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
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.
11
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.
16
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.
20
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/>. */
25
26 #include "libgfortran.h"
27
28 #ifdef HAVE_GFC_UINTEGER_4
29 index_type findloc2_s4 (gfc_array_s4 * const restrict array,
30 const GFC_UINTEGER_4 * restrict value, GFC_LOGICAL_4 back,
31 gfc_charlen_type len_array, gfc_charlen_type len_value);
32 export_proto(findloc2_s4);
33
34 index_type
35 findloc2_s4 (gfc_array_s4 * const restrict array, const GFC_UINTEGER_4 * restrict value,
36 GFC_LOGICAL_4 back,
37 gfc_charlen_type len_array, gfc_charlen_type len_value)
38 {
39 index_type i;
40 index_type sstride;
41 index_type extent;
42 const GFC_UINTEGER_4 * restrict src;
43
44 extent = GFC_DESCRIPTOR_EXTENT(array,0);
45 if (extent <= 0)
46 return 0;
47
48 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
49 if (back)
50 {
51 src = array->base_addr + (extent - 1) * sstride;
52 for (i = extent; i >= 0; i--)
53 {
54 if (compare_string_char4 (len_array, src, len_value, value) == 0)
55 return i;
56 src -= sstride;
57 }
58 }
59 else
60 {
61 src = array->base_addr;
62 for (i = 1; i <= extent; i++)
63 {
64 if (compare_string_char4 (len_array, src, len_value, value) == 0)
65 return i;
66 src += sstride;
67 }
68 }
69 return 0;
70 }
71
72 index_type mfindloc2_s4 (gfc_array_s4 * const restrict array,
73 const GFC_UINTEGER_4 * restrict value,
74 gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
75 gfc_charlen_type len_array, gfc_charlen_type len_value);
76 export_proto(mfindloc2_s4);
77
78 index_type
79 mfindloc2_s4 (gfc_array_s4 * const restrict array,
80 const GFC_UINTEGER_4 * restrict value, gfc_array_l1 *const restrict mask,
81 GFC_LOGICAL_4 back, gfc_charlen_type len_array,
82 gfc_charlen_type len_value)
83 {
84 index_type i;
85 index_type sstride;
86 index_type extent;
87 const GFC_UINTEGER_4 * restrict src;
88 const GFC_LOGICAL_1 * restrict mbase;
89 int mask_kind;
90 index_type mstride;
91
92 extent = GFC_DESCRIPTOR_EXTENT(array,0);
93 if (extent <= 0)
94 return 0;
95
96 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
97 mbase = mask->base_addr;
98
99 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
100 #ifdef HAVE_GFC_LOGICAL_16
101 || mask_kind == 16
102 #endif
103 )
104 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
105 else
106 internal_error (NULL, "Funny sized logical array");
107
108 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
109 mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
110
111 if (back)
112 {
113 src = array->base_addr + (extent - 1) * sstride;
114 mbase += (extent - 1) * mstride;
115 for (i = extent; i >= 0; i--)
116 {
117 if (*mbase && (compare_string_char4 (len_array, src, len_value, value) == 0))
118 return i;
119 src -= sstride;
120 mbase -= mstride;
121 }
122 }
123 else
124 {
125 src = array->base_addr;
126 for (i = 1; i <= extent; i++)
127 {
128 if (*mbase && (compare_string_char4 (len_array, src, len_value, value) == 0))
129 return i;
130 src += sstride;
131 mbase += mstride;
132 }
133 }
134 return 0;
135 }
136 index_type sfindloc2_s4 (gfc_array_s4 * const restrict array,
137 const GFC_UINTEGER_4 * restrict value,
138 GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back,
139 gfc_charlen_type len_array, gfc_charlen_type len_value);
140 export_proto(sfindloc2_s4);
141
142 index_type
143 sfindloc2_s4 (gfc_array_s4 * const restrict array,
144 const GFC_UINTEGER_4 * restrict value, GFC_LOGICAL_4 *const restrict mask,
145 GFC_LOGICAL_4 back, gfc_charlen_type len_array,
146 gfc_charlen_type len_value)
147 {
148 if (mask == NULL || *mask)
149 {
150 return findloc2_s4 (array, value, back, len_array, len_value);
151 }
152 return 0;
153 }
154 #endif