1`/* Helper function for repacking arrays.
2   Copyright (C) 2003-2016 Free Software Foundation, Inc.
3   Contributed by Paul Brook <paul@nowt.org>
4
5This file is part of the GNU Fortran runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Libgfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see 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
30include(iparm.m4)dnl
31
32`#if defined (HAVE_'rtype_name`)
33
34/* Allocates a block of memory with internal_malloc if the array needs
35   repacking.  */
36'
37dnl The kind (ie size) is used to name the function for logicals, integers
38dnl and reals.  For complex, it's c4 or c8.
39rtype_name` *
40internal_pack_'rtype_ccode` ('rtype` * source)
41{
42  index_type count[GFC_MAX_DIMENSIONS];
43  index_type extent[GFC_MAX_DIMENSIONS];
44  index_type stride[GFC_MAX_DIMENSIONS];
45  index_type stride0;
46  index_type dim;
47  index_type ssize;
48  const 'rtype_name` *src;
49  'rtype_name` * restrict dest;
50  'rtype_name` *destptr;
51  int n;
52  int packed;
53
54  /* TODO: Investigate how we can figure out if this is a temporary
55     since the stride=0 thing has been removed from the frontend.  */
56
57  dim = GFC_DESCRIPTOR_RANK (source);
58  ssize = 1;
59  packed = 1;
60  for (n = 0; n < dim; n++)
61    {
62      count[n] = 0;
63      stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
64      extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
65      if (extent[n] <= 0)
66        {
67          /* Do nothing.  */
68          packed = 1;
69          break;
70        }
71
72      if (ssize != stride[n])
73        packed = 0;
74
75      ssize *= extent[n];
76    }
77
78  if (packed)
79    return source->base_addr;
80
81  /* Allocate storage for the destination.  */
82  destptr = xmallocarray (ssize, sizeof ('rtype_name`));
83  dest = destptr;
84  src = source->base_addr;
85  stride0 = stride[0];
86
87
88  while (src)
89    {
90      /* Copy the data.  */
91      *(dest++) = *src;
92      /* Advance to the next element.  */
93      src += stride0;
94      count[0]++;
95      /* Advance to the next source element.  */
96      n = 0;
97      while (count[n] == extent[n])
98        {
99          /* When we get to the end of a dimension, reset it and increment
100             the next dimension.  */
101          count[n] = 0;
102          /* We could precalculate these products, but this is a less
103             frequently used path so probably not worth it.  */
104          src -= stride[n] * extent[n];
105          n++;
106          if (n == dim)
107            {
108              src = NULL;
109              break;
110            }
111          else
112            {
113              count[n]++;
114              src += stride[n];
115            }
116        }
117    }
118  return destptr;
119}
120
121#endif
122'
123