1 /* Generic implementation of the SPREAD intrinsic
2 Copyright (C) 2002-2023 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"
30 spread_internal (gfc_array_char
*ret
, const gfc_array_char
*source
,
31 const index_type
*along
, const index_type
*pncopies
)
33 /* r.* indicates the return array. */
34 index_type rstride
[GFC_MAX_DIMENSIONS
];
36 index_type rdelta
= 0;
41 /* s.* indicates the source array. */
42 index_type sstride
[GFC_MAX_DIMENSIONS
];
47 index_type count
[GFC_MAX_DIMENSIONS
];
48 index_type extent
[GFC_MAX_DIMENSIONS
];
54 size
= GFC_DESCRIPTOR_SIZE(source
);
56 srank
= GFC_DESCRIPTOR_RANK(source
);
58 sstride
[0] = 0; /* Avoid warnings if not initialized. */
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
->base_addr
== NULL
)
71 /* The front end has signalled that we need to populate the
72 return array descriptor. */
76 ret
->dtype
.rank
= rrank
;
80 for (n
= 0; n
< rrank
; n
++)
92 extent
[dim
] = GFC_DESCRIPTOR_EXTENT(source
,dim
);
93 sstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(source
,dim
);
94 rstride
[dim
] = rs
* size
;
101 GFC_DIMENSION_SET(ret
->dim
[n
], 0, ub
, stride
);
104 ret
->base_addr
= xmallocarray (rs
, size
);
116 if (GFC_DESCRIPTOR_RANK(ret
) != rrank
)
117 runtime_error ("rank mismatch in spread()");
119 if (compile_options
.bounds_check
)
121 for (n
= 0; n
< rrank
; n
++)
123 index_type ret_extent
;
125 ret_extent
= GFC_DESCRIPTOR_EXTENT(ret
,n
);
128 rdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
130 if (ret_extent
!= ncopies
)
131 runtime_error("Incorrect extent in return value of SPREAD"
132 " intrinsic in dimension %ld: is %ld,"
133 " should be %ld", (long int) n
+1,
134 (long int) ret_extent
, (long int) ncopies
);
139 extent
[dim
] = GFC_DESCRIPTOR_EXTENT(source
,dim
);
140 if (ret_extent
!= extent
[dim
])
141 runtime_error("Incorrect extent in return value of SPREAD"
142 " intrinsic in dimension %ld: is %ld,"
143 " should be %ld", (long int) n
+1,
144 (long int) ret_extent
,
145 (long int) extent
[dim
]);
147 if (extent
[dim
] <= 0)
149 sstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(source
,dim
);
150 rstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
157 for (n
= 0; n
< rrank
; n
++)
161 rdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
166 extent
[dim
] = GFC_DESCRIPTOR_EXTENT(source
,dim
);
167 if (extent
[dim
] <= 0)
169 sstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(source
,dim
);
170 rstride
[dim
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
,n
);
182 sstride0
= sstride
[0];
183 rstride0
= rstride
[0];
184 rptr
= ret
->base_addr
;
185 sptr
= source
->base_addr
;
189 /* Spread this element. */
191 for (n
= 0; n
< ncopies
; n
++)
193 memcpy (dest
, sptr
, size
);
196 /* Advance to the next element. */
201 while (count
[n
] == extent
[n
])
203 /* When we get to the end of a dimension, reset it and increment
204 the next dimension. */
206 /* We could precalculate these products, but this is a less
207 frequently used path so probably not worth it. */
208 sptr
-= sstride
[n
] * extent
[n
];
209 rptr
-= rstride
[n
] * extent
[n
];
213 /* Break out of the loop. */
227 /* This version of spread_internal treats the special case of a scalar
228 source. This is much simpler than the more general case above. */
231 spread_internal_scalar (gfc_array_char
*ret
, const char *source
,
232 const index_type
*along
, const index_type
*pncopies
)
235 int ncopies
= *pncopies
;
239 size
= GFC_DESCRIPTOR_SIZE(ret
);
241 if (GFC_DESCRIPTOR_RANK (ret
) != 1)
242 runtime_error ("incorrect destination rank in spread()");
245 runtime_error ("dim outside of rank in spread()");
247 if (ret
->base_addr
== NULL
)
249 ret
->base_addr
= xmallocarray (ncopies
, size
);
251 GFC_DIMENSION_SET(ret
->dim
[0], 0, ncopies
- 1, 1);
255 if (ncopies
- 1 > (GFC_DESCRIPTOR_EXTENT(ret
,0) - 1)
256 / GFC_DESCRIPTOR_STRIDE(ret
,0))
257 runtime_error ("dim too large in spread()");
260 for (n
= 0; n
< ncopies
; n
++)
262 dest
= (char*)(ret
->base_addr
+ n
* GFC_DESCRIPTOR_STRIDE_BYTES(ret
,0));
263 memcpy (dest
, source
, size
);
267 extern void spread (gfc_array_char
*, const gfc_array_char
*,
268 const index_type
*, const index_type
*);
269 export_proto(spread
);
272 spread (gfc_array_char
*ret
, const gfc_array_char
*source
,
273 const index_type
*along
, const index_type
*pncopies
)
275 index_type type_size
;
277 type_size
= GFC_DTYPE_TYPE_SIZE(ret
);
280 case GFC_DTYPE_LOGICAL_1
:
281 case GFC_DTYPE_INTEGER_1
:
282 spread_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) source
,
286 case GFC_DTYPE_LOGICAL_2
:
287 case GFC_DTYPE_INTEGER_2
:
288 spread_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) source
,
292 case GFC_DTYPE_LOGICAL_4
:
293 case GFC_DTYPE_INTEGER_4
:
294 spread_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) source
,
298 case GFC_DTYPE_LOGICAL_8
:
299 case GFC_DTYPE_INTEGER_8
:
300 spread_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) source
,
304 #ifdef HAVE_GFC_INTEGER_16
305 case GFC_DTYPE_LOGICAL_16
:
306 case GFC_DTYPE_INTEGER_16
:
307 spread_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) source
,
312 case GFC_DTYPE_REAL_4
:
313 spread_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) source
,
317 case GFC_DTYPE_REAL_8
:
318 spread_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) source
,
322 /* FIXME: This here is a hack, which will have to be removed when
323 the array descriptor is reworked. Currently, we don't store the
324 kind value for the type, but only the size. Because on targets with
325 _Float128, we have sizeof(long double) == sizeof(_Float128),
326 we cannot discriminate here and have to fall back to the generic
327 handling (which is suboptimal). */
328 #if !defined(GFC_REAL_16_IS_FLOAT128)
329 # ifdef GFC_HAVE_REAL_10
330 case GFC_DTYPE_REAL_10
:
331 spread_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) source
,
336 # ifdef GFC_HAVE_REAL_16
337 case GFC_DTYPE_REAL_16
:
338 spread_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) source
,
344 case GFC_DTYPE_COMPLEX_4
:
345 spread_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) source
,
349 case GFC_DTYPE_COMPLEX_8
:
350 spread_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) source
,
354 /* FIXME: This here is a hack, which will have to be removed when
355 the array descriptor is reworked. Currently, we don't store the
356 kind value for the type, but only the size. Because on targets with
357 _Float128, we have sizeof(long double) == sizeof(_Float128),
358 we cannot discriminate here and have to fall back to the generic
359 handling (which is suboptimal). */
360 #if !defined(GFC_REAL_16_IS_FLOAT128)
361 # ifdef GFC_HAVE_COMPLEX_10
362 case GFC_DTYPE_COMPLEX_10
:
363 spread_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) source
,
368 # ifdef GFC_HAVE_COMPLEX_16
369 case GFC_DTYPE_COMPLEX_16
:
370 spread_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) source
,
378 switch (GFC_DESCRIPTOR_SIZE (ret
))
381 spread_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) source
,
386 if (GFC_UNALIGNED_2(ret
->base_addr
) || GFC_UNALIGNED_2(source
->base_addr
))
390 spread_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) source
,
396 if (GFC_UNALIGNED_4(ret
->base_addr
) || GFC_UNALIGNED_4(source
->base_addr
))
400 spread_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) source
,
406 if (GFC_UNALIGNED_8(ret
->base_addr
) || GFC_UNALIGNED_8(source
->base_addr
))
410 spread_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) source
,
414 #ifdef HAVE_GFC_INTEGER_16
416 if (GFC_UNALIGNED_16(ret
->base_addr
)
417 || GFC_UNALIGNED_16(source
->base_addr
))
421 spread_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) source
,
429 spread_internal (ret
, source
, along
, pncopies
);
433 extern void spread_char (gfc_array_char
*, GFC_INTEGER_4
,
434 const gfc_array_char
*, const index_type
*,
435 const index_type
*, GFC_INTEGER_4
);
436 export_proto(spread_char
);
439 spread_char (gfc_array_char
*ret
,
440 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
441 const gfc_array_char
*source
, const index_type
*along
,
442 const index_type
*pncopies
,
443 GFC_INTEGER_4 source_length
__attribute__((unused
)))
445 spread_internal (ret
, source
, along
, pncopies
);
449 extern void spread_char4 (gfc_array_char
*, GFC_INTEGER_4
,
450 const gfc_array_char
*, const index_type
*,
451 const index_type
*, GFC_INTEGER_4
);
452 export_proto(spread_char4
);
455 spread_char4 (gfc_array_char
*ret
,
456 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
457 const gfc_array_char
*source
, const index_type
*along
,
458 const index_type
*pncopies
,
459 GFC_INTEGER_4 source_length
__attribute__((unused
)))
461 spread_internal (ret
, source
, along
, pncopies
);
465 /* The following are the prototypes for the versions of spread with a
468 extern void spread_scalar (gfc_array_char
*, const char *,
469 const index_type
*, const index_type
*);
470 export_proto(spread_scalar
);
473 spread_scalar (gfc_array_char
*ret
, const char *source
,
474 const index_type
*along
, const index_type
*pncopies
)
476 index_type type_size
;
478 if (GFC_DTYPE_IS_UNSET(ret
))
479 runtime_error ("return array missing descriptor in spread()");
481 type_size
= GFC_DTYPE_TYPE_SIZE(ret
);
484 case GFC_DTYPE_LOGICAL_1
:
485 case GFC_DTYPE_INTEGER_1
:
486 spread_scalar_i1 ((gfc_array_i1
*) ret
, (GFC_INTEGER_1
*) source
,
490 case GFC_DTYPE_LOGICAL_2
:
491 case GFC_DTYPE_INTEGER_2
:
492 spread_scalar_i2 ((gfc_array_i2
*) ret
, (GFC_INTEGER_2
*) source
,
496 case GFC_DTYPE_LOGICAL_4
:
497 case GFC_DTYPE_INTEGER_4
:
498 spread_scalar_i4 ((gfc_array_i4
*) ret
, (GFC_INTEGER_4
*) source
,
502 case GFC_DTYPE_LOGICAL_8
:
503 case GFC_DTYPE_INTEGER_8
:
504 spread_scalar_i8 ((gfc_array_i8
*) ret
, (GFC_INTEGER_8
*) source
,
508 #ifdef HAVE_GFC_INTEGER_16
509 case GFC_DTYPE_LOGICAL_16
:
510 case GFC_DTYPE_INTEGER_16
:
511 spread_scalar_i16 ((gfc_array_i16
*) ret
, (GFC_INTEGER_16
*) source
,
516 case GFC_DTYPE_REAL_4
:
517 spread_scalar_r4 ((gfc_array_r4
*) ret
, (GFC_REAL_4
*) source
,
521 case GFC_DTYPE_REAL_8
:
522 spread_scalar_r8 ((gfc_array_r8
*) ret
, (GFC_REAL_8
*) source
,
526 /* FIXME: This here is a hack, which will have to be removed when
527 the array descriptor is reworked. Currently, we don't store the
528 kind value for the type, but only the size. Because on targets with
529 _Float128, we have sizeof(long double) == sizeof(_Float128),
530 we cannot discriminate here and have to fall back to the generic
531 handling (which is suboptimal). */
532 #if !defined(GFC_REAL_16_IS_FLOAT128)
533 # ifdef HAVE_GFC_REAL_10
534 case GFC_DTYPE_REAL_10
:
535 spread_scalar_r10 ((gfc_array_r10
*) ret
, (GFC_REAL_10
*) source
,
540 # ifdef HAVE_GFC_REAL_16
541 case GFC_DTYPE_REAL_16
:
542 spread_scalar_r16 ((gfc_array_r16
*) ret
, (GFC_REAL_16
*) source
,
548 case GFC_DTYPE_COMPLEX_4
:
549 spread_scalar_c4 ((gfc_array_c4
*) ret
, (GFC_COMPLEX_4
*) source
,
553 case GFC_DTYPE_COMPLEX_8
:
554 spread_scalar_c8 ((gfc_array_c8
*) ret
, (GFC_COMPLEX_8
*) source
,
558 /* FIXME: This here is a hack, which will have to be removed when
559 the array descriptor is reworked. Currently, we don't store the
560 kind value for the type, but only the size. Because on targets with
561 _Float128, we have sizeof(long double) == sizeof(_Float128),
562 we cannot discriminate here and have to fall back to the generic
563 handling (which is suboptimal). */
564 #if !defined(GFC_REAL_16_IS_FLOAT128)
565 # ifdef HAVE_GFC_COMPLEX_10
566 case GFC_DTYPE_COMPLEX_10
:
567 spread_scalar_c10 ((gfc_array_c10
*) ret
, (GFC_COMPLEX_10
*) source
,
572 # ifdef HAVE_GFC_COMPLEX_16
573 case GFC_DTYPE_COMPLEX_16
:
574 spread_scalar_c16 ((gfc_array_c16
*) ret
, (GFC_COMPLEX_16
*) source
,
582 switch (GFC_DESCRIPTOR_SIZE(ret
))
585 spread_scalar_i1 ((gfc_array_i1
*) ret
, (GFC_INTEGER_1
*) source
,
590 if (GFC_UNALIGNED_2(ret
->base_addr
) || GFC_UNALIGNED_2(source
))
594 spread_scalar_i2 ((gfc_array_i2
*) ret
, (GFC_INTEGER_2
*) source
,
600 if (GFC_UNALIGNED_4(ret
->base_addr
) || GFC_UNALIGNED_4(source
))
604 spread_scalar_i4 ((gfc_array_i4
*) ret
, (GFC_INTEGER_4
*) source
,
610 if (GFC_UNALIGNED_8(ret
->base_addr
) || GFC_UNALIGNED_8(source
))
614 spread_scalar_i8 ((gfc_array_i8
*) ret
, (GFC_INTEGER_8
*) source
,
618 #ifdef HAVE_GFC_INTEGER_16
620 if (GFC_UNALIGNED_16(ret
->base_addr
) || GFC_UNALIGNED_16(source
))
624 spread_scalar_i16 ((gfc_array_i16
*) ret
, (GFC_INTEGER_16
*) source
,
633 spread_internal_scalar (ret
, source
, along
, pncopies
);
637 extern void spread_char_scalar (gfc_array_char
*, GFC_INTEGER_4
,
638 const char *, const index_type
*,
639 const index_type
*, GFC_INTEGER_4
);
640 export_proto(spread_char_scalar
);
643 spread_char_scalar (gfc_array_char
*ret
,
644 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
645 const char *source
, const index_type
*along
,
646 const index_type
*pncopies
,
647 GFC_INTEGER_4 source_length
__attribute__((unused
)))
649 if (GFC_DTYPE_IS_UNSET(ret
))
650 runtime_error ("return array missing descriptor in spread()");
651 spread_internal_scalar (ret
, source
, along
, pncopies
);
655 extern void spread_char4_scalar (gfc_array_char
*, GFC_INTEGER_4
,
656 const char *, const index_type
*,
657 const index_type
*, GFC_INTEGER_4
);
658 export_proto(spread_char4_scalar
);
661 spread_char4_scalar (gfc_array_char
*ret
,
662 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
663 const char *source
, const index_type
*along
,
664 const index_type
*pncopies
,
665 GFC_INTEGER_4 source_length
__attribute__((unused
)))
667 if (GFC_DTYPE_IS_UNSET(ret
))
668 runtime_error ("return array missing descriptor in spread()");
669 spread_internal_scalar (ret
, source
, along
, pncopies
);