1 /* Implementation of the EOSHIFT intrinsic
2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of the GNU Fortran 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 #include <string.h>
28
29
30 #if defined (HAVE_GFC_INTEGER_16)
31
32 static void
eoshift1(gfc_array_char * const restrict ret,const gfc_array_char * const restrict array,const gfc_array_i16 * const restrict h,const char * const restrict pbound,const GFC_INTEGER_16 * const restrict pwhich,const char * filler,index_type filler_len)33 eoshift1 (gfc_array_char * const restrict ret,
34 const gfc_array_char * const restrict array,
35 const gfc_array_i16 * const restrict h,
36 const char * const restrict pbound,
37 const GFC_INTEGER_16 * const restrict pwhich,
38 const char * filler, index_type filler_len)
39 {
40 /* r.* indicates the return array. */
41 index_type rstride[GFC_MAX_DIMENSIONS];
42 index_type rstride0;
43 index_type roffset;
44 char *rptr;
45 char * restrict dest;
46 /* s.* indicates the source array. */
47 index_type sstride[GFC_MAX_DIMENSIONS];
48 index_type sstride0;
49 index_type soffset;
50 const char *sptr;
51 const char *src;
52 /* h.* indicates the shift array. */
53 index_type hstride[GFC_MAX_DIMENSIONS];
54 index_type hstride0;
55 const GFC_INTEGER_16 *hptr;
56
57 index_type count[GFC_MAX_DIMENSIONS];
58 index_type extent[GFC_MAX_DIMENSIONS];
59 index_type dim;
60 index_type len;
61 index_type n;
62 index_type size;
63 index_type arraysize;
64 int which;
65 GFC_INTEGER_16 sh;
66 GFC_INTEGER_16 delta;
67
68 /* The compiler cannot figure out that these are set, initialize
69 them to avoid warnings. */
70 len = 0;
71 soffset = 0;
72 roffset = 0;
73
74 size = GFC_DESCRIPTOR_SIZE(array);
75
76 if (pwhich)
77 which = *pwhich - 1;
78 else
79 which = 0;
80
81 extent[0] = 1;
82 count[0] = 0;
83
84 arraysize = size0 ((array_t *) array);
85 if (ret->base_addr == NULL)
86 {
87 ret->offset = 0;
88 GFC_DTYPE_COPY(ret,array);
89 for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
90 {
91 index_type ub, str;
92
93 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
94
95 if (i == 0)
96 str = 1;
97 else
98 str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
99 * GFC_DESCRIPTOR_STRIDE(ret,i-1);
100
101 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
102
103 }
104 /* xmallocarray allocates a single byte for zero size. */
105 ret->base_addr = xmallocarray (arraysize, size);
106
107 }
108 else if (unlikely (compile_options.bounds_check))
109 {
110 bounds_equal_extents ((array_t *) ret, (array_t *) array,
111 "return value", "EOSHIFT");
112 }
113
114 if (unlikely (compile_options.bounds_check))
115 {
116 bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
117 "SHIFT argument", "EOSHIFT");
118 }
119
120 if (arraysize == 0)
121 return;
122
123 n = 0;
124 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
125 {
126 if (dim == which)
127 {
128 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
129 if (roffset == 0)
130 roffset = size;
131 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
132 if (soffset == 0)
133 soffset = size;
134 len = GFC_DESCRIPTOR_EXTENT(array,dim);
135 }
136 else
137 {
138 count[n] = 0;
139 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
140 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
141 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
142
143 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
144 n++;
145 }
146 }
147 if (sstride[0] == 0)
148 sstride[0] = size;
149 if (rstride[0] == 0)
150 rstride[0] = size;
151 if (hstride[0] == 0)
152 hstride[0] = 1;
153
154 dim = GFC_DESCRIPTOR_RANK (array);
155 rstride0 = rstride[0];
156 sstride0 = sstride[0];
157 hstride0 = hstride[0];
158 rptr = ret->base_addr;
159 sptr = array->base_addr;
160 hptr = h->base_addr;
161
162 while (rptr)
163 {
164 /* Do the shift for this dimension. */
165 sh = *hptr;
166 if (( sh >= 0 ? sh : -sh ) > len)
167 {
168 delta = len;
169 sh = len;
170 }
171 else
172 delta = (sh >= 0) ? sh: -sh;
173
174 if (sh > 0)
175 {
176 src = &sptr[delta * soffset];
177 dest = rptr;
178 }
179 else
180 {
181 src = sptr;
182 dest = &rptr[delta * roffset];
183 }
184
185 /* If the elements are contiguous, perform a single block move. */
186 if (soffset == size && roffset == size)
187 {
188 size_t chunk = size * (len - delta);
189 memcpy (dest, src, chunk);
190 dest += chunk;
191 }
192 else
193 {
194 for (n = 0; n < len - delta; n++)
195 {
196 memcpy (dest, src, size);
197 dest += roffset;
198 src += soffset;
199 }
200 }
201 if (sh < 0)
202 dest = rptr;
203 n = delta;
204
205 if (pbound)
206 while (n--)
207 {
208 memcpy (dest, pbound, size);
209 dest += roffset;
210 }
211 else
212 while (n--)
213 {
214 index_type i;
215
216 if (filler_len == 1)
217 memset (dest, filler[0], size);
218 else
219 for (i = 0; i < size; i += filler_len)
220 memcpy (&dest[i], filler, filler_len);
221
222 dest += roffset;
223 }
224
225 /* Advance to the next section. */
226 rptr += rstride0;
227 sptr += sstride0;
228 hptr += hstride0;
229 count[0]++;
230 n = 0;
231 while (count[n] == extent[n])
232 {
233 /* When we get to the end of a dimension, reset it and increment
234 the next dimension. */
235 count[n] = 0;
236 /* We could precalculate these products, but this is a less
237 frequently used path so probably not worth it. */
238 rptr -= rstride[n] * extent[n];
239 sptr -= sstride[n] * extent[n];
240 hptr -= hstride[n] * extent[n];
241 n++;
242 if (n >= dim - 1)
243 {
244 /* Break out of the loop. */
245 rptr = NULL;
246 break;
247 }
248 else
249 {
250 count[n]++;
251 rptr += rstride[n];
252 sptr += sstride[n];
253 hptr += hstride[n];
254 }
255 }
256 }
257 }
258
259 void eoshift1_16 (gfc_array_char * const restrict,
260 const gfc_array_char * const restrict,
261 const gfc_array_i16 * const restrict, const char * const restrict,
262 const GFC_INTEGER_16 * const restrict);
263 export_proto(eoshift1_16);
264
265 void
eoshift1_16(gfc_array_char * const restrict ret,const gfc_array_char * const restrict array,const gfc_array_i16 * const restrict h,const char * const restrict pbound,const GFC_INTEGER_16 * const restrict pwhich)266 eoshift1_16 (gfc_array_char * const restrict ret,
267 const gfc_array_char * const restrict array,
268 const gfc_array_i16 * const restrict h,
269 const char * const restrict pbound,
270 const GFC_INTEGER_16 * const restrict pwhich)
271 {
272 eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
273 }
274
275
276 void eoshift1_16_char (gfc_array_char * const restrict,
277 GFC_INTEGER_4,
278 const gfc_array_char * const restrict,
279 const gfc_array_i16 * const restrict,
280 const char * const restrict,
281 const GFC_INTEGER_16 * const restrict,
282 GFC_INTEGER_4, GFC_INTEGER_4);
283 export_proto(eoshift1_16_char);
284
285 void
eoshift1_16_char(gfc_array_char * const restrict ret,GFC_INTEGER_4 ret_length,const gfc_array_char * const restrict array,const gfc_array_i16 * const restrict h,const char * const restrict pbound,const GFC_INTEGER_16 * const restrict pwhich,GFC_INTEGER_4 array_length,GFC_INTEGER_4 bound_length)286 eoshift1_16_char (gfc_array_char * const restrict ret,
287 GFC_INTEGER_4 ret_length __attribute__((unused)),
288 const gfc_array_char * const restrict array,
289 const gfc_array_i16 * const restrict h,
290 const char * const restrict pbound,
291 const GFC_INTEGER_16 * const restrict pwhich,
292 GFC_INTEGER_4 array_length __attribute__((unused)),
293 GFC_INTEGER_4 bound_length __attribute__((unused)))
294 {
295 eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
296 }
297
298
299 void eoshift1_16_char4 (gfc_array_char * const restrict,
300 GFC_INTEGER_4,
301 const gfc_array_char * const restrict,
302 const gfc_array_i16 * const restrict,
303 const char * const restrict,
304 const GFC_INTEGER_16 * const restrict,
305 GFC_INTEGER_4, GFC_INTEGER_4);
306 export_proto(eoshift1_16_char4);
307
308 void
eoshift1_16_char4(gfc_array_char * const restrict ret,GFC_INTEGER_4 ret_length,const gfc_array_char * const restrict array,const gfc_array_i16 * const restrict h,const char * const restrict pbound,const GFC_INTEGER_16 * const restrict pwhich,GFC_INTEGER_4 array_length,GFC_INTEGER_4 bound_length)309 eoshift1_16_char4 (gfc_array_char * const restrict ret,
310 GFC_INTEGER_4 ret_length __attribute__((unused)),
311 const gfc_array_char * const restrict array,
312 const gfc_array_i16 * const restrict h,
313 const char * const restrict pbound,
314 const GFC_INTEGER_16 * const restrict pwhich,
315 GFC_INTEGER_4 array_length __attribute__((unused)),
316 GFC_INTEGER_4 bound_length __attribute__((unused)))
317 {
318 static const gfc_char4_t space = (unsigned char) ' ';
319 eoshift1 (ret, array, h, pbound, pwhich,
320 (const char *) &space, sizeof (gfc_char4_t));
321 }
322
323 #endif
324