]>
Commit | Line | Data |
---|---|---|
58c5b409 | 1 | /* Generic implementation of the PACK intrinsic |
85ec4feb | 2 | Copyright (C) 2002-2018 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | ||
21d1335b | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a | 6 | |
57dea9f6 TM |
7 | Libgfortran is free software; you can redistribute it and/or |
8 | modify it under the terms of the GNU General Public | |
6de9cd9a | 9 | License as published by the Free Software Foundation; either |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
57dea9f6 TM |
11 | |
12 | Ligbfortran is distributed in the hope that it will be useful, | |
6de9cd9a DN |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
57dea9f6 | 15 | GNU General Public License for more details. |
6de9cd9a | 16 | |
748086b7 JJ |
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/>. */ | |
6de9cd9a | 25 | |
36ae8a61 | 26 | #include "libgfortran.h" |
6de9cd9a | 27 | #include <string.h> |
6de9cd9a | 28 | |
58c5b409 TS |
29 | /* PACK is specified as follows: |
30 | ||
31 | 13.14.80 PACK (ARRAY, MASK, [VECTOR]) | |
e606fb39 | 32 | |
58c5b409 TS |
33 | Description: Pack an array into an array of rank one under the |
34 | control of a mask. | |
35 | ||
8b6dba81 | 36 | Class: Transformational function. |
58c5b409 TS |
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 | |
e606fb39 | 44 | with the value true, VECTOR shall have at least as many |
58c5b409 TS |
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, | |
e606fb39 | 64 | VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. |
58c5b409 TS |
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 | ||
7823229b RS |
69 | static void |
70 | pack_internal (gfc_array_char *ret, const gfc_array_char *array, | |
28dc6b33 | 71 | const gfc_array_l1 *mask, const gfc_array_char *vector, |
7823229b | 72 | index_type size) |
6de9cd9a DN |
73 | { |
74 | /* r.* indicates the return array. */ | |
75 | index_type rstride0; | |
5863aacf | 76 | char * restrict rptr; |
6de9cd9a DN |
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; | |
28dc6b33 | 84 | const GFC_LOGICAL_1 *mptr; |
6de9cd9a DN |
85 | |
86 | index_type count[GFC_MAX_DIMENSIONS]; | |
87 | index_type extent[GFC_MAX_DIMENSIONS]; | |
88 | index_type n; | |
89 | index_type dim; | |
6de9cd9a | 90 | index_type nelem; |
18fe404f | 91 | index_type total; |
28dc6b33 | 92 | int mask_kind; |
6de9cd9a | 93 | |
6de9cd9a | 94 | dim = GFC_DESCRIPTOR_RANK (array); |
28dc6b33 | 95 | |
21d1335b TB |
96 | sptr = array->base_addr; |
97 | mptr = mask->base_addr; | |
28dc6b33 TK |
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 | ||
6de9cd9a DN |
117 | for (n = 0; n < dim; n++) |
118 | { | |
119 | count[n] = 0; | |
dfb55fdc | 120 | extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); |
dfb55fdc TK |
121 | sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); |
122 | mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); | |
6de9cd9a DN |
123 | } |
124 | if (sstride[0] == 0) | |
125 | sstride[0] = size; | |
126 | if (mstride[0] == 0) | |
28dc6b33 | 127 | mstride[0] = mask_kind; |
6de9cd9a | 128 | |
21d1335b | 129 | if (ret->base_addr == NULL || unlikely (compile_options.bounds_check)) |
58c5b409 | 130 | { |
18fe404f TK |
131 | /* Count the elements, either for allocating memory or |
132 | for bounds checking. */ | |
58c5b409 | 133 | |
e606fb39 AJ |
134 | if (vector != NULL) |
135 | { | |
58c5b409 | 136 | /* The return array will have as many |
e606fb39 | 137 | elements as there are in VECTOR. */ |
dfb55fdc | 138 | total = GFC_DESCRIPTOR_EXTENT(vector,0); |
e606fb39 AJ |
139 | } |
140 | else | |
141 | { | |
142 | /* We have to count the true elements in MASK. */ | |
58c5b409 | 143 | |
01d93568 | 144 | total = count_0 (mask); |
58c5b409 | 145 | } |
e606fb39 | 146 | |
21d1335b | 147 | if (ret->base_addr == NULL) |
18fe404f TK |
148 | { |
149 | /* Setup the array descriptor. */ | |
dfb55fdc | 150 | GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); |
58c5b409 | 151 | |
18fe404f | 152 | ret->offset = 0; |
92e6f3a4 JB |
153 | /* xmallocarray allocates a single byte for zero size. */ |
154 | ret->base_addr = xmallocarray (total, size); | |
a787f6f9 | 155 | |
18fe404f | 156 | if (total == 0) |
a787f6f9 | 157 | return; /* In this case, nothing remains to be done. */ |
18fe404f TK |
158 | } |
159 | else | |
3d894fc3 | 160 | { |
18fe404f | 161 | /* We come here because of range checking. */ |
d8163f5c TK |
162 | index_type ret_extent; |
163 | ||
dfb55fdc | 164 | ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); |
d8163f5c TK |
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); | |
3d894fc3 | 169 | } |
58c5b409 TS |
170 | } |
171 | ||
dfb55fdc | 172 | rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0); |
58c5b409 TS |
173 | if (rstride0 == 0) |
174 | rstride0 = size; | |
175 | sstride0 = sstride[0]; | |
176 | mstride0 = mstride[0]; | |
21d1335b | 177 | rptr = ret->base_addr; |
58c5b409 | 178 | |
3d894fc3 | 179 | while (sptr && mptr) |
6de9cd9a DN |
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 | |
8b6dba81 | 199 | frequently used path so probably not worth it. */ |
6de9cd9a DN |
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 | { | |
dfb55fdc | 221 | n = GFC_DESCRIPTOR_EXTENT(vector,0); |
21d1335b | 222 | nelem = ((rptr - ret->base_addr) / rstride0); |
6de9cd9a DN |
223 | if (n > nelem) |
224 | { | |
dfb55fdc | 225 | sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0); |
6de9cd9a DN |
226 | if (sstride0 == 0) |
227 | sstride0 = size; | |
228 | ||
21d1335b | 229 | sptr = vector->base_addr + sstride0 * nelem; |
6de9cd9a DN |
230 | n -= nelem; |
231 | while (n--) | |
232 | { | |
233 | memcpy (rptr, sptr, size); | |
234 | rptr += rstride0; | |
235 | sptr += sstride0; | |
236 | } | |
237 | } | |
238 | } | |
239 | } | |
240 | ||
7823229b | 241 | extern void pack (gfc_array_char *, const gfc_array_char *, |
e6082041 | 242 | const gfc_array_l1 *, const gfc_array_char *); |
7823229b | 243 | export_proto(pack); |
7d7b8bfe | 244 | |
58c5b409 | 245 | void |
7823229b | 246 | pack (gfc_array_char *ret, const gfc_array_char *array, |
e6082041 | 247 | const gfc_array_l1 *mask, const gfc_array_char *vector) |
7823229b | 248 | { |
c7d0f4d5 | 249 | index_type type_size; |
3ef2513a TK |
250 | index_type size; |
251 | ||
c7d0f4d5 | 252 | type_size = GFC_DTYPE_TYPE_SIZE(array); |
3ef2513a | 253 | |
c7d0f4d5 | 254 | switch(type_size) |
3ef2513a | 255 | { |
c7d0f4d5 TK |
256 | case GFC_DTYPE_LOGICAL_1: |
257 | case GFC_DTYPE_INTEGER_1: | |
258 | case GFC_DTYPE_DERIVED_1: | |
259 | pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, | |
260 | (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); | |
261 | return; | |
3ef2513a | 262 | |
c7d0f4d5 TK |
263 | case GFC_DTYPE_LOGICAL_2: |
264 | case GFC_DTYPE_INTEGER_2: | |
265 | pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, | |
266 | (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); | |
267 | return; | |
3ef2513a | 268 | |
c7d0f4d5 TK |
269 | case GFC_DTYPE_LOGICAL_4: |
270 | case GFC_DTYPE_INTEGER_4: | |
c7d0f4d5 TK |
271 | pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, |
272 | (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); | |
273 | return; | |
274 | ||
275 | case GFC_DTYPE_LOGICAL_8: | |
276 | case GFC_DTYPE_INTEGER_8: | |
c7d0f4d5 TK |
277 | pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, |
278 | (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); | |
279 | return; | |
3ef2513a TK |
280 | |
281 | #ifdef HAVE_GFC_INTEGER_16 | |
c7d0f4d5 TK |
282 | case GFC_DTYPE_LOGICAL_16: |
283 | case GFC_DTYPE_INTEGER_16: | |
c7d0f4d5 TK |
284 | pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, |
285 | (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); | |
286 | return; | |
3ef2513a | 287 | #endif |
075abad5 | 288 | |
c7d0f4d5 TK |
289 | case GFC_DTYPE_REAL_4: |
290 | pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, | |
291 | (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); | |
292 | return; | |
3ef2513a | 293 | |
c7d0f4d5 TK |
294 | case GFC_DTYPE_REAL_8: |
295 | pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, | |
296 | (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); | |
297 | return; | |
3ef2513a | 298 | |
1ec601bf FXC |
299 | /* FIXME: This here is a hack, which will have to be removed when |
300 | the array descriptor is reworked. Currently, we don't store the | |
301 | kind value for the type, but only the size. Because on targets with | |
302 | __float128, we have sizeof(logn double) == sizeof(__float128), | |
303 | we cannot discriminate here and have to fall back to the generic | |
304 | handling (which is suboptimal). */ | |
305 | #if !defined(GFC_REAL_16_IS_FLOAT128) | |
306 | # ifdef HAVE_GFC_REAL_10 | |
c7d0f4d5 TK |
307 | case GFC_DTYPE_REAL_10: |
308 | pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, | |
309 | (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); | |
310 | return; | |
1ec601bf | 311 | # endif |
3ef2513a | 312 | |
1ec601bf | 313 | # ifdef HAVE_GFC_REAL_16 |
c7d0f4d5 TK |
314 | case GFC_DTYPE_REAL_16: |
315 | pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, | |
316 | (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); | |
317 | return; | |
1ec601bf | 318 | # endif |
3ef2513a | 319 | #endif |
075abad5 | 320 | |
c7d0f4d5 TK |
321 | case GFC_DTYPE_COMPLEX_4: |
322 | pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, | |
323 | (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); | |
324 | return; | |
3ef2513a | 325 | |
c7d0f4d5 TK |
326 | case GFC_DTYPE_COMPLEX_8: |
327 | pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, | |
328 | (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); | |
329 | return; | |
3ef2513a | 330 | |
1ec601bf FXC |
331 | /* FIXME: This here is a hack, which will have to be removed when |
332 | the array descriptor is reworked. Currently, we don't store the | |
333 | kind value for the type, but only the size. Because on targets with | |
334 | __float128, we have sizeof(logn double) == sizeof(__float128), | |
335 | we cannot discriminate here and have to fall back to the generic | |
336 | handling (which is suboptimal). */ | |
337 | #if !defined(GFC_REAL_16_IS_FLOAT128) | |
338 | # ifdef HAVE_GFC_COMPLEX_10 | |
c7d0f4d5 TK |
339 | case GFC_DTYPE_COMPLEX_10: |
340 | pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, | |
341 | (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); | |
342 | return; | |
1ec601bf | 343 | # endif |
3ef2513a | 344 | |
1ec601bf | 345 | # ifdef HAVE_GFC_COMPLEX_16 |
c7d0f4d5 TK |
346 | case GFC_DTYPE_COMPLEX_16: |
347 | pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, | |
348 | (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); | |
349 | return; | |
1ec601bf | 350 | # endif |
3ef2513a TK |
351 | #endif |
352 | ||
c7d0f4d5 TK |
353 | /* For derived types, let's check the actual alignment of the |
354 | data pointers. If they are aligned, we can safely call | |
355 | the unpack functions. */ | |
356 | ||
357 | case GFC_DTYPE_DERIVED_2: | |
21d1335b TB |
358 | if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr) |
359 | || (vector && GFC_UNALIGNED_2(vector->base_addr))) | |
c7d0f4d5 TK |
360 | break; |
361 | else | |
362 | { | |
363 | pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, | |
364 | (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); | |
365 | return; | |
366 | } | |
367 | ||
368 | case GFC_DTYPE_DERIVED_4: | |
21d1335b TB |
369 | if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr) |
370 | || (vector && GFC_UNALIGNED_4(vector->base_addr))) | |
c7d0f4d5 TK |
371 | break; |
372 | else | |
373 | { | |
374 | pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, | |
375 | (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); | |
376 | return; | |
377 | } | |
378 | ||
379 | case GFC_DTYPE_DERIVED_8: | |
21d1335b TB |
380 | if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr) |
381 | || (vector && GFC_UNALIGNED_8(vector->base_addr))) | |
c7d0f4d5 TK |
382 | break; |
383 | else | |
384 | { | |
385 | pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, | |
386 | (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); | |
075abad5 | 387 | return; |
3ef2513a | 388 | } |
c7d0f4d5 TK |
389 | |
390 | #ifdef HAVE_GFC_INTEGER_16 | |
391 | case GFC_DTYPE_DERIVED_16: | |
21d1335b TB |
392 | if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr) |
393 | || (vector && GFC_UNALIGNED_16(vector->base_addr))) | |
c7d0f4d5 TK |
394 | break; |
395 | else | |
396 | { | |
397 | pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, | |
398 | (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); | |
399 | return; | |
400 | } | |
401 | #endif | |
402 | ||
3ef2513a | 403 | } |
c7d0f4d5 TK |
404 | |
405 | size = GFC_DESCRIPTOR_SIZE (array); | |
3ef2513a | 406 | pack_internal (ret, array, mask, vector, size); |
7823229b RS |
407 | } |
408 | ||
3571925e | 409 | |
7823229b | 410 | extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, |
e6082041 | 411 | const gfc_array_l1 *, const gfc_array_char *, |
7823229b RS |
412 | GFC_INTEGER_4, GFC_INTEGER_4); |
413 | export_proto(pack_char); | |
414 | ||
415 | void | |
416 | pack_char (gfc_array_char *ret, | |
417 | GFC_INTEGER_4 ret_length __attribute__((unused)), | |
e6082041 | 418 | const gfc_array_char *array, const gfc_array_l1 *mask, |
7823229b RS |
419 | const gfc_array_char *vector, GFC_INTEGER_4 array_length, |
420 | GFC_INTEGER_4 vector_length __attribute__((unused))) | |
421 | { | |
422 | pack_internal (ret, array, mask, vector, array_length); | |
423 | } | |
424 | ||
3571925e FXC |
425 | |
426 | extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, | |
427 | const gfc_array_l1 *, const gfc_array_char *, | |
428 | GFC_INTEGER_4, GFC_INTEGER_4); | |
429 | export_proto(pack_char4); | |
430 | ||
431 | void | |
432 | pack_char4 (gfc_array_char *ret, | |
433 | GFC_INTEGER_4 ret_length __attribute__((unused)), | |
434 | const gfc_array_char *array, const gfc_array_l1 *mask, | |
435 | const gfc_array_char *vector, GFC_INTEGER_4 array_length, | |
436 | GFC_INTEGER_4 vector_length __attribute__((unused))) | |
437 | { | |
438 | pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t)); | |
439 | } | |
440 | ||
441 | ||
7823229b RS |
442 | static void |
443 | pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, | |
444 | const GFC_LOGICAL_4 *mask, const gfc_array_char *vector, | |
445 | index_type size) | |
58c5b409 TS |
446 | { |
447 | /* r.* indicates the return array. */ | |
448 | index_type rstride0; | |
449 | char *rptr; | |
450 | /* s.* indicates the source array. */ | |
451 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
452 | index_type sstride0; | |
453 | const char *sptr; | |
454 | ||
455 | index_type count[GFC_MAX_DIMENSIONS]; | |
456 | index_type extent[GFC_MAX_DIMENSIONS]; | |
457 | index_type n; | |
458 | index_type dim; | |
3d894fc3 | 459 | index_type ssize; |
58c5b409 | 460 | index_type nelem; |
9e6dca75 | 461 | index_type total; |
58c5b409 | 462 | |
58c5b409 | 463 | dim = GFC_DESCRIPTOR_RANK (array); |
b95216f7 JB |
464 | /* Initialize sstride[0] to avoid -Wmaybe-uninitialized |
465 | complaints. */ | |
466 | sstride[0] = size; | |
3d894fc3 | 467 | ssize = 1; |
58c5b409 TS |
468 | for (n = 0; n < dim; n++) |
469 | { | |
470 | count[n] = 0; | |
dfb55fdc | 471 | extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); |
9e6dca75 TK |
472 | if (extent[n] < 0) |
473 | extent[n] = 0; | |
474 | ||
dfb55fdc | 475 | sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); |
3d894fc3 | 476 | ssize *= extent[n]; |
58c5b409 TS |
477 | } |
478 | if (sstride[0] == 0) | |
479 | sstride[0] = size; | |
480 | ||
481 | sstride0 = sstride[0]; | |
9e6dca75 TK |
482 | |
483 | if (ssize != 0) | |
21d1335b | 484 | sptr = array->base_addr; |
9e6dca75 TK |
485 | else |
486 | sptr = NULL; | |
58c5b409 | 487 | |
21d1335b | 488 | if (ret->base_addr == NULL) |
58c5b409 TS |
489 | { |
490 | /* Allocate the memory for the result. */ | |
58c5b409 TS |
491 | |
492 | if (vector != NULL) | |
493 | { | |
494 | /* The return array will have as many elements as there are | |
495 | in vector. */ | |
dfb55fdc | 496 | total = GFC_DESCRIPTOR_EXTENT(vector,0); |
9e6dca75 TK |
497 | if (total <= 0) |
498 | { | |
499 | total = 0; | |
500 | vector = NULL; | |
501 | } | |
58c5b409 TS |
502 | } |
503 | else | |
504 | { | |
505 | if (*mask) | |
506 | { | |
507 | /* The result array will have as many elements as the input | |
508 | array. */ | |
509 | total = extent[0]; | |
510 | for (n = 1; n < dim; n++) | |
511 | total *= extent[n]; | |
512 | } | |
513 | else | |
3d894fc3 FXC |
514 | /* The result array will be empty. */ |
515 | total = 0; | |
58c5b409 TS |
516 | } |
517 | ||
518 | /* Setup the array descriptor. */ | |
dfb55fdc TK |
519 | GFC_DIMENSION_SET(ret->dim[0],0,total-1,1); |
520 | ||
efd4dc1a | 521 | ret->offset = 0; |
3d894fc3 | 522 | |
92e6f3a4 | 523 | ret->base_addr = xmallocarray (total, size); |
a787f6f9 | 524 | |
3d894fc3 | 525 | if (total == 0) |
a787f6f9 | 526 | return; |
58c5b409 TS |
527 | } |
528 | ||
dfb55fdc | 529 | rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0); |
58c5b409 TS |
530 | if (rstride0 == 0) |
531 | rstride0 = size; | |
21d1335b | 532 | rptr = ret->base_addr; |
58c5b409 | 533 | |
e606fb39 | 534 | /* The remaining possibilities are now: |
58c5b409 TS |
535 | If MASK is .TRUE., we have to copy the source array into the |
536 | result array. We then have to fill it up with elements from VECTOR. | |
537 | If MASK is .FALSE., we have to copy VECTOR into the result | |
538 | array. If VECTOR were not present we would have already returned. */ | |
539 | ||
3d894fc3 | 540 | if (*mask && ssize != 0) |
58c5b409 TS |
541 | { |
542 | while (sptr) | |
543 | { | |
544 | /* Add this element. */ | |
545 | memcpy (rptr, sptr, size); | |
546 | rptr += rstride0; | |
547 | ||
548 | /* Advance to the next element. */ | |
549 | sptr += sstride0; | |
550 | count[0]++; | |
551 | n = 0; | |
552 | while (count[n] == extent[n]) | |
553 | { | |
554 | /* When we get to the end of a dimension, reset it and | |
555 | increment the next dimension. */ | |
556 | count[n] = 0; | |
557 | /* We could precalculate these products, but this is a | |
8b6dba81 | 558 | less frequently used path so probably not worth it. */ |
58c5b409 TS |
559 | sptr -= sstride[n] * extent[n]; |
560 | n++; | |
561 | if (n >= dim) | |
562 | { | |
563 | /* Break out of the loop. */ | |
564 | sptr = NULL; | |
565 | break; | |
566 | } | |
567 | else | |
568 | { | |
569 | count[n]++; | |
570 | sptr += sstride[n]; | |
571 | } | |
572 | } | |
573 | } | |
574 | } | |
e606fb39 | 575 | |
58c5b409 TS |
576 | /* Add any remaining elements from VECTOR. */ |
577 | if (vector) | |
578 | { | |
dfb55fdc | 579 | n = GFC_DESCRIPTOR_EXTENT(vector,0); |
21d1335b | 580 | nelem = ((rptr - ret->base_addr) / rstride0); |
58c5b409 TS |
581 | if (n > nelem) |
582 | { | |
dfb55fdc | 583 | sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0); |
58c5b409 TS |
584 | if (sstride0 == 0) |
585 | sstride0 = size; | |
586 | ||
21d1335b | 587 | sptr = vector->base_addr + sstride0 * nelem; |
58c5b409 TS |
588 | n -= nelem; |
589 | while (n--) | |
590 | { | |
591 | memcpy (rptr, sptr, size); | |
592 | rptr += rstride0; | |
593 | sptr += sstride0; | |
594 | } | |
595 | } | |
596 | } | |
597 | } | |
7823229b RS |
598 | |
599 | extern void pack_s (gfc_array_char *ret, const gfc_array_char *array, | |
600 | const GFC_LOGICAL_4 *, const gfc_array_char *); | |
601 | export_proto(pack_s); | |
602 | ||
603 | void | |
604 | pack_s (gfc_array_char *ret, const gfc_array_char *array, | |
605 | const GFC_LOGICAL_4 *mask, const gfc_array_char *vector) | |
606 | { | |
607 | pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); | |
608 | } | |
609 | ||
3571925e | 610 | |
7823229b RS |
611 | extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4, |
612 | const gfc_array_char *array, const GFC_LOGICAL_4 *, | |
613 | const gfc_array_char *, GFC_INTEGER_4, | |
614 | GFC_INTEGER_4); | |
615 | export_proto(pack_s_char); | |
616 | ||
617 | void | |
618 | pack_s_char (gfc_array_char *ret, | |
619 | GFC_INTEGER_4 ret_length __attribute__((unused)), | |
620 | const gfc_array_char *array, const GFC_LOGICAL_4 *mask, | |
621 | const gfc_array_char *vector, GFC_INTEGER_4 array_length, | |
622 | GFC_INTEGER_4 vector_length __attribute__((unused))) | |
623 | { | |
624 | pack_s_internal (ret, array, mask, vector, array_length); | |
625 | } | |
3571925e FXC |
626 | |
627 | ||
628 | extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4, | |
629 | const gfc_array_char *array, const GFC_LOGICAL_4 *, | |
630 | const gfc_array_char *, GFC_INTEGER_4, | |
631 | GFC_INTEGER_4); | |
632 | export_proto(pack_s_char4); | |
633 | ||
634 | void | |
635 | pack_s_char4 (gfc_array_char *ret, | |
636 | GFC_INTEGER_4 ret_length __attribute__((unused)), | |
637 | const gfc_array_char *array, const GFC_LOGICAL_4 *mask, | |
638 | const gfc_array_char *vector, GFC_INTEGER_4 array_length, | |
639 | GFC_INTEGER_4 vector_length __attribute__((unused))) | |
640 | { | |
641 | pack_s_internal (ret, array, mask, vector, | |
642 | array_length * sizeof (gfc_char4_t)); | |
643 | } |