]>
Commit | Line | Data |
---|---|---|
58c5b409 | 1 | /* Generic implementation of the PACK intrinsic |
36ae8a61 | 2 | Copyright (C) 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | ||
57dea9f6 | 5 | This file is part of the GNU Fortran 95 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 |
57dea9f6 TM |
10 | version 2 of the License, or (at your option) any later version. |
11 | ||
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 | |
19 | executable.) | |
20 | ||
21 | Ligbfortran is distributed in the hope that it will be useful, | |
6de9cd9a DN |
22 | but WITHOUT ANY WARRANTY; without even the implied warranty of |
23 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
57dea9f6 | 24 | GNU General Public License for more details. |
6de9cd9a | 25 | |
57dea9f6 TM |
26 | You should have received a copy of the GNU General Public |
27 | License along with libgfortran; see the file COPYING. If not, | |
fe2ae685 KC |
28 | write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
29 | Boston, MA 02110-1301, USA. */ | |
6de9cd9a | 30 | |
36ae8a61 | 31 | #include "libgfortran.h" |
6de9cd9a DN |
32 | #include <stdlib.h> |
33 | #include <assert.h> | |
34 | #include <string.h> | |
6de9cd9a | 35 | |
58c5b409 TS |
36 | /* PACK is specified as follows: |
37 | ||
38 | 13.14.80 PACK (ARRAY, MASK, [VECTOR]) | |
e606fb39 | 39 | |
58c5b409 TS |
40 | Description: Pack an array into an array of rank one under the |
41 | control of a mask. | |
42 | ||
8b6dba81 | 43 | Class: Transformational function. |
58c5b409 TS |
44 | |
45 | Arguments: | |
46 | ARRAY may be of any type. It shall not be scalar. | |
47 | MASK shall be of type LOGICAL. It shall be conformable with ARRAY. | |
48 | VECTOR (optional) shall be of the same type and type parameters | |
49 | as ARRAY. VECTOR shall have at least as many elements as | |
50 | there are true elements in MASK. If MASK is a scalar | |
e606fb39 | 51 | with the value true, VECTOR shall have at least as many |
58c5b409 TS |
52 | elements as there are in ARRAY. |
53 | ||
54 | Result Characteristics: The result is an array of rank one with the | |
55 | same type and type parameters as ARRAY. If VECTOR is present, the | |
56 | result size is that of VECTOR; otherwise, the result size is the | |
57 | number /t/ of true elements in MASK unless MASK is scalar with the | |
58 | value true, in which case the result size is the size of ARRAY. | |
59 | ||
60 | Result Value: Element /i/ of the result is the element of ARRAY | |
61 | that corresponds to the /i/th true element of MASK, taking elements | |
62 | in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is | |
63 | present and has size /n/ > /t/, element /i/ of the result has the | |
64 | value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. | |
65 | ||
66 | Examples: The nonzero elements of an array M with the value | |
67 | | 0 0 0 | | |
68 | | 9 0 0 | may be "gathered" by the function PACK. The result of | |
69 | | 0 0 7 | | |
70 | PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, | |
e606fb39 | 71 | VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. |
58c5b409 TS |
72 | |
73 | There are two variants of the PACK intrinsic: one, where MASK is | |
74 | array valued, and the other one where MASK is scalar. */ | |
75 | ||
7823229b RS |
76 | static void |
77 | pack_internal (gfc_array_char *ret, const gfc_array_char *array, | |
28dc6b33 | 78 | const gfc_array_l1 *mask, const gfc_array_char *vector, |
7823229b | 79 | index_type size) |
6de9cd9a DN |
80 | { |
81 | /* r.* indicates the return array. */ | |
82 | index_type rstride0; | |
83 | char *rptr; | |
84 | /* s.* indicates the source array. */ | |
85 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
86 | index_type sstride0; | |
87 | const char *sptr; | |
88 | /* m.* indicates the mask array. */ | |
89 | index_type mstride[GFC_MAX_DIMENSIONS]; | |
90 | index_type mstride0; | |
28dc6b33 | 91 | const GFC_LOGICAL_1 *mptr; |
6de9cd9a DN |
92 | |
93 | index_type count[GFC_MAX_DIMENSIONS]; | |
94 | index_type extent[GFC_MAX_DIMENSIONS]; | |
42d53ef3 | 95 | int zero_sized; |
6de9cd9a DN |
96 | index_type n; |
97 | index_type dim; | |
6de9cd9a | 98 | index_type nelem; |
18fe404f | 99 | index_type total; |
28dc6b33 | 100 | int mask_kind; |
6de9cd9a | 101 | |
6de9cd9a | 102 | dim = GFC_DESCRIPTOR_RANK (array); |
28dc6b33 TK |
103 | |
104 | sptr = array->data; | |
105 | mptr = mask->data; | |
106 | ||
107 | /* Use the same loop for all logical types, by using GFC_LOGICAL_1 | |
108 | and using shifting to address size and endian issues. */ | |
109 | ||
110 | mask_kind = GFC_DESCRIPTOR_SIZE (mask); | |
111 | ||
112 | if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 | |
113 | #ifdef HAVE_GFC_LOGICAL_16 | |
114 | || mask_kind == 16 | |
115 | #endif | |
116 | ) | |
117 | { | |
118 | /* Don't convert a NULL pointer as we use test for NULL below. */ | |
119 | if (mptr) | |
120 | mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); | |
121 | } | |
122 | else | |
123 | runtime_error ("Funny sized logical array"); | |
124 | ||
42d53ef3 | 125 | zero_sized = 0; |
6de9cd9a DN |
126 | for (n = 0; n < dim; n++) |
127 | { | |
128 | count[n] = 0; | |
129 | extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; | |
42d53ef3 FXC |
130 | if (extent[n] <= 0) |
131 | zero_sized = 1; | |
6de9cd9a | 132 | sstride[n] = array->dim[n].stride * size; |
28dc6b33 | 133 | mstride[n] = mask->dim[n].stride * mask_kind; |
6de9cd9a DN |
134 | } |
135 | if (sstride[0] == 0) | |
136 | sstride[0] = size; | |
137 | if (mstride[0] == 0) | |
28dc6b33 | 138 | mstride[0] = mask_kind; |
6de9cd9a | 139 | |
18fe404f | 140 | if (ret->data == NULL || compile_options.bounds_check) |
58c5b409 | 141 | { |
18fe404f TK |
142 | /* Count the elements, either for allocating memory or |
143 | for bounds checking. */ | |
58c5b409 | 144 | |
e606fb39 AJ |
145 | if (vector != NULL) |
146 | { | |
58c5b409 | 147 | /* The return array will have as many |
e606fb39 AJ |
148 | elements as there are in VECTOR. */ |
149 | total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; | |
150 | } | |
151 | else | |
152 | { | |
153 | /* We have to count the true elements in MASK. */ | |
58c5b409 TS |
154 | |
155 | /* TODO: We could speed up pack easily in the case of only | |
156 | few .TRUE. entries in MASK, by keeping track of where we | |
157 | would be in the source array during the initial traversal | |
158 | of MASK, and caching the pointers to those elements. Then, | |
159 | supposed the number of elements is small enough, we would | |
160 | only have to traverse the list, and copy those elements | |
161 | into the result array. In the case of datatypes which fit | |
162 | in one of the integer types we could also cache the | |
e606fb39 | 163 | value instead of a pointer to it. |
58c5b409 TS |
164 | This approach might be bad from the point of view of |
165 | cache behavior in the case where our cache is not big | |
166 | enough to hold all elements that have to be copied. */ | |
167 | ||
28dc6b33 | 168 | const GFC_LOGICAL_1 *m = mptr; |
58c5b409 TS |
169 | |
170 | total = 0; | |
42d53ef3 FXC |
171 | if (zero_sized) |
172 | m = NULL; | |
58c5b409 TS |
173 | |
174 | while (m) | |
175 | { | |
176 | /* Test this element. */ | |
177 | if (*m) | |
178 | total++; | |
179 | ||
180 | /* Advance to the next element. */ | |
181 | m += mstride[0]; | |
182 | count[0]++; | |
183 | n = 0; | |
184 | while (count[n] == extent[n]) | |
185 | { | |
186 | /* When we get to the end of a dimension, reset it | |
187 | and increment the next dimension. */ | |
188 | count[n] = 0; | |
189 | /* We could precalculate this product, but this is a | |
8b6dba81 | 190 | less frequently used path so probably not worth |
58c5b409 TS |
191 | it. */ |
192 | m -= mstride[n] * extent[n]; | |
193 | n++; | |
194 | if (n >= dim) | |
195 | { | |
196 | /* Break out of the loop. */ | |
197 | m = NULL; | |
198 | break; | |
199 | } | |
200 | else | |
201 | { | |
202 | count[n]++; | |
7823229b | 203 | m += mstride[n]; |
58c5b409 TS |
204 | } |
205 | } | |
206 | } | |
207 | } | |
e606fb39 | 208 | |
18fe404f TK |
209 | if (ret->data == NULL) |
210 | { | |
211 | /* Setup the array descriptor. */ | |
212 | ret->dim[0].lbound = 0; | |
213 | ret->dim[0].ubound = total - 1; | |
214 | ret->dim[0].stride = 1; | |
58c5b409 | 215 | |
18fe404f TK |
216 | ret->offset = 0; |
217 | if (total == 0) | |
218 | { | |
219 | /* In this case, nothing remains to be done. */ | |
220 | ret->data = internal_malloc_size (1); | |
221 | return; | |
222 | } | |
223 | else | |
224 | ret->data = internal_malloc_size (size * total); | |
225 | } | |
226 | else | |
3d894fc3 | 227 | { |
18fe404f | 228 | /* We come here because of range checking. */ |
d8163f5c TK |
229 | index_type ret_extent; |
230 | ||
231 | ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; | |
232 | if (total != ret_extent) | |
233 | runtime_error ("Incorrect extent in return value of PACK intrinsic;" | |
234 | " is %ld, should be %ld", (long int) total, | |
235 | (long int) ret_extent); | |
3d894fc3 | 236 | } |
58c5b409 TS |
237 | } |
238 | ||
239 | rstride0 = ret->dim[0].stride * size; | |
240 | if (rstride0 == 0) | |
241 | rstride0 = size; | |
242 | sstride0 = sstride[0]; | |
243 | mstride0 = mstride[0]; | |
244 | rptr = ret->data; | |
245 | ||
3d894fc3 | 246 | while (sptr && mptr) |
6de9cd9a DN |
247 | { |
248 | /* Test this element. */ | |
249 | if (*mptr) | |
250 | { | |
251 | /* Add it. */ | |
252 | memcpy (rptr, sptr, size); | |
253 | rptr += rstride0; | |
254 | } | |
255 | /* Advance to the next element. */ | |
256 | sptr += sstride0; | |
257 | mptr += mstride0; | |
258 | count[0]++; | |
259 | n = 0; | |
260 | while (count[n] == extent[n]) | |
261 | { | |
262 | /* When we get to the end of a dimension, reset it and increment | |
263 | the next dimension. */ | |
264 | count[n] = 0; | |
265 | /* We could precalculate these products, but this is a less | |
8b6dba81 | 266 | frequently used path so probably not worth it. */ |
6de9cd9a DN |
267 | sptr -= sstride[n] * extent[n]; |
268 | mptr -= mstride[n] * extent[n]; | |
269 | n++; | |
270 | if (n >= dim) | |
271 | { | |
272 | /* Break out of the loop. */ | |
273 | sptr = NULL; | |
274 | break; | |
275 | } | |
276 | else | |
277 | { | |
278 | count[n]++; | |
279 | sptr += sstride[n]; | |
280 | mptr += mstride[n]; | |
281 | } | |
282 | } | |
283 | } | |
284 | ||
285 | /* Add any remaining elements from VECTOR. */ | |
286 | if (vector) | |
287 | { | |
288 | n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; | |
289 | nelem = ((rptr - ret->data) / rstride0); | |
290 | if (n > nelem) | |
291 | { | |
292 | sstride0 = vector->dim[0].stride * size; | |
293 | if (sstride0 == 0) | |
294 | sstride0 = size; | |
295 | ||
296 | sptr = vector->data + sstride0 * nelem; | |
297 | n -= nelem; | |
298 | while (n--) | |
299 | { | |
300 | memcpy (rptr, sptr, size); | |
301 | rptr += rstride0; | |
302 | sptr += sstride0; | |
303 | } | |
304 | } | |
305 | } | |
306 | } | |
307 | ||
7823229b RS |
308 | extern void pack (gfc_array_char *, const gfc_array_char *, |
309 | const gfc_array_l4 *, const gfc_array_char *); | |
310 | export_proto(pack); | |
7d7b8bfe | 311 | |
58c5b409 | 312 | void |
7823229b RS |
313 | pack (gfc_array_char *ret, const gfc_array_char *array, |
314 | const gfc_array_l4 *mask, const gfc_array_char *vector) | |
315 | { | |
316 | pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); | |
317 | } | |
318 | ||
319 | extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, | |
320 | const gfc_array_l4 *, const gfc_array_char *, | |
321 | GFC_INTEGER_4, GFC_INTEGER_4); | |
322 | export_proto(pack_char); | |
323 | ||
324 | void | |
325 | pack_char (gfc_array_char *ret, | |
326 | GFC_INTEGER_4 ret_length __attribute__((unused)), | |
327 | const gfc_array_char *array, const gfc_array_l4 *mask, | |
328 | const gfc_array_char *vector, GFC_INTEGER_4 array_length, | |
329 | GFC_INTEGER_4 vector_length __attribute__((unused))) | |
330 | { | |
331 | pack_internal (ret, array, mask, vector, array_length); | |
332 | } | |
333 | ||
334 | static void | |
335 | pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, | |
336 | const GFC_LOGICAL_4 *mask, const gfc_array_char *vector, | |
337 | index_type size) | |
58c5b409 TS |
338 | { |
339 | /* r.* indicates the return array. */ | |
340 | index_type rstride0; | |
341 | char *rptr; | |
342 | /* s.* indicates the source array. */ | |
343 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
344 | index_type sstride0; | |
345 | const char *sptr; | |
346 | ||
347 | index_type count[GFC_MAX_DIMENSIONS]; | |
348 | index_type extent[GFC_MAX_DIMENSIONS]; | |
349 | index_type n; | |
350 | index_type dim; | |
3d894fc3 | 351 | index_type ssize; |
58c5b409 TS |
352 | index_type nelem; |
353 | ||
58c5b409 | 354 | dim = GFC_DESCRIPTOR_RANK (array); |
3d894fc3 | 355 | ssize = 1; |
58c5b409 TS |
356 | for (n = 0; n < dim; n++) |
357 | { | |
358 | count[n] = 0; | |
359 | extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; | |
360 | sstride[n] = array->dim[n].stride * size; | |
3d894fc3 | 361 | ssize *= extent[n]; |
58c5b409 TS |
362 | } |
363 | if (sstride[0] == 0) | |
364 | sstride[0] = size; | |
365 | ||
366 | sstride0 = sstride[0]; | |
367 | sptr = array->data; | |
368 | ||
369 | if (ret->data == NULL) | |
370 | { | |
371 | /* Allocate the memory for the result. */ | |
372 | int total; | |
373 | ||
374 | if (vector != NULL) | |
375 | { | |
376 | /* The return array will have as many elements as there are | |
377 | in vector. */ | |
378 | total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; | |
379 | } | |
380 | else | |
381 | { | |
382 | if (*mask) | |
383 | { | |
384 | /* The result array will have as many elements as the input | |
385 | array. */ | |
386 | total = extent[0]; | |
387 | for (n = 1; n < dim; n++) | |
388 | total *= extent[n]; | |
389 | } | |
390 | else | |
3d894fc3 FXC |
391 | /* The result array will be empty. */ |
392 | total = 0; | |
58c5b409 TS |
393 | } |
394 | ||
395 | /* Setup the array descriptor. */ | |
396 | ret->dim[0].lbound = 0; | |
397 | ret->dim[0].ubound = total - 1; | |
398 | ret->dim[0].stride = 1; | |
efd4dc1a | 399 | ret->offset = 0; |
3d894fc3 FXC |
400 | |
401 | if (total == 0) | |
402 | { | |
403 | ret->data = internal_malloc_size (1); | |
404 | return; | |
405 | } | |
406 | else | |
407 | ret->data = internal_malloc_size (size * total); | |
58c5b409 TS |
408 | } |
409 | ||
410 | rstride0 = ret->dim[0].stride * size; | |
411 | if (rstride0 == 0) | |
412 | rstride0 = size; | |
413 | rptr = ret->data; | |
414 | ||
e606fb39 | 415 | /* The remaining possibilities are now: |
58c5b409 TS |
416 | If MASK is .TRUE., we have to copy the source array into the |
417 | result array. We then have to fill it up with elements from VECTOR. | |
418 | If MASK is .FALSE., we have to copy VECTOR into the result | |
419 | array. If VECTOR were not present we would have already returned. */ | |
420 | ||
3d894fc3 | 421 | if (*mask && ssize != 0) |
58c5b409 TS |
422 | { |
423 | while (sptr) | |
424 | { | |
425 | /* Add this element. */ | |
426 | memcpy (rptr, sptr, size); | |
427 | rptr += rstride0; | |
428 | ||
429 | /* Advance to the next element. */ | |
430 | sptr += sstride0; | |
431 | count[0]++; | |
432 | n = 0; | |
433 | while (count[n] == extent[n]) | |
434 | { | |
435 | /* When we get to the end of a dimension, reset it and | |
436 | increment the next dimension. */ | |
437 | count[n] = 0; | |
438 | /* We could precalculate these products, but this is a | |
8b6dba81 | 439 | less frequently used path so probably not worth it. */ |
58c5b409 TS |
440 | sptr -= sstride[n] * extent[n]; |
441 | n++; | |
442 | if (n >= dim) | |
443 | { | |
444 | /* Break out of the loop. */ | |
445 | sptr = NULL; | |
446 | break; | |
447 | } | |
448 | else | |
449 | { | |
450 | count[n]++; | |
451 | sptr += sstride[n]; | |
452 | } | |
453 | } | |
454 | } | |
455 | } | |
e606fb39 | 456 | |
58c5b409 TS |
457 | /* Add any remaining elements from VECTOR. */ |
458 | if (vector) | |
459 | { | |
460 | n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; | |
461 | nelem = ((rptr - ret->data) / rstride0); | |
462 | if (n > nelem) | |
463 | { | |
464 | sstride0 = vector->dim[0].stride * size; | |
465 | if (sstride0 == 0) | |
466 | sstride0 = size; | |
467 | ||
468 | sptr = vector->data + sstride0 * nelem; | |
469 | n -= nelem; | |
470 | while (n--) | |
471 | { | |
472 | memcpy (rptr, sptr, size); | |
473 | rptr += rstride0; | |
474 | sptr += sstride0; | |
475 | } | |
476 | } | |
477 | } | |
478 | } | |
7823229b RS |
479 | |
480 | extern void pack_s (gfc_array_char *ret, const gfc_array_char *array, | |
481 | const GFC_LOGICAL_4 *, const gfc_array_char *); | |
482 | export_proto(pack_s); | |
483 | ||
484 | void | |
485 | pack_s (gfc_array_char *ret, const gfc_array_char *array, | |
486 | const GFC_LOGICAL_4 *mask, const gfc_array_char *vector) | |
487 | { | |
488 | pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); | |
489 | } | |
490 | ||
491 | extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4, | |
492 | const gfc_array_char *array, const GFC_LOGICAL_4 *, | |
493 | const gfc_array_char *, GFC_INTEGER_4, | |
494 | GFC_INTEGER_4); | |
495 | export_proto(pack_s_char); | |
496 | ||
497 | void | |
498 | pack_s_char (gfc_array_char *ret, | |
499 | GFC_INTEGER_4 ret_length __attribute__((unused)), | |
500 | const gfc_array_char *array, const GFC_LOGICAL_4 *mask, | |
501 | const gfc_array_char *vector, GFC_INTEGER_4 array_length, | |
502 | GFC_INTEGER_4 vector_length __attribute__((unused))) | |
503 | { | |
504 | pack_s_internal (ret, array, mask, vector, array_length); | |
505 | } |