OSDN Git Service

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