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