1 dnl Support macro file for intrinsic functions. 2 dnl Contains the generic sections of the array functions. 3 dnl This file is part of the GNU Fortran Runtime Library (libgfortran) 4 dnl Distributed under the GNU GPL with exception. See COPYING for details. 5 define(START_FOREACH_FUNCTION, 6 `static inline int 7 compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) 8 { 9 if (sizeof ('atype_name`) == 1) 10 return memcmp (a, b, n); 11 else 12 return memcmp_char4 (a, b, n); 13 14 } 15 16 extern void name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 17 'atype` * const restrict array'back_arg`, gfc_charlen_type len); 18 export_proto('name`'rtype_qual`_'atype_code); 19 20 void 21 name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 22 'atype` * const restrict array'back_arg`, gfc_charlen_type len) 23 { 24 index_type count[GFC_MAX_DIMENSIONS]; 25 index_type extent[GFC_MAX_DIMENSIONS]; 26 index_type sstride[GFC_MAX_DIMENSIONS]; 27 index_type dstride; 28 const 'atype_name *base; 29 rtype_name * restrict dest; 30 index_type rank; 31 index_type n; 32 33 rank = GFC_DESCRIPTOR_RANK (array); 34 if (rank <= 0) 35 runtime_error ("Rank of array needs to be > 0"); 36 37 if (retarray->base_addr == NULL) 38 { 39 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 40 retarray->dtype.rank = 1; 41 retarray->offset = 0; 42 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name)); 43 } 44 else 45 { 46 if (unlikely (compile_options.bounds_check)) 47 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 48 "u_name"); 49 } 50 51 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 52 dest = retarray->base_addr; 53 for (n = 0; n < rank; n++) 54 { 55 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; 56 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 57 count[n] = 0; 58 if (extent[n] <= 0) 59 { 60 /* Set the return value. */ 61 for (n = 0; n < rank; n++) 62 dest[n * dstride] = 0; 63 return; 64 } 65 } 66 67 base = array->base_addr; 68 69 /* Initialize the return value. */ 70 for (n = 0; n < rank; n++) 71 dest[n * dstride] = 1; 72 { 73 ')dnl 74 define(START_FOREACH_BLOCK, 75 ` while (base) 76 { 77 do 78 { 79 /* Implementation start. */ 80 ')dnl 81 define(FINISH_FOREACH_FUNCTION, 82 ` /* Implementation end. */ 83 /* Advance to the next element. */ 84 base += sstride[0]; 85 } 86 while (++count[0] != extent[0]); 87 n = 0; 88 do 89 { 90 /* When we get to the end of a dimension, reset it and increment 91 the next dimension. */ 92 count[n] = 0; 93 /* We could precalculate these products, but this is a less 94 frequently used path so probably not worth it. */ 95 base -= sstride[n] * extent[n]; 96 n++; 97 if (n >= rank) 98 { 99 /* Break out of the loop. */ 100 base = NULL; 101 break; 102 } 103 else 104 { 105 count[n]++; 106 base += sstride[n]; 107 } 108 } 109 while (count[n] == extent[n]); 110 } 111 } 112 }')dnl 113 define(START_MASKED_FOREACH_FUNCTION, 114 ` 115 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict, 116 'atype` * const restrict, gfc_array_l1 * const restrict 'back_arg`, 117 gfc_charlen_type len); 118 export_proto(m'name`'rtype_qual`_'atype_code`); 119 120 void 121 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 122 'atype` * const restrict array, 123 gfc_array_l1 * const restrict mask'back_arg`, 124 gfc_charlen_type len) 125 { 126 index_type count[GFC_MAX_DIMENSIONS]; 127 index_type extent[GFC_MAX_DIMENSIONS]; 128 index_type sstride[GFC_MAX_DIMENSIONS]; 129 index_type mstride[GFC_MAX_DIMENSIONS]; 130 index_type dstride; 131 'rtype_name *dest; 132 const atype_name *base; 133 GFC_LOGICAL_1 *mbase; 134 int rank; 135 index_type n; 136 int mask_kind; 137 138 if (mask == NULL) 139 { 140 #ifdef HAVE_BACK_ARG 141 name`'rtype_qual`_'atype_code (retarray, array, back, len); 142 #else 143 name`'rtype_qual`_'atype_code (retarray, array, len); 144 #endif 145 return; 146 } 147 148 rank = GFC_DESCRIPTOR_RANK (array); 149 if (rank <= 0) 150 runtime_error ("Rank of array needs to be > 0"); 151 152 if (retarray->base_addr == NULL) 153 { 154 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); 155 retarray->dtype.rank = 1; 156 retarray->offset = 0; 157 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name)); 158 } 159 else 160 { 161 if (unlikely (compile_options.bounds_check)) 162 { 163 164 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 165 "u_name"); 166 bounds_equal_extents ((array_t *) mask, (array_t *) array, 167 "MASK argument", "u_name"); 168 } 169 } 170 171 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 172 173 mbase = mask->base_addr; 174 175 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 176 #ifdef HAVE_GFC_LOGICAL_16 177 || mask_kind == 16 178 #endif 179 ) 180 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 181 else 182 runtime_error ("Funny sized logical array"); 183 184 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 185 dest = retarray->base_addr; 186 for (n = 0; n < rank; n++) 187 { 188 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; 189 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 190 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 191 count[n] = 0; 192 if (extent[n] <= 0) 193 { 194 /* Set the return value. */ 195 for (n = 0; n < rank; n++) 196 dest[n * dstride] = 0; 197 return; 198 } 199 } 200 201 base = array->base_addr; 202 203 /* Initialize the return value. */ 204 for (n = 0; n < rank; n++) 205 dest[n * dstride] = 0; 206 { 207 ')dnl 208 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl 209 define(FINISH_MASKED_FOREACH_FUNCTION, 210 ` /* Implementation end. */ 211 /* Advance to the next element. */ 212 base += sstride[0]; 213 mbase += mstride[0]; 214 } 215 while (++count[0] != extent[0]); 216 n = 0; 217 do 218 { 219 /* When we get to the end of a dimension, reset it and increment 220 the next dimension. */ 221 count[n] = 0; 222 /* We could precalculate these products, but this is a less 223 frequently used path so probably not worth it. */ 224 base -= sstride[n] * extent[n]; 225 mbase -= mstride[n] * extent[n]; 226 n++; 227 if (n >= rank) 228 { 229 /* Break out of the loop. */ 230 base = NULL; 231 break; 232 } 233 else 234 { 235 count[n]++; 236 base += sstride[n]; 237 mbase += mstride[n]; 238 } 239 } 240 while (count[n] == extent[n]); 241 } 242 } 243 }')dnl 244 define(FOREACH_FUNCTION, 245 `START_FOREACH_FUNCTION 246 $1 247 START_FOREACH_BLOCK 248 $2 249 FINISH_FOREACH_FUNCTION')dnl 250 define(MASKED_FOREACH_FUNCTION, 251 `START_MASKED_FOREACH_FUNCTION 252 $1 253 START_MASKED_FOREACH_BLOCK 254 $2 255 FINISH_MASKED_FOREACH_FUNCTION')dnl 256 define(SCALAR_FOREACH_FUNCTION, 257 ` 258 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict, 259 'atype` * const restrict, GFC_LOGICAL_4 *'back_arg`, 260 gfc_charlen_type len); 261 export_proto(s'name`'rtype_qual`_'atype_code); 262 263 void 264 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 265 'atype` * const restrict array, 266 GFC_LOGICAL_4 * mask'back_arg`, 267 gfc_charlen_type len) 268 { 269 index_type rank; 270 index_type dstride; 271 index_type n; 272 'rtype_name *dest; 273 274 if (mask == NULL || *mask) 275 { 276 #ifdef HAVE_BACK_ARG 277 name`'rtype_qual`_'atype_code (retarray, array, back, len); 278 #else 279 name`'rtype_qual`_'atype_code (retarray, array, len); 280 #endif 281 return; 282 } 283 284 rank = GFC_DESCRIPTOR_RANK (array); 285 286 if (rank <= 0) 287 runtime_error ("Rank of array needs to be > 0"); 288 289 if (retarray->base_addr == NULL) 290 { 291 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 292 retarray->dtype.rank = 1; 293 retarray->offset = 0; 294 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name)); 295 } 296 else if (unlikely (compile_options.bounds_check)) 297 { 298 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 299 "u_name"); 300 } 301 302 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 303 dest = retarray->base_addr; 304 for (n = 0; n<rank; n++) 305 dest[n * dstride] = $1 ; 306 }')dnl 307
Indexes created Sun Oct 25 00:26:45 UTC 2026