OSDN Git Service

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