1/* Generic implementation of the SPREAD intrinsic
2   Copyright (C) 2002-2020 Free Software Foundation, Inc.
3   Contributed by Paul Brook <paul@nowt.org>
4
5This file is part of the GNU Fortran runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Ligbfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see 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
29static void
30spread_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
228static void
229spread_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
265extern void spread (gfc_array_char *, const gfc_array_char *,
266		    const index_type *, const index_type *);
267export_proto(spread);
268
269void
270spread (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
431extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
432			 const gfc_array_char *, const index_type *,
433			 const index_type *, GFC_INTEGER_4);
434export_proto(spread_char);
435
436void
437spread_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
447extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
448			  const gfc_array_char *, const index_type *,
449			  const index_type *, GFC_INTEGER_4);
450export_proto(spread_char4);
451
452void
453spread_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
466extern void spread_scalar (gfc_array_char *, const char *,
467			   const index_type *, const index_type *);
468export_proto(spread_scalar);
469
470void
471spread_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
635extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
636				const char *, const index_type *,
637				const index_type *, GFC_INTEGER_4);
638export_proto(spread_char_scalar);
639
640void
641spread_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
653extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
654				 const char *, const index_type *,
655				 const index_type *, GFC_INTEGER_4);
656export_proto(spread_char4_scalar);
657
658void
659spread_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