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 Free Software Foundation, Inc.
5 Contributed by Daniel Celis Garza <celisdanieljr@gmail.com>
6 and Paul Thomas <pault@gcc.gnu.org>
8 This file is part of the GNU Fortran runtime library (libgfortran).
10 Libgfortran is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public
12 License as published by the Free Software Foundation; either
13 version 3 of the License, or (at your option) any later version.
15 Libgfortran is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 Under Section 7 of GPL version 3, you are granted additional
21 permissions described in the GCC Runtime Library Exception, version
22 3.1, as published by the Free Software Foundation.
24 You should have received a copy of the GNU General Public License and
25 a copy of the GCC Runtime Library Exception along with this program;
26 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
27 <http://www.gnu.org/licenses/>. */
29 #include "libgfortran.h"
30 #include <ISO_Fortran_binding.h>
33 extern void cfi_desc_to_gfc_desc (gfc_array_void
*, CFI_cdesc_t
**);
34 export_proto(cfi_desc_to_gfc_desc
);
37 cfi_desc_to_gfc_desc (gfc_array_void
*d
, CFI_cdesc_t
**s_ptr
)
40 CFI_cdesc_t
*s
= *s_ptr
;
42 /* If not a full pointer or allocatable array free the descriptor
44 if (!s
|| s
->attribute
== CFI_attribute_other
)
47 GFC_DESCRIPTOR_DATA (d
) = s
->base_addr
;
49 if (!s
->rank
|| s
->dim
[0].sm
== (CFI_index_t
)s
->elem_len
)
50 GFC_DESCRIPTOR_SIZE (d
) = s
->elem_len
;
52 GFC_DESCRIPTOR_SIZE (d
) = (index_type
)s
->dim
[0].sm
;
54 d
->dtype
.version
= s
->version
;
55 GFC_DESCRIPTOR_RANK (d
) = (signed char)s
->rank
;
56 GFC_DESCRIPTOR_TYPE (d
) = (signed char)(s
->type
& CFI_type_mask
);
58 /* Correct the unfortunate difference in order with types. */
59 if (GFC_DESCRIPTOR_TYPE (d
) == BT_CHARACTER
)
60 GFC_DESCRIPTOR_TYPE (d
) = BT_DERIVED
;
61 else if (GFC_DESCRIPTOR_TYPE (d
) == BT_DERIVED
)
62 GFC_DESCRIPTOR_TYPE (d
) = BT_CHARACTER
;
64 d
->dtype
.attribute
= (signed short)s
->attribute
;
67 d
->span
= (index_type
)s
->dim
[0].sm
;
69 /* On the other hand, CFI_establish can change the bounds. */
71 for (n
= 0; n
< GFC_DESCRIPTOR_RANK (d
); n
++)
73 GFC_DESCRIPTOR_LBOUND(d
, n
) = (index_type
)s
->dim
[n
].lower_bound
;
74 GFC_DESCRIPTOR_UBOUND(d
, n
) = (index_type
)(s
->dim
[n
].extent
75 + s
->dim
[n
].lower_bound
- 1);
76 GFC_DESCRIPTOR_STRIDE(d
, n
) = (index_type
)(s
->dim
[n
].sm
/ s
->elem_len
);
77 d
->offset
-= GFC_DESCRIPTOR_STRIDE(d
, n
) * GFC_DESCRIPTOR_LBOUND(d
, n
);
86 extern void gfc_desc_to_cfi_desc (CFI_cdesc_t
**, const gfc_array_void
*);
87 export_proto(gfc_desc_to_cfi_desc
);
90 gfc_desc_to_cfi_desc (CFI_cdesc_t
**d_ptr
, const gfc_array_void
*s
)
95 /* Play it safe with allocation of the flexible array member 'dim'
96 by setting the length to CFI_MAX_RANK. This should not be necessary
97 but valgrind complains accesses after the allocated block. */
98 d
= malloc (sizeof (CFI_cdesc_t
)
99 + (CFI_type_t
)(CFI_MAX_RANK
* sizeof (CFI_dim_t
)));
101 d
->base_addr
= GFC_DESCRIPTOR_DATA (s
);
102 d
->elem_len
= GFC_DESCRIPTOR_SIZE (s
);
103 d
->version
= s
->dtype
.version
;
104 d
->rank
= (CFI_rank_t
)GFC_DESCRIPTOR_RANK (s
);
105 d
->attribute
= (CFI_attribute_t
)s
->dtype
.attribute
;
107 if (GFC_DESCRIPTOR_TYPE (s
) == BT_CHARACTER
)
108 d
->type
= CFI_type_Character
;
109 else if (GFC_DESCRIPTOR_TYPE (s
) == BT_DERIVED
)
110 d
->type
= CFI_type_struct
;
112 d
->type
= (CFI_type_t
)GFC_DESCRIPTOR_TYPE (s
);
114 if (GFC_DESCRIPTOR_TYPE (s
) != BT_DERIVED
)
115 d
->type
= (CFI_type_t
)(d
->type
116 + ((CFI_type_t
)d
->elem_len
<< CFI_type_kind_shift
));
118 /* Full pointer or allocatable arrays have zero lower_bound. */
119 for (n
= 0; n
< GFC_DESCRIPTOR_RANK (s
); n
++)
121 if (d
->attribute
!= CFI_attribute_other
)
122 d
->dim
[n
].lower_bound
= (CFI_index_t
)GFC_DESCRIPTOR_LBOUND(s
, n
);
124 d
->dim
[n
].lower_bound
= 0;
126 /* Assumed size arrays have gfc ubound == 0 and CFI extent = -1. */
127 if ((n
== GFC_DESCRIPTOR_RANK (s
) - 1)
128 && GFC_DESCRIPTOR_LBOUND(s
, n
) == 1
129 && GFC_DESCRIPTOR_UBOUND(s
, n
) == 0)
130 d
->dim
[n
].extent
= -1;
132 d
->dim
[n
].extent
= (CFI_index_t
)GFC_DESCRIPTOR_UBOUND(s
, n
)
133 - (CFI_index_t
)GFC_DESCRIPTOR_LBOUND(s
, n
) + 1;
134 d
->dim
[n
].sm
= (CFI_index_t
)(GFC_DESCRIPTOR_STRIDE(s
, n
) * s
->span
);
140 void *CFI_address (const CFI_cdesc_t
*dv
, const CFI_index_t subscripts
[])
143 char *base_addr
= (char *)dv
->base_addr
;
145 if (unlikely (compile_options
.bounds_check
))
147 /* C Descriptor must not be NULL. */
150 fprintf (stderr
, "CFI_address: C Descriptor is NULL.\n");
154 /* Base address of C Descriptor must not be NULL. */
155 if (dv
->base_addr
== NULL
)
157 fprintf (stderr
, "CFI_address: base address of C Descriptor "
158 "must not be NULL.\n");
163 /* Return base address if C descriptor is a scalar. */
165 return dv
->base_addr
;
167 /* Calculate the appropriate base address if dv is not a scalar. */
170 /* Base address is the C address of the element of the object
171 specified by subscripts. */
172 for (i
= 0; i
< dv
->rank
; i
++)
174 if (unlikely (compile_options
.bounds_check
)
175 && ((dv
->dim
[i
].extent
!= -1
176 && subscripts
[i
] >= dv
->dim
[i
].extent
)
177 || subscripts
[i
] < 0))
179 fprintf (stderr
, "CFI_address: subscripts[%d], is out of "
180 "bounds. dv->dim[%d].extent = %d subscripts[%d] "
181 "= %d.\n", i
, i
, (int)dv
->dim
[i
].extent
, i
,
186 base_addr
= base_addr
+ (CFI_index_t
)(subscripts
[i
] * dv
->dim
[i
].sm
);
190 return (void *)base_addr
;
195 CFI_allocate (CFI_cdesc_t
*dv
, const CFI_index_t lower_bounds
[],
196 const CFI_index_t upper_bounds
[], size_t elem_len
)
198 if (unlikely (compile_options
.bounds_check
))
200 /* C Descriptor must not be NULL. */
203 fprintf (stderr
, "CFI_allocate: C Descriptor is NULL.\n");
204 return CFI_INVALID_DESCRIPTOR
;
207 /* The C Descriptor must be for an allocatable or pointer object. */
208 if (dv
->attribute
== CFI_attribute_other
)
210 fprintf (stderr
, "CFI_allocate: The object of the C descriptor "
211 "must be a pointer or allocatable variable.\n");
212 return CFI_INVALID_ATTRIBUTE
;
215 /* Base address of C Descriptor must be NULL. */
216 if (dv
->base_addr
!= NULL
)
218 fprintf (stderr
, "CFI_allocate: Base address of C descriptor "
220 return CFI_ERROR_BASE_ADDR_NOT_NULL
;
224 /* If the type is a character, the descriptor's element length is replaced
225 * by the elem_len argument. */
226 if (dv
->type
== CFI_type_char
|| dv
->type
== CFI_type_ucs4_char
||
227 dv
->type
== CFI_type_signed_char
)
228 dv
->elem_len
= elem_len
;
230 /* Dimension information and calculating the array length. */
233 /* If rank is greater than 0, lower_bounds and upper_bounds are used. They're
234 * ignored otherwhise. */
237 if (unlikely (compile_options
.bounds_check
)
238 && (lower_bounds
== NULL
|| upper_bounds
== NULL
))
240 fprintf (stderr
, "CFI_allocate: If 0 < rank (= %d) upper_bounds[] "
241 "and lower_bounds[], must not be NULL.\n", dv
->rank
);
242 return CFI_INVALID_EXTENT
;
245 for (int i
= 0; i
< dv
->rank
; i
++)
247 dv
->dim
[i
].lower_bound
= lower_bounds
[i
];
248 dv
->dim
[i
].extent
= upper_bounds
[i
] - dv
->dim
[i
].lower_bound
+ 1;
250 dv
->dim
[i
].sm
= dv
->elem_len
;
252 dv
->dim
[i
].sm
= dv
->elem_len
* dv
->dim
[i
- 1].extent
;
253 arr_len
*= dv
->dim
[i
].extent
;
257 dv
->base_addr
= calloc (arr_len
, dv
->elem_len
);
258 if (dv
->base_addr
== NULL
)
260 fprintf (stderr
, "CFI_allocate: Failure in memory allocation.\n");
261 return CFI_ERROR_MEM_ALLOCATION
;
269 CFI_deallocate (CFI_cdesc_t
*dv
)
271 if (unlikely (compile_options
.bounds_check
))
273 /* C Descriptor must not be NULL */
276 fprintf (stderr
, "CFI_deallocate: C Descriptor is NULL.\n");
277 return CFI_INVALID_DESCRIPTOR
;
280 /* Base address must not be NULL. */
281 if (dv
->base_addr
== NULL
)
283 fprintf (stderr
, "CFI_deallocate: Base address is already NULL.\n");
284 return CFI_ERROR_BASE_ADDR_NULL
;
287 /* C Descriptor must be for an allocatable or pointer variable. */
288 if (dv
->attribute
== CFI_attribute_other
)
290 fprintf (stderr
, "CFI_deallocate: C Descriptor must describe a "
291 "pointer or allocatable object.\n");
292 return CFI_INVALID_ATTRIBUTE
;
296 /* Free and nullify memory. */
297 free (dv
->base_addr
);
298 dv
->base_addr
= NULL
;
304 int CFI_establish (CFI_cdesc_t
*dv
, void *base_addr
, CFI_attribute_t attribute
,
305 CFI_type_t type
, size_t elem_len
, CFI_rank_t rank
,
306 const CFI_index_t extents
[])
308 if (unlikely (compile_options
.bounds_check
))
310 /* C descriptor must not be NULL. */
313 fprintf (stderr
, "CFI_establish: C descriptor is NULL.\n");
314 return CFI_INVALID_DESCRIPTOR
;
317 /* Rank must be between 0 and CFI_MAX_RANK. */
318 if (rank
< 0 || rank
> CFI_MAX_RANK
)
320 fprintf (stderr
, "CFI_establish: Rank must be between 0 and %d, "
321 "0 < rank (0 !< %d).\n", CFI_MAX_RANK
, (int)rank
);
322 return CFI_INVALID_RANK
;
325 /* C Descriptor must not be an allocated allocatable. */
326 if (dv
->attribute
== CFI_attribute_allocatable
&& dv
->base_addr
!= NULL
)
328 fprintf (stderr
, "CFI_establish: If the C Descriptor represents an "
329 "allocatable variable (dv->attribute = %d), its base "
330 "address must be NULL (dv->base_addr = NULL).\n",
331 CFI_attribute_allocatable
);
332 return CFI_INVALID_DESCRIPTOR
;
335 /* If base address is not NULL, the established C Descriptor is for a
336 nonallocatable entity. */
337 if (attribute
== CFI_attribute_allocatable
&& base_addr
!= NULL
)
339 fprintf (stderr
, "CFI_establish: If base address is not NULL "
340 "(base_addr != NULL), the established C descriptor is "
341 "for a nonallocatable entity (attribute != %d).\n",
342 CFI_attribute_allocatable
);
343 return CFI_INVALID_ATTRIBUTE
;
347 dv
->base_addr
= base_addr
;
349 if (type
== CFI_type_char
|| type
== CFI_type_ucs4_char
||
350 type
== CFI_type_signed_char
|| type
== CFI_type_struct
||
351 type
== CFI_type_other
)
352 dv
->elem_len
= elem_len
;
355 /* base_type describes the intrinsic type with kind parameter. */
356 size_t base_type
= type
& CFI_type_mask
;
357 /* base_type_size is the size in bytes of the variable as given by its
359 size_t base_type_size
= (type
- base_type
) >> CFI_type_kind_shift
;
360 /* Kind types 10 have a size of 64 bytes. */
361 if (base_type_size
== 10)
365 /* Complex numbers are twice the size of their real counterparts. */
366 if (base_type
== CFI_type_Complex
)
370 dv
->elem_len
= base_type_size
;
373 dv
->version
= CFI_VERSION
;
375 dv
->attribute
= attribute
;
378 /* Extents must not be NULL if rank is greater than zero and base_addr is not
380 if (rank
> 0 && base_addr
!= NULL
)
382 if (unlikely (compile_options
.bounds_check
) && extents
== NULL
)
384 fprintf (stderr
, "CFI_establish: Extents must not be NULL "
385 "(extents != NULL) if rank (= %d) > 0 nd base address"
386 "is not NULL (base_addr != NULL).\n", (int)rank
);
387 return CFI_INVALID_EXTENT
;
390 for (int i
= 0; i
< rank
; i
++)
392 /* If the C Descriptor is for a pointer then the lower bounds of every
393 * dimension are set to zero. */
394 if (attribute
== CFI_attribute_pointer
)
395 dv
->dim
[i
].lower_bound
= 0;
397 dv
->dim
[i
].lower_bound
= 1;
399 dv
->dim
[i
].extent
= extents
[i
];
401 dv
->dim
[i
].sm
= dv
->elem_len
;
403 dv
->dim
[i
].sm
= (CFI_index_t
)(dv
->elem_len
* extents
[i
- 1]);
411 int CFI_is_contiguous (const CFI_cdesc_t
*dv
)
413 if (unlikely (compile_options
.bounds_check
))
415 /* C descriptor must not be NULL. */
418 fprintf (stderr
, "CFI_is_contiguous: C descriptor is NULL.\n");
419 return CFI_INVALID_DESCRIPTOR
;
422 /* Base address must not be NULL. */
423 if (dv
->base_addr
== NULL
)
425 fprintf (stderr
, "CFI_is_contiguous: Base address of C Descriptor "
426 "is already NULL.\n");
427 return CFI_ERROR_BASE_ADDR_NULL
;
430 /* Must be an array. */
433 fprintf (stderr
, "CFI_is_contiguous: C Descriptor must describe an "
434 "array (0 < dv->rank = %d).\n", dv
->rank
);
435 return CFI_INVALID_RANK
;
439 /* Assumed size arrays are always contiguous. */
440 if (dv
->rank
> 0 && dv
->dim
[dv
->rank
- 1].extent
== -1)
443 /* If an array is not contiguous the memory stride is different to the element
445 for (int i
= 0; i
< dv
->rank
; i
++)
447 if (i
== 0 && dv
->dim
[i
].sm
== (CFI_index_t
)dv
->elem_len
)
450 && dv
->dim
[i
].sm
== (CFI_index_t
)(dv
->elem_len
451 * dv
->dim
[i
- 1].extent
))
457 /* Array sections are guaranteed to be contiguous by the previous test. */
462 int CFI_section (CFI_cdesc_t
*result
, const CFI_cdesc_t
*source
,
463 const CFI_index_t lower_bounds
[],
464 const CFI_index_t upper_bounds
[], const CFI_index_t strides
[])
466 /* Dimension information. */
467 CFI_index_t lower
[CFI_MAX_RANK
];
468 CFI_index_t upper
[CFI_MAX_RANK
];
469 CFI_index_t stride
[CFI_MAX_RANK
];
473 if (unlikely (compile_options
.bounds_check
))
475 /* C Descriptors must not be NULL. */
478 fprintf (stderr
, "CFI_section: Source must not be NULL.\n");
479 return CFI_INVALID_DESCRIPTOR
;
484 fprintf (stderr
, "CFI_section: Result must not be NULL.\n");
485 return CFI_INVALID_DESCRIPTOR
;
488 /* Base address of source must not be NULL. */
489 if (source
->base_addr
== NULL
)
491 fprintf (stderr
, "CFI_section: Base address of source must "
493 return CFI_ERROR_BASE_ADDR_NULL
;
496 /* Result must not be an allocatable array. */
497 if (result
->attribute
== CFI_attribute_allocatable
)
499 fprintf (stderr
, "CFI_section: Result must not describe an "
500 "allocatable array.\n");
501 return CFI_INVALID_ATTRIBUTE
;
504 /* Source must be some form of array (nonallocatable nonpointer array,
505 allocated allocatable array or an associated pointer array). */
506 if (source
->rank
<= 0)
508 fprintf (stderr
, "CFI_section: Source must describe an array "
509 "(0 < source->rank, 0 !< %d).\n", source
->rank
);
510 return CFI_INVALID_RANK
;
513 /* Element lengths of source and result must be equal. */
514 if (result
->elem_len
!= source
->elem_len
)
516 fprintf (stderr
, "CFI_section: The element lengths of "
517 "source (source->elem_len = %d) and result "
518 "(result->elem_len = %d) must be equal.\n",
519 (int)source
->elem_len
, (int)result
->elem_len
);
520 return CFI_INVALID_ELEM_LEN
;
523 /* Types must be equal. */
524 if (result
->type
!= source
->type
)
526 fprintf (stderr
, "CFI_section: Types of source "
527 "(source->type = %d) and result (result->type = %d) "
528 "must be equal.\n", source
->type
, result
->type
);
529 return CFI_INVALID_TYPE
;
533 /* Stride of zero in the i'th dimension means rank reduction in that
535 for (int i
= 0; i
< source
->rank
; i
++)
541 /* Rank of result must be equal the the rank of source minus the number of
542 * zeros in strides. */
543 if (unlikely (compile_options
.bounds_check
)
544 && result
->rank
!= source
->rank
- zero_count
)
546 fprintf (stderr
, "CFI_section: Rank of result must be equal to the "
547 "rank of source minus the number of zeros in strides "
548 "(result->rank = source->rank - zero_count, %d != %d "
549 "- %d).\n", result
->rank
, source
->rank
, zero_count
);
550 return CFI_INVALID_RANK
;
554 if (lower_bounds
== NULL
)
556 for (int i
= 0; i
< source
->rank
; i
++)
557 lower
[i
] = source
->dim
[i
].lower_bound
;
561 for (int i
= 0; i
< source
->rank
; i
++)
562 lower
[i
] = lower_bounds
[i
];
566 if (upper_bounds
== NULL
)
568 if (unlikely (compile_options
.bounds_check
)
569 && source
->dim
[source
->rank
- 1].extent
== -1)
571 fprintf (stderr
, "CFI_section: Source must not be an assumed size "
572 "array if upper_bounds is NULL.\n");
573 return CFI_INVALID_EXTENT
;
576 for (int i
= 0; i
< source
->rank
; i
++)
577 upper
[i
] = source
->dim
[i
].lower_bound
+ source
->dim
[i
].extent
- 1;
581 for (int i
= 0; i
< source
->rank
; i
++)
582 upper
[i
] = upper_bounds
[i
];
588 for (int i
= 0; i
< source
->rank
; i
++)
593 for (int i
= 0; i
< source
->rank
; i
++)
595 stride
[i
] = strides
[i
];
596 /* If stride[i] == 0 then lower[i] and upper[i] must be equal. */
597 if (unlikely (compile_options
.bounds_check
)
598 && stride
[i
] == 0 && lower
[i
] != upper
[i
])
600 fprintf (stderr
, "CFI_section: If strides[%d] = 0, then the "
601 "lower bounds, lower_bounds[%d] = %d, and "
602 "upper_bounds[%d] = %d, must be equal.\n",
603 i
, i
, (int)lower_bounds
[i
], i
, (int)upper_bounds
[i
]);
604 return CFI_ERROR_OUT_OF_BOUNDS
;
609 /* Check that section upper and lower bounds are within the array bounds. */
610 for (int i
= 0; i
< source
->rank
; i
++)
612 assumed_size
= (i
== source
->rank
- 1)
613 && (source
->dim
[i
].extent
== -1);
614 if (unlikely (compile_options
.bounds_check
)
615 && lower_bounds
!= NULL
616 && (lower
[i
] < source
->dim
[i
].lower_bound
||
617 (!assumed_size
&& lower
[i
] > source
->dim
[i
].lower_bound
618 + source
->dim
[i
].extent
- 1)))
620 fprintf (stderr
, "CFI_section: Lower bounds must be within the "
621 "bounds of the fortran array (source->dim[%d].lower_bound "
622 "<= lower_bounds[%d] <= source->dim[%d].lower_bound "
623 "+ source->dim[%d].extent - 1, %d <= %d <= %d).\n",
624 i
, i
, i
, i
, (int)source
->dim
[i
].lower_bound
, (int)lower
[i
],
625 (int)(source
->dim
[i
].lower_bound
626 + source
->dim
[i
].extent
- 1));
627 return CFI_ERROR_OUT_OF_BOUNDS
;
630 if (unlikely (compile_options
.bounds_check
)
631 && upper_bounds
!= NULL
632 && (upper
[i
] < source
->dim
[i
].lower_bound
634 && upper
[i
] > source
->dim
[i
].lower_bound
635 + source
->dim
[i
].extent
- 1)))
637 fprintf (stderr
, "CFI_section: Upper bounds must be within the "
638 "bounds of the fortran array (source->dim[%d].lower_bound "
639 "<= upper_bounds[%d] <= source->dim[%d].lower_bound + "
640 "source->dim[%d].extent - 1, %d !<= %d !<= %d).\n",
641 i
, i
, i
, i
, (int)source
->dim
[i
].lower_bound
, (int)upper
[i
],
642 (int)(source
->dim
[i
].lower_bound
643 + source
->dim
[i
].extent
- 1));
644 return CFI_ERROR_OUT_OF_BOUNDS
;
647 if (unlikely (compile_options
.bounds_check
)
648 && upper
[i
] < lower
[i
] && stride
[i
] >= 0)
650 fprintf (stderr
, "CFI_section: If the upper bound is smaller than "
651 "the lower bound for a given dimension (upper[%d] < "
652 "lower[%d], %d < %d), then he stride for said dimension"
653 "t must be negative (stride[%d] < 0, %d < 0).\n",
654 i
, i
, (int)upper
[i
], (int)lower
[i
], i
, (int)stride
[i
]);
655 return CFI_INVALID_STRIDE
;
659 /* Set the appropriate dimension information that gives us access to the
662 for (int i
= 0; i
< source
->rank
; i
++)
667 /* Adjust 'lower' for the base address offset. */
668 lower
[i
] = lower
[i
] - source
->dim
[i
].lower_bound
;
672 result
->dim
[idx
].lower_bound
= lower
[i
];
673 result
->dim
[idx
].extent
= upper
[i
] - lower
[i
] + 1;
674 result
->dim
[idx
].sm
= stride
[i
] * source
->dim
[i
].sm
;
675 /* Adjust 'lower' for the base address offset. */
676 lower
[idx
] = lower
[idx
] - source
->dim
[i
].lower_bound
;
679 /* Set the base address. */
680 result
->base_addr
= CFI_address (source
, lower
);
686 int CFI_select_part (CFI_cdesc_t
*result
, const CFI_cdesc_t
*source
,
687 size_t displacement
, size_t elem_len
)
689 if (unlikely (compile_options
.bounds_check
))
691 /* C Descriptors must not be NULL. */
694 fprintf (stderr
, "CFI_select_part: Source must not be NULL.\n");
695 return CFI_INVALID_DESCRIPTOR
;
700 fprintf (stderr
, "CFI_select_part: Result must not be NULL.\n");
701 return CFI_INVALID_DESCRIPTOR
;
704 /* Attribute of result will be CFI_attribute_other or
705 CFI_attribute_pointer. */
706 if (result
->attribute
== CFI_attribute_allocatable
)
708 fprintf (stderr
, "CFI_select_part: Result must not describe an "
709 "allocatable object (result->attribute != %d).\n",
710 CFI_attribute_allocatable
);
711 return CFI_INVALID_ATTRIBUTE
;
714 /* Base address of source must not be NULL. */
715 if (source
->base_addr
== NULL
)
717 fprintf (stderr
, "CFI_select_part: Base address of source must "
719 return CFI_ERROR_BASE_ADDR_NULL
;
722 /* Source and result must have the same rank. */
723 if (source
->rank
!= result
->rank
)
725 fprintf (stderr
, "CFI_select_part: Source and result must have "
726 "the same rank (source->rank = %d, result->rank = %d).\n",
727 (int)source
->rank
, (int)result
->rank
);
728 return CFI_INVALID_RANK
;
731 /* Nonallocatable nonpointer must not be an assumed size array. */
732 if (source
->rank
> 0 && source
->dim
[source
->rank
- 1].extent
== -1)
734 fprintf (stderr
, "CFI_select_part: Source must not describe an "
735 "assumed size array (source->dim[%d].extent != -1).\n",
737 return CFI_INVALID_DESCRIPTOR
;
741 /* Element length. */
742 if (result
->type
== CFI_type_char
|| result
->type
== CFI_type_ucs4_char
||
743 result
->type
== CFI_type_signed_char
)
744 result
->elem_len
= elem_len
;
746 if (unlikely (compile_options
.bounds_check
))
748 /* Ensure displacement is within the bounds of the element length
750 if (displacement
> source
->elem_len
- 1)
752 fprintf (stderr
, "CFI_select_part: Displacement must be within the "
753 "bounds of source (0 <= displacement <= source->elem_len "
754 "- 1, 0 <= %d <= %d).\n", (int)displacement
,
755 (int)(source
->elem_len
- 1));
756 return CFI_ERROR_OUT_OF_BOUNDS
;
759 /* Ensure displacement and element length of result are less than or
760 equal to the element length of source. */
761 if (displacement
+ result
->elem_len
> source
->elem_len
)
763 fprintf (stderr
, "CFI_select_part: Displacement plus the element "
764 "length of result must be less than or equal to the "
765 "element length of source (displacement + result->elem_len "
766 "<= source->elem_len, %d + %d = %d <= %d).\n",
767 (int)displacement
, (int)result
->elem_len
,
768 (int)(displacement
+ result
->elem_len
),
769 (int)source
->elem_len
);
770 return CFI_ERROR_OUT_OF_BOUNDS
;
774 if (result
->rank
> 0)
776 for (int i
= 0; i
< result
->rank
; i
++)
778 result
->dim
[i
].lower_bound
= source
->dim
[i
].lower_bound
;
779 result
->dim
[i
].extent
= source
->dim
[i
].extent
;
780 result
->dim
[i
].sm
= source
->dim
[i
].sm
;
784 result
->base_addr
= (char *) source
->base_addr
+ displacement
;
789 int CFI_setpointer (CFI_cdesc_t
*result
, CFI_cdesc_t
*source
,
790 const CFI_index_t lower_bounds
[])
792 /* Result must not be NULL. */
793 if (unlikely (compile_options
.bounds_check
) && result
== NULL
)
795 fprintf (stderr
, "CFI_setpointer: Result is NULL.\n");
796 return CFI_INVALID_DESCRIPTOR
;
799 /* If source is NULL, the result is a C Descriptor that describes a
800 * disassociated pointer. */
803 result
->base_addr
= NULL
;
804 result
->version
= CFI_VERSION
;
805 result
->attribute
= CFI_attribute_pointer
;
809 /* Check that element lengths, ranks and types of source and result are
811 if (unlikely (compile_options
.bounds_check
))
813 if (result
->elem_len
!= source
->elem_len
)
815 fprintf (stderr
, "CFI_setpointer: Element lengths of result "
816 "(result->elem_len = %d) and source (source->elem_len "
817 "= %d) must be the same.\n", (int)result
->elem_len
,
818 (int)source
->elem_len
);
819 return CFI_INVALID_ELEM_LEN
;
822 if (result
->rank
!= source
->rank
)
824 fprintf (stderr
, "CFI_setpointer: Ranks of result (result->rank "
825 "= %d) and source (source->rank = %d) must be the same."
826 "\n", result
->rank
, source
->rank
);
827 return CFI_INVALID_RANK
;
830 if (result
->type
!= source
->type
)
832 fprintf (stderr
, "CFI_setpointer: Types of result (result->type"
833 "= %d) and source (source->type = %d) must be the same."
834 "\n", result
->type
, source
->type
);
835 return CFI_INVALID_TYPE
;
839 /* If the source is a disassociated pointer, the result must also describe
840 * a disassociated pointer. */
841 if (source
->base_addr
== NULL
&&
842 source
->attribute
== CFI_attribute_pointer
)
843 result
->base_addr
= NULL
;
845 result
->base_addr
= source
->base_addr
;
847 /* Assign components to result. */
848 result
->version
= source
->version
;
849 result
->attribute
= source
->attribute
;
851 /* Dimension information. */
852 for (int i
= 0; i
< source
->rank
; i
++)
854 if (lower_bounds
!= NULL
)
855 result
->dim
[i
].lower_bound
= lower_bounds
[i
];
857 result
->dim
[i
].lower_bound
= source
->dim
[i
].lower_bound
;
859 result
->dim
[i
].extent
= source
->dim
[i
].extent
;
860 result
->dim
[i
].sm
= source
->dim
[i
].sm
;