libgfortran/runtime/in_pack_generic.c

   1 /* Generic helper function for repacking arrays.
   2    Copyright (C) 2003-2018 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 <string.h>
  28
  29 extern void *internal_pack (gfc_array_char *);
  30 export_proto(internal_pack);
  31
  32 void *
  33 internal_pack (gfc_array_char * source)
  34 {
  35   index_type count[GFC_MAX_DIMENSIONS];
  36   index_type extent[GFC_MAX_DIMENSIONS];
  37   index_type stride[GFC_MAX_DIMENSIONS];
  38   index_type stride0;
  39   index_type dim;
  40   index_type ssize;
  41   const char *src;
  42   char *dest;
  43   void *destptr;
  44   int n;
  45   int packed;
  46   index_type size;
  47   index_type type_size;
  48
  49   if (source->base_addr == NULL)
  50     return NULL;
  51
  52   type_size = GFC_DTYPE_TYPE_SIZE(source);
  53   size = GFC_DESCRIPTOR_SIZE (source);
  54   switch (type_size)
  55     {
  56     case GFC_DTYPE_INTEGER_1:
  57     case GFC_DTYPE_LOGICAL_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 /* FIXME: This here is a hack, which will have to be removed when
  84    the array descriptor is reworked.  Currently, we don't store the
  85    kind value for the type, but only the size.  Because on targets with
  86    __float128, we have sizeof(logn double) == sizeof(__float128),
  87    we cannot discriminate here and have to fall back to the generic
  88    handling (which is suboptimal).  */
  89 #if !defined(GFC_REAL_16_IS_FLOAT128)
  90 # if defined (HAVE_GFC_REAL_10)
  91     case GFC_DTYPE_REAL_10:
  92       return internal_pack_r10 ((gfc_array_r10 *) source);
  93 # endif
  94
  95 # if defined (HAVE_GFC_REAL_16)
  96     case GFC_DTYPE_REAL_16:
  97       return internal_pack_r16 ((gfc_array_r16 *) source);
  98 # endif
  99 #endif
 100
 101     case GFC_DTYPE_COMPLEX_4:
 102       return internal_pack_c4 ((gfc_array_c4 *) source);
 103
 104     case GFC_DTYPE_COMPLEX_8:
 105       return internal_pack_c8 ((gfc_array_c8 *) source);
 106
 107 /* FIXME: This here is a hack, which will have to be removed when
 108    the array descriptor is reworked.  Currently, we don't store the
 109    kind value for the type, but only the size.  Because on targets with
 110    __float128, we have sizeof(logn double) == sizeof(__float128),
 111    we cannot discriminate here and have to fall back to the generic
 112    handling (which is suboptimal).  */
 113 #if !defined(GFC_REAL_16_IS_FLOAT128)
 114 # if defined (HAVE_GFC_COMPLEX_10)
 115     case GFC_DTYPE_COMPLEX_10:
 116       return internal_pack_c10 ((gfc_array_c10 *) source);
 117 # endif
 118
 119 # if defined (HAVE_GFC_COMPLEX_16)
 120     case GFC_DTYPE_COMPLEX_16:
 121       return internal_pack_c16 ((gfc_array_c16 *) source);
 122 # endif
 123 #endif
 124
 125     default:
 126       break;
 127     }
 128
 129   switch(GFC_DESCRIPTOR_SIZE (source))
 130     {
 131     case 1:
 132       return internal_pack_1 ((gfc_array_i1 *) source);
 133
 134     case 2:
 135       if (GFC_UNALIGNED_2(source->base_addr))
 136         break;
 137       else
 138         return internal_pack_2 ((gfc_array_i2 *) source);
 139
 140     case 4:
 141       if (GFC_UNALIGNED_4(source->base_addr))
 142         break;
 143       else
 144         return internal_pack_4 ((gfc_array_i4 *) source);
 145
 146     case 8:
 147       if (GFC_UNALIGNED_8(source->base_addr))
 148         break;
 149       else
 150         return internal_pack_8 ((gfc_array_i8 *) source);
 151
 152 #ifdef HAVE_GFC_INTEGER_16
 153     case 16:
 154       if (GFC_UNALIGNED_16(source->base_addr))
 155         break;
 156       else
 157         return internal_pack_16 ((gfc_array_i16 *) source);
 158 #endif
 159     default:
 160       break;
 161     }
 162
 163   dim = GFC_DESCRIPTOR_RANK (source);
 164   ssize = 1;
 165   packed = 1;
 166   for (n = 0; n < dim; n++)
 167     {
 168       count[n] = 0;
 169       stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
 170       extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
 171       if (extent[n] <= 0)
 172         {
 173           /* Do nothing.  */
 174           packed = 1;
 175           break;
 176         }
 177
 178       if (ssize != stride[n])
 179         packed = 0;
 180
 181       ssize *= extent[n];
 182     }
 183
 184   if (packed)
 185     return source->base_addr;
 186
 187    /* Allocate storage for the destination.  */
 188   destptr = xmallocarray (ssize, size);
 189   dest = (char *)destptr;
 190   src = source->base_addr;
 191   stride0 = stride[0] * size;
 192
 193   while (src)
 194     {
 195       /* Copy the data.  */
 196       memcpy(dest, src, size);
 197       /* Advance to the next element.  */
 198       dest += size;
 199       src += stride0;
 200       count[0]++;
 201       /* Advance to the next source element.  */
 202       n = 0;
 203       while (count[n] == extent[n])
 204         {
 205           /* When we get to the end of a dimension, reset it and increment
 206              the next dimension.  */
 207           count[n] = 0;
 208           /* We could precalculate these products, but this is a less
 209              frequently used path so probably not worth it.  */
 210           src -= stride[n] * extent[n] * size;
 211           n++;
 212           if (n == dim)
 213             {
 214               src = NULL;
 215               break;
 216             }
 217           else
 218             {
 219               count[n]++;
 220               src += stride[n] * size;
 221             }
 222         }
 223     }
 224   return destptr;
 225 }