1 /* Generic implementation of the RESHAPE intrinsic
2 Copyright 2002, 2006, 2007, 2009, 2012 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
31 typedef GFC_ARRAY_DESCRIPTOR(1, index_type
) shape_type
;
32 typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS
, char) parray
;
35 reshape_internal (parray
*ret
, parray
*source
, shape_type
*shape
,
36 parray
*pad
, shape_type
*order
, index_type size
)
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
];
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
];
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
];
67 int sempty
, pempty
, shape_empty
;
68 index_type shape_data
[GFC_MAX_DIMENSIONS
];
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");
76 for (n
= 0; n
< rdim
; n
++)
78 shape_data
[n
] = shape
->base_addr
[n
* GFC_DESCRIPTOR_STRIDE(shape
,0)];
79 if (shape_data
[n
] <= 0)
86 if (ret
->base_addr
== NULL
)
88 index_type alloc_size
;
91 for (n
= 0; n
< rdim
; n
++)
95 GFC_DIMENSION_SET(ret
->dim
[n
],0,rex
- 1,rs
);
101 if (unlikely (rs
< 1))
104 alloc_size
= rs
* size
;
106 ret
->base_addr
= xmalloc (alloc_size
);
108 ret
->dtype
= (source
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rdim
;
116 pdim
= GFC_DESCRIPTOR_RANK (pad
);
119 for (n
= 0; n
< pdim
; n
++)
122 pstride
[n
] = GFC_DESCRIPTOR_STRIDE(pad
,n
);
123 pextent
[n
] = GFC_DESCRIPTOR_EXTENT(pad
,n
);
130 if (psize
== pstride
[n
])
135 pptr
= pad
->base_addr
;
145 if (unlikely (compile_options
.bounds_check
))
147 index_type ret_extent
, source_extent
;
150 for (n
= 0; n
< rdim
; 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
]);
162 sdim
= GFC_DESCRIPTOR_RANK (source
);
163 for (n
= 0; n
< sdim
; n
++)
166 se
= GFC_DESCRIPTOR_EXTENT(source
,n
);
167 source_extent
*= se
> 0 ? se
: 0;
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
);
177 int seen
[GFC_MAX_DIMENSIONS
];
180 for (n
= 0; n
< rdim
; n
++)
183 for (n
= 0; n
< rdim
; n
++)
185 v
= order
->base_addr
[n
* GFC_DESCRIPTOR_STRIDE(order
,0)] - 1;
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);
192 runtime_error("Duplicate value %ld in ORDER argument to"
193 " RESHAPE intrinsic", (long int) v
+ 1);
201 for (n
= 0; n
< rdim
; n
++)
204 dim
= order
->base_addr
[n
* GFC_DESCRIPTOR_STRIDE(order
,0)] - 1;
209 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,dim
);
210 rextent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,dim
);
212 if (rextent
[n
] != shape_data
[dim
])
213 runtime_error ("shape and target do not conform");
215 if (rsize
== rstride
[n
])
223 sdim
= GFC_DESCRIPTOR_RANK (source
);
226 for (n
= 0; n
< sdim
; n
++)
229 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(source
,n
);
230 sextent
[n
] = GFC_DESCRIPTOR_EXTENT(source
,n
);
237 if (ssize
== sstride
[n
])
243 if (rsize
!= 0 && ssize
!= 0 && psize
!= 0)
248 reshape_packed (ret
->base_addr
, rsize
, source
->base_addr
, ssize
,
249 pad
? pad
->base_addr
: NULL
, psize
);
252 rptr
= ret
->base_addr
;
253 src
= sptr
= source
->base_addr
;
254 rstride0
= rstride
[0] * size
;
255 sstride0
= sstride
[0] * size
;
257 if (sempty
&& pempty
)
262 /* Pretend we are using the pad array the first time around, too. */
266 for (dim
= 0; dim
< pdim
; dim
++)
268 scount
[dim
] = pcount
[dim
];
269 sextent
[dim
] = pextent
[dim
];
270 sstride
[dim
] = pstride
[dim
];
271 sstride0
= pstride
[0] * size
;
277 /* Select between the source and pad arrays. */
278 memcpy(rptr
, src
, size
);
279 /* Advance to the next element. */
285 /* Advance to the next destination element. */
287 while (rcount
[n
] == rextent
[n
])
289 /* When we get to the end of a dimension, reset it and increment
290 the next dimension. */
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
;
298 /* Break out of the loop. */
305 rptr
+= rstride
[n
] * size
;
309 /* Advance to the next source element. */
311 while (scount
[n
] == sextent
[n
])
313 /* When we get to the end of a dimension, reset it and increment
314 the next dimension. */
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
;
324 /* Switch to the pad array. */
327 for (dim
= 0; dim
< pdim
; dim
++)
329 scount
[dim
] = pcount
[dim
];
330 sextent
[dim
] = pextent
[dim
];
331 sstride
[dim
] = pstride
[dim
];
332 sstride0
= sstride
[0] * size
;
335 /* We now start again from the beginning of the pad array. */
342 src
+= sstride
[n
] * size
;
348 extern void reshape (parray
*, parray
*, shape_type
*, parray
*, shape_type
*);
349 export_proto(reshape
);
352 reshape (parray
*ret
, parray
*source
, shape_type
*shape
, parray
*pad
,
355 reshape_internal (ret
, source
, shape
, pad
, order
,
356 GFC_DESCRIPTOR_SIZE (source
));
360 extern void reshape_char (parray
*, gfc_charlen_type
, parray
*, shape_type
*,
361 parray
*, shape_type
*, gfc_charlen_type
,
363 export_proto(reshape_char
);
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
)))
371 reshape_internal (ret
, source
, shape
, pad
, order
, source_length
);
375 extern void reshape_char4 (parray
*, gfc_charlen_type
, parray
*, shape_type
*,
376 parray
*, shape_type
*, gfc_charlen_type
,
378 export_proto(reshape_char4
);
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
)))
386 reshape_internal (ret
, source
, shape
, pad
, order
,
387 source_length
* sizeof (gfc_char4_t
));