1 /* Generic implementation of the UNPACK intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
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.
11
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.
16
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.
20
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/>. */
25
26 #include "libgfortran.h"
27 #include <assert.h>
28 #include <string.h>
29
30 /* All the bounds checking for unpack in one function. If field is NULL,
31 we don't check it, for the unpack0 functions. */
32
33 static void
34 unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
35 const gfc_array_l1 *mask, const gfc_array_char *field)
36 {
37 index_type vec_size, mask_count;
38 vec_size = size0 ((array_t *) vector);
39 mask_count = count_0 (mask);
40 if (vec_size < mask_count)
41 runtime_error ("Incorrect size of return value in UNPACK"
42 " intrinsic: should be at least %ld, is"
43 " %ld", (long int) mask_count,
44 (long int) vec_size);
45
46 if (field != NULL)
47 bounds_equal_extents ((array_t *) field, (array_t *) mask,
48 "FIELD", "UNPACK");
49
50 if (ret->base_addr != NULL)
51 bounds_equal_extents ((array_t *) ret, (array_t *) mask,
52 "return value", "UNPACK");
53
54 }
55
56 static void
57 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
58 const gfc_array_l1 *mask, const gfc_array_char *field,
59 index_type size)
60 {
61 /* r.* indicates the return array. */
62 index_type rstride[GFC_MAX_DIMENSIONS];
63 index_type rstride0;
64 index_type rs;
65 char * restrict rptr;
66 /* v.* indicates the vector array. */
67 index_type vstride0;
68 char *vptr;
69 /* f.* indicates the field array. */
70 index_type fstride[GFC_MAX_DIMENSIONS];
71 index_type fstride0;
72 const char *fptr;
73 /* m.* indicates the mask array. */
74 index_type mstride[GFC_MAX_DIMENSIONS];
75 index_type mstride0;
76 const GFC_LOGICAL_1 *mptr;
77
78 index_type count[GFC_MAX_DIMENSIONS];
79 index_type extent[GFC_MAX_DIMENSIONS];
80 index_type n;
81 index_type dim;
82
83 int empty;
84 int mask_kind;
85
86 empty = 0;
87
88 mptr = mask->base_addr;
89
90 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
91 and using shifting to address size and endian issues. */
92
93 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
94
95 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
96 #ifdef HAVE_GFC_LOGICAL_16
97 || mask_kind == 16
98 #endif
99 )
100 {
101 /* Don't convert a NULL pointer as we use test for NULL below. */
102 if (mptr)
103 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
104 }
105 else
106 runtime_error ("Funny sized logical array");
107
108 if (ret->base_addr == NULL)
109 {
110 /* The front end has signalled that we need to populate the
111 return array descriptor. */
112 dim = GFC_DESCRIPTOR_RANK (mask);
113 rs = 1;
114 for (n = 0; n < dim; n++)
115 {
116 count[n] = 0;
117 GFC_DIMENSION_SET(ret->dim[n], 0,
118 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
119 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
120 empty = empty || extent[n] <= 0;
121 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
122 fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
123 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
124 rs *= extent[n];
125 }
126 ret->offset = 0;
127 ret->base_addr = xmallocarray (rs, size);
128 }
129 else
130 {
131 dim = GFC_DESCRIPTOR_RANK (ret);
132 for (n = 0; n < dim; n++)
133 {
134 count[n] = 0;
135 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
136 empty = empty || extent[n] <= 0;
137 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
138 fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
139 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
140 }
141 }
142
143 if (empty)
144 return;
145
146 /* This assert makes sure GCC knows we can access *stride[0] later. */
147 assert (dim > 0);
148
149 vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
150 rstride0 = rstride[0];
151 fstride0 = fstride[0];
152 mstride0 = mstride[0];
153 rptr = ret->base_addr;
154 fptr = field->base_addr;
155 vptr = vector->base_addr;
156
157 while (rptr)
158 {
159 if (*mptr)
160 {
161 /* From vector. */
162 memcpy (rptr, vptr, size);
163 vptr += vstride0;
164 }
165 else
166 {
167 /* From field. */
168 memcpy (rptr, fptr, size);
169 }
170 /* Advance to the next element. */
171 rptr += rstride0;
172 fptr += fstride0;
173 mptr += mstride0;
174 count[0]++;
175 n = 0;
176 while (count[n] == extent[n])
177 {
178 /* When we get to the end of a dimension, reset it and increment
179 the next dimension. */
180 count[n] = 0;
181 /* We could precalculate these products, but this is a less
182 frequently used path so probably not worth it. */
183 rptr -= rstride[n] * extent[n];
184 fptr -= fstride[n] * extent[n];
185 mptr -= mstride[n] * extent[n];
186 n++;
187 if (n >= dim)
188 {
189 /* Break out of the loop. */
190 rptr = NULL;
191 break;
192 }
193 else
194 {
195 count[n]++;
196 rptr += rstride[n];
197 fptr += fstride[n];
198 mptr += mstride[n];
199 }
200 }
201 }
202 }
203
204 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
205 const gfc_array_l1 *, const gfc_array_char *);
206 export_proto(unpack1);
207
208 void
209 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
210 const gfc_array_l1 *mask, const gfc_array_char *field)
211 {
212 index_type type_size;
213 index_type size;
214
215 if (unlikely(compile_options.bounds_check))
216 unpack_bounds (ret, vector, mask, field);
217
218 type_size = GFC_DTYPE_TYPE_SIZE (vector);
219 size = GFC_DESCRIPTOR_SIZE (vector);
220
221 switch(type_size)
222 {
223 case GFC_DTYPE_LOGICAL_1:
224 case GFC_DTYPE_INTEGER_1:
225 unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
226 mask, (gfc_array_i1 *) field);
227 return;
228
229 case GFC_DTYPE_LOGICAL_2:
230 case GFC_DTYPE_INTEGER_2:
231 unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
232 mask, (gfc_array_i2 *) field);
233 return;
234
235 case GFC_DTYPE_LOGICAL_4:
236 case GFC_DTYPE_INTEGER_4:
237 unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
238 mask, (gfc_array_i4 *) field);
239 return;
240
241 case GFC_DTYPE_LOGICAL_8:
242 case GFC_DTYPE_INTEGER_8:
243 unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
244 mask, (gfc_array_i8 *) field);
245 return;
246
247 #ifdef HAVE_GFC_INTEGER_16
248 case GFC_DTYPE_LOGICAL_16:
249 case GFC_DTYPE_INTEGER_16:
250 unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
251 mask, (gfc_array_i16 *) field);
252 return;
253 #endif
254
255 case GFC_DTYPE_REAL_4:
256 unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
257 mask, (gfc_array_r4 *) field);
258 return;
259
260 case GFC_DTYPE_REAL_8:
261 unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
262 mask, (gfc_array_r8 *) field);
263 return;
264
265 /* FIXME: This here is a hack, which will have to be removed when
266 the array descriptor is reworked. Currently, we don't store the
267 kind value for the type, but only the size. Because on targets with
268 _Float128, we have sizeof(long double) == sizeof(_Float128),
269 we cannot discriminate here and have to fall back to the generic
270 handling (which is suboptimal). */
271 #if !defined(GFC_REAL_16_IS_FLOAT128)
272 # ifdef HAVE_GFC_REAL_10
273 case GFC_DTYPE_REAL_10:
274 unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
275 mask, (gfc_array_r10 *) field);
276 return;
277 # endif
278
279 # ifdef HAVE_GFC_REAL_16
280 case GFC_DTYPE_REAL_16:
281 unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
282 mask, (gfc_array_r16 *) field);
283 return;
284 # endif
285 #endif
286
287 case GFC_DTYPE_COMPLEX_4:
288 unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
289 mask, (gfc_array_c4 *) field);
290 return;
291
292 case GFC_DTYPE_COMPLEX_8:
293 unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
294 mask, (gfc_array_c8 *) field);
295 return;
296
297 /* FIXME: This here is a hack, which will have to be removed when
298 the array descriptor is reworked. Currently, we don't store the
299 kind value for the type, but only the size. Because on targets with
300 _Float128, we have sizeof(long double) == sizeof(_Float128),
301 we cannot discriminate here and have to fall back to the generic
302 handling (which is suboptimal). */
303 #if !defined(GFC_REAL_16_IS_FLOAT128)
304 # ifdef HAVE_GFC_COMPLEX_10
305 case GFC_DTYPE_COMPLEX_10:
306 unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
307 mask, (gfc_array_c10 *) field);
308 return;
309 # endif
310
311 # ifdef HAVE_GFC_COMPLEX_16
312 case GFC_DTYPE_COMPLEX_16:
313 unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
314 mask, (gfc_array_c16 *) field);
315 return;
316 # endif
317 #endif
318
319 }
320
321 switch (GFC_DESCRIPTOR_SIZE(ret))
322 {
323 case 1:
324 unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
325 mask, (gfc_array_i1 *) field);
326 return;
327
328 case 2:
329 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
330 || GFC_UNALIGNED_2(field->base_addr))
331 break;
332 else
333 {
334 unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
335 mask, (gfc_array_i2 *) field);
336 return;
337 }
338
339 case 4:
340 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
341 || GFC_UNALIGNED_4(field->base_addr))
342 break;
343 else
344 {
345 unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
346 mask, (gfc_array_i4 *) field);
347 return;
348 }
349
350 case 8:
351 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
352 || GFC_UNALIGNED_8(field->base_addr))
353 break;
354 else
355 {
356 unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
357 mask, (gfc_array_i8 *) field);
358 return;
359 }
360
361 #ifdef HAVE_GFC_INTEGER_16
362 case 16:
363 if (GFC_UNALIGNED_16(ret->base_addr)
364 || GFC_UNALIGNED_16(vector->base_addr)
365 || GFC_UNALIGNED_16(field->base_addr))
366 break;
367 else
368 {
369 unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
370 mask, (gfc_array_i16 *) field);
371 return;
372 }
373 #endif
374 default:
375 break;
376 }
377
378 unpack_internal (ret, vector, mask, field, size);
379 }
380
381
382 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
383 const gfc_array_char *, const gfc_array_l1 *,
384 const gfc_array_char *, GFC_INTEGER_4,
385 GFC_INTEGER_4);
386 export_proto(unpack1_char);
387
388 void
389 unpack1_char (gfc_array_char *ret,
390 GFC_INTEGER_4 ret_length __attribute__((unused)),
391 const gfc_array_char *vector, const gfc_array_l1 *mask,
392 const gfc_array_char *field, GFC_INTEGER_4 vector_length,
393 GFC_INTEGER_4 field_length __attribute__((unused)))
394 {
395
396 if (unlikely(compile_options.bounds_check))
397 unpack_bounds (ret, vector, mask, field);
398
399 unpack_internal (ret, vector, mask, field, vector_length);
400 }
401
402
403 extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
404 const gfc_array_char *, const gfc_array_l1 *,
405 const gfc_array_char *, GFC_INTEGER_4,
406 GFC_INTEGER_4);
407 export_proto(unpack1_char4);
408
409 void
410 unpack1_char4 (gfc_array_char *ret,
411 GFC_INTEGER_4 ret_length __attribute__((unused)),
412 const gfc_array_char *vector, const gfc_array_l1 *mask,
413 const gfc_array_char *field, GFC_INTEGER_4 vector_length,
414 GFC_INTEGER_4 field_length __attribute__((unused)))
415 {
416
417 if (unlikely(compile_options.bounds_check))
418 unpack_bounds (ret, vector, mask, field);
419
420 unpack_internal (ret, vector, mask, field,
421 vector_length * sizeof (gfc_char4_t));
422 }
423
424
425 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
426 const gfc_array_l1 *, char *);
427 export_proto(unpack0);
428
429 void
430 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
431 const gfc_array_l1 *mask, char *field)
432 {
433 gfc_array_char tmp;
434
435 index_type type_size;
436
437 if (unlikely(compile_options.bounds_check))
438 unpack_bounds (ret, vector, mask, NULL);
439
440 type_size = GFC_DTYPE_TYPE_SIZE (vector);
441
442 switch (type_size)
443 {
444 case GFC_DTYPE_LOGICAL_1:
445 case GFC_DTYPE_INTEGER_1:
446 unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
447 mask, (GFC_INTEGER_1 *) field);
448 return;
449
450 case GFC_DTYPE_LOGICAL_2:
451 case GFC_DTYPE_INTEGER_2:
452 unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
453 mask, (GFC_INTEGER_2 *) field);
454 return;
455
456 case GFC_DTYPE_LOGICAL_4:
457 case GFC_DTYPE_INTEGER_4:
458 unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
459 mask, (GFC_INTEGER_4 *) field);
460 return;
461
462 case GFC_DTYPE_LOGICAL_8:
463 case GFC_DTYPE_INTEGER_8:
464 unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
465 mask, (GFC_INTEGER_8 *) field);
466 return;
467
468 #ifdef HAVE_GFC_INTEGER_16
469 case GFC_DTYPE_LOGICAL_16:
470 case GFC_DTYPE_INTEGER_16:
471 unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
472 mask, (GFC_INTEGER_16 *) field);
473 return;
474 #endif
475
476 case GFC_DTYPE_REAL_4:
477 unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
478 mask, (GFC_REAL_4 *) field);
479 return;
480
481 case GFC_DTYPE_REAL_8:
482 unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
483 mask, (GFC_REAL_8 *) field);
484 return;
485
486 /* FIXME: This here is a hack, which will have to be removed when
487 the array descriptor is reworked. Currently, we don't store the
488 kind value for the type, but only the size. Because on targets with
489 _Float128, we have sizeof(long double) == sizeof(_Float128),
490 we cannot discriminate here and have to fall back to the generic
491 handling (which is suboptimal). */
492 #if !defined(GFC_REAL_16_IS_FLOAT128)
493 # ifdef HAVE_GFC_REAL_10
494 case GFC_DTYPE_REAL_10:
495 unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
496 mask, (GFC_REAL_10 *) field);
497 return;
498 # endif
499
500 # ifdef HAVE_GFC_REAL_16
501 case GFC_DTYPE_REAL_16:
502 unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
503 mask, (GFC_REAL_16 *) field);
504 return;
505 # endif
506 #endif
507
508 case GFC_DTYPE_COMPLEX_4:
509 unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
510 mask, (GFC_COMPLEX_4 *) field);
511 return;
512
513 case GFC_DTYPE_COMPLEX_8:
514 unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
515 mask, (GFC_COMPLEX_8 *) field);
516 return;
517
518 /* FIXME: This here is a hack, which will have to be removed when
519 the array descriptor is reworked. Currently, we don't store the
520 kind value for the type, but only the size. Because on targets with
521 _Float128, we have sizeof(long double) == sizeof(_Float128),
522 we cannot discriminate here and have to fall back to the generic
523 handling (which is suboptimal). */
524 #if !defined(GFC_REAL_16_IS_FLOAT128)
525 # ifdef HAVE_GFC_COMPLEX_10
526 case GFC_DTYPE_COMPLEX_10:
527 unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
528 mask, (GFC_COMPLEX_10 *) field);
529 return;
530 # endif
531
532 # ifdef HAVE_GFC_COMPLEX_16
533 case GFC_DTYPE_COMPLEX_16:
534 unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
535 mask, (GFC_COMPLEX_16 *) field);
536 return;
537 # endif
538 #endif
539
540 }
541
542 switch (GFC_DESCRIPTOR_SIZE(ret))
543 {
544 case 1:
545 unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
546 mask, (GFC_INTEGER_1 *) field);
547 return;
548
549 case 2:
550 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
551 || GFC_UNALIGNED_2(field))
552 break;
553 else
554 {
555 unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
556 mask, (GFC_INTEGER_2 *) field);
557 return;
558 }
559
560 case 4:
561 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
562 || GFC_UNALIGNED_4(field))
563 break;
564 else
565 {
566 unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
567 mask, (GFC_INTEGER_4 *) field);
568 return;
569 }
570
571 case 8:
572 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
573 || GFC_UNALIGNED_8(field))
574 break;
575 else
576 {
577 unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
578 mask, (GFC_INTEGER_8 *) field);
579 return;
580 }
581
582 #ifdef HAVE_GFC_INTEGER_16
583 case 16:
584 if (GFC_UNALIGNED_16(ret->base_addr)
585 || GFC_UNALIGNED_16(vector->base_addr)
586 || GFC_UNALIGNED_16(field))
587 break;
588 else
589 {
590 unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
591 mask, (GFC_INTEGER_16 *) field);
592 return;
593 }
594 #endif
595 }
596
597 memset (&tmp, 0, sizeof (tmp));
598 GFC_DTYPE_CLEAR(&tmp);
599 tmp.base_addr = field;
600 unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
601 }
602
603
604 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
605 const gfc_array_char *, const gfc_array_l1 *,
606 char *, GFC_INTEGER_4, GFC_INTEGER_4);
607 export_proto(unpack0_char);
608
609 void
610 unpack0_char (gfc_array_char *ret,
611 GFC_INTEGER_4 ret_length __attribute__((unused)),
612 const gfc_array_char *vector, const gfc_array_l1 *mask,
613 char *field, GFC_INTEGER_4 vector_length,
614 GFC_INTEGER_4 field_length __attribute__((unused)))
615 {
616 gfc_array_char tmp;
617
618 if (unlikely(compile_options.bounds_check))
619 unpack_bounds (ret, vector, mask, NULL);
620
621 memset (&tmp, 0, sizeof (tmp));
622 GFC_DTYPE_CLEAR(&tmp);
623 tmp.base_addr = field;
624 unpack_internal (ret, vector, mask, &tmp, vector_length);
625 }
626
627
628 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
629 const gfc_array_char *, const gfc_array_l1 *,
630 char *, GFC_INTEGER_4, GFC_INTEGER_4);
631 export_proto(unpack0_char4);
632
633 void
634 unpack0_char4 (gfc_array_char *ret,
635 GFC_INTEGER_4 ret_length __attribute__((unused)),
636 const gfc_array_char *vector, const gfc_array_l1 *mask,
637 char *field, GFC_INTEGER_4 vector_length,
638 GFC_INTEGER_4 field_length __attribute__((unused)))
639 {
640 gfc_array_char tmp;
641
642 if (unlikely(compile_options.bounds_check))
643 unpack_bounds (ret, vector, mask, NULL);
644
645 memset (&tmp, 0, sizeof (tmp));
646 GFC_DTYPE_CLEAR(&tmp);
647 tmp.base_addr = field;
648 unpack_internal (ret, vector, mask, &tmp,
649 vector_length * sizeof (gfc_char4_t));
650 }