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