1 /* Specific implementation of the UNPACK intrinsic 2 Copyright (C) 2008-2019 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 6 This file is part of the GNU Fortran runtime library (libgfortran). 7 8 Libgfortran is free software; you can redistribute it and/or 9 modify it under the terms of the GNU General Public 10 License as published by the Free Software Foundation; either 11 version 3 of the License, or (at your option) any later version. 12 13 Ligbfortran is distributed in the hope that it will be useful, 14 but WITHOUT ANY WARRANTY; without even the implied warranty of 15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 GNU General Public License for more details. 17 18 Under Section 7 of GPL version 3, you are granted additional 19 permissions described in the GCC Runtime Library Exception, version 20 3.1, as published by the Free Software Foundation. 21 22 You should have received a copy of the GNU General Public License and 23 a copy of the GCC Runtime Library Exception along with this program; 24 see 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_4) 32 33 void 34 unpack0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector, 35 const gfc_array_l1 *mask, const GFC_REAL_4 *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_4 * restrict rptr; 42 /* v.* indicates the vector array. */ 43 index_type vstride0; 44 GFC_REAL_4 *vptr; 45 /* Value for field, this is constant. */ 46 const GFC_REAL_4 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 if (ret->base_addr == NULL) 83 { 84 /* The front end has signalled that we need to populate the 85 return array descriptor. */ 86 dim = GFC_DESCRIPTOR_RANK (mask); 87 rs = 1; 88 for (n = 0; n < dim; n++) 89 { 90 count[n] = 0; 91 GFC_DIMENSION_SET(ret->dim[n], 0, 92 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); 93 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 94 empty = empty || extent[n] <= 0; 95 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 96 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 97 rs *= extent[n]; 98 } 99 ret->offset = 0; 100 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_4)); 101 } 102 else 103 { 104 dim = GFC_DESCRIPTOR_RANK (ret); 105 /* Initialize to avoid -Wmaybe-uninitialized complaints. */ 106 rstride[0] = 1; 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 177 void 178 unpack1_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector, 179 const gfc_array_l1 *mask, const gfc_array_r4 *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_4 * restrict rptr; 186 /* v.* indicates the vector array. */ 187 index_type vstride0; 188 GFC_REAL_4 *vptr; 189 /* f.* indicates the field array. */ 190 index_type fstride[GFC_MAX_DIMENSIONS]; 191 index_type fstride0; 192 const GFC_REAL_4 *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 if (ret->base_addr == NULL) 229 { 230 /* The front end has signalled that we need to populate the 231 return array descriptor. */ 232 dim = GFC_DESCRIPTOR_RANK (mask); 233 rs = 1; 234 for (n = 0; n < dim; n++) 235 { 236 count[n] = 0; 237 GFC_DIMENSION_SET(ret->dim[n], 0, 238 GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); 239 extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); 240 empty = empty || extent[n] <= 0; 241 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); 242 fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); 243 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 244 rs *= extent[n]; 245 } 246 ret->offset = 0; 247 ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_4)); 248 } 249 else 250 { 251 dim = GFC_DESCRIPTOR_RANK (ret); 252 /* Initialize to avoid -Wmaybe-uninitialized complaints. */ 253 rstride[0] = 1; 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