1 /* Generic implementation of the UNPACK intrinsic
2 Copyright 2002, 2003, 2004, 2005, 2007 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 2 of the License, or (at your option) any later version.
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Ligbfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING. If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 #include "libgfortran.h"
37 unpack_internal (gfc_array_char
*ret
, const gfc_array_char
*vector
,
38 const gfc_array_l1
*mask
, const gfc_array_char
*field
,
39 index_type size
, index_type fsize
)
41 /* r.* indicates the return array. */
42 index_type rstride
[GFC_MAX_DIMENSIONS
];
46 /* v.* indicates the vector array. */
49 /* f.* indicates the field array. */
50 index_type fstride
[GFC_MAX_DIMENSIONS
];
53 /* m.* indicates the mask array. */
54 index_type mstride
[GFC_MAX_DIMENSIONS
];
56 const GFC_LOGICAL_1
*mptr
;
58 index_type count
[GFC_MAX_DIMENSIONS
];
59 index_type extent
[GFC_MAX_DIMENSIONS
];
70 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
71 and using shifting to address size and endian issues. */
73 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
75 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
76 #ifdef HAVE_GFC_LOGICAL_16
81 /* Don't convert a NULL pointer as we use test for NULL below. */
83 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
86 runtime_error ("Funny sized logical array");
88 if (ret
->data
== NULL
)
90 /* The front end has signalled that we need to populate the
91 return array descriptor. */
92 dim
= GFC_DESCRIPTOR_RANK (mask
);
94 for (n
= 0; n
< dim
; n
++)
97 ret
->dim
[n
].stride
= rs
;
98 ret
->dim
[n
].lbound
= 0;
99 ret
->dim
[n
].ubound
= mask
->dim
[n
].ubound
- mask
->dim
[n
].lbound
;
100 extent
[n
] = ret
->dim
[n
].ubound
+ 1;
101 empty
= empty
|| extent
[n
] <= 0;
102 rstride
[n
] = ret
->dim
[n
].stride
* size
;
103 fstride
[n
] = field
->dim
[n
].stride
* fsize
;
104 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
108 ret
->data
= internal_malloc_size (rs
* size
);
112 dim
= GFC_DESCRIPTOR_RANK (ret
);
113 for (n
= 0; n
< dim
; n
++)
116 extent
[n
] = ret
->dim
[n
].ubound
+ 1 - ret
->dim
[n
].lbound
;
117 empty
= empty
|| extent
[n
] <= 0;
118 rstride
[n
] = ret
->dim
[n
].stride
* size
;
119 fstride
[n
] = field
->dim
[n
].stride
* fsize
;
120 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
134 vstride0
= vector
->dim
[0].stride
* size
;
137 rstride0
= rstride
[0];
138 fstride0
= fstride
[0];
139 mstride0
= mstride
[0];
149 memcpy (rptr
, vptr
, size
);
155 memcpy (rptr
, fptr
, size
);
157 /* Advance to the next element. */
163 while (count
[n
] == extent
[n
])
165 /* When we get to the end of a dimension, reset it and increment
166 the next dimension. */
168 /* We could precalculate these products, but this is a less
169 frequently used path so probably not worth it. */
170 rptr
-= rstride
[n
] * extent
[n
];
171 fptr
-= fstride
[n
] * extent
[n
];
172 mptr
-= mstride
[n
] * extent
[n
];
176 /* Break out of the loop. */
191 extern void unpack1 (gfc_array_char
*, const gfc_array_char
*,
192 const gfc_array_l1
*, const gfc_array_char
*);
193 export_proto(unpack1
);
196 unpack1 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
197 const gfc_array_l1
*mask
, const gfc_array_char
*field
)
199 index_type type_size
;
202 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
203 size
= GFC_DESCRIPTOR_SIZE (vector
);
207 case GFC_DTYPE_LOGICAL_1
:
208 case GFC_DTYPE_INTEGER_1
:
209 case GFC_DTYPE_DERIVED_1
:
210 unpack1_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
211 mask
, (gfc_array_i1
*) field
);
214 case GFC_DTYPE_LOGICAL_2
:
215 case GFC_DTYPE_INTEGER_2
:
216 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
217 mask
, (gfc_array_i2
*) field
);
220 case GFC_DTYPE_LOGICAL_4
:
221 case GFC_DTYPE_INTEGER_4
:
222 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
223 mask
, (gfc_array_i4
*) field
);
226 case GFC_DTYPE_LOGICAL_8
:
227 case GFC_DTYPE_INTEGER_8
:
228 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
229 mask
, (gfc_array_i8
*) field
);
232 #ifdef HAVE_GFC_INTEGER_16
233 case GFC_DTYPE_LOGICAL_16
:
234 case GFC_DTYPE_INTEGER_16
:
235 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
236 mask
, (gfc_array_i16
*) field
);
239 case GFC_DTYPE_REAL_4
:
240 unpack1_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
241 mask
, (gfc_array_r4
*) field
);
244 case GFC_DTYPE_REAL_8
:
245 unpack1_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
246 mask
, (gfc_array_r8
*) field
);
249 #ifdef HAVE_GFC_REAL_10
250 case GFC_DTYPE_REAL_10
:
251 unpack1_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
252 mask
, (gfc_array_r10
*) field
);
256 #ifdef HAVE_GFC_REAL_16
257 case GFC_DTYPE_REAL_16
:
258 unpack1_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
259 mask
, (gfc_array_r16
*) field
);
263 case GFC_DTYPE_COMPLEX_4
:
264 unpack1_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
265 mask
, (gfc_array_c4
*) field
);
268 case GFC_DTYPE_COMPLEX_8
:
269 unpack1_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
270 mask
, (gfc_array_c8
*) field
);
273 #ifdef HAVE_GFC_COMPLEX_10
274 case GFC_DTYPE_COMPLEX_10
:
275 unpack1_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
276 mask
, (gfc_array_c10
*) field
);
280 #ifdef HAVE_GFC_COMPLEX_16
281 case GFC_DTYPE_COMPLEX_16
:
282 unpack1_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
283 mask
, (gfc_array_c16
*) field
);
287 case GFC_DTYPE_DERIVED_2
:
288 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(vector
->data
)
289 || GFC_UNALIGNED_2(field
->data
))
293 unpack1_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
294 mask
, (gfc_array_i2
*) field
);
298 case GFC_DTYPE_DERIVED_4
:
299 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(vector
->data
)
300 || GFC_UNALIGNED_4(field
->data
))
304 unpack1_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
305 mask
, (gfc_array_i4
*) field
);
309 case GFC_DTYPE_DERIVED_8
:
310 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(vector
->data
)
311 || GFC_UNALIGNED_8(field
->data
))
315 unpack1_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
316 mask
, (gfc_array_i8
*) field
);
320 #ifdef HAVE_GFC_INTEGER_16
321 case GFC_DTYPE_DERIVED_16
:
322 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(vector
->data
)
323 || GFC_UNALIGNED_16(field
->data
))
327 unpack1_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
328 mask
, (gfc_array_i16
*) field
);
334 unpack_internal (ret
, vector
, mask
, field
, size
,
335 GFC_DESCRIPTOR_SIZE (field
));
339 extern void unpack1_char (gfc_array_char
*, GFC_INTEGER_4
,
340 const gfc_array_char
*, const gfc_array_l1
*,
341 const gfc_array_char
*, GFC_INTEGER_4
,
343 export_proto(unpack1_char
);
346 unpack1_char (gfc_array_char
*ret
,
347 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
348 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
349 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
350 GFC_INTEGER_4 field_length
)
352 unpack_internal (ret
, vector
, mask
, field
, vector_length
, field_length
);
356 extern void unpack1_char4 (gfc_array_char
*, GFC_INTEGER_4
,
357 const gfc_array_char
*, const gfc_array_l1
*,
358 const gfc_array_char
*, GFC_INTEGER_4
,
360 export_proto(unpack1_char4
);
363 unpack1_char4 (gfc_array_char
*ret
,
364 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
365 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
366 const gfc_array_char
*field
, GFC_INTEGER_4 vector_length
,
367 GFC_INTEGER_4 field_length
)
369 unpack_internal (ret
, vector
, mask
, field
,
370 vector_length
* sizeof (gfc_char4_t
),
371 field_length
* sizeof (gfc_char4_t
));
375 extern void unpack0 (gfc_array_char
*, const gfc_array_char
*,
376 const gfc_array_l1
*, char *);
377 export_proto(unpack0
);
380 unpack0 (gfc_array_char
*ret
, const gfc_array_char
*vector
,
381 const gfc_array_l1
*mask
, char *field
)
385 index_type type_size
;
388 type_size
= GFC_DTYPE_TYPE_SIZE (vector
);
389 size
= GFC_DESCRIPTOR_SIZE (vector
);
393 case GFC_DTYPE_LOGICAL_1
:
394 case GFC_DTYPE_INTEGER_1
:
395 case GFC_DTYPE_DERIVED_1
:
396 unpack0_i1 ((gfc_array_i1
*) ret
, (gfc_array_i1
*) vector
,
397 mask
, (GFC_INTEGER_1
*) field
);
400 case GFC_DTYPE_LOGICAL_2
:
401 case GFC_DTYPE_INTEGER_2
:
402 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
403 mask
, (GFC_INTEGER_2
*) field
);
406 case GFC_DTYPE_LOGICAL_4
:
407 case GFC_DTYPE_INTEGER_4
:
408 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
409 mask
, (GFC_INTEGER_4
*) field
);
412 case GFC_DTYPE_LOGICAL_8
:
413 case GFC_DTYPE_INTEGER_8
:
414 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
415 mask
, (GFC_INTEGER_8
*) field
);
418 #ifdef HAVE_GFC_INTEGER_16
419 case GFC_DTYPE_LOGICAL_16
:
420 case GFC_DTYPE_INTEGER_16
:
421 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
422 mask
, (GFC_INTEGER_16
*) field
);
425 case GFC_DTYPE_REAL_4
:
426 unpack0_r4 ((gfc_array_r4
*) ret
, (gfc_array_r4
*) vector
,
427 mask
, (GFC_REAL_4
*) field
);
430 case GFC_DTYPE_REAL_8
:
431 unpack0_r8 ((gfc_array_r8
*) ret
, (gfc_array_r8
*) vector
,
432 mask
, (GFC_REAL_8
*) field
);
435 #ifdef HAVE_GFC_REAL_10
436 case GFC_DTYPE_REAL_10
:
437 unpack0_r10 ((gfc_array_r10
*) ret
, (gfc_array_r10
*) vector
,
438 mask
, (GFC_REAL_10
*) field
);
442 #ifdef HAVE_GFC_REAL_16
443 case GFC_DTYPE_REAL_16
:
444 unpack0_r16 ((gfc_array_r16
*) ret
, (gfc_array_r16
*) vector
,
445 mask
, (GFC_REAL_16
*) field
);
449 case GFC_DTYPE_COMPLEX_4
:
450 unpack0_c4 ((gfc_array_c4
*) ret
, (gfc_array_c4
*) vector
,
451 mask
, (GFC_COMPLEX_4
*) field
);
454 case GFC_DTYPE_COMPLEX_8
:
455 unpack0_c8 ((gfc_array_c8
*) ret
, (gfc_array_c8
*) vector
,
456 mask
, (GFC_COMPLEX_8
*) field
);
459 #ifdef HAVE_GFC_COMPLEX_10
460 case GFC_DTYPE_COMPLEX_10
:
461 unpack0_c10 ((gfc_array_c10
*) ret
, (gfc_array_c10
*) vector
,
462 mask
, (GFC_COMPLEX_10
*) field
);
466 #ifdef HAVE_GFC_COMPLEX_16
467 case GFC_DTYPE_COMPLEX_16
:
468 unpack0_c16 ((gfc_array_c16
*) ret
, (gfc_array_c16
*) vector
,
469 mask
, (GFC_COMPLEX_16
*) field
);
472 case GFC_DTYPE_DERIVED_2
:
473 if (GFC_UNALIGNED_2(ret
->data
) || GFC_UNALIGNED_2(vector
->data
)
474 || GFC_UNALIGNED_2(field
))
478 unpack0_i2 ((gfc_array_i2
*) ret
, (gfc_array_i2
*) vector
,
479 mask
, (GFC_INTEGER_2
*) field
);
483 case GFC_DTYPE_DERIVED_4
:
484 if (GFC_UNALIGNED_4(ret
->data
) || GFC_UNALIGNED_4(vector
->data
)
485 || GFC_UNALIGNED_4(field
))
489 unpack0_i4 ((gfc_array_i4
*) ret
, (gfc_array_i4
*) vector
,
490 mask
, (GFC_INTEGER_4
*) field
);
494 case GFC_DTYPE_DERIVED_8
:
495 if (GFC_UNALIGNED_8(ret
->data
) || GFC_UNALIGNED_8(vector
->data
)
496 || GFC_UNALIGNED_8(field
))
500 unpack0_i8 ((gfc_array_i8
*) ret
, (gfc_array_i8
*) vector
,
501 mask
, (GFC_INTEGER_8
*) field
);
504 #ifdef HAVE_GFC_INTEGER_16
505 case GFC_DTYPE_DERIVED_16
:
506 if (GFC_UNALIGNED_16(ret
->data
) || GFC_UNALIGNED_16(vector
->data
)
507 || GFC_UNALIGNED_16(field
))
511 unpack0_i16 ((gfc_array_i16
*) ret
, (gfc_array_i16
*) vector
,
512 mask
, (GFC_INTEGER_16
*) field
);
518 memset (&tmp
, 0, sizeof (tmp
));
521 unpack_internal (ret
, vector
, mask
, &tmp
, GFC_DESCRIPTOR_SIZE (vector
), 0);
525 extern void unpack0_char (gfc_array_char
*, GFC_INTEGER_4
,
526 const gfc_array_char
*, const gfc_array_l1
*,
527 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
528 export_proto(unpack0_char
);
531 unpack0_char (gfc_array_char
*ret
,
532 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
533 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
534 char *field
, GFC_INTEGER_4 vector_length
,
535 GFC_INTEGER_4 field_length
__attribute__((unused
)))
539 memset (&tmp
, 0, sizeof (tmp
));
542 unpack_internal (ret
, vector
, mask
, &tmp
, vector_length
, 0);
546 extern void unpack0_char4 (gfc_array_char
*, GFC_INTEGER_4
,
547 const gfc_array_char
*, const gfc_array_l1
*,
548 char *, GFC_INTEGER_4
, GFC_INTEGER_4
);
549 export_proto(unpack0_char4
);
552 unpack0_char4 (gfc_array_char
*ret
,
553 GFC_INTEGER_4 ret_length
__attribute__((unused
)),
554 const gfc_array_char
*vector
, const gfc_array_l1
*mask
,
555 char *field
, GFC_INTEGER_4 vector_length
,
556 GFC_INTEGER_4 field_length
__attribute__((unused
)))
560 memset (&tmp
, 0, sizeof (tmp
));
563 unpack_internal (ret
, vector
, mask
, &tmp
,
564 vector_length
* sizeof (gfc_char4_t
), 0);