libgfortran/runtime/in_pack_generic.c

   1 /* Generic helper function for repacking arrays.
   2    Copyright (C) 2003-2013 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 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->base_addr == NULL)
  52     return NULL;
  53
  54   type_size = GFC_DTYPE_TYPE_SIZE(source);
  55   size = GFC_DESCRIPTOR_SIZE (source);
  56   switch (type_size)
  57     {
  58     case GFC_DTYPE_INTEGER_1:
  59     case GFC_DTYPE_LOGICAL_1:
  60     case GFC_DTYPE_DERIVED_1:
  61       return internal_pack_1 ((gfc_array_i1 *) source);
  62
  63     case GFC_DTYPE_INTEGER_2:
  64     case GFC_DTYPE_LOGICAL_2:
  65       return internal_pack_2 ((gfc_array_i2 *) source);
  66
  67     case GFC_DTYPE_INTEGER_4:
  68     case GFC_DTYPE_LOGICAL_4:
  69       return internal_pack_4 ((gfc_array_i4 *) source);
  70
  71     case GFC_DTYPE_INTEGER_8:
  72     case GFC_DTYPE_LOGICAL_8:
  73       return internal_pack_8 ((gfc_array_i8 *) source);
  74
  75 #if defined(HAVE_GFC_INTEGER_16)
  76     case GFC_DTYPE_INTEGER_16:
  77     case GFC_DTYPE_LOGICAL_16:
  78       return internal_pack_16 ((gfc_array_i16 *) source);
  79 #endif
  80     case GFC_DTYPE_REAL_4:
  81       return internal_pack_r4 ((gfc_array_r4 *) source);
  82
  83     case GFC_DTYPE_REAL_8:
  84       return internal_pack_r8 ((gfc_array_r8 *) source);
  85
  86 /* FIXME: This here is a hack, which will have to be removed when
  87    the array descriptor is reworked.  Currently, we don't store the
  88    kind value for the type, but only the size.  Because on targets with
  89    __float128, we have sizeof(logn double) == sizeof(__float128),
  90    we cannot discriminate here and have to fall back to the generic
  91    handling (which is suboptimal).  */
  92 #if !defined(GFC_REAL_16_IS_FLOAT128)
  93 # if defined (HAVE_GFC_REAL_10)
  94     case GFC_DTYPE_REAL_10:
  95       return internal_pack_r10 ((gfc_array_r10 *) source);
  96 # endif
  97
  98 # if defined (HAVE_GFC_REAL_16)
  99     case GFC_DTYPE_REAL_16:
 100       return internal_pack_r16 ((gfc_array_r16 *) source);
 101 # endif
 102 #endif
 103
 104     case GFC_DTYPE_COMPLEX_4:
 105       return internal_pack_c4 ((gfc_array_c4 *) source);
 106
 107     case GFC_DTYPE_COMPLEX_8:
 108       return internal_pack_c8 ((gfc_array_c8 *) source);
 109
 110 /* FIXME: This here is a hack, which will have to be removed when
 111    the array descriptor is reworked.  Currently, we don't store the
 112    kind value for the type, but only the size.  Because on targets with
 113    __float128, we have sizeof(logn double) == sizeof(__float128),
 114    we cannot discriminate here and have to fall back to the generic
 115    handling (which is suboptimal).  */
 116 #if !defined(GFC_REAL_16_IS_FLOAT128)
 117 # if defined (HAVE_GFC_COMPLEX_10)
 118     case GFC_DTYPE_COMPLEX_10:
 119       return internal_pack_c10 ((gfc_array_c10 *) source);
 120 # endif
 121
 122 # if defined (HAVE_GFC_COMPLEX_16)
 123     case GFC_DTYPE_COMPLEX_16:
 124       return internal_pack_c16 ((gfc_array_c16 *) source);
 125 # endif
 126 #endif
 127
 128     case GFC_DTYPE_DERIVED_2:
 129       if (GFC_UNALIGNED_2(source->base_addr))
 130         break;
 131       else
 132         return internal_pack_2 ((gfc_array_i2 *) source);
 133
 134     case GFC_DTYPE_DERIVED_4:
 135       if (GFC_UNALIGNED_4(source->base_addr))
 136         break;
 137       else
 138         return internal_pack_4 ((gfc_array_i4 *) source);
 139
 140     case GFC_DTYPE_DERIVED_8:
 141       if (GFC_UNALIGNED_8(source->base_addr))
 142         break;
 143       else
 144         return internal_pack_8 ((gfc_array_i8 *) source);
 145
 146 #ifdef HAVE_GFC_INTEGER_16
 147     case GFC_DTYPE_DERIVED_16:
 148       if (GFC_UNALIGNED_16(source->base_addr))
 149         break;
 150       else
 151         return internal_pack_16 ((gfc_array_i16 *) source);
 152 #endif
 153
 154     default:
 155       break;
 156     }
 157
 158   dim = GFC_DESCRIPTOR_RANK (source);
 159   ssize = 1;
 160   packed = 1;
 161   for (n = 0; n < dim; n++)
 162     {
 163       count[n] = 0;
 164       stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
 165       extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
 166       if (extent[n] <= 0)
 167         {
 168           /* Do nothing.  */
 169           packed = 1;
 170           break;
 171         }
 172
 173       if (ssize != stride[n])
 174         packed = 0;
 175
 176       ssize *= extent[n];
 177     }
 178
 179   if (packed)
 180     return source->base_addr;
 181
 182    /* Allocate storage for the destination.  */
 183   destptr = xmalloc (ssize * size);
 184   dest = (char *)destptr;
 185   src = source->base_addr;
 186   stride0 = stride[0] * size;
 187
 188   while (src)
 189     {
 190       /* Copy the data.  */
 191       memcpy(dest, src, size);
 192       /* Advance to the next element.  */
 193       dest += size;
 194       src += stride0;
 195       count[0]++;
 196       /* Advance to the next source element.  */
 197       n = 0;
 198       while (count[n] == extent[n])
 199         {
 200           /* When we get to the end of a dimension, reset it and increment
 201              the next dimension.  */
 202           count[n] = 0;
 203           /* We could precalculate these products, but this is a less
 204              frequently used path so probably not worth it.  */
 205           src -= stride[n] * extent[n] * size;
 206           n++;
 207           if (n == dim)
 208             {
 209               src = NULL;
 210               break;
 211             }
 212           else
 213             {
 214               count[n]++;
 215               src += stride[n] * size;
 216             }
 217         }
 218     }
 219   return destptr;
 220 }