1 /* Generic implementation of the UNPACK intrinsic
2 Copyright 2002, 2003, 2004, 2005, 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"
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
->data
!= 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
];
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
->data
== 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
->data
= internal_malloc_size (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 vstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(vector
,0);
148 rstride0
= rstride
[0];
149 fstride0
= fstride
[0];
150 mstride0
= mstride
[0];
160 memcpy (rptr
, vptr
, size
);
166 memcpy (rptr
, fptr
, size
);
168 /* Advance to the next element. */
174 while (count
[n
] == extent
[n
])
176 /* When we get to the end of a dimension, reset it and increment
177 the next dimension. */
179 /* We could precalculate these products, but this is a less
180 frequently used path so probably not worth it. */
181 rptr
-= rstride
[n
] * extent
[n
];
182 fptr
-= fstride
[n
] * extent
[n
];
183 mptr
-= mstride
[n
] * extent
[n
];
187 /* Break out of the loop. */
202 extern void unpack1 (gfc_array_char
*, const gfc_array_char
*,
203 const gfc_array_l1
*, const gfc_array_char
*);
204 export_proto(unpack1
);
207 unpack1 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
208 const gfc_array_l1
*mask
, const gfc_array_char
*field
)
210 index_type type_size
;
213 if (unlikely(compile_options
.bounds_check
))
214 unpack_bounds (ret
, vector
, mask
, field
);
216 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
217 size
= GFC_DESCRIPTOR_SIZE (vector
);
221 case GFC_DTYPE_LOGICAL_1
:
222 case GFC_DTYPE_INTEGER_1
:
223 case GFC_DTYPE_DERIVED_1
:
224 unpack1_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
225 mask
, (gfc_array_i1
*) field
);
228 case GFC_DTYPE_LOGICAL_2
:
229 case GFC_DTYPE_INTEGER_2
:
230 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
231 mask
, (gfc_array_i2
*) field
);
234 case GFC_DTYPE_LOGICAL_4
:
235 case GFC_DTYPE_INTEGER_4
:
236 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
237 mask
, (gfc_array_i4
*) field
);
240 case GFC_DTYPE_LOGICAL_8
:
241 case GFC_DTYPE_INTEGER_8
:
242 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
243 mask
, (gfc_array_i8
*) field
);
246 #ifdef HAVE_GFC_INTEGER_16
247 case GFC_DTYPE_LOGICAL_16
:
248 case GFC_DTYPE_INTEGER_16
:
249 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
250 mask
, (gfc_array_i16
*) field
);
254 case GFC_DTYPE_REAL_4
:
255 unpack1_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
256 mask
, (gfc_array_r4
*) field
);
259 case GFC_DTYPE_REAL_8
:
260 unpack1_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
261 mask
, (gfc_array_r8
*) field
);
264 /* FIXME: This here is a hack, which will have to be removed when
265 the array descriptor is reworked. Currently, we don't store the
266 kind value for the type, but only the size. Because on targets with
267 __float128, we have sizeof(logn double) == sizeof(__float128),
268 we cannot discriminate here and have to fall back to the generic
269 handling (which is suboptimal). */
270 #if !defined(GFC_REAL_16_IS_FLOAT128)
271 # ifdef HAVE_GFC_REAL_10
272 case GFC_DTYPE_REAL_10
:
273 unpack1_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
274 mask
, (gfc_array_r10
*) field
);
278 # ifdef HAVE_GFC_REAL_16
279 case GFC_DTYPE_REAL_16
:
280 unpack1_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
281 mask
, (gfc_array_r16
*) field
);
286 case GFC_DTYPE_COMPLEX_4
:
287 unpack1_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
288 mask
, (gfc_array_c4
*) field
);
291 case GFC_DTYPE_COMPLEX_8
:
292 unpack1_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
293 mask
, (gfc_array_c8
*) field
);
296 /* FIXME: This here is a hack, which will have to be removed when
297 the array descriptor is reworked. Currently, we don't store the
298 kind value for the type, but only the size. Because on targets with
299 __float128, we have sizeof(logn double) == sizeof(__float128),
300 we cannot discriminate here and have to fall back to the generic
301 handling (which is suboptimal). */
302 #if !defined(GFC_REAL_16_IS_FLOAT128)
303 # ifdef HAVE_GFC_COMPLEX_10
304 case GFC_DTYPE_COMPLEX_10
:
305 unpack1_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
306 mask
, (gfc_array_c10
*) field
);
310 # ifdef HAVE_GFC_COMPLEX_16
311 case GFC_DTYPE_COMPLEX_16
:
312 unpack1_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
313 mask
, (gfc_array_c16
*) field
);
318 case GFC_DTYPE_DERIVED_2
:
319 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(vector
->data
)
320 || GFC_UNALIGNED_2(field
->data
))
324 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
325 mask
, (gfc_array_i2
*) field
);
329 case GFC_DTYPE_DERIVED_4
:
330 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(vector
->data
)
331 || GFC_UNALIGNED_4(field
->data
))
335 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
336 mask
, (gfc_array_i4
*) field
);
340 case GFC_DTYPE_DERIVED_8
:
341 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(vector
->data
)
342 || GFC_UNALIGNED_8(field
->data
))
346 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
347 mask
, (gfc_array_i8
*) field
);
351 #ifdef HAVE_GFC_INTEGER_16
352 case GFC_DTYPE_DERIVED_16
:
353 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(vector
->data
)
354 || GFC_UNALIGNED_16(field
->data
))
358 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
359 mask
, (gfc_array_i16
*) field
);
365 unpack_internal (ret
, vector
, mask
, field
, size
);
369 extern void unpack1_char (gfc_array_char
*, GFC_INTEGER_4
,
370 const gfc_array_char
*, const gfc_array_l1
*,
371 const gfc_array_char
*, GFC_INTEGER_4
,
373 export_proto(unpack1_char
);
376 unpack1_char (gfc_array_char
*ret
,
377 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
378 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
379 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
380 GFC_INTEGER_4 field_length
__attribute__((unused
)))
383 if (unlikely(compile_options
.bounds_check
))
384 unpack_bounds (ret
, vector
, mask
, field
);
386 unpack_internal (ret
, vector
, mask
, field
, vector_length
);
390 extern void unpack1_char4 (gfc_array_char
*, GFC_INTEGER_4
,
391 const gfc_array_char
*, const gfc_array_l1
*,
392 const gfc_array_char
*, GFC_INTEGER_4
,
394 export_proto(unpack1_char4
);
397 unpack1_char4 (gfc_array_char
*ret
,
398 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
399 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
400 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
401 GFC_INTEGER_4 field_length
__attribute__((unused
)))
404 if (unlikely(compile_options
.bounds_check
))
405 unpack_bounds (ret
, vector
, mask
, field
);
407 unpack_internal (ret
, vector
, mask
, field
,
408 vector_length
* sizeof (gfc_char4_t
));
412 extern void unpack0 (gfc_array_char
*, const gfc_array_char
*,
413 const gfc_array_l1
*, char *);
414 export_proto(unpack0
);
417 unpack0 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
418 const gfc_array_l1
*mask
, char *field
)
422 index_type type_size
;
424 if (unlikely(compile_options
.bounds_check
))
425 unpack_bounds (ret
, vector
, mask
, NULL
);
427 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
431 case GFC_DTYPE_LOGICAL_1
:
432 case GFC_DTYPE_INTEGER_1
:
433 case GFC_DTYPE_DERIVED_1
:
434 unpack0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
435 mask
, (GFC_INTEGER_1
*) field
);
438 case GFC_DTYPE_LOGICAL_2
:
439 case GFC_DTYPE_INTEGER_2
:
440 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
441 mask
, (GFC_INTEGER_2
*) field
);
444 case GFC_DTYPE_LOGICAL_4
:
445 case GFC_DTYPE_INTEGER_4
:
446 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
447 mask
, (GFC_INTEGER_4
*) field
);
450 case GFC_DTYPE_LOGICAL_8
:
451 case GFC_DTYPE_INTEGER_8
:
452 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
453 mask
, (GFC_INTEGER_8
*) field
);
456 #ifdef HAVE_GFC_INTEGER_16
457 case GFC_DTYPE_LOGICAL_16
:
458 case GFC_DTYPE_INTEGER_16
:
459 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
460 mask
, (GFC_INTEGER_16
*) field
);
464 case GFC_DTYPE_REAL_4
:
465 unpack0_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
466 mask
, (GFC_REAL_4
*) field
);
469 case GFC_DTYPE_REAL_8
:
470 unpack0_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
471 mask
, (GFC_REAL_8
*) field
);
474 /* FIXME: This here is a hack, which will have to be removed when
475 the array descriptor is reworked. Currently, we don't store the
476 kind value for the type, but only the size. Because on targets with
477 __float128, we have sizeof(logn double) == sizeof(__float128),
478 we cannot discriminate here and have to fall back to the generic
479 handling (which is suboptimal). */
480 #if !defined(GFC_REAL_16_IS_FLOAT128)
481 # ifdef HAVE_GFC_REAL_10
482 case GFC_DTYPE_REAL_10
:
483 unpack0_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
484 mask
, (GFC_REAL_10
*) field
);
488 # ifdef HAVE_GFC_REAL_16
489 case GFC_DTYPE_REAL_16
:
490 unpack0_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
491 mask
, (GFC_REAL_16
*) field
);
496 case GFC_DTYPE_COMPLEX_4
:
497 unpack0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
498 mask
, (GFC_COMPLEX_4
*) field
);
501 case GFC_DTYPE_COMPLEX_8
:
502 unpack0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
503 mask
, (GFC_COMPLEX_8
*) field
);
506 /* FIXME: This here is a hack, which will have to be removed when
507 the array descriptor is reworked. Currently, we don't store the
508 kind value for the type, but only the size. Because on targets with
509 __float128, we have sizeof(logn double) == sizeof(__float128),
510 we cannot discriminate here and have to fall back to the generic
511 handling (which is suboptimal). */
512 #if !defined(GFC_REAL_16_IS_FLOAT128)
513 # ifdef HAVE_GFC_COMPLEX_10
514 case GFC_DTYPE_COMPLEX_10
:
515 unpack0_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
516 mask
, (GFC_COMPLEX_10
*) field
);
520 # ifdef HAVE_GFC_COMPLEX_16
521 case GFC_DTYPE_COMPLEX_16
:
522 unpack0_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
523 mask
, (GFC_COMPLEX_16
*) field
);
528 case GFC_DTYPE_DERIVED_2
:
529 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(vector
->data
)
530 || GFC_UNALIGNED_2(field
))
534 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
535 mask
, (GFC_INTEGER_2
*) field
);
539 case GFC_DTYPE_DERIVED_4
:
540 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(vector
->data
)
541 || GFC_UNALIGNED_4(field
))
545 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
546 mask
, (GFC_INTEGER_4
*) field
);
550 case GFC_DTYPE_DERIVED_8
:
551 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(vector
->data
)
552 || GFC_UNALIGNED_8(field
))
556 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
557 mask
, (GFC_INTEGER_8
*) field
);
561 #ifdef HAVE_GFC_INTEGER_16
562 case GFC_DTYPE_DERIVED_16
:
563 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(vector
->data
)
564 || GFC_UNALIGNED_16(field
))
568 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
569 mask
, (GFC_INTEGER_16
*) field
);
576 memset (&tmp
, 0, sizeof (tmp
));
579 unpack_internal (ret
, vector
, mask
, &tmp
, GFC_DESCRIPTOR_SIZE (vector
));
583 extern void unpack0_char (gfc_array_char
*, GFC_INTEGER_4
,
584 const gfc_array_char
*, const gfc_array_l1
*,
585 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
586 export_proto(unpack0_char
);
589 unpack0_char (gfc_array_char
*ret
,
590 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
591 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
592 char *field
, GFC_INTEGER_4 vector_length
,
593 GFC_INTEGER_4 field_length
__attribute__((unused
)))
597 if (unlikely(compile_options
.bounds_check
))
598 unpack_bounds (ret
, vector
, mask
, NULL
);
600 memset (&tmp
, 0, sizeof (tmp
));
603 unpack_internal (ret
, vector
, mask
, &tmp
, vector_length
);
607 extern void unpack0_char4 (gfc_array_char
*, GFC_INTEGER_4
,
608 const gfc_array_char
*, const gfc_array_l1
*,
609 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
610 export_proto(unpack0_char4
);
613 unpack0_char4 (gfc_array_char
*ret
,
614 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
615 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
616 char *field
, GFC_INTEGER_4 vector_length
,
617 GFC_INTEGER_4 field_length
__attribute__((unused
)))
621 if (unlikely(compile_options
.bounds_check
))
622 unpack_bounds (ret
, vector
, mask
, NULL
);
624 memset (&tmp
, 0, sizeof (tmp
));
627 unpack_internal (ret
, vector
, mask
, &tmp
,
628 vector_length
* sizeof (gfc_char4_t
));