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