1 /* Special implementation of the SPREAD intrinsic
2 Copyright (C) 2008-2023 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
4 spread_generic.c written by Paul Brook <paul@nowt.org>
5
6 This file is part of the GNU Fortran runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
12
13 Ligbfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
26
27 #include "libgfortran.h"
28 #include <string.h>
29
30
31 #if defined (HAVE_GFC_INTEGER_1)
32
33 void
34 spread_i1 (gfc_array_i1 *ret, const gfc_array_i1 *source,
35 const index_type along, const index_type pncopies)
36 {
37 /* r.* indicates the return array. */
38 index_type rstride[GFC_MAX_DIMENSIONS];
39 index_type rstride0;
40 index_type rdelta = 0;
41 index_type rrank;
42 index_type rs;
43 GFC_INTEGER_1 *rptr;
44 GFC_INTEGER_1 * restrict dest;
45 /* s.* indicates the source array. */
46 index_type sstride[GFC_MAX_DIMENSIONS];
47 index_type sstride0;
48 index_type srank;
49 const GFC_INTEGER_1 *sptr;
50
51 index_type count[GFC_MAX_DIMENSIONS];
52 index_type extent[GFC_MAX_DIMENSIONS];
53 index_type n;
54 index_type dim;
55 index_type ncopies;
56
57 srank = GFC_DESCRIPTOR_RANK(source);
58
59 sstride[0] = 0; /* Avoid warnings if not initialized. */
60
61 rrank = srank + 1;
62 if (rrank > GFC_MAX_DIMENSIONS)
63 runtime_error ("return rank too large in spread()");
64
65 if (along > rrank)
66 runtime_error ("dim outside of rank in spread()");
67
68 ncopies = pncopies;
69
70 if (ret->base_addr == NULL)
71 {
72
73 size_t ub, stride;
74
75 /* The front end has signalled that we need to populate the
76 return array descriptor. */
77 ret->dtype.rank = rrank;
78
79 dim = 0;
80 rs = 1;
81 for (n = 0; n < rrank; n++)
82 {
83 stride = rs;
84 if (n == along - 1)
85 {
86 ub = ncopies - 1;
87 rdelta = rs;
88 rs *= ncopies;
89 }
90 else
91 {
92 count[dim] = 0;
93 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
94 sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
95 rstride[dim] = rs;
96
97 ub = extent[dim] - 1;
98 rs *= extent[dim];
99 dim++;
100 }
101 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
102 }
103 ret->offset = 0;
104
105 /* xmallocarray allocates a single byte for zero size. */
106 ret->base_addr = xmallocarray (rs, sizeof(GFC_INTEGER_1));
107 if (rs <= 0)
108 return;
109 }
110 else
111 {
112 int zero_sized;
113
114 zero_sized = 0;
115
116 dim = 0;
117 if (GFC_DESCRIPTOR_RANK(ret) != rrank)
118 runtime_error ("rank mismatch in spread()");
119
120 if (unlikely (compile_options.bounds_check))
121 {
122 for (n = 0; n < rrank; n++)
123 {
124 index_type ret_extent;
125
126 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
127 if (n == along - 1)
128 {
129 rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
130
131 if (ret_extent != ncopies)
132 runtime_error("Incorrect extent in return value of SPREAD"
133 " intrinsic in dimension %ld: is %ld,"
134 " should be %ld", (long int) n+1,
135 (long int) ret_extent, (long int) ncopies);
136 }
137 else
138 {
139 count[dim] = 0;
140 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
141 if (ret_extent != extent[dim])
142 runtime_error("Incorrect extent in return value of SPREAD"
143 " intrinsic in dimension %ld: is %ld,"
144 " should be %ld", (long int) n+1,
145 (long int) ret_extent,
146 (long int) extent[dim]);
147
148 if (extent[dim] <= 0)
149 zero_sized = 1;
150 sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
151 rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
152 dim++;
153 }
154 }
155 }
156 else
157 {
158 for (n = 0; n < rrank; n++)
159 {
160 if (n == along - 1)
161 {
162 rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
163 }
164 else
165 {
166 count[dim] = 0;
167 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
168 if (extent[dim] <= 0)
169 zero_sized = 1;
170 sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
171 rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
172 dim++;
173 }
174 }
175 }
176
177 if (zero_sized)
178 return;
179
180 if (sstride[0] == 0)
181 sstride[0] = 1;
182 }
183 sstride0 = sstride[0];
184 rstride0 = rstride[0];
185 rptr = ret->base_addr;
186 sptr = source->base_addr;
187
188 while (sptr)
189 {
190 /* Spread this element. */
191 dest = rptr;
192 for (n = 0; n < ncopies; n++)
193 {
194 *dest = *sptr;
195 dest += rdelta;
196 }
197 /* Advance to the next element. */
198 sptr += sstride0;
199 rptr += rstride0;
200 count[0]++;
201 n = 0;
202 while (count[n] == extent[n])
203 {
204 /* When we get to the end of a dimension, reset it and increment
205 the next dimension. */
206 count[n] = 0;
207 /* We could precalculate these products, but this is a less
208 frequently used path so probably not worth it. */
209 sptr -= sstride[n] * extent[n];
210 rptr -= rstride[n] * extent[n];
211 n++;
212 if (n >= srank)
213 {
214 /* Break out of the loop. */
215 sptr = NULL;
216 break;
217 }
218 else
219 {
220 count[n]++;
221 sptr += sstride[n];
222 rptr += rstride[n];
223 }
224 }
225 }
226 }
227
228 /* This version of spread_internal treats the special case of a scalar
229 source. This is much simpler than the more general case above. */
230
231 void
232 spread_scalar_i1 (gfc_array_i1 *ret, const GFC_INTEGER_1 *source,
233 const index_type along, const index_type ncopies)
234 {
235 GFC_INTEGER_1 * restrict dest;
236 index_type stride;
237
238 if (GFC_DESCRIPTOR_RANK (ret) != 1)
239 runtime_error ("incorrect destination rank in spread()");
240
241 if (along > 1)
242 runtime_error ("dim outside of rank in spread()");
243
244 if (ret->base_addr == NULL)
245 {
246 ret->base_addr = xmallocarray (ncopies, sizeof (GFC_INTEGER_1));
247 ret->offset = 0;
248 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
249 }
250 else
251 {
252 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
253 / GFC_DESCRIPTOR_STRIDE(ret,0))
254 runtime_error ("dim too large in spread()");
255 }
256
257 dest = ret->base_addr;
258 stride = GFC_DESCRIPTOR_STRIDE(ret,0);
259
260 for (index_type n = 0; n < ncopies; n++)
261 {
262 *dest = *source;
263 dest += stride;
264 }
265 }
266
267 #endif
268