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"
32 unpack_internal (gfc_array_char
*ret
, const gfc_array_char
*vector
,
33 const gfc_array_l1
*mask
, const gfc_array_char
*field
,
34 index_type size
, index_type fsize
)
36 /* r.* indicates the return array. */
37 index_type rstride
[GFC_MAX_DIMENSIONS
];
41 /* v.* indicates the vector array. */
44 /* f.* indicates the field array. */
45 index_type fstride
[GFC_MAX_DIMENSIONS
];
48 /* m.* indicates the mask array. */
49 index_type mstride
[GFC_MAX_DIMENSIONS
];
51 const GFC_LOGICAL_1
*mptr
;
53 index_type count
[GFC_MAX_DIMENSIONS
];
54 index_type extent
[GFC_MAX_DIMENSIONS
];
65 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
66 and using shifting to address size and endian issues. */
68 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
70 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
71 #ifdef HAVE_GFC_LOGICAL_16
76 /* Don't convert a NULL pointer as we use test for NULL below. */
78 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
81 runtime_error ("Funny sized logical array");
83 if (ret
->data
== NULL
)
85 /* The front end has signalled that we need to populate the
86 return array descriptor. */
87 dim
= GFC_DESCRIPTOR_RANK (mask
);
89 for (n
= 0; n
< dim
; n
++)
92 GFC_DIMENSION_SET(ret
->dim
[n
], 0,
93 GFC_DESCRIPTOR_EXTENT(mask
,n
) - 1, rs
);
94 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
95 empty
= empty
|| extent
[n
] <= 0;
96 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
, n
);
97 fstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(field
, n
);
98 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
);
102 ret
->data
= internal_malloc_size (rs
* size
);
106 dim
= GFC_DESCRIPTOR_RANK (ret
);
107 for (n
= 0; n
< dim
; n
++)
110 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
111 empty
= empty
|| extent
[n
] <= 0;
112 rstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(ret
, n
);
113 fstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(field
, n
);
114 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
);
128 vstride0
= GFC_DESCRIPTOR_STRIDE_BYTES(vector
,0);
131 rstride0
= rstride
[0];
132 fstride0
= fstride
[0];
133 mstride0
= mstride
[0];
143 memcpy (rptr
, vptr
, size
);
149 memcpy (rptr
, fptr
, size
);
151 /* Advance to the next element. */
157 while (count
[n
] == extent
[n
])
159 /* When we get to the end of a dimension, reset it and increment
160 the next dimension. */
162 /* We could precalculate these products, but this is a less
163 frequently used path so probably not worth it. */
164 rptr
-= rstride
[n
] * extent
[n
];
165 fptr
-= fstride
[n
] * extent
[n
];
166 mptr
-= mstride
[n
] * extent
[n
];
170 /* Break out of the loop. */
185 extern void unpack1 (gfc_array_char
*, const gfc_array_char
*,
186 const gfc_array_l1
*, const gfc_array_char
*);
187 export_proto(unpack1
);
190 unpack1 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
191 const gfc_array_l1
*mask
, const gfc_array_char
*field
)
193 index_type type_size
;
196 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
197 size
= GFC_DESCRIPTOR_SIZE (vector
);
201 case GFC_DTYPE_LOGICAL_1
:
202 case GFC_DTYPE_INTEGER_1
:
203 case GFC_DTYPE_DERIVED_1
:
204 unpack1_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
205 mask
, (gfc_array_i1
*) field
);
208 case GFC_DTYPE_LOGICAL_2
:
209 case GFC_DTYPE_INTEGER_2
:
210 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
211 mask
, (gfc_array_i2
*) field
);
214 case GFC_DTYPE_LOGICAL_4
:
215 case GFC_DTYPE_INTEGER_4
:
216 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
217 mask
, (gfc_array_i4
*) field
);
220 case GFC_DTYPE_LOGICAL_8
:
221 case GFC_DTYPE_INTEGER_8
:
222 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
223 mask
, (gfc_array_i8
*) field
);
226 #ifdef HAVE_GFC_INTEGER_16
227 case GFC_DTYPE_LOGICAL_16
:
228 case GFC_DTYPE_INTEGER_16
:
229 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
230 mask
, (gfc_array_i16
*) field
);
233 case GFC_DTYPE_REAL_4
:
234 unpack1_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
235 mask
, (gfc_array_r4
*) field
);
238 case GFC_DTYPE_REAL_8
:
239 unpack1_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
240 mask
, (gfc_array_r8
*) field
);
243 #ifdef HAVE_GFC_REAL_10
244 case GFC_DTYPE_REAL_10
:
245 unpack1_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
246 mask
, (gfc_array_r10
*) field
);
250 #ifdef HAVE_GFC_REAL_16
251 case GFC_DTYPE_REAL_16
:
252 unpack1_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
253 mask
, (gfc_array_r16
*) field
);
257 case GFC_DTYPE_COMPLEX_4
:
258 unpack1_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
259 mask
, (gfc_array_c4
*) field
);
262 case GFC_DTYPE_COMPLEX_8
:
263 unpack1_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
264 mask
, (gfc_array_c8
*) field
);
267 #ifdef HAVE_GFC_COMPLEX_10
268 case GFC_DTYPE_COMPLEX_10
:
269 unpack1_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
270 mask
, (gfc_array_c10
*) field
);
274 #ifdef HAVE_GFC_COMPLEX_16
275 case GFC_DTYPE_COMPLEX_16
:
276 unpack1_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
277 mask
, (gfc_array_c16
*) field
);
281 case GFC_DTYPE_DERIVED_2
:
282 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(vector
->data
)
283 || GFC_UNALIGNED_2(field
->data
))
287 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
288 mask
, (gfc_array_i2
*) field
);
292 case GFC_DTYPE_DERIVED_4
:
293 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(vector
->data
)
294 || GFC_UNALIGNED_4(field
->data
))
298 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
299 mask
, (gfc_array_i4
*) field
);
303 case GFC_DTYPE_DERIVED_8
:
304 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(vector
->data
)
305 || GFC_UNALIGNED_8(field
->data
))
309 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
310 mask
, (gfc_array_i8
*) field
);
314 #ifdef HAVE_GFC_INTEGER_16
315 case GFC_DTYPE_DERIVED_16
:
316 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(vector
->data
)
317 || GFC_UNALIGNED_16(field
->data
))
321 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
322 mask
, (gfc_array_i16
*) field
);
328 unpack_internal (ret
, vector
, mask
, field
, size
,
329 GFC_DESCRIPTOR_SIZE (field
));
333 extern void unpack1_char (gfc_array_char
*, GFC_INTEGER_4
,
334 const gfc_array_char
*, const gfc_array_l1
*,
335 const gfc_array_char
*, GFC_INTEGER_4
,
337 export_proto(unpack1_char
);
340 unpack1_char (gfc_array_char
*ret
,
341 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
342 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
343 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
344 GFC_INTEGER_4 field_length
)
346 unpack_internal (ret
, vector
, mask
, field
, vector_length
, field_length
);
350 extern void unpack1_char4 (gfc_array_char
*, GFC_INTEGER_4
,
351 const gfc_array_char
*, const gfc_array_l1
*,
352 const gfc_array_char
*, GFC_INTEGER_4
,
354 export_proto(unpack1_char4
);
357 unpack1_char4 (gfc_array_char
*ret
,
358 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
359 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
360 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
361 GFC_INTEGER_4 field_length
)
363 unpack_internal (ret
, vector
, mask
, field
,
364 vector_length
* sizeof (gfc_char4_t
),
365 field_length
* sizeof (gfc_char4_t
));
369 extern void unpack0 (gfc_array_char
*, const gfc_array_char
*,
370 const gfc_array_l1
*, char *);
371 export_proto(unpack0
);
374 unpack0 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
375 const gfc_array_l1
*mask
, char *field
)
379 index_type type_size
;
382 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
383 size
= GFC_DESCRIPTOR_SIZE (vector
);
387 case GFC_DTYPE_LOGICAL_1
:
388 case GFC_DTYPE_INTEGER_1
:
389 case GFC_DTYPE_DERIVED_1
:
390 unpack0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
391 mask
, (GFC_INTEGER_1
*) field
);
394 case GFC_DTYPE_LOGICAL_2
:
395 case GFC_DTYPE_INTEGER_2
:
396 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
397 mask
, (GFC_INTEGER_2
*) field
);
400 case GFC_DTYPE_LOGICAL_4
:
401 case GFC_DTYPE_INTEGER_4
:
402 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
403 mask
, (GFC_INTEGER_4
*) field
);
406 case GFC_DTYPE_LOGICAL_8
:
407 case GFC_DTYPE_INTEGER_8
:
408 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
409 mask
, (GFC_INTEGER_8
*) field
);
412 #ifdef HAVE_GFC_INTEGER_16
413 case GFC_DTYPE_LOGICAL_16
:
414 case GFC_DTYPE_INTEGER_16
:
415 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
416 mask
, (GFC_INTEGER_16
*) field
);
419 case GFC_DTYPE_REAL_4
:
420 unpack0_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
421 mask
, (GFC_REAL_4
*) field
);
424 case GFC_DTYPE_REAL_8
:
425 unpack0_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
426 mask
, (GFC_REAL_8
*) field
);
429 #ifdef HAVE_GFC_REAL_10
430 case GFC_DTYPE_REAL_10
:
431 unpack0_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
432 mask
, (GFC_REAL_10
*) field
);
436 #ifdef HAVE_GFC_REAL_16
437 case GFC_DTYPE_REAL_16
:
438 unpack0_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
439 mask
, (GFC_REAL_16
*) field
);
443 case GFC_DTYPE_COMPLEX_4
:
444 unpack0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
445 mask
, (GFC_COMPLEX_4
*) field
);
448 case GFC_DTYPE_COMPLEX_8
:
449 unpack0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
450 mask
, (GFC_COMPLEX_8
*) field
);
453 #ifdef HAVE_GFC_COMPLEX_10
454 case GFC_DTYPE_COMPLEX_10
:
455 unpack0_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
456 mask
, (GFC_COMPLEX_10
*) field
);
460 #ifdef HAVE_GFC_COMPLEX_16
461 case GFC_DTYPE_COMPLEX_16
:
462 unpack0_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
463 mask
, (GFC_COMPLEX_16
*) field
);
466 case GFC_DTYPE_DERIVED_2
:
467 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(vector
->data
)
468 || GFC_UNALIGNED_2(field
))
472 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
473 mask
, (GFC_INTEGER_2
*) field
);
477 case GFC_DTYPE_DERIVED_4
:
478 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(vector
->data
)
479 || GFC_UNALIGNED_4(field
))
483 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
484 mask
, (GFC_INTEGER_4
*) field
);
488 case GFC_DTYPE_DERIVED_8
:
489 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(vector
->data
)
490 || GFC_UNALIGNED_8(field
))
494 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
495 mask
, (GFC_INTEGER_8
*) field
);
498 #ifdef HAVE_GFC_INTEGER_16
499 case GFC_DTYPE_DERIVED_16
:
500 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(vector
->data
)
501 || GFC_UNALIGNED_16(field
))
505 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
506 mask
, (GFC_INTEGER_16
*) field
);
512 memset (&tmp
, 0, sizeof (tmp
));
515 unpack_internal (ret
, vector
, mask
, &tmp
, GFC_DESCRIPTOR_SIZE (vector
), 0);
519 extern void unpack0_char (gfc_array_char
*, GFC_INTEGER_4
,
520 const gfc_array_char
*, const gfc_array_l1
*,
521 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
522 export_proto(unpack0_char
);
525 unpack0_char (gfc_array_char
*ret
,
526 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
527 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
528 char *field
, GFC_INTEGER_4 vector_length
,
529 GFC_INTEGER_4 field_length
__attribute__((unused
)))
533 memset (&tmp
, 0, sizeof (tmp
));
536 unpack_internal (ret
, vector
, mask
, &tmp
, vector_length
, 0);
540 extern void unpack0_char4 (gfc_array_char
*, GFC_INTEGER_4
,
541 const gfc_array_char
*, const gfc_array_l1
*,
542 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
543 export_proto(unpack0_char4
);
546 unpack0_char4 (gfc_array_char
*ret
,
547 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
548 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
549 char *field
, GFC_INTEGER_4 vector_length
,
550 GFC_INTEGER_4 field_length
__attribute__((unused
)))
554 memset (&tmp
, 0, sizeof (tmp
));
557 unpack_internal (ret
, vector
, mask
, &tmp
,
558 vector_length
* sizeof (gfc_char4_t
), 0);