1/* Functions to convert descriptors between CFI and gfortran 2 and the CFI function declarations whose prototypes appear 3 in ISO_Fortran_binding.h. 4 Copyright (C) 2018-2020 Free Software Foundation, Inc. 5 Contributed by Daniel Celis Garza <celisdanieljr@gmail.com> 6 and Paul Thomas <pault@gcc.gnu.org> 7 8This file is part of the GNU Fortran runtime library (libgfortran). 9 10Libgfortran is free software; you can redistribute it and/or 11modify it under the terms of the GNU General Public 12License as published by the Free Software Foundation; either 13version 3 of the License, or (at your option) any later version. 14 15Libgfortran is distributed in the hope that it will be useful, 16but WITHOUT ANY WARRANTY; without even the implied warranty of 17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18GNU General Public License for more details. 19 20Under Section 7 of GPL version 3, you are granted additional 21permissions described in the GCC Runtime Library Exception, version 223.1, as published by the Free Software Foundation. 23 24You should have received a copy of the GNU General Public License and 25a copy of the GCC Runtime Library Exception along with this program; 26see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 27<http://www.gnu.org/licenses/>. */ 28 29#include "libgfortran.h" 30#include <ISO_Fortran_binding.h> 31#include <string.h> 32 33extern void cfi_desc_to_gfc_desc (gfc_array_void *, CFI_cdesc_t **); 34export_proto(cfi_desc_to_gfc_desc); 35 36void 37cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr) 38{ 39 int n; 40 index_type kind; 41 CFI_cdesc_t *s = *s_ptr; 42 43 if (!s) 44 return; 45 46 GFC_DESCRIPTOR_DATA (d) = s->base_addr; 47 GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask); 48 kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift); 49 50 /* Correct the unfortunate difference in order with types. */ 51 if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER) 52 GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED; 53 else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED) 54 GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER; 55 56 if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len) 57 GFC_DESCRIPTOR_SIZE (d) = s->elem_len; 58 else if (GFC_DESCRIPTOR_TYPE (d) != BT_DERIVED) 59 GFC_DESCRIPTOR_SIZE (d) = kind; 60 else 61 GFC_DESCRIPTOR_SIZE (d) = s->elem_len; 62 63 d->dtype.version = s->version; 64 GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank; 65 66 d->dtype.attribute = (signed short)s->attribute; 67 68 if (s->rank) 69 { 70 if ((size_t)s->dim[0].sm % s->elem_len) 71 d->span = (index_type)s->dim[0].sm; 72 else 73 d->span = (index_type)s->elem_len; 74 } 75 76 d->offset = 0; 77 for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++) 78 { 79 GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound; 80 GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent 81 + s->dim[n].lower_bound - 1); 82 GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len); 83 d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n); 84 } 85} 86 87extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *); 88export_proto(gfc_desc_to_cfi_desc); 89 90void 91gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s) 92{ 93 int n; 94 CFI_cdesc_t *d; 95 96 /* Play it safe with allocation of the flexible array member 'dim' 97 by setting the length to CFI_MAX_RANK. This should not be necessary 98 but valgrind complains accesses after the allocated block. */ 99 if (*d_ptr == NULL) 100 d = malloc (sizeof (CFI_cdesc_t) 101 + (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t))); 102 else 103 d = *d_ptr; 104 105 d->base_addr = GFC_DESCRIPTOR_DATA (s); 106 d->elem_len = GFC_DESCRIPTOR_SIZE (s); 107 d->version = s->dtype.version; 108 d->rank = (CFI_rank_t)GFC_DESCRIPTOR_RANK (s); 109 d->attribute = (CFI_attribute_t)s->dtype.attribute; 110 111 if (GFC_DESCRIPTOR_TYPE (s) == BT_CHARACTER) 112 d->type = CFI_type_Character; 113 else if (GFC_DESCRIPTOR_TYPE (s) == BT_DERIVED) 114 d->type = CFI_type_struct; 115 else 116 d->type = (CFI_type_t)GFC_DESCRIPTOR_TYPE (s); 117 118 if (GFC_DESCRIPTOR_TYPE (s) != BT_DERIVED) 119 d->type = (CFI_type_t)(d->type 120 + ((CFI_type_t)d->elem_len << CFI_type_kind_shift)); 121 122 if (d->base_addr) 123 /* Full pointer or allocatable arrays retain their lower_bounds. */ 124 for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++) 125 { 126 if (d->attribute != CFI_attribute_other) 127 d->dim[n].lower_bound = (CFI_index_t)GFC_DESCRIPTOR_LBOUND(s, n); 128 else 129 d->dim[n].lower_bound = 0; 130 131 /* Assumed size arrays have gfc ubound == 0 and CFI extent = -1. */ 132 if (n == GFC_DESCRIPTOR_RANK (s) - 1 133 && GFC_DESCRIPTOR_LBOUND(s, n) == 1 134 && GFC_DESCRIPTOR_UBOUND(s, n) == 0) 135 d->dim[n].extent = -1; 136 else 137 d->dim[n].extent = (CFI_index_t)GFC_DESCRIPTOR_UBOUND(s, n) 138 - (CFI_index_t)GFC_DESCRIPTOR_LBOUND(s, n) + 1; 139 d->dim[n].sm = (CFI_index_t)(GFC_DESCRIPTOR_STRIDE(s, n) * s->span); 140 } 141 142 if (*d_ptr == NULL) 143 *d_ptr = d; 144} 145 146void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) 147{ 148 int i; 149 char *base_addr = (char *)dv->base_addr; 150 151 if (unlikely (compile_options.bounds_check)) 152 { 153 /* C Descriptor must not be NULL. */ 154 if (dv == NULL) 155 { 156 fprintf (stderr, "CFI_address: C Descriptor is NULL.\n"); 157 return NULL; 158 } 159 160 /* Base address of C Descriptor must not be NULL. */ 161 if (dv->base_addr == NULL) 162 { 163 fprintf (stderr, "CFI_address: base address of C Descriptor " 164 "must not be NULL.\n"); 165 return NULL; 166 } 167 } 168 169 /* Return base address if C descriptor is a scalar. */ 170 if (dv->rank == 0) 171 return dv->base_addr; 172 173 /* Calculate the appropriate base address if dv is not a scalar. */ 174 else 175 { 176 /* Base address is the C address of the element of the object 177 specified by subscripts. */ 178 for (i = 0; i < dv->rank; i++) 179 { 180 CFI_index_t idx = subscripts[i] - dv->dim[i].lower_bound; 181 if (unlikely (compile_options.bounds_check) 182 && ((dv->dim[i].extent != -1 && idx >= dv->dim[i].extent) 183 || idx < 0)) 184 { 185 fprintf (stderr, "CFI_address: subscripts[%d] is out of " 186 "bounds. For dimension = %d, subscripts = %d, " 187 "lower_bound = %d, upper bound = %d, extend = %d\n", 188 i, i, (int)subscripts[i], (int)dv->dim[i].lower_bound, 189 (int)(dv->dim[i].extent - dv->dim[i].lower_bound), 190 (int)dv->dim[i].extent); 191 return NULL; 192 } 193 194 base_addr = base_addr + (CFI_index_t)(idx * dv->dim[i].sm); 195 } 196 } 197 198 return (void *)base_addr; 199} 200 201 202int 203CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[], 204 const CFI_index_t upper_bounds[], size_t elem_len) 205{ 206 if (unlikely (compile_options.bounds_check)) 207 { 208 /* C Descriptor must not be NULL. */ 209 if (dv == NULL) 210 { 211 fprintf (stderr, "CFI_allocate: C Descriptor is NULL.\n"); 212 return CFI_INVALID_DESCRIPTOR; 213 } 214 215 /* The C Descriptor must be for an allocatable or pointer object. */ 216 if (dv->attribute == CFI_attribute_other) 217 { 218 fprintf (stderr, "CFI_allocate: The object of the C descriptor " 219 "must be a pointer or allocatable variable.\n"); 220 return CFI_INVALID_ATTRIBUTE; 221 } 222 223 /* Base address of C Descriptor must be NULL. */ 224 if (dv->base_addr != NULL) 225 { 226 fprintf (stderr, "CFI_allocate: Base address of C descriptor " 227 "must be NULL.\n"); 228 return CFI_ERROR_BASE_ADDR_NOT_NULL; 229 } 230 } 231 232 /* If the type is a character, the descriptor's element length is replaced 233 by the elem_len argument. */ 234 if (dv->type == CFI_type_char || dv->type == CFI_type_ucs4_char || 235 dv->type == CFI_type_signed_char) 236 dv->elem_len = elem_len; 237 238 /* Dimension information and calculating the array length. */ 239 size_t arr_len = 1; 240 241 /* If rank is greater than 0, lower_bounds and upper_bounds are used. They're 242 ignored otherwise. */ 243 if (dv->rank > 0) 244 { 245 if (unlikely (compile_options.bounds_check) 246 && (lower_bounds == NULL || upper_bounds == NULL)) 247 { 248 fprintf (stderr, "CFI_allocate: If 0 < rank (= %d) upper_bounds[] " 249 "and lower_bounds[], must not be NULL.\n", dv->rank); 250 return CFI_INVALID_EXTENT; 251 } 252 253 for (int i = 0; i < dv->rank; i++) 254 { 255 dv->dim[i].lower_bound = lower_bounds[i]; 256 dv->dim[i].extent = upper_bounds[i] - dv->dim[i].lower_bound + 1; 257 if (i == 0) 258 dv->dim[i].sm = dv->elem_len; 259 else 260 dv->dim[i].sm = dv->elem_len * dv->dim[i - 1].extent; 261 arr_len *= dv->dim[i].extent; 262 } 263 } 264 265 dv->base_addr = calloc (arr_len, dv->elem_len); 266 if (dv->base_addr == NULL) 267 { 268 fprintf (stderr, "CFI_allocate: Failure in memory allocation.\n"); 269 return CFI_ERROR_MEM_ALLOCATION; 270 } 271 272 return CFI_SUCCESS; 273} 274 275 276int 277CFI_deallocate (CFI_cdesc_t *dv) 278{ 279 if (unlikely (compile_options.bounds_check)) 280 { 281 /* C Descriptor must not be NULL */ 282 if (dv == NULL) 283 { 284 fprintf (stderr, "CFI_deallocate: C Descriptor is NULL.\n"); 285 return CFI_INVALID_DESCRIPTOR; 286 } 287 288 /* Base address must not be NULL. */ 289 if (dv->base_addr == NULL) 290 { 291 fprintf (stderr, "CFI_deallocate: Base address is already NULL.\n"); 292 return CFI_ERROR_BASE_ADDR_NULL; 293 } 294 295 /* C Descriptor must be for an allocatable or pointer variable. */ 296 if (dv->attribute == CFI_attribute_other) 297 { 298 fprintf (stderr, "CFI_deallocate: C Descriptor must describe a " 299 "pointer or allocatable object.\n"); 300 return CFI_INVALID_ATTRIBUTE; 301 } 302 } 303 304 /* Free and nullify memory. */ 305 free (dv->base_addr); 306 dv->base_addr = NULL; 307 308 return CFI_SUCCESS; 309} 310 311 312int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute, 313 CFI_type_t type, size_t elem_len, CFI_rank_t rank, 314 const CFI_index_t extents[]) 315{ 316 if (unlikely (compile_options.bounds_check)) 317 { 318 /* C descriptor must not be NULL. */ 319 if (dv == NULL) 320 { 321 fprintf (stderr, "CFI_establish: C descriptor is NULL.\n"); 322 return CFI_INVALID_DESCRIPTOR; 323 } 324 325 /* Rank must be between 0 and CFI_MAX_RANK. */ 326 if (rank < 0 || rank > CFI_MAX_RANK) 327 { 328 fprintf (stderr, "CFI_establish: Rank must be between 0 and %d, " 329 "0 < rank (0 !< %d).\n", CFI_MAX_RANK, (int)rank); 330 return CFI_INVALID_RANK; 331 } 332 333 /* If base address is not NULL, the established C Descriptor is for a 334 nonallocatable entity. */ 335 if (attribute == CFI_attribute_allocatable && base_addr != NULL) 336 { 337 fprintf (stderr, "CFI_establish: If base address is not NULL " 338 "(base_addr != NULL), the established C descriptor is " 339 "for a nonallocatable entity (attribute != %d).\n", 340 CFI_attribute_allocatable); 341 return CFI_INVALID_ATTRIBUTE; 342 } 343 } 344 345 dv->base_addr = base_addr; 346 347 if (type == CFI_type_char || type == CFI_type_ucs4_char || 348 type == CFI_type_signed_char || type == CFI_type_struct || 349 type == CFI_type_other) 350 dv->elem_len = elem_len; 351 else 352 { 353 /* base_type describes the intrinsic type with kind parameter. */ 354 size_t base_type = type & CFI_type_mask; 355 /* base_type_size is the size in bytes of the variable as given by its 356 * kind parameter. */ 357 size_t base_type_size = (type - base_type) >> CFI_type_kind_shift; 358 /* Kind types 10 have a size of 64 bytes. */ 359 if (base_type_size == 10) 360 { 361 base_type_size = 64; 362 } 363 /* Complex numbers are twice the size of their real counterparts. */ 364 if (base_type == CFI_type_Complex) 365 { 366 base_type_size *= 2; 367 } 368 dv->elem_len = base_type_size; 369 } 370 371 dv->version = CFI_VERSION; 372 dv->rank = rank; 373 dv->attribute = attribute; 374 dv->type = type; 375 376 /* Extents must not be NULL if rank is greater than zero and base_addr is not 377 NULL */ 378 if (rank > 0 && base_addr != NULL) 379 { 380 if (unlikely (compile_options.bounds_check) && extents == NULL) 381 { 382 fprintf (stderr, "CFI_establish: Extents must not be NULL " 383 "(extents != NULL) if rank (= %d) > 0 and base address " 384 "is not NULL (base_addr != NULL).\n", (int)rank); 385 return CFI_INVALID_EXTENT; 386 } 387 388 for (int i = 0; i < rank; i++) 389 { 390 dv->dim[i].lower_bound = 0; 391 dv->dim[i].extent = extents[i]; 392 if (i == 0) 393 dv->dim[i].sm = dv->elem_len; 394 else 395 dv->dim[i].sm = (CFI_index_t)(dv->elem_len * extents[i - 1]); 396 } 397 } 398 399 return CFI_SUCCESS; 400} 401 402 403int CFI_is_contiguous (const CFI_cdesc_t *dv) 404{ 405 if (unlikely (compile_options.bounds_check)) 406 { 407 /* C descriptor must not be NULL. */ 408 if (dv == NULL) 409 { 410 fprintf (stderr, "CFI_is_contiguous: C descriptor is NULL.\n"); 411 return 0; 412 } 413 414 /* Base address must not be NULL. */ 415 if (dv->base_addr == NULL) 416 { 417 fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor " 418 "is already NULL.\n"); 419 return 0; 420 } 421 422 /* Must be an array. */ 423 if (dv->rank == 0) 424 { 425 fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an " 426 "array (0 < dv->rank = %d).\n", dv->rank); 427 return 0; 428 } 429 } 430 431 /* Assumed size arrays are always contiguous. */ 432 if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1) 433 return 1; 434 435 /* If an array is not contiguous the memory stride is different to the element 436 * length. */ 437 for (int i = 0; i < dv->rank; i++) 438 { 439 if (i == 0 && dv->dim[i].sm == (CFI_index_t)dv->elem_len) 440 continue; 441 else if (i > 0 442 && dv->dim[i].sm == (CFI_index_t)(dv->dim[i - 1].sm 443 * dv->dim[i - 1].extent)) 444 continue; 445 446 return 0; 447 } 448 449 /* Array sections are guaranteed to be contiguous by the previous test. */ 450 return 1; 451} 452 453 454int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source, 455 const CFI_index_t lower_bounds[], 456 const CFI_index_t upper_bounds[], const CFI_index_t strides[]) 457{ 458 /* Dimension information. */ 459 CFI_index_t lower[CFI_MAX_RANK]; 460 CFI_index_t upper[CFI_MAX_RANK]; 461 CFI_index_t stride[CFI_MAX_RANK]; 462 int zero_count = 0; 463 bool assumed_size; 464 465 if (unlikely (compile_options.bounds_check)) 466 { 467 /* C Descriptors must not be NULL. */ 468 if (source == NULL) 469 { 470 fprintf (stderr, "CFI_section: Source must not be NULL.\n"); 471 return CFI_INVALID_DESCRIPTOR; 472 } 473 474 if (result == NULL) 475 { 476 fprintf (stderr, "CFI_section: Result must not be NULL.\n"); 477 return CFI_INVALID_DESCRIPTOR; 478 } 479 480 /* Base address of source must not be NULL. */ 481 if (source->base_addr == NULL) 482 { 483 fprintf (stderr, "CFI_section: Base address of source must " 484 "not be NULL.\n"); 485 return CFI_ERROR_BASE_ADDR_NULL; 486 } 487 488 /* Result must not be an allocatable array. */ 489 if (result->attribute == CFI_attribute_allocatable) 490 { 491 fprintf (stderr, "CFI_section: Result must not describe an " 492 "allocatable array.\n"); 493 return CFI_INVALID_ATTRIBUTE; 494 } 495 496 /* Source must be some form of array (nonallocatable nonpointer array, 497 allocated allocatable array or an associated pointer array). */ 498 if (source->rank <= 0) 499 { 500 fprintf (stderr, "CFI_section: Source must describe an array " 501 "(0 < source->rank, 0 !< %d).\n", source->rank); 502 return CFI_INVALID_RANK; 503 } 504 505 /* Element lengths of source and result must be equal. */ 506 if (result->elem_len != source->elem_len) 507 { 508 fprintf (stderr, "CFI_section: The element lengths of " 509 "source (source->elem_len = %d) and result " 510 "(result->elem_len = %d) must be equal.\n", 511 (int)source->elem_len, (int)result->elem_len); 512 return CFI_INVALID_ELEM_LEN; 513 } 514 515 /* Types must be equal. */ 516 if (result->type != source->type) 517 { 518 fprintf (stderr, "CFI_section: Types of source " 519 "(source->type = %d) and result (result->type = %d) " 520 "must be equal.\n", source->type, result->type); 521 return CFI_INVALID_TYPE; 522 } 523 } 524 525 /* Stride of zero in the i'th dimension means rank reduction in that 526 dimension. */ 527 for (int i = 0; i < source->rank; i++) 528 { 529 if (strides[i] == 0) 530 zero_count++; 531 } 532 533 /* Rank of result must be equal the the rank of source minus the number of 534 * zeros in strides. */ 535 if (unlikely (compile_options.bounds_check) 536 && result->rank != source->rank - zero_count) 537 { 538 fprintf (stderr, "CFI_section: Rank of result must be equal to the " 539 "rank of source minus the number of zeros in strides " 540 "(result->rank = source->rank - zero_count, %d != %d " 541 "- %d).\n", result->rank, source->rank, zero_count); 542 return CFI_INVALID_RANK; 543 } 544 545 /* Lower bounds. */ 546 if (lower_bounds == NULL) 547 { 548 for (int i = 0; i < source->rank; i++) 549 lower[i] = source->dim[i].lower_bound; 550 } 551 else 552 { 553 for (int i = 0; i < source->rank; i++) 554 lower[i] = lower_bounds[i]; 555 } 556 557 /* Upper bounds. */ 558 if (upper_bounds == NULL) 559 { 560 if (unlikely (compile_options.bounds_check) 561 && source->dim[source->rank - 1].extent == -1) 562 { 563 fprintf (stderr, "CFI_section: Source must not be an assumed size " 564 "array if upper_bounds is NULL.\n"); 565 return CFI_INVALID_EXTENT; 566 } 567 568 for (int i = 0; i < source->rank; i++) 569 upper[i] = source->dim[i].lower_bound + source->dim[i].extent - 1; 570 } 571 else 572 { 573 for (int i = 0; i < source->rank; i++) 574 upper[i] = upper_bounds[i]; 575 } 576 577 /* Stride */ 578 if (strides == NULL) 579 { 580 for (int i = 0; i < source->rank; i++) 581 stride[i] = 1; 582 } 583 else 584 { 585 for (int i = 0; i < source->rank; i++) 586 { 587 stride[i] = strides[i]; 588 /* If stride[i] == 0 then lower[i] and upper[i] must be equal. */ 589 if (unlikely (compile_options.bounds_check) 590 && stride[i] == 0 && lower[i] != upper[i]) 591 { 592 fprintf (stderr, "CFI_section: If strides[%d] = 0, then the " 593 "lower bounds, lower_bounds[%d] = %d, and " 594 "upper_bounds[%d] = %d, must be equal.\n", 595 i, i, (int)lower_bounds[i], i, (int)upper_bounds[i]); 596 return CFI_ERROR_OUT_OF_BOUNDS; 597 } 598 } 599 } 600 601 /* Check that section upper and lower bounds are within the array bounds. */ 602 for (int i = 0; i < source->rank; i++) 603 { 604 assumed_size = (i == source->rank - 1) 605 && (source->dim[i].extent == -1); 606 if (unlikely (compile_options.bounds_check) 607 && lower_bounds != NULL 608 && (lower[i] < source->dim[i].lower_bound || 609 (!assumed_size && lower[i] > source->dim[i].lower_bound 610 + source->dim[i].extent - 1))) 611 { 612 fprintf (stderr, "CFI_section: Lower bounds must be within the " 613 "bounds of the fortran array (source->dim[%d].lower_bound " 614 "<= lower_bounds[%d] <= source->dim[%d].lower_bound " 615 "+ source->dim[%d].extent - 1, %d <= %d <= %d).\n", 616 i, i, i, i, (int)source->dim[i].lower_bound, (int)lower[i], 617 (int)(source->dim[i].lower_bound 618 + source->dim[i].extent - 1)); 619 return CFI_ERROR_OUT_OF_BOUNDS; 620 } 621 622 if (unlikely (compile_options.bounds_check) 623 && upper_bounds != NULL 624 && (upper[i] < source->dim[i].lower_bound 625 || (!assumed_size 626 && upper[i] > source->dim[i].lower_bound 627 + source->dim[i].extent - 1))) 628 { 629 fprintf (stderr, "CFI_section: Upper bounds must be within the " 630 "bounds of the fortran array (source->dim[%d].lower_bound " 631 "<= upper_bounds[%d] <= source->dim[%d].lower_bound + " 632 "source->dim[%d].extent - 1, %d !<= %d !<= %d).\n", 633 i, i, i, i, (int)source->dim[i].lower_bound, (int)upper[i], 634 (int)(source->dim[i].lower_bound 635 + source->dim[i].extent - 1)); 636 return CFI_ERROR_OUT_OF_BOUNDS; 637 } 638 639 if (unlikely (compile_options.bounds_check) 640 && upper[i] < lower[i] && stride[i] >= 0) 641 { 642 fprintf (stderr, "CFI_section: If the upper bound is smaller than " 643 "the lower bound for a given dimension (upper[%d] < " 644 "lower[%d], %d < %d), then he stride for said dimension" 645 "t must be negative (stride[%d] < 0, %d < 0).\n", 646 i, i, (int)upper[i], (int)lower[i], i, (int)stride[i]); 647 return CFI_INVALID_STRIDE; 648 } 649 } 650 651 /* Set the appropriate dimension information that gives us access to the 652 * data. */ 653 int aux = 0; 654 for (int i = 0; i < source->rank; i++) 655 { 656 if (stride[i] == 0) 657 { 658 aux++; 659 /* Adjust 'lower' for the base address offset. */ 660 lower[i] = lower[i] - source->dim[i].lower_bound; 661 continue; 662 } 663 int idx = i - aux; 664 result->dim[idx].lower_bound = lower[i]; 665 result->dim[idx].extent = 1 + (upper[i] - lower[i])/stride[i]; 666 result->dim[idx].sm = stride[i] * source->dim[i].sm; 667 /* Adjust 'lower' for the base address offset. */ 668 lower[idx] = lower[idx] - source->dim[i].lower_bound; 669 } 670 671 /* Set the base address. */ 672 result->base_addr = CFI_address (source, lower); 673 674 return CFI_SUCCESS; 675} 676 677 678int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source, 679 size_t displacement, size_t elem_len) 680{ 681 if (unlikely (compile_options.bounds_check)) 682 { 683 /* C Descriptors must not be NULL. */ 684 if (source == NULL) 685 { 686 fprintf (stderr, "CFI_select_part: Source must not be NULL.\n"); 687 return CFI_INVALID_DESCRIPTOR; 688 } 689 690 if (result == NULL) 691 { 692 fprintf (stderr, "CFI_select_part: Result must not be NULL.\n"); 693 return CFI_INVALID_DESCRIPTOR; 694 } 695 696 /* Attribute of result will be CFI_attribute_other or 697 CFI_attribute_pointer. */ 698 if (result->attribute == CFI_attribute_allocatable) 699 { 700 fprintf (stderr, "CFI_select_part: Result must not describe an " 701 "allocatable object (result->attribute != %d).\n", 702 CFI_attribute_allocatable); 703 return CFI_INVALID_ATTRIBUTE; 704 } 705 706 /* Base address of source must not be NULL. */ 707 if (source->base_addr == NULL) 708 { 709 fprintf (stderr, "CFI_select_part: Base address of source must " 710 "not be NULL.\n"); 711 return CFI_ERROR_BASE_ADDR_NULL; 712 } 713 714 /* Source and result must have the same rank. */ 715 if (source->rank != result->rank) 716 { 717 fprintf (stderr, "CFI_select_part: Source and result must have " 718 "the same rank (source->rank = %d, result->rank = %d).\n", 719 (int)source->rank, (int)result->rank); 720 return CFI_INVALID_RANK; 721 } 722 723 /* Nonallocatable nonpointer must not be an assumed size array. */ 724 if (source->rank > 0 && source->dim[source->rank - 1].extent == -1) 725 { 726 fprintf (stderr, "CFI_select_part: Source must not describe an " 727 "assumed size array (source->dim[%d].extent != -1).\n", 728 source->rank - 1); 729 return CFI_INVALID_DESCRIPTOR; 730 } 731 } 732 733 /* Element length. */ 734 if (result->type == CFI_type_char || result->type == CFI_type_ucs4_char || 735 result->type == CFI_type_signed_char) 736 result->elem_len = elem_len; 737 738 if (unlikely (compile_options.bounds_check)) 739 { 740 /* Ensure displacement is within the bounds of the element length 741 of source.*/ 742 if (displacement > source->elem_len - 1) 743 { 744 fprintf (stderr, "CFI_select_part: Displacement must be within the " 745 "bounds of source (0 <= displacement <= source->elem_len " 746 "- 1, 0 <= %d <= %d).\n", (int)displacement, 747 (int)(source->elem_len - 1)); 748 return CFI_ERROR_OUT_OF_BOUNDS; 749 } 750 751 /* Ensure displacement and element length of result are less than or 752 equal to the element length of source. */ 753 if (displacement + result->elem_len > source->elem_len) 754 { 755 fprintf (stderr, "CFI_select_part: Displacement plus the element " 756 "length of result must be less than or equal to the " 757 "element length of source (displacement + result->elem_len " 758 "<= source->elem_len, %d + %d = %d <= %d).\n", 759 (int)displacement, (int)result->elem_len, 760 (int)(displacement + result->elem_len), 761 (int)source->elem_len); 762 return CFI_ERROR_OUT_OF_BOUNDS; 763 } 764 } 765 766 if (result->rank > 0) 767 { 768 for (int i = 0; i < result->rank; i++) 769 { 770 result->dim[i].lower_bound = source->dim[i].lower_bound; 771 result->dim[i].extent = source->dim[i].extent; 772 result->dim[i].sm = source->dim[i].sm; 773 } 774 } 775 776 result->base_addr = (char *) source->base_addr + displacement; 777 return CFI_SUCCESS; 778} 779 780 781int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source, 782 const CFI_index_t lower_bounds[]) 783{ 784 /* Result must not be NULL and must be a Fortran pointer. */ 785 if (unlikely (compile_options.bounds_check)) 786 { 787 if (result == NULL) 788 { 789 fprintf (stderr, "CFI_setpointer: Result is NULL.\n"); 790 return CFI_INVALID_DESCRIPTOR; 791 } 792 793 if (result->attribute != CFI_attribute_pointer) 794 { 795 fprintf (stderr, "CFI_setpointer: Result shall be the address of a " 796 "C descriptor for a Fortran pointer.\n"); 797 return CFI_INVALID_ATTRIBUTE; 798 } 799 } 800 801 /* If source is NULL, the result is a C Descriptor that describes a 802 * disassociated pointer. */ 803 if (source == NULL) 804 { 805 result->base_addr = NULL; 806 result->version = CFI_VERSION; 807 } 808 else 809 { 810 /* Check that element lengths, ranks and types of source and result are 811 * the same. */ 812 if (unlikely (compile_options.bounds_check)) 813 { 814 if (result->elem_len != source->elem_len) 815 { 816 fprintf (stderr, "CFI_setpointer: Element lengths of result " 817 "(result->elem_len = %d) and source (source->elem_len " 818 "= %d) must be the same.\n", (int)result->elem_len, 819 (int)source->elem_len); 820 return CFI_INVALID_ELEM_LEN; 821 } 822 823 if (result->rank != source->rank) 824 { 825 fprintf (stderr, "CFI_setpointer: Ranks of result (result->rank " 826 "= %d) and source (source->rank = %d) must be the same." 827 "\n", result->rank, source->rank); 828 return CFI_INVALID_RANK; 829 } 830 831 if (result->type != source->type) 832 { 833 fprintf (stderr, "CFI_setpointer: Types of result (result->type" 834 "= %d) and source (source->type = %d) must be the same." 835 "\n", result->type, source->type); 836 return CFI_INVALID_TYPE; 837 } 838 } 839 840 /* If the source is a disassociated pointer, the result must also describe 841 * a disassociated pointer. */ 842 if (source->base_addr == NULL && 843 source->attribute == CFI_attribute_pointer) 844 result->base_addr = NULL; 845 else 846 result->base_addr = source->base_addr; 847 848 /* Assign components to result. */ 849 result->version = source->version; 850 851 /* Dimension information. */ 852 for (int i = 0; i < source->rank; i++) 853 { 854 if (lower_bounds != NULL) 855 result->dim[i].lower_bound = lower_bounds[i]; 856 else 857 result->dim[i].lower_bound = source->dim[i].lower_bound; 858 859 result->dim[i].extent = source->dim[i].extent; 860 result->dim[i].sm = source->dim[i].sm; 861 } 862 } 863 864 return CFI_SUCCESS; 865} 866