1/* Implementation of the COUNT intrinsic 2 Copyright (C) 2002-2020 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 28 29#if defined (HAVE_GFC_INTEGER_1) 30 31 32extern void count_1_l (gfc_array_i1 * const restrict, 33 gfc_array_l1 * const restrict, const index_type * const restrict); 34export_proto(count_1_l); 35 36void 37count_1_l (gfc_array_i1 * const restrict retarray, 38 gfc_array_l1 * const restrict array, 39 const index_type * const restrict pdim) 40{ 41 index_type count[GFC_MAX_DIMENSIONS]; 42 index_type extent[GFC_MAX_DIMENSIONS]; 43 index_type sstride[GFC_MAX_DIMENSIONS]; 44 index_type dstride[GFC_MAX_DIMENSIONS]; 45 const GFC_LOGICAL_1 * restrict base; 46 GFC_INTEGER_1 * restrict dest; 47 index_type rank; 48 index_type n; 49 index_type len; 50 index_type delta; 51 index_type dim; 52 int src_kind; 53 int continue_loop; 54 55 /* Make dim zero based to avoid confusion. */ 56 dim = (*pdim) - 1; 57 rank = GFC_DESCRIPTOR_RANK (array) - 1; 58 59 src_kind = GFC_DESCRIPTOR_SIZE (array); 60 61 len = GFC_DESCRIPTOR_EXTENT(array,dim); 62 if (len < 0) 63 len = 0; 64 65 delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 66 67 for (n = 0; n < dim; n++) 68 { 69 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); 70 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 71 72 if (extent[n] < 0) 73 extent[n] = 0; 74 } 75 for (n = dim; n < rank; n++) 76 { 77 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); 78 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); 79 80 if (extent[n] < 0) 81 extent[n] = 0; 82 } 83 84 if (retarray->base_addr == NULL) 85 { 86 size_t alloc_size, str; 87 88 for (n = 0; n < rank; n++) 89 { 90 if (n == 0) 91 str = 1; 92 else 93 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 94 95 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 96 97 } 98 99 retarray->offset = 0; 100 retarray->dtype.rank = rank; 101 102 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 103 104 if (alloc_size == 0) 105 { 106 /* Make sure we have a zero-sized array. */ 107 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 108 return; 109 } 110 else 111 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); 112 } 113 else 114 { 115 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 116 runtime_error ("rank of return array incorrect in" 117 " COUNT intrinsic: is %ld, should be %ld", 118 (long int) GFC_DESCRIPTOR_RANK (retarray), 119 (long int) rank); 120 121 if (unlikely (compile_options.bounds_check)) 122 { 123 for (n=0; n < rank; n++) 124 { 125 index_type ret_extent; 126 127 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 128 if (extent[n] != ret_extent) 129 runtime_error ("Incorrect extent in return value of" 130 " COUNT intrinsic in dimension %d:" 131 " is %ld, should be %ld", (int) n + 1, 132 (long int) ret_extent, (long int) extent[n]); 133 } 134 } 135 } 136 137 for (n = 0; n < rank; n++) 138 { 139 count[n] = 0; 140 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 141 if (extent[n] <= 0) 142 return; 143 } 144 145 base = array->base_addr; 146 147 if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 148#ifdef HAVE_GFC_LOGICAL_16 149 || src_kind == 16 150#endif 151 ) 152 { 153 if (base) 154 base = GFOR_POINTER_TO_L1 (base, src_kind); 155 } 156 else 157 internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); 158 159 dest = retarray->base_addr; 160 161 continue_loop = 1; 162 while (continue_loop) 163 { 164 const GFC_LOGICAL_1 * restrict src; 165 GFC_INTEGER_1 result; 166 src = base; 167 { 168 169 result = 0; 170 if (len <= 0) 171 *dest = 0; 172 else 173 { 174 for (n = 0; n < len; n++, src += delta) 175 { 176 177 if (*src) 178 result++; 179 } 180 *dest = result; 181 } 182 } 183 /* Advance to the next element. */ 184 count[0]++; 185 base += sstride[0]; 186 dest += dstride[0]; 187 n = 0; 188 while (count[n] == extent[n]) 189 { 190 /* When we get to the end of a dimension, reset it and increment 191 the next dimension. */ 192 count[n] = 0; 193 /* We could precalculate these products, but this is a less 194 frequently used path so probably not worth it. */ 195 base -= sstride[n] * extent[n]; 196 dest -= dstride[n] * extent[n]; 197 n++; 198 if (n >= rank) 199 { 200 /* Break out of the loop. */ 201 continue_loop = 0; 202 break; 203 } 204 else 205 { 206 count[n]++; 207 base += sstride[n]; 208 dest += dstride[n]; 209 } 210 } 211 } 212} 213 214#endif 215