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