1 /* Generic implementation of the SPREAD intrinsic
2 Copyright 2002, 2005, 2006, 2007, 2009 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
,
36 /* r.* indicates the return array. */
37 index_type rstride
[GFC_MAX_DIMENSIONS
];
39 index_type rdelta
= 0;
44 /* s.* indicates the source array. */
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
50 index_type count
[GFC_MAX_DIMENSIONS
];
51 index_type extent
[GFC_MAX_DIMENSIONS
];
56 srank
= GFC_DESCRIPTOR_RANK(source
);
59 if (rrank
> GFC_MAX_DIMENSIONS
)
60 runtime_error ("return rank too large in spread()");
63 runtime_error ("dim outside of rank in spread()");
67 if (ret
->data
== NULL
)
69 /* The front end has signalled that we need to populate the
70 return array descriptor. */
71 ret
->dtype
= (source
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rrank
;
74 for (n
= 0; n
< rrank
; n
++)
76 ret
->dim
[n
].stride
= rs
;
77 ret
->dim
[n
].lbound
= 0;
80 ret
->dim
[n
].ubound
= ncopies
- 1;
87 extent
[dim
] = source
->dim
[dim
].ubound
+ 1
88 - source
->dim
[dim
].lbound
;
89 sstride
[dim
] = source
->dim
[dim
].stride
* size
;
90 rstride
[dim
] = rs
* size
;
92 ret
->dim
[n
].ubound
= extent
[dim
]-1;
99 ret
->data
= internal_malloc_size (rs
* size
);
102 ret
->data
= internal_malloc_size (1);
113 if (GFC_DESCRIPTOR_RANK(ret
) != rrank
)
114 runtime_error ("rank mismatch in spread()");
116 if (compile_options
.bounds_check
)
118 for (n
= 0; n
< rrank
; n
++)
120 index_type ret_extent
;
122 ret_extent
= ret
->dim
[n
].ubound
+ 1 - ret
->dim
[n
].lbound
;
125 rdelta
= ret
->dim
[n
].stride
* size
;
127 if (ret_extent
!= ncopies
)
128 runtime_error("Incorrect extent in return value of SPREAD"
129 " intrinsic in dimension %ld: is %ld,"
130 " should be %ld", (long int) n
+1,
131 (long int) ret_extent
, (long int) ncopies
);
136 extent
[dim
] = source
->dim
[dim
].ubound
+ 1
137 - source
->dim
[dim
].lbound
;
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
]);
145 if (extent
[dim
] <= 0)
147 sstride
[dim
] = source
->dim
[dim
].stride
* size
;
148 rstride
[dim
] = ret
->dim
[n
].stride
* size
;
155 for (n
= 0; n
< rrank
; n
++)
159 rdelta
= ret
->dim
[n
].stride
* size
;
164 extent
[dim
] = source
->dim
[dim
].ubound
+ 1
165 - source
->dim
[dim
].lbound
;
166 if (extent
[dim
] <= 0)
168 sstride
[dim
] = source
->dim
[dim
].stride
* size
;
169 rstride
[dim
] = ret
->dim
[n
].stride
* size
;
181 sstride0
= sstride
[0];
182 rstride0
= rstride
[0];
188 /* Spread this element. */
190 for (n
= 0; n
< ncopies
; n
++)
192 memcpy (dest
, sptr
, size
);
195 /* Advance to the next element. */
200 while (count
[n
] == extent
[n
])
202 /* When we get to the end of a dimension, reset it and increment
203 the next dimension. */
205 /* We could precalculate these products, but this is a less
206 frequently used path so probably not worth it. */
207 sptr
-= sstride
[n
] * extent
[n
];
208 rptr
-= rstride
[n
] * extent
[n
];
212 /* Break out of the loop. */
226 /* This version of spread_internal treats the special case of a scalar
227 source. This is much simpler than the more general case above. */
230 spread_internal_scalar (gfc_array_char
*ret
, const char *source
,
231 const index_type
*along
, const index_type
*pncopies
,
235 int ncopies
= *pncopies
;
238 if (GFC_DESCRIPTOR_RANK (ret
) != 1)
239 runtime_error ("incorrect destination rank in spread()");
242 runtime_error ("dim outside of rank in spread()");
244 if (ret
->data
== NULL
)
246 ret
->data
= internal_malloc_size (ncopies
* size
);
248 ret
->dim
[0].stride
= 1;
249 ret
->dim
[0].lbound
= 0;
250 ret
->dim
[0].ubound
= ncopies
- 1;
254 if (ncopies
- 1 > (ret
->dim
[0].ubound
- ret
->dim
[0].lbound
)
255 / ret
->dim
[0].stride
)
256 runtime_error ("dim too large in spread()");
259 for (n
= 0; n
< ncopies
; n
++)
261 dest
= (char*)(ret
->data
+ n
*size
*ret
->dim
[0].stride
);
262 memcpy (dest
, source
, size
);
266 extern void spread (gfc_array_char
*, const gfc_array_char
*,
267 const index_type
*, const index_type
*);
268 export_proto(spread
);
271 spread (gfc_array_char
*ret
, const gfc_array_char
*source
,
272 const index_type
*along
, const index_type
*pncopies
)
274 index_type type_size
;
276 type_size
= GFC_DTYPE_TYPE_SIZE(ret
);
279 case GFC_DTYPE_DERIVED_1
:
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 #ifdef GFC_HAVE_REAL_10
323 case GFC_DTYPE_REAL_10
:
324 spread_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) source
,
329 #ifdef GFC_HAVE_REAL_16
330 case GFC_DTYPE_REAL_16
:
331 spread_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) source
,
336 case GFC_DTYPE_COMPLEX_4
:
337 spread_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) source
,
341 case GFC_DTYPE_COMPLEX_8
:
342 spread_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) source
,
346 #ifdef GFC_HAVE_COMPLEX_10
347 case GFC_DTYPE_COMPLEX_10
:
348 spread_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) source
,
353 #ifdef GFC_HAVE_COMPLEX_16
354 case GFC_DTYPE_COMPLEX_16
:
355 spread_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) source
,
360 case GFC_DTYPE_DERIVED_2
:
361 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(source
->data
))
365 spread_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) source
,
370 case GFC_DTYPE_DERIVED_4
:
371 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(source
->data
))
375 spread_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) source
,
380 case GFC_DTYPE_DERIVED_8
:
381 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(source
->data
))
385 spread_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) source
,
390 #ifdef HAVE_GFC_INTEGER_16
391 case GFC_DTYPE_DERIVED_16
:
392 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(source
->data
))
396 spread_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) source
,
403 spread_internal (ret
, source
, along
, pncopies
, GFC_DESCRIPTOR_SIZE (source
));
407 extern void spread_char (gfc_array_char
*, GFC_INTEGER_4
,
408 const gfc_array_char
*, const index_type
*,
409 const index_type
*, GFC_INTEGER_4
);
410 export_proto(spread_char
);
413 spread_char (gfc_array_char
*ret
,
414 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
415 const gfc_array_char
*source
, const index_type
*along
,
416 const index_type
*pncopies
, GFC_INTEGER_4 source_length
)
418 spread_internal (ret
, source
, along
, pncopies
, source_length
);
422 extern void spread_char4 (gfc_array_char
*, GFC_INTEGER_4
,
423 const gfc_array_char
*, const index_type
*,
424 const index_type
*, GFC_INTEGER_4
);
425 export_proto(spread_char4
);
428 spread_char4 (gfc_array_char
*ret
,
429 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
430 const gfc_array_char
*source
, const index_type
*along
,
431 const index_type
*pncopies
, GFC_INTEGER_4 source_length
)
433 spread_internal (ret
, source
, along
, pncopies
,
434 source_length
* sizeof (gfc_char4_t
));
438 /* The following are the prototypes for the versions of spread with a
441 extern void spread_scalar (gfc_array_char
*, const char *,
442 const index_type
*, const index_type
*);
443 export_proto(spread_scalar
);
446 spread_scalar (gfc_array_char
*ret
, const char *source
,
447 const index_type
*along
, const index_type
*pncopies
)
449 index_type type_size
;
452 runtime_error ("return array missing descriptor in spread()");
454 type_size
= GFC_DTYPE_TYPE_SIZE(ret
);
457 case GFC_DTYPE_DERIVED_1
:
458 case GFC_DTYPE_LOGICAL_1
:
459 case GFC_DTYPE_INTEGER_1
:
460 spread_scalar_i1 ((gfc_array_i1
*) ret
, (GFC_INTEGER_1
*) source
,
464 case GFC_DTYPE_LOGICAL_2
:
465 case GFC_DTYPE_INTEGER_2
:
466 spread_scalar_i2 ((gfc_array_i2
*) ret
, (GFC_INTEGER_2
*) source
,
470 case GFC_DTYPE_LOGICAL_4
:
471 case GFC_DTYPE_INTEGER_4
:
472 spread_scalar_i4 ((gfc_array_i4
*) ret
, (GFC_INTEGER_4
*) source
,
476 case GFC_DTYPE_LOGICAL_8
:
477 case GFC_DTYPE_INTEGER_8
:
478 spread_scalar_i8 ((gfc_array_i8
*) ret
, (GFC_INTEGER_8
*) source
,
482 #ifdef HAVE_GFC_INTEGER_16
483 case GFC_DTYPE_LOGICAL_16
:
484 case GFC_DTYPE_INTEGER_16
:
485 spread_scalar_i16 ((gfc_array_i16
*) ret
, (GFC_INTEGER_16
*) source
,
490 case GFC_DTYPE_REAL_4
:
491 spread_scalar_r4 ((gfc_array_r4
*) ret
, (GFC_REAL_4
*) source
,
495 case GFC_DTYPE_REAL_8
:
496 spread_scalar_r8 ((gfc_array_r8
*) ret
, (GFC_REAL_8
*) source
,
500 #ifdef HAVE_GFC_REAL_10
501 case GFC_DTYPE_REAL_10
:
502 spread_scalar_r10 ((gfc_array_r10
*) ret
, (GFC_REAL_10
*) source
,
507 #ifdef HAVE_GFC_REAL_16
508 case GFC_DTYPE_REAL_16
:
509 spread_scalar_r16 ((gfc_array_r16
*) ret
, (GFC_REAL_16
*) source
,
514 case GFC_DTYPE_COMPLEX_4
:
515 spread_scalar_c4 ((gfc_array_c4
*) ret
, (GFC_COMPLEX_4
*) source
,
519 case GFC_DTYPE_COMPLEX_8
:
520 spread_scalar_c8 ((gfc_array_c8
*) ret
, (GFC_COMPLEX_8
*) source
,
524 #ifdef HAVE_GFC_COMPLEX_10
525 case GFC_DTYPE_COMPLEX_10
:
526 spread_scalar_c10 ((gfc_array_c10
*) ret
, (GFC_COMPLEX_10
*) source
,
531 #ifdef HAVE_GFC_COMPLEX_16
532 case GFC_DTYPE_COMPLEX_16
:
533 spread_scalar_c16 ((gfc_array_c16
*) ret
, (GFC_COMPLEX_16
*) source
,
538 case GFC_DTYPE_DERIVED_2
:
539 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(source
))
543 spread_scalar_i2 ((gfc_array_i2
*) ret
, (GFC_INTEGER_2
*) source
,
548 case GFC_DTYPE_DERIVED_4
:
549 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(source
))
553 spread_scalar_i4 ((gfc_array_i4
*) ret
, (GFC_INTEGER_4
*) source
,
558 case GFC_DTYPE_DERIVED_8
:
559 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(source
))
563 spread_scalar_i8 ((gfc_array_i8
*) ret
, (GFC_INTEGER_8
*) source
,
567 #ifdef HAVE_GFC_INTEGER_16
568 case GFC_DTYPE_DERIVED_16
:
569 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(source
))
573 spread_scalar_i16 ((gfc_array_i16
*) ret
, (GFC_INTEGER_16
*) source
,
580 spread_internal_scalar (ret
, source
, along
, pncopies
, GFC_DESCRIPTOR_SIZE (ret
));
584 extern void spread_char_scalar (gfc_array_char
*, GFC_INTEGER_4
,
585 const char *, const index_type
*,
586 const index_type
*, GFC_INTEGER_4
);
587 export_proto(spread_char_scalar
);
590 spread_char_scalar (gfc_array_char
*ret
,
591 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
592 const char *source
, const index_type
*along
,
593 const index_type
*pncopies
, GFC_INTEGER_4 source_length
)
596 runtime_error ("return array missing descriptor in spread()");
597 spread_internal_scalar (ret
, source
, along
, pncopies
, source_length
);
601 extern void spread_char4_scalar (gfc_array_char
*, GFC_INTEGER_4
,
602 const char *, const index_type
*,
603 const index_type
*, GFC_INTEGER_4
);
604 export_proto(spread_char4_scalar
);
607 spread_char4_scalar (gfc_array_char
*ret
,
608 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
609 const char *source
, const index_type
*along
,
610 const index_type
*pncopies
, GFC_INTEGER_4 source_length
)
613 runtime_error ("return array missing descriptor in spread()");
614 spread_internal_scalar (ret
, source
, along
, pncopies
,
615 source_length
* sizeof (gfc_char4_t
));