]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Generic helper function for repacking arrays. |
a5544970 | 2 | Copyright (C) 2003-2019 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | ||
21d1335b | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a | 6 | |
57dea9f6 TM |
7 | Libgfortran is free software; you can redistribute it and/or |
8 | modify it under the terms of the GNU General Public | |
6de9cd9a | 9 | License as published by the Free Software Foundation; either |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
57dea9f6 TM |
11 | |
12 | Libgfortran is distributed in the hope that it will be useful, | |
6de9cd9a DN |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
57dea9f6 | 15 | GNU General Public License for more details. |
6de9cd9a | 16 | |
748086b7 JJ |
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/>. */ | |
6de9cd9a | 25 | |
36ae8a61 | 26 | #include "libgfortran.h" |
6de9cd9a | 27 | #include <string.h> |
6de9cd9a | 28 | |
7d7b8bfe RH |
29 | extern void internal_unpack (gfc_array_char *, const void *); |
30 | export_proto(internal_unpack); | |
31 | ||
6de9cd9a DN |
32 | void |
33 | internal_unpack (gfc_array_char * d, const void * s) | |
34 | { | |
f827a7d0 TK |
35 | index_type count[GFC_MAX_DIMENSIONS]; |
36 | index_type extent[GFC_MAX_DIMENSIONS]; | |
37 | index_type stride[GFC_MAX_DIMENSIONS]; | |
6de9cd9a DN |
38 | index_type stride0; |
39 | index_type dim; | |
40 | index_type dsize; | |
41 | char *dest; | |
42 | const char *src; | |
7a157266 | 43 | index_type size; |
c7d0f4d5 | 44 | int type_size; |
6de9cd9a | 45 | |
21d1335b | 46 | dest = d->base_addr; |
6de9cd9a DN |
47 | /* This check may be redundant, but do it anyway. */ |
48 | if (s == dest || !s) | |
49 | return; | |
50 | ||
c7d0f4d5 TK |
51 | type_size = GFC_DTYPE_TYPE_SIZE (d); |
52 | switch (type_size) | |
6de9cd9a | 53 | { |
c7d0f4d5 TK |
54 | case GFC_DTYPE_INTEGER_1: |
55 | case GFC_DTYPE_LOGICAL_1: | |
c7d0f4d5 TK |
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; | |
6de9cd9a | 73 | |
8e1d7686 | 74 | #if defined (HAVE_GFC_INTEGER_16) |
c7d0f4d5 TK |
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; | |
8e1d7686 | 79 | #endif |
1ec601bf | 80 | |
c7d0f4d5 TK |
81 | case GFC_DTYPE_REAL_4: |
82 | internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s); | |
83 | return; | |
39328081 | 84 | |
c7d0f4d5 TK |
85 | case GFC_DTYPE_REAL_8: |
86 | internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s); | |
87 | return; | |
8e1d7686 | 88 | |
1ec601bf FXC |
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) | |
c7d0f4d5 TK |
97 | case GFC_DTYPE_REAL_10: |
98 | internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s); | |
99 | return; | |
1ec601bf | 100 | # endif |
8e1d7686 | 101 | |
1ec601bf | 102 | # if defined(HAVE_GFC_REAL_16) |
c7d0f4d5 TK |
103 | case GFC_DTYPE_REAL_16: |
104 | internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s); | |
105 | return; | |
1ec601bf | 106 | # endif |
8e1d7686 | 107 | #endif |
1ec601bf | 108 | |
c7d0f4d5 TK |
109 | case GFC_DTYPE_COMPLEX_4: |
110 | internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s); | |
111 | return; | |
8e1d7686 | 112 | |
c7d0f4d5 TK |
113 | case GFC_DTYPE_COMPLEX_8: |
114 | internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s); | |
115 | return; | |
8e1d7686 | 116 | |
1ec601bf FXC |
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) | |
c7d0f4d5 TK |
125 | case GFC_DTYPE_COMPLEX_10: |
126 | internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s); | |
127 | return; | |
1ec601bf | 128 | # endif |
c7d0f4d5 | 129 | |
1ec601bf | 130 | # if defined(HAVE_GFC_COMPLEX_16) |
c7d0f4d5 TK |
131 | case GFC_DTYPE_COMPLEX_16: |
132 | internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s); | |
133 | return; | |
1ec601bf | 134 | # endif |
c7d0f4d5 | 135 | #endif |
1ec601bf | 136 | |
b6019ab1 TK |
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: | |
21d1335b | 148 | if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s)) |
c7d0f4d5 TK |
149 | break; |
150 | else | |
39328081 | 151 | { |
c7d0f4d5 | 152 | internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); |
39328081 | 153 | return; |
c7d0f4d5 | 154 | } |
b6019ab1 TK |
155 | |
156 | case 4: | |
21d1335b | 157 | if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s)) |
c7d0f4d5 TK |
158 | break; |
159 | else | |
160 | { | |
161 | internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); | |
39328081 | 162 | return; |
c7d0f4d5 | 163 | } |
8e1d7686 | 164 | |
b6019ab1 | 165 | case 8: |
21d1335b | 166 | if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s)) |
c7d0f4d5 TK |
167 | break; |
168 | else | |
169 | { | |
170 | internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); | |
8e1d7686 | 171 | return; |
c7d0f4d5 | 172 | } |
8e1d7686 | 173 | |
c7d0f4d5 | 174 | #ifdef HAVE_GFC_INTEGER_16 |
b6019ab1 | 175 | case 16: |
21d1335b | 176 | if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s)) |
c7d0f4d5 TK |
177 | break; |
178 | else | |
179 | { | |
180 | internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s); | |
8e1d7686 | 181 | return; |
c7d0f4d5 | 182 | } |
8e1d7686 | 183 | #endif |
39328081 TK |
184 | default: |
185 | break; | |
6de9cd9a DN |
186 | } |
187 | ||
c7d0f4d5 TK |
188 | size = GFC_DESCRIPTOR_SIZE (d); |
189 | ||
6de9cd9a DN |
190 | dim = GFC_DESCRIPTOR_RANK (d); |
191 | dsize = 1; | |
7a157266 | 192 | for (index_type n = 0; n < dim; n++) |
6de9cd9a DN |
193 | { |
194 | count[n] = 0; | |
dfb55fdc TK |
195 | stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); |
196 | extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); | |
6de9cd9a | 197 | if (extent[n] <= 0) |
210879b8 | 198 | return; |
6de9cd9a DN |
199 | |
200 | if (dsize == stride[n]) | |
210879b8 | 201 | dsize *= extent[n]; |
6de9cd9a | 202 | else |
210879b8 | 203 | dsize = 0; |
6de9cd9a DN |
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. */ | |
7a157266 | 225 | index_type n = 0; |
6de9cd9a DN |
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 | |
8b6dba81 | 232 | frequently used path so probably not worth it. */ |
6de9cd9a DN |
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 | } |