libgfortran/runtime/in_pack_generic.c

   1 /* Generic helper function for repacking arrays.
   2    Copyright 2003, 2004, 2005, 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 Libgfortran 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 extern void *internal_pack (gfc_array_char *);
  32 export_proto(internal_pack);
  33
  34 void *
  35 internal_pack (gfc_array_char * source)
  36 {
  37   index_type count[GFC_MAX_DIMENSIONS];
  38   index_type extent[GFC_MAX_DIMENSIONS];
  39   index_type stride[GFC_MAX_DIMENSIONS];
  40   index_type stride0;
  41   index_type dim;
  42   index_type ssize;
  43   const char *src;
  44   char *dest;
  45   void *destptr;
  46   int n;
  47   int packed;
  48   index_type size;
  49   index_type type_size;
  50
  51   if (source->dim[0].stride == 0)
  52     {
  53       source->dim[0].stride = 1;
  54       return source->data;
  55     }
  56
  57   type_size = GFC_DTYPE_TYPE_SIZE(source);
  58   size = GFC_DESCRIPTOR_SIZE (source);
  59   switch (type_size)
  60     {
  61     case GFC_DTYPE_INTEGER_1:
  62     case GFC_DTYPE_LOGICAL_1:
  63     case GFC_DTYPE_DERIVED_1:
  64       return internal_pack_1 ((gfc_array_i1 *) source);
  65
  66     case GFC_DTYPE_INTEGER_2:
  67     case GFC_DTYPE_LOGICAL_2:
  68       return internal_pack_2 ((gfc_array_i2 *) source);
  69
  70     case GFC_DTYPE_INTEGER_4:
  71     case GFC_DTYPE_LOGICAL_4:
  72       return internal_pack_4 ((gfc_array_i4 *) source);
  73
  74     case GFC_DTYPE_INTEGER_8:
  75     case GFC_DTYPE_LOGICAL_8:
  76       return internal_pack_8 ((gfc_array_i8 *) source);
  77
  78 #if defined(HAVE_GFC_INTEGER_16)
  79     case GFC_DTYPE_INTEGER_16:
  80     case GFC_DTYPE_LOGICAL_16:
  81       return internal_pack_16 ((gfc_array_i16 *) source);
  82 #endif
  83     case GFC_DTYPE_REAL_4:
  84       return internal_pack_r4 ((gfc_array_r4 *) source);
  85
  86     case GFC_DTYPE_REAL_8:
  87       return internal_pack_r8 ((gfc_array_r8 *) source);
  88
  89 #if defined (HAVE_GFC_REAL_10)
  90     case GFC_DTYPE_REAL_10:
  91       return internal_pack_r10 ((gfc_array_r10 *) source);
  92 #endif
  93
  94 #if defined (HAVE_GFC_REAL_16)
  95     case GFC_DTYPE_REAL_16:
  96       return internal_pack_r16 ((gfc_array_r16 *) source);
  97 #endif
  98     case GFC_DTYPE_COMPLEX_4:
  99       return internal_pack_c4 ((gfc_array_c4 *) source);
 100
 101     case GFC_DTYPE_COMPLEX_8:
 102       return internal_pack_c8 ((gfc_array_c8 *) source);
 103
 104 #if defined (HAVE_GFC_COMPLEX_10)
 105     case GFC_DTYPE_COMPLEX_10:
 106       return internal_pack_c10 ((gfc_array_c10 *) source);
 107 #endif
 108
 109 #if defined (HAVE_GFC_COMPLEX_16)
 110     case GFC_DTYPE_COMPLEX_16:
 111       return internal_pack_c16 ((gfc_array_c16 *) source);
 112 #endif
 113
 114     case GFC_DTYPE_DERIVED_2:
 115       if (GFC_UNALIGNED_2(source->data))
 116         break;
 117       else
 118         return internal_pack_2 ((gfc_array_i2 *) source);
 119
 120     case GFC_DTYPE_DERIVED_4:
 121       if (GFC_UNALIGNED_4(source->data))
 122         break;
 123       else
 124         return internal_pack_4 ((gfc_array_i4 *) source);
 125
 126     case GFC_DTYPE_DERIVED_8:
 127       if (GFC_UNALIGNED_8(source->data))
 128         break;
 129       else
 130         return internal_pack_8 ((gfc_array_i8 *) source);
 131
 132 #ifdef HAVE_GFC_INTEGER_16
 133     case GFC_DTYPE_DERIVED_16:
 134       if (GFC_UNALIGNED_16(source->data))
 135         break;
 136       else
 137         return internal_pack_16 ((gfc_array_i16 *) source);
 138 #endif
 139
 140     default:
 141       break;
 142     }
 143
 144   dim = GFC_DESCRIPTOR_RANK (source);
 145   ssize = 1;
 146   packed = 1;
 147   for (n = 0; n < dim; n++)
 148     {
 149       count[n] = 0;
 150       stride[n] = source->dim[n].stride;
 151       extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 152       if (extent[n] <= 0)
 153         {
 154           /* Do nothing.  */
 155           packed = 1;
 156           break;
 157         }
 158
 159       if (ssize != stride[n])
 160         packed = 0;
 161
 162       ssize *= extent[n];
 163     }
 164
 165   if (packed)
 166     return source->data;
 167
 168    /* Allocate storage for the destination.  */
 169   destptr = internal_malloc_size (ssize * size);
 170   dest = (char *)destptr;
 171   src = source->data;
 172   stride0 = stride[0] * size;
 173
 174   while (src)
 175     {
 176       /* Copy the data.  */
 177       memcpy(dest, src, size);
 178       /* Advance to the next element.  */
 179       dest += size;
 180       src += stride0;
 181       count[0]++;
 182       /* Advance to the next source element.  */
 183       n = 0;
 184       while (count[n] == extent[n])
 185         {
 186           /* When we get to the end of a dimension, reset it and increment
 187              the next dimension.  */
 188           count[n] = 0;
 189           /* We could precalculate these products, but this is a less
 190              frequently used path so probably not worth it.  */
 191           src -= stride[n] * extent[n] * size;
 192           n++;
 193           if (n == dim)
 194             {
 195               src = NULL;
 196               break;
 197             }
 198           else
 199             {
 200               count[n]++;
 201               src += stride[n] * size;
 202             }
 203         }
 204     }
 205   return destptr;
 206 }