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