1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2019 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
;
1184 /* This is for the second arg to c_f_pointer and c_f_procpointer
1185 of the iso_c_binding module, to accept any ptr type. */
1186 basetype
= ptr_type_node
;
1187 if (spec
->f90_type
== BT_VOID
)
1190 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1191 basetype
= ptr_type_node
;
1193 basetype
= pfunc_type_node
;
1202 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1205 gfc_conv_array_bound (gfc_expr
* expr
)
1207 /* If expr is an integer constant, return that. */
1208 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1209 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1211 /* Otherwise return NULL. */
1215 /* Return the type of an element of the array. Note that scalar coarrays
1216 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1217 (with POINTER_TYPE stripped) is returned. */
1220 gfc_get_element_type (tree type
)
1224 if (GFC_ARRAY_TYPE_P (type
))
1226 if (TREE_CODE (type
) == POINTER_TYPE
)
1227 type
= TREE_TYPE (type
);
1228 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1230 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1235 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1236 element
= TREE_TYPE (type
);
1241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1242 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1244 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1245 element
= TREE_TYPE (element
);
1247 /* For arrays, which are not scalar coarrays. */
1248 if (TREE_CODE (element
) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (element
))
1249 element
= TREE_TYPE (element
);
1255 /* Build an array. This function is called from gfc_sym_type().
1256 Actually returns array descriptor type.
1258 Format of array descriptors is as follows:
1260 struct gfc_array_descriptor
1264 struct dtype_type dtype;
1265 struct descriptor_dimension dimension[N_DIM];
1274 signed short attribute;
1277 struct descriptor_dimension
1284 Translation code should use gfc_conv_descriptor_* rather than
1285 accessing the descriptor directly. Any changes to the array
1286 descriptor type will require changes in gfc_conv_descriptor_* and
1287 gfc_build_array_initializer.
1289 This is represented internally as a RECORD_TYPE. The index nodes
1290 are gfc_array_index_type and the data node is a pointer to the
1291 data. See below for the handling of character types.
1293 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1294 this generated poor code for assumed/deferred size arrays. These
1295 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1296 of the GENERIC grammar. Also, there is no way to explicitly set
1297 the array stride, so all data must be packed(1). I've tried to
1298 mark all the functions which would require modification with a GCC
1301 The data component points to the first element in the array. The
1302 offset field is the position of the origin of the array (i.e. element
1303 (0, 0 ...)). This may be outside the bounds of the array.
1305 An element is accessed by
1306 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1307 This gives good performance as the computation does not involve the
1308 bounds of the array. For packed arrays, this is optimized further
1309 by substituting the known strides.
1311 This system has one problem: all array bounds must be within 2^31
1312 elements of the origin (2^63 on 64-bit machines). For example
1313 integer, dimension (80000:90000, 80000:90000, 2) :: array
1314 may not work properly on 32-bit machines because 80000*80000 >
1315 2^31, so the calculation for stride2 would overflow. This may
1316 still work, but I haven't checked, and it relies on the overflow
1317 doing the right thing.
1319 The way to fix this problem is to access elements as follows:
1320 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1321 Obviously this is much slower. I will make this a compile time
1322 option, something like -fsmall-array-offsets. Mixing code compiled
1323 with and without this switch will work.
1325 (1) This can be worked around by modifying the upper bound of the
1326 previous dimension. This requires extra fields in the descriptor
1327 (both real_ubound and fake_ubound). */
1330 /* Returns true if the array sym does not require a descriptor. */
1333 gfc_is_nodesc_array (gfc_symbol
* sym
)
1335 symbol_attribute
*array_attr
;
1337 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1339 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1340 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1342 gcc_assert (array_attr
->dimension
|| array_attr
->codimension
);
1344 /* We only want local arrays. */
1345 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1346 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1347 || array_attr
->allocatable
)
1350 /* We want a descriptor for associate-name arrays that do not have an
1351 explicitly known shape already. */
1352 if (sym
->assoc
&& as
->type
!= AS_EXPLICIT
)
1355 /* The dummy is stored in sym and not in the component. */
1356 if (sym
->attr
.dummy
)
1357 return as
->type
!= AS_ASSUMED_SHAPE
1358 && as
->type
!= AS_ASSUMED_RANK
;
1360 if (sym
->attr
.result
|| sym
->attr
.function
)
1363 gcc_assert (as
->type
== AS_EXPLICIT
|| as
->cp_was_assumed
);
1369 /* Create an array descriptor type. */
1372 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1373 enum gfc_array_kind akind
, bool restricted
,
1374 bool contiguous
, int codim
)
1376 tree lbound
[GFC_MAX_DIMENSIONS
];
1377 tree ubound
[GFC_MAX_DIMENSIONS
];
1380 /* Assumed-shape arrays do not have codimension information stored in the
1382 corank
= MAX (as
->corank
, codim
);
1383 if (as
->type
== AS_ASSUMED_SHAPE
||
1384 (as
->type
== AS_ASSUMED_RANK
&& akind
== GFC_ARRAY_ALLOCATABLE
))
1387 if (as
->type
== AS_ASSUMED_RANK
)
1388 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1390 lbound
[n
] = NULL_TREE
;
1391 ubound
[n
] = NULL_TREE
;
1394 for (n
= 0; n
< as
->rank
; n
++)
1396 /* Create expressions for the known bounds of the array. */
1397 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1398 lbound
[n
] = gfc_index_one_node
;
1400 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1401 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1404 for (n
= as
->rank
; n
< as
->rank
+ corank
; n
++)
1406 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1407 lbound
[n
] = gfc_index_one_node
;
1409 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1411 if (n
< as
->rank
+ corank
- 1)
1412 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1415 if (as
->type
== AS_ASSUMED_SHAPE
)
1416 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1417 : GFC_ARRAY_ASSUMED_SHAPE
;
1418 else if (as
->type
== AS_ASSUMED_RANK
)
1419 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1420 : GFC_ARRAY_ASSUMED_RANK
;
1421 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1422 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1423 corank
, lbound
, ubound
, 0, akind
,
1427 /* Returns the struct descriptor_dimension type. */
1430 gfc_get_desc_dim_type (void)
1433 tree decl
, *chain
= NULL
;
1435 if (gfc_desc_dim_type
)
1436 return gfc_desc_dim_type
;
1438 /* Build the type node. */
1439 type
= make_node (RECORD_TYPE
);
1441 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1442 TYPE_PACKED (type
) = 1;
1444 /* Consists of the stride, lbound and ubound members. */
1445 decl
= gfc_add_field_to_struct_1 (type
,
1446 get_identifier ("stride"),
1447 gfc_array_index_type
, &chain
);
1448 TREE_NO_WARNING (decl
) = 1;
1450 decl
= gfc_add_field_to_struct_1 (type
,
1451 get_identifier ("lbound"),
1452 gfc_array_index_type
, &chain
);
1453 TREE_NO_WARNING (decl
) = 1;
1455 decl
= gfc_add_field_to_struct_1 (type
,
1456 get_identifier ("ubound"),
1457 gfc_array_index_type
, &chain
);
1458 TREE_NO_WARNING (decl
) = 1;
1460 /* Finish off the type. */
1461 gfc_finish_type (type
);
1462 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1464 gfc_desc_dim_type
= type
;
1469 /* Return the DTYPE for an array. This describes the type and type parameters
1471 /* TODO: Only call this when the value is actually used, and make all the
1472 unknown cases abort. */
1475 gfc_get_dtype_rank_type (int rank
, tree etype
)
1482 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1484 size
= TYPE_SIZE_UNIT (etype
);
1486 switch (TREE_CODE (etype
))
1505 if (GFC_CLASS_TYPE_P (etype
))
1511 /* We will never have arrays of arrays. */
1514 if (size
== NULL_TREE
)
1515 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1520 if (TREE_CODE (TREE_TYPE (etype
)) != VOID_TYPE
)
1521 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1523 size
= build_int_cst (size_type_node
, 0);
1527 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1528 /* We can encounter strange array types for temporary arrays. */
1529 return gfc_index_zero_node
;
1532 tmp
= get_dtype_type_node ();
1533 field
= gfc_advance_chain (TYPE_FIELDS (tmp
),
1534 GFC_DTYPE_ELEM_LEN
);
1535 CONSTRUCTOR_APPEND_ELT (v
, field
,
1536 fold_convert (TREE_TYPE (field
), size
));
1538 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1540 CONSTRUCTOR_APPEND_ELT (v
, field
,
1541 build_int_cst (TREE_TYPE (field
), rank
));
1543 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1545 CONSTRUCTOR_APPEND_ELT (v
, field
,
1546 build_int_cst (TREE_TYPE (field
), n
));
1548 dtype
= build_constructor (tmp
, v
);
1555 gfc_get_dtype (tree type
)
1561 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1563 rank
= GFC_TYPE_ARRAY_RANK (type
);
1564 etype
= gfc_get_element_type (type
);
1565 dtype
= gfc_get_dtype_rank_type (rank
, etype
);
1567 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1572 /* Build an array type for use without a descriptor, packed according
1573 to the value of PACKED. */
1576 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1590 mpz_init_set_ui (offset
, 0);
1591 mpz_init_set_ui (stride
, 1);
1594 /* We don't use build_array_type because this does not include include
1595 lang-specific information (i.e. the bounds of the array) when checking
1598 type
= make_node (ARRAY_TYPE
);
1600 type
= build_variant_type_copy (etype
);
1602 GFC_ARRAY_TYPE_P (type
) = 1;
1603 TYPE_LANG_SPECIFIC (type
) = ggc_cleared_alloc
<struct lang_type
> ();
1605 known_stride
= (packed
!= PACKED_NO
);
1607 for (n
= 0; n
< as
->rank
; n
++)
1609 /* Fill in the stride and bound components of the type. */
1611 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1614 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1616 expr
= as
->lower
[n
];
1617 if (expr
->expr_type
== EXPR_CONSTANT
)
1619 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1620 gfc_index_integer_kind
);
1627 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1631 /* Calculate the offset. */
1632 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1633 mpz_sub (offset
, offset
, delta
);
1638 expr
= as
->upper
[n
];
1639 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1641 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1642 gfc_index_integer_kind
);
1649 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1653 /* Calculate the stride. */
1654 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1655 as
->lower
[n
]->value
.integer
);
1656 mpz_add_ui (delta
, delta
, 1);
1657 mpz_mul (stride
, stride
, delta
);
1660 /* Only the first stride is known for partial packed arrays. */
1661 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1664 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1666 expr
= as
->lower
[n
];
1667 if (expr
->expr_type
== EXPR_CONSTANT
)
1668 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1669 gfc_index_integer_kind
);
1672 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1674 expr
= as
->upper
[n
];
1675 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1676 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1677 gfc_index_integer_kind
);
1680 if (n
< as
->rank
+ as
->corank
- 1)
1681 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1686 GFC_TYPE_ARRAY_OFFSET (type
) =
1687 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1690 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1694 GFC_TYPE_ARRAY_SIZE (type
) =
1695 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1698 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1700 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1701 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1702 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1703 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1705 /* TODO: use main type if it is unbounded. */
1706 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1707 build_pointer_type (build_array_type (etype
, range
));
1709 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1710 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1711 TYPE_QUAL_RESTRICT
);
1715 if (packed
!= PACKED_STATIC
|| flag_coarray
== GFC_FCOARRAY_LIB
)
1717 type
= build_pointer_type (type
);
1720 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1722 GFC_ARRAY_TYPE_P (type
) = 1;
1723 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1731 mpz_sub_ui (stride
, stride
, 1);
1732 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1737 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1738 TYPE_DOMAIN (type
) = range
;
1740 build_pointer_type (etype
);
1741 TREE_TYPE (type
) = etype
;
1749 /* Represent packed arrays as multi-dimensional if they have rank >
1750 1 and with proper bounds, instead of flat arrays. This makes for
1751 better debug info. */
1754 tree gtype
= etype
, rtype
, type_decl
;
1756 for (n
= as
->rank
- 1; n
>= 0; n
--)
1758 rtype
= build_range_type (gfc_array_index_type
,
1759 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1760 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1761 gtype
= build_array_type (gtype
, rtype
);
1763 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1764 TYPE_DECL
, NULL
, gtype
);
1765 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1768 if (packed
!= PACKED_STATIC
|| !known_stride
1769 || (as
->corank
&& flag_coarray
== GFC_FCOARRAY_LIB
))
1771 /* For dummy arrays and automatic (heap allocated) arrays we
1772 want a pointer to the array. */
1773 type
= build_pointer_type (type
);
1775 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1776 GFC_ARRAY_TYPE_P (type
) = 1;
1777 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1783 /* Return or create the base type for an array descriptor. */
1786 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1788 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1789 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1792 /* Assumed-rank array. */
1794 dimen
= GFC_MAX_DIMENSIONS
;
1796 idx
= 2 * (codimen
+ dimen
) + restricted
;
1798 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1800 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1802 if (gfc_array_descriptor_base_caf
[idx
])
1803 return gfc_array_descriptor_base_caf
[idx
];
1805 else if (gfc_array_descriptor_base
[idx
])
1806 return gfc_array_descriptor_base
[idx
];
1808 /* Build the type node. */
1809 fat_type
= make_node (RECORD_TYPE
);
1811 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1812 TYPE_NAME (fat_type
) = get_identifier (name
);
1813 TYPE_NAMELESS (fat_type
) = 1;
1815 /* Add the data member as the first element of the descriptor. */
1816 decl
= gfc_add_field_to_struct_1 (fat_type
,
1817 get_identifier ("data"),
1820 : ptr_type_node
), &chain
);
1822 /* Add the base component. */
1823 decl
= gfc_add_field_to_struct_1 (fat_type
,
1824 get_identifier ("offset"),
1825 gfc_array_index_type
, &chain
);
1826 TREE_NO_WARNING (decl
) = 1;
1828 /* Add the dtype component. */
1829 decl
= gfc_add_field_to_struct_1 (fat_type
,
1830 get_identifier ("dtype"),
1831 get_dtype_type_node (), &chain
);
1832 TREE_NO_WARNING (decl
) = 1;
1834 /* Add the span component. */
1835 decl
= gfc_add_field_to_struct_1 (fat_type
,
1836 get_identifier ("span"),
1837 gfc_array_index_type
, &chain
);
1838 TREE_NO_WARNING (decl
) = 1;
1840 /* Build the array type for the stride and bound components. */
1841 if (dimen
+ codimen
> 0)
1844 build_array_type (gfc_get_desc_dim_type (),
1845 build_range_type (gfc_array_index_type
,
1846 gfc_index_zero_node
,
1847 gfc_rank_cst
[codimen
+ dimen
- 1]));
1849 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1851 TREE_NO_WARNING (decl
) = 1;
1854 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1856 decl
= gfc_add_field_to_struct_1 (fat_type
,
1857 get_identifier ("token"),
1858 prvoid_type_node
, &chain
);
1859 TREE_NO_WARNING (decl
) = 1;
1862 /* Finish off the type. */
1863 gfc_finish_type (fat_type
);
1864 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1866 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1867 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1869 gfc_array_descriptor_base
[idx
] = fat_type
;
1875 /* Build an array (descriptor) type with given bounds. */
1878 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1879 tree
* ubound
, int packed
,
1880 enum gfc_array_kind akind
, bool restricted
)
1882 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1883 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1884 const char *type_name
;
1887 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1888 fat_type
= build_distinct_type_copy (base_type
);
1889 /* Unshare TYPE_FIELDs. */
1890 for (tree
*tp
= &TYPE_FIELDS (fat_type
); *tp
; tp
= &DECL_CHAIN (*tp
))
1892 tree next
= DECL_CHAIN (*tp
);
1893 *tp
= copy_node (*tp
);
1894 DECL_CONTEXT (*tp
) = fat_type
;
1895 DECL_CHAIN (*tp
) = next
;
1897 /* Make sure that nontarget and target array type have the same canonical
1898 type (and same stub decl for debug info). */
1899 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1900 TYPE_CANONICAL (fat_type
) = base_type
;
1901 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1903 tmp
= TYPE_NAME (etype
);
1904 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1905 tmp
= DECL_NAME (tmp
);
1907 type_name
= IDENTIFIER_POINTER (tmp
);
1909 type_name
= "unknown";
1910 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1911 GFC_MAX_SYMBOL_LEN
, type_name
);
1912 TYPE_NAME (fat_type
) = get_identifier (name
);
1913 TYPE_NAMELESS (fat_type
) = 1;
1915 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1916 TYPE_LANG_SPECIFIC (fat_type
) = ggc_cleared_alloc
<struct lang_type
> ();
1918 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1919 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1920 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1921 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1923 /* Build an array descriptor record type. */
1925 stride
= gfc_index_one_node
;
1928 for (n
= 0; n
< dimen
+ codimen
; n
++)
1931 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1938 if (lower
!= NULL_TREE
)
1940 if (INTEGER_CST_P (lower
))
1941 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1946 if (codimen
&& n
== dimen
+ codimen
- 1)
1950 if (upper
!= NULL_TREE
)
1952 if (INTEGER_CST_P (upper
))
1953 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1961 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1963 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1964 gfc_array_index_type
, upper
, lower
);
1965 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1966 gfc_array_index_type
, tmp
,
1967 gfc_index_one_node
);
1968 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1969 gfc_array_index_type
, tmp
, stride
);
1970 /* Check the folding worked. */
1971 gcc_assert (INTEGER_CST_P (stride
));
1976 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1978 /* TODO: known offsets for descriptors. */
1979 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1983 arraytype
= build_pointer_type (etype
);
1985 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1987 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1991 /* We define data as an array with the correct size if possible.
1992 Much better than doing pointer arithmetic. */
1994 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1995 int_const_binop (MINUS_EXPR
, stride
,
1996 build_int_cst (TREE_TYPE (stride
), 1)));
1998 rtype
= gfc_array_range_type
;
1999 arraytype
= build_array_type (etype
, rtype
);
2000 arraytype
= build_pointer_type (arraytype
);
2002 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
2003 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
2005 /* This will generate the base declarations we need to emit debug
2006 information for this type. FIXME: there must be a better way to
2007 avoid divergence between compilations with and without debug
2010 struct array_descr_info info
;
2011 gfc_get_array_descr_info (fat_type
, &info
);
2012 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
2018 /* Build a pointer type. This function is called from gfc_sym_type(). */
2021 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
2023 /* Array pointer types aren't actually pointers. */
2024 if (sym
->attr
.dimension
)
2027 return build_pointer_type (type
);
2030 static tree
gfc_nonrestricted_type (tree t
);
2031 /* Given two record or union type nodes TO and FROM, ensure
2032 that all fields in FROM have a corresponding field in TO,
2033 their type being nonrestrict variants. This accepts a TO
2034 node that already has a prefix of the fields in FROM. */
2036 mirror_fields (tree to
, tree from
)
2041 /* Forward to the end of TOs fields. */
2042 fto
= TYPE_FIELDS (to
);
2043 ffrom
= TYPE_FIELDS (from
);
2044 chain
= &TYPE_FIELDS (to
);
2047 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
2048 chain
= &DECL_CHAIN (fto
);
2049 fto
= DECL_CHAIN (fto
);
2050 ffrom
= DECL_CHAIN (ffrom
);
2053 /* Now add all fields remaining in FROM (starting with ffrom). */
2054 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
2056 tree newfield
= copy_node (ffrom
);
2057 DECL_CONTEXT (newfield
) = to
;
2058 /* The store to DECL_CHAIN might seem redundant with the
2059 stores to *chain, but not clearing it here would mean
2060 leaving a chain into the old fields. If ever
2061 our called functions would look at them confusion
2063 DECL_CHAIN (newfield
) = NULL_TREE
;
2065 chain
= &DECL_CHAIN (newfield
);
2067 if (TREE_CODE (ffrom
) == FIELD_DECL
)
2069 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
2070 TREE_TYPE (newfield
) = elemtype
;
2076 /* Given a type T, returns a different type of the same structure,
2077 except that all types it refers to (recursively) are always
2078 non-restrict qualified types. */
2080 gfc_nonrestricted_type (tree t
)
2084 /* If the type isn't laid out yet, don't copy it. If something
2085 needs it for real it should wait until the type got finished. */
2089 if (!TYPE_LANG_SPECIFIC (t
))
2090 TYPE_LANG_SPECIFIC (t
) = ggc_cleared_alloc
<struct lang_type
> ();
2091 /* If we're dealing with this very node already further up
2092 the call chain (recursion via pointers and struct members)
2093 we haven't yet determined if we really need a new type node.
2094 Assume we don't, return T itself. */
2095 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
2098 /* If we have calculated this all already, just return it. */
2099 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
2100 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
2102 /* Mark this type. */
2103 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2105 switch (TREE_CODE (t
))
2111 case REFERENCE_TYPE
:
2113 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2114 if (totype
== TREE_TYPE (t
))
2116 else if (TREE_CODE (t
) == POINTER_TYPE
)
2117 ret
= build_pointer_type (totype
);
2119 ret
= build_reference_type (totype
);
2120 ret
= build_qualified_type (ret
,
2121 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2127 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2128 if (elemtype
== TREE_TYPE (t
))
2132 ret
= build_variant_type_copy (t
);
2133 TREE_TYPE (ret
) = elemtype
;
2134 if (TYPE_LANG_SPECIFIC (t
)
2135 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2137 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2138 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2139 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2141 TYPE_LANG_SPECIFIC (ret
)
2142 = ggc_cleared_alloc
<struct lang_type
> ();
2143 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2144 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2153 case QUAL_UNION_TYPE
:
2156 /* First determine if we need a new type at all.
2157 Careful, the two calls to gfc_nonrestricted_type per field
2158 might return different values. That happens exactly when
2159 one of the fields reaches back to this very record type
2160 (via pointers). The first calls will assume that we don't
2161 need to copy T (see the error_mark_node marking). If there
2162 are any reasons for copying T apart from having to copy T,
2163 we'll indeed copy it, and the second calls to
2164 gfc_nonrestricted_type will use that new node if they
2166 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2167 if (TREE_CODE (field
) == FIELD_DECL
)
2169 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2170 if (elemtype
!= TREE_TYPE (field
))
2175 ret
= build_variant_type_copy (t
);
2176 TYPE_FIELDS (ret
) = NULL_TREE
;
2178 /* Here we make sure that as soon as we know we have to copy
2179 T, that also fields reaching back to us will use the new
2180 copy. It's okay if that copy still contains the old fields,
2181 we won't look at them. */
2182 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2183 mirror_fields (ret
, t
);
2188 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2193 /* Return the type for a symbol. Special handling is required for character
2194 types to get the correct level of indirection.
2195 For functions return the return type.
2196 For subroutines return void_type_node.
2197 Calling this multiple times for the same symbol should be avoided,
2198 especially for character and array types. */
2201 gfc_sym_type (gfc_symbol
* sym
)
2207 /* Procedure Pointers inside COMMON blocks. */
2208 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2210 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2211 sym
->attr
.proc_pointer
= 0;
2212 type
= build_pointer_type (gfc_get_function_type (sym
));
2213 sym
->attr
.proc_pointer
= 1;
2217 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2218 return void_type_node
;
2220 /* In the case of a function the fake result variable may have a
2221 type different from the function type, so don't return early in
2223 if (sym
->backend_decl
&& !sym
->attr
.function
)
2224 return TREE_TYPE (sym
->backend_decl
);
2226 if (sym
->attr
.result
2227 && sym
->ts
.type
== BT_CHARACTER
2228 && sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
2229 && sym
->ns
->proc_name
2230 && sym
->ns
->proc_name
->ts
.u
.cl
2231 && sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
!= NULL_TREE
)
2232 sym
->ts
.u
.cl
->backend_decl
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2234 if (sym
->ts
.type
== BT_CHARACTER
2235 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2236 || (sym
->attr
.result
2237 && sym
->ns
->proc_name
2238 && sym
->ns
->proc_name
->attr
.is_bind_c
)
2239 || (sym
->ts
.deferred
&& (!sym
->ts
.u
.cl
2240 || !sym
->ts
.u
.cl
->backend_decl
))))
2241 type
= gfc_character1_type_node
;
2243 type
= gfc_typenode_for_spec (&sym
->ts
, sym
->attr
.codimension
);
2245 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2250 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2251 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2253 type
= gfc_nonrestricted_type (type
);
2255 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2257 if (gfc_is_nodesc_array (sym
))
2259 /* If this is a character argument of unknown length, just use the
2261 if (sym
->ts
.type
!= BT_CHARACTER
2262 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2263 || sym
->ts
.u
.cl
->backend_decl
)
2265 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2274 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2275 if (sym
->attr
.pointer
)
2276 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2277 : GFC_ARRAY_POINTER
;
2278 else if (sym
->attr
.allocatable
)
2279 akind
= GFC_ARRAY_ALLOCATABLE
;
2280 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2281 sym
->attr
.contiguous
, false);
2286 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2287 || gfc_is_associate_pointer (sym
))
2288 type
= gfc_build_pointer_type (sym
, type
);
2291 /* We currently pass all parameters by reference.
2292 See f95_get_function_decl. For dummy function parameters return the
2296 /* We must use pointer types for potentially absent variables. The
2297 optimizers assume a reference type argument is never NULL. */
2298 if (sym
->attr
.optional
2299 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2300 type
= build_pointer_type (type
);
2303 type
= build_reference_type (type
);
2305 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2312 /* Layout and output debug info for a record type. */
2315 gfc_finish_type (tree type
)
2319 decl
= build_decl (input_location
,
2320 TYPE_DECL
, NULL_TREE
, type
);
2321 TYPE_STUB_DECL (type
) = decl
;
2323 rest_of_type_compilation (type
, 1);
2324 rest_of_decl_compilation (decl
, 1, 0);
2327 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2328 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2329 to the end of the field list pointed to by *CHAIN.
2331 Returns a pointer to the new field. */
2334 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2336 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2338 DECL_CONTEXT (decl
) = context
;
2339 DECL_CHAIN (decl
) = NULL_TREE
;
2340 if (TYPE_FIELDS (context
) == NULL_TREE
)
2341 TYPE_FIELDS (context
) = decl
;
2346 *chain
= &DECL_CHAIN (decl
);
2352 /* Like `gfc_add_field_to_struct_1', but adds alignment
2356 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2358 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2360 DECL_INITIAL (decl
) = 0;
2361 SET_DECL_ALIGN (decl
, 0);
2362 DECL_USER_ALIGN (decl
) = 0;
2368 /* Copy the backend_decl and component backend_decls if
2369 the two derived type symbols are "equal", as described
2370 in 4.4.2 and resolved by gfc_compare_derived_types. */
2373 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2376 gfc_component
*to_cm
;
2377 gfc_component
*from_cm
;
2382 if (from
->backend_decl
== NULL
2383 || !gfc_compare_derived_types (from
, to
))
2386 to
->backend_decl
= from
->backend_decl
;
2388 to_cm
= to
->components
;
2389 from_cm
= from
->components
;
2391 /* Copy the component declarations. If a component is itself
2392 a derived type, we need a copy of its component declarations.
2393 This is done by recursing into gfc_get_derived_type and
2394 ensures that the component's component declarations have
2395 been built. If it is a character, we need the character
2397 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2399 to_cm
->backend_decl
= from_cm
->backend_decl
;
2400 to_cm
->caf_token
= from_cm
->caf_token
;
2401 if (from_cm
->ts
.type
== BT_UNION
)
2402 gfc_get_union_type (to_cm
->ts
.u
.derived
);
2403 else if (from_cm
->ts
.type
== BT_DERIVED
2404 && (!from_cm
->attr
.pointer
|| from_gsym
))
2405 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2406 else if (from_cm
->ts
.type
== BT_CLASS
2407 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2408 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2409 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2410 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2417 /* Build a tree node for a procedure pointer component. */
2420 gfc_get_ppc_type (gfc_component
* c
)
2424 /* Explicit interface. */
2425 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2426 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2428 /* Implicit interface (only return value may be known). */
2429 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2430 t
= gfc_typenode_for_spec (&c
->ts
);
2434 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2438 /* Build a tree node for a union type. Requires building each map
2439 structure which is an element of the union. */
2442 gfc_get_union_type (gfc_symbol
*un
)
2444 gfc_component
*map
= NULL
;
2445 tree typenode
= NULL
, map_type
= NULL
, map_field
= NULL
;
2448 if (un
->backend_decl
)
2450 if (TYPE_FIELDS (un
->backend_decl
) || un
->attr
.proc_pointer_comp
)
2451 return un
->backend_decl
;
2453 typenode
= un
->backend_decl
;
2457 typenode
= make_node (UNION_TYPE
);
2458 TYPE_NAME (typenode
) = get_identifier (un
->name
);
2461 /* Add each contained MAP as a field. */
2462 for (map
= un
->components
; map
; map
= map
->next
)
2464 gcc_assert (map
->ts
.type
== BT_DERIVED
);
2466 /* The map's type node, which is defined within this union's context. */
2467 map_type
= gfc_get_derived_type (map
->ts
.u
.derived
);
2468 TYPE_CONTEXT (map_type
) = typenode
;
2470 /* The map field's declaration. */
2471 map_field
= gfc_add_field_to_struct(typenode
, get_identifier(map
->name
),
2474 gfc_set_decl_location (map_field
, &map
->loc
);
2475 else if (un
->declared_at
.lb
)
2476 gfc_set_decl_location (map_field
, &un
->declared_at
);
2478 DECL_PACKED (map_field
) |= TYPE_PACKED (typenode
);
2479 DECL_NAMELESS(map_field
) = true;
2481 /* We should never clobber another backend declaration for this map,
2482 because each map component is unique. */
2483 if (!map
->backend_decl
)
2484 map
->backend_decl
= map_field
;
2487 un
->backend_decl
= typenode
;
2488 gfc_finish_type (typenode
);
2494 /* Build a tree node for a derived type. If there are equal
2495 derived types, with different local names, these are built
2496 at the same time. If an equal derived type has been built
2497 in a parent namespace, this is used. */
2500 gfc_get_derived_type (gfc_symbol
* derived
, int codimen
)
2502 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2503 tree canonical
= NULL_TREE
;
2505 bool got_canonical
= false;
2506 bool unlimited_entity
= false;
2512 coarray_flag
= flag_coarray
== GFC_FCOARRAY_LIB
2513 && derived
->module
&& !derived
->attr
.vtype
;
2515 gcc_assert (!derived
->attr
.pdt_template
);
2517 if (derived
->attr
.unlimited_polymorphic
2518 || (flag_coarray
== GFC_FCOARRAY_LIB
2519 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2520 && (derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
2521 || derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2522 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
)))
2523 return ptr_type_node
;
2525 if (flag_coarray
!= GFC_FCOARRAY_LIB
2526 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2527 && (derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2528 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
))
2529 return gfc_get_int_type (gfc_default_integer_kind
);
2531 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2532 && derived
->attr
.generic
)
2533 derived
= gfc_find_dt_in_generic (derived
);
2535 /* See if it's one of the iso_c_binding derived types. */
2536 if (derived
->attr
.is_iso_c
== 1 || derived
->ts
.f90_type
== BT_VOID
)
2538 if (derived
->backend_decl
)
2539 return derived
->backend_decl
;
2541 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2542 derived
->backend_decl
= ptr_type_node
;
2544 derived
->backend_decl
= pfunc_type_node
;
2546 derived
->ts
.kind
= gfc_index_integer_kind
;
2547 derived
->ts
.type
= BT_INTEGER
;
2548 /* Set the f90_type to BT_VOID as a way to recognize something of type
2549 BT_INTEGER that needs to fit a void * for the purpose of the
2550 iso_c_binding derived types. */
2551 derived
->ts
.f90_type
= BT_VOID
;
2553 return derived
->backend_decl
;
2556 /* If use associated, use the module type for this one. */
2557 if (derived
->backend_decl
== NULL
2558 && derived
->attr
.use_assoc
2560 && gfc_get_module_backend_decl (derived
))
2561 goto copy_derived_types
;
2563 /* The derived types from an earlier namespace can be used as the
2565 if (derived
->backend_decl
== NULL
&& !derived
->attr
.use_assoc
2566 && gfc_global_ns_list
)
2568 for (ns
= gfc_global_ns_list
;
2569 ns
->translated
&& !got_canonical
;
2572 if (ns
->derived_types
)
2574 for (gfc_symbol
*dt
= ns
->derived_types
; dt
&& !got_canonical
;
2577 gfc_copy_dt_decls_ifequal (dt
, derived
, true);
2578 if (derived
->backend_decl
)
2579 got_canonical
= true;
2580 if (dt
->dt_next
== ns
->derived_types
)
2587 /* Store up the canonical type to be added to this one. */
2590 if (TYPE_CANONICAL (derived
->backend_decl
))
2591 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2593 canonical
= derived
->backend_decl
;
2595 derived
->backend_decl
= NULL_TREE
;
2598 /* derived->backend_decl != 0 means we saw it before, but its
2599 components' backend_decl may have not been built. */
2600 if (derived
->backend_decl
)
2602 /* Its components' backend_decl have been built or we are
2603 seeing recursion through the formal arglist of a procedure
2604 pointer component. */
2605 if (TYPE_FIELDS (derived
->backend_decl
))
2606 return derived
->backend_decl
;
2607 else if (derived
->attr
.abstract
2608 && derived
->attr
.proc_pointer_comp
)
2610 /* If an abstract derived type with procedure pointer
2611 components has no other type of component, return the
2612 backend_decl. Otherwise build the components if any of the
2613 non-procedure pointer components have no backend_decl. */
2614 for (c
= derived
->components
; c
; c
= c
->next
)
2616 bool same_alloc_type
= c
->attr
.allocatable
2617 && derived
== c
->ts
.u
.derived
;
2618 if (!c
->attr
.proc_pointer
2620 && c
->backend_decl
== NULL
)
2622 else if (c
->next
== NULL
)
2623 return derived
->backend_decl
;
2625 typenode
= derived
->backend_decl
;
2628 typenode
= derived
->backend_decl
;
2632 /* We see this derived type first time, so build the type node. */
2633 typenode
= make_node (RECORD_TYPE
);
2634 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2635 TYPE_PACKED (typenode
) = flag_pack_derived
;
2636 derived
->backend_decl
= typenode
;
2639 if (derived
->components
2640 && derived
->components
->ts
.type
== BT_DERIVED
2641 && strcmp (derived
->components
->name
, "_data") == 0
2642 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2643 unlimited_entity
= true;
2645 /* Go through the derived type components, building them as
2646 necessary. The reason for doing this now is that it is
2647 possible to recurse back to this derived type through a
2648 pointer component (PR24092). If this happens, the fields
2649 will be built and so we can return the type. */
2650 for (c
= derived
->components
; c
; c
= c
->next
)
2652 bool same_alloc_type
= c
->attr
.allocatable
2653 && derived
== c
->ts
.u
.derived
;
2655 if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->backend_decl
== NULL
)
2656 c
->ts
.u
.derived
->backend_decl
= gfc_get_union_type (c
->ts
.u
.derived
);
2658 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2661 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
2662 && !same_alloc_type
)
2663 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2665 int local_codim
= c
->attr
.codimension
? c
->as
->corank
: codimen
;
2666 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
,
2670 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2672 /* Need to copy the modified ts from the derived type. The
2673 typespec was modified because C_PTR/C_FUNPTR are translated
2674 into (void *) from derived types. */
2675 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2676 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2677 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2680 c
->initializer
->ts
.type
= c
->ts
.type
;
2681 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2682 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2683 c
->initializer
->expr_type
= EXPR_NULL
;
2688 if (TYPE_FIELDS (derived
->backend_decl
))
2689 return derived
->backend_decl
;
2691 /* Build the type member list. Install the newly created RECORD_TYPE
2692 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2693 through only the top-level linked list of components so we correctly
2694 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2695 types are built as part of gfc_get_union_type. */
2696 for (c
= derived
->components
; c
; c
= c
->next
)
2698 bool same_alloc_type
= c
->attr
.allocatable
2699 && derived
== c
->ts
.u
.derived
;
2700 /* Prevent infinite recursion, when the procedure pointer type is
2701 the same as derived, by forcing the procedure pointer component to
2702 be built as if the explicit interface does not exist. */
2703 if (c
->attr
.proc_pointer
2704 && (c
->ts
.type
!= BT_DERIVED
|| (c
->ts
.u
.derived
2705 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)))
2706 && (c
->ts
.type
!= BT_CLASS
|| (CLASS_DATA (c
)->ts
.u
.derived
2707 && !gfc_compare_derived_types (derived
, CLASS_DATA (c
)->ts
.u
.derived
))))
2708 field_type
= gfc_get_ppc_type (c
);
2709 else if (c
->attr
.proc_pointer
&& derived
->backend_decl
)
2711 tmp
= build_function_type_list (derived
->backend_decl
, NULL_TREE
);
2712 field_type
= build_pointer_type (tmp
);
2714 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2715 field_type
= c
->ts
.u
.derived
->backend_decl
;
2716 else if (c
->attr
.caf_token
)
2717 field_type
= pvoid_type_node
;
2720 if (c
->ts
.type
== BT_CHARACTER
2721 && !c
->ts
.deferred
&& !c
->attr
.pdt_string
)
2723 /* Evaluate the string length. */
2724 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2725 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2727 else if (c
->ts
.type
== BT_CHARACTER
)
2728 c
->ts
.u
.cl
->backend_decl
2729 = build_int_cst (gfc_charlen_type_node
, 0);
2731 field_type
= gfc_typenode_for_spec (&c
->ts
, codimen
);
2734 /* This returns an array descriptor type. Initialization may be
2736 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2738 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_array
)
2740 enum gfc_array_kind akind
;
2741 if (c
->attr
.pointer
)
2742 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2743 : GFC_ARRAY_POINTER
;
2745 akind
= GFC_ARRAY_ALLOCATABLE
;
2746 /* Pointers to arrays aren't actually pointer types. The
2747 descriptors are separate, but the data is common. */
2748 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2750 && !c
->attr
.pointer
,
2755 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2759 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_string
)
2760 && !c
->attr
.proc_pointer
2761 && !(unlimited_entity
&& c
== derived
->components
))
2762 field_type
= build_pointer_type (field_type
);
2764 if (c
->attr
.pointer
|| same_alloc_type
)
2765 field_type
= gfc_nonrestricted_type (field_type
);
2767 /* vtype fields can point to different types to the base type. */
2768 if (c
->ts
.type
== BT_DERIVED
2769 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2770 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2773 /* Ensure that the CLASS language specific flag is set. */
2774 if (c
->ts
.type
== BT_CLASS
)
2776 if (POINTER_TYPE_P (field_type
))
2777 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2779 GFC_CLASS_TYPE_P (field_type
) = 1;
2782 field
= gfc_add_field_to_struct (typenode
,
2783 get_identifier (c
->name
),
2784 field_type
, &chain
);
2786 gfc_set_decl_location (field
, &c
->loc
);
2787 else if (derived
->declared_at
.lb
)
2788 gfc_set_decl_location (field
, &derived
->declared_at
);
2790 gfc_finish_decl_attrs (field
, &c
->attr
);
2792 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2795 if (!c
->backend_decl
)
2796 c
->backend_decl
= field
;
2798 if (c
->attr
.pointer
&& c
->attr
.dimension
2799 && !(c
->ts
.type
== BT_DERIVED
2800 && strcmp (c
->name
, "_data") == 0))
2801 GFC_DECL_PTR_ARRAY_P (c
->backend_decl
) = 1;
2804 /* Now lay out the derived type, including the fields. */
2806 TYPE_CANONICAL (typenode
) = canonical
;
2808 gfc_finish_type (typenode
);
2809 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2810 if (derived
->module
&& derived
->ns
->proc_name
2811 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2813 if (derived
->ns
->proc_name
->backend_decl
2814 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2817 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2818 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2819 = derived
->ns
->proc_name
->backend_decl
;
2823 derived
->backend_decl
= typenode
;
2827 for (c
= derived
->components
; c
; c
= c
->next
)
2829 /* Do not add a caf_token field for class container components. */
2830 if ((codimen
|| coarray_flag
)
2831 && !c
->attr
.dimension
&& !c
->attr
.codimension
2832 && (c
->attr
.allocatable
|| c
->attr
.pointer
)
2833 && !derived
->attr
.is_class
)
2835 char caf_name
[GFC_MAX_SYMBOL_LEN
];
2836 gfc_component
*token
;
2837 snprintf (caf_name
, GFC_MAX_SYMBOL_LEN
, "_caf_%s", c
->name
);
2838 token
= gfc_find_component (derived
, caf_name
, true, true, NULL
);
2840 c
->caf_token
= token
->backend_decl
;
2841 TREE_NO_WARNING (c
->caf_token
) = 1;
2845 for (gfc_symbol
*dt
= gfc_derived_types
; dt
; dt
= dt
->dt_next
)
2847 gfc_copy_dt_decls_ifequal (derived
, dt
, false);
2848 if (dt
->dt_next
== gfc_derived_types
)
2852 return derived
->backend_decl
;
2857 gfc_return_by_reference (gfc_symbol
* sym
)
2859 if (!sym
->attr
.function
)
2862 if (sym
->attr
.dimension
)
2865 if (sym
->ts
.type
== BT_CHARACTER
2866 && !sym
->attr
.is_bind_c
2867 && (!sym
->attr
.result
2868 || !sym
->ns
->proc_name
2869 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2872 /* Possibly return complex numbers by reference for g77 compatibility.
2873 We don't do this for calls to intrinsics (as the library uses the
2874 -fno-f2c calling convention), nor for calls to functions which always
2875 require an explicit interface, as no compatibility problems can
2877 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2878 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2885 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2889 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2890 gfc_entry_list
*el
, *el2
;
2892 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2893 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2895 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2897 /* Build the type node. */
2898 type
= make_node (UNION_TYPE
);
2900 TYPE_NAME (type
) = get_identifier (name
);
2902 for (el
= ns
->entries
; el
; el
= el
->next
)
2904 /* Search for duplicates. */
2905 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2906 if (el2
->sym
->result
== el
->sym
->result
)
2910 gfc_add_field_to_struct_1 (type
,
2911 get_identifier (el
->sym
->result
->name
),
2912 gfc_sym_type (el
->sym
->result
), &chain
);
2915 /* Finish off the type. */
2916 gfc_finish_type (type
);
2917 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2921 /* Create a "fn spec" based on the formal arguments;
2922 cf. create_function_arglist. */
2925 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2929 gfc_formal_arglist
*f
;
2932 memset (&spec
, 0, sizeof (spec
));
2936 if (sym
->attr
.entry_master
)
2937 spec
[spec_len
++] = 'R';
2938 if (gfc_return_by_reference (sym
))
2940 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2942 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2943 spec
[spec_len
++] = '.';
2945 spec
[spec_len
++] = 'w';
2946 if (sym
->ts
.type
== BT_CHARACTER
)
2947 spec
[spec_len
++] = 'R';
2950 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2951 if (spec_len
< sizeof (spec
))
2953 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2954 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2955 || (f
->sym
->ts
.type
== BT_DERIVED
2956 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2957 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2958 || (f
->sym
->ts
.type
== BT_CLASS
2959 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2960 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2961 spec
[spec_len
++] = '.';
2962 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2963 spec
[spec_len
++] = 'r';
2965 spec
[spec_len
++] = 'w';
2968 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2969 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2970 return build_type_attribute_variant (fntype
, tmp
);
2973 /* Helper function - if we do not find an interface for a procedure,
2974 construct it from the actual arglist. Luckily, this can only
2975 happen for call by reference, so the information we actually need
2976 to provide (and which would be impossible to guess from the call
2977 itself) is not actually needed. */
2980 get_formal_from_actual_arglist (gfc_symbol
*sym
, gfc_actual_arglist
*actual_args
)
2982 gfc_actual_arglist
*a
;
2983 gfc_formal_arglist
**f
;
2985 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2989 for (a
= actual_args
; a
!= NULL
; a
= a
->next
)
2991 (*f
) = gfc_get_formal_arglist ();
2994 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "_formal_%d", var_num
++);
2995 gfc_get_symbol (name
, NULL
, &s
);
2996 if (a
->expr
->ts
.type
== BT_PROCEDURE
)
2998 s
->attr
.flavor
= FL_PROCEDURE
;
3002 s
->ts
= a
->expr
->ts
;
3003 s
->attr
.flavor
= FL_VARIABLE
;
3004 if (a
->expr
->rank
> 0)
3006 s
->attr
.dimension
= 1;
3007 s
->as
= gfc_get_array_spec ();
3008 s
->as
->type
= AS_ASSUMED_SIZE
;
3012 s
->attr
.intent
= INTENT_UNKNOWN
;
3015 else /* If a->expr is NULL, this is an alternate rerturn. */
3023 gfc_get_function_type (gfc_symbol
* sym
, gfc_actual_arglist
*actual_args
)
3026 vec
<tree
, va_gc
> *typelist
= NULL
;
3027 gfc_formal_arglist
*f
;
3029 int alternate_return
= 0;
3030 bool is_varargs
= true;
3032 /* Make sure this symbol is a function, a subroutine or the main
3034 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
3035 || sym
->attr
.flavor
== FL_PROGRAM
);
3037 /* To avoid recursing infinitely on recursive types, we use error_mark_node
3038 so that they can be detected here and handled further down. */
3039 if (sym
->backend_decl
== NULL
)
3040 sym
->backend_decl
= error_mark_node
;
3041 else if (sym
->backend_decl
== error_mark_node
)
3042 goto arg_type_list_done
;
3043 else if (sym
->attr
.proc_pointer
)
3044 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
3046 return TREE_TYPE (sym
->backend_decl
);
3048 if (sym
->attr
.entry_master
)
3049 /* Additional parameter for selecting an entry point. */
3050 vec_safe_push (typelist
, gfc_array_index_type
);
3057 if (arg
->ts
.type
== BT_CHARACTER
)
3058 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3060 /* Some functions we use an extra parameter for the return value. */
3061 if (gfc_return_by_reference (sym
))
3063 type
= gfc_sym_type (arg
);
3064 if (arg
->ts
.type
== BT_COMPLEX
3065 || arg
->attr
.dimension
3066 || arg
->ts
.type
== BT_CHARACTER
)
3067 type
= build_reference_type (type
);
3069 vec_safe_push (typelist
, type
);
3070 if (arg
->ts
.type
== BT_CHARACTER
)
3072 if (!arg
->ts
.deferred
)
3073 /* Transfer by value. */
3074 vec_safe_push (typelist
, gfc_charlen_type_node
);
3076 /* Deferred character lengths are transferred by reference
3077 so that the value can be returned. */
3078 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
3081 if (sym
->backend_decl
== error_mark_node
&& actual_args
!= NULL
3082 && sym
->formal
== NULL
&& (sym
->attr
.proc
== PROC_EXTERNAL
3083 || sym
->attr
.proc
== PROC_UNKNOWN
))
3084 get_formal_from_actual_arglist (sym
, actual_args
);
3086 /* Build the argument types for the function. */
3087 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3092 /* Evaluate constant character lengths here so that they can be
3093 included in the type. */
3094 if (arg
->ts
.type
== BT_CHARACTER
)
3095 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3097 if (arg
->attr
.flavor
== FL_PROCEDURE
)
3099 type
= gfc_get_function_type (arg
);
3100 type
= build_pointer_type (type
);
3103 type
= gfc_sym_type (arg
);
3105 /* Parameter Passing Convention
3107 We currently pass all parameters by reference.
3108 Parameters with INTENT(IN) could be passed by value.
3109 The problem arises if a function is called via an implicit
3110 prototype. In this situation the INTENT is not known.
3111 For this reason all parameters to global functions must be
3112 passed by reference. Passing by value would potentially
3113 generate bad code. Worse there would be no way of telling that
3114 this code was bad, except that it would give incorrect results.
3116 Contained procedures could pass by value as these are never
3117 used without an explicit interface, and cannot be passed as
3118 actual parameters for a dummy procedure. */
3120 vec_safe_push (typelist
, type
);
3124 if (sym
->attr
.subroutine
)
3125 alternate_return
= 1;
3129 /* Add hidden string length parameters. */
3130 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3133 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
3135 if (!arg
->ts
.deferred
)
3136 /* Transfer by value. */
3137 type
= gfc_charlen_type_node
;
3139 /* Deferred character lengths are transferred by reference
3140 so that the value can be returned. */
3141 type
= build_pointer_type (gfc_charlen_type_node
);
3143 vec_safe_push (typelist
, type
);
3147 if (!vec_safe_is_empty (typelist
)
3148 || sym
->attr
.is_main_program
3149 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
3152 if (sym
->backend_decl
== error_mark_node
)
3153 sym
->backend_decl
= NULL_TREE
;
3157 if (alternate_return
)
3158 type
= integer_type_node
;
3159 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
3160 type
= void_type_node
;
3161 else if (sym
->attr
.mixed_entry_master
)
3162 type
= gfc_get_mixed_entry_union (sym
->ns
);
3163 else if (flag_f2c
&& sym
->ts
.type
== BT_REAL
3164 && sym
->ts
.kind
== gfc_default_real_kind
3165 && !sym
->attr
.always_explicit
)
3167 /* Special case: f2c calling conventions require that (scalar)
3168 default REAL functions return the C type double instead. f2c
3169 compatibility is only an issue with functions that don't
3170 require an explicit interface, as only these could be
3171 implemented in Fortran 77. */
3172 sym
->ts
.kind
= gfc_default_double_kind
;
3173 type
= gfc_typenode_for_spec (&sym
->ts
);
3174 sym
->ts
.kind
= gfc_default_real_kind
;
3176 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
3177 /* Procedure pointer return values. */
3179 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
3181 /* Unset proc_pointer as gfc_get_function_type
3182 is called recursively. */
3183 sym
->result
->attr
.proc_pointer
= 0;
3184 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
3185 sym
->result
->attr
.proc_pointer
= 1;
3188 type
= gfc_sym_type (sym
->result
);
3191 type
= gfc_sym_type (sym
);
3194 type
= build_varargs_function_type_vec (type
, typelist
);
3196 type
= build_function_type_vec (type
, typelist
);
3197 type
= create_fn_spec (sym
, type
);
3202 /* Language hooks for middle-end access to type nodes. */
3204 /* Return an integer type with BITS bits of precision,
3205 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3208 gfc_type_for_size (unsigned bits
, int unsignedp
)
3213 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
3215 tree type
= gfc_integer_types
[i
];
3216 if (type
&& bits
== TYPE_PRECISION (type
))
3220 /* Handle TImode as a special case because it is used by some backends
3221 (e.g. ARM) even though it is not available for normal use. */
3222 #if HOST_BITS_PER_WIDE_INT >= 64
3223 if (bits
== TYPE_PRECISION (intTI_type_node
))
3224 return intTI_type_node
;
3227 if (bits
<= TYPE_PRECISION (intQI_type_node
))
3228 return intQI_type_node
;
3229 if (bits
<= TYPE_PRECISION (intHI_type_node
))
3230 return intHI_type_node
;
3231 if (bits
<= TYPE_PRECISION (intSI_type_node
))
3232 return intSI_type_node
;
3233 if (bits
<= TYPE_PRECISION (intDI_type_node
))
3234 return intDI_type_node
;
3235 if (bits
<= TYPE_PRECISION (intTI_type_node
))
3236 return intTI_type_node
;
3240 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
3241 return unsigned_intQI_type_node
;
3242 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
3243 return unsigned_intHI_type_node
;
3244 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
3245 return unsigned_intSI_type_node
;
3246 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
3247 return unsigned_intDI_type_node
;
3248 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
3249 return unsigned_intTI_type_node
;
3255 /* Return a data type that has machine mode MODE. If the mode is an
3256 integer, then UNSIGNEDP selects between signed and unsigned types. */
3259 gfc_type_for_mode (machine_mode mode
, int unsignedp
)
3263 scalar_int_mode int_mode
;
3265 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
3266 base
= gfc_real_types
;
3267 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
3268 base
= gfc_complex_types
;
3269 else if (is_a
<scalar_int_mode
> (mode
, &int_mode
))
3271 tree type
= gfc_type_for_size (GET_MODE_PRECISION (int_mode
), unsignedp
);
3272 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
3274 else if (GET_MODE_CLASS (mode
) == MODE_VECTOR_BOOL
3275 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3277 unsigned int elem_bits
= vector_element_size (GET_MODE_BITSIZE (mode
),
3278 GET_MODE_NUNITS (mode
));
3279 tree bool_type
= build_nonstandard_boolean_type (elem_bits
);
3280 return build_vector_type_for_mode (bool_type
, mode
);
3282 else if (VECTOR_MODE_P (mode
)
3283 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3285 machine_mode inner_mode
= GET_MODE_INNER (mode
);
3286 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
3287 if (inner_type
!= NULL_TREE
)
3288 return build_vector_type_for_mode (inner_type
, mode
);
3294 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
3296 tree type
= base
[i
];
3297 if (type
&& mode
== TYPE_MODE (type
))
3304 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3308 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
3311 bool indirect
= false;
3312 tree etype
, ptype
, t
, base_decl
;
3313 tree data_off
, dim_off
, dtype_off
, dim_size
, elem_size
;
3314 tree lower_suboff
, upper_suboff
, stride_suboff
;
3315 tree dtype
, field
, rank_off
;
3317 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3319 if (! POINTER_TYPE_P (type
))
3321 type
= TREE_TYPE (type
);
3322 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3327 rank
= GFC_TYPE_ARRAY_RANK (type
);
3328 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3331 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3332 gcc_assert (POINTER_TYPE_P (etype
));
3333 etype
= TREE_TYPE (etype
);
3335 /* If the type is not a scalar coarray. */
3336 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3337 etype
= TREE_TYPE (etype
);
3339 /* Can't handle variable sized elements yet. */
3340 if (int_size_in_bytes (etype
) <= 0)
3342 /* Nor non-constant lower bounds in assumed shape arrays. */
3343 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3344 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3346 for (dim
= 0; dim
< rank
; dim
++)
3347 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3348 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3352 memset (info
, '\0', sizeof (*info
));
3353 info
->ndimensions
= rank
;
3354 info
->ordering
= array_descr_ordering_column_major
;
3355 info
->element_type
= etype
;
3356 ptype
= build_pointer_type (gfc_array_index_type
);
3357 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3360 base_decl
= make_node (DEBUG_EXPR_DECL
);
3361 DECL_ARTIFICIAL (base_decl
) = 1;
3362 TREE_TYPE (base_decl
) = indirect
? build_pointer_type (ptype
) : ptype
;
3363 SET_DECL_MODE (base_decl
, TYPE_MODE (TREE_TYPE (base_decl
)));
3364 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3366 info
->base_decl
= base_decl
;
3368 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3370 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
3372 gfc_get_descriptor_offsets_for_info (type
, &data_off
, &dtype_off
, &dim_off
,
3373 &dim_size
, &stride_suboff
,
3374 &lower_suboff
, &upper_suboff
);
3377 if (!integer_zerop (data_off
))
3378 t
= fold_build_pointer_plus (t
, data_off
);
3379 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3380 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3381 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3382 info
->allocated
= build2 (NE_EXPR
, logical_type_node
,
3383 info
->data_location
, null_pointer_node
);
3384 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3385 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3386 info
->associated
= build2 (NE_EXPR
, logical_type_node
,
3387 info
->data_location
, null_pointer_node
);
3388 if ((GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK
3389 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
)
3390 && dwarf_version
>= 5)
3393 info
->ndimensions
= 1;
3395 if (!integer_zerop (dtype_off
))
3396 t
= fold_build_pointer_plus (t
, dtype_off
);
3397 dtype
= TYPE_MAIN_VARIANT (get_dtype_type_node ());
3398 field
= gfc_advance_chain (TYPE_FIELDS (dtype
), GFC_DTYPE_RANK
);
3399 rank_off
= byte_position (field
);
3400 if (!integer_zerop (dtype_off
))
3401 t
= fold_build_pointer_plus (t
, rank_off
);
3403 t
= build1 (NOP_EXPR
, build_pointer_type (gfc_array_index_type
), t
);
3404 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3406 t
= build0 (PLACEHOLDER_EXPR
, TREE_TYPE (dim_off
));
3407 t
= size_binop (MULT_EXPR
, t
, dim_size
);
3408 dim_off
= build2 (PLUS_EXPR
, TREE_TYPE (dim_off
), t
, dim_off
);
3411 for (dim
= 0; dim
< rank
; dim
++)
3413 t
= fold_build_pointer_plus (base_decl
,
3414 size_binop (PLUS_EXPR
,
3415 dim_off
, lower_suboff
));
3416 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3417 info
->dimen
[dim
].lower_bound
= t
;
3418 t
= fold_build_pointer_plus (base_decl
,
3419 size_binop (PLUS_EXPR
,
3420 dim_off
, upper_suboff
));
3421 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3422 info
->dimen
[dim
].upper_bound
= t
;
3423 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3424 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3426 /* Assumed shape arrays have known lower bounds. */
3427 info
->dimen
[dim
].upper_bound
3428 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3429 info
->dimen
[dim
].upper_bound
,
3430 info
->dimen
[dim
].lower_bound
);
3431 info
->dimen
[dim
].lower_bound
3432 = fold_convert (gfc_array_index_type
,
3433 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3434 info
->dimen
[dim
].upper_bound
3435 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3436 info
->dimen
[dim
].lower_bound
,
3437 info
->dimen
[dim
].upper_bound
);
3439 t
= fold_build_pointer_plus (base_decl
,
3440 size_binop (PLUS_EXPR
,
3441 dim_off
, stride_suboff
));
3442 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3443 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3444 info
->dimen
[dim
].stride
= t
;
3446 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3453 /* Create a type to handle vector subscripts for coarray library calls. It
3455 struct caf_vector_t {
3456 size_t nvec; // size of the vector
3463 ptrdiff_t lower_bound;
3464 ptrdiff_t upper_bound;
3469 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3470 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3473 gfc_get_caf_vector_type (int dim
)
3475 static tree vector_types
[GFC_MAX_DIMENSIONS
];
3476 static tree vec_type
= NULL_TREE
;
3477 tree triplet_struct_type
, vect_struct_type
, union_type
, tmp
, *chain
;
3479 if (vector_types
[dim
-1] != NULL_TREE
)
3480 return vector_types
[dim
-1];
3482 if (vec_type
== NULL_TREE
)
3485 vect_struct_type
= make_node (RECORD_TYPE
);
3486 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3487 get_identifier ("vector"),
3488 pvoid_type_node
, &chain
);
3489 TREE_NO_WARNING (tmp
) = 1;
3490 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3491 get_identifier ("kind"),
3492 integer_type_node
, &chain
);
3493 TREE_NO_WARNING (tmp
) = 1;
3494 gfc_finish_type (vect_struct_type
);
3497 triplet_struct_type
= make_node (RECORD_TYPE
);
3498 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3499 get_identifier ("lower_bound"),
3500 gfc_array_index_type
, &chain
);
3501 TREE_NO_WARNING (tmp
) = 1;
3502 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3503 get_identifier ("upper_bound"),
3504 gfc_array_index_type
, &chain
);
3505 TREE_NO_WARNING (tmp
) = 1;
3506 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
, get_identifier ("stride"),
3507 gfc_array_index_type
, &chain
);
3508 TREE_NO_WARNING (tmp
) = 1;
3509 gfc_finish_type (triplet_struct_type
);
3512 union_type
= make_node (UNION_TYPE
);
3513 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3514 vect_struct_type
, &chain
);
3515 TREE_NO_WARNING (tmp
) = 1;
3516 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("triplet"),
3517 triplet_struct_type
, &chain
);
3518 TREE_NO_WARNING (tmp
) = 1;
3519 gfc_finish_type (union_type
);
3522 vec_type
= make_node (RECORD_TYPE
);
3523 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("nvec"),
3524 size_type_node
, &chain
);
3525 TREE_NO_WARNING (tmp
) = 1;
3526 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("u"),
3527 union_type
, &chain
);
3528 TREE_NO_WARNING (tmp
) = 1;
3529 gfc_finish_type (vec_type
);
3530 TYPE_NAME (vec_type
) = get_identifier ("caf_vector_t");
3533 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3534 gfc_rank_cst
[dim
-1]);
3535 vector_types
[dim
-1] = build_array_type (vec_type
, tmp
);
3536 return vector_types
[dim
-1];
3541 gfc_get_caf_reference_type ()
3543 static tree reference_type
= NULL_TREE
;
3544 tree c_struct_type
, s_struct_type
, v_struct_type
, union_type
, dim_union_type
,
3545 a_struct_type
, u_union_type
, tmp
, *chain
;
3547 if (reference_type
!= NULL_TREE
)
3548 return reference_type
;
3551 c_struct_type
= make_node (RECORD_TYPE
);
3552 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3553 get_identifier ("offset"),
3554 gfc_array_index_type
, &chain
);
3555 TREE_NO_WARNING (tmp
) = 1;
3556 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3557 get_identifier ("caf_token_offset"),
3558 gfc_array_index_type
, &chain
);
3559 TREE_NO_WARNING (tmp
) = 1;
3560 gfc_finish_type (c_struct_type
);
3563 s_struct_type
= make_node (RECORD_TYPE
);
3564 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3565 get_identifier ("start"),
3566 gfc_array_index_type
, &chain
);
3567 TREE_NO_WARNING (tmp
) = 1;
3568 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3569 get_identifier ("end"),
3570 gfc_array_index_type
, &chain
);
3571 TREE_NO_WARNING (tmp
) = 1;
3572 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3573 get_identifier ("stride"),
3574 gfc_array_index_type
, &chain
);
3575 TREE_NO_WARNING (tmp
) = 1;
3576 gfc_finish_type (s_struct_type
);
3579 v_struct_type
= make_node (RECORD_TYPE
);
3580 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3581 get_identifier ("vector"),
3582 pvoid_type_node
, &chain
);
3583 TREE_NO_WARNING (tmp
) = 1;
3584 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3585 get_identifier ("nvec"),
3586 size_type_node
, &chain
);
3587 TREE_NO_WARNING (tmp
) = 1;
3588 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3589 get_identifier ("kind"),
3590 integer_type_node
, &chain
);
3591 TREE_NO_WARNING (tmp
) = 1;
3592 gfc_finish_type (v_struct_type
);
3595 union_type
= make_node (UNION_TYPE
);
3596 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("s"),
3597 s_struct_type
, &chain
);
3598 TREE_NO_WARNING (tmp
) = 1;
3599 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3600 v_struct_type
, &chain
);
3601 TREE_NO_WARNING (tmp
) = 1;
3602 gfc_finish_type (union_type
);
3604 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3605 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1]);
3606 dim_union_type
= build_array_type (union_type
, tmp
);
3609 a_struct_type
= make_node (RECORD_TYPE
);
3610 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("mode"),
3611 build_array_type (unsigned_char_type_node
,
3612 build_range_type (gfc_array_index_type
,
3613 gfc_index_zero_node
,
3614 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1])),
3616 TREE_NO_WARNING (tmp
) = 1;
3617 tmp
= gfc_add_field_to_struct_1 (a_struct_type
,
3618 get_identifier ("static_array_type"),
3619 integer_type_node
, &chain
);
3620 TREE_NO_WARNING (tmp
) = 1;
3621 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("dim"),
3622 dim_union_type
, &chain
);
3623 TREE_NO_WARNING (tmp
) = 1;
3624 gfc_finish_type (a_struct_type
);
3627 u_union_type
= make_node (UNION_TYPE
);
3628 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("c"),
3629 c_struct_type
, &chain
);
3630 TREE_NO_WARNING (tmp
) = 1;
3631 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("a"),
3632 a_struct_type
, &chain
);
3633 TREE_NO_WARNING (tmp
) = 1;
3634 gfc_finish_type (u_union_type
);
3637 reference_type
= make_node (RECORD_TYPE
);
3638 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("next"),
3639 build_pointer_type (reference_type
), &chain
);
3640 TREE_NO_WARNING (tmp
) = 1;
3641 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("type"),
3642 integer_type_node
, &chain
);
3643 TREE_NO_WARNING (tmp
) = 1;
3644 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("item_size"),
3645 size_type_node
, &chain
);
3646 TREE_NO_WARNING (tmp
) = 1;
3647 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("u"),
3648 u_union_type
, &chain
);
3649 TREE_NO_WARNING (tmp
) = 1;
3650 gfc_finish_type (reference_type
);
3651 TYPE_NAME (reference_type
) = get_identifier ("caf_reference_t");
3653 return reference_type
;
3656 #include "gt-fortran-trans-types.h"