OSDN Git Service

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