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>
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
)
41 CFI_cdesc_t
*s
= *s_ptr
;
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
);
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
;
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
;
61 GFC_DESCRIPTOR_SIZE (d
) = s
->elem_len
;
63 d
->dtype
.version
= s
->version
;
64 GFC_DESCRIPTOR_RANK (d
) = (signed char)s
->rank
;
66 d
->dtype
.attribute
= (signed short)s
->attribute
;
70 if ((size_t)s
->dim
[0].sm
% s
->elem_len
)
71 d
->span
= (index_type
)s
->dim
[0].sm
;
73 d
->span
= (index_type
)s
->elem_len
;
77 for (n
= 0; n
< GFC_DESCRIPTOR_RANK (d
); n
++)
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
);
87 extern void gfc_desc_to_cfi_desc (CFI_cdesc_t
**, const gfc_array_void
*);
88 export_proto(gfc_desc_to_cfi_desc
);
91 gfc_desc_to_cfi_desc (CFI_cdesc_t
**d_ptr
, const gfc_array_void
*s
)
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. */
100 d
= malloc (sizeof (CFI_cdesc_t
)
101 + (CFI_type_t
)(CFI_MAX_RANK
* sizeof (CFI_dim_t
)));
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
;
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
;
116 d
->type
= (CFI_type_t
)GFC_DESCRIPTOR_TYPE (s
);
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
));
123 /* Full pointer or allocatable arrays retain their lower_bounds. */
124 for (n
= 0; n
< GFC_DESCRIPTOR_RANK (s
); n
++)
126 if (d
->attribute
!= CFI_attribute_other
)
127 d
->dim
[n
].lower_bound
= (CFI_index_t
)GFC_DESCRIPTOR_LBOUND(s
, n
);
129 d
->dim
[n
].lower_bound
= 0;
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;
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
);
146 void *CFI_address (const CFI_cdesc_t
*dv
, const CFI_index_t subscripts
[])
149 char *base_addr
= (char *)dv
->base_addr
;
151 if (unlikely (compile_options
.bounds_check
))
153 /* C Descriptor must not be NULL. */
156 fprintf (stderr
, "CFI_address: C Descriptor is NULL.\n");
160 /* Base address of C Descriptor must not be NULL. */
161 if (dv
->base_addr
== NULL
)
163 fprintf (stderr
, "CFI_address: base address of C Descriptor "
164 "must not be NULL.\n");
169 /* Return base address if C descriptor is a scalar. */
171 return dv
->base_addr
;
173 /* Calculate the appropriate base address if dv is not a scalar. */
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
++)
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
)
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
);
194 base_addr
= base_addr
+ (CFI_index_t
)(idx
* dv
->dim
[i
].sm
);
198 return (void *)base_addr
;
203 CFI_allocate (CFI_cdesc_t
*dv
, const CFI_index_t lower_bounds
[],
204 const CFI_index_t upper_bounds
[], size_t elem_len
)
206 if (unlikely (compile_options
.bounds_check
))
208 /* C Descriptor must not be NULL. */
211 fprintf (stderr
, "CFI_allocate: C Descriptor is NULL.\n");
212 return CFI_INVALID_DESCRIPTOR
;
215 /* The C Descriptor must be for an allocatable or pointer object. */
216 if (dv
->attribute
== CFI_attribute_other
)
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
;
223 /* Base address of C Descriptor must be NULL. */
224 if (dv
->base_addr
!= NULL
)
226 fprintf (stderr
, "CFI_allocate: Base address of C descriptor "
228 return CFI_ERROR_BASE_ADDR_NOT_NULL
;
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
;
238 /* Dimension information and calculating the array length. */
241 /* If rank is greater than 0, lower_bounds and upper_bounds are used. They're
242 ignored otherwise. */
245 if (unlikely (compile_options
.bounds_check
)
246 && (lower_bounds
== NULL
|| upper_bounds
== NULL
))
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
;
253 for (int i
= 0; i
< dv
->rank
; i
++)
255 dv
->dim
[i
].lower_bound
= lower_bounds
[i
];
256 dv
->dim
[i
].extent
= upper_bounds
[i
] - dv
->dim
[i
].lower_bound
+ 1;
258 dv
->dim
[i
].sm
= dv
->elem_len
;
260 dv
->dim
[i
].sm
= dv
->elem_len
* dv
->dim
[i
- 1].extent
;
261 arr_len
*= dv
->dim
[i
].extent
;
265 dv
->base_addr
= calloc (arr_len
, dv
->elem_len
);
266 if (dv
->base_addr
== NULL
)
268 fprintf (stderr
, "CFI_allocate: Failure in memory allocation.\n");
269 return CFI_ERROR_MEM_ALLOCATION
;
277 CFI_deallocate (CFI_cdesc_t
*dv
)
279 if (unlikely (compile_options
.bounds_check
))
281 /* C Descriptor must not be NULL */
284 fprintf (stderr
, "CFI_deallocate: C Descriptor is NULL.\n");
285 return CFI_INVALID_DESCRIPTOR
;
288 /* Base address must not be NULL. */
289 if (dv
->base_addr
== NULL
)
291 fprintf (stderr
, "CFI_deallocate: Base address is already NULL.\n");
292 return CFI_ERROR_BASE_ADDR_NULL
;
295 /* C Descriptor must be for an allocatable or pointer variable. */
296 if (dv
->attribute
== CFI_attribute_other
)
298 fprintf (stderr
, "CFI_deallocate: C Descriptor must describe a "
299 "pointer or allocatable object.\n");
300 return CFI_INVALID_ATTRIBUTE
;
304 /* Free and nullify memory. */
305 free (dv
->base_addr
);
306 dv
->base_addr
= NULL
;
312 int 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
[])
316 if (unlikely (compile_options
.bounds_check
))
318 /* C descriptor must not be NULL. */
321 fprintf (stderr
, "CFI_establish: C descriptor is NULL.\n");
322 return CFI_INVALID_DESCRIPTOR
;
325 /* Rank must be between 0 and CFI_MAX_RANK. */
326 if (rank
< 0 || rank
> CFI_MAX_RANK
)
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
;
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
)
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
;
345 dv
->base_addr
= base_addr
;
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
;
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
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)
363 /* Complex numbers are twice the size of their real counterparts. */
364 if (base_type
== CFI_type_Complex
)
368 dv
->elem_len
= base_type_size
;
371 dv
->version
= CFI_VERSION
;
373 dv
->attribute
= attribute
;
376 /* Extents must not be NULL if rank is greater than zero and base_addr is not
378 if (rank
> 0 && base_addr
!= NULL
)
380 if (unlikely (compile_options
.bounds_check
) && extents
== NULL
)
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
;
388 for (int i
= 0; i
< rank
; i
++)
390 dv
->dim
[i
].lower_bound
= 0;
391 dv
->dim
[i
].extent
= extents
[i
];
393 dv
->dim
[i
].sm
= dv
->elem_len
;
395 dv
->dim
[i
].sm
= (CFI_index_t
)(dv
->elem_len
* extents
[i
- 1]);
403 int CFI_is_contiguous (const CFI_cdesc_t
*dv
)
405 if (unlikely (compile_options
.bounds_check
))
407 /* C descriptor must not be NULL. */
410 fprintf (stderr
, "CFI_is_contiguous: C descriptor is NULL.\n");
414 /* Base address must not be NULL. */
415 if (dv
->base_addr
== NULL
)
417 fprintf (stderr
, "CFI_is_contiguous: Base address of C Descriptor "
418 "is already NULL.\n");
422 /* Must be an array. */
425 fprintf (stderr
, "CFI_is_contiguous: C Descriptor must describe an "
426 "array (0 < dv->rank = %d).\n", dv
->rank
);
431 /* Assumed size arrays are always contiguous. */
432 if (dv
->rank
> 0 && dv
->dim
[dv
->rank
- 1].extent
== -1)
435 /* If an array is not contiguous the memory stride is different to the element
437 for (int i
= 0; i
< dv
->rank
; i
++)
439 if (i
== 0 && dv
->dim
[i
].sm
== (CFI_index_t
)dv
->elem_len
)
442 && dv
->dim
[i
].sm
== (CFI_index_t
)(dv
->dim
[i
- 1].sm
443 * dv
->dim
[i
- 1].extent
))
449 /* Array sections are guaranteed to be contiguous by the previous test. */
454 int 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
[])
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
];
465 if (unlikely (compile_options
.bounds_check
))
467 /* C Descriptors must not be NULL. */
470 fprintf (stderr
, "CFI_section: Source must not be NULL.\n");
471 return CFI_INVALID_DESCRIPTOR
;
476 fprintf (stderr
, "CFI_section: Result must not be NULL.\n");
477 return CFI_INVALID_DESCRIPTOR
;
480 /* Base address of source must not be NULL. */
481 if (source
->base_addr
== NULL
)
483 fprintf (stderr
, "CFI_section: Base address of source must "
485 return CFI_ERROR_BASE_ADDR_NULL
;
488 /* Result must not be an allocatable array. */
489 if (result
->attribute
== CFI_attribute_allocatable
)
491 fprintf (stderr
, "CFI_section: Result must not describe an "
492 "allocatable array.\n");
493 return CFI_INVALID_ATTRIBUTE
;
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)
500 fprintf (stderr
, "CFI_section: Source must describe an array "
501 "(0 < source->rank, 0 !< %d).\n", source
->rank
);
502 return CFI_INVALID_RANK
;
505 /* Element lengths of source and result must be equal. */
506 if (result
->elem_len
!= source
->elem_len
)
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
;
515 /* Types must be equal. */
516 if (result
->type
!= source
->type
)
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
;
525 /* Stride of zero in the i'th dimension means rank reduction in that
527 for (int i
= 0; i
< source
->rank
; i
++)
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
)
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
;
546 if (lower_bounds
== NULL
)
548 for (int i
= 0; i
< source
->rank
; i
++)
549 lower
[i
] = source
->dim
[i
].lower_bound
;
553 for (int i
= 0; i
< source
->rank
; i
++)
554 lower
[i
] = lower_bounds
[i
];
558 if (upper_bounds
== NULL
)
560 if (unlikely (compile_options
.bounds_check
)
561 && source
->dim
[source
->rank
- 1].extent
== -1)
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
;
568 for (int i
= 0; i
< source
->rank
; i
++)
569 upper
[i
] = source
->dim
[i
].lower_bound
+ source
->dim
[i
].extent
- 1;
573 for (int i
= 0; i
< source
->rank
; i
++)
574 upper
[i
] = upper_bounds
[i
];
580 for (int i
= 0; i
< source
->rank
; i
++)
585 for (int i
= 0; i
< source
->rank
; i
++)
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
])
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
;
601 /* Check that section upper and lower bounds are within the array bounds. */
602 for (int i
= 0; i
< source
->rank
; i
++)
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)))
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
;
622 if (unlikely (compile_options
.bounds_check
)
623 && upper_bounds
!= NULL
624 && (upper
[i
] < source
->dim
[i
].lower_bound
626 && upper
[i
] > source
->dim
[i
].lower_bound
627 + source
->dim
[i
].extent
- 1)))
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
;
639 if (unlikely (compile_options
.bounds_check
)
640 && upper
[i
] < lower
[i
] && stride
[i
] >= 0)
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
;
651 /* Set the appropriate dimension information that gives us access to the
654 for (int i
= 0; i
< source
->rank
; i
++)
659 /* Adjust 'lower' for the base address offset. */
660 lower
[i
] = lower
[i
] - source
->dim
[i
].lower_bound
;
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
;
671 /* Set the base address. */
672 result
->base_addr
= CFI_address (source
, lower
);
678 int CFI_select_part (CFI_cdesc_t
*result
, const CFI_cdesc_t
*source
,
679 size_t displacement
, size_t elem_len
)
681 if (unlikely (compile_options
.bounds_check
))
683 /* C Descriptors must not be NULL. */
686 fprintf (stderr
, "CFI_select_part: Source must not be NULL.\n");
687 return CFI_INVALID_DESCRIPTOR
;
692 fprintf (stderr
, "CFI_select_part: Result must not be NULL.\n");
693 return CFI_INVALID_DESCRIPTOR
;
696 /* Attribute of result will be CFI_attribute_other or
697 CFI_attribute_pointer. */
698 if (result
->attribute
== CFI_attribute_allocatable
)
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
;
706 /* Base address of source must not be NULL. */
707 if (source
->base_addr
== NULL
)
709 fprintf (stderr
, "CFI_select_part: Base address of source must "
711 return CFI_ERROR_BASE_ADDR_NULL
;
714 /* Source and result must have the same rank. */
715 if (source
->rank
!= result
->rank
)
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
;
723 /* Nonallocatable nonpointer must not be an assumed size array. */
724 if (source
->rank
> 0 && source
->dim
[source
->rank
- 1].extent
== -1)
726 fprintf (stderr
, "CFI_select_part: Source must not describe an "
727 "assumed size array (source->dim[%d].extent != -1).\n",
729 return CFI_INVALID_DESCRIPTOR
;
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
;
738 if (unlikely (compile_options
.bounds_check
))
740 /* Ensure displacement is within the bounds of the element length
742 if (displacement
> source
->elem_len
- 1)
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
;
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
)
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
;
766 if (result
->rank
> 0)
768 for (int i
= 0; i
< result
->rank
; i
++)
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
;
776 result
->base_addr
= (char *) source
->base_addr
+ displacement
;
781 int CFI_setpointer (CFI_cdesc_t
*result
, CFI_cdesc_t
*source
,
782 const CFI_index_t lower_bounds
[])
784 /* Result must not be NULL and must be a Fortran pointer. */
785 if (unlikely (compile_options
.bounds_check
))
789 fprintf (stderr
, "CFI_setpointer: Result is NULL.\n");
790 return CFI_INVALID_DESCRIPTOR
;
793 if (result
->attribute
!= CFI_attribute_pointer
)
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
;
801 /* If source is NULL, the result is a C Descriptor that describes a
802 * disassociated pointer. */
805 result
->base_addr
= NULL
;
806 result
->version
= CFI_VERSION
;
810 /* Check that element lengths, ranks and types of source and result are
812 if (unlikely (compile_options
.bounds_check
))
814 if (result
->elem_len
!= source
->elem_len
)
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
;
823 if (result
->rank
!= source
->rank
)
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
;
831 if (result
->type
!= source
->type
)
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
;
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
;
846 result
->base_addr
= source
->base_addr
;
848 /* Assign components to result. */
849 result
->version
= source
->version
;
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
;