1 /* Generic implementation of the UNPACK intrinsic
2 Copyright (C) 2002-2015 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"
31 /* All the bounds checking for unpack in one function. If field is NULL,
32 we don't check it, for the unpack0 functions. */
35 unpack_bounds (gfc_array_char
*ret
, const gfc_array_char
*vector
,
36 const gfc_array_l1
*mask
, const gfc_array_char
*field
)
38 index_type vec_size
, mask_count
;
39 vec_size
= size0 ((array_t
*) vector
);
40 mask_count
= count_0 (mask
);
41 if (vec_size
< mask_count
)
42 runtime_error ("Incorrect size of return value in UNPACK"
43 " intrinsic: should be at least %ld, is"
44 " %ld", (long int) mask_count
,
48 bounds_equal_extents ((array_t
*) field
, (array_t
*) mask
,
51 if (ret
->base_addr
!= NULL
)
52 bounds_equal_extents ((array_t
*) ret
, (array_t
*) mask
,
53 "return value", "UNPACK");
58 unpack_internal (gfc_array_char
*ret
, const gfc_array_char
*vector
,
59 const gfc_array_l1
*mask
, const gfc_array_char
*field
,
62 /* r.* indicates the return array. */
63 index_type rstride
[GFC_MAX_DIMENSIONS
];
67 /* v.* indicates the vector array. */
70 /* f.* indicates the field array. */
71 index_type fstride
[GFC_MAX_DIMENSIONS
];
74 /* m.* indicates the mask array. */
75 index_type mstride
[GFC_MAX_DIMENSIONS
];
77 const GFC_LOGICAL_1
*mptr
;
79 index_type count
[GFC_MAX_DIMENSIONS
];
80 index_type extent
[GFC_MAX_DIMENSIONS
];
89 mptr
= mask
->base_addr
;
91 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
92 and using shifting to address size and endian issues. */
94 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
96 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
97 #ifdef HAVE_GFC_LOGICAL_16
102 /* Don't convert a NULL pointer as we use test for NULL below. */
104 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
107 runtime_error ("Funny sized logical array");
109 if (ret
->base_addr
== NULL
)
111 /* The front end has signalled that we need to populate the
112 return array descriptor. */
113 dim
= GFC_DESCRIPTOR_RANK (mask
);
115 for (n
= 0; n
< dim
; n
++)
118 GFC_DIMENSION_SET(ret
->dim
[n
], 0,
119 GFC_DESCRIPTOR_EXTENT(mask
,n
) - 1, rs
);
120 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
121 empty
= empty
|| extent
[n
] <= 0;
122 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
, n
);
123 fstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(field
, n
);
124 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
);
128 ret
->base_addr
= xmallocarray (rs
, size
);
132 dim
= GFC_DESCRIPTOR_RANK (ret
);
133 for (n
= 0; n
< dim
; n
++)
136 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
137 empty
= empty
|| extent
[n
] <= 0;
138 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
, n
);
139 fstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(field
, n
);
140 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
);
147 /* This assert makes sure GCC knows we can access *stride[0] later. */
150 vstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(vector
,0);
151 rstride0
= rstride
[0];
152 fstride0
= fstride
[0];
153 mstride0
= mstride
[0];
154 rptr
= ret
->base_addr
;
155 fptr
= field
->base_addr
;
156 vptr
= vector
->base_addr
;
163 memcpy (rptr
, vptr
, size
);
169 memcpy (rptr
, fptr
, size
);
171 /* Advance to the next element. */
177 while (count
[n
] == extent
[n
])
179 /* When we get to the end of a dimension, reset it and increment
180 the next dimension. */
182 /* We could precalculate these products, but this is a less
183 frequently used path so probably not worth it. */
184 rptr
-= rstride
[n
] * extent
[n
];
185 fptr
-= fstride
[n
] * extent
[n
];
186 mptr
-= mstride
[n
] * extent
[n
];
190 /* Break out of the loop. */
205 extern void unpack1 (gfc_array_char
*, const gfc_array_char
*,
206 const gfc_array_l1
*, const gfc_array_char
*);
207 export_proto(unpack1
);
210 unpack1 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
211 const gfc_array_l1
*mask
, const gfc_array_char
*field
)
213 index_type type_size
;
216 if (unlikely(compile_options
.bounds_check
))
217 unpack_bounds (ret
, vector
, mask
, field
);
219 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
220 size
= GFC_DESCRIPTOR_SIZE (vector
);
224 case GFC_DTYPE_LOGICAL_1
:
225 case GFC_DTYPE_INTEGER_1
:
226 case GFC_DTYPE_DERIVED_1
:
227 unpack1_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
228 mask
, (gfc_array_i1
*) field
);
231 case GFC_DTYPE_LOGICAL_2
:
232 case GFC_DTYPE_INTEGER_2
:
233 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
234 mask
, (gfc_array_i2
*) field
);
237 case GFC_DTYPE_LOGICAL_4
:
238 case GFC_DTYPE_INTEGER_4
:
239 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
240 mask
, (gfc_array_i4
*) field
);
243 case GFC_DTYPE_LOGICAL_8
:
244 case GFC_DTYPE_INTEGER_8
:
245 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
246 mask
, (gfc_array_i8
*) field
);
249 #ifdef HAVE_GFC_INTEGER_16
250 case GFC_DTYPE_LOGICAL_16
:
251 case GFC_DTYPE_INTEGER_16
:
252 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
253 mask
, (gfc_array_i16
*) field
);
257 case GFC_DTYPE_REAL_4
:
258 unpack1_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
259 mask
, (gfc_array_r4
*) field
);
262 case GFC_DTYPE_REAL_8
:
263 unpack1_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
264 mask
, (gfc_array_r8
*) field
);
267 /* FIXME: This here is a hack, which will have to be removed when
268 the array descriptor is reworked. Currently, we don't store the
269 kind value for the type, but only the size. Because on targets with
270 __float128, we have sizeof(logn double) == sizeof(__float128),
271 we cannot discriminate here and have to fall back to the generic
272 handling (which is suboptimal). */
273 #if !defined(GFC_REAL_16_IS_FLOAT128)
274 # ifdef HAVE_GFC_REAL_10
275 case GFC_DTYPE_REAL_10
:
276 unpack1_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
277 mask
, (gfc_array_r10
*) field
);
281 # ifdef HAVE_GFC_REAL_16
282 case GFC_DTYPE_REAL_16
:
283 unpack1_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
284 mask
, (gfc_array_r16
*) field
);
289 case GFC_DTYPE_COMPLEX_4
:
290 unpack1_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
291 mask
, (gfc_array_c4
*) field
);
294 case GFC_DTYPE_COMPLEX_8
:
295 unpack1_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
296 mask
, (gfc_array_c8
*) field
);
299 /* FIXME: This here is a hack, which will have to be removed when
300 the array descriptor is reworked. Currently, we don't store the
301 kind value for the type, but only the size. Because on targets with
302 __float128, we have sizeof(logn double) == sizeof(__float128),
303 we cannot discriminate here and have to fall back to the generic
304 handling (which is suboptimal). */
305 #if !defined(GFC_REAL_16_IS_FLOAT128)
306 # ifdef HAVE_GFC_COMPLEX_10
307 case GFC_DTYPE_COMPLEX_10
:
308 unpack1_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
309 mask
, (gfc_array_c10
*) field
);
313 # ifdef HAVE_GFC_COMPLEX_16
314 case GFC_DTYPE_COMPLEX_16
:
315 unpack1_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
316 mask
, (gfc_array_c16
*) field
);
321 case GFC_DTYPE_DERIVED_2
:
322 if (GFC_UNALIGNED_2(ret
->base_addr
) || GFC_UNALIGNED_2(vector
->base_addr
)
323 || GFC_UNALIGNED_2(field
->base_addr
))
327 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
328 mask
, (gfc_array_i2
*) field
);
332 case GFC_DTYPE_DERIVED_4
:
333 if (GFC_UNALIGNED_4(ret
->base_addr
) || GFC_UNALIGNED_4(vector
->base_addr
)
334 || GFC_UNALIGNED_4(field
->base_addr
))
338 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
339 mask
, (gfc_array_i4
*) field
);
343 case GFC_DTYPE_DERIVED_8
:
344 if (GFC_UNALIGNED_8(ret
->base_addr
) || GFC_UNALIGNED_8(vector
->base_addr
)
345 || GFC_UNALIGNED_8(field
->base_addr
))
349 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
350 mask
, (gfc_array_i8
*) field
);
354 #ifdef HAVE_GFC_INTEGER_16
355 case GFC_DTYPE_DERIVED_16
:
356 if (GFC_UNALIGNED_16(ret
->base_addr
)
357 || GFC_UNALIGNED_16(vector
->base_addr
)
358 || GFC_UNALIGNED_16(field
->base_addr
))
362 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
363 mask
, (gfc_array_i16
*) field
);
369 unpack_internal (ret
, vector
, mask
, field
, size
);
373 extern void unpack1_char (gfc_array_char
*, GFC_INTEGER_4
,
374 const gfc_array_char
*, const gfc_array_l1
*,
375 const gfc_array_char
*, GFC_INTEGER_4
,
377 export_proto(unpack1_char
);
380 unpack1_char (gfc_array_char
*ret
,
381 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
382 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
383 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
384 GFC_INTEGER_4 field_length
__attribute__((unused
)))
387 if (unlikely(compile_options
.bounds_check
))
388 unpack_bounds (ret
, vector
, mask
, field
);
390 unpack_internal (ret
, vector
, mask
, field
, vector_length
);
394 extern void unpack1_char4 (gfc_array_char
*, GFC_INTEGER_4
,
395 const gfc_array_char
*, const gfc_array_l1
*,
396 const gfc_array_char
*, GFC_INTEGER_4
,
398 export_proto(unpack1_char4
);
401 unpack1_char4 (gfc_array_char
*ret
,
402 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
403 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
404 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
405 GFC_INTEGER_4 field_length
__attribute__((unused
)))
408 if (unlikely(compile_options
.bounds_check
))
409 unpack_bounds (ret
, vector
, mask
, field
);
411 unpack_internal (ret
, vector
, mask
, field
,
412 vector_length
* sizeof (gfc_char4_t
));
416 extern void unpack0 (gfc_array_char
*, const gfc_array_char
*,
417 const gfc_array_l1
*, char *);
418 export_proto(unpack0
);
421 unpack0 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
422 const gfc_array_l1
*mask
, char *field
)
426 index_type type_size
;
428 if (unlikely(compile_options
.bounds_check
))
429 unpack_bounds (ret
, vector
, mask
, NULL
);
431 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
435 case GFC_DTYPE_LOGICAL_1
:
436 case GFC_DTYPE_INTEGER_1
:
437 case GFC_DTYPE_DERIVED_1
:
438 unpack0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
439 mask
, (GFC_INTEGER_1
*) field
);
442 case GFC_DTYPE_LOGICAL_2
:
443 case GFC_DTYPE_INTEGER_2
:
444 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
445 mask
, (GFC_INTEGER_2
*) field
);
448 case GFC_DTYPE_LOGICAL_4
:
449 case GFC_DTYPE_INTEGER_4
:
450 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
451 mask
, (GFC_INTEGER_4
*) field
);
454 case GFC_DTYPE_LOGICAL_8
:
455 case GFC_DTYPE_INTEGER_8
:
456 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
457 mask
, (GFC_INTEGER_8
*) field
);
460 #ifdef HAVE_GFC_INTEGER_16
461 case GFC_DTYPE_LOGICAL_16
:
462 case GFC_DTYPE_INTEGER_16
:
463 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
464 mask
, (GFC_INTEGER_16
*) field
);
468 case GFC_DTYPE_REAL_4
:
469 unpack0_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
470 mask
, (GFC_REAL_4
*) field
);
473 case GFC_DTYPE_REAL_8
:
474 unpack0_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
475 mask
, (GFC_REAL_8
*) field
);
478 /* FIXME: This here is a hack, which will have to be removed when
479 the array descriptor is reworked. Currently, we don't store the
480 kind value for the type, but only the size. Because on targets with
481 __float128, we have sizeof(logn double) == sizeof(__float128),
482 we cannot discriminate here and have to fall back to the generic
483 handling (which is suboptimal). */
484 #if !defined(GFC_REAL_16_IS_FLOAT128)
485 # ifdef HAVE_GFC_REAL_10
486 case GFC_DTYPE_REAL_10
:
487 unpack0_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
488 mask
, (GFC_REAL_10
*) field
);
492 # ifdef HAVE_GFC_REAL_16
493 case GFC_DTYPE_REAL_16
:
494 unpack0_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
495 mask
, (GFC_REAL_16
*) field
);
500 case GFC_DTYPE_COMPLEX_4
:
501 unpack0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
502 mask
, (GFC_COMPLEX_4
*) field
);
505 case GFC_DTYPE_COMPLEX_8
:
506 unpack0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
507 mask
, (GFC_COMPLEX_8
*) field
);
510 /* FIXME: This here is a hack, which will have to be removed when
511 the array descriptor is reworked. Currently, we don't store the
512 kind value for the type, but only the size. Because on targets with
513 __float128, we have sizeof(logn double) == sizeof(__float128),
514 we cannot discriminate here and have to fall back to the generic
515 handling (which is suboptimal). */
516 #if !defined(GFC_REAL_16_IS_FLOAT128)
517 # ifdef HAVE_GFC_COMPLEX_10
518 case GFC_DTYPE_COMPLEX_10
:
519 unpack0_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
520 mask
, (GFC_COMPLEX_10
*) field
);
524 # ifdef HAVE_GFC_COMPLEX_16
525 case GFC_DTYPE_COMPLEX_16
:
526 unpack0_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
527 mask
, (GFC_COMPLEX_16
*) field
);
532 case GFC_DTYPE_DERIVED_2
:
533 if (GFC_UNALIGNED_2(ret
->base_addr
) || GFC_UNALIGNED_2(vector
->base_addr
)
534 || GFC_UNALIGNED_2(field
))
538 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
539 mask
, (GFC_INTEGER_2
*) field
);
543 case GFC_DTYPE_DERIVED_4
:
544 if (GFC_UNALIGNED_4(ret
->base_addr
) || GFC_UNALIGNED_4(vector
->base_addr
)
545 || GFC_UNALIGNED_4(field
))
549 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
550 mask
, (GFC_INTEGER_4
*) field
);
554 case GFC_DTYPE_DERIVED_8
:
555 if (GFC_UNALIGNED_8(ret
->base_addr
) || GFC_UNALIGNED_8(vector
->base_addr
)
556 || GFC_UNALIGNED_8(field
))
560 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
561 mask
, (GFC_INTEGER_8
*) field
);
565 #ifdef HAVE_GFC_INTEGER_16
566 case GFC_DTYPE_DERIVED_16
:
567 if (GFC_UNALIGNED_16(ret
->base_addr
)
568 || GFC_UNALIGNED_16(vector
->base_addr
)
569 || GFC_UNALIGNED_16(field
))
573 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
574 mask
, (GFC_INTEGER_16
*) field
);
581 memset (&tmp
, 0, sizeof (tmp
));
583 tmp
.base_addr
= field
;
584 unpack_internal (ret
, vector
, mask
, &tmp
, GFC_DESCRIPTOR_SIZE (vector
));
588 extern void unpack0_char (gfc_array_char
*, GFC_INTEGER_4
,
589 const gfc_array_char
*, const gfc_array_l1
*,
590 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
591 export_proto(unpack0_char
);
594 unpack0_char (gfc_array_char
*ret
,
595 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
596 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
597 char *field
, GFC_INTEGER_4 vector_length
,
598 GFC_INTEGER_4 field_length
__attribute__((unused
)))
602 if (unlikely(compile_options
.bounds_check
))
603 unpack_bounds (ret
, vector
, mask
, NULL
);
605 memset (&tmp
, 0, sizeof (tmp
));
607 tmp
.base_addr
= field
;
608 unpack_internal (ret
, vector
, mask
, &tmp
, vector_length
);
612 extern void unpack0_char4 (gfc_array_char
*, GFC_INTEGER_4
,
613 const gfc_array_char
*, const gfc_array_l1
*,
614 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
615 export_proto(unpack0_char4
);
618 unpack0_char4 (gfc_array_char
*ret
,
619 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
620 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
621 char *field
, GFC_INTEGER_4 vector_length
,
622 GFC_INTEGER_4 field_length
__attribute__((unused
)))
626 if (unlikely(compile_options
.bounds_check
))
627 unpack_bounds (ret
, vector
, mask
, NULL
);
629 memset (&tmp
, 0, sizeof (tmp
));
631 tmp
.base_addr
= field
;
632 unpack_internal (ret
, vector
, mask
, &tmp
,
633 vector_length
* sizeof (gfc_char4_t
));