OSDN Git Service

bb4abaeae4b4b895b3543d9ea664e0d75730e89e
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / pack_generic.c
1 /* Generic implementation of the PACK intrinsic
2    Copyright (C) 2002, 2004, 2005, 2006, 2007 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 "libgfortran.h"
32 #include <stdlib.h>
33 #include <assert.h>
34 #include <string.h>
35
36 /* PACK is specified as follows:
37
38    13.14.80 PACK (ARRAY, MASK, [VECTOR])
39
40    Description: Pack an array into an array of rank one under the
41    control of a mask.
42
43    Class: Transformational function.
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
51               with the value true, VECTOR shall have at least as many
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,
71    VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
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
76 static void
77 pack_internal (gfc_array_char *ret, const gfc_array_char *array,
78                const gfc_array_l1 *mask, const gfc_array_char *vector,
79                index_type size)
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;
91   const GFC_LOGICAL_1 *mptr;
92
93   index_type count[GFC_MAX_DIMENSIONS];
94   index_type extent[GFC_MAX_DIMENSIONS];
95   int zero_sized;
96   index_type n;
97   index_type dim;
98   index_type nelem;
99   index_type total;
100   int mask_kind;
101
102   dim = GFC_DESCRIPTOR_RANK (array);
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
125   zero_sized = 0;
126   for (n = 0; n < dim; n++)
127     {
128       count[n] = 0;
129       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
130       if (extent[n] <= 0)
131        zero_sized = 1;
132       sstride[n] = array->dim[n].stride * size;
133       mstride[n] = mask->dim[n].stride * mask_kind;
134     }
135   if (sstride[0] == 0)
136     sstride[0] = size;
137   if (mstride[0] == 0)
138     mstride[0] = mask_kind;
139
140   if (ret->data == NULL || compile_options.bounds_check)
141     {
142       /* Count the elements, either for allocating memory or
143          for bounds checking.  */
144
145       if (vector != NULL)
146         {
147           /* The return array will have as many
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.  */
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
163              value instead of a pointer to it.
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
168           const GFC_LOGICAL_1 *m = mptr;
169
170           total = 0;
171           if (zero_sized)
172             m = NULL;
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
190                      less frequently used path so probably not worth
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]++;
203                       m += mstride[n];
204                     }
205                 }
206             }
207         }
208
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;
215
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 
227         {
228           /* We come here because of range checking.  */
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);
236         }
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
246   while (sptr && mptr)
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
266              frequently used path so probably not worth it.  */
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
308 extern void pack (gfc_array_char *, const gfc_array_char *,
309                   const gfc_array_l1 *, const gfc_array_char *);
310 export_proto(pack);
311
312 void
313 pack (gfc_array_char *ret, const gfc_array_char *array,
314       const gfc_array_l1 *mask, const gfc_array_char *vector)
315 {
316   index_type type_size;
317   index_type size;
318
319   type_size = GFC_DTYPE_TYPE_SIZE(array);
320
321   switch(type_size)
322     {
323     case GFC_DTYPE_LOGICAL_1:
324     case GFC_DTYPE_INTEGER_1:
325     case GFC_DTYPE_DERIVED_1:
326       pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
327                (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
328       return;
329
330     case GFC_DTYPE_LOGICAL_2:
331     case GFC_DTYPE_INTEGER_2:
332       pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
333                (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
334       return;
335
336     case GFC_DTYPE_LOGICAL_4:
337     case GFC_DTYPE_INTEGER_4:
338
339       pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
340                (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
341       return;
342
343     case GFC_DTYPE_LOGICAL_8:
344     case GFC_DTYPE_INTEGER_8:
345
346       pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
347                (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
348       return;
349
350 #ifdef HAVE_GFC_INTEGER_16
351     case GFC_DTYPE_LOGICAL_16:
352     case GFC_DTYPE_INTEGER_16:
353
354       pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
355                 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
356       return;
357 #endif
358     case GFC_DTYPE_REAL_4:
359       pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
360                (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
361       return;
362
363     case GFC_DTYPE_REAL_8:
364       pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
365                (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
366       return;
367
368 #ifdef HAVE_GFC_REAL_10
369     case GFC_DTYPE_REAL_10:
370       pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
371                 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
372       return;
373 #endif
374
375 #ifdef HAVE_GFC_REAL_16
376     case GFC_DTYPE_REAL_16:
377       pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
378                 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
379       return;
380 #endif
381     case GFC_DTYPE_COMPLEX_4:
382       pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
383                (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
384       return;
385
386     case GFC_DTYPE_COMPLEX_8:
387       pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
388                (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
389       return;
390
391 #ifdef HAVE_GFC_COMPLEX_10
392     case GFC_DTYPE_COMPLEX_10:
393       pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
394                 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
395       return;
396 #endif
397
398 #ifdef HAVE_GFC_COMPLEX_16
399     case GFC_DTYPE_COMPLEX_16:
400       pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
401                 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
402       return;
403 #endif
404
405       /* For derived types, let's check the actual alignment of the
406          data pointers.  If they are aligned, we can safely call
407          the unpack functions.  */
408
409     case GFC_DTYPE_DERIVED_2:
410       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data)
411           || GFC_UNALIGNED_2(vector->data))
412         break;
413       else
414         {
415           pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
416                    (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
417           return;
418         }
419
420     case GFC_DTYPE_DERIVED_4:
421       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data)
422           || GFC_UNALIGNED_4(vector->data))
423         break;
424       else
425         {
426           pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
427                    (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
428           return;
429         }
430
431     case GFC_DTYPE_DERIVED_8:
432       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data)
433           || GFC_UNALIGNED_8(vector->data))
434         break;
435       else
436         {
437           pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
438                    (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
439         }
440
441 #ifdef HAVE_GFC_INTEGER_16
442     case GFC_DTYPE_DERIVED_16:
443       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data)
444           || GFC_UNALIGNED_16(vector->data))
445         break;
446       else
447         {
448           pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
449                    (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
450           return;
451         }
452 #endif
453
454     }
455
456   size = GFC_DESCRIPTOR_SIZE (array);
457   pack_internal (ret, array, mask, vector, size);
458 }
459
460 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
461                        const gfc_array_l1 *, const gfc_array_char *,
462                        GFC_INTEGER_4, GFC_INTEGER_4);
463 export_proto(pack_char);
464
465 void
466 pack_char (gfc_array_char *ret,
467            GFC_INTEGER_4 ret_length __attribute__((unused)),
468            const gfc_array_char *array, const gfc_array_l1 *mask,
469            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
470            GFC_INTEGER_4 vector_length __attribute__((unused)))
471 {
472   pack_internal (ret, array, mask, vector, array_length);
473 }
474
475 static void
476 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
477                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
478                  index_type size)
479 {
480   /* r.* indicates the return array.  */
481   index_type rstride0;
482   char *rptr;
483   /* s.* indicates the source array.  */
484   index_type sstride[GFC_MAX_DIMENSIONS];
485   index_type sstride0;
486   const char *sptr;
487
488   index_type count[GFC_MAX_DIMENSIONS];
489   index_type extent[GFC_MAX_DIMENSIONS];
490   index_type n;
491   index_type dim;
492   index_type ssize;
493   index_type nelem;
494   index_type total;
495
496   dim = GFC_DESCRIPTOR_RANK (array);
497   ssize = 1;
498   for (n = 0; n < dim; n++)
499     {
500       count[n] = 0;
501       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
502       if (extent[n] < 0)
503         extent[n] = 0;
504
505       sstride[n] = array->dim[n].stride * size;
506       ssize *= extent[n];
507     }
508   if (sstride[0] == 0)
509     sstride[0] = size;
510
511   sstride0 = sstride[0];
512
513   if (ssize != 0)
514     sptr = array->data;
515   else
516     sptr = NULL;
517
518   if (ret->data == NULL)
519     {
520       /* Allocate the memory for the result.  */
521
522       if (vector != NULL)
523         {
524           /* The return array will have as many elements as there are
525              in vector.  */
526           total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
527           if (total <= 0)
528             {
529               total = 0;
530               vector = NULL;
531             }
532         }
533       else
534         {
535           if (*mask)
536             {
537               /* The result array will have as many elements as the input
538                  array.  */
539               total = extent[0];
540               for (n = 1; n < dim; n++)
541                 total *= extent[n];
542             }
543           else
544             /* The result array will be empty.  */
545             total = 0;
546         }
547
548       /* Setup the array descriptor.  */
549       ret->dim[0].lbound = 0;
550       ret->dim[0].ubound = total - 1;
551       ret->dim[0].stride = 1;
552       ret->offset = 0;
553
554       if (total == 0)
555         {
556           ret->data = internal_malloc_size (1);
557           return;
558         }
559       else
560         ret->data = internal_malloc_size (size * total);
561     }
562
563   rstride0 = ret->dim[0].stride * size;
564   if (rstride0 == 0)
565     rstride0 = size;
566   rptr = ret->data;
567
568   /* The remaining possibilities are now:
569        If MASK is .TRUE., we have to copy the source array into the
570      result array. We then have to fill it up with elements from VECTOR.
571        If MASK is .FALSE., we have to copy VECTOR into the result
572      array. If VECTOR were not present we would have already returned.  */
573
574   if (*mask && ssize != 0)
575     {
576       while (sptr)
577         {
578           /* Add this element.  */
579           memcpy (rptr, sptr, size);
580           rptr += rstride0;
581
582           /* Advance to the next element.  */
583           sptr += sstride0;
584           count[0]++;
585           n = 0;
586           while (count[n] == extent[n])
587             {
588               /* When we get to the end of a dimension, reset it and
589                  increment the next dimension.  */
590               count[n] = 0;
591               /* We could precalculate these products, but this is a
592                  less frequently used path so probably not worth it.  */
593               sptr -= sstride[n] * extent[n];
594               n++;
595               if (n >= dim)
596                 {
597                   /* Break out of the loop.  */
598                   sptr = NULL;
599                   break;
600                 }
601               else
602                 {
603                   count[n]++;
604                   sptr += sstride[n];
605                 }
606             }
607         }
608     }
609
610   /* Add any remaining elements from VECTOR.  */
611   if (vector)
612     {
613       n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
614       nelem = ((rptr - ret->data) / rstride0);
615       if (n > nelem)
616         {
617           sstride0 = vector->dim[0].stride * size;
618           if (sstride0 == 0)
619             sstride0 = size;
620
621           sptr = vector->data + sstride0 * nelem;
622           n -= nelem;
623           while (n--)
624             {
625               memcpy (rptr, sptr, size);
626               rptr += rstride0;
627               sptr += sstride0;
628             }
629         }
630     }
631 }
632
633 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
634                     const GFC_LOGICAL_4 *, const gfc_array_char *);
635 export_proto(pack_s);
636
637 void
638 pack_s (gfc_array_char *ret, const gfc_array_char *array,
639         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
640 {
641   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
642 }
643
644 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
645                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
646                          const gfc_array_char *, GFC_INTEGER_4,
647                          GFC_INTEGER_4);
648 export_proto(pack_s_char);
649
650 void
651 pack_s_char (gfc_array_char *ret,
652              GFC_INTEGER_4 ret_length __attribute__((unused)),
653              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
654              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
655              GFC_INTEGER_4 vector_length __attribute__((unused)))
656 {
657   pack_s_internal (ret, array, mask, vector, array_length);
658 }