OSDN Git Service

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