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`static inline int 7compare_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#define INITVAL 'initval` 17 18extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict, 19 gfc_charlen_type, 20 atype * const restrict array, gfc_charlen_type); 21export_proto(name`'rtype_qual`_'atype_code); 22 23void 24name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret, 25 gfc_charlen_type xlen, 26 'atype` * const restrict array, gfc_charlen_type len) 27{ 28 index_type count[GFC_MAX_DIMENSIONS]; 29 index_type extent[GFC_MAX_DIMENSIONS]; 30 index_type sstride[GFC_MAX_DIMENSIONS]; 31 const 'atype_name` *base; 32 index_type rank; 33 index_type n; 34 35 rank = GFC_DESCRIPTOR_RANK (array); 36 if (rank <= 0) 37 runtime_error ("Rank of array needs to be > 0"); 38 39 assert (xlen == len); 40 41 /* Initialize return value. */ 42 memset (ret, INITVAL, sizeof(*ret) * len); 43 44 for (n = 0; n < rank; n++) 45 { 46 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; 47 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 48 count[n] = 0; 49 if (extent[n] <= 0) 50 return; 51 } 52 53 base = array->base_addr; 54 55 { 56')dnl 57define(START_FOREACH_BLOCK, 58` while (base) 59 { 60 do 61 { 62 /* Implementation start. */ 63')dnl 64define(FINISH_FOREACH_FUNCTION, 65` /* Implementation end. */ 66 /* Advance to the next element. */ 67 base += sstride[0]; 68 } 69 while (++count[0] != extent[0]); 70 n = 0; 71 do 72 { 73 /* When we get to the end of a dimension, reset it and increment 74 the next dimension. */ 75 count[n] = 0; 76 /* We could precalculate these products, but this is a less 77 frequently used path so probably not worth it. */ 78 base -= sstride[n] * extent[n]; 79 n++; 80 if (n >= rank) 81 { 82 /* Break out of the loop. */ 83 base = NULL; 84 break; 85 } 86 else 87 { 88 count[n]++; 89 base += sstride[n]; 90 } 91 } 92 while (count[n] == extent[n]); 93 } 94 memcpy (ret, retval, len * sizeof (*ret)); 95 } 96}')dnl 97define(START_MASKED_FOREACH_FUNCTION, 98` 99extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict, 100 gfc_charlen_type, atype * const restrict array, 101 gfc_array_l1 * const restrict mask, gfc_charlen_type len); 102export_proto(`m'name`'rtype_qual`_'atype_code); 103 104void 105`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret, 106 gfc_charlen_type xlen, atype * const restrict array, 107 gfc_array_l1 * const restrict mask, gfc_charlen_type len) 108{ 109 index_type count[GFC_MAX_DIMENSIONS]; 110 index_type extent[GFC_MAX_DIMENSIONS]; 111 index_type sstride[GFC_MAX_DIMENSIONS]; 112 index_type mstride[GFC_MAX_DIMENSIONS]; 113 const atype_name *base; 114 GFC_LOGICAL_1 *mbase; 115 int rank; 116 index_type n; 117 int mask_kind; 118 119 if (mask == NULL) 120 { 121 name`'rtype_qual`_'atype_code (ret, xlen, array, len); 122 return; 123 } 124 125 rank = GFC_DESCRIPTOR_RANK (array); 126 if (rank <= 0) 127 runtime_error ("Rank of array needs to be > 0"); 128 129 assert (xlen == len); 130 131/* Initialize return value. */ 132 memset (ret, INITVAL, sizeof(*ret) * len); 133 134 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 135 136 mbase = mask->base_addr; 137 138 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 139#ifdef HAVE_GFC_LOGICAL_16 140 || mask_kind == 16 141#endif 142 ) 143 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 144 else 145 runtime_error ("Funny sized logical array"); 146 147 for (n = 0; n < rank; n++) 148 { 149 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; 150 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 151 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 152 count[n] = 0; 153 if (extent[n] <= 0) 154 return; 155 } 156 157 base = array->base_addr; 158 { 159')dnl 160define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl 161define(FINISH_MASKED_FOREACH_FUNCTION, 162` /* Implementation end. */ 163 /* Advance to the next element. */ 164 base += sstride[0]; 165 mbase += mstride[0]; 166 } 167 while (++count[0] != extent[0]); 168 n = 0; 169 do 170 { 171 /* When we get to the end of a dimension, reset it and increment 172 the next dimension. */ 173 count[n] = 0; 174 /* We could precalculate these products, but this is a less 175 frequently used path so probably not worth it. */ 176 base -= sstride[n] * extent[n]; 177 mbase -= mstride[n] * extent[n]; 178 n++; 179 if (n >= rank) 180 { 181 /* Break out of the loop. */ 182 base = NULL; 183 break; 184 } 185 else 186 { 187 count[n]++; 188 base += sstride[n]; 189 mbase += mstride[n]; 190 } 191 } 192 while (count[n] == extent[n]); 193 } 194 memcpy (ret, retval, len * sizeof (*ret)); 195 } 196}')dnl 197define(FOREACH_FUNCTION, 198`START_FOREACH_FUNCTION 199$1 200START_FOREACH_BLOCK 201$2 202FINISH_FOREACH_FUNCTION')dnl 203define(MASKED_FOREACH_FUNCTION, 204`START_MASKED_FOREACH_FUNCTION 205$1 206START_MASKED_FOREACH_BLOCK 207$2 208FINISH_MASKED_FOREACH_FUNCTION')dnl 209define(SCALAR_FOREACH_FUNCTION, 210` 211extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict, 212 gfc_charlen_type, 213 atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); 214export_proto(`s'name`'rtype_qual`_'atype_code); 215 216void 217`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret, 218 gfc_charlen_type xlen, atype * const restrict array, 219 GFC_LOGICAL_4 *mask, gfc_charlen_type len) 220 221{ 222 if (mask == NULL || *mask) 223 { 224 name`'rtype_qual`_'atype_code (ret, xlen, array, len); 225 return; 226 } 227 memset (ret, INITVAL, sizeof (*ret) * len); 228}')dnl 229