1 /* Implementation of the EOSHIFT intrinsic
2 Copyright (C) 2002-2022 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 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"
30 #if defined (HAVE_GFC_INTEGER_8)
33 eoshift3 (gfc_array_char
* const restrict ret
,
34 const gfc_array_char
* const restrict array
,
35 const gfc_array_i8
* const restrict h
,
36 const gfc_array_char
* const restrict bound
,
37 const GFC_INTEGER_8
* const restrict pwhich
,
38 const char * filler
, index_type filler_len
)
40 /* r.* indicates the return array. */
41 index_type rstride
[GFC_MAX_DIMENSIONS
];
46 /* s.* indicates the source array. */
47 index_type sstride
[GFC_MAX_DIMENSIONS
];
52 /* h.* indicates the shift array. */
53 index_type hstride
[GFC_MAX_DIMENSIONS
];
55 const GFC_INTEGER_8
*hptr
;
56 /* b.* indicates the bound array. */
57 index_type bstride
[GFC_MAX_DIMENSIONS
];
61 index_type count
[GFC_MAX_DIMENSIONS
];
62 index_type extent
[GFC_MAX_DIMENSIONS
];
72 /* The compiler cannot figure out that these are set, initialize
73 them to avoid warnings. */
78 arraysize
= size0 ((array_t
*) array
);
79 size
= GFC_DESCRIPTOR_SIZE(array
);
86 if (ret
->base_addr
== NULL
)
88 ret
->base_addr
= xmallocarray (arraysize
, size
);
90 GFC_DTYPE_COPY(ret
,array
);
91 for (index_type i
= 0; i
< GFC_DESCRIPTOR_RANK (array
); i
++)
95 ub
= GFC_DESCRIPTOR_EXTENT(array
,i
) - 1;
100 str
= GFC_DESCRIPTOR_EXTENT(ret
,i
-1)
101 * GFC_DESCRIPTOR_STRIDE(ret
,i
-1);
103 GFC_DIMENSION_SET(ret
->dim
[i
], 0, ub
, str
);
106 /* xmallocarray allocates a single byte for zero size. */
107 ret
->base_addr
= xmallocarray (arraysize
, size
);
110 else if (unlikely (compile_options
.bounds_check
))
112 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
113 "return value", "EOSHIFT");
116 if (unlikely (compile_options
.bounds_check
))
118 bounds_reduced_extents ((array_t
*) h
, (array_t
*) array
, which
,
119 "SHIFT argument", "EOSHIFT");
128 for (dim
= 0; dim
< GFC_DESCRIPTOR_RANK (array
); dim
++)
132 roffset
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
135 soffset
= GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
138 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
143 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,dim
);
144 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
145 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
147 hstride
[n
] = GFC_DESCRIPTOR_STRIDE(h
,n
);
149 bstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(bound
,n
);
161 if (bound
&& bstride
[0] == 0)
164 dim
= GFC_DESCRIPTOR_RANK (array
);
165 rstride0
= rstride
[0];
166 sstride0
= sstride
[0];
167 hstride0
= hstride
[0];
168 bstride0
= bstride
[0];
169 rptr
= ret
->base_addr
;
170 sptr
= array
->base_addr
;
173 bptr
= bound
->base_addr
;
179 /* Do the shift for this dimension. */
181 if (( sh
>= 0 ? sh
: -sh
) > len
)
187 delta
= (sh
>= 0) ? sh
: -sh
;
191 src
= &sptr
[delta
* soffset
];
197 dest
= &rptr
[delta
* roffset
];
200 /* If the elements are contiguous, perform a single block move. */
201 if (soffset
== size
&& roffset
== size
)
203 size_t chunk
= size
* (len
- delta
);
204 memcpy (dest
, src
, chunk
);
209 for (n
= 0; n
< len
- delta
; n
++)
211 memcpy (dest
, src
, size
);
224 memcpy (dest
, bptr
, size
);
233 memset (dest
, filler
[0], size
);
235 for (i
= 0; i
< size
; i
+= filler_len
)
236 memcpy (&dest
[i
], filler
, filler_len
);
241 /* Advance to the next section. */
248 while (count
[n
] == extent
[n
])
250 /* When we get to the end of a dimension, reset it and increment
251 the next dimension. */
253 /* We could precalculate these products, but this is a less
254 frequently used path so probably not worth it. */
255 rptr
-= rstride
[n
] * extent
[n
];
256 sptr
-= sstride
[n
] * extent
[n
];
257 hptr
-= hstride
[n
] * extent
[n
];
258 bptr
-= bstride
[n
] * extent
[n
];
262 /* Break out of the loop. */
278 extern void eoshift3_8 (gfc_array_char
* const restrict
,
279 const gfc_array_char
* const restrict
,
280 const gfc_array_i8
* const restrict
,
281 const gfc_array_char
* const restrict
,
282 const GFC_INTEGER_8
*);
283 export_proto(eoshift3_8
);
286 eoshift3_8 (gfc_array_char
* const restrict ret
,
287 const gfc_array_char
* const restrict array
,
288 const gfc_array_i8
* const restrict h
,
289 const gfc_array_char
* const restrict bound
,
290 const GFC_INTEGER_8
* const restrict pwhich
)
292 eoshift3 (ret
, array
, h
, bound
, pwhich
, "\0", 1);
296 extern void eoshift3_8_char (gfc_array_char
* const restrict
,
298 const gfc_array_char
* const restrict
,
299 const gfc_array_i8
* const restrict
,
300 const gfc_array_char
* const restrict
,
301 const GFC_INTEGER_8
* const restrict
,
302 GFC_INTEGER_4
, GFC_INTEGER_4
);
303 export_proto(eoshift3_8_char
);
306 eoshift3_8_char (gfc_array_char
* const restrict ret
,
307 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
308 const gfc_array_char
* const restrict array
,
309 const gfc_array_i8
* const restrict h
,
310 const gfc_array_char
* const restrict bound
,
311 const GFC_INTEGER_8
* const restrict pwhich
,
312 GFC_INTEGER_4 array_length
__attribute__((unused
)),
313 GFC_INTEGER_4 bound_length
__attribute__((unused
)))
315 eoshift3 (ret
, array
, h
, bound
, pwhich
, " ", 1);
319 extern void eoshift3_8_char4 (gfc_array_char
* const restrict
,
321 const gfc_array_char
* const restrict
,
322 const gfc_array_i8
* const restrict
,
323 const gfc_array_char
* const restrict
,
324 const GFC_INTEGER_8
* const restrict
,
325 GFC_INTEGER_4
, GFC_INTEGER_4
);
326 export_proto(eoshift3_8_char4
);
329 eoshift3_8_char4 (gfc_array_char
* const restrict ret
,
330 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
331 const gfc_array_char
* const restrict array
,
332 const gfc_array_i8
* const restrict h
,
333 const gfc_array_char
* const restrict bound
,
334 const GFC_INTEGER_8
* const restrict pwhich
,
335 GFC_INTEGER_4 array_length
__attribute__((unused
)),
336 GFC_INTEGER_4 bound_length
__attribute__((unused
)))
338 static const gfc_char4_t space
= (unsigned char) ' ';
339 eoshift3 (ret
, array
, h
, bound
, pwhich
,
340 (const char *) &space
, sizeof (gfc_char4_t
));