1/* Specific implementation of the UNPACK intrinsic 2 Copyright (C) 2008-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on 4 unpack_generic.c by Paul Brook <paul@nowt.org>. 5 6This file is part of the GNU Fortran runtime library (libgfortran). 7 8Libgfortran is free software; you can redistribute it and/or 9modify it under the terms of the GNU General Public 10License as published by the Free Software Foundation; either 11version 3 of the License, or (at your option) any later version. 12 13Ligbfortran is distributed in the hope that it will be useful, 14but WITHOUT ANY WARRANTY; without even the implied warranty of 15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16GNU General Public License for more details. 17 18Under Section 7 of GPL version 3, you are granted additional 19permissions described in the GCC Runtime Library Exception, version 203.1, as published by the Free Software Foundation. 21 22You should have received a copy of the GNU General Public License and 23a copy of the GCC Runtime Library Exception along with this program; 24see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 25<http://www.gnu.org/licenses/>. */ 26 27#include "libgfortran.h" 28#include <string.h> 29 30 31#if defined (HAVE_GFC_REAL_16) 32 33void 34unpack0_r16 (gfc_array_r16 *ret, const gfc_array_r16 *vector, 35 const gfc_array_l1 *mask, const GFC_REAL_16 *fptr) 36{ 37 /* r.* indicates the return array. */ 38 index_type rstride[GFC_MAX_DIMENSIONS]; 39 index_type rstride0; 40 index_type rs; 41 GFC_REAL_16 * restrict rptr; 42 /* v.* indicates the vector array. */ 43 index_type vstride0; 44 GFC_REAL_16 *vptr; 45 /* Value for field, this is constant. */ 46 const GFC_REAL_16 fval = *fptr; 47 /* m.* indicates the mask array. */ 48 index_type mstride[GFC_MAX_DIMENSIONS]; 49 index_type mstride0; 50 const GFC_LOGICAL_1 *mptr; 51 52 index_type count[GFC_MAX_DIMENSIONS]; 53 index_type extent[GFC_MAX_DIMENSIONS]; 54 index_type n; 55 index_type dim; 56 57 int empty; 58 int mask_kind; 59 60 empty = 0; 61 62 mptr = mask->base_addr; 63 64 /* Use the same loop for all logical types, by using GFC_LOGICAL_1 65 and using shifting to address size and endian issues. */ 66 67 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 68 69 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 70#ifdef HAVE_GFC_LOGICAL_16 71 || mask_kind == 16 72#endif 73 ) 74 { 75 /* Do not convert a NULL pointer as we use test for NULL below. */ 76 if (mptr) 77 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); 78 } 79 else 80 runtime_error ("Funny sized logical array"); 81 82 /* Initialize to avoid -Wmaybe-uninitialized complaints. */ 83 rstride[0] = 1; 84 if (ret->base_addr == NULL) 85 { 86 /* The front end has signalled that we need to populate the 87 return array descriptor. */ 88 dim = GFC_DESCRIPTOR_RANK (mask); 89 rs = 1; 90 for (n = 0; n < dim; n++) 91 { 92 count[n] = 0; 93 GFC_DIMENSION_SET(ret->dim[n], 0, 94 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); 95 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 96 empty = empty || extent[n] <= 0; 97 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 98 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 99 rs *= extent[n]; 100 } 101 ret->offset = 0; 102 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_16)); 103 } 104 else 105 { 106 dim = GFC_DESCRIPTOR_RANK (ret); 107 for (n = 0; n < dim; n++) 108 { 109 count[n] = 0; 110 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 111 empty = empty || extent[n] <= 0; 112 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 113 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 114 } 115 if (rstride[0] == 0) 116 rstride[0] = 1; 117 } 118 119 if (empty) 120 return; 121 122 if (mstride[0] == 0) 123 mstride[0] = 1; 124 125 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); 126 if (vstride0 == 0) 127 vstride0 = 1; 128 rstride0 = rstride[0]; 129 mstride0 = mstride[0]; 130 rptr = ret->base_addr; 131 vptr = vector->base_addr; 132 133 while (rptr) 134 { 135 if (*mptr) 136 { 137 /* From vector. */ 138 *rptr = *vptr; 139 vptr += vstride0; 140 } 141 else 142 { 143 /* From field. */ 144 *rptr = fval; 145 } 146 /* Advance to the next element. */ 147 rptr += rstride0; 148 mptr += mstride0; 149 count[0]++; 150 n = 0; 151 while (count[n] == extent[n]) 152 { 153 /* When we get to the end of a dimension, reset it and increment 154 the next dimension. */ 155 count[n] = 0; 156 /* We could precalculate these products, but this is a less 157 frequently used path so probably not worth it. */ 158 rptr -= rstride[n] * extent[n]; 159 mptr -= mstride[n] * extent[n]; 160 n++; 161 if (n >= dim) 162 { 163 /* Break out of the loop. */ 164 rptr = NULL; 165 break; 166 } 167 else 168 { 169 count[n]++; 170 rptr += rstride[n]; 171 mptr += mstride[n]; 172 } 173 } 174 } 175} 176 177void 178unpack1_r16 (gfc_array_r16 *ret, const gfc_array_r16 *vector, 179 const gfc_array_l1 *mask, const gfc_array_r16 *field) 180{ 181 /* r.* indicates the return array. */ 182 index_type rstride[GFC_MAX_DIMENSIONS]; 183 index_type rstride0; 184 index_type rs; 185 GFC_REAL_16 * restrict rptr; 186 /* v.* indicates the vector array. */ 187 index_type vstride0; 188 GFC_REAL_16 *vptr; 189 /* f.* indicates the field array. */ 190 index_type fstride[GFC_MAX_DIMENSIONS]; 191 index_type fstride0; 192 const GFC_REAL_16 *fptr; 193 /* m.* indicates the mask array. */ 194 index_type mstride[GFC_MAX_DIMENSIONS]; 195 index_type mstride0; 196 const GFC_LOGICAL_1 *mptr; 197 198 index_type count[GFC_MAX_DIMENSIONS]; 199 index_type extent[GFC_MAX_DIMENSIONS]; 200 index_type n; 201 index_type dim; 202 203 int empty; 204 int mask_kind; 205 206 empty = 0; 207 208 mptr = mask->base_addr; 209 210 /* Use the same loop for all logical types, by using GFC_LOGICAL_1 211 and using shifting to address size and endian issues. */ 212 213 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 214 215 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 216#ifdef HAVE_GFC_LOGICAL_16 217 || mask_kind == 16 218#endif 219 ) 220 { 221 /* Do not convert a NULL pointer as we use test for NULL below. */ 222 if (mptr) 223 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); 224 } 225 else 226 runtime_error ("Funny sized logical array"); 227 228 /* Initialize to avoid -Wmaybe-uninitialized complaints. */ 229 rstride[0] = 1; 230 if (ret->base_addr == NULL) 231 { 232 /* The front end has signalled that we need to populate the 233 return array descriptor. */ 234 dim = GFC_DESCRIPTOR_RANK (mask); 235 rs = 1; 236 for (n = 0; n < dim; n++) 237 { 238 count[n] = 0; 239 GFC_DIMENSION_SET(ret->dim[n], 0, 240 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); 241 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 242 empty = empty || extent[n] <= 0; 243 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 244 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); 245 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 246 rs *= extent[n]; 247 } 248 ret->offset = 0; 249 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_16)); 250 } 251 else 252 { 253 dim = GFC_DESCRIPTOR_RANK (ret); 254 for (n = 0; n < dim; n++) 255 { 256 count[n] = 0; 257 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 258 empty = empty || extent[n] <= 0; 259 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 260 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); 261 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 262 } 263 if (rstride[0] == 0) 264 rstride[0] = 1; 265 } 266 267 if (empty) 268 return; 269 270 if (fstride[0] == 0) 271 fstride[0] = 1; 272 if (mstride[0] == 0) 273 mstride[0] = 1; 274 275 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); 276 if (vstride0 == 0) 277 vstride0 = 1; 278 rstride0 = rstride[0]; 279 fstride0 = fstride[0]; 280 mstride0 = mstride[0]; 281 rptr = ret->base_addr; 282 fptr = field->base_addr; 283 vptr = vector->base_addr; 284 285 while (rptr) 286 { 287 if (*mptr) 288 { 289 /* From vector. */ 290 *rptr = *vptr; 291 vptr += vstride0; 292 } 293 else 294 { 295 /* From field. */ 296 *rptr = *fptr; 297 } 298 /* Advance to the next element. */ 299 rptr += rstride0; 300 fptr += fstride0; 301 mptr += mstride0; 302 count[0]++; 303 n = 0; 304 while (count[n] == extent[n]) 305 { 306 /* When we get to the end of a dimension, reset it and increment 307 the next dimension. */ 308 count[n] = 0; 309 /* We could precalculate these products, but this is a less 310 frequently used path so probably not worth it. */ 311 rptr -= rstride[n] * extent[n]; 312 fptr -= fstride[n] * extent[n]; 313 mptr -= mstride[n] * extent[n]; 314 n++; 315 if (n >= dim) 316 { 317 /* Break out of the loop. */ 318 rptr = NULL; 319 break; 320 } 321 else 322 { 323 count[n]++; 324 rptr += rstride[n]; 325 fptr += fstride[n]; 326 mptr += mstride[n]; 327 } 328 } 329 } 330} 331 332#endif 333 334