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