1114402Sru/* Specific implementation of the PACK intrinsic 2114402Sru Copyright (C) 2002-2020 Free Software Foundation, Inc. 3114402Sru Contributed by Paul Brook <paul@nowt.org> 4114402Sru 5114402SruThis file is part of the GNU Fortran runtime library (libgfortran). 6114402Sru 7114402SruLibgfortran is free software; you can redistribute it and/or 8114402Srumodify it under the terms of the GNU General Public 9114402SruLicense as published by the Free Software Foundation; either 10114402Sruversion 3 of the License, or (at your option) any later version. 11114402Sru 12114402SruLigbfortran is distributed in the hope that it will be useful, 13114402Srubut WITHOUT ANY WARRANTY; without even the implied warranty of 14114402SruMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15114402SruGNU General Public License for more details. 16114402Sru 17114402SruUnder Section 7 of GPL version 3, you are granted additional 18114402Srupermissions described in the GCC Runtime Library Exception, version 19114402Sru3.1, as published by the Free Software Foundation. 20114402Sru 21114402SruYou should have received a copy of the GNU General Public License and 22114402Srua copy of the GCC Runtime Library Exception along with this program; 23114402Srusee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24114402Sru<http://www.gnu.org/licenses/>. */ 25114402Sru 26114402Sru#include "libgfortran.h" 27114402Sru#include <string.h> 28114402Sru 29114402Sru 30114402Sru#if defined (HAVE_GFC_INTEGER_8) 31114402Sru 32114402Sru/* PACK is specified as follows: 33114402Sru 34114402Sru 13.14.80 PACK (ARRAY, MASK, [VECTOR]) 35114402Sru 36114402Sru Description: Pack an array into an array of rank one under the 37114402Sru control of a mask. 38114402Sru 39114402Sru Class: Transformational function. 40114402Sru 41114402Sru Arguments: 42114402Sru ARRAY may be of any type. It shall not be scalar. 43114402Sru MASK shall be of type LOGICAL. It shall be conformable with ARRAY. 44114402Sru VECTOR (optional) shall be of the same type and type parameters 45114402Sru as ARRAY. VECTOR shall have at least as many elements as 46114402Sru there are true elements in MASK. If MASK is a scalar 47114402Sru with the value true, VECTOR shall have at least as many 48114402Sru elements as there are in ARRAY. 49114402Sru 50114402Sru Result Characteristics: The result is an array of rank one with the 51114402Sru same type and type parameters as ARRAY. If VECTOR is present, the 52114402Sru result size is that of VECTOR; otherwise, the result size is the 53114402Sru number /t/ of true elements in MASK unless MASK is scalar with the 54114402Sru value true, in which case the result size is the size of ARRAY. 55114402Sru 56114402Sru Result Value: Element /i/ of the result is the element of ARRAY 57114402Sru that corresponds to the /i/th true element of MASK, taking elements 58114402Sru in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is 59114402Sru present and has size /n/ > /t/, element /i/ of the result has the 60114402Sru value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. 61114402Sru 62114402Sru Examples: The nonzero elements of an array M with the value 63114402Sru | 0 0 0 | 64114402Sru | 9 0 0 | may be "gathered" by the function PACK. The result of 65114402Sru | 0 0 7 | 66114402Sru PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, 67114402Sru VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. 68114402Sru 69114402SruThere are two variants of the PACK intrinsic: one, where MASK is 70114402Sruarray valued, and the other one where MASK is scalar. */ 71114402Sru 72114402Sruvoid 73114402Srupack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, 74114402Sru const gfc_array_l1 *mask, const gfc_array_i8 *vector) 75114402Sru{ 76114402Sru /* r.* indicates the return array. */ 77114402Sru index_type rstride0; 78114402Sru GFC_INTEGER_8 * restrict rptr; 79114402Sru /* s.* indicates the source array. */ 80114402Sru index_type sstride[GFC_MAX_DIMENSIONS]; 81114402Sru index_type sstride0; 82114402Sru const GFC_INTEGER_8 *sptr; 83114402Sru /* m.* indicates the mask array. */ 84114402Sru index_type mstride[GFC_MAX_DIMENSIONS]; 85114402Sru index_type mstride0; 86114402Sru const GFC_LOGICAL_1 *mptr; 87114402Sru 88114402Sru index_type count[GFC_MAX_DIMENSIONS]; 89114402Sru index_type extent[GFC_MAX_DIMENSIONS]; 90114402Sru int zero_sized; 91114402Sru index_type n; 92114402Sru index_type dim; 93114402Sru index_type nelem; 94114402Sru index_type total; 95114402Sru int mask_kind; 96114402Sru 97114402Sru dim = GFC_DESCRIPTOR_RANK (array); 98114402Sru 99114402Sru mptr = mask->base_addr; 100114402Sru 101114402Sru /* Use the same loop for all logical types, by using GFC_LOGICAL_1 102114402Sru and using shifting to address size and endian issues. */ 103114402Sru 104114402Sru mask_kind = GFC_DESCRIPTOR_SIZE (mask); 105114402Sru 106114402Sru if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 107114402Sru#ifdef HAVE_GFC_LOGICAL_16 108114402Sru || mask_kind == 16 109114402Sru#endif 110114402Sru ) 111114402Sru { 112114402Sru /* Do not convert a NULL pointer as we use test for NULL below. */ 113114402Sru if (mptr) 114114402Sru mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); 115114402Sru } 116114402Sru else 117114402Sru runtime_error ("Funny sized logical array"); 118114402Sru 119114402Sru zero_sized = 0; 120114402Sru for (n = 0; n < dim; n++) 121114402Sru { 122114402Sru count[n] = 0; 123114402Sru extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 124114402Sru if (extent[n] <= 0) 125114402Sru zero_sized = 1; 126114402Sru sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 127114402Sru mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 128114402Sru } 129114402Sru if (sstride[0] == 0) 130114402Sru sstride[0] = 1; 131114402Sru if (mstride[0] == 0) 132114402Sru mstride[0] = mask_kind; 133114402Sru 134114402Sru if (zero_sized) 135114402Sru sptr = NULL; 136114402Sru else 137114402Sru sptr = array->base_addr; 138114402Sru 139114402Sru if (ret->base_addr == NULL || unlikely (compile_options.bounds_check)) 140114402Sru { 141114402Sru /* Count the elements, either for allocating memory or 142114402Sru for bounds checking. */ 143114402Sru 144114402Sru if (vector != NULL) 145114402Sru { 146114402Sru /* The return array will have as many 147114402Sru elements as there are in VECTOR. */ 148114402Sru total = GFC_DESCRIPTOR_EXTENT(vector,0); 149114402Sru if (total < 0) 150114402Sru { 151114402Sru total = 0; 152114402Sru vector = NULL; 153114402Sru } 154114402Sru } 155114402Sru else 156114402Sru { 157114402Sru /* We have to count the true elements in MASK. */ 158114402Sru total = count_0 (mask); 159114402Sru } 160114402Sru 161114402Sru if (ret->base_addr == NULL) 162114402Sru { 163114402Sru /* Setup the array descriptor. */ 164114402Sru GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); 165114402Sru 166114402Sru ret->offset = 0; 167114402Sru 168114402Sru /* xmallocarray allocates a single byte for zero size. */ 169114402Sru ret->base_addr = xmallocarray (total, sizeof (GFC_INTEGER_8)); 170114402Sru 171114402Sru if (total == 0) 172114402Sru return; 173114402Sru } 174114402Sru else 175114402Sru { 176114402Sru /* We come here because of range checking. */ 177114402Sru index_type ret_extent; 178114402Sru 179114402Sru ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); 180114402Sru if (total != ret_extent) 181114402Sru runtime_error ("Incorrect extent in return value of PACK intrinsic;" 182114402Sru " is %ld, should be %ld", (long int) total, 183114402Sru (long int) ret_extent); 184114402Sru } 185114402Sru } 186114402Sru 187114402Sru rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); 188114402Sru if (rstride0 == 0) 189114402Sru rstride0 = 1; 190114402Sru sstride0 = sstride[0]; 191114402Sru mstride0 = mstride[0]; 192114402Sru rptr = ret->base_addr; 193114402Sru 194114402Sru while (sptr && mptr) 195114402Sru { 196114402Sru /* Test this element. */ 197114402Sru if (*mptr) 198114402Sru { 199114402Sru /* Add it. */ 200114402Sru *rptr = *sptr; 201114402Sru rptr += rstride0; 202114402Sru } 203114402Sru /* Advance to the next element. */ 204114402Sru sptr += sstride0; 205114402Sru mptr += mstride0; 206114402Sru count[0]++; 207114402Sru n = 0; 208114402Sru while (count[n] == extent[n]) 209114402Sru { 210114402Sru /* When we get to the end of a dimension, reset it and increment 211114402Sru the next dimension. */ 212114402Sru count[n] = 0; 213114402Sru /* We could precalculate these products, but this is a less 214114402Sru frequently used path so probably not worth it. */ 215 sptr -= sstride[n] * extent[n]; 216 mptr -= mstride[n] * extent[n]; 217 n++; 218 if (n >= dim) 219 { 220 /* Break out of the loop. */ 221 sptr = NULL; 222 break; 223 } 224 else 225 { 226 count[n]++; 227 sptr += sstride[n]; 228 mptr += mstride[n]; 229 } 230 } 231 } 232 233 /* Add any remaining elements from VECTOR. */ 234 if (vector) 235 { 236 n = GFC_DESCRIPTOR_EXTENT(vector,0); 237 nelem = ((rptr - ret->base_addr) / rstride0); 238 if (n > nelem) 239 { 240 sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); 241 if (sstride0 == 0) 242 sstride0 = 1; 243 244 sptr = vector->base_addr + sstride0 * nelem; 245 n -= nelem; 246 while (n--) 247 { 248 *rptr = *sptr; 249 rptr += rstride0; 250 sptr += sstride0; 251 } 252 } 253 } 254} 255 256#endif 257 258