OSDN Git Service

2008-11-18 Thomas Koenig <tkoenig@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / reshape_generic.c
1 /* Generic implementation of the RESHAPE intrinsic
2    Copyright 2002, 2006, 2007 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 Ligbfortran 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 "libgfortran.h"
32 #include <stdlib.h>
33 #include <string.h>
34 #include <assert.h>
35
36 typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
37 typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray;
38
39 static void
40 reshape_internal (parray *ret, parray *source, shape_type *shape,
41                   parray *pad, shape_type *order, index_type size)
42 {
43   /* r.* indicates the return array.  */
44   index_type rcount[GFC_MAX_DIMENSIONS];
45   index_type rextent[GFC_MAX_DIMENSIONS];
46   index_type rstride[GFC_MAX_DIMENSIONS];
47   index_type rstride0;
48   index_type rdim;
49   index_type rsize;
50   index_type rs;
51   index_type rex;
52   char * restrict rptr;
53   /* s.* indicates the source array.  */
54   index_type scount[GFC_MAX_DIMENSIONS];
55   index_type sextent[GFC_MAX_DIMENSIONS];
56   index_type sstride[GFC_MAX_DIMENSIONS];
57   index_type sstride0;
58   index_type sdim;
59   index_type ssize;
60   const char *sptr;
61   /* p.* indicates the pad array.  */
62   index_type pcount[GFC_MAX_DIMENSIONS];
63   index_type pextent[GFC_MAX_DIMENSIONS];
64   index_type pstride[GFC_MAX_DIMENSIONS];
65   index_type pdim;
66   index_type psize;
67   const char *pptr;
68
69   const char *src;
70   int n;
71   int dim;
72   int sempty, pempty, shape_empty;
73   index_type shape_data[GFC_MAX_DIMENSIONS];
74
75   rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
76   if (rdim != GFC_DESCRIPTOR_RANK(ret))
77     runtime_error("rank of return array incorrect in RESHAPE intrinsic");
78
79   shape_empty = 0;
80
81   for (n = 0; n < rdim; n++)
82     {
83       shape_data[n] = shape->data[n * shape->dim[0].stride];
84       if (shape_data[n] <= 0)
85         {
86           shape_data[n] = 0;
87           shape_empty = 1;
88         }
89     }
90
91   if (ret->data == NULL)
92     {
93       rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
94       rs = 1;
95       for (n = 0; n < rdim; n++)
96         {
97           ret->dim[n].lbound = 0;
98           rex = shape_data[n];
99           ret->dim[n].ubound =  rex - 1;
100           ret->dim[n].stride = rs;
101           rs *= rex;
102         }
103       ret->offset = 0;
104       ret->data = internal_malloc_size ( rs * size );
105       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
106     }
107
108   if (shape_empty)
109     return;
110
111   if (unlikely (compile_options.bounds_check))
112     {
113       index_type ret_extent, source_extent;
114
115       rs = 1;
116       for (n = 0; n < rdim; n++)
117         {
118           rs *= shape_data[n];
119           ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
120           if (ret_extent != shape_data[n])
121             runtime_error("Incorrect extent in return value of RESHAPE"
122                           " intrinsic in dimension %ld: is %ld,"
123                           " should be %ld", (long int) n+1,
124                           (long int) ret_extent, (long int) shape_data[n]);
125         }
126
127       source_extent = source->dim[0].ubound + 1 - source->dim[0].lbound;
128
129       if (rs < source_extent || (rs > source_extent && !pad))
130         runtime_error("Incorrect size in SOURCE argument to RESHAPE"
131                       " intrinsic: is %ld, should be %ld",
132                       (long int) source_extent, (long int) rs);
133
134       if (order)
135         {
136           int seen[GFC_MAX_DIMENSIONS];
137           index_type v;
138
139           for (n = 0; n < rdim; n++)
140             seen[n] = 0;
141
142           for (n = 0; n < rdim; n++)
143             {
144               v = order->data[n * order->dim[0].stride] - 1;
145
146               if (v < 0 || v >= rdim)
147                 runtime_error("Value %ld out of range in ORDER argument"
148                               " to RESHAPE intrinsic", (long int) v + 1);
149
150               if (seen[v] != 0)
151                 runtime_error("Duplicate value %ld in ORDER argument to"
152                               " RESHAPE intrinsic", (long int) v + 1);
153                 
154               seen[v] = 1;
155             }
156         }
157     }
158
159   rsize = 1;
160   for (n = 0; n < rdim; n++)
161     {
162       if (order)
163         dim = order->data[n * order->dim[0].stride] - 1;
164       else
165         dim = n;
166
167       rcount[n] = 0;
168       rstride[n] = ret->dim[dim].stride;
169       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
170
171       if (rextent[n] != shape_data[dim])
172         runtime_error ("shape and target do not conform");
173
174       if (rsize == rstride[n])
175         rsize *= rextent[n];
176       else
177         rsize = 0;
178       if (rextent[n] <= 0)
179         return;
180     }
181
182   sdim = GFC_DESCRIPTOR_RANK (source);
183   ssize = 1;
184   sempty = 0;
185   for (n = 0; n < sdim; n++)
186     {
187       scount[n] = 0;
188       sstride[n] = source->dim[n].stride;
189       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
190       if (sextent[n] <= 0)
191         {
192           sempty = 1;
193           sextent[n] = 0;
194         }
195
196       if (ssize == sstride[n])
197         ssize *= sextent[n];
198       else
199         ssize = 0;
200     }
201
202   if (pad)
203     {
204       pdim = GFC_DESCRIPTOR_RANK (pad);
205       psize = 1;
206       pempty = 0;
207       for (n = 0; n < pdim; n++)
208         {
209           pcount[n] = 0;
210           pstride[n] = pad->dim[n].stride;
211           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
212           if (pextent[n] <= 0)
213             {
214               pempty = 1;
215               pextent[n] = 0;
216             }
217
218           if (psize == pstride[n])
219             psize *= pextent[n];
220           else
221             psize = 0;
222         }
223       pptr = pad->data;
224     }
225   else
226     {
227       pdim = 0;
228       psize = 1;
229       pempty = 1;
230       pptr = NULL;
231     }
232
233   if (rsize != 0 && ssize != 0 && psize != 0)
234     {
235       rsize *= size;
236       ssize *= size;
237       psize *= size;
238       reshape_packed (ret->data, rsize, source->data, ssize,
239                       pad ? pad->data : NULL, psize);
240       return;
241     }
242   rptr = ret->data;
243   src = sptr = source->data;
244   rstride0 = rstride[0] * size;
245   sstride0 = sstride[0] * size;
246
247   if (sempty && pempty)
248     abort ();
249
250   if (sempty)
251     {
252       /* Pretend we are using the pad array the first time around, too.  */
253       src = pptr;
254       sptr = pptr;
255       sdim = pdim;
256       for (dim = 0; dim < pdim; dim++)
257         {
258           scount[dim] = pcount[dim];
259           sextent[dim] = pextent[dim];
260           sstride[dim] = pstride[dim];
261           sstride0 = pstride[0] * size;
262         }
263     }
264
265   while (rptr)
266     {
267       /* Select between the source and pad arrays.  */
268       memcpy(rptr, src, size);
269       /* Advance to the next element.  */
270       rptr += rstride0;
271       src += sstride0;
272       rcount[0]++;
273       scount[0]++;
274
275       /* Advance to the next destination element.  */
276       n = 0;
277       while (rcount[n] == rextent[n])
278         {
279           /* When we get to the end of a dimension, reset it and increment
280              the next dimension.  */
281           rcount[n] = 0;
282           /* We could precalculate these products, but this is a less
283              frequently used path so probably not worth it.  */
284           rptr -= rstride[n] * rextent[n] * size;
285           n++;
286           if (n == rdim)
287             {
288               /* Break out of the loop.  */
289               rptr = NULL;
290               break;
291             }
292           else
293             {
294               rcount[n]++;
295               rptr += rstride[n] * size;
296             }
297         }
298
299       /* Advance to the next source element.  */
300       n = 0;
301       while (scount[n] == sextent[n])
302         {
303           /* When we get to the end of a dimension, reset it and increment
304              the next dimension.  */
305           scount[n] = 0;
306           /* We could precalculate these products, but this is a less
307              frequently used path so probably not worth it.  */
308           src -= sstride[n] * sextent[n] * size;
309           n++;
310           if (n == sdim)
311             {
312               if (sptr && pad)
313                 {
314                   /* Switch to the pad array.  */
315                   sptr = NULL;
316                   sdim = pdim;
317                   for (dim = 0; dim < pdim; dim++)
318                     {
319                       scount[dim] = pcount[dim];
320                       sextent[dim] = pextent[dim];
321                       sstride[dim] = pstride[dim];
322                       sstride0 = sstride[0] * size;
323                     }
324                 }
325               /* We now start again from the beginning of the pad array.  */
326               src = pptr;
327               break;
328             }
329           else
330             {
331               scount[n]++;
332               src += sstride[n] * size;
333             }
334         }
335     }
336 }
337
338 extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
339 export_proto(reshape);
340
341 void
342 reshape (parray *ret, parray *source, shape_type *shape, parray *pad,
343          shape_type *order)
344 {
345   reshape_internal (ret, source, shape, pad, order,
346                     GFC_DESCRIPTOR_SIZE (source));
347 }
348
349
350 extern void reshape_char (parray *, gfc_charlen_type, parray *, shape_type *,
351                           parray *, shape_type *, gfc_charlen_type,
352                           gfc_charlen_type);
353 export_proto(reshape_char);
354
355 void
356 reshape_char (parray *ret, gfc_charlen_type ret_length __attribute__((unused)),
357               parray *source, shape_type *shape, parray *pad,
358               shape_type *order, gfc_charlen_type source_length,
359               gfc_charlen_type pad_length __attribute__((unused)))
360 {
361   reshape_internal (ret, source, shape, pad, order, source_length);
362 }
363
364
365 extern void reshape_char4 (parray *, gfc_charlen_type, parray *, shape_type *,
366                            parray *, shape_type *, gfc_charlen_type,
367                            gfc_charlen_type);
368 export_proto(reshape_char4);
369
370 void
371 reshape_char4 (parray *ret, gfc_charlen_type ret_length __attribute__((unused)),
372                parray *source, shape_type *shape, parray *pad,
373                shape_type *order, gfc_charlen_type source_length,
374                gfc_charlen_type pad_length __attribute__((unused)))
375 {
376   reshape_internal (ret, source, shape, pad, order,
377                     source_length * sizeof (gfc_char4_t));
378 }