OSDN Git Service

2005-05-04 Thomas Koenig <Thomas.Koenig@online.de>
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / eoshift0.c
1 /* Generic implementation of the EOSHIFT intrinsic
2    Copyright 2002 Free Software Foundation, Inc.
3    Contributed by Paul Brook <paul@nowt.org>
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., 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA.  */
30
31 #include "config.h"
32 #include <stdlib.h>
33 #include <assert.h>
34 #include <string.h>
35 #include "libgfortran.h"
36
37 static const char zeros[16] =
38   {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
39
40 /* TODO: make this work for large shifts when
41    sizeof(int) < sizeof (index_type).  */
42
43 static void
44 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
45           int shift, const char * pbound, int which)
46 {
47   /* r.* indicates the return array.  */
48   index_type rstride[GFC_MAX_DIMENSIONS];
49   index_type rstride0;
50   index_type roffset;
51   char *rptr;
52   char *dest;
53   /* s.* indicates the source array.  */
54   index_type sstride[GFC_MAX_DIMENSIONS];
55   index_type sstride0;
56   index_type soffset;
57   const char *sptr;
58   const char *src;
59
60   index_type count[GFC_MAX_DIMENSIONS];
61   index_type extent[GFC_MAX_DIMENSIONS];
62   index_type dim;
63   index_type size;
64   index_type len;
65   index_type n;
66
67   if (!pbound)
68     pbound = zeros;
69
70   size = GFC_DESCRIPTOR_SIZE (ret);
71
72   if (ret->data == NULL)
73     {
74       int i;
75
76       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
77       ret->base = 0;
78       ret->dtype = array->dtype;
79       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
80         {
81           ret->dim[i].lbound = 0;
82           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
83
84           if (i == 0)
85             ret->dim[i].stride = 1;
86           else
87             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
88         }
89     }
90
91   which = which - 1;
92
93   extent[0] = 1;
94   count[0] = 0;
95   size = GFC_DESCRIPTOR_SIZE (array);
96   n = 0;
97   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
98     {
99       if (dim == which)
100         {
101           roffset = ret->dim[dim].stride * size;
102           if (roffset == 0)
103             roffset = size;
104           soffset = array->dim[dim].stride * size;
105           if (soffset == 0)
106             soffset = size;
107           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
108         }
109       else
110         {
111           count[n] = 0;
112           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
113           rstride[n] = ret->dim[dim].stride * size;
114           sstride[n] = array->dim[dim].stride * size;
115           n++;
116         }
117     }
118   if (sstride[0] == 0)
119     sstride[0] = size;
120   if (rstride[0] == 0)
121     rstride[0] = size;
122
123   dim = GFC_DESCRIPTOR_RANK (array);
124   rstride0 = rstride[0];
125   sstride0 = sstride[0];
126   rptr = ret->data;
127   sptr = array->data;
128   if (shift > 0)
129     len = len - shift;
130   else
131     len = len + shift;
132
133   while (rptr)
134     {
135       /* Do the shift for this dimension.  */
136       if (shift > 0)
137         {
138           src = &sptr[shift * soffset];
139           dest = rptr;
140         }
141       else
142         {
143           src = sptr;
144           dest = &rptr[-shift * roffset];
145         }
146       for (n = 0; n < len; n++)
147         {
148           memcpy (dest, src, size);
149           dest += roffset;
150           src += soffset;
151         }
152       if (shift >= 0)
153         {
154           n = shift;
155         }
156       else
157         {
158           dest = rptr;
159           n = -shift;
160         }
161
162       while (n--)
163         {
164           memcpy (dest, pbound, size);
165           dest += roffset;
166         }
167
168       /* Advance to the next section.  */
169       rptr += rstride0;
170       sptr += sstride0;
171       count[0]++;
172       n = 0;
173       while (count[n] == extent[n])
174         {
175           /* When we get to the end of a dimension, reset it and increment
176              the next dimension.  */
177           count[n] = 0;
178           /* We could precalculate these products, but this is a less
179              frequently used path so proabably not worth it.  */
180           rptr -= rstride[n] * extent[n];
181           sptr -= sstride[n] * extent[n];
182           n++;
183           if (n >= dim - 1)
184             {
185               /* Break out of the loop.  */
186               rptr = NULL;
187               break;
188             }
189           else
190             {
191               count[n]++;
192               rptr += rstride[n];
193               sptr += sstride[n];
194             }
195         }
196     }
197 }
198
199
200 extern void eoshift0_1 (gfc_array_char *, const gfc_array_char *,
201                         const GFC_INTEGER_1 *, const char *,
202                         const GFC_INTEGER_1 *);
203 export_proto(eoshift0_1);
204
205 void
206 eoshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
207             const GFC_INTEGER_1 *pshift, const char *pbound,
208             const GFC_INTEGER_1 *pdim)
209 {
210   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
211 }
212
213
214 extern void eoshift0_2 (gfc_array_char *, const gfc_array_char *,
215                         const GFC_INTEGER_2 *, const char *,
216                         const GFC_INTEGER_2 *);
217 export_proto(eoshift0_2);
218
219 void
220 eoshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
221             const GFC_INTEGER_2 *pshift, const char *pbound,
222             const GFC_INTEGER_2 *pdim)
223 {
224   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
225 }
226
227
228 extern void eoshift0_4 (gfc_array_char *, const gfc_array_char *,
229                         const GFC_INTEGER_4 *, const char *,
230                         const GFC_INTEGER_4 *);
231 export_proto(eoshift0_4);
232
233 void
234 eoshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
235             const GFC_INTEGER_4 *pshift, const char *pbound,
236             const GFC_INTEGER_4 *pdim)
237 {
238   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
239 }
240
241
242 extern void eoshift0_8 (gfc_array_char *, const gfc_array_char *,
243                         const GFC_INTEGER_8 *, const char *,
244                         const GFC_INTEGER_8 *);
245 export_proto(eoshift0_8);
246
247 void
248 eoshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
249             const GFC_INTEGER_8 *pshift, const char *pbound,
250             const GFC_INTEGER_8 *pdim)
251 {
252   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
253 }
254