annotate libgfortran/generated/findloc1_s4.c @ 158:494b0b89df80 default tip

...
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 25 May 2020 18:13:55 +0900
parents 1830386684a0
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
145
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
1 /* Implementation of the FINDLOC intrinsic
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
2 Copyright (C) 2018-2020 Free Software Foundation, Inc.
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
3 Contributed by Thomas König <tk@tkoenig.net>
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
4
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
6
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
7 Libgfortran is free software; you can redistribute it and/or
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
8 modify it under the terms of the GNU General Public
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
9 License as published by the Free Software Foundation; either
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
10 version 3 of the License, or (at your option) any later version.
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
11
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
12 Libgfortran is distributed in the hope that it will be useful,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
15 GNU General Public License for more details.
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
16
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
17 Under Section 7 of GPL version 3, you are granted additional
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
18 permissions described in the GCC Runtime Library Exception, version
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
19 3.1, as published by the Free Software Foundation.
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
20
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
21 You should have received a copy of the GNU General Public License and
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
22 a copy of the GCC Runtime Library Exception along with this program;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
24 <http://www.gnu.org/licenses/>. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
25
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
26 #include "libgfortran.h"
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
27 #include <assert.h>
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
28
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
29 #if defined (HAVE_GFC_UINTEGER_4)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
30 extern void findloc1_s4 (gfc_array_index_type * const restrict retarray,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
31 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
32 const index_type * restrict pdim, GFC_LOGICAL_4 back,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
33 gfc_charlen_type len_array, gfc_charlen_type len_value);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
34 export_proto(findloc1_s4);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
35
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
36 extern void
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
37 findloc1_s4 (gfc_array_index_type * const restrict retarray,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
38 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
39 const index_type * restrict pdim, GFC_LOGICAL_4 back,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
40 gfc_charlen_type len_array, gfc_charlen_type len_value)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
41 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
42 index_type count[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
43 index_type extent[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
44 index_type sstride[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
45 index_type dstride[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
46 const GFC_UINTEGER_4 * restrict base;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
47 index_type * restrict dest;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
48 index_type rank;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
49 index_type n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
50 index_type len;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
51 index_type delta;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
52 index_type dim;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
53 int continue_loop;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
54
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
55 /* Make dim zero based to avoid confusion. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
56 rank = GFC_DESCRIPTOR_RANK (array) - 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
57 dim = (*pdim) - 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
58
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
59 if (unlikely (dim < 0 || dim > rank))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
60 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
61 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
62 "is %ld, should be between 1 and %ld",
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
63 (long int) dim + 1, (long int) rank + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
64 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
65
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
66 len = GFC_DESCRIPTOR_EXTENT(array,dim);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
67 if (len < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
68 len = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
69 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
70
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
71 for (n = 0; n < dim; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
72 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
73 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
74 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
75
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
76 if (extent[n] < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
77 extent[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
78 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
79 for (n = dim; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
80 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
81 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
82 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
83
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
84 if (extent[n] < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
85 extent[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
86 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
87
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
88 if (retarray->base_addr == NULL)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
89 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
90 size_t alloc_size, str;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
91
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
92 for (n = 0; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
93 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
94 if (n == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
95 str = 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
96 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
97 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
98
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
99 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
100
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
101 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
102
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
103 retarray->offset = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
104 retarray->dtype.rank = rank;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
105
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
106 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
107
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
108 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
109 if (alloc_size == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
110 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
111 /* Make sure we have a zero-sized array. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
112 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
113 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
114 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
115 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
116 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
117 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
118 if (rank != GFC_DESCRIPTOR_RANK (retarray))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
119 runtime_error ("rank of return array incorrect in"
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
120 " FINDLOC intrinsic: is %ld, should be %ld",
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
121 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
122 (long int) rank);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
123
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
124 if (unlikely (compile_options.bounds_check))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
125 bounds_ifunction_return ((array_t *) retarray, extent,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
126 "return value", "FINDLOC");
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
127 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
128
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
129 for (n = 0; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
130 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
131 count[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
132 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
133 if (extent[n] <= 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
134 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
135 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
136
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
137 dest = retarray->base_addr;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
138 continue_loop = 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
139
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
140 base = array->base_addr;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
141 while (continue_loop)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
142 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
143 const GFC_UINTEGER_4 * restrict src;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
144 index_type result;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
145
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
146 result = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
147 if (back)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
148 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
149 src = base + (len - 1) * delta * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
150 for (n = len; n > 0; n--, src -= delta * len_array)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
151 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
152 if (compare_string_char4 (len_array, src, len_value, value) == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
153 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
154 result = n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
155 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
156 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
157 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
158 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
159 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
160 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
161 src = base;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
162 for (n = 1; n <= len; n++, src += delta * len_array)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
163 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
164 if (compare_string_char4 (len_array, src, len_value, value) == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
165 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
166 result = n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
167 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
168 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
169 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
170 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
171 *dest = result;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
172
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
173 count[0]++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
174 base += sstride[0] * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
175 dest += dstride[0];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
176 n = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
177 while (count[n] == extent[n])
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
178 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
179 count[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
180 base -= sstride[n] * extent[n] * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
181 dest -= dstride[n] * extent[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
182 n++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
183 if (n >= rank)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
184 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
185 continue_loop = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
186 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
187 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
188 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
189 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
190 count[n]++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
191 base += sstride[n] * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
192 dest += dstride[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
193 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
194 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
195 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
196 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
197 extern void mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
198 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
199 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
200 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
201 export_proto(mfindloc1_s4);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
202
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
203 extern void
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
204 mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
205 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
206 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
207 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
208 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
209 index_type count[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
210 index_type extent[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
211 index_type sstride[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
212 index_type mstride[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
213 index_type dstride[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
214 const GFC_UINTEGER_4 * restrict base;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
215 const GFC_LOGICAL_1 * restrict mbase;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
216 index_type * restrict dest;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
217 index_type rank;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
218 index_type n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
219 index_type len;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
220 index_type delta;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
221 index_type mdelta;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
222 index_type dim;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
223 int mask_kind;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
224 int continue_loop;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
225
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
226 /* Make dim zero based to avoid confusion. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
227 rank = GFC_DESCRIPTOR_RANK (array) - 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
228 dim = (*pdim) - 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
229
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
230 if (unlikely (dim < 0 || dim > rank))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
231 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
232 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
233 "is %ld, should be between 1 and %ld",
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
234 (long int) dim + 1, (long int) rank + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
235 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
236
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
237 len = GFC_DESCRIPTOR_EXTENT(array,dim);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
238 if (len < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
239 len = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
240
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
241 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
242 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
243
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
244 mbase = mask->base_addr;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
245
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
246 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
247
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
248 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
249 #ifdef HAVE_GFC_LOGICAL_16
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
250 || mask_kind == 16
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
251 #endif
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
252 )
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
253 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
254 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
255 internal_error (NULL, "Funny sized logical array");
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
256
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
257 for (n = 0; n < dim; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
258 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
259 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
260 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
261 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
262
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
263 if (extent[n] < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
264 extent[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
265 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
266 for (n = dim; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
267 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
268 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
269 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
270 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
271
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
272 if (extent[n] < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
273 extent[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
274 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
275
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
276 if (retarray->base_addr == NULL)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
277 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
278 size_t alloc_size, str;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
279
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
280 for (n = 0; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
281 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
282 if (n == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
283 str = 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
284 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
285 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
286
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
287 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
288
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
289 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
290
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
291 retarray->offset = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
292 retarray->dtype.rank = rank;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
293
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
294 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
295
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
296 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
297 if (alloc_size == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
298 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
299 /* Make sure we have a zero-sized array. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
300 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
301 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
302 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
303 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
304 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
305 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
306 if (rank != GFC_DESCRIPTOR_RANK (retarray))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
307 runtime_error ("rank of return array incorrect in"
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
308 " FINDLOC intrinsic: is %ld, should be %ld",
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
309 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
310 (long int) rank);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
311
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
312 if (unlikely (compile_options.bounds_check))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
313 bounds_ifunction_return ((array_t *) retarray, extent,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
314 "return value", "FINDLOC");
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
315 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
316
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
317 for (n = 0; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
318 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
319 count[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
320 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
321 if (extent[n] <= 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
322 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
323 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
324
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
325 dest = retarray->base_addr;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
326 continue_loop = 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
327
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
328 base = array->base_addr;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
329 while (continue_loop)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
330 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
331 const GFC_UINTEGER_4 * restrict src;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
332 const GFC_LOGICAL_1 * restrict msrc;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
333 index_type result;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
334
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
335 result = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
336 if (back)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
337 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
338 src = base + (len - 1) * delta * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
339 msrc = mbase + (len - 1) * mdelta;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
340 for (n = len; n > 0; n--, src -= delta * len_array, msrc -= mdelta)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
341 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
342 if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
343 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
344 result = n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
345 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
346 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
347 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
348 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
349 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
350 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
351 src = base;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
352 msrc = mbase;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
353 for (n = 1; n <= len; n++, src += delta * len_array, msrc += mdelta)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
354 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
355 if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
356 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
357 result = n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
358 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
359 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
360 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
361 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
362 *dest = result;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
363
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
364 count[0]++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
365 base += sstride[0] * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
366 mbase += mstride[0];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
367 dest += dstride[0];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
368 n = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
369 while (count[n] == extent[n])
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
370 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
371 count[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
372 base -= sstride[n] * extent[n] * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
373 mbase -= mstride[n] * extent[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
374 dest -= dstride[n] * extent[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
375 n++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
376 if (n >= rank)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
377 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
378 continue_loop = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
379 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
380 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
381 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
382 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
383 count[n]++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
384 base += sstride[n] * len_array;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
385 dest += dstride[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
386 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
387 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
388 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
389 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
390 extern void sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
391 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
392 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
393 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
394 export_proto(sfindloc1_s4);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
395
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
396 extern void
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
397 sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
398 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
399 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
400 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
401 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
402 index_type count[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
403 index_type extent[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
404 index_type dstride[GFC_MAX_DIMENSIONS];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
405 index_type * restrict dest;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
406 index_type rank;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
407 index_type n;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
408 index_type len;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
409 index_type dim;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
410 bool continue_loop;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
411
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
412 if (mask == NULL || *mask)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
413 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
414 findloc1_s4 (retarray, array, value, pdim, back, len_array, len_value);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
415 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
416 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
417 /* Make dim zero based to avoid confusion. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
418 rank = GFC_DESCRIPTOR_RANK (array) - 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
419 dim = (*pdim) - 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
420
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
421 if (unlikely (dim < 0 || dim > rank))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
422 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
423 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
424 "is %ld, should be between 1 and %ld",
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
425 (long int) dim + 1, (long int) rank + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
426 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
427
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
428 len = GFC_DESCRIPTOR_EXTENT(array,dim);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
429 if (len < 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
430 len = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
431
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
432 for (n = 0; n < dim; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
433 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
434 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
435
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
436 if (extent[n] <= 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
437 extent[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
438 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
439
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
440 for (n = dim; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
441 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
442 extent[n] =
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
443 GFC_DESCRIPTOR_EXTENT(array,n + 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
444
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
445 if (extent[n] <= 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
446 extent[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
447 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
448
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
449
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
450 if (retarray->base_addr == NULL)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
451 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
452 size_t alloc_size, str;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
453
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
454 for (n = 0; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
455 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
456 if (n == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
457 str = 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
458 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
459 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
460
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
461 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
462 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
463
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
464 retarray->offset = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
465 retarray->dtype.rank = rank;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
466
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
467 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
468
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
469 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
470 if (alloc_size == 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
471 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
472 /* Make sure we have a zero-sized array. */
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
473 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
474 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
475 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
476 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
477 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
478 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
479 if (rank != GFC_DESCRIPTOR_RANK (retarray))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
480 runtime_error ("rank of return array incorrect in"
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
481 " FINDLOC intrinsic: is %ld, should be %ld",
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
482 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
483 (long int) rank);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
484
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
485 if (unlikely (compile_options.bounds_check))
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
486 bounds_ifunction_return ((array_t *) retarray, extent,
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
487 "return value", "FINDLOC");
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
488 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
489
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
490 for (n = 0; n < rank; n++)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
491 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
492 count[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
493 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
494 if (extent[n] <= 0)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
495 return;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
496 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
497 dest = retarray->base_addr;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
498 continue_loop = 1;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
499
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
500 while (continue_loop)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
501 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
502 *dest = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
503
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
504 count[0]++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
505 dest += dstride[0];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
506 n = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
507 while (count[n] == extent[n])
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
508 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
509 count[n] = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
510 dest -= dstride[n] * extent[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
511 n++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
512 if (n >= rank)
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
513 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
514 continue_loop = 0;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
515 break;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
516 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
517 else
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
518 {
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
519 count[n]++;
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
520 dest += dstride[n];
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
521 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
522 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
523 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
524 }
1830386684a0 gcc-9.2.0
anatofuz
parents:
diff changeset
525 #endif