1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2020 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. */
43 #if (GFC_MAX_DIMENSIONS < 10)
44 #define GFC_RANK_DIGITS 1
45 #define GFC_RANK_PRINTF_FORMAT "%01d"
46 #elif (GFC_MAX_DIMENSIONS < 100)
47 #define GFC_RANK_DIGITS 2
48 #define GFC_RANK_PRINTF_FORMAT "%02d"
50 #error If you really need >99 dimensions, continue the sequence above...
53 /* array of structs so we don't have to worry about xmalloc or free */
54 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
56 tree gfc_array_index_type
;
57 tree gfc_array_range_type
;
58 tree gfc_character1_type_node
;
60 tree prvoid_type_node
;
61 tree ppvoid_type_node
;
65 tree logical_type_node
;
66 tree logical_true_node
;
67 tree logical_false_node
;
68 tree gfc_charlen_type_node
;
70 tree gfc_float128_type_node
= NULL_TREE
;
71 tree gfc_complex_float128_type_node
= NULL_TREE
;
73 bool gfc_real16_is_float128
= false;
75 static GTY(()) tree gfc_desc_dim_type
;
76 static GTY(()) tree gfc_max_array_element_size
;
77 static GTY(()) tree gfc_array_descriptor_base
[2 * (GFC_MAX_DIMENSIONS
+1)];
78 static GTY(()) tree gfc_array_descriptor_base_caf
[2 * (GFC_MAX_DIMENSIONS
+1)];
80 /* Arrays for all integral and real kinds. We'll fill this in at runtime
81 after the target has a chance to process command-line options. */
83 #define MAX_INT_KINDS 5
84 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
85 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
86 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
87 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
89 #define MAX_REAL_KINDS 5
90 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
91 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
92 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
94 #define MAX_CHARACTER_KINDS 2
95 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
96 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
97 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
99 static tree
gfc_add_field_to_struct_1 (tree
, tree
, tree
, tree
**);
101 /* The integer kind to use for array indices. This will be set to the
102 proper value based on target information from the backend. */
104 int gfc_index_integer_kind
;
106 /* The default kinds of the various types. */
108 int gfc_default_integer_kind
;
109 int gfc_max_integer_kind
;
110 int gfc_default_real_kind
;
111 int gfc_default_double_kind
;
112 int gfc_default_character_kind
;
113 int gfc_default_logical_kind
;
114 int gfc_default_complex_kind
;
116 int gfc_atomic_int_kind
;
117 int gfc_atomic_logical_kind
;
119 /* The kind size used for record offsets. If the target system supports
120 kind=8, this will be set to 8, otherwise it is set to 4. */
123 /* The integer kind used to store character lengths. */
124 int gfc_charlen_int_kind
;
126 /* Kind of internal integer for storing object sizes. */
129 /* The size of the numeric storage unit and character storage unit. */
130 int gfc_numeric_storage_size
;
131 int gfc_character_storage_size
;
133 tree dtype_type_node
= NULL_TREE
;
136 /* Build the dtype_type_node if necessary. */
137 tree
get_dtype_type_node (void)
141 tree
*dtype_chain
= NULL
;
143 if (dtype_type_node
== NULL_TREE
)
145 dtype_node
= make_node (RECORD_TYPE
);
146 TYPE_NAME (dtype_node
) = get_identifier ("dtype_type");
147 TYPE_NAMELESS (dtype_node
) = 1;
148 field
= gfc_add_field_to_struct_1 (dtype_node
,
149 get_identifier ("elem_len"),
150 size_type_node
, &dtype_chain
);
151 TREE_NO_WARNING (field
) = 1;
152 field
= gfc_add_field_to_struct_1 (dtype_node
,
153 get_identifier ("version"),
154 integer_type_node
, &dtype_chain
);
155 TREE_NO_WARNING (field
) = 1;
156 field
= gfc_add_field_to_struct_1 (dtype_node
,
157 get_identifier ("rank"),
158 signed_char_type_node
, &dtype_chain
);
159 TREE_NO_WARNING (field
) = 1;
160 field
= gfc_add_field_to_struct_1 (dtype_node
,
161 get_identifier ("type"),
162 signed_char_type_node
, &dtype_chain
);
163 TREE_NO_WARNING (field
) = 1;
164 field
= gfc_add_field_to_struct_1 (dtype_node
,
165 get_identifier ("attribute"),
166 short_integer_type_node
, &dtype_chain
);
167 TREE_NO_WARNING (field
) = 1;
168 gfc_finish_type (dtype_node
);
169 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node
)) = 1;
170 dtype_type_node
= dtype_node
;
172 return dtype_type_node
;
176 gfc_check_any_c_kind (gfc_typespec
*ts
)
180 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
182 /* Check for any C interoperable kind for the given type/kind in ts.
183 This can be used after verify_c_interop to make sure that the
184 Fortran kind being used exists in at least some form for C. */
185 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
186 c_interop_kinds_table
[i
].value
== ts
->kind
)
195 get_real_kind_from_node (tree type
)
199 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
200 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
201 return gfc_real_kinds
[i
].kind
;
207 get_int_kind_from_node (tree type
)
214 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
215 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
216 return gfc_integer_kinds
[i
].kind
;
222 get_int_kind_from_name (const char *name
)
224 return get_int_kind_from_node (get_typenode_from_name (name
));
228 /* Get the kind number corresponding to an integer of given size,
229 following the required return values for ISO_FORTRAN_ENV INT* constants:
230 -2 is returned if we support a kind of larger size, -1 otherwise. */
232 gfc_get_int_kind_from_width_isofortranenv (int size
)
236 /* Look for a kind with matching storage size. */
237 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
238 if (gfc_integer_kinds
[i
].bit_size
== size
)
239 return gfc_integer_kinds
[i
].kind
;
241 /* Look for a kind with larger storage size. */
242 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
243 if (gfc_integer_kinds
[i
].bit_size
> size
)
250 /* Get the kind number corresponding to a real of a given storage size.
251 If two real's have the same storage size, then choose the real with
252 the largest precision. If a kind type is unavailable and a real
253 exists with wider storage, then return -2; otherwise, return -1. */
256 gfc_get_real_kind_from_width_isofortranenv (int size
)
265 /* Look for a kind with matching storage size. */
266 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
267 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
269 if (gfc_real_kinds
[i
].digits
> digits
)
271 digits
= gfc_real_kinds
[i
].digits
;
272 kind
= gfc_real_kinds
[i
].kind
;
279 /* Look for a kind with larger storage size. */
280 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
281 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
290 get_int_kind_from_width (int size
)
294 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
295 if (gfc_integer_kinds
[i
].bit_size
== size
)
296 return gfc_integer_kinds
[i
].kind
;
302 get_int_kind_from_minimal_width (int size
)
306 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
307 if (gfc_integer_kinds
[i
].bit_size
>= size
)
308 return gfc_integer_kinds
[i
].kind
;
314 /* Generate the CInteropKind_t objects for the C interoperable
318 gfc_init_c_interop_kinds (void)
322 /* init all pointers in the list to NULL */
323 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
325 /* Initialize the name and value fields. */
326 c_interop_kinds_table
[i
].name
[0] = '\0';
327 c_interop_kinds_table
[i
].value
= -100;
328 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
331 #define NAMED_INTCST(a,b,c,d) \
332 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
333 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
334 c_interop_kinds_table[a].value = c;
335 #define NAMED_REALCST(a,b,c,d) \
336 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
337 c_interop_kinds_table[a].f90_type = BT_REAL; \
338 c_interop_kinds_table[a].value = c;
339 #define NAMED_CMPXCST(a,b,c,d) \
340 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
341 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
342 c_interop_kinds_table[a].value = c;
343 #define NAMED_LOGCST(a,b,c) \
344 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
345 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
346 c_interop_kinds_table[a].value = c;
347 #define NAMED_CHARKNDCST(a,b,c) \
348 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
349 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
350 c_interop_kinds_table[a].value = c;
351 #define NAMED_CHARCST(a,b,c) \
352 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
353 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
354 c_interop_kinds_table[a].value = c;
355 #define DERIVED_TYPE(a,b,c) \
356 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
357 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
358 c_interop_kinds_table[a].value = c;
359 #define NAMED_FUNCTION(a,b,c,d) \
360 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
361 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
362 c_interop_kinds_table[a].value = c;
363 #define NAMED_SUBROUTINE(a,b,c,d) \
364 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
365 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
366 c_interop_kinds_table[a].value = c;
367 #include "iso-c-binding.def"
371 /* Query the target to determine which machine modes are available for
372 computation. Choose KIND numbers for them. */
375 gfc_init_kinds (void)
377 opt_scalar_int_mode int_mode_iter
;
378 opt_scalar_float_mode float_mode_iter
;
379 int i_index
, r_index
, kind
;
380 bool saw_i4
= false, saw_i8
= false;
381 bool saw_r4
= false, saw_r8
= false, saw_r10
= false, saw_r16
= false;
384 FOR_EACH_MODE_IN_CLASS (int_mode_iter
, MODE_INT
)
386 scalar_int_mode mode
= int_mode_iter
.require ();
389 if (!targetm
.scalar_mode_supported_p (mode
))
392 /* The middle end doesn't support constants larger than 2*HWI.
393 Perhaps the target hook shouldn't have accepted these either,
394 but just to be safe... */
395 bitsize
= GET_MODE_BITSIZE (mode
);
396 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
399 gcc_assert (i_index
!= MAX_INT_KINDS
);
401 /* Let the kind equal the bit size divided by 8. This insulates the
402 programmer from the underlying byte size. */
410 gfc_integer_kinds
[i_index
].kind
= kind
;
411 gfc_integer_kinds
[i_index
].radix
= 2;
412 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
413 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
415 gfc_logical_kinds
[i_index
].kind
= kind
;
416 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
421 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
422 used for large file access. */
429 /* If we do not at least have kind = 4, everything is pointless. */
432 /* Set the maximum integer kind. Used with at least BOZ constants. */
433 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
436 FOR_EACH_MODE_IN_CLASS (float_mode_iter
, MODE_FLOAT
)
438 scalar_float_mode mode
= float_mode_iter
.require ();
439 const struct real_format
*fmt
= REAL_MODE_FORMAT (mode
);
444 if (!targetm
.scalar_mode_supported_p (mode
))
447 /* Only let float, double, long double and __float128 go through.
448 Runtime support for others is not provided, so they would be
450 if (!targetm
.libgcc_floating_mode_supported_p (mode
))
452 if (mode
!= TYPE_MODE (float_type_node
)
453 && (mode
!= TYPE_MODE (double_type_node
))
454 && (mode
!= TYPE_MODE (long_double_type_node
))
455 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
461 /* Let the kind equal the precision divided by 8, rounding up. Again,
462 this insulates the programmer from the underlying byte size.
464 Also, it effectively deals with IEEE extended formats. There, the
465 total size of the type may equal 16, but it's got 6 bytes of padding
466 and the increased size can get in the way of a real IEEE quad format
467 which may also be supported by the target.
469 We round up so as to handle IA-64 __floatreg (RFmode), which is an
470 82 bit type. Not to be confused with __float80 (XFmode), which is
471 an 80 bit type also supported by IA-64. So XFmode should come out
472 to be kind=10, and RFmode should come out to be kind=11. Egads. */
474 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
485 /* Careful we don't stumble a weird internal mode. */
486 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
487 /* Or have too many modes for the allocated space. */
488 gcc_assert (r_index
!= MAX_REAL_KINDS
);
490 gfc_real_kinds
[r_index
].kind
= kind
;
491 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
492 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
493 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
494 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
495 if (fmt
->pnan
< fmt
->p
)
496 /* This is an IBM extended double format (or the MIPS variant)
497 made up of two IEEE doubles. The value of the long double is
498 the sum of the values of the two parts. The most significant
499 part is required to be the value of the long double rounded
500 to the nearest double. If we use emax of 1024 then we can't
501 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
502 rounding will make the most significant part overflow. */
503 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
504 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
508 /* Choose the default integer kind. We choose 4 unless the user directs us
509 otherwise. Even if the user specified that the default integer kind is 8,
510 the numeric storage size is not 64 bits. In this case, a warning will be
511 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
513 gfc_numeric_storage_size
= 4 * 8;
515 if (flag_default_integer
)
518 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
519 "%<-fdefault-integer-8%> option");
521 gfc_default_integer_kind
= 8;
524 else if (flag_integer4_kind
== 8)
527 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
528 "%<-finteger-4-integer-8%> option");
530 gfc_default_integer_kind
= 8;
534 gfc_default_integer_kind
= 4;
538 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
539 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
542 /* Choose the default real kind. Again, we choose 4 when possible. */
543 if (flag_default_real_8
)
546 gfc_fatal_error ("REAL(KIND=8) is not available for "
547 "%<-fdefault-real-8%> option");
549 gfc_default_real_kind
= 8;
551 else if (flag_default_real_10
)
554 gfc_fatal_error ("REAL(KIND=10) is not available for "
555 "%<-fdefault-real-10%> option");
557 gfc_default_real_kind
= 10;
559 else if (flag_default_real_16
)
562 gfc_fatal_error ("REAL(KIND=16) is not available for "
563 "%<-fdefault-real-16%> option");
565 gfc_default_real_kind
= 16;
567 else if (flag_real4_kind
== 8)
570 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
573 gfc_default_real_kind
= 8;
575 else if (flag_real4_kind
== 10)
578 gfc_fatal_error ("REAL(KIND=10) is not available for "
579 "%<-freal-4-real-10%> option");
581 gfc_default_real_kind
= 10;
583 else if (flag_real4_kind
== 16)
586 gfc_fatal_error ("REAL(KIND=16) is not available for "
587 "%<-freal-4-real-16%> option");
589 gfc_default_real_kind
= 16;
592 gfc_default_real_kind
= 4;
594 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
596 /* Choose the default double kind. If -fdefault-real and -fdefault-double
597 are specified, we use kind=8, if it's available. If -fdefault-real is
598 specified without -fdefault-double, we use kind=16, if it's available.
599 Otherwise we do not change anything. */
600 if (flag_default_double
&& saw_r8
)
601 gfc_default_double_kind
= 8;
602 else if (flag_default_real_8
|| flag_default_real_10
|| flag_default_real_16
)
604 /* Use largest available kind. */
606 gfc_default_double_kind
= 16;
608 gfc_default_double_kind
= 10;
610 gfc_default_double_kind
= 8;
612 gfc_default_double_kind
= gfc_default_real_kind
;
614 else if (flag_real8_kind
== 4)
617 gfc_fatal_error ("REAL(KIND=4) is not available for "
618 "%<-freal-8-real-4%> option");
620 gfc_default_double_kind
= 4;
622 else if (flag_real8_kind
== 10 )
625 gfc_fatal_error ("REAL(KIND=10) is not available for "
626 "%<-freal-8-real-10%> option");
628 gfc_default_double_kind
= 10;
630 else if (flag_real8_kind
== 16 )
633 gfc_fatal_error ("REAL(KIND=10) is not available for "
634 "%<-freal-8-real-16%> option");
636 gfc_default_double_kind
= 16;
638 else if (saw_r4
&& saw_r8
)
639 gfc_default_double_kind
= 8;
642 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
643 real ... occupies two contiguous numeric storage units.
645 Therefore we must be supplied a kind twice as large as we chose
646 for single precision. There are loopholes, in that double
647 precision must *occupy* two storage units, though it doesn't have
648 to *use* two storage units. Which means that you can make this
649 kind artificially wide by padding it. But at present there are
650 no GCC targets for which a two-word type does not exist, so we
651 just let gfc_validate_kind abort and tell us if something breaks. */
653 gfc_default_double_kind
654 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
657 /* The default logical kind is constrained to be the same as the
658 default integer kind. Similarly with complex and real. */
659 gfc_default_logical_kind
= gfc_default_integer_kind
;
660 gfc_default_complex_kind
= gfc_default_real_kind
;
662 /* We only have two character kinds: ASCII and UCS-4.
663 ASCII corresponds to a 8-bit integer type, if one is available.
664 UCS-4 corresponds to a 32-bit integer type, if one is available. */
666 if ((kind
= get_int_kind_from_width (8)) > 0)
668 gfc_character_kinds
[i_index
].kind
= kind
;
669 gfc_character_kinds
[i_index
].bit_size
= 8;
670 gfc_character_kinds
[i_index
].name
= "ascii";
673 if ((kind
= get_int_kind_from_width (32)) > 0)
675 gfc_character_kinds
[i_index
].kind
= kind
;
676 gfc_character_kinds
[i_index
].bit_size
= 32;
677 gfc_character_kinds
[i_index
].name
= "iso_10646";
681 /* Choose the smallest integer kind for our default character. */
682 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
683 gfc_character_storage_size
= gfc_default_character_kind
* 8;
685 gfc_index_integer_kind
= get_int_kind_from_name (PTRDIFF_TYPE
);
687 /* Pick a kind the same size as the C "int" type. */
688 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
690 /* Choose atomic kinds to match C's int. */
691 gfc_atomic_int_kind
= gfc_c_int_kind
;
692 gfc_atomic_logical_kind
= gfc_c_int_kind
;
696 /* Make sure that a valid kind is present. Returns an index into the
697 associated kinds array, -1 if the kind is not present. */
700 validate_integer (int kind
)
704 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
705 if (gfc_integer_kinds
[i
].kind
== kind
)
712 validate_real (int kind
)
716 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
717 if (gfc_real_kinds
[i
].kind
== kind
)
724 validate_logical (int kind
)
728 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
729 if (gfc_logical_kinds
[i
].kind
== kind
)
736 validate_character (int kind
)
740 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
741 if (gfc_character_kinds
[i
].kind
== kind
)
747 /* Validate a kind given a basic type. The return value is the same
748 for the child functions, with -1 indicating nonexistence of the
749 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
752 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
758 case BT_REAL
: /* Fall through */
760 rc
= validate_real (kind
);
763 rc
= validate_integer (kind
);
766 rc
= validate_logical (kind
);
769 rc
= validate_character (kind
);
773 gfc_internal_error ("gfc_validate_kind(): Got bad type");
776 if (rc
< 0 && !may_fail
)
777 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
783 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
784 Reuse common type nodes where possible. Recognize if the kind matches up
785 with a C type. This will be used later in determining which routines may
786 be scarfed from libm. */
789 gfc_build_int_type (gfc_integer_info
*info
)
791 int mode_precision
= info
->bit_size
;
793 if (mode_precision
== CHAR_TYPE_SIZE
)
795 if (mode_precision
== SHORT_TYPE_SIZE
)
797 if (mode_precision
== INT_TYPE_SIZE
)
799 if (mode_precision
== LONG_TYPE_SIZE
)
801 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
802 info
->c_long_long
= 1;
804 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
805 return intQI_type_node
;
806 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
807 return intHI_type_node
;
808 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
809 return intSI_type_node
;
810 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
811 return intDI_type_node
;
812 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
813 return intTI_type_node
;
815 return make_signed_type (mode_precision
);
819 gfc_build_uint_type (int size
)
821 if (size
== CHAR_TYPE_SIZE
)
822 return unsigned_char_type_node
;
823 if (size
== SHORT_TYPE_SIZE
)
824 return short_unsigned_type_node
;
825 if (size
== INT_TYPE_SIZE
)
826 return unsigned_type_node
;
827 if (size
== LONG_TYPE_SIZE
)
828 return long_unsigned_type_node
;
829 if (size
== LONG_LONG_TYPE_SIZE
)
830 return long_long_unsigned_type_node
;
832 return make_unsigned_type (size
);
837 gfc_build_real_type (gfc_real_info
*info
)
839 int mode_precision
= info
->mode_precision
;
842 if (mode_precision
== FLOAT_TYPE_SIZE
)
844 if (mode_precision
== DOUBLE_TYPE_SIZE
)
846 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
847 info
->c_long_double
= 1;
848 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
850 info
->c_float128
= 1;
851 gfc_real16_is_float128
= true;
854 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
855 return float_type_node
;
856 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
857 return double_type_node
;
858 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
859 return long_double_type_node
;
861 new_type
= make_node (REAL_TYPE
);
862 TYPE_PRECISION (new_type
) = mode_precision
;
863 layout_type (new_type
);
868 gfc_build_complex_type (tree scalar_type
)
872 if (scalar_type
== NULL
)
874 if (scalar_type
== float_type_node
)
875 return complex_float_type_node
;
876 if (scalar_type
== double_type_node
)
877 return complex_double_type_node
;
878 if (scalar_type
== long_double_type_node
)
879 return complex_long_double_type_node
;
881 new_type
= make_node (COMPLEX_TYPE
);
882 TREE_TYPE (new_type
) = scalar_type
;
883 layout_type (new_type
);
888 gfc_build_logical_type (gfc_logical_info
*info
)
890 int bit_size
= info
->bit_size
;
893 if (bit_size
== BOOL_TYPE_SIZE
)
896 return boolean_type_node
;
899 new_type
= make_unsigned_type (bit_size
);
900 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
901 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
902 TYPE_PRECISION (new_type
) = 1;
908 /* Create the backend type nodes. We map them to their
909 equivalent C type, at least for now. We also give
910 names to the types here, and we push them in the
911 global binding level context.*/
914 gfc_init_types (void)
921 /* Create and name the types. */
922 #define PUSH_TYPE(name, node) \
923 pushdecl (build_decl (input_location, \
924 TYPE_DECL, get_identifier (name), node))
926 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
928 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
929 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
930 if (TYPE_STRING_FLAG (type
))
931 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
932 gfc_integer_types
[index
] = type
;
933 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
934 gfc_integer_kinds
[index
].kind
);
935 PUSH_TYPE (name_buf
, type
);
938 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
940 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
941 gfc_logical_types
[index
] = type
;
942 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
943 gfc_logical_kinds
[index
].kind
);
944 PUSH_TYPE (name_buf
, type
);
947 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
949 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
950 gfc_real_types
[index
] = type
;
951 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
952 gfc_real_kinds
[index
].kind
);
953 PUSH_TYPE (name_buf
, type
);
955 if (gfc_real_kinds
[index
].c_float128
)
956 gfc_float128_type_node
= type
;
958 type
= gfc_build_complex_type (type
);
959 gfc_complex_types
[index
] = type
;
960 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
961 gfc_real_kinds
[index
].kind
);
962 PUSH_TYPE (name_buf
, type
);
964 if (gfc_real_kinds
[index
].c_float128
)
965 gfc_complex_float128_type_node
= type
;
968 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
970 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
971 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
972 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
973 gfc_character_kinds
[index
].kind
);
974 PUSH_TYPE (name_buf
, type
);
975 gfc_character_types
[index
] = type
;
976 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
978 gfc_character1_type_node
= gfc_character_types
[0];
980 PUSH_TYPE ("byte", unsigned_char_type_node
);
981 PUSH_TYPE ("void", void_type_node
);
983 /* DBX debugging output gets upset if these aren't set. */
984 if (!TYPE_NAME (integer_type_node
))
985 PUSH_TYPE ("c_integer", integer_type_node
);
986 if (!TYPE_NAME (char_type_node
))
987 PUSH_TYPE ("c_char", char_type_node
);
991 pvoid_type_node
= build_pointer_type (void_type_node
);
992 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
993 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
994 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
996 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
998 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
999 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
1000 since this function is called before gfc_init_constants. */
1001 gfc_array_range_type
1002 = build_range_type (gfc_array_index_type
,
1003 build_int_cst (gfc_array_index_type
, 0),
1006 /* The maximum array element size that can be handled is determined
1007 by the number of bits available to store this field in the array
1010 n
= TYPE_PRECISION (size_type_node
);
1011 gfc_max_array_element_size
1012 = wide_int_to_tree (size_type_node
,
1013 wi::mask (n
, UNSIGNED
,
1014 TYPE_PRECISION (size_type_node
)));
1016 logical_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
1017 logical_true_node
= build_int_cst (logical_type_node
, 1);
1018 logical_false_node
= build_int_cst (logical_type_node
, 0);
1020 /* Character lengths are of type size_t, except signed. */
1021 gfc_charlen_int_kind
= get_int_kind_from_node (size_type_node
);
1022 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
1024 /* Fortran kind number of size_type_node (size_t). This is used for
1025 the _size member in vtables. */
1026 gfc_size_kind
= get_int_kind_from_node (size_type_node
);
1029 /* Get the type node for the given type and kind. */
1032 gfc_get_int_type (int kind
)
1034 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
1035 return index
< 0 ? 0 : gfc_integer_types
[index
];
1039 gfc_get_real_type (int kind
)
1041 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
1042 return index
< 0 ? 0 : gfc_real_types
[index
];
1046 gfc_get_complex_type (int kind
)
1048 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
1049 return index
< 0 ? 0 : gfc_complex_types
[index
];
1053 gfc_get_logical_type (int kind
)
1055 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
1056 return index
< 0 ? 0 : gfc_logical_types
[index
];
1060 gfc_get_char_type (int kind
)
1062 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1063 return index
< 0 ? 0 : gfc_character_types
[index
];
1067 gfc_get_pchar_type (int kind
)
1069 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1070 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
1074 /* Create a character type with the given kind and length. */
1077 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
1081 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
1082 type
= build_array_type (eltype
, bounds
);
1083 TYPE_STRING_FLAG (type
) = 1;
1089 gfc_get_character_type_len (int kind
, tree len
)
1091 gfc_validate_kind (BT_CHARACTER
, kind
, false);
1092 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
1096 /* Get a type node for a character kind. */
1099 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
1103 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1104 if (len
&& POINTER_TYPE_P (TREE_TYPE (len
)))
1105 len
= build_fold_indirect_ref (len
);
1107 return gfc_get_character_type_len (kind
, len
);
1110 /* Convert a basic type. This will be an array for character types. */
1113 gfc_typenode_for_spec (gfc_typespec
* spec
, int codim
)
1123 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1124 has been resolved. This is done so we can convert C_PTR and
1125 C_FUNPTR to simple variables that get translated to (void *). */
1126 if (spec
->f90_type
== BT_VOID
)
1129 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1130 basetype
= ptr_type_node
;
1132 basetype
= pfunc_type_node
;
1135 basetype
= gfc_get_int_type (spec
->kind
);
1139 basetype
= gfc_get_real_type (spec
->kind
);
1143 basetype
= gfc_get_complex_type (spec
->kind
);
1147 basetype
= gfc_get_logical_type (spec
->kind
);
1151 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1155 /* Since this cannot be used, return a length one character. */
1156 basetype
= gfc_get_character_type_len (gfc_default_character_kind
,
1157 gfc_index_one_node
);
1161 basetype
= gfc_get_union_type (spec
->u
.derived
);
1166 basetype
= gfc_get_derived_type (spec
->u
.derived
, codim
);
1168 if (spec
->type
== BT_CLASS
)
1169 GFC_CLASS_TYPE_P (basetype
) = 1;
1171 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1172 type and kind to fit a (void *) and the basetype returned was a
1173 ptr_type_node. We need to pass up this new information to the
1174 symbol that was declared of type C_PTR or C_FUNPTR. */
1175 if (spec
->u
.derived
->ts
.f90_type
== BT_VOID
)
1177 spec
->type
= BT_INTEGER
;
1178 spec
->kind
= gfc_index_integer_kind
;
1179 spec
->f90_type
= BT_VOID
;
1180 spec
->is_c_interop
= 1; /* Mark as escaping later. */
1185 /* This is for the second arg to c_f_pointer and c_f_procpointer
1186 of the iso_c_binding module, to accept any ptr type. */
1187 basetype
= ptr_type_node
;
1188 if (spec
->f90_type
== BT_VOID
)
1191 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1192 basetype
= ptr_type_node
;
1194 basetype
= pfunc_type_node
;
1198 basetype
= pfunc_type_node
;
1206 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1209 gfc_conv_array_bound (gfc_expr
* expr
)
1211 /* If expr is an integer constant, return that. */
1212 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1213 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1215 /* Otherwise return NULL. */
1219 /* Return the type of an element of the array. Note that scalar coarrays
1220 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1221 (with POINTER_TYPE stripped) is returned. */
1224 gfc_get_element_type (tree type
)
1228 if (GFC_ARRAY_TYPE_P (type
))
1230 if (TREE_CODE (type
) == POINTER_TYPE
)
1231 type
= TREE_TYPE (type
);
1232 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1234 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1239 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1240 element
= TREE_TYPE (type
);
1245 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1246 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1248 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1249 element
= TREE_TYPE (element
);
1251 /* For arrays, which are not scalar coarrays. */
1252 if (TREE_CODE (element
) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (element
))
1253 element
= TREE_TYPE (element
);
1259 /* Build an array. This function is called from gfc_sym_type().
1260 Actually returns array descriptor type.
1262 Format of array descriptors is as follows:
1264 struct gfc_array_descriptor
1268 struct dtype_type dtype;
1269 struct descriptor_dimension dimension[N_DIM];
1278 signed short attribute;
1281 struct descriptor_dimension
1288 Translation code should use gfc_conv_descriptor_* rather than
1289 accessing the descriptor directly. Any changes to the array
1290 descriptor type will require changes in gfc_conv_descriptor_* and
1291 gfc_build_array_initializer.
1293 This is represented internally as a RECORD_TYPE. The index nodes
1294 are gfc_array_index_type and the data node is a pointer to the
1295 data. See below for the handling of character types.
1297 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1298 this generated poor code for assumed/deferred size arrays. These
1299 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1300 of the GENERIC grammar. Also, there is no way to explicitly set
1301 the array stride, so all data must be packed(1). I've tried to
1302 mark all the functions which would require modification with a GCC
1305 The data component points to the first element in the array. The
1306 offset field is the position of the origin of the array (i.e. element
1307 (0, 0 ...)). This may be outside the bounds of the array.
1309 An element is accessed by
1310 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1311 This gives good performance as the computation does not involve the
1312 bounds of the array. For packed arrays, this is optimized further
1313 by substituting the known strides.
1315 This system has one problem: all array bounds must be within 2^31
1316 elements of the origin (2^63 on 64-bit machines). For example
1317 integer, dimension (80000:90000, 80000:90000, 2) :: array
1318 may not work properly on 32-bit machines because 80000*80000 >
1319 2^31, so the calculation for stride2 would overflow. This may
1320 still work, but I haven't checked, and it relies on the overflow
1321 doing the right thing.
1323 The way to fix this problem is to access elements as follows:
1324 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1325 Obviously this is much slower. I will make this a compile time
1326 option, something like -fsmall-array-offsets. Mixing code compiled
1327 with and without this switch will work.
1329 (1) This can be worked around by modifying the upper bound of the
1330 previous dimension. This requires extra fields in the descriptor
1331 (both real_ubound and fake_ubound). */
1334 /* Returns true if the array sym does not require a descriptor. */
1337 gfc_is_nodesc_array (gfc_symbol
* sym
)
1339 symbol_attribute
*array_attr
;
1341 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1343 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1344 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1346 gcc_assert (array_attr
->dimension
|| array_attr
->codimension
);
1348 /* We only want local arrays. */
1349 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1350 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1351 || array_attr
->allocatable
)
1354 /* We want a descriptor for associate-name arrays that do not have an
1355 explicitly known shape already. */
1356 if (sym
->assoc
&& as
->type
!= AS_EXPLICIT
)
1359 /* The dummy is stored in sym and not in the component. */
1360 if (sym
->attr
.dummy
)
1361 return as
->type
!= AS_ASSUMED_SHAPE
1362 && as
->type
!= AS_ASSUMED_RANK
;
1364 if (sym
->attr
.result
|| sym
->attr
.function
)
1367 gcc_assert (as
->type
== AS_EXPLICIT
|| as
->cp_was_assumed
);
1373 /* Create an array descriptor type. */
1376 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1377 enum gfc_array_kind akind
, bool restricted
,
1378 bool contiguous
, int codim
)
1380 tree lbound
[GFC_MAX_DIMENSIONS
];
1381 tree ubound
[GFC_MAX_DIMENSIONS
];
1384 /* Assumed-shape arrays do not have codimension information stored in the
1386 corank
= MAX (as
->corank
, codim
);
1387 if (as
->type
== AS_ASSUMED_SHAPE
||
1388 (as
->type
== AS_ASSUMED_RANK
&& akind
== GFC_ARRAY_ALLOCATABLE
))
1391 if (as
->type
== AS_ASSUMED_RANK
)
1392 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1394 lbound
[n
] = NULL_TREE
;
1395 ubound
[n
] = NULL_TREE
;
1398 for (n
= 0; n
< as
->rank
; n
++)
1400 /* Create expressions for the known bounds of the array. */
1401 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1402 lbound
[n
] = gfc_index_one_node
;
1404 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1405 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1408 for (n
= as
->rank
; n
< as
->rank
+ corank
; n
++)
1410 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1411 lbound
[n
] = gfc_index_one_node
;
1413 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1415 if (n
< as
->rank
+ corank
- 1)
1416 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1419 if (as
->type
== AS_ASSUMED_SHAPE
)
1420 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1421 : GFC_ARRAY_ASSUMED_SHAPE
;
1422 else if (as
->type
== AS_ASSUMED_RANK
)
1423 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1424 : GFC_ARRAY_ASSUMED_RANK
;
1425 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1426 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1427 corank
, lbound
, ubound
, 0, akind
,
1431 /* Returns the struct descriptor_dimension type. */
1434 gfc_get_desc_dim_type (void)
1437 tree decl
, *chain
= NULL
;
1439 if (gfc_desc_dim_type
)
1440 return gfc_desc_dim_type
;
1442 /* Build the type node. */
1443 type
= make_node (RECORD_TYPE
);
1445 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1446 TYPE_PACKED (type
) = 1;
1448 /* Consists of the stride, lbound and ubound members. */
1449 decl
= gfc_add_field_to_struct_1 (type
,
1450 get_identifier ("stride"),
1451 gfc_array_index_type
, &chain
);
1452 TREE_NO_WARNING (decl
) = 1;
1454 decl
= gfc_add_field_to_struct_1 (type
,
1455 get_identifier ("lbound"),
1456 gfc_array_index_type
, &chain
);
1457 TREE_NO_WARNING (decl
) = 1;
1459 decl
= gfc_add_field_to_struct_1 (type
,
1460 get_identifier ("ubound"),
1461 gfc_array_index_type
, &chain
);
1462 TREE_NO_WARNING (decl
) = 1;
1464 /* Finish off the type. */
1465 gfc_finish_type (type
);
1466 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1468 gfc_desc_dim_type
= type
;
1473 /* Return the DTYPE for an array. This describes the type and type parameters
1475 /* TODO: Only call this when the value is actually used, and make all the
1476 unknown cases abort. */
1479 gfc_get_dtype_rank_type (int rank
, tree etype
)
1486 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1488 size
= TYPE_SIZE_UNIT (etype
);
1490 switch (TREE_CODE (etype
))
1509 if (GFC_CLASS_TYPE_P (etype
))
1515 /* We will never have arrays of arrays. */
1518 if (size
== NULL_TREE
)
1519 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1524 if (TREE_CODE (TREE_TYPE (etype
)) != VOID_TYPE
)
1525 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1527 size
= build_int_cst (size_type_node
, 0);
1531 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1532 /* We can encounter strange array types for temporary arrays. */
1533 return gfc_index_zero_node
;
1536 tmp
= get_dtype_type_node ();
1537 field
= gfc_advance_chain (TYPE_FIELDS (tmp
),
1538 GFC_DTYPE_ELEM_LEN
);
1539 CONSTRUCTOR_APPEND_ELT (v
, field
,
1540 fold_convert (TREE_TYPE (field
), size
));
1542 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1544 CONSTRUCTOR_APPEND_ELT (v
, field
,
1545 build_int_cst (TREE_TYPE (field
), rank
));
1547 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1549 CONSTRUCTOR_APPEND_ELT (v
, field
,
1550 build_int_cst (TREE_TYPE (field
), n
));
1552 dtype
= build_constructor (tmp
, v
);
1559 gfc_get_dtype (tree type
)
1565 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1567 rank
= GFC_TYPE_ARRAY_RANK (type
);
1568 etype
= gfc_get_element_type (type
);
1569 dtype
= gfc_get_dtype_rank_type (rank
, etype
);
1571 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1576 /* Build an array type for use without a descriptor, packed according
1577 to the value of PACKED. */
1580 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1594 mpz_init_set_ui (offset
, 0);
1595 mpz_init_set_ui (stride
, 1);
1598 /* We don't use build_array_type because this does not include
1599 lang-specific information (i.e. the bounds of the array) when checking
1602 type
= make_node (ARRAY_TYPE
);
1604 type
= build_variant_type_copy (etype
);
1606 GFC_ARRAY_TYPE_P (type
) = 1;
1607 TYPE_LANG_SPECIFIC (type
) = ggc_cleared_alloc
<struct lang_type
> ();
1609 known_stride
= (packed
!= PACKED_NO
);
1611 for (n
= 0; n
< as
->rank
; n
++)
1613 /* Fill in the stride and bound components of the type. */
1615 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1618 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1620 expr
= as
->lower
[n
];
1621 if (expr
->expr_type
== EXPR_CONSTANT
)
1623 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1624 gfc_index_integer_kind
);
1631 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1635 /* Calculate the offset. */
1636 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1637 mpz_sub (offset
, offset
, delta
);
1642 expr
= as
->upper
[n
];
1643 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1645 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1646 gfc_index_integer_kind
);
1653 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1657 /* Calculate the stride. */
1658 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1659 as
->lower
[n
]->value
.integer
);
1660 mpz_add_ui (delta
, delta
, 1);
1661 mpz_mul (stride
, stride
, delta
);
1664 /* Only the first stride is known for partial packed arrays. */
1665 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1668 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1670 expr
= as
->lower
[n
];
1671 if (expr
->expr_type
== EXPR_CONSTANT
)
1672 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1673 gfc_index_integer_kind
);
1676 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1678 expr
= as
->upper
[n
];
1679 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1680 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1681 gfc_index_integer_kind
);
1684 if (n
< as
->rank
+ as
->corank
- 1)
1685 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1690 GFC_TYPE_ARRAY_OFFSET (type
) =
1691 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1694 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1698 GFC_TYPE_ARRAY_SIZE (type
) =
1699 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1702 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1704 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1705 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1706 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1707 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1709 /* TODO: use main type if it is unbounded. */
1710 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1711 build_pointer_type (build_array_type (etype
, range
));
1713 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1714 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1715 TYPE_QUAL_RESTRICT
);
1719 if (packed
!= PACKED_STATIC
|| flag_coarray
== GFC_FCOARRAY_LIB
)
1721 type
= build_pointer_type (type
);
1724 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1726 GFC_ARRAY_TYPE_P (type
) = 1;
1727 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1735 mpz_sub_ui (stride
, stride
, 1);
1736 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1741 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1742 TYPE_DOMAIN (type
) = range
;
1744 build_pointer_type (etype
);
1745 TREE_TYPE (type
) = etype
;
1753 /* Represent packed arrays as multi-dimensional if they have rank >
1754 1 and with proper bounds, instead of flat arrays. This makes for
1755 better debug info. */
1758 tree gtype
= etype
, rtype
, type_decl
;
1760 for (n
= as
->rank
- 1; n
>= 0; n
--)
1762 rtype
= build_range_type (gfc_array_index_type
,
1763 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1764 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1765 gtype
= build_array_type (gtype
, rtype
);
1767 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1768 TYPE_DECL
, NULL
, gtype
);
1769 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1772 if (packed
!= PACKED_STATIC
|| !known_stride
1773 || (as
->corank
&& flag_coarray
== GFC_FCOARRAY_LIB
))
1775 /* For dummy arrays and automatic (heap allocated) arrays we
1776 want a pointer to the array. */
1777 type
= build_pointer_type (type
);
1779 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1780 GFC_ARRAY_TYPE_P (type
) = 1;
1781 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1787 /* Return or create the base type for an array descriptor. */
1790 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1792 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1793 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1796 /* Assumed-rank array. */
1798 dimen
= GFC_MAX_DIMENSIONS
;
1800 idx
= 2 * (codimen
+ dimen
) + restricted
;
1802 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1804 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1806 if (gfc_array_descriptor_base_caf
[idx
])
1807 return gfc_array_descriptor_base_caf
[idx
];
1809 else if (gfc_array_descriptor_base
[idx
])
1810 return gfc_array_descriptor_base
[idx
];
1812 /* Build the type node. */
1813 fat_type
= make_node (RECORD_TYPE
);
1815 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1816 TYPE_NAME (fat_type
) = get_identifier (name
);
1817 TYPE_NAMELESS (fat_type
) = 1;
1819 /* Add the data member as the first element of the descriptor. */
1820 gfc_add_field_to_struct_1 (fat_type
,
1821 get_identifier ("data"),
1824 : ptr_type_node
), &chain
);
1826 /* Add the base component. */
1827 decl
= gfc_add_field_to_struct_1 (fat_type
,
1828 get_identifier ("offset"),
1829 gfc_array_index_type
, &chain
);
1830 TREE_NO_WARNING (decl
) = 1;
1832 /* Add the dtype component. */
1833 decl
= gfc_add_field_to_struct_1 (fat_type
,
1834 get_identifier ("dtype"),
1835 get_dtype_type_node (), &chain
);
1836 TREE_NO_WARNING (decl
) = 1;
1838 /* Add the span component. */
1839 decl
= gfc_add_field_to_struct_1 (fat_type
,
1840 get_identifier ("span"),
1841 gfc_array_index_type
, &chain
);
1842 TREE_NO_WARNING (decl
) = 1;
1844 /* Build the array type for the stride and bound components. */
1845 if (dimen
+ codimen
> 0)
1848 build_array_type (gfc_get_desc_dim_type (),
1849 build_range_type (gfc_array_index_type
,
1850 gfc_index_zero_node
,
1851 gfc_rank_cst
[codimen
+ dimen
- 1]));
1853 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1855 TREE_NO_WARNING (decl
) = 1;
1858 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1860 decl
= gfc_add_field_to_struct_1 (fat_type
,
1861 get_identifier ("token"),
1862 prvoid_type_node
, &chain
);
1863 TREE_NO_WARNING (decl
) = 1;
1866 /* Finish off the type. */
1867 gfc_finish_type (fat_type
);
1868 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1870 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1871 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1873 gfc_array_descriptor_base
[idx
] = fat_type
;
1879 /* Build an array (descriptor) type with given bounds. */
1882 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1883 tree
* ubound
, int packed
,
1884 enum gfc_array_kind akind
, bool restricted
)
1886 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1887 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1888 const char *type_name
;
1891 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1892 fat_type
= build_distinct_type_copy (base_type
);
1893 /* Unshare TYPE_FIELDs. */
1894 for (tree
*tp
= &TYPE_FIELDS (fat_type
); *tp
; tp
= &DECL_CHAIN (*tp
))
1896 tree next
= DECL_CHAIN (*tp
);
1897 *tp
= copy_node (*tp
);
1898 DECL_CONTEXT (*tp
) = fat_type
;
1899 DECL_CHAIN (*tp
) = next
;
1901 /* Make sure that nontarget and target array type have the same canonical
1902 type (and same stub decl for debug info). */
1903 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1904 TYPE_CANONICAL (fat_type
) = base_type
;
1905 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1907 tmp
= TYPE_NAME (etype
);
1908 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1909 tmp
= DECL_NAME (tmp
);
1911 type_name
= IDENTIFIER_POINTER (tmp
);
1913 type_name
= "unknown";
1914 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1915 GFC_MAX_SYMBOL_LEN
, type_name
);
1916 TYPE_NAME (fat_type
) = get_identifier (name
);
1917 TYPE_NAMELESS (fat_type
) = 1;
1919 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1920 TYPE_LANG_SPECIFIC (fat_type
) = ggc_cleared_alloc
<struct lang_type
> ();
1922 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1923 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1924 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1925 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1927 /* Build an array descriptor record type. */
1929 stride
= gfc_index_one_node
;
1932 for (n
= 0; n
< dimen
+ codimen
; n
++)
1935 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1942 if (lower
!= NULL_TREE
)
1944 if (INTEGER_CST_P (lower
))
1945 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1950 if (codimen
&& n
== dimen
+ codimen
- 1)
1954 if (upper
!= NULL_TREE
)
1956 if (INTEGER_CST_P (upper
))
1957 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1965 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1967 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1968 gfc_array_index_type
, upper
, lower
);
1969 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1970 gfc_array_index_type
, tmp
,
1971 gfc_index_one_node
);
1972 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1973 gfc_array_index_type
, tmp
, stride
);
1974 /* Check the folding worked. */
1975 gcc_assert (INTEGER_CST_P (stride
));
1980 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1982 /* TODO: known offsets for descriptors. */
1983 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1987 arraytype
= build_pointer_type (etype
);
1989 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1991 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1995 /* We define data as an array with the correct size if possible.
1996 Much better than doing pointer arithmetic. */
1998 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1999 int_const_binop (MINUS_EXPR
, stride
,
2000 build_int_cst (TREE_TYPE (stride
), 1)));
2002 rtype
= gfc_array_range_type
;
2003 arraytype
= build_array_type (etype
, rtype
);
2004 arraytype
= build_pointer_type (arraytype
);
2006 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
2007 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
2009 /* This will generate the base declarations we need to emit debug
2010 information for this type. FIXME: there must be a better way to
2011 avoid divergence between compilations with and without debug
2014 struct array_descr_info info
;
2015 gfc_get_array_descr_info (fat_type
, &info
);
2016 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
2022 /* Build a pointer type. This function is called from gfc_sym_type(). */
2025 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
2027 /* Array pointer types aren't actually pointers. */
2028 if (sym
->attr
.dimension
)
2031 return build_pointer_type (type
);
2034 static tree
gfc_nonrestricted_type (tree t
);
2035 /* Given two record or union type nodes TO and FROM, ensure
2036 that all fields in FROM have a corresponding field in TO,
2037 their type being nonrestrict variants. This accepts a TO
2038 node that already has a prefix of the fields in FROM. */
2040 mirror_fields (tree to
, tree from
)
2045 /* Forward to the end of TOs fields. */
2046 fto
= TYPE_FIELDS (to
);
2047 ffrom
= TYPE_FIELDS (from
);
2048 chain
= &TYPE_FIELDS (to
);
2051 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
2052 chain
= &DECL_CHAIN (fto
);
2053 fto
= DECL_CHAIN (fto
);
2054 ffrom
= DECL_CHAIN (ffrom
);
2057 /* Now add all fields remaining in FROM (starting with ffrom). */
2058 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
2060 tree newfield
= copy_node (ffrom
);
2061 DECL_CONTEXT (newfield
) = to
;
2062 /* The store to DECL_CHAIN might seem redundant with the
2063 stores to *chain, but not clearing it here would mean
2064 leaving a chain into the old fields. If ever
2065 our called functions would look at them confusion
2067 DECL_CHAIN (newfield
) = NULL_TREE
;
2069 chain
= &DECL_CHAIN (newfield
);
2071 if (TREE_CODE (ffrom
) == FIELD_DECL
)
2073 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
2074 TREE_TYPE (newfield
) = elemtype
;
2080 /* Given a type T, returns a different type of the same structure,
2081 except that all types it refers to (recursively) are always
2082 non-restrict qualified types. */
2084 gfc_nonrestricted_type (tree t
)
2088 /* If the type isn't laid out yet, don't copy it. If something
2089 needs it for real it should wait until the type got finished. */
2093 if (!TYPE_LANG_SPECIFIC (t
))
2094 TYPE_LANG_SPECIFIC (t
) = ggc_cleared_alloc
<struct lang_type
> ();
2095 /* If we're dealing with this very node already further up
2096 the call chain (recursion via pointers and struct members)
2097 we haven't yet determined if we really need a new type node.
2098 Assume we don't, return T itself. */
2099 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
2102 /* If we have calculated this all already, just return it. */
2103 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
2104 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
2106 /* Mark this type. */
2107 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2109 switch (TREE_CODE (t
))
2115 case REFERENCE_TYPE
:
2117 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2118 if (totype
== TREE_TYPE (t
))
2120 else if (TREE_CODE (t
) == POINTER_TYPE
)
2121 ret
= build_pointer_type (totype
);
2123 ret
= build_reference_type (totype
);
2124 ret
= build_qualified_type (ret
,
2125 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2131 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2132 if (elemtype
== TREE_TYPE (t
))
2136 ret
= build_variant_type_copy (t
);
2137 TREE_TYPE (ret
) = elemtype
;
2138 if (TYPE_LANG_SPECIFIC (t
)
2139 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2141 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2142 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2143 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2145 TYPE_LANG_SPECIFIC (ret
)
2146 = ggc_cleared_alloc
<struct lang_type
> ();
2147 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2148 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2157 case QUAL_UNION_TYPE
:
2160 /* First determine if we need a new type at all.
2161 Careful, the two calls to gfc_nonrestricted_type per field
2162 might return different values. That happens exactly when
2163 one of the fields reaches back to this very record type
2164 (via pointers). The first calls will assume that we don't
2165 need to copy T (see the error_mark_node marking). If there
2166 are any reasons for copying T apart from having to copy T,
2167 we'll indeed copy it, and the second calls to
2168 gfc_nonrestricted_type will use that new node if they
2170 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2171 if (TREE_CODE (field
) == FIELD_DECL
)
2173 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2174 if (elemtype
!= TREE_TYPE (field
))
2179 ret
= build_variant_type_copy (t
);
2180 TYPE_FIELDS (ret
) = NULL_TREE
;
2182 /* Here we make sure that as soon as we know we have to copy
2183 T, that also fields reaching back to us will use the new
2184 copy. It's okay if that copy still contains the old fields,
2185 we won't look at them. */
2186 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2187 mirror_fields (ret
, t
);
2192 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2197 /* Return the type for a symbol. Special handling is required for character
2198 types to get the correct level of indirection.
2199 For functions return the return type.
2200 For subroutines return void_type_node.
2201 Calling this multiple times for the same symbol should be avoided,
2202 especially for character and array types. */
2205 gfc_sym_type (gfc_symbol
* sym
)
2211 /* Procedure Pointers inside COMMON blocks. */
2212 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2214 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2215 sym
->attr
.proc_pointer
= 0;
2216 type
= build_pointer_type (gfc_get_function_type (sym
));
2217 sym
->attr
.proc_pointer
= 1;
2221 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2222 return void_type_node
;
2224 /* In the case of a function the fake result variable may have a
2225 type different from the function type, so don't return early in
2227 if (sym
->backend_decl
&& !sym
->attr
.function
)
2228 return TREE_TYPE (sym
->backend_decl
);
2230 if (sym
->attr
.result
2231 && sym
->ts
.type
== BT_CHARACTER
2232 && sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
2233 && sym
->ns
->proc_name
2234 && sym
->ns
->proc_name
->ts
.u
.cl
2235 && sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
!= NULL_TREE
)
2236 sym
->ts
.u
.cl
->backend_decl
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2238 if (sym
->ts
.type
== BT_CHARACTER
2239 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2240 || (sym
->attr
.result
2241 && sym
->ns
->proc_name
2242 && sym
->ns
->proc_name
->attr
.is_bind_c
)
2243 || (sym
->ts
.deferred
&& (!sym
->ts
.u
.cl
2244 || !sym
->ts
.u
.cl
->backend_decl
))))
2245 type
= gfc_character1_type_node
;
2247 type
= gfc_typenode_for_spec (&sym
->ts
, sym
->attr
.codimension
);
2249 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2254 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2255 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2257 type
= gfc_nonrestricted_type (type
);
2259 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2261 if (gfc_is_nodesc_array (sym
))
2263 /* If this is a character argument of unknown length, just use the
2265 if (sym
->ts
.type
!= BT_CHARACTER
2266 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2267 || sym
->ts
.u
.cl
->backend_decl
)
2269 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2278 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2279 if (sym
->attr
.pointer
)
2280 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2281 : GFC_ARRAY_POINTER
;
2282 else if (sym
->attr
.allocatable
)
2283 akind
= GFC_ARRAY_ALLOCATABLE
;
2284 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2285 sym
->attr
.contiguous
, false);
2290 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2291 || gfc_is_associate_pointer (sym
))
2292 type
= gfc_build_pointer_type (sym
, type
);
2295 /* We currently pass all parameters by reference.
2296 See f95_get_function_decl. For dummy function parameters return the
2300 /* We must use pointer types for potentially absent variables. The
2301 optimizers assume a reference type argument is never NULL. */
2302 if (sym
->attr
.optional
2303 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2304 type
= build_pointer_type (type
);
2307 type
= build_reference_type (type
);
2309 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2316 /* Layout and output debug info for a record type. */
2319 gfc_finish_type (tree type
)
2323 decl
= build_decl (input_location
,
2324 TYPE_DECL
, NULL_TREE
, type
);
2325 TYPE_STUB_DECL (type
) = decl
;
2327 rest_of_type_compilation (type
, 1);
2328 rest_of_decl_compilation (decl
, 1, 0);
2331 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2332 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2333 to the end of the field list pointed to by *CHAIN.
2335 Returns a pointer to the new field. */
2338 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2340 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2342 DECL_CONTEXT (decl
) = context
;
2343 DECL_CHAIN (decl
) = NULL_TREE
;
2344 if (TYPE_FIELDS (context
) == NULL_TREE
)
2345 TYPE_FIELDS (context
) = decl
;
2350 *chain
= &DECL_CHAIN (decl
);
2356 /* Like `gfc_add_field_to_struct_1', but adds alignment
2360 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2362 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2364 DECL_INITIAL (decl
) = 0;
2365 SET_DECL_ALIGN (decl
, 0);
2366 DECL_USER_ALIGN (decl
) = 0;
2372 /* Copy the backend_decl and component backend_decls if
2373 the two derived type symbols are "equal", as described
2374 in 4.4.2 and resolved by gfc_compare_derived_types. */
2377 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2380 gfc_component
*to_cm
;
2381 gfc_component
*from_cm
;
2386 if (from
->backend_decl
== NULL
2387 || !gfc_compare_derived_types (from
, to
))
2390 to
->backend_decl
= from
->backend_decl
;
2392 to_cm
= to
->components
;
2393 from_cm
= from
->components
;
2395 /* Copy the component declarations. If a component is itself
2396 a derived type, we need a copy of its component declarations.
2397 This is done by recursing into gfc_get_derived_type and
2398 ensures that the component's component declarations have
2399 been built. If it is a character, we need the character
2401 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2403 to_cm
->backend_decl
= from_cm
->backend_decl
;
2404 to_cm
->caf_token
= from_cm
->caf_token
;
2405 if (from_cm
->ts
.type
== BT_UNION
)
2406 gfc_get_union_type (to_cm
->ts
.u
.derived
);
2407 else if (from_cm
->ts
.type
== BT_DERIVED
2408 && (!from_cm
->attr
.pointer
|| from_gsym
))
2409 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2410 else if (from_cm
->ts
.type
== BT_CLASS
2411 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2412 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2413 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2414 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2421 /* Build a tree node for a procedure pointer component. */
2424 gfc_get_ppc_type (gfc_component
* c
)
2428 /* Explicit interface. */
2429 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2430 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2432 /* Implicit interface (only return value may be known). */
2433 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2434 t
= gfc_typenode_for_spec (&c
->ts
);
2438 /* FIXME: it would be better to provide explicit interfaces in all
2439 cases, since they should be known by the compiler. */
2440 return build_pointer_type (build_function_type (t
, NULL_TREE
));
2444 /* Build a tree node for a union type. Requires building each map
2445 structure which is an element of the union. */
2448 gfc_get_union_type (gfc_symbol
*un
)
2450 gfc_component
*map
= NULL
;
2451 tree typenode
= NULL
, map_type
= NULL
, map_field
= NULL
;
2454 if (un
->backend_decl
)
2456 if (TYPE_FIELDS (un
->backend_decl
) || un
->attr
.proc_pointer_comp
)
2457 return un
->backend_decl
;
2459 typenode
= un
->backend_decl
;
2463 typenode
= make_node (UNION_TYPE
);
2464 TYPE_NAME (typenode
) = get_identifier (un
->name
);
2467 /* Add each contained MAP as a field. */
2468 for (map
= un
->components
; map
; map
= map
->next
)
2470 gcc_assert (map
->ts
.type
== BT_DERIVED
);
2472 /* The map's type node, which is defined within this union's context. */
2473 map_type
= gfc_get_derived_type (map
->ts
.u
.derived
);
2474 TYPE_CONTEXT (map_type
) = typenode
;
2476 /* The map field's declaration. */
2477 map_field
= gfc_add_field_to_struct(typenode
, get_identifier(map
->name
),
2480 gfc_set_decl_location (map_field
, &map
->loc
);
2481 else if (un
->declared_at
.lb
)
2482 gfc_set_decl_location (map_field
, &un
->declared_at
);
2484 DECL_PACKED (map_field
) |= TYPE_PACKED (typenode
);
2485 DECL_NAMELESS(map_field
) = true;
2487 /* We should never clobber another backend declaration for this map,
2488 because each map component is unique. */
2489 if (!map
->backend_decl
)
2490 map
->backend_decl
= map_field
;
2493 un
->backend_decl
= typenode
;
2494 gfc_finish_type (typenode
);
2500 /* Build a tree node for a derived type. If there are equal
2501 derived types, with different local names, these are built
2502 at the same time. If an equal derived type has been built
2503 in a parent namespace, this is used. */
2506 gfc_get_derived_type (gfc_symbol
* derived
, int codimen
)
2508 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2509 tree canonical
= NULL_TREE
;
2511 bool got_canonical
= false;
2512 bool unlimited_entity
= false;
2518 coarray_flag
= flag_coarray
== GFC_FCOARRAY_LIB
2519 && derived
->module
&& !derived
->attr
.vtype
;
2521 gcc_assert (!derived
->attr
.pdt_template
);
2523 if (derived
->attr
.unlimited_polymorphic
2524 || (flag_coarray
== GFC_FCOARRAY_LIB
2525 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2526 && (derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
2527 || derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2528 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
)))
2529 return ptr_type_node
;
2531 if (flag_coarray
!= GFC_FCOARRAY_LIB
2532 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2533 && (derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2534 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
))
2535 return gfc_get_int_type (gfc_default_integer_kind
);
2537 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2538 && derived
->attr
.generic
)
2539 derived
= gfc_find_dt_in_generic (derived
);
2541 /* See if it's one of the iso_c_binding derived types. */
2542 if (derived
->attr
.is_iso_c
== 1 || derived
->ts
.f90_type
== BT_VOID
)
2544 if (derived
->backend_decl
)
2545 return derived
->backend_decl
;
2547 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2548 derived
->backend_decl
= ptr_type_node
;
2550 derived
->backend_decl
= pfunc_type_node
;
2552 derived
->ts
.kind
= gfc_index_integer_kind
;
2553 derived
->ts
.type
= BT_INTEGER
;
2554 /* Set the f90_type to BT_VOID as a way to recognize something of type
2555 BT_INTEGER that needs to fit a void * for the purpose of the
2556 iso_c_binding derived types. */
2557 derived
->ts
.f90_type
= BT_VOID
;
2559 return derived
->backend_decl
;
2562 /* If use associated, use the module type for this one. */
2563 if (derived
->backend_decl
== NULL
2564 && (derived
->attr
.use_assoc
|| derived
->attr
.used_in_submodule
)
2566 && gfc_get_module_backend_decl (derived
))
2567 goto copy_derived_types
;
2569 /* The derived types from an earlier namespace can be used as the
2571 if (derived
->backend_decl
== NULL
2572 && !derived
->attr
.use_assoc
2573 && !derived
->attr
.used_in_submodule
2574 && gfc_global_ns_list
)
2576 for (ns
= gfc_global_ns_list
;
2577 ns
->translated
&& !got_canonical
;
2580 if (ns
->derived_types
)
2582 for (gfc_symbol
*dt
= ns
->derived_types
; dt
&& !got_canonical
;
2585 gfc_copy_dt_decls_ifequal (dt
, derived
, true);
2586 if (derived
->backend_decl
)
2587 got_canonical
= true;
2588 if (dt
->dt_next
== ns
->derived_types
)
2595 /* Store up the canonical type to be added to this one. */
2598 if (TYPE_CANONICAL (derived
->backend_decl
))
2599 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2601 canonical
= derived
->backend_decl
;
2603 derived
->backend_decl
= NULL_TREE
;
2606 /* derived->backend_decl != 0 means we saw it before, but its
2607 components' backend_decl may have not been built. */
2608 if (derived
->backend_decl
)
2610 /* Its components' backend_decl have been built or we are
2611 seeing recursion through the formal arglist of a procedure
2612 pointer component. */
2613 if (TYPE_FIELDS (derived
->backend_decl
))
2614 return derived
->backend_decl
;
2615 else if (derived
->attr
.abstract
2616 && derived
->attr
.proc_pointer_comp
)
2618 /* If an abstract derived type with procedure pointer
2619 components has no other type of component, return the
2620 backend_decl. Otherwise build the components if any of the
2621 non-procedure pointer components have no backend_decl. */
2622 for (c
= derived
->components
; c
; c
= c
->next
)
2624 bool same_alloc_type
= c
->attr
.allocatable
2625 && derived
== c
->ts
.u
.derived
;
2626 if (!c
->attr
.proc_pointer
2628 && c
->backend_decl
== NULL
)
2630 else if (c
->next
== NULL
)
2631 return derived
->backend_decl
;
2633 typenode
= derived
->backend_decl
;
2636 typenode
= derived
->backend_decl
;
2640 /* We see this derived type first time, so build the type node. */
2641 typenode
= make_node (RECORD_TYPE
);
2642 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2643 TYPE_PACKED (typenode
) = flag_pack_derived
;
2644 derived
->backend_decl
= typenode
;
2647 if (derived
->components
2648 && derived
->components
->ts
.type
== BT_DERIVED
2649 && strcmp (derived
->components
->name
, "_data") == 0
2650 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2651 unlimited_entity
= true;
2653 /* Go through the derived type components, building them as
2654 necessary. The reason for doing this now is that it is
2655 possible to recurse back to this derived type through a
2656 pointer component (PR24092). If this happens, the fields
2657 will be built and so we can return the type. */
2658 for (c
= derived
->components
; c
; c
= c
->next
)
2660 bool same_alloc_type
= c
->attr
.allocatable
2661 && derived
== c
->ts
.u
.derived
;
2663 if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->backend_decl
== NULL
)
2664 c
->ts
.u
.derived
->backend_decl
= gfc_get_union_type (c
->ts
.u
.derived
);
2666 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2669 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
2670 && !same_alloc_type
)
2671 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2673 int local_codim
= c
->attr
.codimension
? c
->as
->corank
: codimen
;
2674 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
,
2678 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2680 /* Need to copy the modified ts from the derived type. The
2681 typespec was modified because C_PTR/C_FUNPTR are translated
2682 into (void *) from derived types. */
2683 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2684 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2685 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2688 c
->initializer
->ts
.type
= c
->ts
.type
;
2689 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2690 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2691 c
->initializer
->expr_type
= EXPR_NULL
;
2696 if (TYPE_FIELDS (derived
->backend_decl
))
2697 return derived
->backend_decl
;
2699 /* Build the type member list. Install the newly created RECORD_TYPE
2700 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2701 through only the top-level linked list of components so we correctly
2702 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2703 types are built as part of gfc_get_union_type. */
2704 for (c
= derived
->components
; c
; c
= c
->next
)
2706 bool same_alloc_type
= c
->attr
.allocatable
2707 && derived
== c
->ts
.u
.derived
;
2708 /* Prevent infinite recursion, when the procedure pointer type is
2709 the same as derived, by forcing the procedure pointer component to
2710 be built as if the explicit interface does not exist. */
2711 if (c
->attr
.proc_pointer
2712 && (c
->ts
.type
!= BT_DERIVED
|| (c
->ts
.u
.derived
2713 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)))
2714 && (c
->ts
.type
!= BT_CLASS
|| (CLASS_DATA (c
)->ts
.u
.derived
2715 && !gfc_compare_derived_types (derived
, CLASS_DATA (c
)->ts
.u
.derived
))))
2716 field_type
= gfc_get_ppc_type (c
);
2717 else if (c
->attr
.proc_pointer
&& derived
->backend_decl
)
2719 tmp
= build_function_type (derived
->backend_decl
, NULL_TREE
);
2720 field_type
= build_pointer_type (tmp
);
2722 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2723 field_type
= c
->ts
.u
.derived
->backend_decl
;
2724 else if (c
->attr
.caf_token
)
2725 field_type
= pvoid_type_node
;
2728 if (c
->ts
.type
== BT_CHARACTER
2729 && !c
->ts
.deferred
&& !c
->attr
.pdt_string
)
2731 /* Evaluate the string length. */
2732 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2733 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2735 else if (c
->ts
.type
== BT_CHARACTER
)
2736 c
->ts
.u
.cl
->backend_decl
2737 = build_int_cst (gfc_charlen_type_node
, 0);
2739 field_type
= gfc_typenode_for_spec (&c
->ts
, codimen
);
2742 /* This returns an array descriptor type. Initialization may be
2744 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2746 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_array
)
2748 enum gfc_array_kind akind
;
2749 if (c
->attr
.pointer
)
2750 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2751 : GFC_ARRAY_POINTER
;
2753 akind
= GFC_ARRAY_ALLOCATABLE
;
2754 /* Pointers to arrays aren't actually pointer types. The
2755 descriptors are separate, but the data is common. */
2756 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2758 && !c
->attr
.pointer
,
2763 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2767 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_string
)
2768 && !c
->attr
.proc_pointer
2769 && !(unlimited_entity
&& c
== derived
->components
))
2770 field_type
= build_pointer_type (field_type
);
2772 if (c
->attr
.pointer
|| same_alloc_type
)
2773 field_type
= gfc_nonrestricted_type (field_type
);
2775 /* vtype fields can point to different types to the base type. */
2776 if (c
->ts
.type
== BT_DERIVED
2777 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2778 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2781 /* Ensure that the CLASS language specific flag is set. */
2782 if (c
->ts
.type
== BT_CLASS
)
2784 if (POINTER_TYPE_P (field_type
))
2785 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2787 GFC_CLASS_TYPE_P (field_type
) = 1;
2790 field
= gfc_add_field_to_struct (typenode
,
2791 get_identifier (c
->name
),
2792 field_type
, &chain
);
2794 gfc_set_decl_location (field
, &c
->loc
);
2795 else if (derived
->declared_at
.lb
)
2796 gfc_set_decl_location (field
, &derived
->declared_at
);
2798 gfc_finish_decl_attrs (field
, &c
->attr
);
2800 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2803 if (!c
->backend_decl
)
2804 c
->backend_decl
= field
;
2806 if (c
->attr
.pointer
&& c
->attr
.dimension
2807 && !(c
->ts
.type
== BT_DERIVED
2808 && strcmp (c
->name
, "_data") == 0))
2809 GFC_DECL_PTR_ARRAY_P (c
->backend_decl
) = 1;
2812 /* Now lay out the derived type, including the fields. */
2814 TYPE_CANONICAL (typenode
) = canonical
;
2816 gfc_finish_type (typenode
);
2817 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2818 if (derived
->module
&& derived
->ns
->proc_name
2819 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2821 if (derived
->ns
->proc_name
->backend_decl
2822 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2825 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2826 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2827 = derived
->ns
->proc_name
->backend_decl
;
2831 derived
->backend_decl
= typenode
;
2835 for (c
= derived
->components
; c
; c
= c
->next
)
2837 /* Do not add a caf_token field for class container components. */
2838 if ((codimen
|| coarray_flag
)
2839 && !c
->attr
.dimension
&& !c
->attr
.codimension
2840 && (c
->attr
.allocatable
|| c
->attr
.pointer
)
2841 && !derived
->attr
.is_class
)
2843 /* Provide sufficient space to hold "_caf_symbol". */
2844 char caf_name
[GFC_MAX_SYMBOL_LEN
+ 6];
2845 gfc_component
*token
;
2846 snprintf (caf_name
, sizeof (caf_name
), "_caf_%s", c
->name
);
2847 token
= gfc_find_component (derived
, caf_name
, true, true, NULL
);
2849 c
->caf_token
= token
->backend_decl
;
2850 TREE_NO_WARNING (c
->caf_token
) = 1;
2854 for (gfc_symbol
*dt
= gfc_derived_types
; dt
; dt
= dt
->dt_next
)
2856 gfc_copy_dt_decls_ifequal (derived
, dt
, false);
2857 if (dt
->dt_next
== gfc_derived_types
)
2861 return derived
->backend_decl
;
2866 gfc_return_by_reference (gfc_symbol
* sym
)
2868 if (!sym
->attr
.function
)
2871 if (sym
->attr
.dimension
)
2874 if (sym
->ts
.type
== BT_CHARACTER
2875 && !sym
->attr
.is_bind_c
2876 && (!sym
->attr
.result
2877 || !sym
->ns
->proc_name
2878 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2881 /* Possibly return complex numbers by reference for g77 compatibility.
2882 We don't do this for calls to intrinsics (as the library uses the
2883 -fno-f2c calling convention), nor for calls to functions which always
2884 require an explicit interface, as no compatibility problems can
2886 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2887 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2894 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2898 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2899 gfc_entry_list
*el
, *el2
;
2901 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2902 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2904 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2906 /* Build the type node. */
2907 type
= make_node (UNION_TYPE
);
2909 TYPE_NAME (type
) = get_identifier (name
);
2911 for (el
= ns
->entries
; el
; el
= el
->next
)
2913 /* Search for duplicates. */
2914 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2915 if (el2
->sym
->result
== el
->sym
->result
)
2919 gfc_add_field_to_struct_1 (type
,
2920 get_identifier (el
->sym
->result
->name
),
2921 gfc_sym_type (el
->sym
->result
), &chain
);
2924 /* Finish off the type. */
2925 gfc_finish_type (type
);
2926 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2930 /* Create a "fn spec" based on the formal arguments;
2931 cf. create_function_arglist. */
2934 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2938 gfc_formal_arglist
*f
;
2941 memset (&spec
, 0, sizeof (spec
));
2945 if (sym
->attr
.entry_master
)
2946 spec
[spec_len
++] = 'R';
2947 if (gfc_return_by_reference (sym
))
2949 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2951 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2952 spec
[spec_len
++] = '.';
2954 spec
[spec_len
++] = 'w';
2955 if (sym
->ts
.type
== BT_CHARACTER
)
2956 spec
[spec_len
++] = 'R';
2959 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2960 if (spec_len
< sizeof (spec
))
2962 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2963 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2964 || (f
->sym
->ts
.type
== BT_DERIVED
2965 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2966 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2967 || (f
->sym
->ts
.type
== BT_CLASS
2968 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2969 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
))
2970 || (f
->sym
->ts
.type
== BT_INTEGER
&& f
->sym
->ts
.is_c_interop
))
2971 spec
[spec_len
++] = '.';
2972 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2973 spec
[spec_len
++] = 'r';
2975 spec
[spec_len
++] = 'w';
2978 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2979 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2980 return build_type_attribute_variant (fntype
, tmp
);
2984 gfc_get_function_type (gfc_symbol
* sym
, gfc_actual_arglist
*actual_args
)
2987 vec
<tree
, va_gc
> *typelist
= NULL
;
2988 gfc_formal_arglist
*f
;
2990 int alternate_return
= 0;
2991 bool is_varargs
= true;
2993 /* Make sure this symbol is a function, a subroutine or the main
2995 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2996 || sym
->attr
.flavor
== FL_PROGRAM
);
2998 /* To avoid recursing infinitely on recursive types, we use error_mark_node
2999 so that they can be detected here and handled further down. */
3000 if (sym
->backend_decl
== NULL
)
3001 sym
->backend_decl
= error_mark_node
;
3002 else if (sym
->backend_decl
== error_mark_node
)
3003 goto arg_type_list_done
;
3004 else if (sym
->attr
.proc_pointer
)
3005 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
3007 return TREE_TYPE (sym
->backend_decl
);
3009 if (sym
->attr
.entry_master
)
3010 /* Additional parameter for selecting an entry point. */
3011 vec_safe_push (typelist
, gfc_array_index_type
);
3018 if (arg
->ts
.type
== BT_CHARACTER
)
3019 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3021 /* Some functions we use an extra parameter for the return value. */
3022 if (gfc_return_by_reference (sym
))
3024 type
= gfc_sym_type (arg
);
3025 if (arg
->ts
.type
== BT_COMPLEX
3026 || arg
->attr
.dimension
3027 || arg
->ts
.type
== BT_CHARACTER
)
3028 type
= build_reference_type (type
);
3030 vec_safe_push (typelist
, type
);
3031 if (arg
->ts
.type
== BT_CHARACTER
)
3033 if (!arg
->ts
.deferred
)
3034 /* Transfer by value. */
3035 vec_safe_push (typelist
, gfc_charlen_type_node
);
3037 /* Deferred character lengths are transferred by reference
3038 so that the value can be returned. */
3039 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
3042 if (sym
->backend_decl
== error_mark_node
&& actual_args
!= NULL
3043 && sym
->formal
== NULL
&& (sym
->attr
.proc
== PROC_EXTERNAL
3044 || sym
->attr
.proc
== PROC_UNKNOWN
))
3045 gfc_get_formal_from_actual_arglist (sym
, actual_args
);
3047 /* Build the argument types for the function. */
3048 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3053 /* Evaluate constant character lengths here so that they can be
3054 included in the type. */
3055 if (arg
->ts
.type
== BT_CHARACTER
)
3056 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3058 if (arg
->attr
.flavor
== FL_PROCEDURE
)
3060 type
= gfc_get_function_type (arg
);
3061 type
= build_pointer_type (type
);
3064 type
= gfc_sym_type (arg
);
3066 /* Parameter Passing Convention
3068 We currently pass all parameters by reference.
3069 Parameters with INTENT(IN) could be passed by value.
3070 The problem arises if a function is called via an implicit
3071 prototype. In this situation the INTENT is not known.
3072 For this reason all parameters to global functions must be
3073 passed by reference. Passing by value would potentially
3074 generate bad code. Worse there would be no way of telling that
3075 this code was bad, except that it would give incorrect results.
3077 Contained procedures could pass by value as these are never
3078 used without an explicit interface, and cannot be passed as
3079 actual parameters for a dummy procedure. */
3081 vec_safe_push (typelist
, type
);
3085 if (sym
->attr
.subroutine
)
3086 alternate_return
= 1;
3090 /* Add hidden string length parameters. */
3091 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3094 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
3096 if (!arg
->ts
.deferred
)
3097 /* Transfer by value. */
3098 type
= gfc_charlen_type_node
;
3100 /* Deferred character lengths are transferred by reference
3101 so that the value can be returned. */
3102 type
= build_pointer_type (gfc_charlen_type_node
);
3104 vec_safe_push (typelist
, type
);
3106 /* For noncharacter scalar intrinsic types, VALUE passes the value,
3107 hence, the optional status cannot be transferred via a NULL pointer.
3108 Thus, we will use a hidden argument in that case. */
3110 && arg
->attr
.optional
3112 && !arg
->attr
.dimension
3113 && arg
->ts
.type
!= BT_CLASS
3114 && !gfc_bt_struct (arg
->ts
.type
))
3115 vec_safe_push (typelist
, boolean_type_node
);
3118 if (!vec_safe_is_empty (typelist
)
3119 || sym
->attr
.is_main_program
3120 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
3123 if (sym
->backend_decl
== error_mark_node
)
3124 sym
->backend_decl
= NULL_TREE
;
3128 if (alternate_return
)
3129 type
= integer_type_node
;
3130 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
3131 type
= void_type_node
;
3132 else if (sym
->attr
.mixed_entry_master
)
3133 type
= gfc_get_mixed_entry_union (sym
->ns
);
3134 else if (flag_f2c
&& sym
->ts
.type
== BT_REAL
3135 && sym
->ts
.kind
== gfc_default_real_kind
3136 && !sym
->attr
.always_explicit
)
3138 /* Special case: f2c calling conventions require that (scalar)
3139 default REAL functions return the C type double instead. f2c
3140 compatibility is only an issue with functions that don't
3141 require an explicit interface, as only these could be
3142 implemented in Fortran 77. */
3143 sym
->ts
.kind
= gfc_default_double_kind
;
3144 type
= gfc_typenode_for_spec (&sym
->ts
);
3145 sym
->ts
.kind
= gfc_default_real_kind
;
3147 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
3148 /* Procedure pointer return values. */
3150 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
3152 /* Unset proc_pointer as gfc_get_function_type
3153 is called recursively. */
3154 sym
->result
->attr
.proc_pointer
= 0;
3155 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
3156 sym
->result
->attr
.proc_pointer
= 1;
3159 type
= gfc_sym_type (sym
->result
);
3162 type
= gfc_sym_type (sym
);
3165 type
= build_varargs_function_type_vec (type
, typelist
);
3167 type
= build_function_type_vec (type
, typelist
);
3168 type
= create_fn_spec (sym
, type
);
3173 /* Language hooks for middle-end access to type nodes. */
3175 /* Return an integer type with BITS bits of precision,
3176 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3179 gfc_type_for_size (unsigned bits
, int unsignedp
)
3184 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
3186 tree type
= gfc_integer_types
[i
];
3187 if (type
&& bits
== TYPE_PRECISION (type
))
3191 /* Handle TImode as a special case because it is used by some backends
3192 (e.g. ARM) even though it is not available for normal use. */
3193 #if HOST_BITS_PER_WIDE_INT >= 64
3194 if (bits
== TYPE_PRECISION (intTI_type_node
))
3195 return intTI_type_node
;
3198 if (bits
<= TYPE_PRECISION (intQI_type_node
))
3199 return intQI_type_node
;
3200 if (bits
<= TYPE_PRECISION (intHI_type_node
))
3201 return intHI_type_node
;
3202 if (bits
<= TYPE_PRECISION (intSI_type_node
))
3203 return intSI_type_node
;
3204 if (bits
<= TYPE_PRECISION (intDI_type_node
))
3205 return intDI_type_node
;
3206 if (bits
<= TYPE_PRECISION (intTI_type_node
))
3207 return intTI_type_node
;
3211 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
3212 return unsigned_intQI_type_node
;
3213 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
3214 return unsigned_intHI_type_node
;
3215 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
3216 return unsigned_intSI_type_node
;
3217 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
3218 return unsigned_intDI_type_node
;
3219 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
3220 return unsigned_intTI_type_node
;
3226 /* Return a data type that has machine mode MODE. If the mode is an
3227 integer, then UNSIGNEDP selects between signed and unsigned types. */
3230 gfc_type_for_mode (machine_mode mode
, int unsignedp
)
3234 scalar_int_mode int_mode
;
3236 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
3237 base
= gfc_real_types
;
3238 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
3239 base
= gfc_complex_types
;
3240 else if (is_a
<scalar_int_mode
> (mode
, &int_mode
))
3242 tree type
= gfc_type_for_size (GET_MODE_PRECISION (int_mode
), unsignedp
);
3243 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
3245 else if (GET_MODE_CLASS (mode
) == MODE_VECTOR_BOOL
3246 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3248 unsigned int elem_bits
= vector_element_size (GET_MODE_BITSIZE (mode
),
3249 GET_MODE_NUNITS (mode
));
3250 tree bool_type
= build_nonstandard_boolean_type (elem_bits
);
3251 return build_vector_type_for_mode (bool_type
, mode
);
3253 else if (VECTOR_MODE_P (mode
)
3254 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3256 machine_mode inner_mode
= GET_MODE_INNER (mode
);
3257 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
3258 if (inner_type
!= NULL_TREE
)
3259 return build_vector_type_for_mode (inner_type
, mode
);
3265 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
3267 tree type
= base
[i
];
3268 if (type
&& mode
== TYPE_MODE (type
))
3275 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3279 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
3282 bool indirect
= false;
3283 tree etype
, ptype
, t
, base_decl
;
3284 tree data_off
, span_off
, dim_off
, dtype_off
, dim_size
, elem_size
;
3285 tree lower_suboff
, upper_suboff
, stride_suboff
;
3286 tree dtype
, field
, rank_off
;
3288 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3290 if (! POINTER_TYPE_P (type
))
3292 type
= TREE_TYPE (type
);
3293 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3298 rank
= GFC_TYPE_ARRAY_RANK (type
);
3299 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3302 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3303 gcc_assert (POINTER_TYPE_P (etype
));
3304 etype
= TREE_TYPE (etype
);
3306 /* If the type is not a scalar coarray. */
3307 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3308 etype
= TREE_TYPE (etype
);
3310 /* Can't handle variable sized elements yet. */
3311 if (int_size_in_bytes (etype
) <= 0)
3313 /* Nor non-constant lower bounds in assumed shape arrays. */
3314 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3315 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3317 for (dim
= 0; dim
< rank
; dim
++)
3318 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3319 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3323 memset (info
, '\0', sizeof (*info
));
3324 info
->ndimensions
= rank
;
3325 info
->ordering
= array_descr_ordering_column_major
;
3326 info
->element_type
= etype
;
3327 ptype
= build_pointer_type (gfc_array_index_type
);
3328 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3331 base_decl
= make_node (DEBUG_EXPR_DECL
);
3332 DECL_ARTIFICIAL (base_decl
) = 1;
3333 TREE_TYPE (base_decl
) = indirect
? build_pointer_type (ptype
) : ptype
;
3334 SET_DECL_MODE (base_decl
, TYPE_MODE (TREE_TYPE (base_decl
)));
3335 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3337 info
->base_decl
= base_decl
;
3339 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3341 gfc_get_descriptor_offsets_for_info (type
, &data_off
, &dtype_off
, &span_off
,
3342 &dim_off
, &dim_size
, &stride_suboff
,
3343 &lower_suboff
, &upper_suboff
);
3345 t
= fold_build_pointer_plus (base_decl
, span_off
);
3346 elem_size
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3349 if (!integer_zerop (data_off
))
3350 t
= fold_build_pointer_plus (t
, data_off
);
3351 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3352 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3353 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3354 info
->allocated
= build2 (NE_EXPR
, logical_type_node
,
3355 info
->data_location
, null_pointer_node
);
3356 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3357 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3358 info
->associated
= build2 (NE_EXPR
, logical_type_node
,
3359 info
->data_location
, null_pointer_node
);
3360 if ((GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK
3361 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
)
3362 && dwarf_version
>= 5)
3365 info
->ndimensions
= 1;
3367 if (!integer_zerop (dtype_off
))
3368 t
= fold_build_pointer_plus (t
, dtype_off
);
3369 dtype
= TYPE_MAIN_VARIANT (get_dtype_type_node ());
3370 field
= gfc_advance_chain (TYPE_FIELDS (dtype
), GFC_DTYPE_RANK
);
3371 rank_off
= byte_position (field
);
3372 if (!integer_zerop (dtype_off
))
3373 t
= fold_build_pointer_plus (t
, rank_off
);
3375 t
= build1 (NOP_EXPR
, build_pointer_type (gfc_array_index_type
), t
);
3376 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3378 t
= build0 (PLACEHOLDER_EXPR
, TREE_TYPE (dim_off
));
3379 t
= size_binop (MULT_EXPR
, t
, dim_size
);
3380 dim_off
= build2 (PLUS_EXPR
, TREE_TYPE (dim_off
), t
, dim_off
);
3383 for (dim
= 0; dim
< rank
; dim
++)
3385 t
= fold_build_pointer_plus (base_decl
,
3386 size_binop (PLUS_EXPR
,
3387 dim_off
, lower_suboff
));
3388 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3389 info
->dimen
[dim
].lower_bound
= t
;
3390 t
= fold_build_pointer_plus (base_decl
,
3391 size_binop (PLUS_EXPR
,
3392 dim_off
, upper_suboff
));
3393 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3394 info
->dimen
[dim
].upper_bound
= t
;
3395 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3396 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3398 /* Assumed shape arrays have known lower bounds. */
3399 info
->dimen
[dim
].upper_bound
3400 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3401 info
->dimen
[dim
].upper_bound
,
3402 info
->dimen
[dim
].lower_bound
);
3403 info
->dimen
[dim
].lower_bound
3404 = fold_convert (gfc_array_index_type
,
3405 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3406 info
->dimen
[dim
].upper_bound
3407 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3408 info
->dimen
[dim
].lower_bound
,
3409 info
->dimen
[dim
].upper_bound
);
3411 t
= fold_build_pointer_plus (base_decl
,
3412 size_binop (PLUS_EXPR
,
3413 dim_off
, stride_suboff
));
3414 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3415 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3416 info
->dimen
[dim
].stride
= t
;
3418 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3425 /* Create a type to handle vector subscripts for coarray library calls. It
3427 struct caf_vector_t {
3428 size_t nvec; // size of the vector
3435 ptrdiff_t lower_bound;
3436 ptrdiff_t upper_bound;
3441 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3442 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3445 gfc_get_caf_vector_type (int dim
)
3447 static tree vector_types
[GFC_MAX_DIMENSIONS
];
3448 static tree vec_type
= NULL_TREE
;
3449 tree triplet_struct_type
, vect_struct_type
, union_type
, tmp
, *chain
;
3451 if (vector_types
[dim
-1] != NULL_TREE
)
3452 return vector_types
[dim
-1];
3454 if (vec_type
== NULL_TREE
)
3457 vect_struct_type
= make_node (RECORD_TYPE
);
3458 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3459 get_identifier ("vector"),
3460 pvoid_type_node
, &chain
);
3461 TREE_NO_WARNING (tmp
) = 1;
3462 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3463 get_identifier ("kind"),
3464 integer_type_node
, &chain
);
3465 TREE_NO_WARNING (tmp
) = 1;
3466 gfc_finish_type (vect_struct_type
);
3469 triplet_struct_type
= make_node (RECORD_TYPE
);
3470 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3471 get_identifier ("lower_bound"),
3472 gfc_array_index_type
, &chain
);
3473 TREE_NO_WARNING (tmp
) = 1;
3474 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3475 get_identifier ("upper_bound"),
3476 gfc_array_index_type
, &chain
);
3477 TREE_NO_WARNING (tmp
) = 1;
3478 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
, get_identifier ("stride"),
3479 gfc_array_index_type
, &chain
);
3480 TREE_NO_WARNING (tmp
) = 1;
3481 gfc_finish_type (triplet_struct_type
);
3484 union_type
= make_node (UNION_TYPE
);
3485 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3486 vect_struct_type
, &chain
);
3487 TREE_NO_WARNING (tmp
) = 1;
3488 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("triplet"),
3489 triplet_struct_type
, &chain
);
3490 TREE_NO_WARNING (tmp
) = 1;
3491 gfc_finish_type (union_type
);
3494 vec_type
= make_node (RECORD_TYPE
);
3495 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("nvec"),
3496 size_type_node
, &chain
);
3497 TREE_NO_WARNING (tmp
) = 1;
3498 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("u"),
3499 union_type
, &chain
);
3500 TREE_NO_WARNING (tmp
) = 1;
3501 gfc_finish_type (vec_type
);
3502 TYPE_NAME (vec_type
) = get_identifier ("caf_vector_t");
3505 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3506 gfc_rank_cst
[dim
-1]);
3507 vector_types
[dim
-1] = build_array_type (vec_type
, tmp
);
3508 return vector_types
[dim
-1];
3513 gfc_get_caf_reference_type ()
3515 static tree reference_type
= NULL_TREE
;
3516 tree c_struct_type
, s_struct_type
, v_struct_type
, union_type
, dim_union_type
,
3517 a_struct_type
, u_union_type
, tmp
, *chain
;
3519 if (reference_type
!= NULL_TREE
)
3520 return reference_type
;
3523 c_struct_type
= make_node (RECORD_TYPE
);
3524 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3525 get_identifier ("offset"),
3526 gfc_array_index_type
, &chain
);
3527 TREE_NO_WARNING (tmp
) = 1;
3528 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3529 get_identifier ("caf_token_offset"),
3530 gfc_array_index_type
, &chain
);
3531 TREE_NO_WARNING (tmp
) = 1;
3532 gfc_finish_type (c_struct_type
);
3535 s_struct_type
= make_node (RECORD_TYPE
);
3536 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3537 get_identifier ("start"),
3538 gfc_array_index_type
, &chain
);
3539 TREE_NO_WARNING (tmp
) = 1;
3540 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3541 get_identifier ("end"),
3542 gfc_array_index_type
, &chain
);
3543 TREE_NO_WARNING (tmp
) = 1;
3544 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3545 get_identifier ("stride"),
3546 gfc_array_index_type
, &chain
);
3547 TREE_NO_WARNING (tmp
) = 1;
3548 gfc_finish_type (s_struct_type
);
3551 v_struct_type
= make_node (RECORD_TYPE
);
3552 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3553 get_identifier ("vector"),
3554 pvoid_type_node
, &chain
);
3555 TREE_NO_WARNING (tmp
) = 1;
3556 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3557 get_identifier ("nvec"),
3558 size_type_node
, &chain
);
3559 TREE_NO_WARNING (tmp
) = 1;
3560 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3561 get_identifier ("kind"),
3562 integer_type_node
, &chain
);
3563 TREE_NO_WARNING (tmp
) = 1;
3564 gfc_finish_type (v_struct_type
);
3567 union_type
= make_node (UNION_TYPE
);
3568 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("s"),
3569 s_struct_type
, &chain
);
3570 TREE_NO_WARNING (tmp
) = 1;
3571 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3572 v_struct_type
, &chain
);
3573 TREE_NO_WARNING (tmp
) = 1;
3574 gfc_finish_type (union_type
);
3576 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3577 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1]);
3578 dim_union_type
= build_array_type (union_type
, tmp
);
3581 a_struct_type
= make_node (RECORD_TYPE
);
3582 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("mode"),
3583 build_array_type (unsigned_char_type_node
,
3584 build_range_type (gfc_array_index_type
,
3585 gfc_index_zero_node
,
3586 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1])),
3588 TREE_NO_WARNING (tmp
) = 1;
3589 tmp
= gfc_add_field_to_struct_1 (a_struct_type
,
3590 get_identifier ("static_array_type"),
3591 integer_type_node
, &chain
);
3592 TREE_NO_WARNING (tmp
) = 1;
3593 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("dim"),
3594 dim_union_type
, &chain
);
3595 TREE_NO_WARNING (tmp
) = 1;
3596 gfc_finish_type (a_struct_type
);
3599 u_union_type
= make_node (UNION_TYPE
);
3600 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("c"),
3601 c_struct_type
, &chain
);
3602 TREE_NO_WARNING (tmp
) = 1;
3603 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("a"),
3604 a_struct_type
, &chain
);
3605 TREE_NO_WARNING (tmp
) = 1;
3606 gfc_finish_type (u_union_type
);
3609 reference_type
= make_node (RECORD_TYPE
);
3610 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("next"),
3611 build_pointer_type (reference_type
), &chain
);
3612 TREE_NO_WARNING (tmp
) = 1;
3613 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("type"),
3614 integer_type_node
, &chain
);
3615 TREE_NO_WARNING (tmp
) = 1;
3616 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("item_size"),
3617 size_type_node
, &chain
);
3618 TREE_NO_WARNING (tmp
) = 1;
3619 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("u"),
3620 u_union_type
, &chain
);
3621 TREE_NO_WARNING (tmp
) = 1;
3622 gfc_finish_type (reference_type
);
3623 TYPE_NAME (reference_type
) = get_identifier ("caf_reference_t");
3625 return reference_type
;
3628 #include "gt-fortran-trans-types.h"