|
145
|
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
|
|
|
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
|
|
|
33 extern void cfi_desc_to_gfc_desc (gfc_array_void *, CFI_cdesc_t **);
|
|
|
34 export_proto(cfi_desc_to_gfc_desc);
|
|
|
35
|
|
|
36 void
|
|
|
37 cfi_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
|
|
|
87 extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
|
|
|
88 export_proto(gfc_desc_to_cfi_desc);
|
|
|
89
|
|
|
90 void
|
|
|
91 gfc_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
|
|
|
146 void *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
|
|
|
202 int
|
|
|
203 CFI_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
|
|
|
276 int
|
|
|
277 CFI_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
|
|
|
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[])
|
|
|
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
|
|
|
403 int 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
|
|
|
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[])
|
|
|
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
|
|
|
678 int 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
|
|
|
781 int 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 }
|
