1`/* Helper function for repacking arrays.
2   Copyright (C) 2003-2019 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
28include(iparm.m4)dnl
29
30`#if defined (HAVE_'rtype_name`)
31
32/* Allocates a block of memory with internal_malloc if the array needs
33   repacking.  */
34'
35dnl The kind (ie size) is used to name the function for logicals, integers
36dnl and reals.  For complex, it's c4 or c8.
37rtype_name` *
38internal_pack_'rtype_ccode` ('rtype` * source)
39{
40  index_type count[GFC_MAX_DIMENSIONS];
41  index_type extent[GFC_MAX_DIMENSIONS];
42  index_type stride[GFC_MAX_DIMENSIONS];
43  index_type stride0;
44  index_type dim;
45  index_type ssize;
46  const 'rtype_name` *src;
47  'rtype_name` * restrict dest;
48  'rtype_name` *destptr;
49  int packed;
50
51  /* TODO: Investigate how we can figure out if this is a temporary
52     since the stride=0 thing has been removed from the frontend.  */
53
54  dim = GFC_DESCRIPTOR_RANK (source);
55  ssize = 1;
56  packed = 1;
57  for (index_type n = 0; n < dim; n++)
58    {
59      count[n] = 0;
60      stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
61      extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
62      if (extent[n] <= 0)
63        {
64          /* Do nothing.  */
65          packed = 1;
66          break;
67        }
68
69      if (ssize != stride[n])
70        packed = 0;
71
72      ssize *= extent[n];
73    }
74
75  if (packed)
76    return source->base_addr;
77
78  /* Allocate storage for the destination.  */
79  destptr = xmallocarray (ssize, sizeof ('rtype_name`));
80  dest = destptr;
81  src = source->base_addr;
82  stride0 = stride[0];
83
84
85  while (src)
86    {
87      /* Copy the data.  */
88      *(dest++) = *src;
89      /* Advance to the next element.  */
90      src += stride0;
91      count[0]++;
92      /* Advance to the next source element.  */
93      index_type n = 0;
94      while (count[n] == extent[n])
95        {
96          /* When we get to the end of a dimension, reset it and increment
97             the next dimension.  */
98          count[n] = 0;
99          /* We could precalculate these products, but this is a less
100             frequently used path so probably not worth it.  */
101          src -= stride[n] * extent[n];
102          n++;
103          if (n == dim)
104            {
105              src = NULL;
106              break;
107            }
108          else
109            {
110              count[n]++;
111              src += stride[n];
112            }
113        }
114    }
115  return destptr;
116}
117
118#endif
119'
120