OSDN Git Service

gcc/fortran/
[pf3gnuchains/gcc-fork.git] / libgfortran / generated / eoshift3_8.c
1 /* Implementation of the EOSHIFT intrinsic
2    Copyright 2002, 2005 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., 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 static void
38 eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h,
39           const gfc_array_char *bound, const GFC_INTEGER_8 *pwhich,
40           index_type size, char filler)
41 {
42   /* r.* indicates the return array.  */
43   index_type rstride[GFC_MAX_DIMENSIONS];
44   index_type rstride0;
45   index_type roffset;
46   char *rptr;
47   char *dest;
48   /* s.* indicates the source array.  */
49   index_type sstride[GFC_MAX_DIMENSIONS];
50   index_type sstride0;
51   index_type soffset;
52   const char *sptr;
53   const char *src;
54   /* h.* indicates the shift array.  */
55   index_type hstride[GFC_MAX_DIMENSIONS];
56   index_type hstride0;
57   const GFC_INTEGER_8 *hptr;
58   /* b.* indicates the bound array.  */
59   index_type bstride[GFC_MAX_DIMENSIONS];
60   index_type bstride0;
61   const char *bptr;
62
63   index_type count[GFC_MAX_DIMENSIONS];
64   index_type extent[GFC_MAX_DIMENSIONS];
65   index_type dim;
66   index_type len;
67   index_type n;
68   int which;
69   GFC_INTEGER_8 sh;
70   GFC_INTEGER_8 delta;
71
72   /* The compiler cannot figure out that these are set, initialize
73      them to avoid warnings.  */
74   len = 0;
75   soffset = 0;
76   roffset = 0;
77
78   if (pwhich)
79     which = *pwhich - 1;
80   else
81     which = 0;
82
83   if (ret->data == NULL)
84     {
85       int i;
86
87       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
88       ret->offset = 0;
89       ret->dtype = array->dtype;
90       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
91         {
92           ret->dim[i].lbound = 0;
93           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
94
95           if (i == 0)
96             ret->dim[i].stride = 1;
97           else
98             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
99         }
100     }
101
102
103   extent[0] = 1;
104   count[0] = 0;
105   n = 0;
106   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
107     {
108       if (dim == which)
109         {
110           roffset = ret->dim[dim].stride * size;
111           if (roffset == 0)
112             roffset = size;
113           soffset = array->dim[dim].stride * size;
114           if (soffset == 0)
115             soffset = size;
116           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
117         }
118       else
119         {
120           count[n] = 0;
121           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
122           rstride[n] = ret->dim[dim].stride * size;
123           sstride[n] = array->dim[dim].stride * size;
124
125           hstride[n] = h->dim[n].stride;
126           if (bound)
127             bstride[n] = bound->dim[n].stride * size;
128           else
129             bstride[n] = 0;
130           n++;
131         }
132     }
133   if (sstride[0] == 0)
134     sstride[0] = size;
135   if (rstride[0] == 0)
136     rstride[0] = size;
137   if (hstride[0] == 0)
138     hstride[0] = 1;
139   if (bound && bstride[0] == 0)
140     bstride[0] = size;
141
142   dim = GFC_DESCRIPTOR_RANK (array);
143   rstride0 = rstride[0];
144   sstride0 = sstride[0];
145   hstride0 = hstride[0];
146   bstride0 = bstride[0];
147   rptr = ret->data;
148   sptr = array->data;
149   hptr = h->data;
150   if (bound)
151     bptr = bound->data;
152   else
153     bptr = NULL;
154
155   while (rptr)
156     {
157       /* Do the shift for this dimension.  */
158       sh = *hptr;
159       if (( sh >= 0 ? sh : -sh ) > len)
160         {
161           delta = len;
162           sh = len;
163         }
164       else
165         delta = (sh >= 0) ? sh: -sh;
166
167       if (sh > 0)
168         {
169           src = &sptr[delta * soffset];
170           dest = rptr;
171         }
172       else
173         {
174           src = sptr;
175           dest = &rptr[delta * roffset];
176         }
177       for (n = 0; n < len - delta; n++)
178         {
179           memcpy (dest, src, size);
180           dest += roffset;
181           src += soffset;
182         }
183       if (sh < 0)
184         dest = rptr;
185       n = delta;
186
187       if (bptr)
188         while (n--)
189           {
190             memcpy (dest, bptr, size);
191             dest += roffset;
192           }
193       else
194         while (n--)
195           {
196             memset (dest, filler, size);
197             dest += roffset;
198           }
199
200       /* Advance to the next section.  */
201       rptr += rstride0;
202       sptr += sstride0;
203       hptr += hstride0;
204       bptr += bstride0;
205       count[0]++;
206       n = 0;
207       while (count[n] == extent[n])
208         {
209           /* When we get to the end of a dimension, reset it and increment
210              the next dimension.  */
211           count[n] = 0;
212           /* We could precalculate these products, but this is a less
213              frequently used path so proabably not worth it.  */
214           rptr -= rstride[n] * extent[n];
215           sptr -= sstride[n] * extent[n];
216           hptr -= hstride[n] * extent[n];
217           bptr -= bstride[n] * extent[n];
218           n++;
219           if (n >= dim - 1)
220             {
221               /* Break out of the loop.  */
222               rptr = NULL;
223               break;
224             }
225           else
226             {
227               count[n]++;
228               rptr += rstride[n];
229               sptr += sstride[n];
230               hptr += hstride[n];
231               bptr += bstride[n];
232             }
233         }
234     }
235 }
236
237 extern void eoshift3_8 (gfc_array_char *, const gfc_array_char *,
238                                    const gfc_array_i8 *, const gfc_array_char *,
239                                    const GFC_INTEGER_8 *);
240 export_proto(eoshift3_8);
241
242 void
243 eoshift3_8 (gfc_array_char *ret, const gfc_array_char *array,
244                        const gfc_array_i8 *h, const gfc_array_char *bound,
245                        const GFC_INTEGER_8 *pwhich)
246 {
247   eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
248 }
249
250 extern void eoshift3_8_char (gfc_array_char *, GFC_INTEGER_4,
251                                           const gfc_array_char *,
252                                           const gfc_array_i8 *,
253                                           const gfc_array_char *,
254                                           const GFC_INTEGER_8 *, GFC_INTEGER_4,
255                                           GFC_INTEGER_4);
256 export_proto(eoshift3_8_char);
257
258 void
259 eoshift3_8_char (gfc_array_char *ret,
260                               GFC_INTEGER_4 ret_length __attribute__((unused)),
261                               const gfc_array_char *array, const gfc_array_i8 *h,
262                               const gfc_array_char *bound,
263                               const GFC_INTEGER_8 *pwhich,
264                               GFC_INTEGER_4 array_length,
265                               GFC_INTEGER_4 bound_length
266                                 __attribute__((unused)))
267 {
268   eoshift3 (ret, array, h, bound, pwhich, array_length, ' ');
269 }