1 /* Generic implementation of the SPREAD intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of the GNU Fortran 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 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.
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 <string.h>
28
29 static void
30 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
31 const index_type *along, const index_type *pncopies)
32 {
33 /* r.* indicates the return array. */
34 index_type rstride[GFC_MAX_DIMENSIONS];
35 index_type rstride0;
36 index_type rdelta = 0;
37 index_type rrank;
38 index_type rs;
39 char *rptr;
40 char *dest;
41 /* s.* indicates the source array. */
42 index_type sstride[GFC_MAX_DIMENSIONS];
43 index_type sstride0;
44 index_type srank;
45 const char *sptr;
46
47 index_type count[GFC_MAX_DIMENSIONS];
48 index_type extent[GFC_MAX_DIMENSIONS];
49 index_type n;
50 index_type dim;
51 index_type ncopies;
52 index_type size;
53
54 size = GFC_DESCRIPTOR_SIZE(source);
55
56 srank = GFC_DESCRIPTOR_RANK(source);
57
58 sstride[0] = 0; /* Avoid warnings if not initialized. */
59
60 rrank = srank + 1;
61 if (rrank > GFC_MAX_DIMENSIONS)
62 runtime_error ("return rank too large in spread()");
63
64 if (*along > rrank)
65 runtime_error ("dim outside of rank in spread()");
66
67 ncopies = *pncopies;
68
69 if (ret->base_addr == NULL)
70 {
71 /* The front end has signalled that we need to populate the
72 return array descriptor. */
73
74 size_t ub, stride;
75
76 ret->dtype.rank = rrank;
77
78 dim = 0;
79 rs = 1;
80 for (n = 0; n < rrank; n++)
81 {
82 stride = rs;
83 if (n == *along - 1)
84 {
85 ub = ncopies - 1;
86 rdelta = rs * size;
87 rs *= ncopies;
88 }
89 else
90 {
91 count[dim] = 0;
92 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
93 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
94 rstride[dim] = rs * size;
95
96 ub = extent[dim]-1;
97 rs *= extent[dim];
98 dim++;
99 }
100
101 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
102 }
103 ret->offset = 0;
104 ret->base_addr = xmallocarray (rs, size);
105
106 if (rs <= 0)
107 return;
108 }
109 else
110 {
111 int zero_sized;
112
113 zero_sized = 0;
114
115 dim = 0;
116 if (GFC_DESCRIPTOR_RANK(ret) != rrank)
117 runtime_error ("rank mismatch in spread()");
118
119 if (compile_options.bounds_check)
120 {
121 for (n = 0; n < rrank; n++)
122 {
123 index_type ret_extent;
124
125 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
126 if (n == *along - 1)
127 {
128 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
129
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);
135 }
136 else
137 {
138 count[dim] = 0;
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]);
146
147 if (extent[dim] <= 0)
148 zero_sized = 1;
149 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
150 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
151 dim++;
152 }
153 }
154 }
155 else
156 {
157 for (n = 0; n < rrank; n++)
158 {
159 if (n == *along - 1)
160 {
161 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
162 }
163 else
164 {
165 count[dim] = 0;
166 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
167 if (extent[dim] <= 0)
168 zero_sized = 1;
169 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
170 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
171 dim++;
172 }
173 }
174 }
175
176 if (zero_sized)
177 return;
178
179 if (sstride[0] == 0)
180 sstride[0] = size;
181 }
182 sstride0 = sstride[0];
183 rstride0 = rstride[0];
184 rptr = ret->base_addr;
185 sptr = source->base_addr;
186
187 while (sptr)
188 {
189 /* Spread this element. */
190 dest = rptr;
191 for (n = 0; n < ncopies; n++)
192 {
193 memcpy (dest, sptr, size);
194 dest += rdelta;
195 }
196 /* Advance to the next element. */
197 sptr += sstride0;
198 rptr += rstride0;
199 count[0]++;
200 n = 0;
201 while (count[n] == extent[n])
202 {
203 /* When we get to the end of a dimension, reset it and increment
204 the next dimension. */
205 count[n] = 0;
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];
210 n++;
211 if (n >= srank)
212 {
213 /* Break out of the loop. */
214 sptr = NULL;
215 break;
216 }
217 else
218 {
219 count[n]++;
220 sptr += sstride[n];
221 rptr += rstride[n];
222 }
223 }
224 }
225 }
226
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. */
229
230 static void
231 spread_internal_scalar (gfc_array_char *ret, const char *source,
232 const index_type *along, const index_type *pncopies)
233 {
234 int n;
235 int ncopies = *pncopies;
236 char * dest;
237 size_t size;
238
239 size = GFC_DESCRIPTOR_SIZE(ret);
240
241 if (GFC_DESCRIPTOR_RANK (ret) != 1)
242 runtime_error ("incorrect destination rank in spread()");
243
244 if (*along > 1)
245 runtime_error ("dim outside of rank in spread()");
246
247 if (ret->base_addr == NULL)
248 {
249 ret->base_addr = xmallocarray (ncopies, size);
250 ret->offset = 0;
251 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
252 }
253 else
254 {
255 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
256 / GFC_DESCRIPTOR_STRIDE(ret,0))
257 runtime_error ("dim too large in spread()");
258 }
259
260 for (n = 0; n < ncopies; n++)
261 {
262 dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
263 memcpy (dest , source, size);
264 }
265 }
266
267 extern void spread (gfc_array_char *, const gfc_array_char *,
268 const index_type *, const index_type *);
269 export_proto(spread);
270
271 void
272 spread (gfc_array_char *ret, const gfc_array_char *source,
273 const index_type *along, const index_type *pncopies)
274 {
275 index_type type_size;
276
277 type_size = GFC_DTYPE_TYPE_SIZE(ret);
278 switch(type_size)
279 {
280 case GFC_DTYPE_LOGICAL_1:
281 case GFC_DTYPE_INTEGER_1:
282 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
283 *along, *pncopies);
284 return;
285
286 case GFC_DTYPE_LOGICAL_2:
287 case GFC_DTYPE_INTEGER_2:
288 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
289 *along, *pncopies);
290 return;
291
292 case GFC_DTYPE_LOGICAL_4:
293 case GFC_DTYPE_INTEGER_4:
294 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
295 *along, *pncopies);
296 return;
297
298 case GFC_DTYPE_LOGICAL_8:
299 case GFC_DTYPE_INTEGER_8:
300 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
301 *along, *pncopies);
302 return;
303
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,
308 *along, *pncopies);
309 return;
310 #endif
311
312 case GFC_DTYPE_REAL_4:
313 spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
314 *along, *pncopies);
315 return;
316
317 case GFC_DTYPE_REAL_8:
318 spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
319 *along, *pncopies);
320 return;
321
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,
332 *along, *pncopies);
333 return;
334 # endif
335
336 # ifdef GFC_HAVE_REAL_16
337 case GFC_DTYPE_REAL_16:
338 spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
339 *along, *pncopies);
340 return;
341 # endif
342 #endif
343
344 case GFC_DTYPE_COMPLEX_4:
345 spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
346 *along, *pncopies);
347 return;
348
349 case GFC_DTYPE_COMPLEX_8:
350 spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
351 *along, *pncopies);
352 return;
353
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,
364 *along, *pncopies);
365 return;
366 # endif
367
368 # ifdef GFC_HAVE_COMPLEX_16
369 case GFC_DTYPE_COMPLEX_16:
370 spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
371 *along, *pncopies);
372 return;
373 # endif
374 #endif
375
376 }
377
378 switch (GFC_DESCRIPTOR_SIZE (ret))
379 {
380 case 1:
381 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
382 *along, *pncopies);
383 return;
384
385 case 2:
386 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
387 break;
388 else
389 {
390 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
391 *along, *pncopies);
392 return;
393 }
394
395 case 4:
396 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
397 break;
398 else
399 {
400 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
401 *along, *pncopies);
402 return;
403 }
404
405 case 8:
406 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
407 break;
408 else
409 {
410 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
411 *along, *pncopies);
412 return;
413 }
414 #ifdef HAVE_GFC_INTEGER_16
415 case 16:
416 if (GFC_UNALIGNED_16(ret->base_addr)
417 || GFC_UNALIGNED_16(source->base_addr))
418 break;
419 else
420 {
421 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
422 *along, *pncopies);
423 return;
424 }
425 #endif
426
427 }
428
429 spread_internal (ret, source, along, pncopies);
430 }
431
432
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);
437
438 void
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)))
444 {
445 spread_internal (ret, source, along, pncopies);
446 }
447
448
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);
453
454 void
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)))
460 {
461 spread_internal (ret, source, along, pncopies);
462 }
463
464
465 /* The following are the prototypes for the versions of spread with a
466 scalar source. */
467
468 extern void spread_scalar (gfc_array_char *, const char *,
469 const index_type *, const index_type *);
470 export_proto(spread_scalar);
471
472 void
473 spread_scalar (gfc_array_char *ret, const char *source,
474 const index_type *along, const index_type *pncopies)
475 {
476 index_type type_size;
477
478 if (GFC_DTYPE_IS_UNSET(ret))
479 runtime_error ("return array missing descriptor in spread()");
480
481 type_size = GFC_DTYPE_TYPE_SIZE(ret);
482 switch(type_size)
483 {
484 case GFC_DTYPE_LOGICAL_1:
485 case GFC_DTYPE_INTEGER_1:
486 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
487 *along, *pncopies);
488 return;
489
490 case GFC_DTYPE_LOGICAL_2:
491 case GFC_DTYPE_INTEGER_2:
492 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
493 *along, *pncopies);
494 return;
495
496 case GFC_DTYPE_LOGICAL_4:
497 case GFC_DTYPE_INTEGER_4:
498 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
499 *along, *pncopies);
500 return;
501
502 case GFC_DTYPE_LOGICAL_8:
503 case GFC_DTYPE_INTEGER_8:
504 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
505 *along, *pncopies);
506 return;
507
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,
512 *along, *pncopies);
513 return;
514 #endif
515
516 case GFC_DTYPE_REAL_4:
517 spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
518 *along, *pncopies);
519 return;
520
521 case GFC_DTYPE_REAL_8:
522 spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
523 *along, *pncopies);
524 return;
525
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,
536 *along, *pncopies);
537 return;
538 # endif
539
540 # ifdef HAVE_GFC_REAL_16
541 case GFC_DTYPE_REAL_16:
542 spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
543 *along, *pncopies);
544 return;
545 # endif
546 #endif
547
548 case GFC_DTYPE_COMPLEX_4:
549 spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
550 *along, *pncopies);
551 return;
552
553 case GFC_DTYPE_COMPLEX_8:
554 spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
555 *along, *pncopies);
556 return;
557
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,
568 *along, *pncopies);
569 return;
570 # endif
571
572 # ifdef HAVE_GFC_COMPLEX_16
573 case GFC_DTYPE_COMPLEX_16:
574 spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
575 *along, *pncopies);
576 return;
577 # endif
578 #endif
579
580 }
581
582 switch (GFC_DESCRIPTOR_SIZE(ret))
583 {
584 case 1:
585 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
586 *along, *pncopies);
587 return;
588
589 case 2:
590 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
591 break;
592 else
593 {
594 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
595 *along, *pncopies);
596 return;
597 }
598
599 case 4:
600 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
601 break;
602 else
603 {
604 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
605 *along, *pncopies);
606 return;
607 }
608
609 case 8:
610 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
611 break;
612 else
613 {
614 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
615 *along, *pncopies);
616 return;
617 }
618 #ifdef HAVE_GFC_INTEGER_16
619 case 16:
620 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
621 break;
622 else
623 {
624 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
625 *along, *pncopies);
626 return;
627 }
628 #endif
629 default:
630 break;
631 }
632
633 spread_internal_scalar (ret, source, along, pncopies);
634 }
635
636
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);
641
642 void
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)))
648 {
649 if (GFC_DTYPE_IS_UNSET(ret))
650 runtime_error ("return array missing descriptor in spread()");
651 spread_internal_scalar (ret, source, along, pncopies);
652 }
653
654
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);
659
660 void
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)))
666 {
667 if (GFC_DTYPE_IS_UNSET(ret))
668 runtime_error ("return array missing descriptor in spread()");
669 spread_internal_scalar (ret, source, along, pncopies);
670
671 }
672