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