1`/* Specific implementation of the UNPACK intrinsic 2 Copyright (C) 2008-2021 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 30include(iparm.m4)dnl 31 32`#if defined (HAVE_'rtype_name`) 33 34void 35unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector, 36 const gfc_array_l1 *mask, const 'rtype_name` *fptr) 37{ 38 /* r.* indicates the return array. */ 39 index_type rstride[GFC_MAX_DIMENSIONS]; 40 index_type rstride0; 41 index_type rs; 42 'rtype_name` * restrict rptr; 43 /* v.* indicates the vector array. */ 44 index_type vstride0; 45 'rtype_name` *vptr; 46 /* Value for field, this is constant. */ 47 const 'rtype_name` fval = *fptr; 48 /* m.* indicates the mask array. */ 49 index_type mstride[GFC_MAX_DIMENSIONS]; 50 index_type mstride0; 51 const GFC_LOGICAL_1 *mptr; 52 53 index_type count[GFC_MAX_DIMENSIONS]; 54 index_type extent[GFC_MAX_DIMENSIONS]; 55 index_type n; 56 index_type dim; 57 58 int empty; 59 int mask_kind; 60 61 empty = 0; 62 63 mptr = mask->base_addr; 64 65 /* Use the same loop for all logical types, by using GFC_LOGICAL_1 66 and using shifting to address size and endian issues. */ 67 68 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 69 70 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 71#ifdef HAVE_GFC_LOGICAL_16 72 || mask_kind == 16 73#endif 74 ) 75 { 76 /* Do not convert a NULL pointer as we use test for NULL below. */ 77 if (mptr) 78 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); 79 } 80 else 81 runtime_error ("Funny sized logical array"); 82 83 /* Initialize to avoid -Wmaybe-uninitialized complaints. */ 84 rstride[0] = 1; 85 if (ret->base_addr == NULL) 86 { 87 /* The front end has signalled that we need to populate the 88 return array descriptor. */ 89 dim = GFC_DESCRIPTOR_RANK (mask); 90 rs = 1; 91 for (n = 0; n < dim; n++) 92 { 93 count[n] = 0; 94 GFC_DIMENSION_SET(ret->dim[n], 0, 95 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); 96 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 97 empty = empty || extent[n] <= 0; 98 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 99 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 100 rs *= extent[n]; 101 } 102 ret->offset = 0; 103 ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`)); 104 } 105 else 106 { 107 dim = GFC_DESCRIPTOR_RANK (ret); 108 for (n = 0; n < dim; n++) 109 { 110 count[n] = 0; 111 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 112 empty = empty || extent[n] <= 0; 113 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 114 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 115 } 116 if (rstride[0] == 0) 117 rstride[0] = 1; 118 } 119 120 if (empty) 121 return; 122 123 if (mstride[0] == 0) 124 mstride[0] = 1; 125 126 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); 127 if (vstride0 == 0) 128 vstride0 = 1; 129 rstride0 = rstride[0]; 130 mstride0 = mstride[0]; 131 rptr = ret->base_addr; 132 vptr = vector->base_addr; 133 134 while (rptr) 135 { 136 if (*mptr) 137 { 138 /* From vector. */ 139 *rptr = *vptr; 140 vptr += vstride0; 141 } 142 else 143 { 144 /* From field. */ 145 *rptr = fval; 146 } 147 /* Advance to the next element. */ 148 rptr += rstride0; 149 mptr += mstride0; 150 count[0]++; 151 n = 0; 152 while (count[n] == extent[n]) 153 { 154 /* When we get to the end of a dimension, reset it and increment 155 the next dimension. */ 156 count[n] = 0; 157 /* We could precalculate these products, but this is a less 158 frequently used path so probably not worth it. */ 159 rptr -= rstride[n] * extent[n]; 160 mptr -= mstride[n] * extent[n]; 161 n++; 162 if (n >= dim) 163 { 164 /* Break out of the loop. */ 165 rptr = NULL; 166 break; 167 } 168 else 169 { 170 count[n]++; 171 rptr += rstride[n]; 172 mptr += mstride[n]; 173 } 174 } 175 } 176} 177 178void 179unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector, 180 const gfc_array_l1 *mask, const 'rtype` *field) 181{ 182 /* r.* indicates the return array. */ 183 index_type rstride[GFC_MAX_DIMENSIONS]; 184 index_type rstride0; 185 index_type rs; 186 'rtype_name` * restrict rptr; 187 /* v.* indicates the vector array. */ 188 index_type vstride0; 189 'rtype_name` *vptr; 190 /* f.* indicates the field array. */ 191 index_type fstride[GFC_MAX_DIMENSIONS]; 192 index_type fstride0; 193 const 'rtype_name` *fptr; 194 /* m.* indicates the mask array. */ 195 index_type mstride[GFC_MAX_DIMENSIONS]; 196 index_type mstride0; 197 const GFC_LOGICAL_1 *mptr; 198 199 index_type count[GFC_MAX_DIMENSIONS]; 200 index_type extent[GFC_MAX_DIMENSIONS]; 201 index_type n; 202 index_type dim; 203 204 int empty; 205 int mask_kind; 206 207 empty = 0; 208 209 mptr = mask->base_addr; 210 211 /* Use the same loop for all logical types, by using GFC_LOGICAL_1 212 and using shifting to address size and endian issues. */ 213 214 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 215 216 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 217#ifdef HAVE_GFC_LOGICAL_16 218 || mask_kind == 16 219#endif 220 ) 221 { 222 /* Do not convert a NULL pointer as we use test for NULL below. */ 223 if (mptr) 224 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); 225 } 226 else 227 runtime_error ("Funny sized logical array"); 228 229 /* Initialize to avoid -Wmaybe-uninitialized complaints. */ 230 rstride[0] = 1; 231 if (ret->base_addr == NULL) 232 { 233 /* The front end has signalled that we need to populate the 234 return array descriptor. */ 235 dim = GFC_DESCRIPTOR_RANK (mask); 236 rs = 1; 237 for (n = 0; n < dim; n++) 238 { 239 count[n] = 0; 240 GFC_DIMENSION_SET(ret->dim[n], 0, 241 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); 242 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 243 empty = empty || extent[n] <= 0; 244 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 245 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); 246 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 247 rs *= extent[n]; 248 } 249 ret->offset = 0; 250 ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`)); 251 } 252 else 253 { 254 dim = GFC_DESCRIPTOR_RANK (ret); 255 for (n = 0; n < dim; n++) 256 { 257 count[n] = 0; 258 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 259 empty = empty || extent[n] <= 0; 260 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 261 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); 262 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 263 } 264 if (rstride[0] == 0) 265 rstride[0] = 1; 266 } 267 268 if (empty) 269 return; 270 271 if (fstride[0] == 0) 272 fstride[0] = 1; 273 if (mstride[0] == 0) 274 mstride[0] = 1; 275 276 vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); 277 if (vstride0 == 0) 278 vstride0 = 1; 279 rstride0 = rstride[0]; 280 fstride0 = fstride[0]; 281 mstride0 = mstride[0]; 282 rptr = ret->base_addr; 283 fptr = field->base_addr; 284 vptr = vector->base_addr; 285 286 while (rptr) 287 { 288 if (*mptr) 289 { 290 /* From vector. */ 291 *rptr = *vptr; 292 vptr += vstride0; 293 } 294 else 295 { 296 /* From field. */ 297 *rptr = *fptr; 298 } 299 /* Advance to the next element. */ 300 rptr += rstride0; 301 fptr += fstride0; 302 mptr += mstride0; 303 count[0]++; 304 n = 0; 305 while (count[n] == extent[n]) 306 { 307 /* When we get to the end of a dimension, reset it and increment 308 the next dimension. */ 309 count[n] = 0; 310 /* We could precalculate these products, but this is a less 311 frequently used path so probably not worth it. */ 312 rptr -= rstride[n] * extent[n]; 313 fptr -= fstride[n] * extent[n]; 314 mptr -= mstride[n] * extent[n]; 315 n++; 316 if (n >= dim) 317 { 318 /* Break out of the loop. */ 319 rptr = NULL; 320 break; 321 } 322 else 323 { 324 count[n]++; 325 rptr += rstride[n]; 326 fptr += fstride[n]; 327 mptr += mstride[n]; 328 } 329 } 330 } 331} 332 333#endif 334' 335