OSDN Git Service

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