1 /* Generic implementation of the SPREAD intrinsic
2 Copyright (C) 2002-2019 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
spread_internal(gfc_array_char * ret,const gfc_array_char * source,const index_type * along,const index_type * pncopies)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 rrank = srank + 1;
59 if (rrank > GFC_MAX_DIMENSIONS)
60 runtime_error ("return rank too large in spread()");
61
62 if (*along > rrank)
63 runtime_error ("dim outside of rank in spread()");
64
65 ncopies = *pncopies;
66
67 if (ret->base_addr == NULL)
68 {
69 /* The front end has signalled that we need to populate the
70 return array descriptor. */
71
72 size_t ub, stride;
73
74 ret->dtype.rank = rrank;
75
76 dim = 0;
77 rs = 1;
78 for (n = 0; n < rrank; n++)
79 {
80 stride = rs;
81 if (n == *along - 1)
82 {
83 ub = ncopies - 1;
84 rdelta = rs * size;
85 rs *= ncopies;
86 }
87 else
88 {
89 count[dim] = 0;
90 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
91 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
92 rstride[dim] = rs * size;
93
94 ub = extent[dim]-1;
95 rs *= extent[dim];
96 dim++;
97 }
98
99 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
100 }
101 ret->offset = 0;
102 ret->base_addr = xmallocarray (rs, size);
103
104 if (rs <= 0)
105 return;
106 }
107 else
108 {
109 int zero_sized;
110
111 zero_sized = 0;
112
113 dim = 0;
114 if (GFC_DESCRIPTOR_RANK(ret) != rrank)
115 runtime_error ("rank mismatch in spread()");
116
117 if (compile_options.bounds_check)
118 {
119 for (n = 0; n < rrank; n++)
120 {
121 index_type ret_extent;
122
123 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
124 if (n == *along - 1)
125 {
126 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
127
128 if (ret_extent != ncopies)
129 runtime_error("Incorrect extent in return value of SPREAD"
130 " intrinsic in dimension %ld: is %ld,"
131 " should be %ld", (long int) n+1,
132 (long int) ret_extent, (long int) ncopies);
133 }
134 else
135 {
136 count[dim] = 0;
137 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
138 if (ret_extent != extent[dim])
139 runtime_error("Incorrect extent in return value of SPREAD"
140 " intrinsic in dimension %ld: is %ld,"
141 " should be %ld", (long int) n+1,
142 (long int) ret_extent,
143 (long int) extent[dim]);
144
145 if (extent[dim] <= 0)
146 zero_sized = 1;
147 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
148 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
149 dim++;
150 }
151 }
152 }
153 else
154 {
155 for (n = 0; n < rrank; n++)
156 {
157 if (n == *along - 1)
158 {
159 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
160 }
161 else
162 {
163 count[dim] = 0;
164 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
165 if (extent[dim] <= 0)
166 zero_sized = 1;
167 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
168 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
169 dim++;
170 }
171 }
172 }
173
174 if (zero_sized)
175 return;
176
177 if (sstride[0] == 0)
178 sstride[0] = size;
179 }
180 sstride0 = sstride[0];
181 rstride0 = rstride[0];
182 rptr = ret->base_addr;
183 sptr = source->base_addr;
184
185 while (sptr)
186 {
187 /* Spread this element. */
188 dest = rptr;
189 for (n = 0; n < ncopies; n++)
190 {
191 memcpy (dest, sptr, size);
192 dest += rdelta;
193 }
194 /* Advance to the next element. */
195 sptr += sstride0;
196 rptr += rstride0;
197 count[0]++;
198 n = 0;
199 while (count[n] == extent[n])
200 {
201 /* When we get to the end of a dimension, reset it and increment
202 the next dimension. */
203 count[n] = 0;
204 /* We could precalculate these products, but this is a less
205 frequently used path so probably not worth it. */
206 sptr -= sstride[n] * extent[n];
207 rptr -= rstride[n] * extent[n];
208 n++;
209 if (n >= srank)
210 {
211 /* Break out of the loop. */
212 sptr = NULL;
213 break;
214 }
215 else
216 {
217 count[n]++;
218 sptr += sstride[n];
219 rptr += rstride[n];
220 }
221 }
222 }
223 }
224
225 /* This version of spread_internal treats the special case of a scalar
226 source. This is much simpler than the more general case above. */
227
228 static void
spread_internal_scalar(gfc_array_char * ret,const char * source,const index_type * along,const index_type * pncopies)229 spread_internal_scalar (gfc_array_char *ret, const char *source,
230 const index_type *along, const index_type *pncopies)
231 {
232 int n;
233 int ncopies = *pncopies;
234 char * dest;
235 size_t size;
236
237 size = GFC_DESCRIPTOR_SIZE(ret);
238
239 if (GFC_DESCRIPTOR_RANK (ret) != 1)
240 runtime_error ("incorrect destination rank in spread()");
241
242 if (*along > 1)
243 runtime_error ("dim outside of rank in spread()");
244
245 if (ret->base_addr == NULL)
246 {
247 ret->base_addr = xmallocarray (ncopies, size);
248 ret->offset = 0;
249 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
250 }
251 else
252 {
253 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
254 / GFC_DESCRIPTOR_STRIDE(ret,0))
255 runtime_error ("dim too large in spread()");
256 }
257
258 for (n = 0; n < ncopies; n++)
259 {
260 dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
261 memcpy (dest , source, size);
262 }
263 }
264
265 extern void spread (gfc_array_char *, const gfc_array_char *,
266 const index_type *, const index_type *);
267 export_proto(spread);
268
269 void
spread(gfc_array_char * ret,const gfc_array_char * source,const index_type * along,const index_type * pncopies)270 spread (gfc_array_char *ret, const gfc_array_char *source,
271 const index_type *along, const index_type *pncopies)
272 {
273 index_type type_size;
274
275 type_size = GFC_DTYPE_TYPE_SIZE(ret);
276 switch(type_size)
277 {
278 case GFC_DTYPE_LOGICAL_1:
279 case GFC_DTYPE_INTEGER_1:
280 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
281 *along, *pncopies);
282 return;
283
284 case GFC_DTYPE_LOGICAL_2:
285 case GFC_DTYPE_INTEGER_2:
286 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
287 *along, *pncopies);
288 return;
289
290 case GFC_DTYPE_LOGICAL_4:
291 case GFC_DTYPE_INTEGER_4:
292 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
293 *along, *pncopies);
294 return;
295
296 case GFC_DTYPE_LOGICAL_8:
297 case GFC_DTYPE_INTEGER_8:
298 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
299 *along, *pncopies);
300 return;
301
302 #ifdef HAVE_GFC_INTEGER_16
303 case GFC_DTYPE_LOGICAL_16:
304 case GFC_DTYPE_INTEGER_16:
305 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
306 *along, *pncopies);
307 return;
308 #endif
309
310 case GFC_DTYPE_REAL_4:
311 spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
312 *along, *pncopies);
313 return;
314
315 case GFC_DTYPE_REAL_8:
316 spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
317 *along, *pncopies);
318 return;
319
320 /* FIXME: This here is a hack, which will have to be removed when
321 the array descriptor is reworked. Currently, we don't store the
322 kind value for the type, but only the size. Because on targets with
323 __float128, we have sizeof(logn double) == sizeof(__float128),
324 we cannot discriminate here and have to fall back to the generic
325 handling (which is suboptimal). */
326 #if !defined(GFC_REAL_16_IS_FLOAT128)
327 # ifdef GFC_HAVE_REAL_10
328 case GFC_DTYPE_REAL_10:
329 spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
330 *along, *pncopies);
331 return;
332 # endif
333
334 # ifdef GFC_HAVE_REAL_16
335 case GFC_DTYPE_REAL_16:
336 spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
337 *along, *pncopies);
338 return;
339 # endif
340 #endif
341
342 case GFC_DTYPE_COMPLEX_4:
343 spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
344 *along, *pncopies);
345 return;
346
347 case GFC_DTYPE_COMPLEX_8:
348 spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
349 *along, *pncopies);
350 return;
351
352 /* FIXME: This here is a hack, which will have to be removed when
353 the array descriptor is reworked. Currently, we don't store the
354 kind value for the type, but only the size. Because on targets with
355 __float128, we have sizeof(logn double) == sizeof(__float128),
356 we cannot discriminate here and have to fall back to the generic
357 handling (which is suboptimal). */
358 #if !defined(GFC_REAL_16_IS_FLOAT128)
359 # ifdef GFC_HAVE_COMPLEX_10
360 case GFC_DTYPE_COMPLEX_10:
361 spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
362 *along, *pncopies);
363 return;
364 # endif
365
366 # ifdef GFC_HAVE_COMPLEX_16
367 case GFC_DTYPE_COMPLEX_16:
368 spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
369 *along, *pncopies);
370 return;
371 # endif
372 #endif
373
374 }
375
376 switch (GFC_DESCRIPTOR_SIZE (ret))
377 {
378 case 1:
379 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
380 *along, *pncopies);
381 return;
382
383 case 2:
384 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
385 break;
386 else
387 {
388 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
389 *along, *pncopies);
390 return;
391 }
392
393 case 4:
394 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
395 break;
396 else
397 {
398 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
399 *along, *pncopies);
400 return;
401 }
402
403 case 8:
404 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
405 break;
406 else
407 {
408 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
409 *along, *pncopies);
410 return;
411 }
412 #ifdef HAVE_GFC_INTEGER_16
413 case 16:
414 if (GFC_UNALIGNED_16(ret->base_addr)
415 || GFC_UNALIGNED_16(source->base_addr))
416 break;
417 else
418 {
419 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
420 *along, *pncopies);
421 return;
422 }
423 #endif
424
425 }
426
427 spread_internal (ret, source, along, pncopies);
428 }
429
430
431 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
432 const gfc_array_char *, const index_type *,
433 const index_type *, GFC_INTEGER_4);
434 export_proto(spread_char);
435
436 void
spread_char(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const gfc_array_char * source,const index_type * along,const index_type * pncopies,GFC_INTEGER_4 source_length)437 spread_char (gfc_array_char *ret,
438 GFC_INTEGER_4 ret_length __attribute__((unused)),
439 const gfc_array_char *source, const index_type *along,
440 const index_type *pncopies,
441 GFC_INTEGER_4 source_length __attribute__((unused)))
442 {
443 spread_internal (ret, source, along, pncopies);
444 }
445
446
447 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
448 const gfc_array_char *, const index_type *,
449 const index_type *, GFC_INTEGER_4);
450 export_proto(spread_char4);
451
452 void
spread_char4(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const gfc_array_char * source,const index_type * along,const index_type * pncopies,GFC_INTEGER_4 source_length)453 spread_char4 (gfc_array_char *ret,
454 GFC_INTEGER_4 ret_length __attribute__((unused)),
455 const gfc_array_char *source, const index_type *along,
456 const index_type *pncopies,
457 GFC_INTEGER_4 source_length __attribute__((unused)))
458 {
459 spread_internal (ret, source, along, pncopies);
460 }
461
462
463 /* The following are the prototypes for the versions of spread with a
464 scalar source. */
465
466 extern void spread_scalar (gfc_array_char *, const char *,
467 const index_type *, const index_type *);
468 export_proto(spread_scalar);
469
470 void
spread_scalar(gfc_array_char * ret,const char * source,const index_type * along,const index_type * pncopies)471 spread_scalar (gfc_array_char *ret, const char *source,
472 const index_type *along, const index_type *pncopies)
473 {
474 index_type type_size;
475
476 if (GFC_DTYPE_IS_UNSET(ret))
477 runtime_error ("return array missing descriptor in spread()");
478
479 type_size = GFC_DTYPE_TYPE_SIZE(ret);
480 switch(type_size)
481 {
482 case GFC_DTYPE_LOGICAL_1:
483 case GFC_DTYPE_INTEGER_1:
484 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
485 *along, *pncopies);
486 return;
487
488 case GFC_DTYPE_LOGICAL_2:
489 case GFC_DTYPE_INTEGER_2:
490 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
491 *along, *pncopies);
492 return;
493
494 case GFC_DTYPE_LOGICAL_4:
495 case GFC_DTYPE_INTEGER_4:
496 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
497 *along, *pncopies);
498 return;
499
500 case GFC_DTYPE_LOGICAL_8:
501 case GFC_DTYPE_INTEGER_8:
502 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
503 *along, *pncopies);
504 return;
505
506 #ifdef HAVE_GFC_INTEGER_16
507 case GFC_DTYPE_LOGICAL_16:
508 case GFC_DTYPE_INTEGER_16:
509 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
510 *along, *pncopies);
511 return;
512 #endif
513
514 case GFC_DTYPE_REAL_4:
515 spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
516 *along, *pncopies);
517 return;
518
519 case GFC_DTYPE_REAL_8:
520 spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
521 *along, *pncopies);
522 return;
523
524 /* FIXME: This here is a hack, which will have to be removed when
525 the array descriptor is reworked. Currently, we don't store the
526 kind value for the type, but only the size. Because on targets with
527 __float128, we have sizeof(logn double) == sizeof(__float128),
528 we cannot discriminate here and have to fall back to the generic
529 handling (which is suboptimal). */
530 #if !defined(GFC_REAL_16_IS_FLOAT128)
531 # ifdef HAVE_GFC_REAL_10
532 case GFC_DTYPE_REAL_10:
533 spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
534 *along, *pncopies);
535 return;
536 # endif
537
538 # ifdef HAVE_GFC_REAL_16
539 case GFC_DTYPE_REAL_16:
540 spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
541 *along, *pncopies);
542 return;
543 # endif
544 #endif
545
546 case GFC_DTYPE_COMPLEX_4:
547 spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
548 *along, *pncopies);
549 return;
550
551 case GFC_DTYPE_COMPLEX_8:
552 spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
553 *along, *pncopies);
554 return;
555
556 /* FIXME: This here is a hack, which will have to be removed when
557 the array descriptor is reworked. Currently, we don't store the
558 kind value for the type, but only the size. Because on targets with
559 __float128, we have sizeof(logn double) == sizeof(__float128),
560 we cannot discriminate here and have to fall back to the generic
561 handling (which is suboptimal). */
562 #if !defined(GFC_REAL_16_IS_FLOAT128)
563 # ifdef HAVE_GFC_COMPLEX_10
564 case GFC_DTYPE_COMPLEX_10:
565 spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
566 *along, *pncopies);
567 return;
568 # endif
569
570 # ifdef HAVE_GFC_COMPLEX_16
571 case GFC_DTYPE_COMPLEX_16:
572 spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
573 *along, *pncopies);
574 return;
575 # endif
576 #endif
577
578 }
579
580 switch (GFC_DESCRIPTOR_SIZE(ret))
581 {
582 case 1:
583 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
584 *along, *pncopies);
585 return;
586
587 case 2:
588 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
589 break;
590 else
591 {
592 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
593 *along, *pncopies);
594 return;
595 }
596
597 case 4:
598 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
599 break;
600 else
601 {
602 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
603 *along, *pncopies);
604 return;
605 }
606
607 case 8:
608 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
609 break;
610 else
611 {
612 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
613 *along, *pncopies);
614 return;
615 }
616 #ifdef HAVE_GFC_INTEGER_16
617 case 16:
618 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
619 break;
620 else
621 {
622 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
623 *along, *pncopies);
624 return;
625 }
626 #endif
627 default:
628 break;
629 }
630
631 spread_internal_scalar (ret, source, along, pncopies);
632 }
633
634
635 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
636 const char *, const index_type *,
637 const index_type *, GFC_INTEGER_4);
638 export_proto(spread_char_scalar);
639
640 void
spread_char_scalar(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const char * source,const index_type * along,const index_type * pncopies,GFC_INTEGER_4 source_length)641 spread_char_scalar (gfc_array_char *ret,
642 GFC_INTEGER_4 ret_length __attribute__((unused)),
643 const char *source, const index_type *along,
644 const index_type *pncopies,
645 GFC_INTEGER_4 source_length __attribute__((unused)))
646 {
647 if (GFC_DTYPE_IS_UNSET(ret))
648 runtime_error ("return array missing descriptor in spread()");
649 spread_internal_scalar (ret, source, along, pncopies);
650 }
651
652
653 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
654 const char *, const index_type *,
655 const index_type *, GFC_INTEGER_4);
656 export_proto(spread_char4_scalar);
657
658 void
spread_char4_scalar(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const char * source,const index_type * along,const index_type * pncopies,GFC_INTEGER_4 source_length)659 spread_char4_scalar (gfc_array_char *ret,
660 GFC_INTEGER_4 ret_length __attribute__((unused)),
661 const char *source, const index_type *along,
662 const index_type *pncopies,
663 GFC_INTEGER_4 source_length __attribute__((unused)))
664 {
665 if (GFC_DTYPE_IS_UNSET(ret))
666 runtime_error ("return array missing descriptor in spread()");
667 spread_internal_scalar (ret, source, along, pncopies);
668
669 }
670
671