OSDN Git Service

PR libfortran/18966
[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 (libgfor).
6
7 Libgfor is free software; you can redistribute it and/or
8 modify it under the terms of the GNU Lesser General Public
9 License as published by the Free Software Foundation; either
10 version 2.1 of the License, or (at your option) any later version.
11
12 Ligbfor 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 Lesser General Public License for more details.
16
17 You should have received a copy of the GNU Lesser General Public
18 License along with libgfor; see the file COPYING.LIB.  If not,
19 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA.  */
21
22 #include "config.h"
23 #include <stdlib.h>
24 #include <assert.h>
25 #include <string.h>
26 #include "libgfortran.h"
27
28 static const char zeros[16] =
29   {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
30
31 /* TODO: make this work for large shifts when
32    sizeof(int) < sizeof (index_type).  */
33
34 static void
35 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
36           int shift, const char * pbound, int which)
37 {
38   /* r.* indicates the return array.  */
39   index_type rstride[GFC_MAX_DIMENSIONS - 1];
40   index_type rstride0;
41   index_type roffset;
42   char *rptr;
43   char *dest;
44   /* s.* indicates the source array.  */
45   index_type sstride[GFC_MAX_DIMENSIONS - 1];
46   index_type sstride0;
47   index_type soffset;
48   const char *sptr;
49   const char *src;
50
51   index_type count[GFC_MAX_DIMENSIONS - 1];
52   index_type extent[GFC_MAX_DIMENSIONS - 1];
53   index_type dim;
54   index_type size;
55   index_type len;
56   index_type n;
57
58   if (!pbound)
59     pbound = zeros;
60
61   size = GFC_DESCRIPTOR_SIZE (ret);
62
63   if (ret->data == NULL)
64     {
65       int i;
66
67       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
68       ret->base = 0;
69       ret->dtype = array->dtype;
70       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
71         {
72           ret->dim[i].lbound = 0;
73           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
74
75           if (i == 0)
76             ret->dim[i].stride = 1;
77           else
78             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
79         }
80     }
81
82   which = which - 1;
83
84   extent[0] = 1;
85   count[0] = 0;
86   size = GFC_DESCRIPTOR_SIZE (array);
87   n = 0;
88   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
89     {
90       if (dim == which)
91         {
92           roffset = ret->dim[dim].stride * size;
93           if (roffset == 0)
94             roffset = size;
95           soffset = array->dim[dim].stride * size;
96           if (soffset == 0)
97             soffset = size;
98           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
99         }
100       else
101         {
102           count[n] = 0;
103           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
104           rstride[n] = ret->dim[dim].stride * size;
105           sstride[n] = array->dim[dim].stride * size;
106           n++;
107         }
108     }
109   if (sstride[0] == 0)
110     sstride[0] = size;
111   if (rstride[0] == 0)
112     rstride[0] = size;
113
114   dim = GFC_DESCRIPTOR_RANK (array);
115   rstride0 = rstride[0];
116   sstride0 = sstride[0];
117   rptr = ret->data;
118   sptr = array->data;
119   if (shift > 0)
120     len = len - shift;
121   else
122     len = len + shift;
123
124   while (rptr)
125     {
126       /* Do the shift for this dimension.  */
127       if (shift > 0)
128         {
129           src = &sptr[shift * soffset];
130           dest = rptr;
131         }
132       else
133         {
134           src = sptr;
135           dest = &rptr[-shift * roffset];
136         }
137       for (n = 0; n < len; n++)
138         {
139           memcpy (dest, src, size);
140           dest += roffset;
141           src += soffset;
142         }
143       if (shift >= 0)
144         {
145           n = shift;
146         }
147       else
148         {
149           dest = rptr;
150           n = -shift;
151         }
152
153       while (n--)
154         {
155           memcpy (dest, pbound, size);
156           dest += roffset;
157         }
158
159       /* Advance to the next section.  */
160       rptr += rstride0;
161       sptr += sstride0;
162       count[0]++;
163       n = 0;
164       while (count[n] == extent[n])
165         {
166           /* When we get to the end of a dimension, reset it and increment
167              the next dimension.  */
168           count[n] = 0;
169           /* We could precalculate these products, but this is a less
170              frequently used path so proabably not worth it.  */
171           rptr -= rstride[n] * extent[n];
172           sptr -= sstride[n] * extent[n];
173           n++;
174           if (n >= dim - 1)
175             {
176               /* Break out of the loop.  */
177               rptr = NULL;
178               break;
179             }
180           else
181             {
182               count[n]++;
183               rptr += rstride[n];
184               sptr += sstride[n];
185             }
186         }
187     }
188 }
189
190
191 extern void eoshift0_1 (gfc_array_char *, const gfc_array_char *,
192                         const GFC_INTEGER_1 *, const char *,
193                         const GFC_INTEGER_1 *);
194 export_proto(eoshift0_1);
195
196 void
197 eoshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
198             const GFC_INTEGER_1 *pshift, const char *pbound,
199             const GFC_INTEGER_1 *pdim)
200 {
201   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
202 }
203
204
205 extern void eoshift0_2 (gfc_array_char *, const gfc_array_char *,
206                         const GFC_INTEGER_2 *, const char *,
207                         const GFC_INTEGER_2 *);
208 export_proto(eoshift0_2);
209
210 void
211 eoshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
212             const GFC_INTEGER_2 *pshift, const char *pbound,
213             const GFC_INTEGER_2 *pdim)
214 {
215   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
216 }
217
218
219 extern void eoshift0_4 (gfc_array_char *, const gfc_array_char *,
220                         const GFC_INTEGER_4 *, const char *,
221                         const GFC_INTEGER_4 *);
222 export_proto(eoshift0_4);
223
224 void
225 eoshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
226             const GFC_INTEGER_4 *pshift, const char *pbound,
227             const GFC_INTEGER_4 *pdim)
228 {
229   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
230 }
231
232
233 extern void eoshift0_8 (gfc_array_char *, const gfc_array_char *,
234                         const GFC_INTEGER_8 *, const char *,
235                         const GFC_INTEGER_8 *);
236 export_proto(eoshift0_8);
237
238 void
239 eoshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
240             const GFC_INTEGER_8 *pshift, const char *pbound,
241             const GFC_INTEGER_8 *pdim)
242 {
243   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
244 }
245