1 /* Generic implementation of the PACK intrinsic
2 Copyright (C) 2002-2018 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 <string.h>
28
29 /* PACK is specified as follows:
30
31 13.14.80 PACK (ARRAY, MASK, [VECTOR])
32
33 Description: Pack an array into an array of rank one under the
34 control of a mask.
35
36 Class: Transformational function.
37
38 Arguments:
39 ARRAY may be of any type. It shall not be scalar.
40 MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
41 VECTOR (optional) shall be of the same type and type parameters
42 as ARRAY. VECTOR shall have at least as many elements as
43 there are true elements in MASK. If MASK is a scalar
44 with the value true, VECTOR shall have at least as many
45 elements as there are in ARRAY.
46
47 Result Characteristics: The result is an array of rank one with the
48 same type and type parameters as ARRAY. If VECTOR is present, the
49 result size is that of VECTOR; otherwise, the result size is the
50 number /t/ of true elements in MASK unless MASK is scalar with the
51 value true, in which case the result size is the size of ARRAY.
52
53 Result Value: Element /i/ of the result is the element of ARRAY
54 that corresponds to the /i/th true element of MASK, taking elements
55 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
56 present and has size /n/ > /t/, element /i/ of the result has the
57 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
58
59 Examples: The nonzero elements of an array M with the value
60 | 0 0 0 |
61 | 9 0 0 | may be "gathered" by the function PACK. The result of
62 | 0 0 7 |
63 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
64 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
65
66 There are two variants of the PACK intrinsic: one, where MASK is
67 array valued, and the other one where MASK is scalar. */
68
69 static void
pack_internal(gfc_array_char * ret,const gfc_array_char * array,const gfc_array_l1 * mask,const gfc_array_char * vector,index_type size)70 pack_internal (gfc_array_char *ret, const gfc_array_char *array,
71 const gfc_array_l1 *mask, const gfc_array_char *vector,
72 index_type size)
73 {
74 /* r.* indicates the return array. */
75 index_type rstride0;
76 char * restrict rptr;
77 /* s.* indicates the source array. */
78 index_type sstride[GFC_MAX_DIMENSIONS];
79 index_type sstride0;
80 const char *sptr;
81 /* m.* indicates the mask array. */
82 index_type mstride[GFC_MAX_DIMENSIONS];
83 index_type mstride0;
84 const GFC_LOGICAL_1 *mptr;
85
86 index_type count[GFC_MAX_DIMENSIONS];
87 index_type extent[GFC_MAX_DIMENSIONS];
88 index_type n;
89 index_type dim;
90 index_type nelem;
91 index_type total;
92 int mask_kind;
93
94 dim = GFC_DESCRIPTOR_RANK (array);
95
96 sptr = array->base_addr;
97 mptr = mask->base_addr;
98
99 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
100 and using shifting to address size and endian issues. */
101
102 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
103
104 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
105 #ifdef HAVE_GFC_LOGICAL_16
106 || mask_kind == 16
107 #endif
108 )
109 {
110 /* Don't convert a NULL pointer as we use test for NULL below. */
111 if (mptr)
112 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
113 }
114 else
115 runtime_error ("Funny sized logical array");
116
117 for (n = 0; n < dim; n++)
118 {
119 count[n] = 0;
120 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
121 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
122 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
123 }
124 if (sstride[0] == 0)
125 sstride[0] = size;
126 if (mstride[0] == 0)
127 mstride[0] = mask_kind;
128
129 if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
130 {
131 /* Count the elements, either for allocating memory or
132 for bounds checking. */
133
134 if (vector != NULL)
135 {
136 /* The return array will have as many
137 elements as there are in VECTOR. */
138 total = GFC_DESCRIPTOR_EXTENT(vector,0);
139 }
140 else
141 {
142 /* We have to count the true elements in MASK. */
143
144 total = count_0 (mask);
145 }
146
147 if (ret->base_addr == NULL)
148 {
149 /* Setup the array descriptor. */
150 GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
151
152 ret->offset = 0;
153 /* xmallocarray allocates a single byte for zero size. */
154 ret->base_addr = xmallocarray (total, size);
155
156 if (total == 0)
157 return; /* In this case, nothing remains to be done. */
158 }
159 else
160 {
161 /* We come here because of range checking. */
162 index_type ret_extent;
163
164 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
165 if (total != ret_extent)
166 runtime_error ("Incorrect extent in return value of PACK intrinsic;"
167 " is %ld, should be %ld", (long int) total,
168 (long int) ret_extent);
169 }
170 }
171
172 rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
173 if (rstride0 == 0)
174 rstride0 = size;
175 sstride0 = sstride[0];
176 mstride0 = mstride[0];
177 rptr = ret->base_addr;
178
179 while (sptr && mptr)
180 {
181 /* Test this element. */
182 if (*mptr)
183 {
184 /* Add it. */
185 memcpy (rptr, sptr, size);
186 rptr += rstride0;
187 }
188 /* Advance to the next element. */
189 sptr += sstride0;
190 mptr += mstride0;
191 count[0]++;
192 n = 0;
193 while (count[n] == extent[n])
194 {
195 /* When we get to the end of a dimension, reset it and increment
196 the next dimension. */
197 count[n] = 0;
198 /* We could precalculate these products, but this is a less
199 frequently used path so probably not worth it. */
200 sptr -= sstride[n] * extent[n];
201 mptr -= mstride[n] * extent[n];
202 n++;
203 if (n >= dim)
204 {
205 /* Break out of the loop. */
206 sptr = NULL;
207 break;
208 }
209 else
210 {
211 count[n]++;
212 sptr += sstride[n];
213 mptr += mstride[n];
214 }
215 }
216 }
217
218 /* Add any remaining elements from VECTOR. */
219 if (vector)
220 {
221 n = GFC_DESCRIPTOR_EXTENT(vector,0);
222 nelem = ((rptr - ret->base_addr) / rstride0);
223 if (n > nelem)
224 {
225 sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
226 if (sstride0 == 0)
227 sstride0 = size;
228
229 sptr = vector->base_addr + sstride0 * nelem;
230 n -= nelem;
231 while (n--)
232 {
233 memcpy (rptr, sptr, size);
234 rptr += rstride0;
235 sptr += sstride0;
236 }
237 }
238 }
239 }
240
241 extern void pack (gfc_array_char *, const gfc_array_char *,
242 const gfc_array_l1 *, const gfc_array_char *);
243 export_proto(pack);
244
245 void
pack(gfc_array_char * ret,const gfc_array_char * array,const gfc_array_l1 * mask,const gfc_array_char * vector)246 pack (gfc_array_char *ret, const gfc_array_char *array,
247 const gfc_array_l1 *mask, const gfc_array_char *vector)
248 {
249 index_type type_size;
250 index_type size;
251
252 type_size = GFC_DTYPE_TYPE_SIZE(array);
253
254 switch(type_size)
255 {
256 case GFC_DTYPE_LOGICAL_1:
257 case GFC_DTYPE_INTEGER_1:
258 pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
259 (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
260 return;
261
262 case GFC_DTYPE_LOGICAL_2:
263 case GFC_DTYPE_INTEGER_2:
264 pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
265 (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
266 return;
267
268 case GFC_DTYPE_LOGICAL_4:
269 case GFC_DTYPE_INTEGER_4:
270 pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
271 (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
272 return;
273
274 case GFC_DTYPE_LOGICAL_8:
275 case GFC_DTYPE_INTEGER_8:
276 pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
277 (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
278 return;
279
280 #ifdef HAVE_GFC_INTEGER_16
281 case GFC_DTYPE_LOGICAL_16:
282 case GFC_DTYPE_INTEGER_16:
283 pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
284 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
285 return;
286 #endif
287
288 case GFC_DTYPE_REAL_4:
289 pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
290 (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
291 return;
292
293 case GFC_DTYPE_REAL_8:
294 pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
295 (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
296 return;
297
298 /* FIXME: This here is a hack, which will have to be removed when
299 the array descriptor is reworked. Currently, we don't store the
300 kind value for the type, but only the size. Because on targets with
301 __float128, we have sizeof(logn double) == sizeof(__float128),
302 we cannot discriminate here and have to fall back to the generic
303 handling (which is suboptimal). */
304 #if !defined(GFC_REAL_16_IS_FLOAT128)
305 # ifdef HAVE_GFC_REAL_10
306 case GFC_DTYPE_REAL_10:
307 pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
308 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
309 return;
310 # endif
311
312 # ifdef HAVE_GFC_REAL_16
313 case GFC_DTYPE_REAL_16:
314 pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
315 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
316 return;
317 # endif
318 #endif
319
320 case GFC_DTYPE_COMPLEX_4:
321 pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
322 (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
323 return;
324
325 case GFC_DTYPE_COMPLEX_8:
326 pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
327 (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
328 return;
329
330 /* FIXME: This here is a hack, which will have to be removed when
331 the array descriptor is reworked. Currently, we don't store the
332 kind value for the type, but only the size. Because on targets with
333 __float128, we have sizeof(logn double) == sizeof(__float128),
334 we cannot discriminate here and have to fall back to the generic
335 handling (which is suboptimal). */
336 #if !defined(GFC_REAL_16_IS_FLOAT128)
337 # ifdef HAVE_GFC_COMPLEX_10
338 case GFC_DTYPE_COMPLEX_10:
339 pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
340 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
341 return;
342 # endif
343
344 # ifdef HAVE_GFC_COMPLEX_16
345 case GFC_DTYPE_COMPLEX_16:
346 pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
347 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
348 return;
349 # endif
350 #endif
351 }
352
353 /* For other types, let's check the actual alignment of the data pointers.
354 If they are aligned, we can safely call the unpack functions. */
355
356 switch (GFC_DESCRIPTOR_SIZE (array))
357 {
358 case 1:
359 pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
360 (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
361 return;
362
363 case 2:
364 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr)
365 || (vector && GFC_UNALIGNED_2(vector->base_addr)))
366 break;
367 else
368 {
369 pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
370 (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
371 return;
372 }
373
374 case 4:
375 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr)
376 || (vector && GFC_UNALIGNED_4(vector->base_addr)))
377 break;
378 else
379 {
380 pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
381 (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
382 return;
383 }
384
385 case 8:
386 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr)
387 || (vector && GFC_UNALIGNED_8(vector->base_addr)))
388 break;
389 else
390 {
391 pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
392 (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
393 return;
394 }
395
396 #ifdef HAVE_GFC_INTEGER_16
397 case 16:
398 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr)
399 || (vector && GFC_UNALIGNED_16(vector->base_addr)))
400 break;
401 else
402 {
403 pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
404 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
405 return;
406 }
407 #endif
408 default:
409 break;
410 }
411
412 size = GFC_DESCRIPTOR_SIZE (array);
413 pack_internal (ret, array, mask, vector, size);
414 }
415
416
417 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
418 const gfc_array_l1 *, const gfc_array_char *,
419 GFC_INTEGER_4, GFC_INTEGER_4);
420 export_proto(pack_char);
421
422 void
pack_char(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const gfc_array_char * array,const gfc_array_l1 * mask,const gfc_array_char * vector,GFC_INTEGER_4 array_length,GFC_INTEGER_4 vector_length)423 pack_char (gfc_array_char *ret,
424 GFC_INTEGER_4 ret_length __attribute__((unused)),
425 const gfc_array_char *array, const gfc_array_l1 *mask,
426 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
427 GFC_INTEGER_4 vector_length __attribute__((unused)))
428 {
429 pack_internal (ret, array, mask, vector, array_length);
430 }
431
432
433 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
434 const gfc_array_l1 *, const gfc_array_char *,
435 GFC_INTEGER_4, GFC_INTEGER_4);
436 export_proto(pack_char4);
437
438 void
pack_char4(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const gfc_array_char * array,const gfc_array_l1 * mask,const gfc_array_char * vector,GFC_INTEGER_4 array_length,GFC_INTEGER_4 vector_length)439 pack_char4 (gfc_array_char *ret,
440 GFC_INTEGER_4 ret_length __attribute__((unused)),
441 const gfc_array_char *array, const gfc_array_l1 *mask,
442 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
443 GFC_INTEGER_4 vector_length __attribute__((unused)))
444 {
445 pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t));
446 }
447
448
449 static void
pack_s_internal(gfc_array_char * ret,const gfc_array_char * array,const GFC_LOGICAL_4 * mask,const gfc_array_char * vector,index_type size)450 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
451 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
452 index_type size)
453 {
454 /* r.* indicates the return array. */
455 index_type rstride0;
456 char *rptr;
457 /* s.* indicates the source array. */
458 index_type sstride[GFC_MAX_DIMENSIONS];
459 index_type sstride0;
460 const char *sptr;
461
462 index_type count[GFC_MAX_DIMENSIONS];
463 index_type extent[GFC_MAX_DIMENSIONS];
464 index_type n;
465 index_type dim;
466 index_type ssize;
467 index_type nelem;
468 index_type total;
469
470 dim = GFC_DESCRIPTOR_RANK (array);
471 /* Initialize sstride[0] to avoid -Wmaybe-uninitialized
472 complaints. */
473 sstride[0] = size;
474 ssize = 1;
475 for (n = 0; n < dim; n++)
476 {
477 count[n] = 0;
478 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
479 if (extent[n] < 0)
480 extent[n] = 0;
481
482 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
483 ssize *= extent[n];
484 }
485 if (sstride[0] == 0)
486 sstride[0] = size;
487
488 sstride0 = sstride[0];
489
490 if (ssize != 0)
491 sptr = array->base_addr;
492 else
493 sptr = NULL;
494
495 if (ret->base_addr == NULL)
496 {
497 /* Allocate the memory for the result. */
498
499 if (vector != NULL)
500 {
501 /* The return array will have as many elements as there are
502 in vector. */
503 total = GFC_DESCRIPTOR_EXTENT(vector,0);
504 if (total <= 0)
505 {
506 total = 0;
507 vector = NULL;
508 }
509 }
510 else
511 {
512 if (*mask)
513 {
514 /* The result array will have as many elements as the input
515 array. */
516 total = extent[0];
517 for (n = 1; n < dim; n++)
518 total *= extent[n];
519 }
520 else
521 /* The result array will be empty. */
522 total = 0;
523 }
524
525 /* Setup the array descriptor. */
526 GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
527
528 ret->offset = 0;
529
530 ret->base_addr = xmallocarray (total, size);
531
532 if (total == 0)
533 return;
534 }
535
536 rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
537 if (rstride0 == 0)
538 rstride0 = size;
539 rptr = ret->base_addr;
540
541 /* The remaining possibilities are now:
542 If MASK is .TRUE., we have to copy the source array into the
543 result array. We then have to fill it up with elements from VECTOR.
544 If MASK is .FALSE., we have to copy VECTOR into the result
545 array. If VECTOR were not present we would have already returned. */
546
547 if (*mask && ssize != 0)
548 {
549 while (sptr)
550 {
551 /* Add this element. */
552 memcpy (rptr, sptr, size);
553 rptr += rstride0;
554
555 /* Advance to the next element. */
556 sptr += sstride0;
557 count[0]++;
558 n = 0;
559 while (count[n] == extent[n])
560 {
561 /* When we get to the end of a dimension, reset it and
562 increment the next dimension. */
563 count[n] = 0;
564 /* We could precalculate these products, but this is a
565 less frequently used path so probably not worth it. */
566 sptr -= sstride[n] * extent[n];
567 n++;
568 if (n >= dim)
569 {
570 /* Break out of the loop. */
571 sptr = NULL;
572 break;
573 }
574 else
575 {
576 count[n]++;
577 sptr += sstride[n];
578 }
579 }
580 }
581 }
582
583 /* Add any remaining elements from VECTOR. */
584 if (vector)
585 {
586 n = GFC_DESCRIPTOR_EXTENT(vector,0);
587 nelem = ((rptr - ret->base_addr) / rstride0);
588 if (n > nelem)
589 {
590 sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
591 if (sstride0 == 0)
592 sstride0 = size;
593
594 sptr = vector->base_addr + sstride0 * nelem;
595 n -= nelem;
596 while (n--)
597 {
598 memcpy (rptr, sptr, size);
599 rptr += rstride0;
600 sptr += sstride0;
601 }
602 }
603 }
604 }
605
606 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
607 const GFC_LOGICAL_4 *, const gfc_array_char *);
608 export_proto(pack_s);
609
610 void
pack_s(gfc_array_char * ret,const gfc_array_char * array,const GFC_LOGICAL_4 * mask,const gfc_array_char * vector)611 pack_s (gfc_array_char *ret, const gfc_array_char *array,
612 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
613 {
614 pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
615 }
616
617
618 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
619 const gfc_array_char *array, const GFC_LOGICAL_4 *,
620 const gfc_array_char *, GFC_INTEGER_4,
621 GFC_INTEGER_4);
622 export_proto(pack_s_char);
623
624 void
pack_s_char(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const gfc_array_char * array,const GFC_LOGICAL_4 * mask,const gfc_array_char * vector,GFC_INTEGER_4 array_length,GFC_INTEGER_4 vector_length)625 pack_s_char (gfc_array_char *ret,
626 GFC_INTEGER_4 ret_length __attribute__((unused)),
627 const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
628 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
629 GFC_INTEGER_4 vector_length __attribute__((unused)))
630 {
631 pack_s_internal (ret, array, mask, vector, array_length);
632 }
633
634
635 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4,
636 const gfc_array_char *array, const GFC_LOGICAL_4 *,
637 const gfc_array_char *, GFC_INTEGER_4,
638 GFC_INTEGER_4);
639 export_proto(pack_s_char4);
640
641 void
pack_s_char4(gfc_array_char * ret,GFC_INTEGER_4 ret_length,const gfc_array_char * array,const GFC_LOGICAL_4 * mask,const gfc_array_char * vector,GFC_INTEGER_4 array_length,GFC_INTEGER_4 vector_length)642 pack_s_char4 (gfc_array_char *ret,
643 GFC_INTEGER_4 ret_length __attribute__((unused)),
644 const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
645 const gfc_array_char *vector, GFC_INTEGER_4 array_length,
646 GFC_INTEGER_4 vector_length __attribute__((unused)))
647 {
648 pack_s_internal (ret, array, mask, vector,
649 array_length * sizeof (gfc_char4_t));
650 }
651