1 /* Generic implementation of the SPREAD intrinsic
2 Copyright 2002, 2005, 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 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"
32 spread_internal (gfc_array_char
*ret
, const gfc_array_char
*source
,
33 const index_type
*along
, const index_type
*pncopies
)
35 /* r.* indicates the return array. */
36 index_type rstride
[GFC_MAX_DIMENSIONS
];
38 index_type rdelta
= 0;
43 /* s.* indicates the source array. */
44 index_type sstride
[GFC_MAX_DIMENSIONS
];
49 index_type count
[GFC_MAX_DIMENSIONS
];
50 index_type extent
[GFC_MAX_DIMENSIONS
];
56 size
= GFC_DESCRIPTOR_SIZE(source
);
58 srank
= GFC_DESCRIPTOR_RANK(source
);
61 if (rrank
> GFC_MAX_DIMENSIONS
)
62 runtime_error ("return rank too large in spread()");
65 runtime_error ("dim outside of rank in spread()");
69 if (ret
->data
== NULL
)
71 /* The front end has signalled that we need to populate the
72 return array descriptor. */
76 ret
->dtype
= (source
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rrank
;
79 for (n
= 0; n
< rrank
; n
++)
91 extent
[dim
] = GFC_DESCRIPTOR_EXTENT(source
,dim
);
92 sstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(source
,dim
);
93 rstride
[dim
] = rs
* size
;
100 GFC_DIMENSION_SET(ret
->dim
[n
], 0, ub
, stride
);
104 ret
->data
= internal_malloc_size (rs
* size
);
107 ret
->data
= internal_malloc_size (1);
118 if (GFC_DESCRIPTOR_RANK(ret
) != rrank
)
119 runtime_error ("rank mismatch in spread()");
121 if (compile_options
.bounds_check
)
123 for (n
= 0; n
< rrank
; n
++)
125 index_type ret_extent
;
127 ret_extent
= GFC_DESCRIPTOR_EXTENT(ret
,n
);
130 rdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
132 if (ret_extent
!= ncopies
)
133 runtime_error("Incorrect extent in return value of SPREAD"
134 " intrinsic in dimension %ld: is %ld,"
135 " should be %ld", (long int) n
+1,
136 (long int) ret_extent
, (long int) ncopies
);
141 extent
[dim
] = GFC_DESCRIPTOR_EXTENT(source
,dim
);
142 if (ret_extent
!= extent
[dim
])
143 runtime_error("Incorrect extent in return value of SPREAD"
144 " intrinsic in dimension %ld: is %ld,"
145 " should be %ld", (long int) n
+1,
146 (long int) ret_extent
,
147 (long int) extent
[dim
]);
149 if (extent
[dim
] <= 0)
151 sstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(source
,dim
);
152 rstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
159 for (n
= 0; n
< rrank
; n
++)
163 rdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
168 extent
[dim
] = GFC_DESCRIPTOR_EXTENT(source
,dim
);
169 if (extent
[dim
] <= 0)
171 sstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(source
,dim
);
172 rstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
184 sstride0
= sstride
[0];
185 rstride0
= rstride
[0];
191 /* Spread this element. */
193 for (n
= 0; n
< ncopies
; n
++)
195 memcpy (dest
, sptr
, size
);
198 /* Advance to the next element. */
203 while (count
[n
] == extent
[n
])
205 /* When we get to the end of a dimension, reset it and increment
206 the next dimension. */
208 /* We could precalculate these products, but this is a less
209 frequently used path so probably not worth it. */
210 sptr
-= sstride
[n
] * extent
[n
];
211 rptr
-= rstride
[n
] * extent
[n
];
215 /* Break out of the loop. */
229 /* This version of spread_internal treats the special case of a scalar
230 source. This is much simpler than the more general case above. */
233 spread_internal_scalar (gfc_array_char
*ret
, const char *source
,
234 const index_type
*along
, const index_type
*pncopies
)
237 int ncopies
= *pncopies
;
241 size
= GFC_DESCRIPTOR_SIZE(ret
);
243 if (GFC_DESCRIPTOR_RANK (ret
) != 1)
244 runtime_error ("incorrect destination rank in spread()");
247 runtime_error ("dim outside of rank in spread()");
249 if (ret
->data
== NULL
)
251 ret
->data
= internal_malloc_size (ncopies
* size
);
253 GFC_DIMENSION_SET(ret
->dim
[0], 0, ncopies
- 1, 1);
257 if (ncopies
- 1 > (GFC_DESCRIPTOR_EXTENT(ret
,0) - 1)
258 / GFC_DESCRIPTOR_STRIDE(ret
,0))
259 runtime_error ("dim too large in spread()");
262 for (n
= 0; n
< ncopies
; n
++)
264 dest
= (char*)(ret
->data
+ n
* GFC_DESCRIPTOR_STRIDE_BYTES(ret
,0));
265 memcpy (dest
, source
, size
);
269 extern void spread (gfc_array_char
*, const gfc_array_char
*,
270 const index_type
*, const index_type
*);
271 export_proto(spread
);
274 spread (gfc_array_char
*ret
, const gfc_array_char
*source
,
275 const index_type
*along
, const index_type
*pncopies
)
277 index_type type_size
;
279 type_size
= GFC_DTYPE_TYPE_SIZE(ret
);
282 case GFC_DTYPE_DERIVED_1
:
283 case GFC_DTYPE_LOGICAL_1
:
284 case GFC_DTYPE_INTEGER_1
:
285 spread_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) source
,
289 case GFC_DTYPE_LOGICAL_2
:
290 case GFC_DTYPE_INTEGER_2
:
291 spread_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) source
,
295 case GFC_DTYPE_LOGICAL_4
:
296 case GFC_DTYPE_INTEGER_4
:
297 spread_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) source
,
301 case GFC_DTYPE_LOGICAL_8
:
302 case GFC_DTYPE_INTEGER_8
:
303 spread_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) source
,
307 #ifdef HAVE_GFC_INTEGER_16
308 case GFC_DTYPE_LOGICAL_16
:
309 case GFC_DTYPE_INTEGER_16
:
310 spread_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) source
,
315 case GFC_DTYPE_REAL_4
:
316 spread_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) source
,
320 case GFC_DTYPE_REAL_8
:
321 spread_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) source
,
325 /* FIXME: This here is a hack, which will have to be removed when
326 the array descriptor is reworked. Currently, we don't store the
327 kind value for the type, but only the size. Because on targets with
328 __float128, we have sizeof(logn double) == sizeof(__float128),
329 we cannot discriminate here and have to fall back to the generic
330 handling (which is suboptimal). */
331 #if !defined(GFC_REAL_16_IS_FLOAT128)
332 # ifdef GFC_HAVE_REAL_10
333 case GFC_DTYPE_REAL_10
:
334 spread_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) source
,
339 # ifdef GFC_HAVE_REAL_16
340 case GFC_DTYPE_REAL_16
:
341 spread_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) source
,
347 case GFC_DTYPE_COMPLEX_4
:
348 spread_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) source
,
352 case GFC_DTYPE_COMPLEX_8
:
353 spread_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) source
,
357 /* FIXME: This here is a hack, which will have to be removed when
358 the array descriptor is reworked. Currently, we don't store the
359 kind value for the type, but only the size. Because on targets with
360 __float128, we have sizeof(logn double) == sizeof(__float128),
361 we cannot discriminate here and have to fall back to the generic
362 handling (which is suboptimal). */
363 #if !defined(GFC_REAL_16_IS_FLOAT128)
364 # ifdef GFC_HAVE_COMPLEX_10
365 case GFC_DTYPE_COMPLEX_10
:
366 spread_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) source
,
371 # ifdef GFC_HAVE_COMPLEX_16
372 case GFC_DTYPE_COMPLEX_16
:
373 spread_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) source
,
379 case GFC_DTYPE_DERIVED_2
:
380 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(source
->data
))
384 spread_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) source
,
389 case GFC_DTYPE_DERIVED_4
:
390 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(source
->data
))
394 spread_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) source
,
399 case GFC_DTYPE_DERIVED_8
:
400 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(source
->data
))
404 spread_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) source
,
409 #ifdef HAVE_GFC_INTEGER_16
410 case GFC_DTYPE_DERIVED_16
:
411 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(source
->data
))
415 spread_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) source
,
422 spread_internal (ret
, source
, along
, pncopies
);
426 extern void spread_char (gfc_array_char
*, GFC_INTEGER_4
,
427 const gfc_array_char
*, const index_type
*,
428 const index_type
*, GFC_INTEGER_4
);
429 export_proto(spread_char
);
432 spread_char (gfc_array_char
*ret
,
433 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
434 const gfc_array_char
*source
, const index_type
*along
,
435 const index_type
*pncopies
,
436 GFC_INTEGER_4 source_length
__attribute__((unused
)))
438 spread_internal (ret
, source
, along
, pncopies
);
442 extern void spread_char4 (gfc_array_char
*, GFC_INTEGER_4
,
443 const gfc_array_char
*, const index_type
*,
444 const index_type
*, GFC_INTEGER_4
);
445 export_proto(spread_char4
);
448 spread_char4 (gfc_array_char
*ret
,
449 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
450 const gfc_array_char
*source
, const index_type
*along
,
451 const index_type
*pncopies
,
452 GFC_INTEGER_4 source_length
__attribute__((unused
)))
454 spread_internal (ret
, source
, along
, pncopies
);
458 /* The following are the prototypes for the versions of spread with a
461 extern void spread_scalar (gfc_array_char
*, const char *,
462 const index_type
*, const index_type
*);
463 export_proto(spread_scalar
);
466 spread_scalar (gfc_array_char
*ret
, const char *source
,
467 const index_type
*along
, const index_type
*pncopies
)
469 index_type type_size
;
472 runtime_error ("return array missing descriptor in spread()");
474 type_size
= GFC_DTYPE_TYPE_SIZE(ret
);
477 case GFC_DTYPE_DERIVED_1
:
478 case GFC_DTYPE_LOGICAL_1
:
479 case GFC_DTYPE_INTEGER_1
:
480 spread_scalar_i1 ((gfc_array_i1
*) ret
, (GFC_INTEGER_1
*) source
,
484 case GFC_DTYPE_LOGICAL_2
:
485 case GFC_DTYPE_INTEGER_2
:
486 spread_scalar_i2 ((gfc_array_i2
*) ret
, (GFC_INTEGER_2
*) source
,
490 case GFC_DTYPE_LOGICAL_4
:
491 case GFC_DTYPE_INTEGER_4
:
492 spread_scalar_i4 ((gfc_array_i4
*) ret
, (GFC_INTEGER_4
*) source
,
496 case GFC_DTYPE_LOGICAL_8
:
497 case GFC_DTYPE_INTEGER_8
:
498 spread_scalar_i8 ((gfc_array_i8
*) ret
, (GFC_INTEGER_8
*) source
,
502 #ifdef HAVE_GFC_INTEGER_16
503 case GFC_DTYPE_LOGICAL_16
:
504 case GFC_DTYPE_INTEGER_16
:
505 spread_scalar_i16 ((gfc_array_i16
*) ret
, (GFC_INTEGER_16
*) source
,
510 case GFC_DTYPE_REAL_4
:
511 spread_scalar_r4 ((gfc_array_r4
*) ret
, (GFC_REAL_4
*) source
,
515 case GFC_DTYPE_REAL_8
:
516 spread_scalar_r8 ((gfc_array_r8
*) ret
, (GFC_REAL_8
*) source
,
520 /* FIXME: This here is a hack, which will have to be removed when
521 the array descriptor is reworked. Currently, we don't store the
522 kind value for the type, but only the size. Because on targets with
523 __float128, we have sizeof(logn double) == sizeof(__float128),
524 we cannot discriminate here and have to fall back to the generic
525 handling (which is suboptimal). */
526 #if !defined(GFC_REAL_16_IS_FLOAT128)
527 # ifdef HAVE_GFC_REAL_10
528 case GFC_DTYPE_REAL_10
:
529 spread_scalar_r10 ((gfc_array_r10
*) ret
, (GFC_REAL_10
*) source
,
534 # ifdef HAVE_GFC_REAL_16
535 case GFC_DTYPE_REAL_16
:
536 spread_scalar_r16 ((gfc_array_r16
*) ret
, (GFC_REAL_16
*) source
,
542 case GFC_DTYPE_COMPLEX_4
:
543 spread_scalar_c4 ((gfc_array_c4
*) ret
, (GFC_COMPLEX_4
*) source
,
547 case GFC_DTYPE_COMPLEX_8
:
548 spread_scalar_c8 ((gfc_array_c8
*) ret
, (GFC_COMPLEX_8
*) source
,
552 /* FIXME: This here is a hack, which will have to be removed when
553 the array descriptor is reworked. Currently, we don't store the
554 kind value for the type, but only the size. Because on targets with
555 __float128, we have sizeof(logn double) == sizeof(__float128),
556 we cannot discriminate here and have to fall back to the generic
557 handling (which is suboptimal). */
558 #if !defined(GFC_REAL_16_IS_FLOAT128)
559 # ifdef HAVE_GFC_COMPLEX_10
560 case GFC_DTYPE_COMPLEX_10
:
561 spread_scalar_c10 ((gfc_array_c10
*) ret
, (GFC_COMPLEX_10
*) source
,
566 # ifdef HAVE_GFC_COMPLEX_16
567 case GFC_DTYPE_COMPLEX_16
:
568 spread_scalar_c16 ((gfc_array_c16
*) ret
, (GFC_COMPLEX_16
*) source
,
574 case GFC_DTYPE_DERIVED_2
:
575 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(source
))
579 spread_scalar_i2 ((gfc_array_i2
*) ret
, (GFC_INTEGER_2
*) source
,
584 case GFC_DTYPE_DERIVED_4
:
585 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(source
))
589 spread_scalar_i4 ((gfc_array_i4
*) ret
, (GFC_INTEGER_4
*) source
,
594 case GFC_DTYPE_DERIVED_8
:
595 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(source
))
599 spread_scalar_i8 ((gfc_array_i8
*) ret
, (GFC_INTEGER_8
*) source
,
603 #ifdef HAVE_GFC_INTEGER_16
604 case GFC_DTYPE_DERIVED_16
:
605 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(source
))
609 spread_scalar_i16 ((gfc_array_i16
*) ret
, (GFC_INTEGER_16
*) source
,
616 spread_internal_scalar (ret
, source
, along
, pncopies
);
620 extern void spread_char_scalar (gfc_array_char
*, GFC_INTEGER_4
,
621 const char *, const index_type
*,
622 const index_type
*, GFC_INTEGER_4
);
623 export_proto(spread_char_scalar
);
626 spread_char_scalar (gfc_array_char
*ret
,
627 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
628 const char *source
, const index_type
*along
,
629 const index_type
*pncopies
,
630 GFC_INTEGER_4 source_length
__attribute__((unused
)))
633 runtime_error ("return array missing descriptor in spread()");
634 spread_internal_scalar (ret
, source
, along
, pncopies
);
638 extern void spread_char4_scalar (gfc_array_char
*, GFC_INTEGER_4
,
639 const char *, const index_type
*,
640 const index_type
*, GFC_INTEGER_4
);
641 export_proto(spread_char4_scalar
);
644 spread_char4_scalar (gfc_array_char
*ret
,
645 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
646 const char *source
, const index_type
*along
,
647 const index_type
*pncopies
,
648 GFC_INTEGER_4 source_length
__attribute__((unused
)))
651 runtime_error ("return array missing descriptor in spread()");
652 spread_internal_scalar (ret
, source
, along
, pncopies
);