1 /* Implementation of the EOSHIFT intrinsic
2 Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 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"
32 #if defined (HAVE_GFC_INTEGER_16)
35 eoshift3 (gfc_array_char
* const restrict ret
,
36 const gfc_array_char
* const restrict array
,
37 const gfc_array_i16
* const restrict h
,
38 const gfc_array_char
* const restrict bound
,
39 const GFC_INTEGER_16
* const restrict pwhich
,
40 const char * filler
, index_type filler_len
)
42 /* r.* indicates the return array. */
43 index_type rstride
[GFC_MAX_DIMENSIONS
];
48 /* s.* indicates the source array. */
49 index_type sstride
[GFC_MAX_DIMENSIONS
];
54 /* h.* indicates the shift array. */
55 index_type hstride
[GFC_MAX_DIMENSIONS
];
57 const GFC_INTEGER_16
*hptr
;
58 /* b.* indicates the bound array. */
59 index_type bstride
[GFC_MAX_DIMENSIONS
];
63 index_type count
[GFC_MAX_DIMENSIONS
];
64 index_type extent
[GFC_MAX_DIMENSIONS
];
74 /* The compiler cannot figure out that these are set, initialize
75 them to avoid warnings. */
80 arraysize
= size0 ((array_t
*) array
);
81 size
= GFC_DESCRIPTOR_SIZE(array
);
88 if (ret
->data
== NULL
)
92 ret
->data
= internal_malloc_size (size
* arraysize
);
94 ret
->dtype
= array
->dtype
;
95 for (i
= 0; i
< GFC_DESCRIPTOR_RANK (array
); i
++)
99 ub
= GFC_DESCRIPTOR_EXTENT(array
,i
) - 1;
104 str
= GFC_DESCRIPTOR_EXTENT(ret
,i
-1)
105 * GFC_DESCRIPTOR_STRIDE(ret
,i
-1);
107 GFC_DIMENSION_SET(ret
->dim
[i
], 0, ub
, str
);
111 ret
->data
= internal_malloc_size (size
* arraysize
);
113 ret
->data
= internal_malloc_size (1);
116 else if (unlikely (compile_options
.bounds_check
))
118 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
119 "return value", "EOSHIFT");
122 if (unlikely (compile_options
.bounds_check
))
124 bounds_reduced_extents ((array_t
*) h
, (array_t
*) array
, which
,
125 "SHIFT argument", "EOSHIFT");
134 for (dim
= 0; dim
< GFC_DESCRIPTOR_RANK (array
); dim
++)
138 roffset
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
141 soffset
= GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
144 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
149 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,dim
);
150 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,dim
);
151 sstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(array
,dim
);
153 hstride
[n
] = GFC_DESCRIPTOR_STRIDE(h
,n
);
155 bstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(bound
,n
);
167 if (bound
&& bstride
[0] == 0)
170 dim
= GFC_DESCRIPTOR_RANK (array
);
171 rstride0
= rstride
[0];
172 sstride0
= sstride
[0];
173 hstride0
= hstride
[0];
174 bstride0
= bstride
[0];
185 /* Do the shift for this dimension. */
187 if (( sh
>= 0 ? sh
: -sh
) > len
)
193 delta
= (sh
>= 0) ? sh
: -sh
;
197 src
= &sptr
[delta
* soffset
];
203 dest
= &rptr
[delta
* roffset
];
205 for (n
= 0; n
< len
- delta
; n
++)
207 memcpy (dest
, src
, size
);
218 memcpy (dest
, bptr
, size
);
227 memset (dest
, filler
[0], size
);
229 for (i
= 0; i
< size
; i
+= filler_len
)
230 memcpy (&dest
[i
], filler
, filler_len
);
235 /* Advance to the next section. */
242 while (count
[n
] == extent
[n
])
244 /* When we get to the end of a dimension, reset it and increment
245 the next dimension. */
247 /* We could precalculate these products, but this is a less
248 frequently used path so probably not worth it. */
249 rptr
-= rstride
[n
] * extent
[n
];
250 sptr
-= sstride
[n
] * extent
[n
];
251 hptr
-= hstride
[n
] * extent
[n
];
252 bptr
-= bstride
[n
] * extent
[n
];
256 /* Break out of the loop. */
272 extern void eoshift3_16 (gfc_array_char
* const restrict
,
273 const gfc_array_char
* const restrict
,
274 const gfc_array_i16
* const restrict
,
275 const gfc_array_char
* const restrict
,
276 const GFC_INTEGER_16
*);
277 export_proto(eoshift3_16
);
280 eoshift3_16 (gfc_array_char
* const restrict ret
,
281 const gfc_array_char
* const restrict array
,
282 const gfc_array_i16
* const restrict h
,
283 const gfc_array_char
* const restrict bound
,
284 const GFC_INTEGER_16
* const restrict pwhich
)
286 eoshift3 (ret
, array
, h
, bound
, pwhich
, "\0", 1);
290 extern void eoshift3_16_char (gfc_array_char
* const restrict
,
292 const gfc_array_char
* const restrict
,
293 const gfc_array_i16
* const restrict
,
294 const gfc_array_char
* const restrict
,
295 const GFC_INTEGER_16
* const restrict
,
296 GFC_INTEGER_4
, GFC_INTEGER_4
);
297 export_proto(eoshift3_16_char
);
300 eoshift3_16_char (gfc_array_char
* const restrict ret
,
301 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
302 const gfc_array_char
* const restrict array
,
303 const gfc_array_i16
* const restrict h
,
304 const gfc_array_char
* const restrict bound
,
305 const GFC_INTEGER_16
* const restrict pwhich
,
306 GFC_INTEGER_4 array_length
__attribute__((unused
)),
307 GFC_INTEGER_4 bound_length
__attribute__((unused
)))
309 eoshift3 (ret
, array
, h
, bound
, pwhich
, " ", 1);
313 extern void eoshift3_16_char4 (gfc_array_char
* const restrict
,
315 const gfc_array_char
* const restrict
,
316 const gfc_array_i16
* const restrict
,
317 const gfc_array_char
* const restrict
,
318 const GFC_INTEGER_16
* const restrict
,
319 GFC_INTEGER_4
, GFC_INTEGER_4
);
320 export_proto(eoshift3_16_char4
);
323 eoshift3_16_char4 (gfc_array_char
* const restrict ret
,
324 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
325 const gfc_array_char
* const restrict array
,
326 const gfc_array_i16
* const restrict h
,
327 const gfc_array_char
* const restrict bound
,
328 const GFC_INTEGER_16
* const restrict pwhich
,
329 GFC_INTEGER_4 array_length
__attribute__((unused
)),
330 GFC_INTEGER_4 bound_length
__attribute__((unused
)))
332 static const gfc_char4_t space
= (unsigned char) ' ';
333 eoshift3 (ret
, array
, h
, bound
, pwhich
,
334 (const char *) &space
, sizeof (gfc_char4_t
));