1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2018 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
;
221 /* Return a typenode for the "standard" C type with a given name. */
223 get_typenode_from_name (const char *name
)
225 if (name
== NULL
|| *name
== '\0')
228 if (strcmp (name
, "char") == 0)
229 return char_type_node
;
230 if (strcmp (name
, "unsigned char") == 0)
231 return unsigned_char_type_node
;
232 if (strcmp (name
, "signed char") == 0)
233 return signed_char_type_node
;
235 if (strcmp (name
, "short int") == 0)
236 return short_integer_type_node
;
237 if (strcmp (name
, "short unsigned int") == 0)
238 return short_unsigned_type_node
;
240 if (strcmp (name
, "int") == 0)
241 return integer_type_node
;
242 if (strcmp (name
, "unsigned int") == 0)
243 return unsigned_type_node
;
245 if (strcmp (name
, "long int") == 0)
246 return long_integer_type_node
;
247 if (strcmp (name
, "long unsigned int") == 0)
248 return long_unsigned_type_node
;
250 if (strcmp (name
, "long long int") == 0)
251 return long_long_integer_type_node
;
252 if (strcmp (name
, "long long unsigned int") == 0)
253 return long_long_unsigned_type_node
;
259 get_int_kind_from_name (const char *name
)
261 return get_int_kind_from_node (get_typenode_from_name (name
));
265 /* Get the kind number corresponding to an integer of given size,
266 following the required return values for ISO_FORTRAN_ENV INT* constants:
267 -2 is returned if we support a kind of larger size, -1 otherwise. */
269 gfc_get_int_kind_from_width_isofortranenv (int size
)
273 /* Look for a kind with matching storage size. */
274 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
275 if (gfc_integer_kinds
[i
].bit_size
== size
)
276 return gfc_integer_kinds
[i
].kind
;
278 /* Look for a kind with larger storage size. */
279 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
280 if (gfc_integer_kinds
[i
].bit_size
> size
)
287 /* Get the kind number corresponding to a real of a given storage size.
288 If two real's have the same storage size, then choose the real with
289 the largest precision. If a kind type is unavailable and a real
290 exists with wider storage, then return -2; otherwise, return -1. */
293 gfc_get_real_kind_from_width_isofortranenv (int size
)
302 /* Look for a kind with matching storage size. */
303 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
304 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
306 if (gfc_real_kinds
[i
].digits
> digits
)
308 digits
= gfc_real_kinds
[i
].digits
;
309 kind
= gfc_real_kinds
[i
].kind
;
316 /* Look for a kind with larger storage size. */
317 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
318 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
327 get_int_kind_from_width (int size
)
331 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
332 if (gfc_integer_kinds
[i
].bit_size
== size
)
333 return gfc_integer_kinds
[i
].kind
;
339 get_int_kind_from_minimal_width (int size
)
343 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
344 if (gfc_integer_kinds
[i
].bit_size
>= size
)
345 return gfc_integer_kinds
[i
].kind
;
351 /* Generate the CInteropKind_t objects for the C interoperable
355 gfc_init_c_interop_kinds (void)
359 /* init all pointers in the list to NULL */
360 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
362 /* Initialize the name and value fields. */
363 c_interop_kinds_table
[i
].name
[0] = '\0';
364 c_interop_kinds_table
[i
].value
= -100;
365 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
368 #define NAMED_INTCST(a,b,c,d) \
369 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
370 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
371 c_interop_kinds_table[a].value = c;
372 #define NAMED_REALCST(a,b,c,d) \
373 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
374 c_interop_kinds_table[a].f90_type = BT_REAL; \
375 c_interop_kinds_table[a].value = c;
376 #define NAMED_CMPXCST(a,b,c,d) \
377 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
378 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
379 c_interop_kinds_table[a].value = c;
380 #define NAMED_LOGCST(a,b,c) \
381 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
382 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
383 c_interop_kinds_table[a].value = c;
384 #define NAMED_CHARKNDCST(a,b,c) \
385 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
386 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
387 c_interop_kinds_table[a].value = c;
388 #define NAMED_CHARCST(a,b,c) \
389 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
390 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
391 c_interop_kinds_table[a].value = c;
392 #define DERIVED_TYPE(a,b,c) \
393 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
394 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
395 c_interop_kinds_table[a].value = c;
396 #define NAMED_FUNCTION(a,b,c,d) \
397 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
398 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
399 c_interop_kinds_table[a].value = c;
400 #define NAMED_SUBROUTINE(a,b,c,d) \
401 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
402 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
403 c_interop_kinds_table[a].value = c;
404 #include "iso-c-binding.def"
408 /* Query the target to determine which machine modes are available for
409 computation. Choose KIND numbers for them. */
412 gfc_init_kinds (void)
414 opt_scalar_int_mode int_mode_iter
;
415 opt_scalar_float_mode float_mode_iter
;
416 int i_index
, r_index
, kind
;
417 bool saw_i4
= false, saw_i8
= false;
418 bool saw_r4
= false, saw_r8
= false, saw_r10
= false, saw_r16
= false;
421 FOR_EACH_MODE_IN_CLASS (int_mode_iter
, MODE_INT
)
423 scalar_int_mode mode
= int_mode_iter
.require ();
426 if (!targetm
.scalar_mode_supported_p (mode
))
429 /* The middle end doesn't support constants larger than 2*HWI.
430 Perhaps the target hook shouldn't have accepted these either,
431 but just to be safe... */
432 bitsize
= GET_MODE_BITSIZE (mode
);
433 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
436 gcc_assert (i_index
!= MAX_INT_KINDS
);
438 /* Let the kind equal the bit size divided by 8. This insulates the
439 programmer from the underlying byte size. */
447 gfc_integer_kinds
[i_index
].kind
= kind
;
448 gfc_integer_kinds
[i_index
].radix
= 2;
449 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
450 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
452 gfc_logical_kinds
[i_index
].kind
= kind
;
453 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
458 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
459 used for large file access. */
466 /* If we do not at least have kind = 4, everything is pointless. */
469 /* Set the maximum integer kind. Used with at least BOZ constants. */
470 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
473 FOR_EACH_MODE_IN_CLASS (float_mode_iter
, MODE_FLOAT
)
475 scalar_float_mode mode
= float_mode_iter
.require ();
476 const struct real_format
*fmt
= REAL_MODE_FORMAT (mode
);
481 if (!targetm
.scalar_mode_supported_p (mode
))
484 /* Only let float, double, long double and __float128 go through.
485 Runtime support for others is not provided, so they would be
487 if (!targetm
.libgcc_floating_mode_supported_p (mode
))
489 if (mode
!= TYPE_MODE (float_type_node
)
490 && (mode
!= TYPE_MODE (double_type_node
))
491 && (mode
!= TYPE_MODE (long_double_type_node
))
492 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
498 /* Let the kind equal the precision divided by 8, rounding up. Again,
499 this insulates the programmer from the underlying byte size.
501 Also, it effectively deals with IEEE extended formats. There, the
502 total size of the type may equal 16, but it's got 6 bytes of padding
503 and the increased size can get in the way of a real IEEE quad format
504 which may also be supported by the target.
506 We round up so as to handle IA-64 __floatreg (RFmode), which is an
507 82 bit type. Not to be confused with __float80 (XFmode), which is
508 an 80 bit type also supported by IA-64. So XFmode should come out
509 to be kind=10, and RFmode should come out to be kind=11. Egads. */
511 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
522 /* Careful we don't stumble a weird internal mode. */
523 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
524 /* Or have too many modes for the allocated space. */
525 gcc_assert (r_index
!= MAX_REAL_KINDS
);
527 gfc_real_kinds
[r_index
].kind
= kind
;
528 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
529 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
530 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
531 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
532 if (fmt
->pnan
< fmt
->p
)
533 /* This is an IBM extended double format (or the MIPS variant)
534 made up of two IEEE doubles. The value of the long double is
535 the sum of the values of the two parts. The most significant
536 part is required to be the value of the long double rounded
537 to the nearest double. If we use emax of 1024 then we can't
538 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
539 rounding will make the most significant part overflow. */
540 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
541 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
545 /* Choose the default integer kind. We choose 4 unless the user directs us
546 otherwise. Even if the user specified that the default integer kind is 8,
547 the numeric storage size is not 64 bits. In this case, a warning will be
548 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
550 gfc_numeric_storage_size
= 4 * 8;
552 if (flag_default_integer
)
555 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
556 "%<-fdefault-integer-8%> option");
558 gfc_default_integer_kind
= 8;
561 else if (flag_integer4_kind
== 8)
564 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
565 "%<-finteger-4-integer-8%> option");
567 gfc_default_integer_kind
= 8;
571 gfc_default_integer_kind
= 4;
575 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
576 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
579 /* Choose the default real kind. Again, we choose 4 when possible. */
580 if (flag_default_real_8
)
583 gfc_fatal_error ("REAL(KIND=8) is not available for "
584 "%<-fdefault-real-8%> option");
586 gfc_default_real_kind
= 8;
588 else if (flag_default_real_10
)
591 gfc_fatal_error ("REAL(KIND=10) is not available for "
592 "%<-fdefault-real-10%> option");
594 gfc_default_real_kind
= 10;
596 else if (flag_default_real_16
)
599 gfc_fatal_error ("REAL(KIND=16) is not available for "
600 "%<-fdefault-real-16%> option");
602 gfc_default_real_kind
= 16;
604 else if (flag_real4_kind
== 8)
607 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
610 gfc_default_real_kind
= 8;
612 else if (flag_real4_kind
== 10)
615 gfc_fatal_error ("REAL(KIND=10) is not available for "
616 "%<-freal-4-real-10%> option");
618 gfc_default_real_kind
= 10;
620 else if (flag_real4_kind
== 16)
623 gfc_fatal_error ("REAL(KIND=16) is not available for "
624 "%<-freal-4-real-16%> option");
626 gfc_default_real_kind
= 16;
629 gfc_default_real_kind
= 4;
631 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
633 /* Choose the default double kind. If -fdefault-real and -fdefault-double
634 are specified, we use kind=8, if it's available. If -fdefault-real is
635 specified without -fdefault-double, we use kind=16, if it's available.
636 Otherwise we do not change anything. */
637 if (flag_default_double
&& saw_r8
)
638 gfc_default_double_kind
= 8;
639 else if (flag_default_real_8
|| flag_default_real_10
|| flag_default_real_16
)
641 /* Use largest available kind. */
643 gfc_default_double_kind
= 16;
645 gfc_default_double_kind
= 10;
647 gfc_default_double_kind
= 8;
649 gfc_default_double_kind
= gfc_default_real_kind
;
651 else if (flag_real8_kind
== 4)
654 gfc_fatal_error ("REAL(KIND=4) is not available for "
655 "%<-freal-8-real-4%> option");
657 gfc_default_double_kind
= 4;
659 else if (flag_real8_kind
== 10 )
662 gfc_fatal_error ("REAL(KIND=10) is not available for "
663 "%<-freal-8-real-10%> option");
665 gfc_default_double_kind
= 10;
667 else if (flag_real8_kind
== 16 )
670 gfc_fatal_error ("REAL(KIND=10) is not available for "
671 "%<-freal-8-real-16%> option");
673 gfc_default_double_kind
= 16;
675 else if (saw_r4
&& saw_r8
)
676 gfc_default_double_kind
= 8;
679 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
680 real ... occupies two contiguous numeric storage units.
682 Therefore we must be supplied a kind twice as large as we chose
683 for single precision. There are loopholes, in that double
684 precision must *occupy* two storage units, though it doesn't have
685 to *use* two storage units. Which means that you can make this
686 kind artificially wide by padding it. But at present there are
687 no GCC targets for which a two-word type does not exist, so we
688 just let gfc_validate_kind abort and tell us if something breaks. */
690 gfc_default_double_kind
691 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
694 /* The default logical kind is constrained to be the same as the
695 default integer kind. Similarly with complex and real. */
696 gfc_default_logical_kind
= gfc_default_integer_kind
;
697 gfc_default_complex_kind
= gfc_default_real_kind
;
699 /* We only have two character kinds: ASCII and UCS-4.
700 ASCII corresponds to a 8-bit integer type, if one is available.
701 UCS-4 corresponds to a 32-bit integer type, if one is available. */
703 if ((kind
= get_int_kind_from_width (8)) > 0)
705 gfc_character_kinds
[i_index
].kind
= kind
;
706 gfc_character_kinds
[i_index
].bit_size
= 8;
707 gfc_character_kinds
[i_index
].name
= "ascii";
710 if ((kind
= get_int_kind_from_width (32)) > 0)
712 gfc_character_kinds
[i_index
].kind
= kind
;
713 gfc_character_kinds
[i_index
].bit_size
= 32;
714 gfc_character_kinds
[i_index
].name
= "iso_10646";
718 /* Choose the smallest integer kind for our default character. */
719 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
720 gfc_character_storage_size
= gfc_default_character_kind
* 8;
722 gfc_index_integer_kind
= get_int_kind_from_name (PTRDIFF_TYPE
);
724 /* Pick a kind the same size as the C "int" type. */
725 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
727 /* Choose atomic kinds to match C's int. */
728 gfc_atomic_int_kind
= gfc_c_int_kind
;
729 gfc_atomic_logical_kind
= gfc_c_int_kind
;
733 /* Make sure that a valid kind is present. Returns an index into the
734 associated kinds array, -1 if the kind is not present. */
737 validate_integer (int kind
)
741 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
742 if (gfc_integer_kinds
[i
].kind
== kind
)
749 validate_real (int kind
)
753 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
754 if (gfc_real_kinds
[i
].kind
== kind
)
761 validate_logical (int kind
)
765 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
766 if (gfc_logical_kinds
[i
].kind
== kind
)
773 validate_character (int kind
)
777 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
778 if (gfc_character_kinds
[i
].kind
== kind
)
784 /* Validate a kind given a basic type. The return value is the same
785 for the child functions, with -1 indicating nonexistence of the
786 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
789 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
795 case BT_REAL
: /* Fall through */
797 rc
= validate_real (kind
);
800 rc
= validate_integer (kind
);
803 rc
= validate_logical (kind
);
806 rc
= validate_character (kind
);
810 gfc_internal_error ("gfc_validate_kind(): Got bad type");
813 if (rc
< 0 && !may_fail
)
814 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
820 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
821 Reuse common type nodes where possible. Recognize if the kind matches up
822 with a C type. This will be used later in determining which routines may
823 be scarfed from libm. */
826 gfc_build_int_type (gfc_integer_info
*info
)
828 int mode_precision
= info
->bit_size
;
830 if (mode_precision
== CHAR_TYPE_SIZE
)
832 if (mode_precision
== SHORT_TYPE_SIZE
)
834 if (mode_precision
== INT_TYPE_SIZE
)
836 if (mode_precision
== LONG_TYPE_SIZE
)
838 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
839 info
->c_long_long
= 1;
841 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
842 return intQI_type_node
;
843 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
844 return intHI_type_node
;
845 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
846 return intSI_type_node
;
847 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
848 return intDI_type_node
;
849 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
850 return intTI_type_node
;
852 return make_signed_type (mode_precision
);
856 gfc_build_uint_type (int size
)
858 if (size
== CHAR_TYPE_SIZE
)
859 return unsigned_char_type_node
;
860 if (size
== SHORT_TYPE_SIZE
)
861 return short_unsigned_type_node
;
862 if (size
== INT_TYPE_SIZE
)
863 return unsigned_type_node
;
864 if (size
== LONG_TYPE_SIZE
)
865 return long_unsigned_type_node
;
866 if (size
== LONG_LONG_TYPE_SIZE
)
867 return long_long_unsigned_type_node
;
869 return make_unsigned_type (size
);
874 gfc_build_real_type (gfc_real_info
*info
)
876 int mode_precision
= info
->mode_precision
;
879 if (mode_precision
== FLOAT_TYPE_SIZE
)
881 if (mode_precision
== DOUBLE_TYPE_SIZE
)
883 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
884 info
->c_long_double
= 1;
885 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
887 info
->c_float128
= 1;
888 gfc_real16_is_float128
= true;
891 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
892 return float_type_node
;
893 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
894 return double_type_node
;
895 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
896 return long_double_type_node
;
898 new_type
= make_node (REAL_TYPE
);
899 TYPE_PRECISION (new_type
) = mode_precision
;
900 layout_type (new_type
);
905 gfc_build_complex_type (tree scalar_type
)
909 if (scalar_type
== NULL
)
911 if (scalar_type
== float_type_node
)
912 return complex_float_type_node
;
913 if (scalar_type
== double_type_node
)
914 return complex_double_type_node
;
915 if (scalar_type
== long_double_type_node
)
916 return complex_long_double_type_node
;
918 new_type
= make_node (COMPLEX_TYPE
);
919 TREE_TYPE (new_type
) = scalar_type
;
920 layout_type (new_type
);
925 gfc_build_logical_type (gfc_logical_info
*info
)
927 int bit_size
= info
->bit_size
;
930 if (bit_size
== BOOL_TYPE_SIZE
)
933 return boolean_type_node
;
936 new_type
= make_unsigned_type (bit_size
);
937 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
938 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
939 TYPE_PRECISION (new_type
) = 1;
945 /* Create the backend type nodes. We map them to their
946 equivalent C type, at least for now. We also give
947 names to the types here, and we push them in the
948 global binding level context.*/
951 gfc_init_types (void)
958 /* Create and name the types. */
959 #define PUSH_TYPE(name, node) \
960 pushdecl (build_decl (input_location, \
961 TYPE_DECL, get_identifier (name), node))
963 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
965 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
966 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
967 if (TYPE_STRING_FLAG (type
))
968 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
969 gfc_integer_types
[index
] = type
;
970 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
971 gfc_integer_kinds
[index
].kind
);
972 PUSH_TYPE (name_buf
, type
);
975 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
977 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
978 gfc_logical_types
[index
] = type
;
979 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
980 gfc_logical_kinds
[index
].kind
);
981 PUSH_TYPE (name_buf
, type
);
984 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
986 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
987 gfc_real_types
[index
] = type
;
988 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
989 gfc_real_kinds
[index
].kind
);
990 PUSH_TYPE (name_buf
, type
);
992 if (gfc_real_kinds
[index
].c_float128
)
993 gfc_float128_type_node
= type
;
995 type
= gfc_build_complex_type (type
);
996 gfc_complex_types
[index
] = type
;
997 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
998 gfc_real_kinds
[index
].kind
);
999 PUSH_TYPE (name_buf
, type
);
1001 if (gfc_real_kinds
[index
].c_float128
)
1002 gfc_complex_float128_type_node
= type
;
1005 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
1007 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
1008 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
1009 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
1010 gfc_character_kinds
[index
].kind
);
1011 PUSH_TYPE (name_buf
, type
);
1012 gfc_character_types
[index
] = type
;
1013 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
1015 gfc_character1_type_node
= gfc_character_types
[0];
1017 PUSH_TYPE ("byte", unsigned_char_type_node
);
1018 PUSH_TYPE ("void", void_type_node
);
1020 /* DBX debugging output gets upset if these aren't set. */
1021 if (!TYPE_NAME (integer_type_node
))
1022 PUSH_TYPE ("c_integer", integer_type_node
);
1023 if (!TYPE_NAME (char_type_node
))
1024 PUSH_TYPE ("c_char", char_type_node
);
1028 pvoid_type_node
= build_pointer_type (void_type_node
);
1029 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
1030 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
1031 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
1033 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
1035 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
1036 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
1037 since this function is called before gfc_init_constants. */
1038 gfc_array_range_type
1039 = build_range_type (gfc_array_index_type
,
1040 build_int_cst (gfc_array_index_type
, 0),
1043 /* The maximum array element size that can be handled is determined
1044 by the number of bits available to store this field in the array
1047 n
= TYPE_PRECISION (size_type_node
);
1048 gfc_max_array_element_size
1049 = wide_int_to_tree (size_type_node
,
1050 wi::mask (n
, UNSIGNED
,
1051 TYPE_PRECISION (size_type_node
)));
1053 logical_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
1054 logical_true_node
= build_int_cst (logical_type_node
, 1);
1055 logical_false_node
= build_int_cst (logical_type_node
, 0);
1057 /* Character lengths are of type size_t, except signed. */
1058 gfc_charlen_int_kind
= get_int_kind_from_node (size_type_node
);
1059 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
1061 /* Fortran kind number of size_type_node (size_t). This is used for
1062 the _size member in vtables. */
1063 gfc_size_kind
= get_int_kind_from_node (size_type_node
);
1066 /* Get the type node for the given type and kind. */
1069 gfc_get_int_type (int kind
)
1071 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
1072 return index
< 0 ? 0 : gfc_integer_types
[index
];
1076 gfc_get_real_type (int kind
)
1078 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
1079 return index
< 0 ? 0 : gfc_real_types
[index
];
1083 gfc_get_complex_type (int kind
)
1085 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
1086 return index
< 0 ? 0 : gfc_complex_types
[index
];
1090 gfc_get_logical_type (int kind
)
1092 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
1093 return index
< 0 ? 0 : gfc_logical_types
[index
];
1097 gfc_get_char_type (int kind
)
1099 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1100 return index
< 0 ? 0 : gfc_character_types
[index
];
1104 gfc_get_pchar_type (int kind
)
1106 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1107 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
1111 /* Create a character type with the given kind and length. */
1114 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
1118 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
1119 type
= build_array_type (eltype
, bounds
);
1120 TYPE_STRING_FLAG (type
) = 1;
1126 gfc_get_character_type_len (int kind
, tree len
)
1128 gfc_validate_kind (BT_CHARACTER
, kind
, false);
1129 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
1133 /* Get a type node for a character kind. */
1136 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
1140 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1141 if (len
&& POINTER_TYPE_P (TREE_TYPE (len
)))
1142 len
= build_fold_indirect_ref (len
);
1144 return gfc_get_character_type_len (kind
, len
);
1147 /* Convert a basic type. This will be an array for character types. */
1150 gfc_typenode_for_spec (gfc_typespec
* spec
, int codim
)
1160 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1161 has been resolved. This is done so we can convert C_PTR and
1162 C_FUNPTR to simple variables that get translated to (void *). */
1163 if (spec
->f90_type
== BT_VOID
)
1166 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1167 basetype
= ptr_type_node
;
1169 basetype
= pfunc_type_node
;
1172 basetype
= gfc_get_int_type (spec
->kind
);
1176 basetype
= gfc_get_real_type (spec
->kind
);
1180 basetype
= gfc_get_complex_type (spec
->kind
);
1184 basetype
= gfc_get_logical_type (spec
->kind
);
1188 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1192 /* Since this cannot be used, return a length one character. */
1193 basetype
= gfc_get_character_type_len (gfc_default_character_kind
,
1194 gfc_index_one_node
);
1198 basetype
= gfc_get_union_type (spec
->u
.derived
);
1203 basetype
= gfc_get_derived_type (spec
->u
.derived
, codim
);
1205 if (spec
->type
== BT_CLASS
)
1206 GFC_CLASS_TYPE_P (basetype
) = 1;
1208 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1209 type and kind to fit a (void *) and the basetype returned was a
1210 ptr_type_node. We need to pass up this new information to the
1211 symbol that was declared of type C_PTR or C_FUNPTR. */
1212 if (spec
->u
.derived
->ts
.f90_type
== BT_VOID
)
1214 spec
->type
= BT_INTEGER
;
1215 spec
->kind
= gfc_index_integer_kind
;
1216 spec
->f90_type
= BT_VOID
;
1221 /* This is for the second arg to c_f_pointer and c_f_procpointer
1222 of the iso_c_binding module, to accept any ptr type. */
1223 basetype
= ptr_type_node
;
1224 if (spec
->f90_type
== BT_VOID
)
1227 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1228 basetype
= ptr_type_node
;
1230 basetype
= pfunc_type_node
;
1239 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1242 gfc_conv_array_bound (gfc_expr
* expr
)
1244 /* If expr is an integer constant, return that. */
1245 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1246 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1248 /* Otherwise return NULL. */
1252 /* Return the type of an element of the array. Note that scalar coarrays
1253 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1254 (with POINTER_TYPE stripped) is returned. */
1257 gfc_get_element_type (tree type
)
1261 if (GFC_ARRAY_TYPE_P (type
))
1263 if (TREE_CODE (type
) == POINTER_TYPE
)
1264 type
= TREE_TYPE (type
);
1265 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1267 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1272 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1273 element
= TREE_TYPE (type
);
1278 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1279 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1281 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1282 element
= TREE_TYPE (element
);
1284 /* For arrays, which are not scalar coarrays. */
1285 if (TREE_CODE (element
) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (element
))
1286 element
= TREE_TYPE (element
);
1292 /* Build an array. This function is called from gfc_sym_type().
1293 Actually returns array descriptor type.
1295 Format of array descriptors is as follows:
1297 struct gfc_array_descriptor
1301 struct dtype_type dtype;
1302 struct descriptor_dimension dimension[N_DIM];
1311 signed short attribute;
1314 struct descriptor_dimension
1321 Translation code should use gfc_conv_descriptor_* rather than
1322 accessing the descriptor directly. Any changes to the array
1323 descriptor type will require changes in gfc_conv_descriptor_* and
1324 gfc_build_array_initializer.
1326 This is represented internally as a RECORD_TYPE. The index nodes
1327 are gfc_array_index_type and the data node is a pointer to the
1328 data. See below for the handling of character types.
1330 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1331 this generated poor code for assumed/deferred size arrays. These
1332 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1333 of the GENERIC grammar. Also, there is no way to explicitly set
1334 the array stride, so all data must be packed(1). I've tried to
1335 mark all the functions which would require modification with a GCC
1338 The data component points to the first element in the array. The
1339 offset field is the position of the origin of the array (i.e. element
1340 (0, 0 ...)). This may be outside the bounds of the array.
1342 An element is accessed by
1343 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1344 This gives good performance as the computation does not involve the
1345 bounds of the array. For packed arrays, this is optimized further
1346 by substituting the known strides.
1348 This system has one problem: all array bounds must be within 2^31
1349 elements of the origin (2^63 on 64-bit machines). For example
1350 integer, dimension (80000:90000, 80000:90000, 2) :: array
1351 may not work properly on 32-bit machines because 80000*80000 >
1352 2^31, so the calculation for stride2 would overflow. This may
1353 still work, but I haven't checked, and it relies on the overflow
1354 doing the right thing.
1356 The way to fix this problem is to access elements as follows:
1357 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1358 Obviously this is much slower. I will make this a compile time
1359 option, something like -fsmall-array-offsets. Mixing code compiled
1360 with and without this switch will work.
1362 (1) This can be worked around by modifying the upper bound of the
1363 previous dimension. This requires extra fields in the descriptor
1364 (both real_ubound and fake_ubound). */
1367 /* Returns true if the array sym does not require a descriptor. */
1370 gfc_is_nodesc_array (gfc_symbol
* sym
)
1372 symbol_attribute
*array_attr
;
1374 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1376 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1377 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1379 gcc_assert (array_attr
->dimension
|| array_attr
->codimension
);
1381 /* We only want local arrays. */
1382 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1383 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1384 || array_attr
->allocatable
)
1387 /* We want a descriptor for associate-name arrays that do not have an
1388 explicitly known shape already. */
1389 if (sym
->assoc
&& as
->type
!= AS_EXPLICIT
)
1392 /* The dummy is stored in sym and not in the component. */
1393 if (sym
->attr
.dummy
)
1394 return as
->type
!= AS_ASSUMED_SHAPE
1395 && as
->type
!= AS_ASSUMED_RANK
;
1397 if (sym
->attr
.result
|| sym
->attr
.function
)
1400 gcc_assert (as
->type
== AS_EXPLICIT
|| as
->cp_was_assumed
);
1406 /* Create an array descriptor type. */
1409 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1410 enum gfc_array_kind akind
, bool restricted
,
1411 bool contiguous
, int codim
)
1413 tree lbound
[GFC_MAX_DIMENSIONS
];
1414 tree ubound
[GFC_MAX_DIMENSIONS
];
1417 /* Assumed-shape arrays do not have codimension information stored in the
1419 corank
= MAX (as
->corank
, codim
);
1420 if (as
->type
== AS_ASSUMED_SHAPE
||
1421 (as
->type
== AS_ASSUMED_RANK
&& akind
== GFC_ARRAY_ALLOCATABLE
))
1424 if (as
->type
== AS_ASSUMED_RANK
)
1425 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1427 lbound
[n
] = NULL_TREE
;
1428 ubound
[n
] = NULL_TREE
;
1431 for (n
= 0; n
< as
->rank
; n
++)
1433 /* Create expressions for the known bounds of the array. */
1434 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1435 lbound
[n
] = gfc_index_one_node
;
1437 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1438 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1441 for (n
= as
->rank
; n
< as
->rank
+ corank
; n
++)
1443 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1444 lbound
[n
] = gfc_index_one_node
;
1446 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1448 if (n
< as
->rank
+ corank
- 1)
1449 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1452 if (as
->type
== AS_ASSUMED_SHAPE
)
1453 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1454 : GFC_ARRAY_ASSUMED_SHAPE
;
1455 else if (as
->type
== AS_ASSUMED_RANK
)
1456 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1457 : GFC_ARRAY_ASSUMED_RANK
;
1458 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1459 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1460 corank
, lbound
, ubound
, 0, akind
,
1464 /* Returns the struct descriptor_dimension type. */
1467 gfc_get_desc_dim_type (void)
1470 tree decl
, *chain
= NULL
;
1472 if (gfc_desc_dim_type
)
1473 return gfc_desc_dim_type
;
1475 /* Build the type node. */
1476 type
= make_node (RECORD_TYPE
);
1478 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1479 TYPE_PACKED (type
) = 1;
1481 /* Consists of the stride, lbound and ubound members. */
1482 decl
= gfc_add_field_to_struct_1 (type
,
1483 get_identifier ("stride"),
1484 gfc_array_index_type
, &chain
);
1485 TREE_NO_WARNING (decl
) = 1;
1487 decl
= gfc_add_field_to_struct_1 (type
,
1488 get_identifier ("lbound"),
1489 gfc_array_index_type
, &chain
);
1490 TREE_NO_WARNING (decl
) = 1;
1492 decl
= gfc_add_field_to_struct_1 (type
,
1493 get_identifier ("ubound"),
1494 gfc_array_index_type
, &chain
);
1495 TREE_NO_WARNING (decl
) = 1;
1497 /* Finish off the type. */
1498 gfc_finish_type (type
);
1499 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1501 gfc_desc_dim_type
= type
;
1506 /* Return the DTYPE for an array. This describes the type and type parameters
1508 /* TODO: Only call this when the value is actually used, and make all the
1509 unknown cases abort. */
1512 gfc_get_dtype_rank_type (int rank
, tree etype
)
1519 vec
<constructor_elt
, va_gc
> *v
= NULL
;
1521 switch (TREE_CODE (etype
))
1540 if (GFC_CLASS_TYPE_P (etype
))
1546 /* We will never have arrays of arrays. */
1556 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1557 /* We can strange array types for temporary arrays. */
1558 return gfc_index_zero_node
;
1561 size
= TYPE_SIZE_UNIT (etype
);
1562 if (n
== BT_CHARACTER
&& size
== NULL_TREE
)
1563 size
= TYPE_SIZE_UNIT (TREE_TYPE (etype
));
1565 tmp
= get_dtype_type_node ();
1566 field
= gfc_advance_chain (TYPE_FIELDS (tmp
),
1567 GFC_DTYPE_ELEM_LEN
);
1568 CONSTRUCTOR_APPEND_ELT (v
, field
,
1569 fold_convert (TREE_TYPE (field
), size
));
1571 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1573 CONSTRUCTOR_APPEND_ELT (v
, field
,
1574 build_int_cst (TREE_TYPE (field
), rank
));
1576 field
= gfc_advance_chain (TYPE_FIELDS (dtype_type_node
),
1578 CONSTRUCTOR_APPEND_ELT (v
, field
,
1579 build_int_cst (TREE_TYPE (field
), n
));
1581 dtype
= build_constructor (tmp
, v
);
1588 gfc_get_dtype (tree type
)
1594 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1596 rank
= GFC_TYPE_ARRAY_RANK (type
);
1597 etype
= gfc_get_element_type (type
);
1598 dtype
= gfc_get_dtype_rank_type (rank
, etype
);
1600 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1605 /* Build an array type for use without a descriptor, packed according
1606 to the value of PACKED. */
1609 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1623 mpz_init_set_ui (offset
, 0);
1624 mpz_init_set_ui (stride
, 1);
1627 /* We don't use build_array_type because this does not include include
1628 lang-specific information (i.e. the bounds of the array) when checking
1631 type
= make_node (ARRAY_TYPE
);
1633 type
= build_variant_type_copy (etype
);
1635 GFC_ARRAY_TYPE_P (type
) = 1;
1636 TYPE_LANG_SPECIFIC (type
) = ggc_cleared_alloc
<struct lang_type
> ();
1638 known_stride
= (packed
!= PACKED_NO
);
1640 for (n
= 0; n
< as
->rank
; n
++)
1642 /* Fill in the stride and bound components of the type. */
1644 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1647 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1649 expr
= as
->lower
[n
];
1650 if (expr
->expr_type
== EXPR_CONSTANT
)
1652 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1653 gfc_index_integer_kind
);
1660 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1664 /* Calculate the offset. */
1665 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1666 mpz_sub (offset
, offset
, delta
);
1671 expr
= as
->upper
[n
];
1672 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1674 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1675 gfc_index_integer_kind
);
1682 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1686 /* Calculate the stride. */
1687 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1688 as
->lower
[n
]->value
.integer
);
1689 mpz_add_ui (delta
, delta
, 1);
1690 mpz_mul (stride
, stride
, delta
);
1693 /* Only the first stride is known for partial packed arrays. */
1694 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1697 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1699 expr
= as
->lower
[n
];
1700 if (expr
->expr_type
== EXPR_CONSTANT
)
1701 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1702 gfc_index_integer_kind
);
1705 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1707 expr
= as
->upper
[n
];
1708 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1709 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1710 gfc_index_integer_kind
);
1713 if (n
< as
->rank
+ as
->corank
- 1)
1714 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1719 GFC_TYPE_ARRAY_OFFSET (type
) =
1720 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1723 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1727 GFC_TYPE_ARRAY_SIZE (type
) =
1728 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1731 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1733 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1734 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1735 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1736 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1738 /* TODO: use main type if it is unbounded. */
1739 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1740 build_pointer_type (build_array_type (etype
, range
));
1742 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1743 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1744 TYPE_QUAL_RESTRICT
);
1748 if (packed
!= PACKED_STATIC
|| flag_coarray
== GFC_FCOARRAY_LIB
)
1750 type
= build_pointer_type (type
);
1753 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1755 GFC_ARRAY_TYPE_P (type
) = 1;
1756 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1764 mpz_sub_ui (stride
, stride
, 1);
1765 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1770 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1771 TYPE_DOMAIN (type
) = range
;
1773 build_pointer_type (etype
);
1774 TREE_TYPE (type
) = etype
;
1782 /* Represent packed arrays as multi-dimensional if they have rank >
1783 1 and with proper bounds, instead of flat arrays. This makes for
1784 better debug info. */
1787 tree gtype
= etype
, rtype
, type_decl
;
1789 for (n
= as
->rank
- 1; n
>= 0; n
--)
1791 rtype
= build_range_type (gfc_array_index_type
,
1792 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1793 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1794 gtype
= build_array_type (gtype
, rtype
);
1796 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1797 TYPE_DECL
, NULL
, gtype
);
1798 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1801 if (packed
!= PACKED_STATIC
|| !known_stride
1802 || (as
->corank
&& flag_coarray
== GFC_FCOARRAY_LIB
))
1804 /* For dummy arrays and automatic (heap allocated) arrays we
1805 want a pointer to the array. */
1806 type
= build_pointer_type (type
);
1808 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1809 GFC_ARRAY_TYPE_P (type
) = 1;
1810 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1816 /* Return or create the base type for an array descriptor. */
1819 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1821 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1822 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1825 /* Assumed-rank array. */
1827 dimen
= GFC_MAX_DIMENSIONS
;
1829 idx
= 2 * (codimen
+ dimen
) + restricted
;
1831 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1833 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1835 if (gfc_array_descriptor_base_caf
[idx
])
1836 return gfc_array_descriptor_base_caf
[idx
];
1838 else if (gfc_array_descriptor_base
[idx
])
1839 return gfc_array_descriptor_base
[idx
];
1841 /* Build the type node. */
1842 fat_type
= make_node (RECORD_TYPE
);
1844 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1845 TYPE_NAME (fat_type
) = get_identifier (name
);
1846 TYPE_NAMELESS (fat_type
) = 1;
1848 /* Add the data member as the first element of the descriptor. */
1849 decl
= gfc_add_field_to_struct_1 (fat_type
,
1850 get_identifier ("data"),
1853 : ptr_type_node
), &chain
);
1855 /* Add the base component. */
1856 decl
= gfc_add_field_to_struct_1 (fat_type
,
1857 get_identifier ("offset"),
1858 gfc_array_index_type
, &chain
);
1859 TREE_NO_WARNING (decl
) = 1;
1861 /* Add the dtype component. */
1862 decl
= gfc_add_field_to_struct_1 (fat_type
,
1863 get_identifier ("dtype"),
1864 get_dtype_type_node (), &chain
);
1865 TREE_NO_WARNING (decl
) = 1;
1867 /* Add the span component. */
1868 decl
= gfc_add_field_to_struct_1 (fat_type
,
1869 get_identifier ("span"),
1870 gfc_array_index_type
, &chain
);
1871 TREE_NO_WARNING (decl
) = 1;
1873 /* Build the array type for the stride and bound components. */
1874 if (dimen
+ codimen
> 0)
1877 build_array_type (gfc_get_desc_dim_type (),
1878 build_range_type (gfc_array_index_type
,
1879 gfc_index_zero_node
,
1880 gfc_rank_cst
[codimen
+ dimen
- 1]));
1882 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1884 TREE_NO_WARNING (decl
) = 1;
1887 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1889 decl
= gfc_add_field_to_struct_1 (fat_type
,
1890 get_identifier ("token"),
1891 prvoid_type_node
, &chain
);
1892 TREE_NO_WARNING (decl
) = 1;
1895 /* Finish off the type. */
1896 gfc_finish_type (fat_type
);
1897 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1899 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1900 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1902 gfc_array_descriptor_base
[idx
] = fat_type
;
1908 /* Build an array (descriptor) type with given bounds. */
1911 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1912 tree
* ubound
, int packed
,
1913 enum gfc_array_kind akind
, bool restricted
)
1915 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1916 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1917 const char *type_name
;
1920 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1921 fat_type
= build_distinct_type_copy (base_type
);
1922 /* Make sure that nontarget and target array type have the same canonical
1923 type (and same stub decl for debug info). */
1924 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1925 TYPE_CANONICAL (fat_type
) = base_type
;
1926 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1928 tmp
= TYPE_NAME (etype
);
1929 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1930 tmp
= DECL_NAME (tmp
);
1932 type_name
= IDENTIFIER_POINTER (tmp
);
1934 type_name
= "unknown";
1935 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1936 GFC_MAX_SYMBOL_LEN
, type_name
);
1937 TYPE_NAME (fat_type
) = get_identifier (name
);
1938 TYPE_NAMELESS (fat_type
) = 1;
1940 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1941 TYPE_LANG_SPECIFIC (fat_type
) = ggc_cleared_alloc
<struct lang_type
> ();
1943 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1944 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1945 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1946 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1948 /* Build an array descriptor record type. */
1950 stride
= gfc_index_one_node
;
1953 for (n
= 0; n
< dimen
+ codimen
; n
++)
1956 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1963 if (lower
!= NULL_TREE
)
1965 if (INTEGER_CST_P (lower
))
1966 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1971 if (codimen
&& n
== dimen
+ codimen
- 1)
1975 if (upper
!= NULL_TREE
)
1977 if (INTEGER_CST_P (upper
))
1978 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1986 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1988 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1989 gfc_array_index_type
, upper
, lower
);
1990 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1991 gfc_array_index_type
, tmp
,
1992 gfc_index_one_node
);
1993 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1994 gfc_array_index_type
, tmp
, stride
);
1995 /* Check the folding worked. */
1996 gcc_assert (INTEGER_CST_P (stride
));
2001 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
2003 /* TODO: known offsets for descriptors. */
2004 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
2008 arraytype
= build_pointer_type (etype
);
2010 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
2012 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
2016 /* We define data as an array with the correct size if possible.
2017 Much better than doing pointer arithmetic. */
2019 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
2020 int_const_binop (MINUS_EXPR
, stride
,
2021 build_int_cst (TREE_TYPE (stride
), 1)));
2023 rtype
= gfc_array_range_type
;
2024 arraytype
= build_array_type (etype
, rtype
);
2025 arraytype
= build_pointer_type (arraytype
);
2027 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
2028 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
2030 /* This will generate the base declarations we need to emit debug
2031 information for this type. FIXME: there must be a better way to
2032 avoid divergence between compilations with and without debug
2035 struct array_descr_info info
;
2036 gfc_get_array_descr_info (fat_type
, &info
);
2037 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
2043 /* Build a pointer type. This function is called from gfc_sym_type(). */
2046 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
2048 /* Array pointer types aren't actually pointers. */
2049 if (sym
->attr
.dimension
)
2052 return build_pointer_type (type
);
2055 static tree
gfc_nonrestricted_type (tree t
);
2056 /* Given two record or union type nodes TO and FROM, ensure
2057 that all fields in FROM have a corresponding field in TO,
2058 their type being nonrestrict variants. This accepts a TO
2059 node that already has a prefix of the fields in FROM. */
2061 mirror_fields (tree to
, tree from
)
2066 /* Forward to the end of TOs fields. */
2067 fto
= TYPE_FIELDS (to
);
2068 ffrom
= TYPE_FIELDS (from
);
2069 chain
= &TYPE_FIELDS (to
);
2072 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
2073 chain
= &DECL_CHAIN (fto
);
2074 fto
= DECL_CHAIN (fto
);
2075 ffrom
= DECL_CHAIN (ffrom
);
2078 /* Now add all fields remaining in FROM (starting with ffrom). */
2079 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
2081 tree newfield
= copy_node (ffrom
);
2082 DECL_CONTEXT (newfield
) = to
;
2083 /* The store to DECL_CHAIN might seem redundant with the
2084 stores to *chain, but not clearing it here would mean
2085 leaving a chain into the old fields. If ever
2086 our called functions would look at them confusion
2088 DECL_CHAIN (newfield
) = NULL_TREE
;
2090 chain
= &DECL_CHAIN (newfield
);
2092 if (TREE_CODE (ffrom
) == FIELD_DECL
)
2094 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
2095 TREE_TYPE (newfield
) = elemtype
;
2101 /* Given a type T, returns a different type of the same structure,
2102 except that all types it refers to (recursively) are always
2103 non-restrict qualified types. */
2105 gfc_nonrestricted_type (tree t
)
2109 /* If the type isn't laid out yet, don't copy it. If something
2110 needs it for real it should wait until the type got finished. */
2114 if (!TYPE_LANG_SPECIFIC (t
))
2115 TYPE_LANG_SPECIFIC (t
) = ggc_cleared_alloc
<struct lang_type
> ();
2116 /* If we're dealing with this very node already further up
2117 the call chain (recursion via pointers and struct members)
2118 we haven't yet determined if we really need a new type node.
2119 Assume we don't, return T itself. */
2120 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
2123 /* If we have calculated this all already, just return it. */
2124 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
2125 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
2127 /* Mark this type. */
2128 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2130 switch (TREE_CODE (t
))
2136 case REFERENCE_TYPE
:
2138 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2139 if (totype
== TREE_TYPE (t
))
2141 else if (TREE_CODE (t
) == POINTER_TYPE
)
2142 ret
= build_pointer_type (totype
);
2144 ret
= build_reference_type (totype
);
2145 ret
= build_qualified_type (ret
,
2146 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2152 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2153 if (elemtype
== TREE_TYPE (t
))
2157 ret
= build_variant_type_copy (t
);
2158 TREE_TYPE (ret
) = elemtype
;
2159 if (TYPE_LANG_SPECIFIC (t
)
2160 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2162 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2163 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2164 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2166 TYPE_LANG_SPECIFIC (ret
)
2167 = ggc_cleared_alloc
<struct lang_type
> ();
2168 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2169 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2178 case QUAL_UNION_TYPE
:
2181 /* First determine if we need a new type at all.
2182 Careful, the two calls to gfc_nonrestricted_type per field
2183 might return different values. That happens exactly when
2184 one of the fields reaches back to this very record type
2185 (via pointers). The first calls will assume that we don't
2186 need to copy T (see the error_mark_node marking). If there
2187 are any reasons for copying T apart from having to copy T,
2188 we'll indeed copy it, and the second calls to
2189 gfc_nonrestricted_type will use that new node if they
2191 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2192 if (TREE_CODE (field
) == FIELD_DECL
)
2194 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2195 if (elemtype
!= TREE_TYPE (field
))
2200 ret
= build_variant_type_copy (t
);
2201 TYPE_FIELDS (ret
) = NULL_TREE
;
2203 /* Here we make sure that as soon as we know we have to copy
2204 T, that also fields reaching back to us will use the new
2205 copy. It's okay if that copy still contains the old fields,
2206 we won't look at them. */
2207 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2208 mirror_fields (ret
, t
);
2213 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2218 /* Return the type for a symbol. Special handling is required for character
2219 types to get the correct level of indirection.
2220 For functions return the return type.
2221 For subroutines return void_type_node.
2222 Calling this multiple times for the same symbol should be avoided,
2223 especially for character and array types. */
2226 gfc_sym_type (gfc_symbol
* sym
)
2232 /* Procedure Pointers inside COMMON blocks. */
2233 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2235 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2236 sym
->attr
.proc_pointer
= 0;
2237 type
= build_pointer_type (gfc_get_function_type (sym
));
2238 sym
->attr
.proc_pointer
= 1;
2242 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2243 return void_type_node
;
2245 /* In the case of a function the fake result variable may have a
2246 type different from the function type, so don't return early in
2248 if (sym
->backend_decl
&& !sym
->attr
.function
)
2249 return TREE_TYPE (sym
->backend_decl
);
2251 if (sym
->attr
.result
2252 && sym
->ts
.type
== BT_CHARACTER
2253 && sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
2254 && sym
->ns
->proc_name
2255 && sym
->ns
->proc_name
->ts
.u
.cl
2256 && sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
!= NULL_TREE
)
2257 sym
->ts
.u
.cl
->backend_decl
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2259 if (sym
->ts
.type
== BT_CHARACTER
2260 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2261 || (sym
->attr
.result
2262 && sym
->ns
->proc_name
2263 && sym
->ns
->proc_name
->attr
.is_bind_c
)
2264 || (sym
->ts
.deferred
&& (!sym
->ts
.u
.cl
2265 || !sym
->ts
.u
.cl
->backend_decl
))))
2266 type
= gfc_character1_type_node
;
2268 type
= gfc_typenode_for_spec (&sym
->ts
, sym
->attr
.codimension
);
2270 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2275 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2276 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2278 type
= gfc_nonrestricted_type (type
);
2280 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2282 if (gfc_is_nodesc_array (sym
))
2284 /* If this is a character argument of unknown length, just use the
2286 if (sym
->ts
.type
!= BT_CHARACTER
2287 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2288 || sym
->ts
.u
.cl
->backend_decl
)
2290 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2299 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2300 if (sym
->attr
.pointer
)
2301 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2302 : GFC_ARRAY_POINTER
;
2303 else if (sym
->attr
.allocatable
)
2304 akind
= GFC_ARRAY_ALLOCATABLE
;
2305 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2306 sym
->attr
.contiguous
, false);
2311 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2312 || gfc_is_associate_pointer (sym
))
2313 type
= gfc_build_pointer_type (sym
, type
);
2316 /* We currently pass all parameters by reference.
2317 See f95_get_function_decl. For dummy function parameters return the
2321 /* We must use pointer types for potentially absent variables. The
2322 optimizers assume a reference type argument is never NULL. */
2323 if (sym
->attr
.optional
2324 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2325 type
= build_pointer_type (type
);
2328 type
= build_reference_type (type
);
2330 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2337 /* Layout and output debug info for a record type. */
2340 gfc_finish_type (tree type
)
2344 decl
= build_decl (input_location
,
2345 TYPE_DECL
, NULL_TREE
, type
);
2346 TYPE_STUB_DECL (type
) = decl
;
2348 rest_of_type_compilation (type
, 1);
2349 rest_of_decl_compilation (decl
, 1, 0);
2352 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2353 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2354 to the end of the field list pointed to by *CHAIN.
2356 Returns a pointer to the new field. */
2359 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2361 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2363 DECL_CONTEXT (decl
) = context
;
2364 DECL_CHAIN (decl
) = NULL_TREE
;
2365 if (TYPE_FIELDS (context
) == NULL_TREE
)
2366 TYPE_FIELDS (context
) = decl
;
2371 *chain
= &DECL_CHAIN (decl
);
2377 /* Like `gfc_add_field_to_struct_1', but adds alignment
2381 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2383 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2385 DECL_INITIAL (decl
) = 0;
2386 SET_DECL_ALIGN (decl
, 0);
2387 DECL_USER_ALIGN (decl
) = 0;
2393 /* Copy the backend_decl and component backend_decls if
2394 the two derived type symbols are "equal", as described
2395 in 4.4.2 and resolved by gfc_compare_derived_types. */
2398 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2401 gfc_component
*to_cm
;
2402 gfc_component
*from_cm
;
2407 if (from
->backend_decl
== NULL
2408 || !gfc_compare_derived_types (from
, to
))
2411 to
->backend_decl
= from
->backend_decl
;
2413 to_cm
= to
->components
;
2414 from_cm
= from
->components
;
2416 /* Copy the component declarations. If a component is itself
2417 a derived type, we need a copy of its component declarations.
2418 This is done by recursing into gfc_get_derived_type and
2419 ensures that the component's component declarations have
2420 been built. If it is a character, we need the character
2422 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2424 to_cm
->backend_decl
= from_cm
->backend_decl
;
2425 to_cm
->caf_token
= from_cm
->caf_token
;
2426 if (from_cm
->ts
.type
== BT_UNION
)
2427 gfc_get_union_type (to_cm
->ts
.u
.derived
);
2428 else if (from_cm
->ts
.type
== BT_DERIVED
2429 && (!from_cm
->attr
.pointer
|| from_gsym
))
2430 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2431 else if (from_cm
->ts
.type
== BT_CLASS
2432 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2433 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2434 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2435 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2442 /* Build a tree node for a procedure pointer component. */
2445 gfc_get_ppc_type (gfc_component
* c
)
2449 /* Explicit interface. */
2450 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2451 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2453 /* Implicit interface (only return value may be known). */
2454 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2455 t
= gfc_typenode_for_spec (&c
->ts
);
2459 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2463 /* Build a tree node for a union type. Requires building each map
2464 structure which is an element of the union. */
2467 gfc_get_union_type (gfc_symbol
*un
)
2469 gfc_component
*map
= NULL
;
2470 tree typenode
= NULL
, map_type
= NULL
, map_field
= NULL
;
2473 if (un
->backend_decl
)
2475 if (TYPE_FIELDS (un
->backend_decl
) || un
->attr
.proc_pointer_comp
)
2476 return un
->backend_decl
;
2478 typenode
= un
->backend_decl
;
2482 typenode
= make_node (UNION_TYPE
);
2483 TYPE_NAME (typenode
) = get_identifier (un
->name
);
2486 /* Add each contained MAP as a field. */
2487 for (map
= un
->components
; map
; map
= map
->next
)
2489 gcc_assert (map
->ts
.type
== BT_DERIVED
);
2491 /* The map's type node, which is defined within this union's context. */
2492 map_type
= gfc_get_derived_type (map
->ts
.u
.derived
);
2493 TYPE_CONTEXT (map_type
) = typenode
;
2495 /* The map field's declaration. */
2496 map_field
= gfc_add_field_to_struct(typenode
, get_identifier(map
->name
),
2499 gfc_set_decl_location (map_field
, &map
->loc
);
2500 else if (un
->declared_at
.lb
)
2501 gfc_set_decl_location (map_field
, &un
->declared_at
);
2503 DECL_PACKED (map_field
) |= TYPE_PACKED (typenode
);
2504 DECL_NAMELESS(map_field
) = true;
2506 /* We should never clobber another backend declaration for this map,
2507 because each map component is unique. */
2508 if (!map
->backend_decl
)
2509 map
->backend_decl
= map_field
;
2512 un
->backend_decl
= typenode
;
2513 gfc_finish_type (typenode
);
2519 /* Build a tree node for a derived type. If there are equal
2520 derived types, with different local names, these are built
2521 at the same time. If an equal derived type has been built
2522 in a parent namespace, this is used. */
2525 gfc_get_derived_type (gfc_symbol
* derived
, int codimen
)
2527 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2528 tree canonical
= NULL_TREE
;
2530 bool got_canonical
= false;
2531 bool unlimited_entity
= false;
2538 coarray_flag
= flag_coarray
== GFC_FCOARRAY_LIB
2539 && derived
->module
&& !derived
->attr
.vtype
;
2541 gcc_assert (!derived
->attr
.pdt_template
);
2543 if (derived
->attr
.unlimited_polymorphic
2544 || (flag_coarray
== GFC_FCOARRAY_LIB
2545 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2546 && (derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
2547 || derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2548 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
)))
2549 return ptr_type_node
;
2551 if (flag_coarray
!= GFC_FCOARRAY_LIB
2552 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2553 && (derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
2554 || derived
->intmod_sym_id
== ISOFORTRAN_TEAM_TYPE
))
2555 return gfc_get_int_type (gfc_default_integer_kind
);
2557 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2558 && derived
->attr
.generic
)
2559 derived
= gfc_find_dt_in_generic (derived
);
2561 /* See if it's one of the iso_c_binding derived types. */
2562 if (derived
->attr
.is_iso_c
== 1 || derived
->ts
.f90_type
== BT_VOID
)
2564 if (derived
->backend_decl
)
2565 return derived
->backend_decl
;
2567 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2568 derived
->backend_decl
= ptr_type_node
;
2570 derived
->backend_decl
= pfunc_type_node
;
2572 derived
->ts
.kind
= gfc_index_integer_kind
;
2573 derived
->ts
.type
= BT_INTEGER
;
2574 /* Set the f90_type to BT_VOID as a way to recognize something of type
2575 BT_INTEGER that needs to fit a void * for the purpose of the
2576 iso_c_binding derived types. */
2577 derived
->ts
.f90_type
= BT_VOID
;
2579 return derived
->backend_decl
;
2582 /* If use associated, use the module type for this one. */
2583 if (derived
->backend_decl
== NULL
2584 && derived
->attr
.use_assoc
2586 && gfc_get_module_backend_decl (derived
))
2587 goto copy_derived_types
;
2589 /* The derived types from an earlier namespace can be used as the
2591 if (derived
->backend_decl
== NULL
&& !derived
->attr
.use_assoc
2592 && gfc_global_ns_list
)
2594 for (ns
= gfc_global_ns_list
;
2595 ns
->translated
&& !got_canonical
;
2598 dt
= ns
->derived_types
;
2599 for (; dt
&& !canonical
; dt
= dt
->next
)
2601 gfc_copy_dt_decls_ifequal (dt
->derived
, derived
, true);
2602 if (derived
->backend_decl
)
2603 got_canonical
= true;
2608 /* Store up the canonical type to be added to this one. */
2611 if (TYPE_CANONICAL (derived
->backend_decl
))
2612 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2614 canonical
= derived
->backend_decl
;
2616 derived
->backend_decl
= NULL_TREE
;
2619 /* derived->backend_decl != 0 means we saw it before, but its
2620 components' backend_decl may have not been built. */
2621 if (derived
->backend_decl
)
2623 /* Its components' backend_decl have been built or we are
2624 seeing recursion through the formal arglist of a procedure
2625 pointer component. */
2626 if (TYPE_FIELDS (derived
->backend_decl
))
2627 return derived
->backend_decl
;
2628 else if (derived
->attr
.abstract
2629 && derived
->attr
.proc_pointer_comp
)
2631 /* If an abstract derived type with procedure pointer
2632 components has no other type of component, return the
2633 backend_decl. Otherwise build the components if any of the
2634 non-procedure pointer components have no backend_decl. */
2635 for (c
= derived
->components
; c
; c
= c
->next
)
2637 bool same_alloc_type
= c
->attr
.allocatable
2638 && derived
== c
->ts
.u
.derived
;
2639 if (!c
->attr
.proc_pointer
2641 && c
->backend_decl
== NULL
)
2643 else if (c
->next
== NULL
)
2644 return derived
->backend_decl
;
2646 typenode
= derived
->backend_decl
;
2649 typenode
= derived
->backend_decl
;
2653 /* We see this derived type first time, so build the type node. */
2654 typenode
= make_node (RECORD_TYPE
);
2655 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2656 TYPE_PACKED (typenode
) = flag_pack_derived
;
2657 derived
->backend_decl
= typenode
;
2660 if (derived
->components
2661 && derived
->components
->ts
.type
== BT_DERIVED
2662 && strcmp (derived
->components
->name
, "_data") == 0
2663 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2664 unlimited_entity
= true;
2666 /* Go through the derived type components, building them as
2667 necessary. The reason for doing this now is that it is
2668 possible to recurse back to this derived type through a
2669 pointer component (PR24092). If this happens, the fields
2670 will be built and so we can return the type. */
2671 for (c
= derived
->components
; c
; c
= c
->next
)
2673 bool same_alloc_type
= c
->attr
.allocatable
2674 && derived
== c
->ts
.u
.derived
;
2676 if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->backend_decl
== NULL
)
2677 c
->ts
.u
.derived
->backend_decl
= gfc_get_union_type (c
->ts
.u
.derived
);
2679 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2682 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
2683 && !same_alloc_type
)
2684 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2686 int local_codim
= c
->attr
.codimension
? c
->as
->corank
: codimen
;
2687 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
,
2691 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2693 /* Need to copy the modified ts from the derived type. The
2694 typespec was modified because C_PTR/C_FUNPTR are translated
2695 into (void *) from derived types. */
2696 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2697 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2698 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2701 c
->initializer
->ts
.type
= c
->ts
.type
;
2702 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2703 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2704 c
->initializer
->expr_type
= EXPR_NULL
;
2709 if (TYPE_FIELDS (derived
->backend_decl
))
2710 return derived
->backend_decl
;
2712 /* Build the type member list. Install the newly created RECORD_TYPE
2713 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2714 through only the top-level linked list of components so we correctly
2715 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2716 types are built as part of gfc_get_union_type. */
2717 for (c
= derived
->components
; c
; c
= c
->next
)
2719 bool same_alloc_type
= c
->attr
.allocatable
2720 && derived
== c
->ts
.u
.derived
;
2721 /* Prevent infinite recursion, when the procedure pointer type is
2722 the same as derived, by forcing the procedure pointer component to
2723 be built as if the explicit interface does not exist. */
2724 if (c
->attr
.proc_pointer
2725 && (c
->ts
.type
!= BT_DERIVED
|| (c
->ts
.u
.derived
2726 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)))
2727 && (c
->ts
.type
!= BT_CLASS
|| (CLASS_DATA (c
)->ts
.u
.derived
2728 && !gfc_compare_derived_types (derived
, CLASS_DATA (c
)->ts
.u
.derived
))))
2729 field_type
= gfc_get_ppc_type (c
);
2730 else if (c
->attr
.proc_pointer
&& derived
->backend_decl
)
2732 tmp
= build_function_type_list (derived
->backend_decl
, NULL_TREE
);
2733 field_type
= build_pointer_type (tmp
);
2735 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2736 field_type
= c
->ts
.u
.derived
->backend_decl
;
2737 else if (c
->attr
.caf_token
)
2738 field_type
= pvoid_type_node
;
2741 if (c
->ts
.type
== BT_CHARACTER
2742 && !c
->ts
.deferred
&& !c
->attr
.pdt_string
)
2744 /* Evaluate the string length. */
2745 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2746 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2748 else if (c
->ts
.type
== BT_CHARACTER
)
2749 c
->ts
.u
.cl
->backend_decl
2750 = build_int_cst (gfc_charlen_type_node
, 0);
2752 field_type
= gfc_typenode_for_spec (&c
->ts
, codimen
);
2755 /* This returns an array descriptor type. Initialization may be
2757 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2759 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_array
)
2761 enum gfc_array_kind akind
;
2762 if (c
->attr
.pointer
)
2763 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2764 : GFC_ARRAY_POINTER
;
2766 akind
= GFC_ARRAY_ALLOCATABLE
;
2767 /* Pointers to arrays aren't actually pointer types. The
2768 descriptors are separate, but the data is common. */
2769 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2771 && !c
->attr
.pointer
,
2776 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2780 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_string
)
2781 && !c
->attr
.proc_pointer
2782 && !(unlimited_entity
&& c
== derived
->components
))
2783 field_type
= build_pointer_type (field_type
);
2785 if (c
->attr
.pointer
|| same_alloc_type
)
2786 field_type
= gfc_nonrestricted_type (field_type
);
2788 /* vtype fields can point to different types to the base type. */
2789 if (c
->ts
.type
== BT_DERIVED
2790 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2791 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2794 /* Ensure that the CLASS language specific flag is set. */
2795 if (c
->ts
.type
== BT_CLASS
)
2797 if (POINTER_TYPE_P (field_type
))
2798 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2800 GFC_CLASS_TYPE_P (field_type
) = 1;
2803 field
= gfc_add_field_to_struct (typenode
,
2804 get_identifier (c
->name
),
2805 field_type
, &chain
);
2807 gfc_set_decl_location (field
, &c
->loc
);
2808 else if (derived
->declared_at
.lb
)
2809 gfc_set_decl_location (field
, &derived
->declared_at
);
2811 gfc_finish_decl_attrs (field
, &c
->attr
);
2813 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2816 if (!c
->backend_decl
)
2817 c
->backend_decl
= field
;
2819 if (c
->attr
.pointer
&& c
->attr
.dimension
2820 && !(c
->ts
.type
== BT_DERIVED
2821 && strcmp (c
->name
, "_data") == 0))
2822 GFC_DECL_PTR_ARRAY_P (c
->backend_decl
) = 1;
2825 /* Now lay out the derived type, including the fields. */
2827 TYPE_CANONICAL (typenode
) = canonical
;
2829 gfc_finish_type (typenode
);
2830 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2831 if (derived
->module
&& derived
->ns
->proc_name
2832 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2834 if (derived
->ns
->proc_name
->backend_decl
2835 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2838 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2839 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2840 = derived
->ns
->proc_name
->backend_decl
;
2844 derived
->backend_decl
= typenode
;
2848 for (c
= derived
->components
; c
; c
= c
->next
)
2850 /* Do not add a caf_token field for class container components. */
2851 if ((codimen
|| coarray_flag
)
2852 && !c
->attr
.dimension
&& !c
->attr
.codimension
2853 && (c
->attr
.allocatable
|| c
->attr
.pointer
)
2854 && !derived
->attr
.is_class
)
2856 char caf_name
[GFC_MAX_SYMBOL_LEN
];
2857 gfc_component
*token
;
2858 snprintf (caf_name
, GFC_MAX_SYMBOL_LEN
, "_caf_%s", c
->name
);
2859 token
= gfc_find_component (derived
, caf_name
, true, true, NULL
);
2861 c
->caf_token
= token
->backend_decl
;
2862 TREE_NO_WARNING (c
->caf_token
) = 1;
2866 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2867 gfc_copy_dt_decls_ifequal (derived
, dt
->derived
, false);
2869 return derived
->backend_decl
;
2874 gfc_return_by_reference (gfc_symbol
* sym
)
2876 if (!sym
->attr
.function
)
2879 if (sym
->attr
.dimension
)
2882 if (sym
->ts
.type
== BT_CHARACTER
2883 && !sym
->attr
.is_bind_c
2884 && (!sym
->attr
.result
2885 || !sym
->ns
->proc_name
2886 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2889 /* Possibly return complex numbers by reference for g77 compatibility.
2890 We don't do this for calls to intrinsics (as the library uses the
2891 -fno-f2c calling convention), nor for calls to functions which always
2892 require an explicit interface, as no compatibility problems can
2894 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2895 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2902 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2906 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2907 gfc_entry_list
*el
, *el2
;
2909 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2910 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2912 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2914 /* Build the type node. */
2915 type
= make_node (UNION_TYPE
);
2917 TYPE_NAME (type
) = get_identifier (name
);
2919 for (el
= ns
->entries
; el
; el
= el
->next
)
2921 /* Search for duplicates. */
2922 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2923 if (el2
->sym
->result
== el
->sym
->result
)
2927 gfc_add_field_to_struct_1 (type
,
2928 get_identifier (el
->sym
->result
->name
),
2929 gfc_sym_type (el
->sym
->result
), &chain
);
2932 /* Finish off the type. */
2933 gfc_finish_type (type
);
2934 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2938 /* Create a "fn spec" based on the formal arguments;
2939 cf. create_function_arglist. */
2942 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2946 gfc_formal_arglist
*f
;
2949 memset (&spec
, 0, sizeof (spec
));
2953 if (sym
->attr
.entry_master
)
2954 spec
[spec_len
++] = 'R';
2955 if (gfc_return_by_reference (sym
))
2957 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2959 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2960 spec
[spec_len
++] = '.';
2962 spec
[spec_len
++] = 'w';
2963 if (sym
->ts
.type
== BT_CHARACTER
)
2964 spec
[spec_len
++] = 'R';
2967 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2968 if (spec_len
< sizeof (spec
))
2970 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2971 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2972 || (f
->sym
->ts
.type
== BT_DERIVED
2973 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2974 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2975 || (f
->sym
->ts
.type
== BT_CLASS
2976 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2977 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2978 spec
[spec_len
++] = '.';
2979 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2980 spec
[spec_len
++] = 'r';
2982 spec
[spec_len
++] = 'w';
2985 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2986 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2987 return build_type_attribute_variant (fntype
, tmp
);
2992 gfc_get_function_type (gfc_symbol
* sym
)
2995 vec
<tree
, va_gc
> *typelist
= NULL
;
2996 gfc_formal_arglist
*f
;
2998 int alternate_return
= 0;
2999 bool is_varargs
= true;
3001 /* Make sure this symbol is a function, a subroutine or the main
3003 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
3004 || sym
->attr
.flavor
== FL_PROGRAM
);
3006 /* To avoid recursing infinitely on recursive types, we use error_mark_node
3007 so that they can be detected here and handled further down. */
3008 if (sym
->backend_decl
== NULL
)
3009 sym
->backend_decl
= error_mark_node
;
3010 else if (sym
->backend_decl
== error_mark_node
)
3011 goto arg_type_list_done
;
3012 else if (sym
->attr
.proc_pointer
)
3013 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
3015 return TREE_TYPE (sym
->backend_decl
);
3017 if (sym
->attr
.entry_master
)
3018 /* Additional parameter for selecting an entry point. */
3019 vec_safe_push (typelist
, gfc_array_index_type
);
3026 if (arg
->ts
.type
== BT_CHARACTER
)
3027 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3029 /* Some functions we use an extra parameter for the return value. */
3030 if (gfc_return_by_reference (sym
))
3032 type
= gfc_sym_type (arg
);
3033 if (arg
->ts
.type
== BT_COMPLEX
3034 || arg
->attr
.dimension
3035 || arg
->ts
.type
== BT_CHARACTER
)
3036 type
= build_reference_type (type
);
3038 vec_safe_push (typelist
, type
);
3039 if (arg
->ts
.type
== BT_CHARACTER
)
3041 if (!arg
->ts
.deferred
)
3042 /* Transfer by value. */
3043 vec_safe_push (typelist
, gfc_charlen_type_node
);
3045 /* Deferred character lengths are transferred by reference
3046 so that the value can be returned. */
3047 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
3051 /* Build the argument types for the function. */
3052 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3057 /* Evaluate constant character lengths here so that they can be
3058 included in the type. */
3059 if (arg
->ts
.type
== BT_CHARACTER
)
3060 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3062 if (arg
->attr
.flavor
== FL_PROCEDURE
)
3064 type
= gfc_get_function_type (arg
);
3065 type
= build_pointer_type (type
);
3068 type
= gfc_sym_type (arg
);
3070 /* Parameter Passing Convention
3072 We currently pass all parameters by reference.
3073 Parameters with INTENT(IN) could be passed by value.
3074 The problem arises if a function is called via an implicit
3075 prototype. In this situation the INTENT is not known.
3076 For this reason all parameters to global functions must be
3077 passed by reference. Passing by value would potentially
3078 generate bad code. Worse there would be no way of telling that
3079 this code was bad, except that it would give incorrect results.
3081 Contained procedures could pass by value as these are never
3082 used without an explicit interface, and cannot be passed as
3083 actual parameters for a dummy procedure. */
3085 vec_safe_push (typelist
, type
);
3089 if (sym
->attr
.subroutine
)
3090 alternate_return
= 1;
3094 /* Add hidden string length parameters. */
3095 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3098 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
3100 if (!arg
->ts
.deferred
)
3101 /* Transfer by value. */
3102 type
= gfc_charlen_type_node
;
3104 /* Deferred character lengths are transferred by reference
3105 so that the value can be returned. */
3106 type
= build_pointer_type (gfc_charlen_type_node
);
3108 vec_safe_push (typelist
, type
);
3112 if (!vec_safe_is_empty (typelist
)
3113 || sym
->attr
.is_main_program
3114 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
3117 if (sym
->backend_decl
== error_mark_node
)
3118 sym
->backend_decl
= NULL_TREE
;
3122 if (alternate_return
)
3123 type
= integer_type_node
;
3124 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
3125 type
= void_type_node
;
3126 else if (sym
->attr
.mixed_entry_master
)
3127 type
= gfc_get_mixed_entry_union (sym
->ns
);
3128 else if (flag_f2c
&& sym
->ts
.type
== BT_REAL
3129 && sym
->ts
.kind
== gfc_default_real_kind
3130 && !sym
->attr
.always_explicit
)
3132 /* Special case: f2c calling conventions require that (scalar)
3133 default REAL functions return the C type double instead. f2c
3134 compatibility is only an issue with functions that don't
3135 require an explicit interface, as only these could be
3136 implemented in Fortran 77. */
3137 sym
->ts
.kind
= gfc_default_double_kind
;
3138 type
= gfc_typenode_for_spec (&sym
->ts
);
3139 sym
->ts
.kind
= gfc_default_real_kind
;
3141 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
3142 /* Procedure pointer return values. */
3144 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
3146 /* Unset proc_pointer as gfc_get_function_type
3147 is called recursively. */
3148 sym
->result
->attr
.proc_pointer
= 0;
3149 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
3150 sym
->result
->attr
.proc_pointer
= 1;
3153 type
= gfc_sym_type (sym
->result
);
3156 type
= gfc_sym_type (sym
);
3159 type
= build_varargs_function_type_vec (type
, typelist
);
3161 type
= build_function_type_vec (type
, typelist
);
3162 type
= create_fn_spec (sym
, type
);
3167 /* Language hooks for middle-end access to type nodes. */
3169 /* Return an integer type with BITS bits of precision,
3170 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3173 gfc_type_for_size (unsigned bits
, int unsignedp
)
3178 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
3180 tree type
= gfc_integer_types
[i
];
3181 if (type
&& bits
== TYPE_PRECISION (type
))
3185 /* Handle TImode as a special case because it is used by some backends
3186 (e.g. ARM) even though it is not available for normal use. */
3187 #if HOST_BITS_PER_WIDE_INT >= 64
3188 if (bits
== TYPE_PRECISION (intTI_type_node
))
3189 return intTI_type_node
;
3192 if (bits
<= TYPE_PRECISION (intQI_type_node
))
3193 return intQI_type_node
;
3194 if (bits
<= TYPE_PRECISION (intHI_type_node
))
3195 return intHI_type_node
;
3196 if (bits
<= TYPE_PRECISION (intSI_type_node
))
3197 return intSI_type_node
;
3198 if (bits
<= TYPE_PRECISION (intDI_type_node
))
3199 return intDI_type_node
;
3200 if (bits
<= TYPE_PRECISION (intTI_type_node
))
3201 return intTI_type_node
;
3205 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
3206 return unsigned_intQI_type_node
;
3207 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
3208 return unsigned_intHI_type_node
;
3209 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
3210 return unsigned_intSI_type_node
;
3211 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
3212 return unsigned_intDI_type_node
;
3213 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
3214 return unsigned_intTI_type_node
;
3220 /* Return a data type that has machine mode MODE. If the mode is an
3221 integer, then UNSIGNEDP selects between signed and unsigned types. */
3224 gfc_type_for_mode (machine_mode mode
, int unsignedp
)
3228 scalar_int_mode int_mode
;
3230 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
3231 base
= gfc_real_types
;
3232 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
3233 base
= gfc_complex_types
;
3234 else if (is_a
<scalar_int_mode
> (mode
, &int_mode
))
3236 tree type
= gfc_type_for_size (GET_MODE_PRECISION (int_mode
), unsignedp
);
3237 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
3239 else if (GET_MODE_CLASS (mode
) == MODE_VECTOR_BOOL
3240 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3242 unsigned int elem_bits
= vector_element_size (GET_MODE_BITSIZE (mode
),
3243 GET_MODE_NUNITS (mode
));
3244 tree bool_type
= build_nonstandard_boolean_type (elem_bits
);
3245 return build_vector_type_for_mode (bool_type
, mode
);
3247 else if (VECTOR_MODE_P (mode
)
3248 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3250 machine_mode inner_mode
= GET_MODE_INNER (mode
);
3251 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
3252 if (inner_type
!= NULL_TREE
)
3253 return build_vector_type_for_mode (inner_type
, mode
);
3259 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
3261 tree type
= base
[i
];
3262 if (type
&& mode
== TYPE_MODE (type
))
3269 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3273 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
3276 bool indirect
= false;
3277 tree etype
, ptype
, t
, base_decl
;
3278 tree data_off
, dim_off
, dtype_off
, dim_size
, elem_size
;
3279 tree lower_suboff
, upper_suboff
, stride_suboff
;
3280 tree dtype
, field
, rank_off
;
3282 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3284 if (! POINTER_TYPE_P (type
))
3286 type
= TREE_TYPE (type
);
3287 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3292 rank
= GFC_TYPE_ARRAY_RANK (type
);
3293 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3296 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3297 gcc_assert (POINTER_TYPE_P (etype
));
3298 etype
= TREE_TYPE (etype
);
3300 /* If the type is not a scalar coarray. */
3301 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3302 etype
= TREE_TYPE (etype
);
3304 /* Can't handle variable sized elements yet. */
3305 if (int_size_in_bytes (etype
) <= 0)
3307 /* Nor non-constant lower bounds in assumed shape arrays. */
3308 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3309 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3311 for (dim
= 0; dim
< rank
; dim
++)
3312 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3313 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3317 memset (info
, '\0', sizeof (*info
));
3318 info
->ndimensions
= rank
;
3319 info
->ordering
= array_descr_ordering_column_major
;
3320 info
->element_type
= etype
;
3321 ptype
= build_pointer_type (gfc_array_index_type
);
3322 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3325 base_decl
= make_node (DEBUG_EXPR_DECL
);
3326 DECL_ARTIFICIAL (base_decl
) = 1;
3327 TREE_TYPE (base_decl
) = indirect
? build_pointer_type (ptype
) : ptype
;
3328 SET_DECL_MODE (base_decl
, TYPE_MODE (TREE_TYPE (base_decl
)));
3329 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3331 info
->base_decl
= base_decl
;
3333 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3335 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
3337 gfc_get_descriptor_offsets_for_info (type
, &data_off
, &dtype_off
, &dim_off
,
3338 &dim_size
, &stride_suboff
,
3339 &lower_suboff
, &upper_suboff
);
3342 if (!integer_zerop (data_off
))
3343 t
= fold_build_pointer_plus (t
, data_off
);
3344 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3345 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3346 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3347 info
->allocated
= build2 (NE_EXPR
, logical_type_node
,
3348 info
->data_location
, null_pointer_node
);
3349 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3350 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3351 info
->associated
= build2 (NE_EXPR
, logical_type_node
,
3352 info
->data_location
, null_pointer_node
);
3353 if ((GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK
3354 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
)
3355 && dwarf_version
>= 5)
3358 info
->ndimensions
= 1;
3360 if (!integer_zerop (dtype_off
))
3361 t
= fold_build_pointer_plus (t
, dtype_off
);
3362 dtype
= TYPE_MAIN_VARIANT (get_dtype_type_node ());
3363 field
= gfc_advance_chain (TYPE_FIELDS (dtype
), GFC_DTYPE_RANK
);
3364 rank_off
= byte_position (field
);
3365 if (!integer_zerop (dtype_off
))
3366 t
= fold_build_pointer_plus (t
, rank_off
);
3368 t
= build1 (NOP_EXPR
, build_pointer_type (gfc_array_index_type
), t
);
3369 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3371 t
= build0 (PLACEHOLDER_EXPR
, TREE_TYPE (dim_off
));
3372 t
= size_binop (MULT_EXPR
, t
, dim_size
);
3373 dim_off
= build2 (PLUS_EXPR
, TREE_TYPE (dim_off
), t
, dim_off
);
3376 for (dim
= 0; dim
< rank
; dim
++)
3378 t
= fold_build_pointer_plus (base_decl
,
3379 size_binop (PLUS_EXPR
,
3380 dim_off
, lower_suboff
));
3381 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3382 info
->dimen
[dim
].lower_bound
= t
;
3383 t
= fold_build_pointer_plus (base_decl
,
3384 size_binop (PLUS_EXPR
,
3385 dim_off
, upper_suboff
));
3386 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3387 info
->dimen
[dim
].upper_bound
= t
;
3388 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3389 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3391 /* Assumed shape arrays have known lower bounds. */
3392 info
->dimen
[dim
].upper_bound
3393 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3394 info
->dimen
[dim
].upper_bound
,
3395 info
->dimen
[dim
].lower_bound
);
3396 info
->dimen
[dim
].lower_bound
3397 = fold_convert (gfc_array_index_type
,
3398 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3399 info
->dimen
[dim
].upper_bound
3400 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3401 info
->dimen
[dim
].lower_bound
,
3402 info
->dimen
[dim
].upper_bound
);
3404 t
= fold_build_pointer_plus (base_decl
,
3405 size_binop (PLUS_EXPR
,
3406 dim_off
, stride_suboff
));
3407 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3408 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3409 info
->dimen
[dim
].stride
= t
;
3411 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3418 /* Create a type to handle vector subscripts for coarray library calls. It
3420 struct caf_vector_t {
3421 size_t nvec; // size of the vector
3428 ptrdiff_t lower_bound;
3429 ptrdiff_t upper_bound;
3434 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3435 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3438 gfc_get_caf_vector_type (int dim
)
3440 static tree vector_types
[GFC_MAX_DIMENSIONS
];
3441 static tree vec_type
= NULL_TREE
;
3442 tree triplet_struct_type
, vect_struct_type
, union_type
, tmp
, *chain
;
3444 if (vector_types
[dim
-1] != NULL_TREE
)
3445 return vector_types
[dim
-1];
3447 if (vec_type
== NULL_TREE
)
3450 vect_struct_type
= make_node (RECORD_TYPE
);
3451 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3452 get_identifier ("vector"),
3453 pvoid_type_node
, &chain
);
3454 TREE_NO_WARNING (tmp
) = 1;
3455 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3456 get_identifier ("kind"),
3457 integer_type_node
, &chain
);
3458 TREE_NO_WARNING (tmp
) = 1;
3459 gfc_finish_type (vect_struct_type
);
3462 triplet_struct_type
= make_node (RECORD_TYPE
);
3463 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3464 get_identifier ("lower_bound"),
3465 gfc_array_index_type
, &chain
);
3466 TREE_NO_WARNING (tmp
) = 1;
3467 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3468 get_identifier ("upper_bound"),
3469 gfc_array_index_type
, &chain
);
3470 TREE_NO_WARNING (tmp
) = 1;
3471 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
, get_identifier ("stride"),
3472 gfc_array_index_type
, &chain
);
3473 TREE_NO_WARNING (tmp
) = 1;
3474 gfc_finish_type (triplet_struct_type
);
3477 union_type
= make_node (UNION_TYPE
);
3478 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3479 vect_struct_type
, &chain
);
3480 TREE_NO_WARNING (tmp
) = 1;
3481 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("triplet"),
3482 triplet_struct_type
, &chain
);
3483 TREE_NO_WARNING (tmp
) = 1;
3484 gfc_finish_type (union_type
);
3487 vec_type
= make_node (RECORD_TYPE
);
3488 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("nvec"),
3489 size_type_node
, &chain
);
3490 TREE_NO_WARNING (tmp
) = 1;
3491 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("u"),
3492 union_type
, &chain
);
3493 TREE_NO_WARNING (tmp
) = 1;
3494 gfc_finish_type (vec_type
);
3495 TYPE_NAME (vec_type
) = get_identifier ("caf_vector_t");
3498 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3499 gfc_rank_cst
[dim
-1]);
3500 vector_types
[dim
-1] = build_array_type (vec_type
, tmp
);
3501 return vector_types
[dim
-1];
3506 gfc_get_caf_reference_type ()
3508 static tree reference_type
= NULL_TREE
;
3509 tree c_struct_type
, s_struct_type
, v_struct_type
, union_type
, dim_union_type
,
3510 a_struct_type
, u_union_type
, tmp
, *chain
;
3512 if (reference_type
!= NULL_TREE
)
3513 return reference_type
;
3516 c_struct_type
= make_node (RECORD_TYPE
);
3517 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3518 get_identifier ("offset"),
3519 gfc_array_index_type
, &chain
);
3520 TREE_NO_WARNING (tmp
) = 1;
3521 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3522 get_identifier ("caf_token_offset"),
3523 gfc_array_index_type
, &chain
);
3524 TREE_NO_WARNING (tmp
) = 1;
3525 gfc_finish_type (c_struct_type
);
3528 s_struct_type
= make_node (RECORD_TYPE
);
3529 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3530 get_identifier ("start"),
3531 gfc_array_index_type
, &chain
);
3532 TREE_NO_WARNING (tmp
) = 1;
3533 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3534 get_identifier ("end"),
3535 gfc_array_index_type
, &chain
);
3536 TREE_NO_WARNING (tmp
) = 1;
3537 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3538 get_identifier ("stride"),
3539 gfc_array_index_type
, &chain
);
3540 TREE_NO_WARNING (tmp
) = 1;
3541 gfc_finish_type (s_struct_type
);
3544 v_struct_type
= make_node (RECORD_TYPE
);
3545 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3546 get_identifier ("vector"),
3547 pvoid_type_node
, &chain
);
3548 TREE_NO_WARNING (tmp
) = 1;
3549 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3550 get_identifier ("nvec"),
3551 size_type_node
, &chain
);
3552 TREE_NO_WARNING (tmp
) = 1;
3553 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3554 get_identifier ("kind"),
3555 integer_type_node
, &chain
);
3556 TREE_NO_WARNING (tmp
) = 1;
3557 gfc_finish_type (v_struct_type
);
3560 union_type
= make_node (UNION_TYPE
);
3561 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("s"),
3562 s_struct_type
, &chain
);
3563 TREE_NO_WARNING (tmp
) = 1;
3564 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3565 v_struct_type
, &chain
);
3566 TREE_NO_WARNING (tmp
) = 1;
3567 gfc_finish_type (union_type
);
3569 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3570 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1]);
3571 dim_union_type
= build_array_type (union_type
, tmp
);
3574 a_struct_type
= make_node (RECORD_TYPE
);
3575 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("mode"),
3576 build_array_type (unsigned_char_type_node
,
3577 build_range_type (gfc_array_index_type
,
3578 gfc_index_zero_node
,
3579 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1])),
3581 TREE_NO_WARNING (tmp
) = 1;
3582 tmp
= gfc_add_field_to_struct_1 (a_struct_type
,
3583 get_identifier ("static_array_type"),
3584 integer_type_node
, &chain
);
3585 TREE_NO_WARNING (tmp
) = 1;
3586 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("dim"),
3587 dim_union_type
, &chain
);
3588 TREE_NO_WARNING (tmp
) = 1;
3589 gfc_finish_type (a_struct_type
);
3592 u_union_type
= make_node (UNION_TYPE
);
3593 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("c"),
3594 c_struct_type
, &chain
);
3595 TREE_NO_WARNING (tmp
) = 1;
3596 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("a"),
3597 a_struct_type
, &chain
);
3598 TREE_NO_WARNING (tmp
) = 1;
3599 gfc_finish_type (u_union_type
);
3602 reference_type
= make_node (RECORD_TYPE
);
3603 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("next"),
3604 build_pointer_type (reference_type
), &chain
);
3605 TREE_NO_WARNING (tmp
) = 1;
3606 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("type"),
3607 integer_type_node
, &chain
);
3608 TREE_NO_WARNING (tmp
) = 1;
3609 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("item_size"),
3610 size_type_node
, &chain
);
3611 TREE_NO_WARNING (tmp
) = 1;
3612 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("u"),
3613 u_union_type
, &chain
);
3614 TREE_NO_WARNING (tmp
) = 1;
3615 gfc_finish_type (reference_type
);
3616 TYPE_NAME (reference_type
) = get_identifier ("caf_reference_t");
3618 return reference_type
;
3621 #include "gt-fortran-trans-types.h"