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 atype` * const restrict, const 'index_type` * const restrict'back_arg`); 24 export_proto('name`'rtype_qual`_'atype_code); 25 26 void 27 name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 28 'atype` * const restrict array, 29 const index_type * const restrict pdim'back_arg`) 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 'atype_name * 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 continue_loop; 43 44 /* Make dim zero based to avoid confusion. */ 45 rank = GFC_DESCRIPTOR_RANK (array) - 1; 46 dim = (*pdim) - 1; 47 48 if (unlikely (dim < 0 || dim > rank)) 49 { 50 runtime_error ("Dim argument incorrect in u_name intrinsic: " 51 "is %ld, should be between 1 and %ld", 52 (long int) dim + 1, (long int) rank + 1); 53 } 54 55 len = GFC_DESCRIPTOR_EXTENT(array,dim); 56 if (len < 0) 57 len = 0; 58 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 59 60 for (n = 0; n < dim; n++) 61 { 62 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 63 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 64 65 if (extent[n] < 0) 66 extent[n] = 0; 67 } 68 for (n = dim; n < rank; n++) 69 { 70 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 71 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 72 73 if (extent[n] < 0) 74 extent[n] = 0; 75 } 76 77 if (retarray->base_addr == NULL) 78 { 79 size_t alloc_size, str; 80 81 for (n = 0; n < rank; n++) 82 { 83 if (n == 0) 84 str = 1; 85 else 86 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 87 88 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 89 90 } 91 92 retarray->offset = 0; 93 retarray->dtype.rank = rank; 94 95 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 96 97 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); 98 if (alloc_size == 0) 99 return; 100 } 101 else 102 { 103 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 104 runtime_error ("rank of return array incorrect in" 105 " u_name intrinsic: is %ld, should be %ld", 106 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 107 (long int) rank); 108 109 if (unlikely (compile_options.bounds_check)) 110 bounds_ifunction_return ((array_t *) retarray, extent, 111 "return value", "u_name"); 112 } 113 114 for (n = 0; n < rank; n++) 115 { 116 count[n] = 0; 117 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 118 if (extent[n] <= 0) 119 return; 120 } 121 122 base = array->base_addr; 123 dest = retarray->base_addr; 124 125 continue_loop = 1; 126 while (continue_loop) 127 { 128 const atype_name * restrict src; 129 rtype_name result; 130 src = base; 131 { 132 ')dnl 133 define(START_ARRAY_BLOCK, 134 ` if (len <= 0) 135 *dest = '$1`; 136 else 137 { 138 #if ! defined HAVE_BACK_ARG 139 for (n = 0; n < len; n++, src += delta) 140 { 141 #endif 142 ')dnl 143 define(FINISH_ARRAY_FUNCTION, 144 ` } 145 '$1` 146 *dest = result; 147 } 148 } 149 /* Advance to the next element. */ 150 count[0]++; 151 base += sstride[0]; 152 dest += dstride[0]; 153 n = 0; 154 while (count[n] == extent[n]) 155 { 156 /* When we get to the end of a dimension, reset it and increment 157 the next dimension. */ 158 count[n] = 0; 159 /* We could precalculate these products, but this is a less 160 frequently used path so probably not worth it. */ 161 base -= sstride[n] * extent[n]; 162 dest -= dstride[n] * extent[n]; 163 n++; 164 if (n >= rank) 165 { 166 /* Break out of the loop. */ 167 continue_loop = 0; 168 break; 169 } 170 else 171 { 172 count[n]++; 173 base += sstride[n]; 174 dest += dstride[n]; 175 } 176 } 177 } 178 }')dnl 179 define(START_MASKED_ARRAY_FUNCTION, 180 ` 181 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict, 182 'atype` * const restrict, const 'index_type` * const restrict, 183 gfc_array_l1 * const restrict'back_arg`); 184 export_proto(m'name`'rtype_qual`_'atype_code`); 185 186 void 187 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 188 'atype` * const restrict array, 189 const index_type * const restrict pdim, 190 gfc_array_l1 * const restrict mask'back_arg`) 191 { 192 index_type count[GFC_MAX_DIMENSIONS]; 193 index_type extent[GFC_MAX_DIMENSIONS]; 194 index_type sstride[GFC_MAX_DIMENSIONS]; 195 index_type dstride[GFC_MAX_DIMENSIONS]; 196 index_type mstride[GFC_MAX_DIMENSIONS]; 197 'rtype_name * restrict dest; 198 const atype_name * restrict base; 199 const GFC_LOGICAL_1 * restrict mbase; 200 index_type rank; 201 index_type dim; 202 index_type n; 203 index_type len; 204 index_type delta; 205 index_type mdelta; 206 int mask_kind; 207 208 if (mask == NULL) 209 { 210 #ifdef HAVE_BACK_ARG 211 name`'rtype_qual`_'atype_code (retarray, array, pdim, back); 212 #else 213 name`'rtype_qual`_'atype_code (retarray, array, pdim); 214 #endif 215 return; 216 } 217 218 dim = (*pdim) - 1; 219 rank = GFC_DESCRIPTOR_RANK (array) - 1; 220 221 222 if (unlikely (dim < 0 || dim > rank)) 223 { 224 runtime_error ("Dim argument incorrect in u_name intrinsic: " 225 "is %ld, should be between 1 and %ld", 226 (long int) dim + 1, (long int) rank + 1); 227 } 228 229 len = GFC_DESCRIPTOR_EXTENT(array,dim); 230 if (len < 0) 231 len = 0; 232 233 mbase = mask->base_addr; 234 235 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 236 237 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 238 #ifdef HAVE_GFC_LOGICAL_16 239 || mask_kind == 16 240 #endif 241 ) 242 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 243 else 244 runtime_error ("Funny sized logical array"); 245 246 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 247 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); 248 249 for (n = 0; n < dim; n++) 250 { 251 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 252 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 253 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 254 255 if (extent[n] < 0) 256 extent[n] = 0; 257 258 } 259 for (n = dim; n < rank; n++) 260 { 261 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); 262 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); 263 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 264 265 if (extent[n] < 0) 266 extent[n] = 0; 267 } 268 269 if (retarray->base_addr == NULL) 270 { 271 size_t alloc_size, str; 272 273 for (n = 0; n < rank; n++) 274 { 275 if (n == 0) 276 str = 1; 277 else 278 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 279 280 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 281 282 } 283 284 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 285 286 retarray->offset = 0; 287 retarray->dtype.rank = rank; 288 289 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); 290 if (alloc_size == 0) 291 return; 292 } 293 else 294 { 295 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 296 runtime_error ("rank of return array incorrect in u_name intrinsic"); 297 298 if (unlikely (compile_options.bounds_check)) 299 { 300 bounds_ifunction_return ((array_t *) retarray, extent, 301 "return value", "u_name"); 302 bounds_equal_extents ((array_t *) mask, (array_t *) array, 303 "MASK argument", "u_name"); 304 } 305 } 306 307 for (n = 0; n < rank; n++) 308 { 309 count[n] = 0; 310 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 311 if (extent[n] <= 0) 312 return; 313 } 314 315 dest = retarray->base_addr; 316 base = array->base_addr; 317 318 while (base) 319 { 320 const atype_name * restrict src; 321 const GFC_LOGICAL_1 * restrict msrc; 322 rtype_name result; 323 src = base; 324 msrc = mbase; 325 { 326 ')dnl 327 define(START_MASKED_ARRAY_BLOCK, 328 ` for (n = 0; n < len; n++, src += delta, msrc += mdelta) 329 { 330 ')dnl 331 define(FINISH_MASKED_ARRAY_FUNCTION, 332 ` } 333 *dest = result; 334 } 335 /* Advance to the next element. */ 336 count[0]++; 337 base += sstride[0]; 338 mbase += mstride[0]; 339 dest += dstride[0]; 340 n = 0; 341 while (count[n] == extent[n]) 342 { 343 /* When we get to the end of a dimension, reset it and increment 344 the next dimension. */ 345 count[n] = 0; 346 /* We could precalculate these products, but this is a less 347 frequently used path so probably not worth it. */ 348 base -= sstride[n] * extent[n]; 349 mbase -= mstride[n] * extent[n]; 350 dest -= dstride[n] * extent[n]; 351 n++; 352 if (n >= rank) 353 { 354 /* Break out of the loop. */ 355 base = NULL; 356 break; 357 } 358 else 359 { 360 count[n]++; 361 base += sstride[n]; 362 mbase += mstride[n]; 363 dest += dstride[n]; 364 } 365 } 366 } 367 }')dnl 368 define(SCALAR_ARRAY_FUNCTION, 369 ` 370 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict, 371 'atype` * const restrict, const index_type * const restrict, 372 GFC_LOGICAL_4 *'back_arg`); 373 export_proto(s'name`'rtype_qual`_'atype_code); 374 375 void 376 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 377 'atype` * const restrict array, 378 const index_type * const restrict pdim, 379 GFC_LOGICAL_4 * mask'back_arg`) 380 { 381 index_type count[GFC_MAX_DIMENSIONS]; 382 index_type extent[GFC_MAX_DIMENSIONS]; 383 index_type dstride[GFC_MAX_DIMENSIONS]; 384 'rtype_name * restrict dest; 385 index_type rank; 386 index_type n; 387 index_type dim; 388 389 390 if (mask == NULL || *mask) 391 { 392 #ifdef HAVE_BACK_ARG 393 name`'rtype_qual`_'atype_code (retarray, array, pdim, back); 394 #else 395 name`'rtype_qual`_'atype_code (retarray, array, pdim); 396 #endif 397 return; 398 } 399 /* Make dim zero based to avoid confusion. */ 400 dim = (*pdim) - 1; 401 rank = GFC_DESCRIPTOR_RANK (array) - 1; 402 403 if (unlikely (dim < 0 || dim > rank)) 404 { 405 runtime_error ("Dim argument incorrect in u_name intrinsic: " 406 "is %ld, should be between 1 and %ld", 407 (long int) dim + 1, (long int) rank + 1); 408 } 409 410 for (n = 0; n < dim; n++) 411 { 412 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 413 414 if (extent[n] <= 0) 415 extent[n] = 0; 416 } 417 418 for (n = dim; n < rank; n++) 419 { 420 extent[n] = 421 GFC_DESCRIPTOR_EXTENT(array,n + 1); 422 423 if (extent[n] <= 0) 424 extent[n] = 0; 425 } 426 427 if (retarray->base_addr == NULL) 428 { 429 size_t alloc_size, str; 430 431 for (n = 0; n < rank; n++) 432 { 433 if (n == 0) 434 str = 1; 435 else 436 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 437 438 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 439 440 } 441 442 retarray->offset = 0; 443 retarray->dtype.rank = rank; 444 445 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 446 447 retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); 448 if (alloc_size == 0) 449 return; 450 } 451 else 452 { 453 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 454 runtime_error ("rank of return array incorrect in" 455 " u_name intrinsic: is %ld, should be %ld", 456 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 457 (long int) rank); 458 459 if (unlikely (compile_options.bounds_check)) 460 { 461 for (n=0; n < rank; n++) 462 { 463 index_type ret_extent; 464 465 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 466 if (extent[n] != ret_extent) 467 runtime_error ("Incorrect extent in return value of" 468 " u_name intrinsic in dimension %ld:" 469 " is %ld, should be %ld", (long int) n + 1, 470 (long int) ret_extent, (long int) extent[n]); 471 } 472 } 473 } 474 475 for (n = 0; n < rank; n++) 476 { 477 count[n] = 0; 478 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 479 } 480 481 dest = retarray->base_addr; 482 483 while(1) 484 { 485 *dest = '$1`; 486 count[0]++; 487 dest += dstride[0]; 488 n = 0; 489 while (count[n] == extent[n]) 490 { 491 /* When we get to the end of a dimension, reset it and increment 492 the next dimension. */ 493 count[n] = 0; 494 /* We could precalculate these products, but this is a less 495 frequently used path so probably not worth it. */ 496 dest -= dstride[n] * extent[n]; 497 n++; 498 if (n >= rank) 499 return; 500 else 501 { 502 count[n]++; 503 dest += dstride[n]; 504 } 505 } 506 } 507 }')dnl 508 define(ARRAY_FUNCTION, 509 `START_ARRAY_FUNCTION 510 $2 511 START_ARRAY_BLOCK($1) 512 $3 513 FINISH_ARRAY_FUNCTION($4)')dnl 514 define(MASKED_ARRAY_FUNCTION, 515 `START_MASKED_ARRAY_FUNCTION 516 $2 517 START_MASKED_ARRAY_BLOCK 518 $3 519 FINISH_MASKED_ARRAY_FUNCTION')dnl 520
Indexes created Mon Mar 30 00:23:01 UTC 2026