1/* Generic helper function for repacking arrays.
2   Copyright (C) 2003-2022 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 <string.h>
28
29extern void internal_unpack (gfc_array_char *, const void *);
30export_proto(internal_unpack);
31
32void
33internal_unpack (gfc_array_char * d, const void * s)
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 dsize;
41  char *dest;
42  const char *src;
43  index_type size;
44  int type_size;
45
46  dest = d->base_addr;
47  /* This check may be redundant, but do it anyway.  */
48  if (s == dest || !s)
49    return;
50
51  type_size = GFC_DTYPE_TYPE_SIZE (d);
52  switch (type_size)
53    {
54    case GFC_DTYPE_INTEGER_1:
55    case GFC_DTYPE_LOGICAL_1:
56      internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s);
57      return;
58
59    case GFC_DTYPE_INTEGER_2:
60    case GFC_DTYPE_LOGICAL_2:
61      internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
62      return;
63
64    case GFC_DTYPE_INTEGER_4:
65    case GFC_DTYPE_LOGICAL_4:
66      internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
67      return;
68
69    case GFC_DTYPE_INTEGER_8:
70    case GFC_DTYPE_LOGICAL_8:
71      internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
72      return;
73
74#if defined (HAVE_GFC_INTEGER_16)
75    case GFC_DTYPE_INTEGER_16:
76    case GFC_DTYPE_LOGICAL_16:
77      internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
78      return;
79#endif
80
81    case GFC_DTYPE_REAL_4:
82      internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s);
83      return;
84
85    case GFC_DTYPE_REAL_8:
86      internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s);
87      return;
88
89/* FIXME: This here is a hack, which will have to be removed when
90   the array descriptor is reworked.  Currently, we don't store the
91   kind value for the type, but only the size.  Because on targets with
92   __float128, we have sizeof(logn double) == sizeof(__float128),
93   we cannot discriminate here and have to fall back to the generic
94   handling (which is suboptimal).  */
95#if !defined(GFC_REAL_16_IS_FLOAT128)
96# if defined(HAVE_GFC_REAL_10)
97    case GFC_DTYPE_REAL_10:
98      internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s);
99      return;
100# endif
101
102# if defined(HAVE_GFC_REAL_16)
103    case GFC_DTYPE_REAL_16:
104      internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s);
105      return;
106# endif
107#endif
108
109    case GFC_DTYPE_COMPLEX_4:
110      internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
111      return;
112
113    case GFC_DTYPE_COMPLEX_8:
114      internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
115      return;
116
117/* FIXME: This here is a hack, which will have to be removed when
118   the array descriptor is reworked.  Currently, we don't store the
119   kind value for the type, but only the size.  Because on targets with
120   __float128, we have sizeof(logn double) == sizeof(__float128),
121   we cannot discriminate here and have to fall back to the generic
122   handling (which is suboptimal).  */
123#if !defined(GFC_REAL_16_IS_FLOAT128)
124# if defined(HAVE_GFC_COMPLEX_10)
125    case GFC_DTYPE_COMPLEX_10:
126      internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s);
127      return;
128# endif
129
130# if defined(HAVE_GFC_COMPLEX_16)
131    case GFC_DTYPE_COMPLEX_16:
132      internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s);
133      return;
134# endif
135#endif
136
137    default:
138      break;
139    }
140
141  switch (GFC_DESCRIPTOR_SIZE(d))
142    {
143    case 1:
144      internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s);
145      return;
146
147    case 2:
148      if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s))
149	break;
150      else
151	{
152	  internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
153	  return;
154	}
155
156    case 4:
157      if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s))
158	break;
159      else
160	{
161	  internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
162	  return;
163	}
164
165    case 8:
166      if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s))
167	break;
168      else
169	{
170	  internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
171	  return;
172	}
173
174#ifdef HAVE_GFC_INTEGER_16
175    case 16:
176      if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s))
177	break;
178      else
179	{
180	  internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
181	  return;
182	}
183#endif
184    default:
185      break;
186    }
187
188  size = GFC_DESCRIPTOR_SIZE (d);
189
190  dim = GFC_DESCRIPTOR_RANK (d);
191  dsize = 1;
192  for (index_type n = 0; n < dim; n++)
193    {
194      count[n] = 0;
195      stride[n] = GFC_DESCRIPTOR_STRIDE(d,n);
196      extent[n] = GFC_DESCRIPTOR_EXTENT(d,n);
197      if (extent[n] <= 0)
198	return;
199
200      if (dsize == stride[n])
201	dsize *= extent[n];
202      else
203	dsize = 0;
204    }
205
206  src = s;
207
208  if (dsize != 0)
209    {
210      memcpy (dest, src, dsize * size);
211      return;
212    }
213
214  stride0 = stride[0] * size;
215
216  while (dest)
217    {
218      /* Copy the data.  */
219      memcpy (dest, src, size);
220      /* Advance to the next element.  */
221      src += size;
222      dest += stride0;
223      count[0]++;
224      /* Advance to the next source element.  */
225      index_type n = 0;
226      while (count[n] == extent[n])
227        {
228          /* When we get to the end of a dimension, reset it and increment
229             the next dimension.  */
230          count[n] = 0;
231          /* We could precalculate these products, but this is a less
232             frequently used path so probably not worth it.  */
233          dest -= stride[n] * extent[n] * size;
234          n++;
235          if (n == dim)
236            {
237              dest = NULL;
238              break;
239            }
240          else
241            {
242              count[n]++;
243              dest += stride[n] * size;
244            }
245        }
246    }
247}
248