1 /* Implementation of the EOSHIFT intrinsic
2 Copyright 2002, 2005, 2007, 2009, 2012 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"
32 #if defined (HAVE_GFC_INTEGER_8)
35 eoshift1 (gfc_array_char
* const restrict ret
,
36 const gfc_array_char
* const restrict array
,
37 const gfc_array_i8
* const restrict h
,
38 const char * const restrict pbound
,
39 const GFC_INTEGER_8
* 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_8
*hptr
;
59 index_type count
[GFC_MAX_DIMENSIONS
];
60 index_type extent
[GFC_MAX_DIMENSIONS
];
70 /* The compiler cannot figure out that these are set, initialize
71 them to avoid warnings. */
76 size
= GFC_DESCRIPTOR_SIZE(array
);
86 arraysize
= size0 ((array_t
*) array
);
87 if (ret
->base_addr
== NULL
)
92 ret
->dtype
= array
->dtype
;
93 for (i
= 0; i
< GFC_DESCRIPTOR_RANK (array
); i
++)
97 ub
= GFC_DESCRIPTOR_EXTENT(array
,i
) - 1;
102 str
= GFC_DESCRIPTOR_EXTENT(ret
,i
-1)
103 * GFC_DESCRIPTOR_STRIDE(ret
,i
-1);
105 GFC_DIMENSION_SET(ret
->dim
[i
], 0, ub
, str
);
108 /* internal_malloc_size allocates a single byte for zero size. */
109 ret
->base_addr
= internal_malloc_size (size
* arraysize
);
112 else if (unlikely (compile_options
.bounds_check
))
114 bounds_equal_extents ((array_t
*) ret
, (array_t
*) array
,
115 "return value", "EOSHIFT");
118 if (unlikely (compile_options
.bounds_check
))
120 bounds_reduced_extents ((array_t
*) h
, (array_t
*) array
, which
,
121 "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
);
158 dim
= GFC_DESCRIPTOR_RANK (array
);
159 rstride0
= rstride
[0];
160 sstride0
= sstride
[0];
161 hstride0
= hstride
[0];
162 rptr
= ret
->base_addr
;
163 sptr
= array
->base_addr
;
168 /* Do the shift for this dimension. */
170 if (( sh
>= 0 ? sh
: -sh
) > len
)
176 delta
= (sh
>= 0) ? sh
: -sh
;
180 src
= &sptr
[delta
* soffset
];
186 dest
= &rptr
[delta
* roffset
];
188 for (n
= 0; n
< len
- delta
; n
++)
190 memcpy (dest
, src
, size
);
201 memcpy (dest
, pbound
, size
);
210 memset (dest
, filler
[0], size
);
212 for (i
= 0; i
< size
; i
+= filler_len
)
213 memcpy (&dest
[i
], filler
, filler_len
);
218 /* Advance to the next section. */
224 while (count
[n
] == extent
[n
])
226 /* When we get to the end of a dimension, reset it and increment
227 the next dimension. */
229 /* We could precalculate these products, but this is a less
230 frequently used path so probably not worth it. */
231 rptr
-= rstride
[n
] * extent
[n
];
232 sptr
-= sstride
[n
] * extent
[n
];
233 hptr
-= hstride
[n
] * extent
[n
];
237 /* Break out of the loop. */
252 void eoshift1_8 (gfc_array_char
* const restrict
,
253 const gfc_array_char
* const restrict
,
254 const gfc_array_i8
* const restrict
, const char * const restrict
,
255 const GFC_INTEGER_8
* const restrict
);
256 export_proto(eoshift1_8
);
259 eoshift1_8 (gfc_array_char
* const restrict ret
,
260 const gfc_array_char
* const restrict array
,
261 const gfc_array_i8
* const restrict h
,
262 const char * const restrict pbound
,
263 const GFC_INTEGER_8
* const restrict pwhich
)
265 eoshift1 (ret
, array
, h
, pbound
, pwhich
, "\0", 1);
269 void eoshift1_8_char (gfc_array_char
* const restrict
,
271 const gfc_array_char
* const restrict
,
272 const gfc_array_i8
* const restrict
,
273 const char * const restrict
,
274 const GFC_INTEGER_8
* const restrict
,
275 GFC_INTEGER_4
, GFC_INTEGER_4
);
276 export_proto(eoshift1_8_char
);
279 eoshift1_8_char (gfc_array_char
* const restrict ret
,
280 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
281 const gfc_array_char
* const restrict array
,
282 const gfc_array_i8
* const restrict h
,
283 const char * const restrict pbound
,
284 const GFC_INTEGER_8
* const restrict pwhich
,
285 GFC_INTEGER_4 array_length
__attribute__((unused
)),
286 GFC_INTEGER_4 bound_length
__attribute__((unused
)))
288 eoshift1 (ret
, array
, h
, pbound
, pwhich
, " ", 1);
292 void eoshift1_8_char4 (gfc_array_char
* const restrict
,
294 const gfc_array_char
* const restrict
,
295 const gfc_array_i8
* const restrict
,
296 const char * const restrict
,
297 const GFC_INTEGER_8
* const restrict
,
298 GFC_INTEGER_4
, GFC_INTEGER_4
);
299 export_proto(eoshift1_8_char4
);
302 eoshift1_8_char4 (gfc_array_char
* const restrict ret
,
303 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
304 const gfc_array_char
* const restrict array
,
305 const gfc_array_i8
* const restrict h
,
306 const char * const restrict pbound
,
307 const GFC_INTEGER_8
* const restrict pwhich
,
308 GFC_INTEGER_4 array_length
__attribute__((unused
)),
309 GFC_INTEGER_4 bound_length
__attribute__((unused
)))
311 static const gfc_char4_t space
= (unsigned char) ' ';
312 eoshift1 (ret
, array
, h
, pbound
, pwhich
,
313 (const char *) &space
, sizeof (gfc_char4_t
));