OSDN Git Service

gcc/fortran/
[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, index_type size)
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 len;
99   index_type n;
100   int whichloop;
101
102   if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
103     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
104
105   which = which - 1;
106
107   extent[0] = 1;
108   count[0] = 0;
109   n = 0;
110
111   /* The values assigned here must match the cases in the inner loop.  */
112   whichloop = 0;
113   switch (GFC_DESCRIPTOR_TYPE (array))
114     {
115     case GFC_DTYPE_LOGICAL:
116     case GFC_DTYPE_INTEGER:
117     case GFC_DTYPE_REAL:
118       if (size == sizeof (int))
119         whichloop = 1;
120       else if (size == sizeof (long))
121         whichloop = 2;
122       else if (size == sizeof (double))
123         whichloop = 3;
124       else if (size == sizeof (long double))
125         whichloop = 4;
126       break;
127
128     case GFC_DTYPE_COMPLEX:
129       if (size == sizeof (_Complex float))
130         whichloop = 5;
131       else if (size == sizeof (_Complex double))
132         whichloop = 6;
133       break;
134
135     default:
136       break;
137     }
138
139   /* Initialized for avoiding compiler warnings.  */
140   roffset = size;
141   soffset = size;
142   len = 0;
143
144   if (ret->data == NULL)
145     {
146       int i;
147
148       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
149       ret->offset = 0;
150       ret->dtype = array->dtype;
151       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
152         {
153           ret->dim[i].lbound = 0;
154           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
155
156           if (i == 0)
157             ret->dim[i].stride = 1;
158           else
159             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
160         }
161     }
162
163   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
164     {
165       if (dim == which)
166         {
167           roffset = ret->dim[dim].stride * size;
168           if (roffset == 0)
169             roffset = size;
170           soffset = array->dim[dim].stride * size;
171           if (soffset == 0)
172             soffset = size;
173           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
174         }
175       else
176         {
177           count[n] = 0;
178           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
179           rstride[n] = ret->dim[dim].stride * size;
180           sstride[n] = array->dim[dim].stride * size;
181           n++;
182         }
183     }
184   if (sstride[0] == 0)
185     sstride[0] = size;
186   if (rstride[0] == 0)
187     rstride[0] = size;
188
189   dim = GFC_DESCRIPTOR_RANK (array);
190   rstride0 = rstride[0];
191   sstride0 = sstride[0];
192   rptr = ret->data;
193   sptr = array->data;
194
195   shift = shift % (ssize_t)len;
196   if (shift < 0)
197     shift += len;
198
199   while (rptr)
200     {
201       /* Do the shift for this dimension.  */
202
203       /* If elements are contiguous, perform the operation
204          in two block moves.  */
205       if (soffset == size && roffset == size)
206         {
207           size_t len1 = shift * size;
208           size_t len2 = (len - shift) * size;
209           memcpy (rptr, sptr + len1, len2);
210           memcpy (rptr + len2, sptr, len1);
211         }
212       else
213         {
214           /* Otherwise, we'll have to perform the copy one element at
215              a time.  We can speed this up a tad for common cases of 
216              fundamental types.  */
217           switch (whichloop)
218             {
219             case 0:
220               {
221                 char *dest = rptr;
222                 const char *src = &sptr[shift * soffset];
223
224                 for (n = 0; n < len - shift; n++)
225                   {
226                     memcpy (dest, src, size);
227                     dest += roffset;
228                     src += soffset;
229                   }
230                 for (src = sptr, n = 0; n < shift; n++)
231                   {
232                     memcpy (dest, src, size);
233                     dest += roffset;
234                     src += soffset;
235                   }
236               }
237               break;
238
239             case 1:
240               copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
241               break;
242
243             case 2:
244               copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
245               break;
246
247             case 3:
248               copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
249               break;
250
251             case 4:
252               copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
253               break;
254
255             case 5:
256               copy_loop_cfloat (rptr, sptr, roffset, soffset, len, shift);
257               break;
258               
259             case 6:
260               copy_loop_cdouble (rptr, sptr, roffset, soffset, len, shift);
261               break;
262
263             default:
264               abort ();
265             }
266         }
267
268       /* Advance to the next section.  */
269       rptr += rstride0;
270       sptr += sstride0;
271       count[0]++;
272       n = 0;
273       while (count[n] == extent[n])
274         {
275           /* When we get to the end of a dimension, reset it and increment
276              the next dimension.  */
277           count[n] = 0;
278           /* We could precalculate these products, but this is a less
279              frequently used path so proabably not worth it.  */
280           rptr -= rstride[n] * extent[n];
281           sptr -= sstride[n] * extent[n];
282           n++;
283           if (n >= dim - 1)
284             {
285               /* Break out of the loop.  */
286               rptr = NULL;
287               break;
288             }
289           else
290             {
291               count[n]++;
292               rptr += rstride[n];
293               sptr += sstride[n];
294             }
295         }
296     }
297 }
298
299 #define DEFINE_CSHIFT(N)                                                      \
300   extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,          \
301                            const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
302   export_proto(cshift0_##N);                                                  \
303                                                                               \
304   void                                                                        \
305   cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,              \
306                const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
307   {                                                                           \
308     cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
309              GFC_DESCRIPTOR_SIZE (array));                                    \
310   }                                                                           \
311                                                                               \
312   extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,            \
313                                   const gfc_array_char *,                     \
314                                   const GFC_INTEGER_##N *,                    \
315                                   const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
316   export_proto(cshift0_##N##_char);                                           \
317                                                                               \
318   void                                                                        \
319   cshift0_##N##_char (gfc_array_char *ret,                                    \
320                       GFC_INTEGER_4 ret_length __attribute__((unused)),       \
321                       const gfc_array_char *array,                            \
322                       const GFC_INTEGER_##N *pshift,                          \
323                       const GFC_INTEGER_##N *pdim,                            \
324                       GFC_INTEGER_4 array_length)                             \
325   {                                                                           \
326     cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);            \
327   }
328
329 DEFINE_CSHIFT (1);
330 DEFINE_CSHIFT (2);
331 DEFINE_CSHIFT (4);
332 DEFINE_CSHIFT (8);