1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2021 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-types.c -- gfortran backend types */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "fold-const.h"
33 #include "stor-layout.h"
34 #include "langhooks.h" /* For iso-c-bindings.def. */
35 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "trans-types.h"
37 #include "trans-const.h"
38 #include "trans-array.h"
39 #include "dwarf2out.h" /* For struct array_descr_info. */
44 #if (GFC_MAX_DIMENSIONS < 10)
45 #define GFC_RANK_DIGITS 1
46 #define GFC_RANK_PRINTF_FORMAT "%01d"
47 #elif (GFC_MAX_DIMENSIONS < 100)
48 #define GFC_RANK_DIGITS 2
49 #define GFC_RANK_PRINTF_FORMAT "%02d"
51 #error If you really need >99 dimensions, continue the sequence above...
54 /* array of structs so we don't have to worry about xmalloc or free */
55 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
57 tree gfc_array_index_type
;
58 tree gfc_array_range_type
;
59 tree gfc_character1_type_node
;
61 tree prvoid_type_node
;
62 tree ppvoid_type_node
;
66 tree logical_type_node
;
67 tree logical_true_node
;
68 tree logical_false_node
;
69 tree gfc_charlen_type_node
;
71 tree gfc_float128_type_node
= NULL_TREE
;
72 tree gfc_complex_float128_type_node
= NULL_TREE
;
74 bool gfc_real16_is_float128
= false;
76 static GTY(()) tree gfc_desc_dim_type
;
77 static GTY(()) tree gfc_max_array_element_size
;
78 static GTY(()) tree gfc_array_descriptor_base
[2 * (GFC_MAX_DIMENSIONS
+1)];
79 static GTY(()) tree gfc_array_descriptor_base_caf
[2 * (GFC_MAX_DIMENSIONS
+1)];
81 /* Arrays for all integral and real kinds. We'll fill this in at runtime
82 after the target has a chance to process command-line options. */
84 #define MAX_INT_KINDS 5
85 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
86 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
87 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
88 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
90 #define MAX_REAL_KINDS 5
91 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
92 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
93 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
95 #define MAX_CHARACTER_KINDS 2
96 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
97 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
98 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
100 static tree
gfc_add_field_to_struct_1 (tree
, tree
, tree
, tree
**);
102 /* The integer kind to use for array indices. This will be set to the
103 proper value based on target information from the backend. */
105 int gfc_index_integer_kind
;
107 /* The default kinds of the various types. */
109 int gfc_default_integer_kind
;
110 int gfc_max_integer_kind
;
111 int gfc_default_real_kind
;
112 int gfc_default_double_kind
;
113 int gfc_default_character_kind
;
114 int gfc_default_logical_kind
;
115 int gfc_default_complex_kind
;
117 int gfc_atomic_int_kind
;
118 int gfc_atomic_logical_kind
;
120 /* The kind size used for record offsets. If the target system supports
121 kind=8, this will be set to 8, otherwise it is set to 4. */
124 /* The integer kind used to store character lengths. */
125 int gfc_charlen_int_kind
;
127 /* Kind of internal integer for storing object sizes. */
130 /* The size of the numeric storage unit and character storage unit. */
131 int gfc_numeric_storage_size
;
132 int gfc_character_storage_size
;
134 tree dtype_type_node
= NULL_TREE
;
137 /* Build the dtype_type_node if necessary. */
138 tree
get_dtype_type_node (void)
142 tree
*dtype_chain
= NULL
;
144 if (dtype_type_node
== NULL_TREE
)
146 dtype_node
= make_node (RECORD_TYPE
);
147 TYPE_NAME (dtype_node
) = get_identifier ("dtype_type");
148 TYPE_NAMELESS (dtype_node
) = 1;
149 field
= gfc_add_field_to_struct_1 (dtype_node
,
150 get_identifier ("elem_len"),
151 size_type_node
, &dtype_chain
);
152 TREE_NO_WARNING (field
) = 1;
153 field
= gfc_add_field_to_struct_1 (dtype_node
,
154 get_identifier ("version"),
155 integer_type_node
, &dtype_chain
);
156 TREE_NO_WARNING (field
) = 1;
157 field
= gfc_add_field_to_struct_1 (dtype_node
,
158 get_identifier ("rank"),
159 signed_char_type_node
, &dtype_chain
);
160 TREE_NO_WARNING (field
) = 1;
161 field
= gfc_add_field_to_struct_1 (dtype_node
,
162 get_identifier ("type"),
163 signed_char_type_node
, &dtype_chain
);
164 TREE_NO_WARNING (field
) = 1;
165 field
= gfc_add_field_to_struct_1 (dtype_node
,
166 get_identifier ("attribute"),
167 short_integer_type_node
, &dtype_chain
);
168 TREE_NO_WARNING (field
) = 1;
169 gfc_finish_type (dtype_node
);
170 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node
)) = 1;
171 dtype_type_node
= dtype_node
;
173 return dtype_type_node
;
177 gfc_check_any_c_kind (gfc_typespec
*ts
)
181 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
183 /* Check for any C interoperable kind for the given type/kind in ts.
184 This can be used after verify_c_interop to make sure that the
185 Fortran kind being used exists in at least some form for C. */
186 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
187 c_interop_kinds_table
[i
].value
== ts
->kind
)
196 get_real_kind_from_node (tree type
)
200 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
201 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
202 return gfc_real_kinds
[i
].kind
;
208 get_int_kind_from_node (tree type
)
215 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
216 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
217 return gfc_integer_kinds
[i
].kind
;
223 get_int_kind_from_name (const char *name
)
225 return get_int_kind_from_node (get_typenode_from_name (name
));
229 /* Get the kind number corresponding to an integer of given size,
230 following the required return values for ISO_FORTRAN_ENV INT* constants:
231 -2 is returned if we support a kind of larger size, -1 otherwise. */
233 gfc_get_int_kind_from_width_isofortranenv (int size
)
237 /* Look for a kind with matching storage size. */
238 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
239 if (gfc_integer_kinds
[i
].bit_size
== size
)
240 return gfc_integer_kinds
[i
].kind
;
242 /* Look for a kind with larger storage size. */
243 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
244 if (gfc_integer_kinds
[i
].bit_size
> size
)
251 /* Get the kind number corresponding to a real of a given storage size.
252 If two real's have the same storage size, then choose the real with
253 the largest precision. If a kind type is unavailable and a real
254 exists with wider storage, then return -2; otherwise, return -1. */
257 gfc_get_real_kind_from_width_isofortranenv (int size
)
266 /* Look for a kind with matching storage size. */
267 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
268 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
270 if (gfc_real_kinds
[i
].digits
> digits
)
272 digits
= gfc_real_kinds
[i
].digits
;
273 kind
= gfc_real_kinds
[i
].kind
;
280 /* Look for a kind with larger storage size. */
281 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
282 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
291 get_int_kind_from_width (int size
)
295 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
296 if (gfc_integer_kinds
[i
].bit_size
== size
)
297 return gfc_integer_kinds
[i
].kind
;
303 get_int_kind_from_minimal_width (int size
)
307 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
308 if (gfc_integer_kinds
[i
].bit_size
>= size
)
309 return gfc_integer_kinds
[i
].kind
;
315 /* Generate the CInteropKind_t objects for the C interoperable
319 gfc_init_c_interop_kinds (void)
323 /* init all pointers in the list to NULL */
324 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
326 /* Initialize the name and value fields. */
327 c_interop_kinds_table
[i
].name
[0] = '\0';
328 c_interop_kinds_table
[i
].value
= -100;
329 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
332 #define NAMED_INTCST(a,b,c,d) \
333 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
334 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
335 c_interop_kinds_table[a].value = c;
336 #define NAMED_REALCST(a,b,c,d) \
337 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
338 c_interop_kinds_table[a].f90_type = BT_REAL; \
339 c_interop_kinds_table[a].value = c;
340 #define NAMED_CMPXCST(a,b,c,d) \
341 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
342 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
343 c_interop_kinds_table[a].value = c;
344 #define NAMED_LOGCST(a,b,c) \
345 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
346 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
347 c_interop_kinds_table[a].value = c;
348 #define NAMED_CHARKNDCST(a,b,c) \
349 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
350 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
351 c_interop_kinds_table[a].value = c;
352 #define NAMED_CHARCST(a,b,c) \
353 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
354 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
355 c_interop_kinds_table[a].value = c;
356 #define DERIVED_TYPE(a,b,c) \
357 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
358 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
359 c_interop_kinds_table[a].value = c;
360 #define NAMED_FUNCTION(a,b,c,d) \
361 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
362 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
363 c_interop_kinds_table[a].value = c;
364 #define NAMED_SUBROUTINE(a,b,c,d) \
365 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
366 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
367 c_interop_kinds_table[a].value = c;
368 #include "iso-c-binding.def"
372 /* Query the target to determine which machine modes are available for
373 computation. Choose KIND numbers for them. */
376 gfc_init_kinds (void)
378 opt_scalar_int_mode int_mode_iter
;
379 opt_scalar_float_mode float_mode_iter
;
380 int i_index
, r_index
, kind
;
381 bool saw_i4
= false, saw_i8
= false;
382 bool saw_r4
= false, saw_r8
= false, saw_r10
= false, saw_r16
= false;
385 FOR_EACH_MODE_IN_CLASS (int_mode_iter
, MODE_INT
)
387 scalar_int_mode mode
= int_mode_iter
.require ();
390 if (!targetm
.scalar_mode_supported_p (mode
))
393 /* The middle end doesn't support constants larger than 2*HWI.
394 Perhaps the target hook shouldn't have accepted these either,
395 but just to be safe... */
396 bitsize
= GET_MODE_BITSIZE (mode
);
397 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
400 gcc_assert (i_index
!= MAX_INT_KINDS
);
402 /* Let the kind equal the bit size divided by 8. This insulates the
403 programmer from the underlying byte size. */
411 gfc_integer_kinds
[i_index
].kind
= kind
;
412 gfc_integer_kinds
[i_index
].radix
= 2;
413 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
414 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
416 gfc_logical_kinds
[i_index
].kind
= kind
;
417 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
422 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
423 used for large file access. */
430 /* If we do not at least have kind = 4, everything is pointless. */
433 /* Set the maximum integer kind. Used with at least BOZ constants. */
434 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
437 FOR_EACH_MODE_IN_CLASS (float_mode_iter
, MODE_FLOAT
)
439 scalar_float_mode mode
= float_mode_iter
.require ();
440 const struct real_format
*fmt
= REAL_MODE_FORMAT (mode
);
445 if (!targetm
.scalar_mode_supported_p (mode
))
448 /* Only let float, double, long double and __float128 go through.
449 Runtime support for others is not provided, so they would be
451 if (!targetm
.libgcc_floating_mode_supported_p (mode
))
453 if (mode
!= TYPE_MODE (float_type_node
)
454 && (mode
!= TYPE_MODE (double_type_node
))
455 && (mode
!= TYPE_MODE (long_double_type_node
))
456 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
462 /* Let the kind equal the precision divided by 8, rounding up. Again,
463 this insulates the programmer from the underlying byte size.
465 Also, it effectively deals with IEEE extended formats. There, the
466 total size of the type may equal 16, but it's got 6 bytes of padding
467 and the increased size can get in the way of a real IEEE quad format
468 which may also be supported by the target.
470 We round up so as to handle IA-64 __floatreg (RFmode), which is an
471 82 bit type. Not to be confused with __float80 (XFmode), which is
472 an 80 bit type also supported by IA-64. So XFmode should come out
473 to be kind=10, and RFmode should come out to be kind=11. Egads. */
475 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
486 /* Careful we don't stumble a weird internal mode. */
487 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
488 /* Or have too many modes for the allocated space. */
489 gcc_assert (r_index
!= MAX_REAL_KINDS
);
491 gfc_real_kinds
[r_index
].kind
= kind
;
492 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
493 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
494 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
495 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
496 if (fmt
->pnan
< fmt
->p
)
497 /* This is an IBM extended double format (or the MIPS variant)
498 made up of two IEEE doubles. The value of the long double is
499 the sum of the values of the two parts. The most significant
500 part is required to be the value of the long double rounded
501 to the nearest double. If we use emax of 1024 then we can't
502 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
503 rounding will make the most significant part overflow. */
504 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
505 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
509 /* Choose the default integer kind. We choose 4 unless the user directs us
510 otherwise. Even if the user specified that the default integer kind is 8,
511 the numeric storage size is not 64 bits. In this case, a warning will be
512 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
514 gfc_numeric_storage_size
= 4 * 8;
516 if (flag_default_integer
)
519 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
520 "%<-fdefault-integer-8%> option");
522 gfc_default_integer_kind
= 8;
525 else if (flag_integer4_kind
== 8)
528 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
529 "%<-finteger-4-integer-8%> option");
531 gfc_default_integer_kind
= 8;
535 gfc_default_integer_kind
= 4;
539 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
540 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
543 /* Choose the default real kind. Again, we choose 4 when possible. */
544 if (flag_default_real_8
)
547 gfc_fatal_error ("REAL(KIND=8) is not available for "
548 "%<-fdefault-real-8%> option");
550 gfc_default_real_kind
= 8;
552 else if (flag_default_real_10
)
555 gfc_fatal_error ("REAL(KIND=10) is not available for "
556 "%<-fdefault-real-10%> option");
558 gfc_default_real_kind
= 10;
560 else if (flag_default_real_16
)
563 gfc_fatal_error ("REAL(KIND=16) is not available for "
564 "%<-fdefault-real-16%> option");
566 gfc_default_real_kind
= 16;
568 else if (flag_real4_kind
== 8)
571 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
574 gfc_default_real_kind
= 8;
576 else if (flag_real4_kind
== 10)
579 gfc_fatal_error ("REAL(KIND=10) is not available for "
580 "%<-freal-4-real-10%> option");
582 gfc_default_real_kind
= 10;
584 else if (flag_real4_kind
== 16)
587 gfc_fatal_error ("REAL(KIND=16) is not available for "
588 "%<-freal-4-real-16%> option");
590 gfc_default_real_kind
= 16;
593 gfc_default_real_kind
= 4;
595 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
597 /* Choose the default double kind. If -fdefault-real and -fdefault-double
598 are specified, we use kind=8, if it's available. If -fdefault-real is
599 specified without -fdefault-double, we use kind=16, if it's available.
600 Otherwise we do not change anything. */
601 if (flag_default_double
&& saw_r8
)
602 gfc_default_double_kind
= 8;
603 else if (flag_default_real_8
|| flag_default_real_10
|| flag_default_real_16
)
605 /* Use largest available kind. */
607 gfc_default_double_kind
= 16;
609 gfc_default_double_kind
= 10;
611 gfc_default_double_kind
= 8;
613 gfc_default_double_kind
= gfc_default_real_kind
;
615 else if (flag_real8_kind
== 4)
618 gfc_fatal_error ("REAL(KIND=4) is not available for "
619 "%<-freal-8-real-4%> option");
621 gfc_default_double_kind
= 4;
623 else if (flag_real8_kind
== 10 )
626 gfc_fatal_error ("REAL(KIND=10) is not available for "
627 "%<-freal-8-real-10%> option");
629 gfc_default_double_kind
= 10;
631 else if (flag_real8_kind
== 16 )
634 gfc_fatal_error ("REAL(KIND=10) is not available for "
635 "%<-freal-8-real-16%> option");
637 gfc_default_double_kind
= 16;
639 else if (saw_r4
&& saw_r8
)
640 gfc_default_double_kind
= 8;
643 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
644 real ... occupies two contiguous numeric storage units.
646 Therefore we must be supplied a kind twice as large as we chose
647 for single precision. There are loopholes, in that double
648 precision must *occupy* two storage units, though it doesn't have
649 to *use* two storage units. Which means that you can make this
650 kind artificially wide by padding it. But at present there are
651 no GCC targets for which a two-word type does not exist, so we
652 just let gfc_validate_kind abort and tell us if something breaks. */
654 gfc_default_double_kind
655 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
658 /* The default logical kind is constrained to be the same as the
659 default integer kind. Similarly with complex and real. */
660 gfc_default_logical_kind
= gfc_default_integer_kind
;
661 gfc_default_complex_kind
= gfc_default_real_kind
;
663 /* We only have two character kinds: ASCII and UCS-4.
664 ASCII corresponds to a 8-bit integer type, if one is available.
665 UCS-4 corresponds to a 32-bit integer type, if one is available. */
667 if ((kind
= get_int_kind_from_width (8)) > 0)
669 gfc_character_kinds
[i_index
].kind
= kind
;
670 gfc_character_kinds
[i_index
].bit_size
= 8;
671 gfc_character_kinds
[i_index
].name
= "ascii";
674 if ((kind
= get_int_kind_from_width (32)) > 0)
676 gfc_character_kinds
[i_index
].kind
= kind
;
677 gfc_character_kinds
[i_index
].bit_size
= 32;
678 gfc_character_kinds
[i_index
].name
= "iso_10646";
682 /* Choose the smallest integer kind for our default character. */
683 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
684 gfc_character_storage_size
= gfc_default_character_kind
* 8;
686 gfc_index_integer_kind
= get_int_kind_from_name (PTRDIFF_TYPE
);
688 /* Pick a kind the same size as the C "int" type. */
689 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
691 /* Choose atomic kinds to match C's int. */
692 gfc_atomic_int_kind
= gfc_c_int_kind
;
693 gfc_atomic_logical_kind
= gfc_c_int_kind
;
697 /* Make sure that a valid kind is present. Returns an index into the
698 associated kinds array, -1 if the kind is not present. */
701 validate_integer (int kind
)
705 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
706 if (gfc_integer_kinds
[i
].kind
== kind
)
713 validate_real (int kind
)
717 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
718 if (gfc_real_kinds
[i
].kind
== kind
)
725 validate_logical (int kind
)
729 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
730 if (gfc_logical_kinds
[i
].kind
== kind
)
737 validate_character (int kind
)
741 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
742 if (gfc_character_kinds
[i
].kind
== kind
)
748 /* Validate a kind given a basic type. The return value is the same
749 for the child functions, with -1 indicating nonexistence of the
750 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
753 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
759 case BT_REAL
: /* Fall through */
761 rc
= validate_real (kind
);
764 rc
= validate_integer (kind
);
767 rc
= validate_logical (kind
);
770 rc
= validate_character (kind
);
774 gfc_internal_error ("gfc_validate_kind(): Got bad type");
777 if (rc
< 0 && !may_fail
)
778 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
784 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
785 Reuse common type nodes where possible. Recognize if the kind matches up
786 with a C type. This will be used later in determining which routines may
787 be scarfed from libm. */
790 gfc_build_int_type (gfc_integer_info
*info
)
792 int mode_precision
= info
->bit_size
;
794 if (mode_precision
== CHAR_TYPE_SIZE
)
796 if (mode_precision
== SHORT_TYPE_SIZE
)
798 if (mode_precision
== INT_TYPE_SIZE
)
800 if (mode_precision
== LONG_TYPE_SIZE
)
802 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
803 info
->c_long_long
= 1;
805 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
806 return intQI_type_node
;
807 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
808 return intHI_type_node
;
809 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
810 return intSI_type_node
;
811 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
812 return intDI_type_node
;
813 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
814 return intTI_type_node
;
816 return make_signed_type (mode_precision
);
820 gfc_build_uint_type (int size
)
822 if (size
== CHAR_TYPE_SIZE
)
823 return unsigned_char_type_node
;
824 if (size
== SHORT_TYPE_SIZE
)
825 return short_unsigned_type_node
;
826 if (size
== INT_TYPE_SIZE
)
827 return unsigned_type_node
;
828 if (size
== LONG_TYPE_SIZE
)
829 return long_unsigned_type_node
;
830 if (size
== LONG_LONG_TYPE_SIZE
)
831 return long_long_unsigned_type_node
;
833 return make_unsigned_type (size
);
838 gfc_build_real_type (gfc_real_info
*info
)
840 int mode_precision
= info
->mode_precision
;
843 if (mode_precision
== FLOAT_TYPE_SIZE
)
845 if (mode_precision
== DOUBLE_TYPE_SIZE
)
847 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
848 info
->c_long_double
= 1;
849 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
851 info
->c_float128
= 1;
852 gfc_real16_is_float128
= true;
855 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
856 return float_type_node
;
857 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
858 return double_type_node
;
859 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
860 return long_double_type_node
;
862 new_type
= make_node (REAL_TYPE
);
863 TYPE_PRECISION (new_type
) = mode_precision
;
864 layout_type (new_type
);
869 gfc_build_complex_type (tree scalar_type
)
873 if (scalar_type
== NULL
)
875 if (scalar_type
== float_type_node
)
876 return complex_float_type_node
;
877 if (scalar_type
== double_type_node
)
878 return complex_double_type_node
;
879 if (scalar_type
== long_double_type_node
)
880 return complex_long_double_type_node
;
882 new_type
= make_node (COMPLEX_TYPE
);
883 TREE_TYPE (new_type
) = scalar_type
;
884 layout_type (new_type
);
889 gfc_build_logical_type (gfc_logical_info
*info
)
891 int bit_size
= info
->bit_size
;
894 if (bit_size
== BOOL_TYPE_SIZE
)
897 return boolean_type_node
;
900 new_type
= make_unsigned_type (bit_size
);
901 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
902 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
903 TYPE_PRECISION (new_type
) = 1;
909 /* Create the backend type nodes. We map them to their
910 equivalent C type, at least for now. We also give
911 names to the types here, and we push them in the
912 global binding level context.*/
915 gfc_init_types (void)
922 /* Create and name the types. */
923 #define PUSH_TYPE(name, node) \
924 pushdecl (build_decl (input_location, \
925 TYPE_DECL, get_identifier (name), node))
927 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
929 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
930 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
931 if (TYPE_STRING_FLAG (type
))
932 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
933 gfc_integer_types
[index
] = type
;
934 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
935 gfc_integer_kinds
[index
].kind
);
936 PUSH_TYPE (name_buf
, type
);
939 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
941 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
942 gfc_logical_types
[index
] = type
;
943 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
944 gfc_logical_kinds
[index
].kind
);
945 PUSH_TYPE (name_buf
, type
);
948 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
950 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
951 gfc_real_types
[index
] = type
;
952 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
953 gfc_real_kinds
[index
].kind
);
954 PUSH_TYPE (name_buf
, type
);
956 if (gfc_real_kinds
[index
].c_float128
)
957 gfc_float128_type_node
= type
;
959 type
= gfc_build_complex_type (type
);
960 gfc_complex_types
[index
] = type
;
961 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
962 gfc_real_kinds
[index
].kind
);
963 PUSH_TYPE (name_buf
, type
);
965 if (gfc_real_kinds
[index
].c_float128
)
966 gfc_complex_float128_type_node
= type
;
969 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
971 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
972 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
973 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
974 gfc_character_kinds
[index
].kind
);
975 PUSH_TYPE (name_buf
, type
);
976 gfc_character_types
[index
] = type
;
977 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
979 gfc_character1_type_node
= gfc_character_types
[0];
981 PUSH_TYPE ("byte", unsigned_char_type_node
);
982 PUSH_TYPE ("void", void_type_node
);
984 /* DBX debugging output gets upset if these aren't set. */
985 if (!TYPE_NAME (integer_type_node
))
986 PUSH_TYPE ("c_integer", integer_type_node
);
987 if (!TYPE_NAME (char_type_node
))
988 PUSH_TYPE ("c_char", char_type_node
);
992 pvoid_type_node
= build_pointer_type (void_type_node
);
993 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
994 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
995 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
997 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
999 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
1000 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
1001 since this function is called before gfc_init_constants. */
1002 gfc_array_range_type
1003 = build_range_type (gfc_array_index_type
,
1004 build_int_cst (gfc_array_index_type
, 0),
1007 /* The maximum array element size that can be handled is determined
1008 by the number of bits available to store this field in the array
1011 n
= TYPE_PRECISION (size_type_node
);
1012 gfc_max_array_element_size
1013 = wide_int_to_tree (size_type_node
,
1014 wi::mask (n
, UNSIGNED
,
1015 TYPE_PRECISION (size_type_node
)));
1017 logical_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
1018 logical_true_node
= build_int_cst (logical_type_node
, 1);
1019 logical_false_node
= build_int_cst (logical_type_node
, 0);
1021 /* Character lengths are of type size_t, except signed. */
1022 gfc_charlen_int_kind
= get_int_kind_from_node (size_type_node
);
1023 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
1025 /* Fortran kind number of size_type_node (size_t). This is used for
1026 the _size member in vtables. */
1027 gfc_size_kind
= get_int_kind_from_node (size_type_node
);
1030 /* Get the type node for the given type and kind. */
1033 gfc_get_int_type (int kind
)
1035 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
1036 return index
< 0 ? 0 : gfc_integer_types
[index
];
1040 gfc_get_real_type (int kind
)
1042 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
1043 return index
< 0 ? 0 : gfc_real_types
[index
];
1047 gfc_get_complex_type (int kind
)
1049 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
1050 return index
< 0 ? 0 : gfc_complex_types
[index
];
1054 gfc_get_logical_type (int kind
)
1056 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
1057 return index
< 0 ? 0 : gfc_logical_types
[index
];
1061 gfc_get_char_type (int kind
)
1063 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1064 return index
< 0 ? 0 : gfc_character_types
[index
];
1068 gfc_get_pchar_type (int kind
)
1070 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1071 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
1075 /* Create a character type with the given kind and length. */
1078 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
1082 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
1083 type
= build_array_type (eltype
, bounds
);
1084 TYPE_STRING_FLAG (type
) = 1;
1090 gfc_get_character_type_len (int kind
, tree len
)
1092 gfc_validate_kind (BT_CHARACTER
, kind
, false);
1093 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
1097 /* Get a type node for a character kind. */
1100 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
1104 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1105 if (len
&& POINTER_TYPE_P (TREE_TYPE (len
)))
1106 len
= build_fold_indirect_ref (len
);
1108 return gfc_get_character_type_len (kind
, len
);
1111 /* Convert a basic type. This will be an array for character types. */
1114 gfc_typenode_for_spec (gfc_typespec
* spec
, int codim
)
1124 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1125 has been resolved. This is done so we can convert C_PTR and
1126 C_FUNPTR to simple variables that get translated to (void *). */
1127 if (spec
->f90_type
== BT_VOID
)
1130 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1131 basetype
= ptr_type_node
;
1133 basetype
= pfunc_type_node
;
1136 basetype
= gfc_get_int_type (spec
->kind
);
1140 basetype
= gfc_get_real_type (spec
->kind
);
1144 basetype
= gfc_get_complex_type (spec
->kind
);
1148 basetype
= gfc_get_logical_type (spec
->kind
);
1152 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1156 /* Since this cannot be used, return a length one character. */
1157 basetype
= gfc_get_character_type_len (gfc_default_character_kind
,
1158 gfc_index_one_node
);
1162 basetype
= gfc_get_union_type (spec
->u
.derived
);
1167 basetype
= gfc_get_derived_type (spec
->u
.derived
, codim
);
1169 if (spec
->type
== BT_CLASS
)
1170 GFC_CLASS_TYPE_P (basetype
) = 1;
1172 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1173 type and kind to fit a (void *) and the basetype returned was a
1174 ptr_type_node. We need to pass up this new information to the
1175 symbol that was declared of type C_PTR or C_FUNPTR. */
1176 if (spec
->u
.derived
->ts
.f90_type
== BT_VOID
)
1178 spec
->type
= BT_INTEGER
;
1179 spec
->kind
= gfc_index_integer_kind
;
1180 spec
->f90_type
= BT_VOID
;
1181 spec
->is_c_interop
= 1; /* Mark as escaping later. */
1186 /* This is for the second arg to c_f_pointer and c_f_procpointer
1187 of the iso_c_binding module, to accept any ptr type. */
1188 basetype
= ptr_type_node
;
1189 if (spec
->f90_type
== BT_VOID
)
1192 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1193 basetype
= ptr_type_node
;
1195 basetype
= pfunc_type_node
;
1199 basetype
= pfunc_type_node
;
1207 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1210 gfc_conv_array_bound (gfc_expr
* expr
)
1212 /* If expr is an integer constant, return that. */
1213 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1214 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1216 /* Otherwise return NULL. */
1220 /* Return the type of an element of the array. Note that scalar coarrays
1221 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1222 (with POINTER_TYPE stripped) is returned. */
1225 gfc_get_element_type (tree type
)
1229 if (GFC_ARRAY_TYPE_P (type
))
1231 if (TREE_CODE (type
) == POINTER_TYPE
)
1232 type
= TREE_TYPE (type
);
1233 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1235 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1240 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1241 element
= TREE_TYPE (type
);
1246 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1247 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1249 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1250 element
= TREE_TYPE (element
);
1252 /* For arrays, which are not scalar coarrays. */
1253 if (TREE_CODE (element
) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (element
))
1254 element
= TREE_TYPE (element
);
1260 /* Build an array. This function is called from gfc_sym_type().
1261 Actually returns array descriptor type.
1263 Format of array descriptors is as follows:
1265 struct gfc_array_descriptor
1269 struct dtype_type dtype;
1270 struct descriptor_dimension dimension[N_DIM];
1279 signed short attribute;
1282 struct descriptor_dimension
1289 Translation code should use gfc_conv_descriptor_* rather than
1290 accessing the descriptor directly. Any changes to the array
1291 descriptor type will require changes in gfc_conv_descriptor_* and
1292 gfc_build_array_initializer.
1294 This is represented internally as a RECORD_TYPE. The index nodes
1295 are gfc_array_index_type and the data node is a pointer to the
1296 data. See below for the handling of character types.
1298 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1299 this generated poor code for assumed/deferred size arrays. These
1300 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1301 of the GENERIC grammar. Also, there is no way to explicitly set
1302 the array stride, so all data must be packed(1). I've tried to
1303 mark all the functions which would require modification with a GCC
1306 The data component points to the first element in the array. The
1307 offset field is the position of the origin of the array (i.e. element
1308 (0, 0 ...)). This may be outside the bounds of the array.
1310 An element is accessed by
1311 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1312 This gives good performance as the computation does not involve the
1313 bounds of the array. For packed arrays, this is optimized further
1314 by substituting the known strides.
1316 This system has one problem: all array bounds must be within 2^31
1317 elements of the origin (2^63 on 64-bit machines). For example
1318 integer, dimension (80000:90000, 80000:90000, 2) :: array
1319 may not work properly on 32-bit machines because 80000*80000 >
1320 2^31, so the calculation for stride2 would overflow. This may
1321 still work, but I haven't checked, and it relies on the overflow
1322 doing the right thing.
1324 The way to fix this problem is to access elements as follows:
1325 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1326 Obviously this is much slower. I will make this a compile time
1327 option, something like -fsmall-array-offsets. Mixing code compiled
1328 with and without this switch will work.
1330 (1) This can be worked around by modifying the upper bound of the
1331 previous dimension. This requires extra fields in the descriptor
1332 (both real_ubound and fake_ubound). */
1335 /* Returns true if the array sym does not require a descriptor. */
1338 gfc_is_nodesc_array (gfc_symbol
* sym
)
1340 symbol_attribute
*array_attr
;
1342 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1344 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1345 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1347 gcc_assert (array_attr
->dimension
|| array_attr
->codimension
);
1349 /* We only want local arrays. */
1350 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1351 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1352 || array_attr
->allocatable
)
1355 /* We want a descriptor for associate-name arrays that do not have an
1356 explicitly known shape already. */
1357 if (sym
->assoc
&& as
->type
!= AS_EXPLICIT
)
1360 /* The dummy is stored in sym and not in the component. */
1361 if (sym
->attr
.dummy
)
1362 return as
->type
!= AS_ASSUMED_SHAPE
1363 && as
->type
!= AS_ASSUMED_RANK
;
1365 if (sym
->attr
.result
|| sym
->attr
.function
)
1368 gcc_assert (as
->type
== AS_EXPLICIT
|| as
->cp_was_assumed
);
1374 /* Create an array descriptor type. */
1377 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1378 enum gfc_array_kind akind
, bool restricted
,
1379 bool contiguous
, int codim
)
1381 tree lbound
[GFC_MAX_DIMENSIONS
];
1382 tree ubound
[GFC_MAX_DIMENSIONS
];
1385 /* Assumed-shape arrays do not have codimension information stored in the
1387 corank
= MAX (as
->corank
, codim
);
1388 if (as
->type
== AS_ASSUMED_SHAPE
||
1389 (as
->type
== AS_ASSUMED_RANK
&& akind
== GFC_ARRAY_ALLOCATABLE
))
1392 if (as
->type
== AS_ASSUMED_RANK
)
1393 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1395 lbound
[n
] = NULL_TREE
;
1396 ubound
[n
] = NULL_TREE
;
1399 for (n
= 0; n
< as
->rank
; n
++)
1401 /* Create expressions for the known bounds of the array. */
1402 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1403 lbound
[n
] = gfc_index_one_node
;
1405 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1406 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1409 for (n
= as
->rank
; n
< as
->rank
+ corank
; n
++)
1411 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1412 lbound
[n
] = gfc_index_one_node
;
1414 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1416 if (n
< as
->rank
+ corank
- 1)
1417 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1420 if (as
->type
== AS_ASSUMED_SHAPE
)
1421 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1422 : GFC_ARRAY_ASSUMED_SHAPE
;
1423 else if (as
->type
== AS_ASSUMED_RANK
)
1424 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1425 : GFC_ARRAY_ASSUMED_RANK
;
1426 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1427 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1428 corank
, lbound
, ubound
, 0, akind
,
1432 /* Returns the struct descriptor_dimension type. */
1435 gfc_get_desc_dim_type (void)
1438 tree decl
, *chain
= NULL
;
1440 if (gfc_desc_dim_type
)
1441 return gfc_desc_dim_type
;
1443 /* Build the type node. */
1444 type
= make_node (RECORD_TYPE
);
1446 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1447 TYPE_PACKED (type
) = 1;
1449 /* Consists of the stride, lbound and ubound members. */
1450 decl
= gfc_add_field_to_struct_1 (type
,
1451 get_identifier ("stride"),
1452 gfc_array_index_type
, &chain
);
1453 TREE_NO_WARNING (decl
) = 1;
1455 decl
= gfc_add_field_to_struct_1 (type
,
1456 get_identifier ("lbound"),
1457 gfc_array_index_type
, &chain
);
1458 TREE_NO_WARNING (decl
) = 1;
1460 decl
= gfc_add_field_to_struct_1 (type
,
1461 get_identifier ("ubound"),
1462 gfc_array_index_type
, &chain
);
1463 TREE_NO_WARNING (decl
) = 1;
1465 /* Finish off the type. */
1466 gfc_finish_type (type
);
1467 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1469 gfc_desc_dim_type
= type
;
1474 /* Return the DTYPE for an array. This describes the type and type parameters
1476 /* TODO: Only call this when the value is actually used, and make all the
1477 unknown cases abort. */
1480 gfc_get_dtype_rank_type (int rank
, tree etype
)
1487 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1489 size
= TYPE_SIZE_UNIT (etype
);
1491 switch (TREE_CODE (etype
))
1510 if (GFC_CLASS_TYPE_P (etype
))
1516 /* We will never have arrays of arrays. */
1519 if (size
== NULL_TREE
)
1520 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1525 if (TREE_CODE (TREE_TYPE (etype
)) != VOID_TYPE
)
1526 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1528 size
= build_int_cst (size_type_node
, 0);
1532 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1533 /* We can encounter strange array types for temporary arrays. */
1534 return gfc_index_zero_node
;
1537 tmp
= get_dtype_type_node ();
1538 field
= gfc_advance_chain (TYPE_FIELDS (tmp
),
1539 GFC_DTYPE_ELEM_LEN
);
1540 CONSTRUCTOR_APPEND_ELT (v
, field
,
1541 fold_convert (TREE_TYPE (field
), size
));
1543 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1545 CONSTRUCTOR_APPEND_ELT (v
, field
,
1546 build_int_cst (TREE_TYPE (field
), rank
));
1548 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1550 CONSTRUCTOR_APPEND_ELT (v
, field
,
1551 build_int_cst (TREE_TYPE (field
), n
));
1553 dtype
= build_constructor (tmp
, v
);
1560 gfc_get_dtype (tree type
)
1566 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1568 rank
= GFC_TYPE_ARRAY_RANK (type
);
1569 etype
= gfc_get_element_type (type
);
1570 dtype
= gfc_get_dtype_rank_type (rank
, etype
);
1572 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1577 /* Build an array type for use without a descriptor, packed according
1578 to the value of PACKED. */
1581 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1595 mpz_init_set_ui (offset
, 0);
1596 mpz_init_set_ui (stride
, 1);
1599 /* We don't use build_array_type because this does not include
1600 lang-specific information (i.e. the bounds of the array) when checking
1603 type
= make_node (ARRAY_TYPE
);
1605 type
= build_variant_type_copy (etype
);
1607 GFC_ARRAY_TYPE_P (type
) = 1;
1608 TYPE_LANG_SPECIFIC (type
) = ggc_cleared_alloc
<struct lang_type
> ();
1610 known_stride
= (packed
!= PACKED_NO
);
1612 for (n
= 0; n
< as
->rank
; n
++)
1614 /* Fill in the stride and bound components of the type. */
1616 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1619 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1621 expr
= as
->lower
[n
];
1622 if (expr
->expr_type
== EXPR_CONSTANT
)
1624 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1625 gfc_index_integer_kind
);
1632 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1636 /* Calculate the offset. */
1637 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1638 mpz_sub (offset
, offset
, delta
);
1643 expr
= as
->upper
[n
];
1644 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1646 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1647 gfc_index_integer_kind
);
1654 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1658 /* Calculate the stride. */
1659 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1660 as
->lower
[n
]->value
.integer
);
1661 mpz_add_ui (delta
, delta
, 1);
1662 mpz_mul (stride
, stride
, delta
);
1665 /* Only the first stride is known for partial packed arrays. */
1666 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1669 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1671 expr
= as
->lower
[n
];
1672 if (expr
->expr_type
== EXPR_CONSTANT
)
1673 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1674 gfc_index_integer_kind
);
1677 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1679 expr
= as
->upper
[n
];
1680 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1681 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1682 gfc_index_integer_kind
);
1685 if (n
< as
->rank
+ as
->corank
- 1)
1686 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1691 GFC_TYPE_ARRAY_OFFSET (type
) =
1692 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1695 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1699 GFC_TYPE_ARRAY_SIZE (type
) =
1700 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1703 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1705 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1706 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1707 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1708 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1710 /* TODO: use main type if it is unbounded. */
1711 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1712 build_pointer_type (build_array_type (etype
, range
));
1714 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1715 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1716 TYPE_QUAL_RESTRICT
);
1720 if (packed
!= PACKED_STATIC
|| flag_coarray
== GFC_FCOARRAY_LIB
)
1722 type
= build_pointer_type (type
);
1725 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1727 GFC_ARRAY_TYPE_P (type
) = 1;
1728 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1736 mpz_sub_ui (stride
, stride
, 1);
1737 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1742 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1743 TYPE_DOMAIN (type
) = range
;
1745 build_pointer_type (etype
);
1746 TREE_TYPE (type
) = etype
;
1754 /* Represent packed arrays as multi-dimensional if they have rank >
1755 1 and with proper bounds, instead of flat arrays. This makes for
1756 better debug info. */
1759 tree gtype
= etype
, rtype
, type_decl
;
1761 for (n
= as
->rank
- 1; n
>= 0; n
--)
1763 rtype
= build_range_type (gfc_array_index_type
,
1764 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1765 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1766 gtype
= build_array_type (gtype
, rtype
);
1768 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1769 TYPE_DECL
, NULL
, gtype
);
1770 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1773 if (packed
!= PACKED_STATIC
|| !known_stride
1774 || (as
->corank
&& flag_coarray
== GFC_FCOARRAY_LIB
))
1776 /* For dummy arrays and automatic (heap allocated) arrays we
1777 want a pointer to the array. */
1778 type
= build_pointer_type (type
);
1780 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1781 GFC_ARRAY_TYPE_P (type
) = 1;
1782 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1788 /* Return or create the base type for an array descriptor. */
1791 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1793 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1794 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1797 /* Assumed-rank array. */
1799 dimen
= GFC_MAX_DIMENSIONS
;
1801 idx
= 2 * (codimen
+ dimen
) + restricted
;
1803 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1805 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1807 if (gfc_array_descriptor_base_caf
[idx
])
1808 return gfc_array_descriptor_base_caf
[idx
];
1810 else if (gfc_array_descriptor_base
[idx
])
1811 return gfc_array_descriptor_base
[idx
];
1813 /* Build the type node. */
1814 fat_type
= make_node (RECORD_TYPE
);
1816 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1817 TYPE_NAME (fat_type
) = get_identifier (name
);
1818 TYPE_NAMELESS (fat_type
) = 1;
1820 /* Add the data member as the first element of the descriptor. */
1821 gfc_add_field_to_struct_1 (fat_type
,
1822 get_identifier ("data"),
1825 : ptr_type_node
), &chain
);
1827 /* Add the base component. */
1828 decl
= gfc_add_field_to_struct_1 (fat_type
,
1829 get_identifier ("offset"),
1830 gfc_array_index_type
, &chain
);
1831 TREE_NO_WARNING (decl
) = 1;
1833 /* Add the dtype component. */
1834 decl
= gfc_add_field_to_struct_1 (fat_type
,
1835 get_identifier ("dtype"),
1836 get_dtype_type_node (), &chain
);
1837 TREE_NO_WARNING (decl
) = 1;
1839 /* Add the span component. */
1840 decl
= gfc_add_field_to_struct_1 (fat_type
,
1841 get_identifier ("span"),
1842 gfc_array_index_type
, &chain
);
1843 TREE_NO_WARNING (decl
) = 1;
1845 /* Build the array type for the stride and bound components. */
1846 if (dimen
+ codimen
> 0)
1849 build_array_type (gfc_get_desc_dim_type (),
1850 build_range_type (gfc_array_index_type
,
1851 gfc_index_zero_node
,
1852 gfc_rank_cst
[codimen
+ dimen
- 1]));
1854 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1856 TREE_NO_WARNING (decl
) = 1;
1859 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1861 decl
= gfc_add_field_to_struct_1 (fat_type
,
1862 get_identifier ("token"),
1863 prvoid_type_node
, &chain
);
1864 TREE_NO_WARNING (decl
) = 1;
1867 /* Finish off the type. */
1868 gfc_finish_type (fat_type
);
1869 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1871 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1872 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1874 gfc_array_descriptor_base
[idx
] = fat_type
;
1880 /* Build an array (descriptor) type with given bounds. */
1883 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1884 tree
* ubound
, int packed
,
1885 enum gfc_array_kind akind
, bool restricted
)
1887 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1888 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1889 const char *type_name
;
1892 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1893 fat_type
= build_distinct_type_copy (base_type
);
1894 /* Unshare TYPE_FIELDs. */
1895 for (tree
*tp
= &TYPE_FIELDS (fat_type
); *tp
; tp
= &DECL_CHAIN (*tp
))
1897 tree next
= DECL_CHAIN (*tp
);
1898 *tp
= copy_node (*tp
);
1899 DECL_CONTEXT (*tp
) = fat_type
;
1900 DECL_CHAIN (*tp
) = next
;
1902 /* Make sure that nontarget and target array type have the same canonical
1903 type (and same stub decl for debug info). */
1904 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1905 TYPE_CANONICAL (fat_type
) = base_type
;
1906 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1907 /* Arrays of unknown type must alias with all array descriptors. */
1908 TYPE_TYPELESS_STORAGE (base_type
) = 1;
1909 TYPE_TYPELESS_STORAGE (fat_type
) = 1;
1910 gcc_checking_assert (!get_alias_set (base_type
) && !get_alias_set (fat_type
));
1912 tmp
= TYPE_NAME (etype
);
1913 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1914 tmp
= DECL_NAME (tmp
);
1916 type_name
= IDENTIFIER_POINTER (tmp
);
1918 type_name
= "unknown";
1919 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1920 GFC_MAX_SYMBOL_LEN
, type_name
);
1921 TYPE_NAME (fat_type
) = get_identifier (name
);
1922 TYPE_NAMELESS (fat_type
) = 1;
1924 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1925 TYPE_LANG_SPECIFIC (fat_type
) = ggc_cleared_alloc
<struct lang_type
> ();
1927 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1928 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1929 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1930 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1932 /* Build an array descriptor record type. */
1934 stride
= gfc_index_one_node
;
1937 for (n
= 0; n
< dimen
+ codimen
; n
++)
1940 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1947 if (lower
!= NULL_TREE
)
1949 if (INTEGER_CST_P (lower
))
1950 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1955 if (codimen
&& n
== dimen
+ codimen
- 1)
1959 if (upper
!= NULL_TREE
)
1961 if (INTEGER_CST_P (upper
))
1962 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1970 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1972 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1973 gfc_array_index_type
, upper
, lower
);
1974 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1975 gfc_array_index_type
, tmp
,
1976 gfc_index_one_node
);
1977 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1978 gfc_array_index_type
, tmp
, stride
);
1979 /* Check the folding worked. */
1980 gcc_assert (INTEGER_CST_P (stride
));
1985 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1987 /* TODO: known offsets for descriptors. */
1988 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1992 arraytype
= build_pointer_type (etype
);
1994 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1996 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
2000 /* We define data as an array with the correct size if possible.
2001 Much better than doing pointer arithmetic. */
2003 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
2004 int_const_binop (MINUS_EXPR
, stride
,
2005 build_int_cst (TREE_TYPE (stride
), 1)));
2007 rtype
= gfc_array_range_type
;
2008 arraytype
= build_array_type (etype
, rtype
);
2009 arraytype
= build_pointer_type (arraytype
);
2011 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
2012 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
2014 /* This will generate the base declarations we need to emit debug
2015 information for this type. FIXME: there must be a better way to
2016 avoid divergence between compilations with and without debug
2019 struct array_descr_info info
;
2020 gfc_get_array_descr_info (fat_type
, &info
);
2021 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
2027 /* Build a pointer type. This function is called from gfc_sym_type(). */
2030 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
2032 /* Array pointer types aren't actually pointers. */
2033 if (sym
->attr
.dimension
)
2036 return build_pointer_type (type
);
2039 static tree
gfc_nonrestricted_type (tree t
);
2040 /* Given two record or union type nodes TO and FROM, ensure
2041 that all fields in FROM have a corresponding field in TO,
2042 their type being nonrestrict variants. This accepts a TO
2043 node that already has a prefix of the fields in FROM. */
2045 mirror_fields (tree to
, tree from
)
2050 /* Forward to the end of TOs fields. */
2051 fto
= TYPE_FIELDS (to
);
2052 ffrom
= TYPE_FIELDS (from
);
2053 chain
= &TYPE_FIELDS (to
);
2056 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
2057 chain
= &DECL_CHAIN (fto
);
2058 fto
= DECL_CHAIN (fto
);
2059 ffrom
= DECL_CHAIN (ffrom
);
2062 /* Now add all fields remaining in FROM (starting with ffrom). */
2063 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
2065 tree newfield
= copy_node (ffrom
);
2066 DECL_CONTEXT (newfield
) = to
;
2067 /* The store to DECL_CHAIN might seem redundant with the
2068 stores to *chain, but not clearing it here would mean
2069 leaving a chain into the old fields. If ever
2070 our called functions would look at them confusion
2072 DECL_CHAIN (newfield
) = NULL_TREE
;
2074 chain
= &DECL_CHAIN (newfield
);
2076 if (TREE_CODE (ffrom
) == FIELD_DECL
)
2078 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
2079 TREE_TYPE (newfield
) = elemtype
;
2085 /* Given a type T, returns a different type of the same structure,
2086 except that all types it refers to (recursively) are always
2087 non-restrict qualified types. */
2089 gfc_nonrestricted_type (tree t
)
2093 /* If the type isn't laid out yet, don't copy it. If something
2094 needs it for real it should wait until the type got finished. */
2098 if (!TYPE_LANG_SPECIFIC (t
))
2099 TYPE_LANG_SPECIFIC (t
) = ggc_cleared_alloc
<struct lang_type
> ();
2100 /* If we're dealing with this very node already further up
2101 the call chain (recursion via pointers and struct members)
2102 we haven't yet determined if we really need a new type node.
2103 Assume we don't, return T itself. */
2104 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
2107 /* If we have calculated this all already, just return it. */
2108 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
2109 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
2111 /* Mark this type. */
2112 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2114 switch (TREE_CODE (t
))
2120 case REFERENCE_TYPE
:
2122 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2123 if (totype
== TREE_TYPE (t
))
2125 else if (TREE_CODE (t
) == POINTER_TYPE
)
2126 ret
= build_pointer_type (totype
);
2128 ret
= build_reference_type (totype
);
2129 ret
= build_qualified_type (ret
,
2130 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2136 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2137 if (elemtype
== TREE_TYPE (t
))
2141 ret
= build_variant_type_copy (t
);
2142 TREE_TYPE (ret
) = elemtype
;
2143 if (TYPE_LANG_SPECIFIC (t
)
2144 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2146 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2147 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2148 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2150 TYPE_LANG_SPECIFIC (ret
)
2151 = ggc_cleared_alloc
<struct lang_type
> ();
2152 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2153 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2162 case QUAL_UNION_TYPE
:
2165 /* First determine if we need a new type at all.
2166 Careful, the two calls to gfc_nonrestricted_type per field
2167 might return different values. That happens exactly when
2168 one of the fields reaches back to this very record type
2169 (via pointers). The first calls will assume that we don't
2170 need to copy T (see the error_mark_node marking). If there
2171 are any reasons for copying T apart from having to copy T,
2172 we'll indeed copy it, and the second calls to
2173 gfc_nonrestricted_type will use that new node if they
2175 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2176 if (TREE_CODE (field
) == FIELD_DECL
)
2178 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2179 if (elemtype
!= TREE_TYPE (field
))
2184 ret
= build_variant_type_copy (t
);
2185 TYPE_FIELDS (ret
) = NULL_TREE
;
2187 /* Here we make sure that as soon as we know we have to copy
2188 T, that also fields reaching back to us will use the new
2189 copy. It's okay if that copy still contains the old fields,
2190 we won't look at them. */
2191 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2192 mirror_fields (ret
, t
);
2197 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2202 /* Return the type for a symbol. Special handling is required for character
2203 types to get the correct level of indirection.
2204 For functions return the return type.
2205 For subroutines return void_type_node.
2206 Calling this multiple times for the same symbol should be avoided,
2207 especially for character and array types. */
2210 gfc_sym_type (gfc_symbol
* sym
)
2216 /* Procedure Pointers inside COMMON blocks. */
2217 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2219 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2220 sym
->attr
.proc_pointer
= 0;
2221 type
= build_pointer_type (gfc_get_function_type (sym
));
2222 sym
->attr
.proc_pointer
= 1;
2226 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2227 return void_type_node
;
2229 /* In the case of a function the fake result variable may have a
2230 type different from the function type, so don't return early in
2232 if (sym
->backend_decl
&& !sym
->attr
.function
)
2233 return TREE_TYPE (sym
->backend_decl
);
2235 if (sym
->attr
.result
2236 && sym
->ts
.type
== BT_CHARACTER
2237 && sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
2238 && sym
->ns
->proc_name
2239 && sym
->ns
->proc_name
->ts
.u
.cl
2240 && sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
!= NULL_TREE
)
2241 sym
->ts
.u
.cl
->backend_decl
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2243 if (sym
->ts
.type
== BT_CHARACTER
2244 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2245 || (sym
->attr
.result
2246 && sym
->ns
->proc_name
2247 && sym
->ns
->proc_name
->attr
.is_bind_c
)
2248 || (sym
->ts
.deferred
&& (!sym
->ts
.u
.cl
2249 || !sym
->ts
.u
.cl
->backend_decl
))))
2250 type
= gfc_character1_type_node
;
2252 type
= gfc_typenode_for_spec (&sym
->ts
, sym
->attr
.codimension
);
2254 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
2255 && !sym
->pass_as_value
)
2260 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2261 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2263 type
= gfc_nonrestricted_type (type
);
2265 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2267 if (gfc_is_nodesc_array (sym
))
2269 /* If this is a character argument of unknown length, just use the
2271 if (sym
->ts
.type
!= BT_CHARACTER
2272 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2273 || sym
->ts
.u
.cl
->backend_decl
)
2275 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2284 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2285 if (sym
->attr
.pointer
)
2286 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2287 : GFC_ARRAY_POINTER
;
2288 else if (sym
->attr
.allocatable
)
2289 akind
= GFC_ARRAY_ALLOCATABLE
;
2290 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2291 sym
->attr
.contiguous
, false);
2296 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2297 || gfc_is_associate_pointer (sym
))
2298 type
= gfc_build_pointer_type (sym
, type
);
2301 /* We currently pass all parameters by reference.
2302 See f95_get_function_decl. For dummy function parameters return the
2306 /* We must use pointer types for potentially absent variables. The
2307 optimizers assume a reference type argument is never NULL. */
2308 if (sym
->attr
.optional
2309 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2310 type
= build_pointer_type (type
);
2313 type
= build_reference_type (type
);
2315 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2322 /* Layout and output debug info for a record type. */
2325 gfc_finish_type (tree type
)
2329 decl
= build_decl (input_location
,
2330 TYPE_DECL
, NULL_TREE
, type
);
2331 TYPE_STUB_DECL (type
) = decl
;
2333 rest_of_type_compilation (type
, 1);
2334 rest_of_decl_compilation (decl
, 1, 0);
2337 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2338 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2339 to the end of the field list pointed to by *CHAIN.
2341 Returns a pointer to the new field. */
2344 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2346 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2348 DECL_CONTEXT (decl
) = context
;
2349 DECL_CHAIN (decl
) = NULL_TREE
;
2350 if (TYPE_FIELDS (context
) == NULL_TREE
)
2351 TYPE_FIELDS (context
) = decl
;
2356 *chain
= &DECL_CHAIN (decl
);
2362 /* Like `gfc_add_field_to_struct_1', but adds alignment
2366 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2368 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2370 DECL_INITIAL (decl
) = 0;
2371 SET_DECL_ALIGN (decl
, 0);
2372 DECL_USER_ALIGN (decl
) = 0;
2378 /* Copy the backend_decl and component backend_decls if
2379 the two derived type symbols are "equal", as described
2380 in 4.4.2 and resolved by gfc_compare_derived_types. */
2383 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2386 gfc_component
*to_cm
;
2387 gfc_component
*from_cm
;
2392 if (from
->backend_decl
== NULL
2393 || !gfc_compare_derived_types (from
, to
))
2396 to
->backend_decl
= from
->backend_decl
;
2398 to_cm
= to
->components
;
2399 from_cm
= from
->components
;
2401 /* Copy the component declarations. If a component is itself
2402 a derived type, we need a copy of its component declarations.
2403 This is done by recursing into gfc_get_derived_type and
2404 ensures that the component's component declarations have
2405 been built. If it is a character, we need the character
2407 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2409 to_cm
->backend_decl
= from_cm
->backend_decl
;
2410 to_cm
->caf_token
= from_cm
->caf_token
;
2411 if (from_cm
->ts
.type
== BT_UNION
)
2412 gfc_get_union_type (to_cm
->ts
.u
.derived
);
2413 else if (from_cm
->ts
.type
== BT_DERIVED
2414 && (!from_cm
->attr
.pointer
|| from_gsym
))
2415 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2416 else if (from_cm
->ts
.type
== BT_CLASS
2417 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2418 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2419 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2420 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2427 /* Build a tree node for a procedure pointer component. */
2430 gfc_get_ppc_type (gfc_component
* c
)
2434 /* Explicit interface. */
2435 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2436 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2438 /* Implicit interface (only return value may be known). */
2439 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2440 t
= gfc_typenode_for_spec (&c
->ts
);
2444 /* FIXME: it would be better to provide explicit interfaces in all
2445 cases, since they should be known by the compiler. */
2446 return build_pointer_type (build_function_type (t
, NULL_TREE
));
2450 /* Build a tree node for a union type. Requires building each map
2451 structure which is an element of the union. */
2454 gfc_get_union_type (gfc_symbol
*un
)
2456 gfc_component
*map
= NULL
;
2457 tree typenode
= NULL
, map_type
= NULL
, map_field
= NULL
;
2460 if (un
->backend_decl
)
2462 if (TYPE_FIELDS (un
->backend_decl
) || un
->attr
.proc_pointer_comp
)
2463 return un
->backend_decl
;
2465 typenode
= un
->backend_decl
;
2469 typenode
= make_node (UNION_TYPE
);
2470 TYPE_NAME (typenode
) = get_identifier (un
->name
);
2473 /* Add each contained MAP as a field. */
2474 for (map
= un
->components
; map
; map
= map
->next
)
2476 gcc_assert (map
->ts
.type
== BT_DERIVED
);
2478 /* The map's type node, which is defined within this union's context. */
2479 map_type
= gfc_get_derived_type (map
->ts
.u
.derived
);
2480 TYPE_CONTEXT (map_type
) = typenode
;
2482 /* The map field's declaration. */
2483 map_field
= gfc_add_field_to_struct(typenode
, get_identifier(map
->name
),
2486 gfc_set_decl_location (map_field
, &map
->loc
);
2487 else if (un
->declared_at
.lb
)
2488 gfc_set_decl_location (map_field
, &un
->declared_at
);
2490 DECL_PACKED (map_field
) |= TYPE_PACKED (typenode
);
2491 DECL_NAMELESS(map_field
) = true;
2493 /* We should never clobber another backend declaration for this map,
2494 because each map component is unique. */
2495 if (!map
->backend_decl
)
2496 map
->backend_decl
= map_field
;
2499 un
->backend_decl
= typenode
;
2500 gfc_finish_type (typenode
);
2506 /* Build a tree node for a derived type. If there are equal
2507 derived types, with different local names, these are built
2508 at the same time. If an equal derived type has been built
2509 in a parent namespace, this is used. */
2512 gfc_get_derived_type (gfc_symbol
* derived
, int codimen
)
2514 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2515 tree canonical
= NULL_TREE
;
2517 bool got_canonical
= false;
2518 bool unlimited_entity
= false;
2524 coarray_flag
= flag_coarray
== GFC_FCOARRAY_LIB
2525 && derived
->module
&& !derived
->attr
.vtype
;
2527 gcc_assert (!derived
->attr
.pdt_template
);
2529 if (derived
->attr
.unlimited_polymorphic
2530 || (flag_coarray
== GFC_FCOARRAY_LIB
2531 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2532 && (derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
2533 || derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2534 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
)))
2535 return ptr_type_node
;
2537 if (flag_coarray
!= GFC_FCOARRAY_LIB
2538 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2539 && (derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2540 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
))
2541 return gfc_get_int_type (gfc_default_integer_kind
);
2543 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2544 && derived
->attr
.generic
)
2545 derived
= gfc_find_dt_in_generic (derived
);
2547 /* See if it's one of the iso_c_binding derived types. */
2548 if (derived
->attr
.is_iso_c
== 1 || derived
->ts
.f90_type
== BT_VOID
)
2550 if (derived
->backend_decl
)
2551 return derived
->backend_decl
;
2553 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2554 derived
->backend_decl
= ptr_type_node
;
2556 derived
->backend_decl
= pfunc_type_node
;
2558 derived
->ts
.kind
= gfc_index_integer_kind
;
2559 derived
->ts
.type
= BT_INTEGER
;
2560 /* Set the f90_type to BT_VOID as a way to recognize something of type
2561 BT_INTEGER that needs to fit a void * for the purpose of the
2562 iso_c_binding derived types. */
2563 derived
->ts
.f90_type
= BT_VOID
;
2565 return derived
->backend_decl
;
2568 /* If use associated, use the module type for this one. */
2569 if (derived
->backend_decl
== NULL
2570 && (derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2572 && gfc_get_module_backend_decl (derived
))
2573 goto copy_derived_types
;
2575 /* The derived types from an earlier namespace can be used as the
2577 if (derived
->backend_decl
== NULL
2578 && !derived
->attr
.use_assoc
2579 && !derived
->attr
.used_in_submodule
2580 && gfc_global_ns_list
)
2582 for (ns
= gfc_global_ns_list
;
2583 ns
->translated
&& !got_canonical
;
2586 if (ns
->derived_types
)
2588 for (gfc_symbol
*dt
= ns
->derived_types
; dt
&& !got_canonical
;
2591 gfc_copy_dt_decls_ifequal (dt
, derived
, true);
2592 if (derived
->backend_decl
)
2593 got_canonical
= true;
2594 if (dt
->dt_next
== ns
->derived_types
)
2601 /* Store up the canonical type to be added to this one. */
2604 if (TYPE_CANONICAL (derived
->backend_decl
))
2605 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2607 canonical
= derived
->backend_decl
;
2609 derived
->backend_decl
= NULL_TREE
;
2612 /* derived->backend_decl != 0 means we saw it before, but its
2613 components' backend_decl may have not been built. */
2614 if (derived
->backend_decl
)
2616 /* Its components' backend_decl have been built or we are
2617 seeing recursion through the formal arglist of a procedure
2618 pointer component. */
2619 if (TYPE_FIELDS (derived
->backend_decl
))
2620 return derived
->backend_decl
;
2621 else if (derived
->attr
.abstract
2622 && derived
->attr
.proc_pointer_comp
)
2624 /* If an abstract derived type with procedure pointer
2625 components has no other type of component, return the
2626 backend_decl. Otherwise build the components if any of the
2627 non-procedure pointer components have no backend_decl. */
2628 for (c
= derived
->components
; c
; c
= c
->next
)
2630 bool same_alloc_type
= c
->attr
.allocatable
2631 && derived
== c
->ts
.u
.derived
;
2632 if (!c
->attr
.proc_pointer
2634 && c
->backend_decl
== NULL
)
2636 else if (c
->next
== NULL
)
2637 return derived
->backend_decl
;
2639 typenode
= derived
->backend_decl
;
2642 typenode
= derived
->backend_decl
;
2646 /* We see this derived type first time, so build the type node. */
2647 typenode
= make_node (RECORD_TYPE
);
2648 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2649 TYPE_PACKED (typenode
) = flag_pack_derived
;
2650 derived
->backend_decl
= typenode
;
2653 if (derived
->components
2654 && derived
->components
->ts
.type
== BT_DERIVED
2655 && strcmp (derived
->components
->name
, "_data") == 0
2656 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2657 unlimited_entity
= true;
2659 /* Go through the derived type components, building them as
2660 necessary. The reason for doing this now is that it is
2661 possible to recurse back to this derived type through a
2662 pointer component (PR24092). If this happens, the fields
2663 will be built and so we can return the type. */
2664 for (c
= derived
->components
; c
; c
= c
->next
)
2666 bool same_alloc_type
= c
->attr
.allocatable
2667 && derived
== c
->ts
.u
.derived
;
2669 if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->backend_decl
== NULL
)
2670 c
->ts
.u
.derived
->backend_decl
= gfc_get_union_type (c
->ts
.u
.derived
);
2672 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2675 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
2676 && !same_alloc_type
)
2677 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2679 int local_codim
= c
->attr
.codimension
? c
->as
->corank
: codimen
;
2680 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
,
2684 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2686 /* Need to copy the modified ts from the derived type. The
2687 typespec was modified because C_PTR/C_FUNPTR are translated
2688 into (void *) from derived types. */
2689 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2690 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2691 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2694 c
->initializer
->ts
.type
= c
->ts
.type
;
2695 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2696 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2697 c
->initializer
->expr_type
= EXPR_NULL
;
2702 if (TYPE_FIELDS (derived
->backend_decl
))
2703 return derived
->backend_decl
;
2705 /* Build the type member list. Install the newly created RECORD_TYPE
2706 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2707 through only the top-level linked list of components so we correctly
2708 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2709 types are built as part of gfc_get_union_type. */
2710 for (c
= derived
->components
; c
; c
= c
->next
)
2712 bool same_alloc_type
= c
->attr
.allocatable
2713 && derived
== c
->ts
.u
.derived
;
2714 /* Prevent infinite recursion, when the procedure pointer type is
2715 the same as derived, by forcing the procedure pointer component to
2716 be built as if the explicit interface does not exist. */
2717 if (c
->attr
.proc_pointer
2718 && (c
->ts
.type
!= BT_DERIVED
|| (c
->ts
.u
.derived
2719 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)))
2720 && (c
->ts
.type
!= BT_CLASS
|| (CLASS_DATA (c
)->ts
.u
.derived
2721 && !gfc_compare_derived_types (derived
, CLASS_DATA (c
)->ts
.u
.derived
))))
2722 field_type
= gfc_get_ppc_type (c
);
2723 else if (c
->attr
.proc_pointer
&& derived
->backend_decl
)
2725 tmp
= build_function_type (derived
->backend_decl
, NULL_TREE
);
2726 field_type
= build_pointer_type (tmp
);
2728 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2729 field_type
= c
->ts
.u
.derived
->backend_decl
;
2730 else if (c
->attr
.caf_token
)
2731 field_type
= pvoid_type_node
;
2734 if (c
->ts
.type
== BT_CHARACTER
2735 && !c
->ts
.deferred
&& !c
->attr
.pdt_string
)
2737 /* Evaluate the string length. */
2738 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2739 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2741 else if (c
->ts
.type
== BT_CHARACTER
)
2742 c
->ts
.u
.cl
->backend_decl
2743 = build_int_cst (gfc_charlen_type_node
, 0);
2745 field_type
= gfc_typenode_for_spec (&c
->ts
, codimen
);
2748 /* This returns an array descriptor type. Initialization may be
2750 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2752 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_array
)
2754 enum gfc_array_kind akind
;
2755 if (c
->attr
.pointer
)
2756 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2757 : GFC_ARRAY_POINTER
;
2759 akind
= GFC_ARRAY_ALLOCATABLE
;
2760 /* Pointers to arrays aren't actually pointer types. The
2761 descriptors are separate, but the data is common. */
2762 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2764 && !c
->attr
.pointer
,
2769 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2773 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_string
)
2774 && !c
->attr
.proc_pointer
2775 && !(unlimited_entity
&& c
== derived
->components
))
2776 field_type
= build_pointer_type (field_type
);
2778 if (c
->attr
.pointer
|| same_alloc_type
)
2779 field_type
= gfc_nonrestricted_type (field_type
);
2781 /* vtype fields can point to different types to the base type. */
2782 if (c
->ts
.type
== BT_DERIVED
2783 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2784 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2787 /* Ensure that the CLASS language specific flag is set. */
2788 if (c
->ts
.type
== BT_CLASS
)
2790 if (POINTER_TYPE_P (field_type
))
2791 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2793 GFC_CLASS_TYPE_P (field_type
) = 1;
2796 field
= gfc_add_field_to_struct (typenode
,
2797 get_identifier (c
->name
),
2798 field_type
, &chain
);
2800 gfc_set_decl_location (field
, &c
->loc
);
2801 else if (derived
->declared_at
.lb
)
2802 gfc_set_decl_location (field
, &derived
->declared_at
);
2804 gfc_finish_decl_attrs (field
, &c
->attr
);
2806 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2809 if (!c
->backend_decl
)
2810 c
->backend_decl
= field
;
2812 if (c
->attr
.pointer
&& c
->attr
.dimension
2813 && !(c
->ts
.type
== BT_DERIVED
2814 && strcmp (c
->name
, "_data") == 0))
2815 GFC_DECL_PTR_ARRAY_P (c
->backend_decl
) = 1;
2818 /* Now lay out the derived type, including the fields. */
2820 TYPE_CANONICAL (typenode
) = canonical
;
2822 gfc_finish_type (typenode
);
2823 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2824 if (derived
->module
&& derived
->ns
->proc_name
2825 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2827 if (derived
->ns
->proc_name
->backend_decl
2828 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2831 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2832 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2833 = derived
->ns
->proc_name
->backend_decl
;
2837 derived
->backend_decl
= typenode
;
2841 for (c
= derived
->components
; c
; c
= c
->next
)
2843 /* Do not add a caf_token field for class container components. */
2844 if ((codimen
|| coarray_flag
)
2845 && !c
->attr
.dimension
&& !c
->attr
.codimension
2846 && (c
->attr
.allocatable
|| c
->attr
.pointer
)
2847 && !derived
->attr
.is_class
)
2849 /* Provide sufficient space to hold "_caf_symbol". */
2850 char caf_name
[GFC_MAX_SYMBOL_LEN
+ 6];
2851 gfc_component
*token
;
2852 snprintf (caf_name
, sizeof (caf_name
), "_caf_%s", c
->name
);
2853 token
= gfc_find_component (derived
, caf_name
, true, true, NULL
);
2855 c
->caf_token
= token
->backend_decl
;
2856 TREE_NO_WARNING (c
->caf_token
) = 1;
2860 for (gfc_symbol
*dt
= gfc_derived_types
; dt
; dt
= dt
->dt_next
)
2862 gfc_copy_dt_decls_ifequal (derived
, dt
, false);
2863 if (dt
->dt_next
== gfc_derived_types
)
2867 return derived
->backend_decl
;
2872 gfc_return_by_reference (gfc_symbol
* sym
)
2874 if (!sym
->attr
.function
)
2877 if (sym
->attr
.dimension
)
2880 if (sym
->ts
.type
== BT_CHARACTER
2881 && !sym
->attr
.is_bind_c
2882 && (!sym
->attr
.result
2883 || !sym
->ns
->proc_name
2884 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2887 /* Possibly return complex numbers by reference for g77 compatibility.
2888 We don't do this for calls to intrinsics (as the library uses the
2889 -fno-f2c calling convention), nor for calls to functions which always
2890 require an explicit interface, as no compatibility problems can
2892 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2893 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2900 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2904 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2905 gfc_entry_list
*el
, *el2
;
2907 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2908 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2910 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2912 /* Build the type node. */
2913 type
= make_node (UNION_TYPE
);
2915 TYPE_NAME (type
) = get_identifier (name
);
2917 for (el
= ns
->entries
; el
; el
= el
->next
)
2919 /* Search for duplicates. */
2920 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2921 if (el2
->sym
->result
== el
->sym
->result
)
2925 gfc_add_field_to_struct_1 (type
,
2926 get_identifier (el
->sym
->result
->name
),
2927 gfc_sym_type (el
->sym
->result
), &chain
);
2930 /* Finish off the type. */
2931 gfc_finish_type (type
);
2932 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2936 /* Create a "fn spec" based on the formal arguments;
2937 cf. create_function_arglist. */
2940 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2944 gfc_formal_arglist
*f
;
2947 memset (&spec
, 0, sizeof (spec
));
2952 if (sym
->attr
.entry_master
)
2954 spec
[spec_len
++] = 'R';
2955 spec
[spec_len
++] = ' ';
2957 if (gfc_return_by_reference (sym
))
2959 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2961 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2963 spec
[spec_len
++] = '.';
2964 spec
[spec_len
++] = ' ';
2968 spec
[spec_len
++] = 'w';
2969 spec
[spec_len
++] = ' ';
2971 if (sym
->ts
.type
== BT_CHARACTER
)
2973 spec
[spec_len
++] = 'R';
2974 spec
[spec_len
++] = ' ';
2978 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2979 if (spec_len
< sizeof (spec
))
2981 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2982 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2983 || (f
->sym
->ts
.type
== BT_DERIVED
2984 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2985 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2986 || (f
->sym
->ts
.type
== BT_CLASS
2987 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2988 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
))
2989 || (f
->sym
->ts
.type
== BT_INTEGER
&& f
->sym
->ts
.is_c_interop
))
2991 spec
[spec_len
++] = '.';
2992 spec
[spec_len
++] = ' ';
2994 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2996 spec
[spec_len
++] = 'r';
2997 spec
[spec_len
++] = ' ';
3001 spec
[spec_len
++] = 'w';
3002 spec
[spec_len
++] = ' ';
3006 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
3007 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
3008 return build_type_attribute_variant (fntype
, tmp
);
3012 gfc_get_function_type (gfc_symbol
* sym
, gfc_actual_arglist
*actual_args
,
3016 vec
<tree
, va_gc
> *typelist
= NULL
;
3017 gfc_formal_arglist
*f
;
3019 int alternate_return
= 0;
3020 bool is_varargs
= true;
3022 /* Make sure this symbol is a function, a subroutine or the main
3024 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
3025 || sym
->attr
.flavor
== FL_PROGRAM
);
3027 /* To avoid recursing infinitely on recursive types, we use error_mark_node
3028 so that they can be detected here and handled further down. */
3029 if (sym
->backend_decl
== NULL
)
3030 sym
->backend_decl
= error_mark_node
;
3031 else if (sym
->backend_decl
== error_mark_node
)
3032 goto arg_type_list_done
;
3033 else if (sym
->attr
.proc_pointer
)
3034 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
3036 return TREE_TYPE (sym
->backend_decl
);
3038 if (sym
->attr
.entry_master
)
3039 /* Additional parameter for selecting an entry point. */
3040 vec_safe_push (typelist
, gfc_array_index_type
);
3047 if (arg
->ts
.type
== BT_CHARACTER
)
3048 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3050 /* Some functions we use an extra parameter for the return value. */
3051 if (gfc_return_by_reference (sym
))
3053 type
= gfc_sym_type (arg
);
3054 if (arg
->ts
.type
== BT_COMPLEX
3055 || arg
->attr
.dimension
3056 || arg
->ts
.type
== BT_CHARACTER
)
3057 type
= build_reference_type (type
);
3059 vec_safe_push (typelist
, type
);
3060 if (arg
->ts
.type
== BT_CHARACTER
)
3062 if (!arg
->ts
.deferred
)
3063 /* Transfer by value. */
3064 vec_safe_push (typelist
, gfc_charlen_type_node
);
3066 /* Deferred character lengths are transferred by reference
3067 so that the value can be returned. */
3068 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
3071 if (sym
->backend_decl
== error_mark_node
&& actual_args
!= NULL
3072 && sym
->formal
== NULL
&& (sym
->attr
.proc
== PROC_EXTERNAL
3073 || sym
->attr
.proc
== PROC_UNKNOWN
))
3074 gfc_get_formal_from_actual_arglist (sym
, actual_args
);
3076 /* Build the argument types for the function. */
3077 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3082 /* Evaluate constant character lengths here so that they can be
3083 included in the type. */
3084 if (arg
->ts
.type
== BT_CHARACTER
)
3085 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3087 if (arg
->attr
.flavor
== FL_PROCEDURE
)
3089 type
= gfc_get_function_type (arg
);
3090 type
= build_pointer_type (type
);
3093 type
= gfc_sym_type (arg
);
3095 /* Parameter Passing Convention
3097 We currently pass all parameters by reference.
3098 Parameters with INTENT(IN) could be passed by value.
3099 The problem arises if a function is called via an implicit
3100 prototype. In this situation the INTENT is not known.
3101 For this reason all parameters to global functions must be
3102 passed by reference. Passing by value would potentially
3103 generate bad code. Worse there would be no way of telling that
3104 this code was bad, except that it would give incorrect results.
3106 Contained procedures could pass by value as these are never
3107 used without an explicit interface, and cannot be passed as
3108 actual parameters for a dummy procedure. */
3110 vec_safe_push (typelist
, type
);
3114 if (sym
->attr
.subroutine
)
3115 alternate_return
= 1;
3119 /* Add hidden string length parameters. */
3120 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3123 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
3125 if (!arg
->ts
.deferred
)
3126 /* Transfer by value. */
3127 type
= gfc_charlen_type_node
;
3129 /* Deferred character lengths are transferred by reference
3130 so that the value can be returned. */
3131 type
= build_pointer_type (gfc_charlen_type_node
);
3133 vec_safe_push (typelist
, type
);
3135 /* For noncharacter scalar intrinsic types, VALUE passes the value,
3136 hence, the optional status cannot be transferred via a NULL pointer.
3137 Thus, we will use a hidden argument in that case. */
3139 && arg
->attr
.optional
3141 && !arg
->attr
.dimension
3142 && arg
->ts
.type
!= BT_CLASS
3143 && !gfc_bt_struct (arg
->ts
.type
))
3144 vec_safe_push (typelist
, boolean_type_node
);
3147 if (!vec_safe_is_empty (typelist
)
3148 || sym
->attr
.is_main_program
3149 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
3152 if (sym
->backend_decl
== error_mark_node
)
3153 sym
->backend_decl
= NULL_TREE
;
3157 if (alternate_return
)
3158 type
= integer_type_node
;
3159 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
3160 type
= void_type_node
;
3161 else if (sym
->attr
.mixed_entry_master
)
3162 type
= gfc_get_mixed_entry_union (sym
->ns
);
3163 else if (flag_f2c
&& sym
->ts
.type
== BT_REAL
3164 && sym
->ts
.kind
== gfc_default_real_kind
3165 && !sym
->attr
.always_explicit
)
3167 /* Special case: f2c calling conventions require that (scalar)
3168 default REAL functions return the C type double instead. f2c
3169 compatibility is only an issue with functions that don't
3170 require an explicit interface, as only these could be
3171 implemented in Fortran 77. */
3172 sym
->ts
.kind
= gfc_default_double_kind
;
3173 type
= gfc_typenode_for_spec (&sym
->ts
);
3174 sym
->ts
.kind
= gfc_default_real_kind
;
3176 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
3177 /* Procedure pointer return values. */
3179 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
3181 /* Unset proc_pointer as gfc_get_function_type
3182 is called recursively. */
3183 sym
->result
->attr
.proc_pointer
= 0;
3184 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
3185 sym
->result
->attr
.proc_pointer
= 1;
3188 type
= gfc_sym_type (sym
->result
);
3191 type
= gfc_sym_type (sym
);
3194 type
= build_varargs_function_type_vec (type
, typelist
);
3196 type
= build_function_type_vec (type
, typelist
);
3198 /* If we were passed an fn spec, add it here, otherwise determine it from
3199 the formal arguments. */
3203 int spec_len
= strlen (fnspec
);
3204 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, fnspec
));
3205 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (type
));
3206 type
= build_type_attribute_variant (type
, tmp
);
3209 type
= create_fn_spec (sym
, type
);
3214 /* Language hooks for middle-end access to type nodes. */
3216 /* Return an integer type with BITS bits of precision,
3217 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3220 gfc_type_for_size (unsigned bits
, int unsignedp
)
3225 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
3227 tree type
= gfc_integer_types
[i
];
3228 if (type
&& bits
== TYPE_PRECISION (type
))
3232 /* Handle TImode as a special case because it is used by some backends
3233 (e.g. ARM) even though it is not available for normal use. */
3234 #if HOST_BITS_PER_WIDE_INT >= 64
3235 if (bits
== TYPE_PRECISION (intTI_type_node
))
3236 return intTI_type_node
;
3239 if (bits
<= TYPE_PRECISION (intQI_type_node
))
3240 return intQI_type_node
;
3241 if (bits
<= TYPE_PRECISION (intHI_type_node
))
3242 return intHI_type_node
;
3243 if (bits
<= TYPE_PRECISION (intSI_type_node
))
3244 return intSI_type_node
;
3245 if (bits
<= TYPE_PRECISION (intDI_type_node
))
3246 return intDI_type_node
;
3247 if (bits
<= TYPE_PRECISION (intTI_type_node
))
3248 return intTI_type_node
;
3252 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
3253 return unsigned_intQI_type_node
;
3254 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
3255 return unsigned_intHI_type_node
;
3256 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
3257 return unsigned_intSI_type_node
;
3258 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
3259 return unsigned_intDI_type_node
;
3260 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
3261 return unsigned_intTI_type_node
;
3267 /* Return a data type that has machine mode MODE. If the mode is an
3268 integer, then UNSIGNEDP selects between signed and unsigned types. */
3271 gfc_type_for_mode (machine_mode mode
, int unsignedp
)
3275 scalar_int_mode int_mode
;
3277 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
3278 base
= gfc_real_types
;
3279 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
3280 base
= gfc_complex_types
;
3281 else if (is_a
<scalar_int_mode
> (mode
, &int_mode
))
3283 tree type
= gfc_type_for_size (GET_MODE_PRECISION (int_mode
), unsignedp
);
3284 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
3286 else if (GET_MODE_CLASS (mode
) == MODE_VECTOR_BOOL
3287 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3289 unsigned int elem_bits
= vector_element_size (GET_MODE_BITSIZE (mode
),
3290 GET_MODE_NUNITS (mode
));
3291 tree bool_type
= build_nonstandard_boolean_type (elem_bits
);
3292 return build_vector_type_for_mode (bool_type
, mode
);
3294 else if (VECTOR_MODE_P (mode
)
3295 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3297 machine_mode inner_mode
= GET_MODE_INNER (mode
);
3298 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
3299 if (inner_type
!= NULL_TREE
)
3300 return build_vector_type_for_mode (inner_type
, mode
);
3306 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
3308 tree type
= base
[i
];
3309 if (type
&& mode
== TYPE_MODE (type
))
3316 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3320 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
3323 bool indirect
= false;
3324 tree etype
, ptype
, t
, base_decl
;
3325 tree data_off
, span_off
, dim_off
, dtype_off
, dim_size
, elem_size
;
3326 tree lower_suboff
, upper_suboff
, stride_suboff
;
3327 tree dtype
, field
, rank_off
;
3329 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3331 if (! POINTER_TYPE_P (type
))
3333 type
= TREE_TYPE (type
);
3334 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3339 rank
= GFC_TYPE_ARRAY_RANK (type
);
3340 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3343 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3344 gcc_assert (POINTER_TYPE_P (etype
));
3345 etype
= TREE_TYPE (etype
);
3347 /* If the type is not a scalar coarray. */
3348 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3349 etype
= TREE_TYPE (etype
);
3351 /* Can't handle variable sized elements yet. */
3352 if (int_size_in_bytes (etype
) <= 0)
3354 /* Nor non-constant lower bounds in assumed shape arrays. */
3355 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3356 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3358 for (dim
= 0; dim
< rank
; dim
++)
3359 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3360 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3364 memset (info
, '\0', sizeof (*info
));
3365 info
->ndimensions
= rank
;
3366 info
->ordering
= array_descr_ordering_column_major
;
3367 info
->element_type
= etype
;
3368 ptype
= build_pointer_type (gfc_array_index_type
);
3369 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3372 base_decl
= make_node (DEBUG_EXPR_DECL
);
3373 DECL_ARTIFICIAL (base_decl
) = 1;
3374 TREE_TYPE (base_decl
) = indirect
? build_pointer_type (ptype
) : ptype
;
3375 SET_DECL_MODE (base_decl
, TYPE_MODE (TREE_TYPE (base_decl
)));
3376 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3378 info
->base_decl
= base_decl
;
3380 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3382 gfc_get_descriptor_offsets_for_info (type
, &data_off
, &dtype_off
, &span_off
,
3383 &dim_off
, &dim_size
, &stride_suboff
,
3384 &lower_suboff
, &upper_suboff
);
3386 t
= fold_build_pointer_plus (base_decl
, span_off
);
3387 elem_size
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3390 if (!integer_zerop (data_off
))
3391 t
= fold_build_pointer_plus (t
, data_off
);
3392 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3393 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3394 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3395 info
->allocated
= build2 (NE_EXPR
, logical_type_node
,
3396 info
->data_location
, null_pointer_node
);
3397 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3398 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3399 info
->associated
= build2 (NE_EXPR
, logical_type_node
,
3400 info
->data_location
, null_pointer_node
);
3401 if ((GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK
3402 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
)
3403 && dwarf_version
>= 5)
3406 info
->ndimensions
= 1;
3408 if (!integer_zerop (dtype_off
))
3409 t
= fold_build_pointer_plus (t
, dtype_off
);
3410 dtype
= TYPE_MAIN_VARIANT (get_dtype_type_node ());
3411 field
= gfc_advance_chain (TYPE_FIELDS (dtype
), GFC_DTYPE_RANK
);
3412 rank_off
= byte_position (field
);
3413 if (!integer_zerop (dtype_off
))
3414 t
= fold_build_pointer_plus (t
, rank_off
);
3416 t
= build1 (NOP_EXPR
, build_pointer_type (gfc_array_index_type
), t
);
3417 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3419 t
= build0 (PLACEHOLDER_EXPR
, TREE_TYPE (dim_off
));
3420 t
= size_binop (MULT_EXPR
, t
, dim_size
);
3421 dim_off
= build2 (PLUS_EXPR
, TREE_TYPE (dim_off
), t
, dim_off
);
3424 for (dim
= 0; dim
< rank
; dim
++)
3426 t
= fold_build_pointer_plus (base_decl
,
3427 size_binop (PLUS_EXPR
,
3428 dim_off
, lower_suboff
));
3429 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3430 info
->dimen
[dim
].lower_bound
= t
;
3431 t
= fold_build_pointer_plus (base_decl
,
3432 size_binop (PLUS_EXPR
,
3433 dim_off
, upper_suboff
));
3434 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3435 info
->dimen
[dim
].upper_bound
= t
;
3436 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3437 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3439 /* Assumed shape arrays have known lower bounds. */
3440 info
->dimen
[dim
].upper_bound
3441 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3442 info
->dimen
[dim
].upper_bound
,
3443 info
->dimen
[dim
].lower_bound
);
3444 info
->dimen
[dim
].lower_bound
3445 = fold_convert (gfc_array_index_type
,
3446 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3447 info
->dimen
[dim
].upper_bound
3448 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3449 info
->dimen
[dim
].lower_bound
,
3450 info
->dimen
[dim
].upper_bound
);
3452 t
= fold_build_pointer_plus (base_decl
,
3453 size_binop (PLUS_EXPR
,
3454 dim_off
, stride_suboff
));
3455 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3456 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3457 info
->dimen
[dim
].stride
= t
;
3459 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3466 /* Create a type to handle vector subscripts for coarray library calls. It
3468 struct caf_vector_t {
3469 size_t nvec; // size of the vector
3476 ptrdiff_t lower_bound;
3477 ptrdiff_t upper_bound;
3482 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3483 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3486 gfc_get_caf_vector_type (int dim
)
3488 static tree vector_types
[GFC_MAX_DIMENSIONS
];
3489 static tree vec_type
= NULL_TREE
;
3490 tree triplet_struct_type
, vect_struct_type
, union_type
, tmp
, *chain
;
3492 if (vector_types
[dim
-1] != NULL_TREE
)
3493 return vector_types
[dim
-1];
3495 if (vec_type
== NULL_TREE
)
3498 vect_struct_type
= make_node (RECORD_TYPE
);
3499 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3500 get_identifier ("vector"),
3501 pvoid_type_node
, &chain
);
3502 TREE_NO_WARNING (tmp
) = 1;
3503 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3504 get_identifier ("kind"),
3505 integer_type_node
, &chain
);
3506 TREE_NO_WARNING (tmp
) = 1;
3507 gfc_finish_type (vect_struct_type
);
3510 triplet_struct_type
= make_node (RECORD_TYPE
);
3511 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3512 get_identifier ("lower_bound"),
3513 gfc_array_index_type
, &chain
);
3514 TREE_NO_WARNING (tmp
) = 1;
3515 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3516 get_identifier ("upper_bound"),
3517 gfc_array_index_type
, &chain
);
3518 TREE_NO_WARNING (tmp
) = 1;
3519 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
, get_identifier ("stride"),
3520 gfc_array_index_type
, &chain
);
3521 TREE_NO_WARNING (tmp
) = 1;
3522 gfc_finish_type (triplet_struct_type
);
3525 union_type
= make_node (UNION_TYPE
);
3526 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3527 vect_struct_type
, &chain
);
3528 TREE_NO_WARNING (tmp
) = 1;
3529 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("triplet"),
3530 triplet_struct_type
, &chain
);
3531 TREE_NO_WARNING (tmp
) = 1;
3532 gfc_finish_type (union_type
);
3535 vec_type
= make_node (RECORD_TYPE
);
3536 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("nvec"),
3537 size_type_node
, &chain
);
3538 TREE_NO_WARNING (tmp
) = 1;
3539 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("u"),
3540 union_type
, &chain
);
3541 TREE_NO_WARNING (tmp
) = 1;
3542 gfc_finish_type (vec_type
);
3543 TYPE_NAME (vec_type
) = get_identifier ("caf_vector_t");
3546 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3547 gfc_rank_cst
[dim
-1]);
3548 vector_types
[dim
-1] = build_array_type (vec_type
, tmp
);
3549 return vector_types
[dim
-1];
3554 gfc_get_caf_reference_type ()
3556 static tree reference_type
= NULL_TREE
;
3557 tree c_struct_type
, s_struct_type
, v_struct_type
, union_type
, dim_union_type
,
3558 a_struct_type
, u_union_type
, tmp
, *chain
;
3560 if (reference_type
!= NULL_TREE
)
3561 return reference_type
;
3564 c_struct_type
= make_node (RECORD_TYPE
);
3565 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3566 get_identifier ("offset"),
3567 gfc_array_index_type
, &chain
);
3568 TREE_NO_WARNING (tmp
) = 1;
3569 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3570 get_identifier ("caf_token_offset"),
3571 gfc_array_index_type
, &chain
);
3572 TREE_NO_WARNING (tmp
) = 1;
3573 gfc_finish_type (c_struct_type
);
3576 s_struct_type
= make_node (RECORD_TYPE
);
3577 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3578 get_identifier ("start"),
3579 gfc_array_index_type
, &chain
);
3580 TREE_NO_WARNING (tmp
) = 1;
3581 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3582 get_identifier ("end"),
3583 gfc_array_index_type
, &chain
);
3584 TREE_NO_WARNING (tmp
) = 1;
3585 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3586 get_identifier ("stride"),
3587 gfc_array_index_type
, &chain
);
3588 TREE_NO_WARNING (tmp
) = 1;
3589 gfc_finish_type (s_struct_type
);
3592 v_struct_type
= make_node (RECORD_TYPE
);
3593 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3594 get_identifier ("vector"),
3595 pvoid_type_node
, &chain
);
3596 TREE_NO_WARNING (tmp
) = 1;
3597 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3598 get_identifier ("nvec"),
3599 size_type_node
, &chain
);
3600 TREE_NO_WARNING (tmp
) = 1;
3601 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3602 get_identifier ("kind"),
3603 integer_type_node
, &chain
);
3604 TREE_NO_WARNING (tmp
) = 1;
3605 gfc_finish_type (v_struct_type
);
3608 union_type
= make_node (UNION_TYPE
);
3609 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("s"),
3610 s_struct_type
, &chain
);
3611 TREE_NO_WARNING (tmp
) = 1;
3612 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3613 v_struct_type
, &chain
);
3614 TREE_NO_WARNING (tmp
) = 1;
3615 gfc_finish_type (union_type
);
3617 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3618 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1]);
3619 dim_union_type
= build_array_type (union_type
, tmp
);
3622 a_struct_type
= make_node (RECORD_TYPE
);
3623 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("mode"),
3624 build_array_type (unsigned_char_type_node
,
3625 build_range_type (gfc_array_index_type
,
3626 gfc_index_zero_node
,
3627 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1])),
3629 TREE_NO_WARNING (tmp
) = 1;
3630 tmp
= gfc_add_field_to_struct_1 (a_struct_type
,
3631 get_identifier ("static_array_type"),
3632 integer_type_node
, &chain
);
3633 TREE_NO_WARNING (tmp
) = 1;
3634 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("dim"),
3635 dim_union_type
, &chain
);
3636 TREE_NO_WARNING (tmp
) = 1;
3637 gfc_finish_type (a_struct_type
);
3640 u_union_type
= make_node (UNION_TYPE
);
3641 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("c"),
3642 c_struct_type
, &chain
);
3643 TREE_NO_WARNING (tmp
) = 1;
3644 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("a"),
3645 a_struct_type
, &chain
);
3646 TREE_NO_WARNING (tmp
) = 1;
3647 gfc_finish_type (u_union_type
);
3650 reference_type
= make_node (RECORD_TYPE
);
3651 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("next"),
3652 build_pointer_type (reference_type
), &chain
);
3653 TREE_NO_WARNING (tmp
) = 1;
3654 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("type"),
3655 integer_type_node
, &chain
);
3656 TREE_NO_WARNING (tmp
) = 1;
3657 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("item_size"),
3658 size_type_node
, &chain
);
3659 TREE_NO_WARNING (tmp
) = 1;
3660 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("u"),
3661 u_union_type
, &chain
);
3662 TREE_NO_WARNING (tmp
) = 1;
3663 gfc_finish_type (reference_type
);
3664 TYPE_NAME (reference_type
) = get_identifier ("caf_reference_t");
3666 return reference_type
;
3669 #include "gt-fortran-trans-types.h"