1 /* Generic helper function for repacking arrays.
2 Copyright (C) 2003-2023 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_unpack (gfc_array_char *, const void *);
30 export_proto(internal_unpack);
31
32 void
33 internal_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(long 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(long 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 }