OSDN Git Service

2009-08-30 Thomas Koenig <tkoenig@gcc.gnu.org>
[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 || unlikely (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           total = count_0 (mask);
151         }
152
153       if (ret->data == NULL)
154         {
155           /* Setup the array descriptor.  */
156           GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
157
158           ret->offset = 0;
159           if (total == 0)
160             {
161               /* In this case, nothing remains to be done.  */
162               ret->data = internal_malloc_size (1);
163               return;
164             }
165           else
166             ret->data = internal_malloc_size (size * total);
167         }
168       else 
169         {
170           /* We come here because of range checking.  */
171           index_type ret_extent;
172
173           ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
174           if (total != ret_extent)
175             runtime_error ("Incorrect extent in return value of PACK intrinsic;"
176                            " is %ld, should be %ld", (long int) total,
177                            (long int) ret_extent);
178         }
179     }
180
181   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
182   if (rstride0 == 0)
183     rstride0 = size;
184   sstride0 = sstride[0];
185   mstride0 = mstride[0];
186   rptr = ret->data;
187
188   while (sptr && mptr)
189     {
190       /* Test this element.  */
191       if (*mptr)
192         {
193           /* Add it.  */
194           memcpy (rptr, sptr, size);
195           rptr += rstride0;
196         }
197       /* Advance to the next element.  */
198       sptr += sstride0;
199       mptr += mstride0;
200       count[0]++;
201       n = 0;
202       while (count[n] == extent[n])
203         {
204           /* When we get to the end of a dimension, reset it and increment
205              the next dimension.  */
206           count[n] = 0;
207           /* We could precalculate these products, but this is a less
208              frequently used path so probably not worth it.  */
209           sptr -= sstride[n] * extent[n];
210           mptr -= mstride[n] * extent[n];
211           n++;
212           if (n >= dim)
213             {
214               /* Break out of the loop.  */
215               sptr = NULL;
216               break;
217             }
218           else
219             {
220               count[n]++;
221               sptr += sstride[n];
222               mptr += mstride[n];
223             }
224         }
225     }
226
227   /* Add any remaining elements from VECTOR.  */
228   if (vector)
229     {
230       n = GFC_DESCRIPTOR_EXTENT(vector,0);
231       nelem = ((rptr - ret->data) / rstride0);
232       if (n > nelem)
233         {
234           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
235           if (sstride0 == 0)
236             sstride0 = size;
237
238           sptr = vector->data + sstride0 * nelem;
239           n -= nelem;
240           while (n--)
241             {
242               memcpy (rptr, sptr, size);
243               rptr += rstride0;
244               sptr += sstride0;
245             }
246         }
247     }
248 }
249
250 extern void pack (gfc_array_char *, const gfc_array_char *,
251                   const gfc_array_l1 *, const gfc_array_char *);
252 export_proto(pack);
253
254 void
255 pack (gfc_array_char *ret, const gfc_array_char *array,
256       const gfc_array_l1 *mask, const gfc_array_char *vector)
257 {
258   index_type type_size;
259   index_type size;
260
261   type_size = GFC_DTYPE_TYPE_SIZE(array);
262
263   switch(type_size)
264     {
265     case GFC_DTYPE_LOGICAL_1:
266     case GFC_DTYPE_INTEGER_1:
267     case GFC_DTYPE_DERIVED_1:
268       pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
269                (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
270       return;
271
272     case GFC_DTYPE_LOGICAL_2:
273     case GFC_DTYPE_INTEGER_2:
274       pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
275                (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
276       return;
277
278     case GFC_DTYPE_LOGICAL_4:
279     case GFC_DTYPE_INTEGER_4:
280
281       pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
282                (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
283       return;
284
285     case GFC_DTYPE_LOGICAL_8:
286     case GFC_DTYPE_INTEGER_8:
287
288       pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
289                (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
290       return;
291
292 #ifdef HAVE_GFC_INTEGER_16
293     case GFC_DTYPE_LOGICAL_16:
294     case GFC_DTYPE_INTEGER_16:
295
296       pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
297                 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
298       return;
299 #endif
300     case GFC_DTYPE_REAL_4:
301       pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
302                (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
303       return;
304
305     case GFC_DTYPE_REAL_8:
306       pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
307                (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
308       return;
309
310 #ifdef HAVE_GFC_REAL_10
311     case GFC_DTYPE_REAL_10:
312       pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
313                 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
314       return;
315 #endif
316
317 #ifdef HAVE_GFC_REAL_16
318     case GFC_DTYPE_REAL_16:
319       pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
320                 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
321       return;
322 #endif
323     case GFC_DTYPE_COMPLEX_4:
324       pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
325                (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
326       return;
327
328     case GFC_DTYPE_COMPLEX_8:
329       pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
330                (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
331       return;
332
333 #ifdef HAVE_GFC_COMPLEX_10
334     case GFC_DTYPE_COMPLEX_10:
335       pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
336                 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
337       return;
338 #endif
339
340 #ifdef HAVE_GFC_COMPLEX_16
341     case GFC_DTYPE_COMPLEX_16:
342       pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
343                 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
344       return;
345 #endif
346
347       /* For derived types, let's check the actual alignment of the
348          data pointers.  If they are aligned, we can safely call
349          the unpack functions.  */
350
351     case GFC_DTYPE_DERIVED_2:
352       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data)
353           || GFC_UNALIGNED_2(vector->data))
354         break;
355       else
356         {
357           pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
358                    (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
359           return;
360         }
361
362     case GFC_DTYPE_DERIVED_4:
363       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data)
364           || GFC_UNALIGNED_4(vector->data))
365         break;
366       else
367         {
368           pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
369                    (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
370           return;
371         }
372
373     case GFC_DTYPE_DERIVED_8:
374       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data)
375           || GFC_UNALIGNED_8(vector->data))
376         break;
377       else
378         {
379           pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
380                    (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
381         }
382
383 #ifdef HAVE_GFC_INTEGER_16
384     case GFC_DTYPE_DERIVED_16:
385       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data)
386           || GFC_UNALIGNED_16(vector->data))
387         break;
388       else
389         {
390           pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
391                    (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
392           return;
393         }
394 #endif
395
396     }
397
398   size = GFC_DESCRIPTOR_SIZE (array);
399   pack_internal (ret, array, mask, vector, size);
400 }
401
402
403 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
404                        const gfc_array_l1 *, const gfc_array_char *,
405                        GFC_INTEGER_4, GFC_INTEGER_4);
406 export_proto(pack_char);
407
408 void
409 pack_char (gfc_array_char *ret,
410            GFC_INTEGER_4 ret_length __attribute__((unused)),
411            const gfc_array_char *array, const gfc_array_l1 *mask,
412            const gfc_array_char *vector, GFC_INTEGER_4 array_length,
413            GFC_INTEGER_4 vector_length __attribute__((unused)))
414 {
415   pack_internal (ret, array, mask, vector, array_length);
416 }
417
418
419 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
420                         const gfc_array_l1 *, const gfc_array_char *,
421                         GFC_INTEGER_4, GFC_INTEGER_4);
422 export_proto(pack_char4);
423
424 void
425 pack_char4 (gfc_array_char *ret,
426             GFC_INTEGER_4 ret_length __attribute__((unused)),
427             const gfc_array_char *array, const gfc_array_l1 *mask,
428             const gfc_array_char *vector, GFC_INTEGER_4 array_length,
429             GFC_INTEGER_4 vector_length __attribute__((unused)))
430 {
431   pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t));
432 }
433
434
435 static void
436 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
437                  const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
438                  index_type size)
439 {
440   /* r.* indicates the return array.  */
441   index_type rstride0;
442   char *rptr;
443   /* s.* indicates the source array.  */
444   index_type sstride[GFC_MAX_DIMENSIONS];
445   index_type sstride0;
446   const char *sptr;
447
448   index_type count[GFC_MAX_DIMENSIONS];
449   index_type extent[GFC_MAX_DIMENSIONS];
450   index_type n;
451   index_type dim;
452   index_type ssize;
453   index_type nelem;
454   index_type total;
455
456   dim = GFC_DESCRIPTOR_RANK (array);
457   ssize = 1;
458   for (n = 0; n < dim; n++)
459     {
460       count[n] = 0;
461       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
462       if (extent[n] < 0)
463         extent[n] = 0;
464
465       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
466       ssize *= extent[n];
467     }
468   if (sstride[0] == 0)
469     sstride[0] = size;
470
471   sstride0 = sstride[0];
472
473   if (ssize != 0)
474     sptr = array->data;
475   else
476     sptr = NULL;
477
478   if (ret->data == NULL)
479     {
480       /* Allocate the memory for the result.  */
481
482       if (vector != NULL)
483         {
484           /* The return array will have as many elements as there are
485              in vector.  */
486           total = GFC_DESCRIPTOR_EXTENT(vector,0);
487           if (total <= 0)
488             {
489               total = 0;
490               vector = NULL;
491             }
492         }
493       else
494         {
495           if (*mask)
496             {
497               /* The result array will have as many elements as the input
498                  array.  */
499               total = extent[0];
500               for (n = 1; n < dim; n++)
501                 total *= extent[n];
502             }
503           else
504             /* The result array will be empty.  */
505             total = 0;
506         }
507
508       /* Setup the array descriptor.  */
509       GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
510
511       ret->offset = 0;
512
513       if (total == 0)
514         {
515           ret->data = internal_malloc_size (1);
516           return;
517         }
518       else
519         ret->data = internal_malloc_size (size * total);
520     }
521
522   rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
523   if (rstride0 == 0)
524     rstride0 = size;
525   rptr = ret->data;
526
527   /* The remaining possibilities are now:
528        If MASK is .TRUE., we have to copy the source array into the
529      result array. We then have to fill it up with elements from VECTOR.
530        If MASK is .FALSE., we have to copy VECTOR into the result
531      array. If VECTOR were not present we would have already returned.  */
532
533   if (*mask && ssize != 0)
534     {
535       while (sptr)
536         {
537           /* Add this element.  */
538           memcpy (rptr, sptr, size);
539           rptr += rstride0;
540
541           /* Advance to the next element.  */
542           sptr += sstride0;
543           count[0]++;
544           n = 0;
545           while (count[n] == extent[n])
546             {
547               /* When we get to the end of a dimension, reset it and
548                  increment the next dimension.  */
549               count[n] = 0;
550               /* We could precalculate these products, but this is a
551                  less frequently used path so probably not worth it.  */
552               sptr -= sstride[n] * extent[n];
553               n++;
554               if (n >= dim)
555                 {
556                   /* Break out of the loop.  */
557                   sptr = NULL;
558                   break;
559                 }
560               else
561                 {
562                   count[n]++;
563                   sptr += sstride[n];
564                 }
565             }
566         }
567     }
568
569   /* Add any remaining elements from VECTOR.  */
570   if (vector)
571     {
572       n = GFC_DESCRIPTOR_EXTENT(vector,0);
573       nelem = ((rptr - ret->data) / rstride0);
574       if (n > nelem)
575         {
576           sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
577           if (sstride0 == 0)
578             sstride0 = size;
579
580           sptr = vector->data + sstride0 * nelem;
581           n -= nelem;
582           while (n--)
583             {
584               memcpy (rptr, sptr, size);
585               rptr += rstride0;
586               sptr += sstride0;
587             }
588         }
589     }
590 }
591
592 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
593                     const GFC_LOGICAL_4 *, const gfc_array_char *);
594 export_proto(pack_s);
595
596 void
597 pack_s (gfc_array_char *ret, const gfc_array_char *array,
598         const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
599 {
600   pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
601 }
602
603
604 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
605                          const gfc_array_char *array, const GFC_LOGICAL_4 *,
606                          const gfc_array_char *, GFC_INTEGER_4,
607                          GFC_INTEGER_4);
608 export_proto(pack_s_char);
609
610 void
611 pack_s_char (gfc_array_char *ret,
612              GFC_INTEGER_4 ret_length __attribute__((unused)),
613              const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
614              const gfc_array_char *vector, GFC_INTEGER_4 array_length,
615              GFC_INTEGER_4 vector_length __attribute__((unused)))
616 {
617   pack_s_internal (ret, array, mask, vector, array_length);
618 }
619
620
621 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4,
622                           const gfc_array_char *array, const GFC_LOGICAL_4 *,
623                           const gfc_array_char *, GFC_INTEGER_4,
624                           GFC_INTEGER_4);
625 export_proto(pack_s_char4);
626
627 void
628 pack_s_char4 (gfc_array_char *ret,
629               GFC_INTEGER_4 ret_length __attribute__((unused)),
630               const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
631               const gfc_array_char *vector, GFC_INTEGER_4 array_length,
632               GFC_INTEGER_4 vector_length __attribute__((unused)))
633 {
634   pack_s_internal (ret, array, mask, vector,
635                    array_length * sizeof (gfc_char4_t));
636 }