OSDN Git Service

e491e178e36b7ecbed2e843893155432033d1da5
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / cshift0.c
1 /* Generic implementation of the CSHIFT intrinsic
2    Copyright 2003, 2005 Free Software Foundation, Inc.
3    Contributed by Feng Wang <wf_cs@yahoo.com>
4
5 This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING.  If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA.  */
30
31 #include "config.h"
32 #include <stdlib.h>
33 #include <assert.h>
34 #include <string.h>
35 #include "libgfortran.h"
36
37
38 /* "Templatized" helper function for the inner shift loop.  */
39
40 #define DEF_COPY_LOOP(NAME, TYPE)                                       \
41 static inline void                                                      \
42 copy_loop_##NAME (void *xdest, const void *xsrc,                        \
43                   size_t roff, size_t soff,                             \
44                   index_type len, index_type shift)                     \
45 {                                                                       \
46   TYPE *dest = xdest;                                                   \
47   const TYPE *src;                                                      \
48   index_type i;                                                         \
49                                                                         \
50   roff /= sizeof (TYPE);                                                \
51   soff /= sizeof (TYPE);                                                \
52                                                                         \
53   src = xsrc;                                                           \
54   src += shift * soff;                                                  \
55   for (i = 0; i < len - shift; ++i)                                     \
56     {                                                                   \
57       *dest = *src;                                                     \
58       dest += roff;                                                     \
59       src += soff;                                                      \
60     }                                                                   \
61                                                                         \
62   src = xsrc;                                                           \
63   for (i = 0; i < shift; ++i)                                           \
64     {                                                                   \
65       *dest = *src;                                                     \
66       dest += roff;                                                     \
67       src += soff;                                                      \
68     }                                                                   \
69 }
70
71 DEF_COPY_LOOP(int, int)
72 DEF_COPY_LOOP(long, long)
73 DEF_COPY_LOOP(double, double)
74 DEF_COPY_LOOP(ldouble, long double)
75 DEF_COPY_LOOP(cfloat, _Complex float)
76 DEF_COPY_LOOP(cdouble, _Complex double)
77
78
79 static void
80 cshift0 (gfc_array_char * ret, const gfc_array_char * array,
81          ssize_t shift, int which)
82 {
83   /* r.* indicates the return array.  */
84   index_type rstride[GFC_MAX_DIMENSIONS];
85   index_type rstride0;
86   index_type roffset;
87   char *rptr;
88
89   /* s.* indicates the source array.  */
90   index_type sstride[GFC_MAX_DIMENSIONS];
91   index_type sstride0;
92   index_type soffset;
93   const char *sptr;
94
95   index_type count[GFC_MAX_DIMENSIONS];
96   index_type extent[GFC_MAX_DIMENSIONS];
97   index_type dim;
98   index_type size;
99   index_type len;
100   index_type n;
101   int whichloop;
102
103   if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
104     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
105
106   which = which - 1;
107
108   extent[0] = 1;
109   count[0] = 0;
110   size = GFC_DESCRIPTOR_SIZE (array);
111   n = 0;
112
113   /* The values assigned here must match the cases in the inner loop.  */
114   whichloop = 0;
115   switch (GFC_DESCRIPTOR_TYPE (array))
116     {
117     case GFC_DTYPE_LOGICAL:
118     case GFC_DTYPE_INTEGER:
119     case GFC_DTYPE_REAL:
120       if (size == sizeof (int))
121         whichloop = 1;
122       else if (size == sizeof (long))
123         whichloop = 2;
124       else if (size == sizeof (double))
125         whichloop = 3;
126       else if (size == sizeof (long double))
127         whichloop = 4;
128       break;
129
130     case GFC_DTYPE_COMPLEX:
131       if (size == sizeof (_Complex float))
132         whichloop = 5;
133       else if (size == sizeof (_Complex double))
134         whichloop = 6;
135       break;
136
137     default:
138       break;
139     }
140
141   /* Initialized for avoiding compiler warnings.  */
142   roffset = size;
143   soffset = size;
144   len = 0;
145
146   if (ret->data == NULL)
147     {
148       int i;
149
150       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
151       ret->offset = 0;
152       ret->dtype = array->dtype;
153       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
154         {
155           ret->dim[i].lbound = 0;
156           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
157
158           if (i == 0)
159             ret->dim[i].stride = 1;
160           else
161             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
162         }
163     }
164
165   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
166     {
167       if (dim == which)
168         {
169           roffset = ret->dim[dim].stride * size;
170           if (roffset == 0)
171             roffset = size;
172           soffset = array->dim[dim].stride * size;
173           if (soffset == 0)
174             soffset = size;
175           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
176         }
177       else
178         {
179           count[n] = 0;
180           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
181           rstride[n] = ret->dim[dim].stride * size;
182           sstride[n] = array->dim[dim].stride * size;
183           n++;
184         }
185     }
186   if (sstride[0] == 0)
187     sstride[0] = size;
188   if (rstride[0] == 0)
189     rstride[0] = size;
190
191   dim = GFC_DESCRIPTOR_RANK (array);
192   rstride0 = rstride[0];
193   sstride0 = sstride[0];
194   rptr = ret->data;
195   sptr = array->data;
196
197   shift = shift % (ssize_t)len;
198   if (shift < 0)
199     shift += len;
200
201   while (rptr)
202     {
203       /* Do the shift for this dimension.  */
204
205       /* If elements are contiguous, perform the operation
206          in two block moves.  */
207       if (soffset == size && roffset == size)
208         {
209           size_t len1 = shift * size;
210           size_t len2 = (len - shift) * size;
211           memcpy (rptr, sptr + len1, len2);
212           memcpy (rptr + len2, sptr, len1);
213         }
214       else
215         {
216           /* Otherwise, we'll have to perform the copy one element at
217              a time.  We can speed this up a tad for common cases of 
218              fundamental types.  */
219           switch (whichloop)
220             {
221             case 0:
222               {
223                 char *dest = rptr;
224                 const char *src = &sptr[shift * soffset];
225
226                 for (n = 0; n < len - shift; n++)
227                   {
228                     memcpy (dest, src, size);
229                     dest += roffset;
230                     src += soffset;
231                   }
232                 for (src = sptr, n = 0; n < shift; n++)
233                   {
234                     memcpy (dest, src, size);
235                     dest += roffset;
236                     src += soffset;
237                   }
238               }
239               break;
240
241             case 1:
242               copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
243               break;
244
245             case 2:
246               copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
247               break;
248
249             case 3:
250               copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
251               break;
252
253             case 4:
254               copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
255               break;
256
257             case 5:
258               copy_loop_cfloat (rptr, sptr, roffset, soffset, len, shift);
259               break;
260               
261             case 6:
262               copy_loop_cdouble (rptr, sptr, roffset, soffset, len, shift);
263               break;
264
265             default:
266               abort ();
267             }
268         }
269
270       /* Advance to the next section.  */
271       rptr += rstride0;
272       sptr += sstride0;
273       count[0]++;
274       n = 0;
275       while (count[n] == extent[n])
276         {
277           /* When we get to the end of a dimension, reset it and increment
278              the next dimension.  */
279           count[n] = 0;
280           /* We could precalculate these products, but this is a less
281              frequently used path so proabably not worth it.  */
282           rptr -= rstride[n] * extent[n];
283           sptr -= sstride[n] * extent[n];
284           n++;
285           if (n >= dim - 1)
286             {
287               /* Break out of the loop.  */
288               rptr = NULL;
289               break;
290             }
291           else
292             {
293               count[n]++;
294               rptr += rstride[n];
295               sptr += sstride[n];
296             }
297         }
298     }
299 }
300
301
302 extern void cshift0_1 (gfc_array_char *, const gfc_array_char *,
303                        const GFC_INTEGER_1 *, const GFC_INTEGER_1 *);
304 export_proto(cshift0_1);
305
306 void
307 cshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
308            const GFC_INTEGER_1 *pshift, const GFC_INTEGER_1 *pdim)
309 {
310   cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
311 }
312
313
314 extern void cshift0_2 (gfc_array_char *, const gfc_array_char *,
315                        const GFC_INTEGER_2 *, const GFC_INTEGER_2 *);
316 export_proto(cshift0_2);
317
318 void
319 cshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
320            const GFC_INTEGER_2 *pshift, const GFC_INTEGER_2 *pdim)
321 {
322   cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
323 }
324
325
326 extern void cshift0_4 (gfc_array_char *, const gfc_array_char *,
327                        const GFC_INTEGER_4 *, const GFC_INTEGER_4 *);
328 export_proto(cshift0_4);
329
330 void
331 cshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
332            const GFC_INTEGER_4 *pshift, const GFC_INTEGER_4 *pdim)
333 {
334   cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
335 }
336
337
338 extern void cshift0_8 (gfc_array_char *, const gfc_array_char *,
339                        const GFC_INTEGER_8 *, const GFC_INTEGER_8 *);
340 export_proto(cshift0_8);
341
342 void
343 cshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
344            const GFC_INTEGER_8 *pshift, const GFC_INTEGER_8 *pdim)
345 {
346   cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
347 }
348