]>
Commit | Line | Data |
---|---|---|
4ee9c684 | 1 | /* Generic helper function for repacking arrays. |
6bc9506f | 2 | Copyright 2003, 2004, 2005, 2007, 2009 Free Software Foundation, Inc. |
4ee9c684 | 3 | Contributed by Paul Brook <paul@nowt.org> |
4 | ||
b417ea8c | 5 | This file is part of the GNU Fortran 95 runtime library (libgfortran). |
4ee9c684 | 6 | |
b417ea8c | 7 | Libgfortran is free software; you can redistribute it and/or |
8 | modify it under the terms of the GNU General Public | |
4ee9c684 | 9 | License as published by the Free Software Foundation; either |
6bc9506f | 10 | version 3 of the License, or (at your option) any later version. |
b417ea8c | 11 | |
12 | Libgfortran is distributed in the hope that it will be useful, | |
4ee9c684 | 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
b417ea8c | 15 | GNU General Public License for more details. |
4ee9c684 | 16 | |
6bc9506f | 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/>. */ | |
4ee9c684 | 25 | |
41f2d5e8 | 26 | #include "libgfortran.h" |
4ee9c684 | 27 | #include <stdlib.h> |
28 | #include <assert.h> | |
29 | #include <string.h> | |
4ee9c684 | 30 | |
7b6cb5bd | 31 | extern void *internal_pack (gfc_array_char *); |
32 | export_proto(internal_pack); | |
33 | ||
4ee9c684 | 34 | void * |
35 | internal_pack (gfc_array_char * source) | |
36 | { | |
fa6176a2 | 37 | index_type count[GFC_MAX_DIMENSIONS]; |
38 | index_type extent[GFC_MAX_DIMENSIONS]; | |
39 | index_type stride[GFC_MAX_DIMENSIONS]; | |
4ee9c684 | 40 | index_type stride0; |
41 | index_type dim; | |
42 | index_type ssize; | |
43 | const char *src; | |
44 | char *dest; | |
45 | void *destptr; | |
46 | int n; | |
47 | int packed; | |
48 | index_type size; | |
ed3634f6 | 49 | index_type type_size; |
4ee9c684 | 50 | |
ed3634f6 | 51 | type_size = GFC_DTYPE_TYPE_SIZE(source); |
4ee9c684 | 52 | size = GFC_DESCRIPTOR_SIZE (source); |
ed3634f6 | 53 | switch (type_size) |
4ee9c684 | 54 | { |
ed3634f6 | 55 | case GFC_DTYPE_INTEGER_1: |
56 | case GFC_DTYPE_LOGICAL_1: | |
57 | case GFC_DTYPE_DERIVED_1: | |
58 | return internal_pack_1 ((gfc_array_i1 *) source); | |
59 | ||
60 | case GFC_DTYPE_INTEGER_2: | |
61 | case GFC_DTYPE_LOGICAL_2: | |
62 | return internal_pack_2 ((gfc_array_i2 *) source); | |
63 | ||
64 | case GFC_DTYPE_INTEGER_4: | |
65 | case GFC_DTYPE_LOGICAL_4: | |
66 | return internal_pack_4 ((gfc_array_i4 *) source); | |
67 | ||
68 | case GFC_DTYPE_INTEGER_8: | |
69 | case GFC_DTYPE_LOGICAL_8: | |
70 | return internal_pack_8 ((gfc_array_i8 *) source); | |
98380129 | 71 | |
72 | #if defined(HAVE_GFC_INTEGER_16) | |
ed3634f6 | 73 | case GFC_DTYPE_INTEGER_16: |
74 | case GFC_DTYPE_LOGICAL_16: | |
75 | return internal_pack_16 ((gfc_array_i16 *) source); | |
98380129 | 76 | #endif |
ed3634f6 | 77 | case GFC_DTYPE_REAL_4: |
78 | return internal_pack_r4 ((gfc_array_r4 *) source); | |
98380129 | 79 | |
ed3634f6 | 80 | case GFC_DTYPE_REAL_8: |
81 | return internal_pack_r8 ((gfc_array_r8 *) source); | |
98380129 | 82 | |
87969c8c | 83 | /* FIXME: This here is a hack, which will have to be removed when |
84 | the array descriptor is reworked. Currently, we don't store the | |
85 | kind value for the type, but only the size. Because on targets with | |
86 | __float128, we have sizeof(logn double) == sizeof(__float128), | |
87 | we cannot discriminate here and have to fall back to the generic | |
88 | handling (which is suboptimal). */ | |
89 | #if !defined(GFC_REAL_16_IS_FLOAT128) | |
90 | # if defined (HAVE_GFC_REAL_10) | |
ed3634f6 | 91 | case GFC_DTYPE_REAL_10: |
92 | return internal_pack_r10 ((gfc_array_r10 *) source); | |
87969c8c | 93 | # endif |
98380129 | 94 | |
87969c8c | 95 | # if defined (HAVE_GFC_REAL_16) |
ed3634f6 | 96 | case GFC_DTYPE_REAL_16: |
97 | return internal_pack_r16 ((gfc_array_r16 *) source); | |
87969c8c | 98 | # endif |
98380129 | 99 | #endif |
87969c8c | 100 | |
ed3634f6 | 101 | case GFC_DTYPE_COMPLEX_4: |
102 | return internal_pack_c4 ((gfc_array_c4 *) source); | |
103 | ||
104 | case GFC_DTYPE_COMPLEX_8: | |
105 | return internal_pack_c8 ((gfc_array_c8 *) source); | |
98380129 | 106 | |
87969c8c | 107 | /* FIXME: This here is a hack, which will have to be removed when |
108 | the array descriptor is reworked. Currently, we don't store the | |
109 | kind value for the type, but only the size. Because on targets with | |
110 | __float128, we have sizeof(logn double) == sizeof(__float128), | |
111 | we cannot discriminate here and have to fall back to the generic | |
112 | handling (which is suboptimal). */ | |
113 | #if !defined(GFC_REAL_16_IS_FLOAT128) | |
114 | # if defined (HAVE_GFC_COMPLEX_10) | |
ed3634f6 | 115 | case GFC_DTYPE_COMPLEX_10: |
116 | return internal_pack_c10 ((gfc_array_c10 *) source); | |
87969c8c | 117 | # endif |
98380129 | 118 | |
87969c8c | 119 | # if defined (HAVE_GFC_COMPLEX_16) |
ed3634f6 | 120 | case GFC_DTYPE_COMPLEX_16: |
121 | return internal_pack_c16 ((gfc_array_c16 *) source); | |
87969c8c | 122 | # endif |
98380129 | 123 | #endif |
124 | ||
ed3634f6 | 125 | case GFC_DTYPE_DERIVED_2: |
126 | if (GFC_UNALIGNED_2(source->data)) | |
127 | break; | |
128 | else | |
129 | return internal_pack_2 ((gfc_array_i2 *) source); | |
130 | ||
131 | case GFC_DTYPE_DERIVED_4: | |
132 | if (GFC_UNALIGNED_4(source->data)) | |
133 | break; | |
134 | else | |
135 | return internal_pack_4 ((gfc_array_i4 *) source); | |
136 | ||
137 | case GFC_DTYPE_DERIVED_8: | |
138 | if (GFC_UNALIGNED_8(source->data)) | |
139 | break; | |
140 | else | |
141 | return internal_pack_8 ((gfc_array_i8 *) source); | |
142 | ||
143 | #ifdef HAVE_GFC_INTEGER_16 | |
144 | case GFC_DTYPE_DERIVED_16: | |
145 | if (GFC_UNALIGNED_16(source->data)) | |
146 | break; | |
147 | else | |
148 | return internal_pack_16 ((gfc_array_i16 *) source); | |
149 | #endif | |
f27ef643 | 150 | |
151 | default: | |
152 | break; | |
4ee9c684 | 153 | } |
154 | ||
155 | dim = GFC_DESCRIPTOR_RANK (source); | |
156 | ssize = 1; | |
157 | packed = 1; | |
158 | for (n = 0; n < dim; n++) | |
159 | { | |
160 | count[n] = 0; | |
827aef63 | 161 | stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); |
162 | extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); | |
4ee9c684 | 163 | if (extent[n] <= 0) |
164 | { | |
165 | /* Do nothing. */ | |
166 | packed = 1; | |
167 | break; | |
168 | } | |
169 | ||
170 | if (ssize != stride[n]) | |
171 | packed = 0; | |
172 | ||
173 | ssize *= extent[n]; | |
174 | } | |
175 | ||
176 | if (packed) | |
177 | return source->data; | |
178 | ||
179 | /* Allocate storage for the destination. */ | |
180 | destptr = internal_malloc_size (ssize * size); | |
181 | dest = (char *)destptr; | |
182 | src = source->data; | |
183 | stride0 = stride[0] * size; | |
184 | ||
185 | while (src) | |
186 | { | |
187 | /* Copy the data. */ | |
188 | memcpy(dest, src, size); | |
189 | /* Advance to the next element. */ | |
190 | dest += size; | |
191 | src += stride0; | |
192 | count[0]++; | |
193 | /* Advance to the next source element. */ | |
194 | n = 0; | |
195 | while (count[n] == extent[n]) | |
196 | { | |
197 | /* When we get to the end of a dimension, reset it and increment | |
198 | the next dimension. */ | |
199 | count[n] = 0; | |
200 | /* We could precalculate these products, but this is a less | |
a2ffc2c4 | 201 | frequently used path so probably not worth it. */ |
4ee9c684 | 202 | src -= stride[n] * extent[n] * size; |
203 | n++; | |
204 | if (n == dim) | |
205 | { | |
206 | src = NULL; | |
207 | break; | |
208 | } | |
209 | else | |
210 | { | |
211 | count[n]++; | |
212 | src += stride[n] * size; | |
213 | } | |
214 | } | |
215 | } | |
216 | return destptr; | |
217 | } |