Mercurial > hg > CbC > CbC_gcc

comparison libgfortran/m4/cshift1.m4 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 `/* Implementation of the CSHIFT intrinsic
2 Copyright (C) 2003-2017 Free Software Foundation, Inc.
3 Contributed by Feng Wang <wf_cs@yahoo.com>
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 Ligbfortran 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 include(iparm.m4)dnl
30
31 `#if defined (HAVE_'atype_name`)
32
33 static void
34 cshift1 (gfc_array_char * const restrict ret,
35 const gfc_array_char * const restrict array,
36 const 'atype` * const restrict h,
37 const 'atype_name` * const restrict pwhich)
38 {
39 /* r.* indicates the return array. */
40 index_type rstride[GFC_MAX_DIMENSIONS];
41 index_type rstride0;
42 index_type roffset;
43 char *rptr;
44 char *dest;
45 /* s.* indicates the source array. */
46 index_type sstride[GFC_MAX_DIMENSIONS];
47 index_type sstride0;
48 index_type soffset;
49 const char *sptr;
50 const char *src;
51 /* h.* indicates the shift array. */
52 index_type hstride[GFC_MAX_DIMENSIONS];
53 index_type hstride0;
54 const 'atype_name` *hptr;
55
56 index_type count[GFC_MAX_DIMENSIONS];
57 index_type extent[GFC_MAX_DIMENSIONS];
58 index_type dim;
59 index_type len;
60 index_type n;
61 int which;
62 'atype_name` sh;
63 index_type arraysize;
64 index_type size;
65 index_type type_size;
66
67 if (pwhich)
68 which = *pwhich - 1;
69 else
70 which = 0;
71
72 if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
73 runtime_error ("Argument ''`DIM''` is out of range in call to ''`CSHIFT''`");
74
75 size = GFC_DESCRIPTOR_SIZE(array);
76
77 arraysize = size0 ((array_t *)array);
78
79 if (ret->base_addr == NULL)
80 {
81 int i;
82
83 ret->base_addr = xmallocarray (arraysize, size);
84 ret->offset = 0;
85 ret->dtype = array->dtype;
86 for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
87 {
88 index_type ub, str;
89
90 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
91
92 if (i == 0)
93 str = 1;
94 else
95 str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
96 GFC_DESCRIPTOR_STRIDE(ret,i-1);
97
98 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
99 }
100 }
101 else if (unlikely (compile_options.bounds_check))
102 {
103 bounds_equal_extents ((array_t *) ret, (array_t *) array,
104 "return value", "CSHIFT");
105 }
106
107 if (unlikely (compile_options.bounds_check))
108 {
109 bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
110 "SHIFT argument", "CSHIFT");
111 }
112
113 if (arraysize == 0)
114 return;
115
116 /* See if we should dispatch to a helper function. */
117
118 type_size = GFC_DTYPE_TYPE_SIZE (array);
119
120 switch (type_size)
121 {
122 case GFC_DTYPE_LOGICAL_1:
123 case GFC_DTYPE_INTEGER_1:
124 case GFC_DTYPE_DERIVED_1:
125 cshift1_'atype_kind`_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array,
126 h, pwhich);
127 return;
128
129 case GFC_DTYPE_LOGICAL_2:
130 case GFC_DTYPE_INTEGER_2:
131 cshift1_'atype_kind`_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array,
132 h, pwhich);
133 return;
134
135 case GFC_DTYPE_LOGICAL_4:
136 case GFC_DTYPE_INTEGER_4:
137 cshift1_'atype_kind`_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array,
138 h, pwhich);
139 return;
140
141 case GFC_DTYPE_LOGICAL_8:
142 case GFC_DTYPE_INTEGER_8:
143 cshift1_'atype_kind`_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array,
144 h, pwhich);
145 return;
146
147 #if defined (HAVE_INTEGER_16)
148 case GFC_DTYPE_LOGICAL_16:
149 case GFC_DTYPE_INTEGER_16:
150 cshift1_'atype_kind`_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array,
151 h, pwhich);
152 return;
153 #endif
154
155 case GFC_DTYPE_REAL_4:
156 cshift1_'atype_kind`_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array,
157 h, pwhich);
158 return;
159
160 case GFC_DTYPE_REAL_8:
161 cshift1_'atype_kind`_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array,
162 h, pwhich);
163 return;
164
165 #if defined (HAVE_REAL_10)
166 case GFC_DTYPE_REAL_10:
167 cshift1_'atype_kind`_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array,
168 h, pwhich);
169 return;
170 #endif
171
172 #if defined (HAVE_REAL_16)
173 case GFC_DTYPE_REAL_16:
174 cshift1_'atype_kind`_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array,
175 h, pwhich);
176 return;
177 #endif
178
179 case GFC_DTYPE_COMPLEX_4:
180 cshift1_'atype_kind`_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array,
181 h, pwhich);
182 return;
183
184 case GFC_DTYPE_COMPLEX_8:
185 cshift1_'atype_kind`_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array,
186 h, pwhich);
187 return;
188
189 #if defined (HAVE_COMPLEX_10)
190 case GFC_DTYPE_COMPLEX_10:
191 cshift1_'atype_kind`_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array,
192 h, pwhich);
193 return;
194 #endif
195
196 #if defined (HAVE_COMPLEX_16)
197 case GFC_DTYPE_COMPLEX_16:
198 cshift1_'atype_kind`_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array,
199 h, pwhich);
200 return;
201 #endif
202
203 default:
204 break;
205
206 }
207
208 extent[0] = 1;
209 count[0] = 0;
210 n = 0;
211
212 /* Initialized for avoiding compiler warnings. */
213 roffset = size;
214 soffset = size;
215 len = 0;
216
217 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
218 {
219 if (dim == which)
220 {
221 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
222 if (roffset == 0)
223 roffset = size;
224 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
225 if (soffset == 0)
226 soffset = size;
227 len = GFC_DESCRIPTOR_EXTENT(array,dim);
228 }
229 else
230 {
231 count[n] = 0;
232 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
233 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
234 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
235
236 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
237 n++;
238 }
239 }
240 if (sstride[0] == 0)
241 sstride[0] = size;
242 if (rstride[0] == 0)
243 rstride[0] = size;
244 if (hstride[0] == 0)
245 hstride[0] = 1;
246
247 dim = GFC_DESCRIPTOR_RANK (array);
248 rstride0 = rstride[0];
249 sstride0 = sstride[0];
250 hstride0 = hstride[0];
251 rptr = ret->base_addr;
252 sptr = array->base_addr;
253 hptr = h->base_addr;
254
255 while (rptr)
256 {
257 /* Do the shift for this dimension. */
258 sh = *hptr;
259 /* Normal case should be -len < sh < len; try to
260 avoid the expensive remainder operation if possible. */
261 if (sh < 0)
262 sh += len;
263 if (unlikely (sh >= len || sh < 0))
264 {
265 sh = sh % len;
266 if (sh < 0)
267 sh += len;
268 }
269
270 src = &sptr[sh * soffset];
271 dest = rptr;
272 if (soffset == size && roffset == size)
273 {
274 size_t len1 = sh * size;
275 size_t len2 = (len - sh) * size;
276 memcpy (rptr, sptr + len1, len2);
277 memcpy (rptr + len2, sptr, len1);
278 }
279 else
280 {
281 for (n = 0; n < len - sh; n++)
282 {
283 memcpy (dest, src, size);
284 dest += roffset;
285 src += soffset;
286 }
287 for (src = sptr, n = 0; n < sh; n++)
288 {
289 memcpy (dest, src, size);
290 dest += roffset;
291 src += soffset;
292 }
293 }
294
295 /* Advance to the next section. */
296 rptr += rstride0;
297 sptr += sstride0;
298 hptr += hstride0;
299 count[0]++;
300 n = 0;
301 while (count[n] == extent[n])
302 {
303 /* When we get to the end of a dimension, reset it and increment
304 the next dimension. */
305 count[n] = 0;
306 /* We could precalculate these products, but this is a less
307 frequently used path so probably not worth it. */
308 rptr -= rstride[n] * extent[n];
309 sptr -= sstride[n] * extent[n];
310 hptr -= hstride[n] * extent[n];
311 n++;
312 if (n >= dim - 1)
313 {
314 /* Break out of the loop. */
315 rptr = NULL;
316 break;
317 }
318 else
319 {
320 count[n]++;
321 rptr += rstride[n];
322 sptr += sstride[n];
323 hptr += hstride[n];
324 }
325 }
326 }
327 }
328
329 void cshift1_'atype_kind` (gfc_array_char * const restrict,
330 const gfc_array_char * const restrict,
331 const 'atype` * const restrict,
332 const 'atype_name` * const restrict);
333 export_proto(cshift1_'atype_kind`);
334
335 void
336 cshift1_'atype_kind` (gfc_array_char * const restrict ret,
337 const gfc_array_char * const restrict array,
338 const 'atype` * const restrict h,
339 const 'atype_name` * const restrict pwhich)
340 {
341 cshift1 (ret, array, h, pwhich);
342 }
343
344
345 void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
346 GFC_INTEGER_4,
347 const gfc_array_char * const restrict array,
348 const 'atype` * const restrict h,
349 const 'atype_name` * const restrict pwhich,
350 GFC_INTEGER_4);
351 export_proto(cshift1_'atype_kind`_char);
352
353 void
354 cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
355 GFC_INTEGER_4 ret_length __attribute__((unused)),
356 const gfc_array_char * const restrict array,
357 const 'atype` * const restrict h,
358 const 'atype_name` * const restrict pwhich,
359 GFC_INTEGER_4 array_length __attribute__((unused)))
360 {
361 cshift1 (ret, array, h, pwhich);
362 }
363
364
365 void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
366 GFC_INTEGER_4,
367 const gfc_array_char * const restrict array,
368 const 'atype` * const restrict h,
369 const 'atype_name` * const restrict pwhich,
370 GFC_INTEGER_4);
371 export_proto(cshift1_'atype_kind`_char4);
372
373 void
374 cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
375 GFC_INTEGER_4 ret_length __attribute__((unused)),
376 const gfc_array_char * const restrict array,
377 const 'atype` * const restrict h,
378 const 'atype_name` * const restrict pwhich,
379 GFC_INTEGER_4 array_length __attribute__((unused)))
380 {
381 cshift1 (ret, array, h, pwhich);
382 }
383
384 #endif'