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 dnl 6 dnl Pass the implementation for a single section as the parameter to 7 dnl {MASK_}ARRAY_FUNCTION. 8 dnl The variables base, delta, and len describe the input section. 9 dnl For masked section the mask is described by mbase and mdelta. 10 dnl These should not be modified. The result should be stored in *dest. 11 dnl The names count, extent, sstride, dstride, base, dest, rank, dim 12 dnl retarray, array, pdim and mstride should not be used. 13 dnl The variable n is declared as index_type and may be used. 14 dnl Other variable declarations may be placed at the start of the code, 15 dnl The types of the array parameter and the return value are 16 dnl atype_name and rtype_name respectively. 17 dnl Execution should be allowed to continue to the end of the block. 18 dnl You should not return or break from the inner loop of the implementation. 19 dnl Care should also be taken to avoid using the names defined in iparm.m4 20 define(START_ARRAY_FUNCTION, 21 ` 22 extern void name`'rtype_qual`_'atype_code (rtype * const restrict, 23 gfc_array_l1 * const restrict, const index_type * const restrict); 24 export_proto(name`'rtype_qual`_'atype_code); 25 26 void 27 name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 28 gfc_array_l1 * const restrict array, 29 const index_type * const restrict pdim) 30 { 31 index_type count[GFC_MAX_DIMENSIONS]; 32 index_type extent[GFC_MAX_DIMENSIONS]; 33 index_type sstride[GFC_MAX_DIMENSIONS]; 34 index_type dstride[GFC_MAX_DIMENSIONS]; 35 const GFC_LOGICAL_1 * restrict base; 36 rtype_name * restrict dest; 37 index_type rank; 38 index_type n; 39 index_type len; 40 index_type delta; 41 index_type dim; 42 int src_kind; 43 int continue_loop; 44 45 /* Make dim zero based to avoid confusion. */ 46 dim = (*pdim) - 1; 47 rank = GFC_DESCRIPTOR_RANK (array) - 1; 48 49 src_kind = GFC_DESCRIPTOR_SIZE (array); 50 51 len = GFC_DESCRIPTOR_EXTENT(array,dim); 52 if (len < 0) 53 len = 0; 54 55 delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); 56 57 for (n = 0; n < dim; n++) 58 { 59 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); 60 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 61 62 if (extent[n] < 0) 63 extent[n] = 0; 64 } 65 for (n = dim; n < rank; n++) 66 { 67 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); 68 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); 69 70 if (extent[n] < 0) 71 extent[n] = 0; 72 } 73 74 if (retarray->base_addr == NULL) 75 { 76 size_t alloc_size, str; 77 78 for (n = 0; n < rank; n++) 79 { 80 if (n == 0) 81 str = 1; 82 else 83 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 84 85 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 86 87 } 88 89 retarray->offset = 0; 90 retarray->dtype.rank = rank; 91 92 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 93 94 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); 95 if (alloc_size == 0) 96 return; 97 } 98 else 99 { 100 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 101 runtime_error ("rank of return array incorrect in" 102 " u_name intrinsic: is %ld, should be %ld", 103 (long int) GFC_DESCRIPTOR_RANK (retarray), 104 (long int) rank); 105 106 if (unlikely (compile_options.bounds_check)) 107 { 108 for (n=0; n < rank; n++) 109 { 110 index_type ret_extent; 111 112 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 113 if (extent[n] != ret_extent) 114 runtime_error ("Incorrect extent in return value of" 115 " u_name intrinsic in dimension %d:" 116 " is %ld, should be %ld", (int) n + 1, 117 (long int) ret_extent, (long int) extent[n]); 118 } 119 } 120 } 121 122 for (n = 0; n < rank; n++) 123 { 124 count[n] = 0; 125 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 126 if (extent[n] <= 0) 127 return; 128 } 129 130 base = array->base_addr; 131 132 if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 133 #ifdef HAVE_GFC_LOGICAL_16 134 || src_kind == 16 135 #endif 136 ) 137 { 138 if (base) 139 base = GFOR_POINTER_TO_L1 (base, src_kind); 140 } 141 else 142 internal_error (NULL, "Funny sized logical array in u_name intrinsic"); 143 144 dest = retarray->base_addr; 145 146 continue_loop = 1; 147 while (continue_loop) 148 { 149 const GFC_LOGICAL_1 * restrict src; 150 rtype_name result; 151 src = base; 152 { 153 ')dnl 154 define(START_ARRAY_BLOCK, 155 ` if (len <= 0) 156 *dest = '$1`; 157 else 158 { 159 for (n = 0; n < len; n++, src += delta) 160 { 161 ')dnl 162 define(FINISH_ARRAY_FUNCTION, 163 ` } 164 *dest = result; 165 } 166 } 167 /* Advance to the next element. */ 168 count[0]++; 169 base += sstride[0]; 170 dest += dstride[0]; 171 n = 0; 172 while (count[n] == extent[n]) 173 { 174 /* When we get to the end of a dimension, reset it and increment 175 the next dimension. */ 176 count[n] = 0; 177 /* We could precalculate these products, but this is a less 178 frequently used path so probably not worth it. */ 179 base -= sstride[n] * extent[n]; 180 dest -= dstride[n] * extent[n]; 181 n++; 182 if (n >= rank) 183 { 184 /* Break out of the loop. */ 185 continue_loop = 0; 186 break; 187 } 188 else 189 { 190 count[n]++; 191 base += sstride[n]; 192 dest += dstride[n]; 193 } 194 } 195 } 196 }')dnl 197 define(ARRAY_FUNCTION, 198 `START_ARRAY_FUNCTION 199 $2 200 START_ARRAY_BLOCK($1) 201 $3 202 FINISH_ARRAY_FUNCTION')dnl 203
Indexes created Tue Mar 24 00:24:13 UTC 2026