OSDN Git Service

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