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