1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2013 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"
27 #include "tm.h" /* For INTMAX_TYPE, INT8_TYPE, INT16_TYPE, INT32_TYPE,
28 INT64_TYPE, INT_LEAST8_TYPE, INT_LEAST16_TYPE,
29 INT_LEAST32_TYPE, INT_LEAST64_TYPE, INT_FAST8_TYPE,
30 INT_FAST16_TYPE, INT_FAST32_TYPE, INT_FAST64_TYPE,
31 BOOL_TYPE_SIZE, BITS_PER_UNIT, POINTER_SIZE,
32 INT_TYPE_SIZE, CHAR_TYPE_SIZE, SHORT_TYPE_SIZE,
33 LONG_TYPE_SIZE, LONG_LONG_TYPE_SIZE,
34 FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE,
35 LONG_DOUBLE_TYPE_SIZE and LIBGCC2_HAS_TF_MODE. */
37 #include "langhooks.h" /* For iso-c-bindings.def. */
40 #include "diagnostic-core.h" /* For fatal_error. */
41 #include "toplev.h" /* For rest_of_decl_compilation. */
44 #include "trans-types.h"
45 #include "trans-const.h"
47 #include "dwarf2out.h" /* For struct array_descr_info. */
50 #if (GFC_MAX_DIMENSIONS < 10)
51 #define GFC_RANK_DIGITS 1
52 #define GFC_RANK_PRINTF_FORMAT "%01d"
53 #elif (GFC_MAX_DIMENSIONS < 100)
54 #define GFC_RANK_DIGITS 2
55 #define GFC_RANK_PRINTF_FORMAT "%02d"
57 #error If you really need >99 dimensions, continue the sequence above...
60 /* array of structs so we don't have to worry about xmalloc or free */
61 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
63 tree gfc_array_index_type
;
64 tree gfc_array_range_type
;
65 tree gfc_character1_type_node
;
67 tree prvoid_type_node
;
68 tree ppvoid_type_node
;
72 tree gfc_charlen_type_node
;
74 tree float128_type_node
= NULL_TREE
;
75 tree complex_float128_type_node
= NULL_TREE
;
77 bool gfc_real16_is_float128
= false;
79 static GTY(()) tree gfc_desc_dim_type
;
80 static GTY(()) tree gfc_max_array_element_size
;
81 static GTY(()) tree gfc_array_descriptor_base
[2 * (GFC_MAX_DIMENSIONS
+1)];
82 static GTY(()) tree gfc_array_descriptor_base_caf
[2 * (GFC_MAX_DIMENSIONS
+1)];
84 /* Arrays for all integral and real kinds. We'll fill this in at runtime
85 after the target has a chance to process command-line options. */
87 #define MAX_INT_KINDS 5
88 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
89 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
90 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
91 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
93 #define MAX_REAL_KINDS 5
94 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
95 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
96 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
98 #define MAX_CHARACTER_KINDS 2
99 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
100 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
101 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
103 static tree
gfc_add_field_to_struct_1 (tree
, tree
, tree
, tree
**);
105 /* The integer kind to use for array indices. This will be set to the
106 proper value based on target information from the backend. */
108 int gfc_index_integer_kind
;
110 /* The default kinds of the various types. */
112 int gfc_default_integer_kind
;
113 int gfc_max_integer_kind
;
114 int gfc_default_real_kind
;
115 int gfc_default_double_kind
;
116 int gfc_default_character_kind
;
117 int gfc_default_logical_kind
;
118 int gfc_default_complex_kind
;
120 int gfc_atomic_int_kind
;
121 int gfc_atomic_logical_kind
;
123 /* The kind size used for record offsets. If the target system supports
124 kind=8, this will be set to 8, otherwise it is set to 4. */
127 /* The integer kind used to store character lengths. */
128 int gfc_charlen_int_kind
;
130 /* The size of the numeric storage unit and character storage unit. */
131 int gfc_numeric_storage_size
;
132 int gfc_character_storage_size
;
136 gfc_check_any_c_kind (gfc_typespec
*ts
)
140 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
142 /* Check for any C interoperable kind for the given type/kind in ts.
143 This can be used after verify_c_interop to make sure that the
144 Fortran kind being used exists in at least some form for C. */
145 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
146 c_interop_kinds_table
[i
].value
== ts
->kind
)
155 get_real_kind_from_node (tree type
)
159 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
160 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
161 return gfc_real_kinds
[i
].kind
;
167 get_int_kind_from_node (tree type
)
174 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
175 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
176 return gfc_integer_kinds
[i
].kind
;
181 /* Return a typenode for the "standard" C type with a given name. */
183 get_typenode_from_name (const char *name
)
185 if (name
== NULL
|| *name
== '\0')
188 if (strcmp (name
, "char") == 0)
189 return char_type_node
;
190 if (strcmp (name
, "unsigned char") == 0)
191 return unsigned_char_type_node
;
192 if (strcmp (name
, "signed char") == 0)
193 return signed_char_type_node
;
195 if (strcmp (name
, "short int") == 0)
196 return short_integer_type_node
;
197 if (strcmp (name
, "short unsigned int") == 0)
198 return short_unsigned_type_node
;
200 if (strcmp (name
, "int") == 0)
201 return integer_type_node
;
202 if (strcmp (name
, "unsigned int") == 0)
203 return unsigned_type_node
;
205 if (strcmp (name
, "long int") == 0)
206 return long_integer_type_node
;
207 if (strcmp (name
, "long unsigned int") == 0)
208 return long_unsigned_type_node
;
210 if (strcmp (name
, "long long int") == 0)
211 return long_long_integer_type_node
;
212 if (strcmp (name
, "long long unsigned int") == 0)
213 return long_long_unsigned_type_node
;
219 get_int_kind_from_name (const char *name
)
221 return get_int_kind_from_node (get_typenode_from_name (name
));
225 /* Get the kind number corresponding to an integer of given size,
226 following the required return values for ISO_FORTRAN_ENV INT* constants:
227 -2 is returned if we support a kind of larger size, -1 otherwise. */
229 gfc_get_int_kind_from_width_isofortranenv (int size
)
233 /* Look for a kind with matching storage size. */
234 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
235 if (gfc_integer_kinds
[i
].bit_size
== size
)
236 return gfc_integer_kinds
[i
].kind
;
238 /* Look for a kind with larger storage size. */
239 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
240 if (gfc_integer_kinds
[i
].bit_size
> size
)
246 /* Get the kind number corresponding to a real of given storage size,
247 following the required return values for ISO_FORTRAN_ENV REAL* constants:
248 -2 is returned if we support a kind of larger size, -1 otherwise. */
250 gfc_get_real_kind_from_width_isofortranenv (int size
)
256 /* Look for a kind with matching storage size. */
257 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
258 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
259 return gfc_real_kinds
[i
].kind
;
261 /* Look for a kind with larger storage size. */
262 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
263 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
272 get_int_kind_from_width (int size
)
276 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
277 if (gfc_integer_kinds
[i
].bit_size
== size
)
278 return gfc_integer_kinds
[i
].kind
;
284 get_int_kind_from_minimal_width (int size
)
288 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
289 if (gfc_integer_kinds
[i
].bit_size
>= size
)
290 return gfc_integer_kinds
[i
].kind
;
296 /* Generate the CInteropKind_t objects for the C interoperable
300 gfc_init_c_interop_kinds (void)
304 /* init all pointers in the list to NULL */
305 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
307 /* Initialize the name and value fields. */
308 c_interop_kinds_table
[i
].name
[0] = '\0';
309 c_interop_kinds_table
[i
].value
= -100;
310 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
313 #define NAMED_INTCST(a,b,c,d) \
314 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
315 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
316 c_interop_kinds_table[a].value = c;
317 #define NAMED_REALCST(a,b,c,d) \
318 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
319 c_interop_kinds_table[a].f90_type = BT_REAL; \
320 c_interop_kinds_table[a].value = c;
321 #define NAMED_CMPXCST(a,b,c,d) \
322 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
323 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
324 c_interop_kinds_table[a].value = c;
325 #define NAMED_LOGCST(a,b,c) \
326 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
327 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
328 c_interop_kinds_table[a].value = c;
329 #define NAMED_CHARKNDCST(a,b,c) \
330 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
331 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
332 c_interop_kinds_table[a].value = c;
333 #define NAMED_CHARCST(a,b,c) \
334 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
335 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
336 c_interop_kinds_table[a].value = c;
337 #define DERIVED_TYPE(a,b,c) \
338 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
339 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
340 c_interop_kinds_table[a].value = c;
341 #define PROCEDURE(a,b) \
342 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
343 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
344 c_interop_kinds_table[a].value = 0;
345 #include "iso-c-binding.def"
346 #define NAMED_FUNCTION(a,b,c,d) \
347 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
348 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
349 c_interop_kinds_table[a].value = c;
350 #include "iso-c-binding.def"
354 /* Query the target to determine which machine modes are available for
355 computation. Choose KIND numbers for them. */
358 gfc_init_kinds (void)
361 int i_index
, r_index
, kind
;
362 bool saw_i4
= false, saw_i8
= false;
363 bool saw_r4
= false, saw_r8
= false, saw_r10
= false, saw_r16
= false;
365 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
369 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
372 /* The middle end doesn't support constants larger than 2*HWI.
373 Perhaps the target hook shouldn't have accepted these either,
374 but just to be safe... */
375 bitsize
= GET_MODE_BITSIZE (mode
);
376 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
379 gcc_assert (i_index
!= MAX_INT_KINDS
);
381 /* Let the kind equal the bit size divided by 8. This insulates the
382 programmer from the underlying byte size. */
390 gfc_integer_kinds
[i_index
].kind
= kind
;
391 gfc_integer_kinds
[i_index
].radix
= 2;
392 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
393 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
395 gfc_logical_kinds
[i_index
].kind
= kind
;
396 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
401 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
402 used for large file access. */
409 /* If we do not at least have kind = 4, everything is pointless. */
412 /* Set the maximum integer kind. Used with at least BOZ constants. */
413 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
415 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
417 const struct real_format
*fmt
=
418 REAL_MODE_FORMAT ((enum machine_mode
) mode
);
423 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
426 /* Only let float, double, long double and __float128 go through.
427 Runtime support for others is not provided, so they would be
429 if (mode
!= TYPE_MODE (float_type_node
)
430 && (mode
!= TYPE_MODE (double_type_node
))
431 && (mode
!= TYPE_MODE (long_double_type_node
))
432 #if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
438 /* Let the kind equal the precision divided by 8, rounding up. Again,
439 this insulates the programmer from the underlying byte size.
441 Also, it effectively deals with IEEE extended formats. There, the
442 total size of the type may equal 16, but it's got 6 bytes of padding
443 and the increased size can get in the way of a real IEEE quad format
444 which may also be supported by the target.
446 We round up so as to handle IA-64 __floatreg (RFmode), which is an
447 82 bit type. Not to be confused with __float80 (XFmode), which is
448 an 80 bit type also supported by IA-64. So XFmode should come out
449 to be kind=10, and RFmode should come out to be kind=11. Egads. */
451 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
462 /* Careful we don't stumble a weird internal mode. */
463 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
464 /* Or have too many modes for the allocated space. */
465 gcc_assert (r_index
!= MAX_REAL_KINDS
);
467 gfc_real_kinds
[r_index
].kind
= kind
;
468 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
469 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
470 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
471 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
472 if (fmt
->pnan
< fmt
->p
)
473 /* This is an IBM extended double format (or the MIPS variant)
474 made up of two IEEE doubles. The value of the long double is
475 the sum of the values of the two parts. The most significant
476 part is required to be the value of the long double rounded
477 to the nearest double. If we use emax of 1024 then we can't
478 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
479 rounding will make the most significant part overflow. */
480 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
481 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
485 /* Choose the default integer kind. We choose 4 unless the user directs us
486 otherwise. Even if the user specified that the default integer kind is 8,
487 the numeric storage size is not 64 bits. In this case, a warning will be
488 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
490 gfc_numeric_storage_size
= 4 * 8;
492 if (gfc_option
.flag_default_integer
)
495 fatal_error ("INTEGER(KIND=8) is not available for -fdefault-integer-8 option");
497 gfc_default_integer_kind
= 8;
500 else if (gfc_option
.flag_integer4_kind
== 8)
503 fatal_error ("INTEGER(KIND=8) is not available for -finteger-4-integer-8 option");
505 gfc_default_integer_kind
= 8;
509 gfc_default_integer_kind
= 4;
513 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
514 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
517 /* Choose the default real kind. Again, we choose 4 when possible. */
518 if (gfc_option
.flag_default_real
)
521 fatal_error ("REAL(KIND=8) is not available for -fdefault-real-8 option");
523 gfc_default_real_kind
= 8;
525 else if (gfc_option
.flag_real4_kind
== 8)
528 fatal_error ("REAL(KIND=8) is not available for -freal-4-real-8 option");
530 gfc_default_real_kind
= 8;
532 else if (gfc_option
.flag_real4_kind
== 10)
535 fatal_error ("REAL(KIND=10) is not available for -freal-4-real-10 option");
537 gfc_default_real_kind
= 10;
539 else if (gfc_option
.flag_real4_kind
== 16)
542 fatal_error ("REAL(KIND=16) is not available for -freal-4-real-16 option");
544 gfc_default_real_kind
= 16;
547 gfc_default_real_kind
= 4;
549 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
551 /* Choose the default double kind. If -fdefault-real and -fdefault-double
552 are specified, we use kind=8, if it's available. If -fdefault-real is
553 specified without -fdefault-double, we use kind=16, if it's available.
554 Otherwise we do not change anything. */
555 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
556 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
558 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
559 gfc_default_double_kind
= 8;
560 else if (gfc_option
.flag_default_real
&& saw_r16
)
561 gfc_default_double_kind
= 16;
562 else if (gfc_option
.flag_real8_kind
== 4)
565 fatal_error ("REAL(KIND=4) is not available for -freal-8-real-4 option");
567 gfc_default_double_kind
= 4;
569 else if (gfc_option
.flag_real8_kind
== 10 )
572 fatal_error ("REAL(KIND=10) is not available for -freal-8-real-10 option");
574 gfc_default_double_kind
= 10;
576 else if (gfc_option
.flag_real8_kind
== 16 )
579 fatal_error ("REAL(KIND=10) is not available for -freal-8-real-16 option");
581 gfc_default_double_kind
= 16;
583 else if (saw_r4
&& saw_r8
)
584 gfc_default_double_kind
= 8;
587 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
588 real ... occupies two contiguous numeric storage units.
590 Therefore we must be supplied a kind twice as large as we chose
591 for single precision. There are loopholes, in that double
592 precision must *occupy* two storage units, though it doesn't have
593 to *use* two storage units. Which means that you can make this
594 kind artificially wide by padding it. But at present there are
595 no GCC targets for which a two-word type does not exist, so we
596 just let gfc_validate_kind abort and tell us if something breaks. */
598 gfc_default_double_kind
599 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
602 /* The default logical kind is constrained to be the same as the
603 default integer kind. Similarly with complex and real. */
604 gfc_default_logical_kind
= gfc_default_integer_kind
;
605 gfc_default_complex_kind
= gfc_default_real_kind
;
607 /* We only have two character kinds: ASCII and UCS-4.
608 ASCII corresponds to a 8-bit integer type, if one is available.
609 UCS-4 corresponds to a 32-bit integer type, if one is available. */
611 if ((kind
= get_int_kind_from_width (8)) > 0)
613 gfc_character_kinds
[i_index
].kind
= kind
;
614 gfc_character_kinds
[i_index
].bit_size
= 8;
615 gfc_character_kinds
[i_index
].name
= "ascii";
618 if ((kind
= get_int_kind_from_width (32)) > 0)
620 gfc_character_kinds
[i_index
].kind
= kind
;
621 gfc_character_kinds
[i_index
].bit_size
= 32;
622 gfc_character_kinds
[i_index
].name
= "iso_10646";
626 /* Choose the smallest integer kind for our default character. */
627 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
628 gfc_character_storage_size
= gfc_default_character_kind
* 8;
630 gfc_index_integer_kind
= get_int_kind_from_name (PTRDIFF_TYPE
);
632 /* Pick a kind the same size as the C "int" type. */
633 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
635 /* Choose atomic kinds to match C's int. */
636 gfc_atomic_int_kind
= gfc_c_int_kind
;
637 gfc_atomic_logical_kind
= gfc_c_int_kind
;
641 /* Make sure that a valid kind is present. Returns an index into the
642 associated kinds array, -1 if the kind is not present. */
645 validate_integer (int kind
)
649 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
650 if (gfc_integer_kinds
[i
].kind
== kind
)
657 validate_real (int kind
)
661 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
662 if (gfc_real_kinds
[i
].kind
== kind
)
669 validate_logical (int kind
)
673 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
674 if (gfc_logical_kinds
[i
].kind
== kind
)
681 validate_character (int kind
)
685 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
686 if (gfc_character_kinds
[i
].kind
== kind
)
692 /* Validate a kind given a basic type. The return value is the same
693 for the child functions, with -1 indicating nonexistence of the
694 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
697 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
703 case BT_REAL
: /* Fall through */
705 rc
= validate_real (kind
);
708 rc
= validate_integer (kind
);
711 rc
= validate_logical (kind
);
714 rc
= validate_character (kind
);
718 gfc_internal_error ("gfc_validate_kind(): Got bad type");
721 if (rc
< 0 && !may_fail
)
722 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
728 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
729 Reuse common type nodes where possible. Recognize if the kind matches up
730 with a C type. This will be used later in determining which routines may
731 be scarfed from libm. */
734 gfc_build_int_type (gfc_integer_info
*info
)
736 int mode_precision
= info
->bit_size
;
738 if (mode_precision
== CHAR_TYPE_SIZE
)
740 if (mode_precision
== SHORT_TYPE_SIZE
)
742 if (mode_precision
== INT_TYPE_SIZE
)
744 if (mode_precision
== LONG_TYPE_SIZE
)
746 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
747 info
->c_long_long
= 1;
749 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
750 return intQI_type_node
;
751 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
752 return intHI_type_node
;
753 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
754 return intSI_type_node
;
755 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
756 return intDI_type_node
;
757 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
758 return intTI_type_node
;
760 return make_signed_type (mode_precision
);
764 gfc_build_uint_type (int size
)
766 if (size
== CHAR_TYPE_SIZE
)
767 return unsigned_char_type_node
;
768 if (size
== SHORT_TYPE_SIZE
)
769 return short_unsigned_type_node
;
770 if (size
== INT_TYPE_SIZE
)
771 return unsigned_type_node
;
772 if (size
== LONG_TYPE_SIZE
)
773 return long_unsigned_type_node
;
774 if (size
== LONG_LONG_TYPE_SIZE
)
775 return long_long_unsigned_type_node
;
777 return make_unsigned_type (size
);
782 gfc_build_real_type (gfc_real_info
*info
)
784 int mode_precision
= info
->mode_precision
;
787 if (mode_precision
== FLOAT_TYPE_SIZE
)
789 if (mode_precision
== DOUBLE_TYPE_SIZE
)
791 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
792 info
->c_long_double
= 1;
793 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
795 info
->c_float128
= 1;
796 gfc_real16_is_float128
= true;
799 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
800 return float_type_node
;
801 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
802 return double_type_node
;
803 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
804 return long_double_type_node
;
806 new_type
= make_node (REAL_TYPE
);
807 TYPE_PRECISION (new_type
) = mode_precision
;
808 layout_type (new_type
);
813 gfc_build_complex_type (tree scalar_type
)
817 if (scalar_type
== NULL
)
819 if (scalar_type
== float_type_node
)
820 return complex_float_type_node
;
821 if (scalar_type
== double_type_node
)
822 return complex_double_type_node
;
823 if (scalar_type
== long_double_type_node
)
824 return complex_long_double_type_node
;
826 new_type
= make_node (COMPLEX_TYPE
);
827 TREE_TYPE (new_type
) = scalar_type
;
828 layout_type (new_type
);
833 gfc_build_logical_type (gfc_logical_info
*info
)
835 int bit_size
= info
->bit_size
;
838 if (bit_size
== BOOL_TYPE_SIZE
)
841 return boolean_type_node
;
844 new_type
= make_unsigned_type (bit_size
);
845 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
846 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
847 TYPE_PRECISION (new_type
) = 1;
853 /* Create the backend type nodes. We map them to their
854 equivalent C type, at least for now. We also give
855 names to the types here, and we push them in the
856 global binding level context.*/
859 gfc_init_types (void)
865 unsigned HOST_WIDE_INT hi
;
866 unsigned HOST_WIDE_INT lo
;
868 /* Create and name the types. */
869 #define PUSH_TYPE(name, node) \
870 pushdecl (build_decl (input_location, \
871 TYPE_DECL, get_identifier (name), node))
873 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
875 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
876 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
877 if (TYPE_STRING_FLAG (type
))
878 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
879 gfc_integer_types
[index
] = type
;
880 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
881 gfc_integer_kinds
[index
].kind
);
882 PUSH_TYPE (name_buf
, type
);
885 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
887 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
888 gfc_logical_types
[index
] = type
;
889 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
890 gfc_logical_kinds
[index
].kind
);
891 PUSH_TYPE (name_buf
, type
);
894 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
896 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
897 gfc_real_types
[index
] = type
;
898 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
899 gfc_real_kinds
[index
].kind
);
900 PUSH_TYPE (name_buf
, type
);
902 if (gfc_real_kinds
[index
].c_float128
)
903 float128_type_node
= type
;
905 type
= gfc_build_complex_type (type
);
906 gfc_complex_types
[index
] = type
;
907 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
908 gfc_real_kinds
[index
].kind
);
909 PUSH_TYPE (name_buf
, type
);
911 if (gfc_real_kinds
[index
].c_float128
)
912 complex_float128_type_node
= type
;
915 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
917 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
918 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
919 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
920 gfc_character_kinds
[index
].kind
);
921 PUSH_TYPE (name_buf
, type
);
922 gfc_character_types
[index
] = type
;
923 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
925 gfc_character1_type_node
= gfc_character_types
[0];
927 PUSH_TYPE ("byte", unsigned_char_type_node
);
928 PUSH_TYPE ("void", void_type_node
);
930 /* DBX debugging output gets upset if these aren't set. */
931 if (!TYPE_NAME (integer_type_node
))
932 PUSH_TYPE ("c_integer", integer_type_node
);
933 if (!TYPE_NAME (char_type_node
))
934 PUSH_TYPE ("c_char", char_type_node
);
938 pvoid_type_node
= build_pointer_type (void_type_node
);
939 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
940 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
941 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
943 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
945 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
946 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
947 since this function is called before gfc_init_constants. */
949 = build_range_type (gfc_array_index_type
,
950 build_int_cst (gfc_array_index_type
, 0),
953 /* The maximum array element size that can be handled is determined
954 by the number of bits available to store this field in the array
957 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
958 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
959 if (n
> HOST_BITS_PER_WIDE_INT
)
960 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
962 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
963 gfc_max_array_element_size
964 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
966 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
967 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
968 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
970 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
971 gfc_charlen_int_kind
= 4;
972 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
975 /* Get the type node for the given type and kind. */
978 gfc_get_int_type (int kind
)
980 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
981 return index
< 0 ? 0 : gfc_integer_types
[index
];
985 gfc_get_real_type (int kind
)
987 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
988 return index
< 0 ? 0 : gfc_real_types
[index
];
992 gfc_get_complex_type (int kind
)
994 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
995 return index
< 0 ? 0 : gfc_complex_types
[index
];
999 gfc_get_logical_type (int kind
)
1001 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
1002 return index
< 0 ? 0 : gfc_logical_types
[index
];
1006 gfc_get_char_type (int kind
)
1008 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1009 return index
< 0 ? 0 : gfc_character_types
[index
];
1013 gfc_get_pchar_type (int kind
)
1015 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1016 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
1020 /* Create a character type with the given kind and length. */
1023 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
1027 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
1028 type
= build_array_type (eltype
, bounds
);
1029 TYPE_STRING_FLAG (type
) = 1;
1035 gfc_get_character_type_len (int kind
, tree len
)
1037 gfc_validate_kind (BT_CHARACTER
, kind
, false);
1038 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
1042 /* Get a type node for a character kind. */
1045 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
1049 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1051 return gfc_get_character_type_len (kind
, len
);
1054 /* Covert a basic type. This will be an array for character types. */
1057 gfc_typenode_for_spec (gfc_typespec
* spec
)
1067 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1068 has been resolved. This is done so we can convert C_PTR and
1069 C_FUNPTR to simple variables that get translated to (void *). */
1070 if (spec
->f90_type
== BT_VOID
)
1073 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1074 basetype
= ptr_type_node
;
1076 basetype
= pfunc_type_node
;
1079 basetype
= gfc_get_int_type (spec
->kind
);
1083 basetype
= gfc_get_real_type (spec
->kind
);
1087 basetype
= gfc_get_complex_type (spec
->kind
);
1091 basetype
= gfc_get_logical_type (spec
->kind
);
1097 basetype
= gfc_get_character_type (spec
->kind
, NULL
);
1100 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1105 basetype
= gfc_get_derived_type (spec
->u
.derived
);
1107 if (spec
->type
== BT_CLASS
)
1108 GFC_CLASS_TYPE_P (basetype
) = 1;
1110 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1111 type and kind to fit a (void *) and the basetype returned was a
1112 ptr_type_node. We need to pass up this new information to the
1113 symbol that was declared of type C_PTR or C_FUNPTR. */
1114 if (spec
->u
.derived
->attr
.is_iso_c
)
1116 spec
->type
= spec
->u
.derived
->ts
.type
;
1117 spec
->kind
= spec
->u
.derived
->ts
.kind
;
1118 spec
->f90_type
= spec
->u
.derived
->ts
.f90_type
;
1123 /* This is for the second arg to c_f_pointer and c_f_procpointer
1124 of the iso_c_binding module, to accept any ptr type. */
1125 basetype
= ptr_type_node
;
1126 if (spec
->f90_type
== BT_VOID
)
1129 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1130 basetype
= ptr_type_node
;
1132 basetype
= pfunc_type_node
;
1141 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1144 gfc_conv_array_bound (gfc_expr
* expr
)
1146 /* If expr is an integer constant, return that. */
1147 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1148 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1150 /* Otherwise return NULL. */
1155 gfc_get_element_type (tree type
)
1159 if (GFC_ARRAY_TYPE_P (type
))
1161 if (TREE_CODE (type
) == POINTER_TYPE
)
1162 type
= TREE_TYPE (type
);
1163 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1165 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1170 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1171 element
= TREE_TYPE (type
);
1176 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1177 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1179 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1180 element
= TREE_TYPE (element
);
1182 /* For arrays, which are not scalar coarrays. */
1183 if (TREE_CODE (element
) == ARRAY_TYPE
)
1184 element
= TREE_TYPE (element
);
1190 /* Build an array. This function is called from gfc_sym_type().
1191 Actually returns array descriptor type.
1193 Format of array descriptors is as follows:
1195 struct gfc_array_descriptor
1200 struct descriptor_dimension dimension[N_DIM];
1203 struct descriptor_dimension
1210 Translation code should use gfc_conv_descriptor_* rather than
1211 accessing the descriptor directly. Any changes to the array
1212 descriptor type will require changes in gfc_conv_descriptor_* and
1213 gfc_build_array_initializer.
1215 This is represented internally as a RECORD_TYPE. The index nodes
1216 are gfc_array_index_type and the data node is a pointer to the
1217 data. See below for the handling of character types.
1219 The dtype member is formatted as follows:
1220 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1221 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1222 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1224 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1225 this generated poor code for assumed/deferred size arrays. These
1226 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1227 of the GENERIC grammar. Also, there is no way to explicitly set
1228 the array stride, so all data must be packed(1). I've tried to
1229 mark all the functions which would require modification with a GCC
1232 The data component points to the first element in the array. The
1233 offset field is the position of the origin of the array (i.e. element
1234 (0, 0 ...)). This may be outside the bounds of the array.
1236 An element is accessed by
1237 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1238 This gives good performance as the computation does not involve the
1239 bounds of the array. For packed arrays, this is optimized further
1240 by substituting the known strides.
1242 This system has one problem: all array bounds must be within 2^31
1243 elements of the origin (2^63 on 64-bit machines). For example
1244 integer, dimension (80000:90000, 80000:90000, 2) :: array
1245 may not work properly on 32-bit machines because 80000*80000 >
1246 2^31, so the calculation for stride2 would overflow. This may
1247 still work, but I haven't checked, and it relies on the overflow
1248 doing the right thing.
1250 The way to fix this problem is to access elements as follows:
1251 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1252 Obviously this is much slower. I will make this a compile time
1253 option, something like -fsmall-array-offsets. Mixing code compiled
1254 with and without this switch will work.
1256 (1) This can be worked around by modifying the upper bound of the
1257 previous dimension. This requires extra fields in the descriptor
1258 (both real_ubound and fake_ubound). */
1261 /* Returns true if the array sym does not require a descriptor. */
1264 gfc_is_nodesc_array (gfc_symbol
* sym
)
1266 gcc_assert (sym
->attr
.dimension
|| sym
->attr
.codimension
);
1268 /* We only want local arrays. */
1269 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1272 /* We want a descriptor for associate-name arrays that do not have an
1273 explicitly known shape already. */
1274 if (sym
->assoc
&& sym
->as
->type
!= AS_EXPLICIT
)
1277 if (sym
->attr
.dummy
)
1278 return sym
->as
->type
!= AS_ASSUMED_SHAPE
1279 && sym
->as
->type
!= AS_ASSUMED_RANK
;
1281 if (sym
->attr
.result
|| sym
->attr
.function
)
1284 gcc_assert (sym
->as
->type
== AS_EXPLICIT
|| sym
->as
->cp_was_assumed
);
1290 /* Create an array descriptor type. */
1293 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1294 enum gfc_array_kind akind
, bool restricted
,
1297 tree lbound
[GFC_MAX_DIMENSIONS
];
1298 tree ubound
[GFC_MAX_DIMENSIONS
];
1301 if (as
->type
== AS_ASSUMED_RANK
)
1302 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1304 lbound
[n
] = NULL_TREE
;
1305 ubound
[n
] = NULL_TREE
;
1308 for (n
= 0; n
< as
->rank
; n
++)
1310 /* Create expressions for the known bounds of the array. */
1311 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1312 lbound
[n
] = gfc_index_one_node
;
1314 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1315 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1318 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1320 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1321 lbound
[n
] = gfc_index_one_node
;
1323 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1325 if (n
< as
->rank
+ as
->corank
- 1)
1326 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1329 if (as
->type
== AS_ASSUMED_SHAPE
)
1330 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1331 : GFC_ARRAY_ASSUMED_SHAPE
;
1332 else if (as
->type
== AS_ASSUMED_RANK
)
1333 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1334 : GFC_ARRAY_ASSUMED_RANK
;
1335 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1336 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1338 ubound
, 0, akind
, restricted
);
1341 /* Returns the struct descriptor_dimension type. */
1344 gfc_get_desc_dim_type (void)
1347 tree decl
, *chain
= NULL
;
1349 if (gfc_desc_dim_type
)
1350 return gfc_desc_dim_type
;
1352 /* Build the type node. */
1353 type
= make_node (RECORD_TYPE
);
1355 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1356 TYPE_PACKED (type
) = 1;
1358 /* Consists of the stride, lbound and ubound members. */
1359 decl
= gfc_add_field_to_struct_1 (type
,
1360 get_identifier ("stride"),
1361 gfc_array_index_type
, &chain
);
1362 TREE_NO_WARNING (decl
) = 1;
1364 decl
= gfc_add_field_to_struct_1 (type
,
1365 get_identifier ("lbound"),
1366 gfc_array_index_type
, &chain
);
1367 TREE_NO_WARNING (decl
) = 1;
1369 decl
= gfc_add_field_to_struct_1 (type
,
1370 get_identifier ("ubound"),
1371 gfc_array_index_type
, &chain
);
1372 TREE_NO_WARNING (decl
) = 1;
1374 /* Finish off the type. */
1375 gfc_finish_type (type
);
1376 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1378 gfc_desc_dim_type
= type
;
1383 /* Return the DTYPE for an array. This describes the type and type parameters
1385 /* TODO: Only call this when the value is actually used, and make all the
1386 unknown cases abort. */
1389 gfc_get_dtype (tree type
)
1399 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1401 if (GFC_TYPE_ARRAY_DTYPE (type
))
1402 return GFC_TYPE_ARRAY_DTYPE (type
);
1404 rank
= GFC_TYPE_ARRAY_RANK (type
);
1405 etype
= gfc_get_element_type (type
);
1407 switch (TREE_CODE (etype
))
1425 /* We will never have arrays of arrays. */
1439 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1440 /* We can strange array types for temporary arrays. */
1441 return gfc_index_zero_node
;
1444 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1445 size
= TYPE_SIZE_UNIT (etype
);
1447 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1448 if (size
&& INTEGER_CST_P (size
))
1450 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1451 gfc_fatal_error ("Array element size too big at %C");
1453 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1455 dtype
= build_int_cst (gfc_array_index_type
, i
);
1457 if (size
&& !INTEGER_CST_P (size
))
1459 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1460 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
,
1461 gfc_array_index_type
,
1462 fold_convert (gfc_array_index_type
, size
), tmp
);
1463 dtype
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1466 /* If we don't know the size we leave it as zero. This should never happen
1467 for anything that is actually used. */
1468 /* TODO: Check this is actually true, particularly when repacking
1469 assumed size parameters. */
1471 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1476 /* Build an array type for use without a descriptor, packed according
1477 to the value of PACKED. */
1480 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1494 mpz_init_set_ui (offset
, 0);
1495 mpz_init_set_ui (stride
, 1);
1498 /* We don't use build_array_type because this does not include include
1499 lang-specific information (i.e. the bounds of the array) when checking
1502 type
= make_node (ARRAY_TYPE
);
1504 type
= build_variant_type_copy (etype
);
1506 GFC_ARRAY_TYPE_P (type
) = 1;
1507 TYPE_LANG_SPECIFIC (type
)
1508 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1510 known_stride
= (packed
!= PACKED_NO
);
1512 for (n
= 0; n
< as
->rank
; n
++)
1514 /* Fill in the stride and bound components of the type. */
1516 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1519 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1521 expr
= as
->lower
[n
];
1522 if (expr
->expr_type
== EXPR_CONSTANT
)
1524 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1525 gfc_index_integer_kind
);
1532 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1536 /* Calculate the offset. */
1537 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1538 mpz_sub (offset
, offset
, delta
);
1543 expr
= as
->upper
[n
];
1544 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1546 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1547 gfc_index_integer_kind
);
1554 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1558 /* Calculate the stride. */
1559 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1560 as
->lower
[n
]->value
.integer
);
1561 mpz_add_ui (delta
, delta
, 1);
1562 mpz_mul (stride
, stride
, delta
);
1565 /* Only the first stride is known for partial packed arrays. */
1566 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1569 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1571 expr
= as
->lower
[n
];
1572 if (expr
->expr_type
== EXPR_CONSTANT
)
1573 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1574 gfc_index_integer_kind
);
1577 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1579 expr
= as
->upper
[n
];
1580 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1581 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1582 gfc_index_integer_kind
);
1585 if (n
< as
->rank
+ as
->corank
- 1)
1586 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1591 GFC_TYPE_ARRAY_OFFSET (type
) =
1592 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1595 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1599 GFC_TYPE_ARRAY_SIZE (type
) =
1600 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1603 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1605 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1606 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1607 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1608 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1610 /* TODO: use main type if it is unbounded. */
1611 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1612 build_pointer_type (build_array_type (etype
, range
));
1614 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1615 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1616 TYPE_QUAL_RESTRICT
);
1620 if (packed
!= PACKED_STATIC
|| gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
1622 type
= build_pointer_type (type
);
1625 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1627 GFC_ARRAY_TYPE_P (type
) = 1;
1628 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1636 mpz_sub_ui (stride
, stride
, 1);
1637 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1642 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1643 TYPE_DOMAIN (type
) = range
;
1645 build_pointer_type (etype
);
1646 TREE_TYPE (type
) = etype
;
1654 /* Represent packed arrays as multi-dimensional if they have rank >
1655 1 and with proper bounds, instead of flat arrays. This makes for
1656 better debug info. */
1659 tree gtype
= etype
, rtype
, type_decl
;
1661 for (n
= as
->rank
- 1; n
>= 0; n
--)
1663 rtype
= build_range_type (gfc_array_index_type
,
1664 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1665 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1666 gtype
= build_array_type (gtype
, rtype
);
1668 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1669 TYPE_DECL
, NULL
, gtype
);
1670 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1673 if (packed
!= PACKED_STATIC
|| !known_stride
1674 || (as
->corank
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
))
1676 /* For dummy arrays and automatic (heap allocated) arrays we
1677 want a pointer to the array. */
1678 type
= build_pointer_type (type
);
1680 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1681 GFC_ARRAY_TYPE_P (type
) = 1;
1682 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1688 /* Return or create the base type for an array descriptor. */
1691 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
,
1692 enum gfc_array_kind akind
)
1694 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1695 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1698 /* Assumed-rank array. */
1700 dimen
= GFC_MAX_DIMENSIONS
;
1702 idx
= 2 * (codimen
+ dimen
) + restricted
;
1704 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1706 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1708 if (gfc_array_descriptor_base_caf
[idx
])
1709 return gfc_array_descriptor_base_caf
[idx
];
1711 else if (gfc_array_descriptor_base
[idx
])
1712 return gfc_array_descriptor_base
[idx
];
1714 /* Build the type node. */
1715 fat_type
= make_node (RECORD_TYPE
);
1717 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1718 TYPE_NAME (fat_type
) = get_identifier (name
);
1719 TYPE_NAMELESS (fat_type
) = 1;
1721 /* Add the data member as the first element of the descriptor. */
1722 decl
= gfc_add_field_to_struct_1 (fat_type
,
1723 get_identifier ("data"),
1726 : ptr_type_node
), &chain
);
1728 /* Add the base component. */
1729 decl
= gfc_add_field_to_struct_1 (fat_type
,
1730 get_identifier ("offset"),
1731 gfc_array_index_type
, &chain
);
1732 TREE_NO_WARNING (decl
) = 1;
1734 /* Add the dtype component. */
1735 decl
= gfc_add_field_to_struct_1 (fat_type
,
1736 get_identifier ("dtype"),
1737 gfc_array_index_type
, &chain
);
1738 TREE_NO_WARNING (decl
) = 1;
1740 /* Build the array type for the stride and bound components. */
1741 if (dimen
+ codimen
> 0)
1744 build_array_type (gfc_get_desc_dim_type (),
1745 build_range_type (gfc_array_index_type
,
1746 gfc_index_zero_node
,
1747 gfc_rank_cst
[codimen
+ dimen
- 1]));
1749 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1751 TREE_NO_WARNING (decl
) = 1;
1754 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& codimen
1755 && akind
== GFC_ARRAY_ALLOCATABLE
)
1757 decl
= gfc_add_field_to_struct_1 (fat_type
,
1758 get_identifier ("token"),
1759 prvoid_type_node
, &chain
);
1760 TREE_NO_WARNING (decl
) = 1;
1763 /* Finish off the type. */
1764 gfc_finish_type (fat_type
);
1765 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1767 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& codimen
1768 && akind
== GFC_ARRAY_ALLOCATABLE
)
1769 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1771 gfc_array_descriptor_base
[idx
] = fat_type
;
1777 /* Build an array (descriptor) type with given bounds. */
1780 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1781 tree
* ubound
, int packed
,
1782 enum gfc_array_kind akind
, bool restricted
)
1784 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1785 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1786 const char *type_name
;
1789 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
, akind
);
1790 fat_type
= build_distinct_type_copy (base_type
);
1791 /* Make sure that nontarget and target array type have the same canonical
1792 type (and same stub decl for debug info). */
1793 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false, akind
);
1794 TYPE_CANONICAL (fat_type
) = base_type
;
1795 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1797 tmp
= TYPE_NAME (etype
);
1798 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1799 tmp
= DECL_NAME (tmp
);
1801 type_name
= IDENTIFIER_POINTER (tmp
);
1803 type_name
= "unknown";
1804 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1805 GFC_MAX_SYMBOL_LEN
, type_name
);
1806 TYPE_NAME (fat_type
) = get_identifier (name
);
1807 TYPE_NAMELESS (fat_type
) = 1;
1809 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1810 TYPE_LANG_SPECIFIC (fat_type
)
1811 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1813 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1814 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1815 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1816 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1818 /* Build an array descriptor record type. */
1820 stride
= gfc_index_one_node
;
1823 for (n
= 0; n
< dimen
+ codimen
; n
++)
1826 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1833 if (lower
!= NULL_TREE
)
1835 if (INTEGER_CST_P (lower
))
1836 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1841 if (codimen
&& n
== dimen
+ codimen
- 1)
1845 if (upper
!= NULL_TREE
)
1847 if (INTEGER_CST_P (upper
))
1848 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1856 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1858 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1859 gfc_array_index_type
, upper
, lower
);
1860 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1861 gfc_array_index_type
, tmp
,
1862 gfc_index_one_node
);
1863 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1864 gfc_array_index_type
, tmp
, stride
);
1865 /* Check the folding worked. */
1866 gcc_assert (INTEGER_CST_P (stride
));
1871 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1873 /* TODO: known offsets for descriptors. */
1874 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1878 arraytype
= build_pointer_type (etype
);
1880 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1882 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1886 /* We define data as an array with the correct size if possible.
1887 Much better than doing pointer arithmetic. */
1889 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1890 int_const_binop (MINUS_EXPR
, stride
,
1893 rtype
= gfc_array_range_type
;
1894 arraytype
= build_array_type (etype
, rtype
);
1895 arraytype
= build_pointer_type (arraytype
);
1897 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1898 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1900 /* This will generate the base declarations we need to emit debug
1901 information for this type. FIXME: there must be a better way to
1902 avoid divergence between compilations with and without debug
1905 struct array_descr_info info
;
1906 gfc_get_array_descr_info (fat_type
, &info
);
1907 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
1913 /* Build a pointer type. This function is called from gfc_sym_type(). */
1916 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1918 /* Array pointer types aren't actually pointers. */
1919 if (sym
->attr
.dimension
)
1922 return build_pointer_type (type
);
1925 static tree
gfc_nonrestricted_type (tree t
);
1926 /* Given two record or union type nodes TO and FROM, ensure
1927 that all fields in FROM have a corresponding field in TO,
1928 their type being nonrestrict variants. This accepts a TO
1929 node that already has a prefix of the fields in FROM. */
1931 mirror_fields (tree to
, tree from
)
1936 /* Forward to the end of TOs fields. */
1937 fto
= TYPE_FIELDS (to
);
1938 ffrom
= TYPE_FIELDS (from
);
1939 chain
= &TYPE_FIELDS (to
);
1942 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
1943 chain
= &DECL_CHAIN (fto
);
1944 fto
= DECL_CHAIN (fto
);
1945 ffrom
= DECL_CHAIN (ffrom
);
1948 /* Now add all fields remaining in FROM (starting with ffrom). */
1949 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
1951 tree newfield
= copy_node (ffrom
);
1952 DECL_CONTEXT (newfield
) = to
;
1953 /* The store to DECL_CHAIN might seem redundant with the
1954 stores to *chain, but not clearing it here would mean
1955 leaving a chain into the old fields. If ever
1956 our called functions would look at them confusion
1958 DECL_CHAIN (newfield
) = NULL_TREE
;
1960 chain
= &DECL_CHAIN (newfield
);
1962 if (TREE_CODE (ffrom
) == FIELD_DECL
)
1964 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
1965 TREE_TYPE (newfield
) = elemtype
;
1971 /* Given a type T, returns a different type of the same structure,
1972 except that all types it refers to (recursively) are always
1973 non-restrict qualified types. */
1975 gfc_nonrestricted_type (tree t
)
1979 /* If the type isn't laid out yet, don't copy it. If something
1980 needs it for real it should wait until the type got finished. */
1984 if (!TYPE_LANG_SPECIFIC (t
))
1985 TYPE_LANG_SPECIFIC (t
)
1986 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1987 /* If we're dealing with this very node already further up
1988 the call chain (recursion via pointers and struct members)
1989 we haven't yet determined if we really need a new type node.
1990 Assume we don't, return T itself. */
1991 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
1994 /* If we have calculated this all already, just return it. */
1995 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
1996 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
1998 /* Mark this type. */
1999 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2001 switch (TREE_CODE (t
))
2007 case REFERENCE_TYPE
:
2009 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2010 if (totype
== TREE_TYPE (t
))
2012 else if (TREE_CODE (t
) == POINTER_TYPE
)
2013 ret
= build_pointer_type (totype
);
2015 ret
= build_reference_type (totype
);
2016 ret
= build_qualified_type (ret
,
2017 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2023 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2024 if (elemtype
== TREE_TYPE (t
))
2028 ret
= build_variant_type_copy (t
);
2029 TREE_TYPE (ret
) = elemtype
;
2030 if (TYPE_LANG_SPECIFIC (t
)
2031 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2033 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2034 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2035 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2037 TYPE_LANG_SPECIFIC (ret
)
2038 = ggc_alloc_cleared_lang_type (sizeof (struct
2040 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2041 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2050 case QUAL_UNION_TYPE
:
2053 /* First determine if we need a new type at all.
2054 Careful, the two calls to gfc_nonrestricted_type per field
2055 might return different values. That happens exactly when
2056 one of the fields reaches back to this very record type
2057 (via pointers). The first calls will assume that we don't
2058 need to copy T (see the error_mark_node marking). If there
2059 are any reasons for copying T apart from having to copy T,
2060 we'll indeed copy it, and the second calls to
2061 gfc_nonrestricted_type will use that new node if they
2063 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2064 if (TREE_CODE (field
) == FIELD_DECL
)
2066 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2067 if (elemtype
!= TREE_TYPE (field
))
2072 ret
= build_variant_type_copy (t
);
2073 TYPE_FIELDS (ret
) = NULL_TREE
;
2075 /* Here we make sure that as soon as we know we have to copy
2076 T, that also fields reaching back to us will use the new
2077 copy. It's okay if that copy still contains the old fields,
2078 we won't look at them. */
2079 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2080 mirror_fields (ret
, t
);
2085 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2090 /* Return the type for a symbol. Special handling is required for character
2091 types to get the correct level of indirection.
2092 For functions return the return type.
2093 For subroutines return void_type_node.
2094 Calling this multiple times for the same symbol should be avoided,
2095 especially for character and array types. */
2098 gfc_sym_type (gfc_symbol
* sym
)
2104 /* Procedure Pointers inside COMMON blocks. */
2105 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2107 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2108 sym
->attr
.proc_pointer
= 0;
2109 type
= build_pointer_type (gfc_get_function_type (sym
));
2110 sym
->attr
.proc_pointer
= 1;
2114 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2115 return void_type_node
;
2117 /* In the case of a function the fake result variable may have a
2118 type different from the function type, so don't return early in
2120 if (sym
->backend_decl
&& !sym
->attr
.function
)
2121 return TREE_TYPE (sym
->backend_decl
);
2123 if (sym
->ts
.type
== BT_CHARACTER
2124 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2125 || (sym
->attr
.result
2126 && sym
->ns
->proc_name
2127 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
2128 type
= gfc_character1_type_node
;
2130 type
= gfc_typenode_for_spec (&sym
->ts
);
2132 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2137 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2138 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2140 type
= gfc_nonrestricted_type (type
);
2142 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2144 if (gfc_is_nodesc_array (sym
))
2146 /* If this is a character argument of unknown length, just use the
2148 if (sym
->ts
.type
!= BT_CHARACTER
2149 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2150 || sym
->ts
.u
.cl
->backend_decl
)
2152 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2159 if (sym
->attr
.cray_pointee
)
2160 GFC_POINTER_TYPE_P (type
) = 1;
2164 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2165 if (sym
->attr
.pointer
)
2166 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2167 : GFC_ARRAY_POINTER
;
2168 else if (sym
->attr
.allocatable
)
2169 akind
= GFC_ARRAY_ALLOCATABLE
;
2170 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2171 sym
->attr
.contiguous
);
2176 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2177 || gfc_is_associate_pointer (sym
))
2178 type
= gfc_build_pointer_type (sym
, type
);
2179 if (sym
->attr
.pointer
|| sym
->attr
.cray_pointee
)
2180 GFC_POINTER_TYPE_P (type
) = 1;
2183 /* We currently pass all parameters by reference.
2184 See f95_get_function_decl. For dummy function parameters return the
2188 /* We must use pointer types for potentially absent variables. The
2189 optimizers assume a reference type argument is never NULL. */
2190 if (sym
->attr
.optional
2191 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2192 type
= build_pointer_type (type
);
2195 type
= build_reference_type (type
);
2197 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2204 /* Layout and output debug info for a record type. */
2207 gfc_finish_type (tree type
)
2211 decl
= build_decl (input_location
,
2212 TYPE_DECL
, NULL_TREE
, type
);
2213 TYPE_STUB_DECL (type
) = decl
;
2215 rest_of_type_compilation (type
, 1);
2216 rest_of_decl_compilation (decl
, 1, 0);
2219 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2220 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2221 to the end of the field list pointed to by *CHAIN.
2223 Returns a pointer to the new field. */
2226 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2228 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2230 DECL_CONTEXT (decl
) = context
;
2231 DECL_CHAIN (decl
) = NULL_TREE
;
2232 if (TYPE_FIELDS (context
) == NULL_TREE
)
2233 TYPE_FIELDS (context
) = decl
;
2238 *chain
= &DECL_CHAIN (decl
);
2244 /* Like `gfc_add_field_to_struct_1', but adds alignment
2248 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2250 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2252 DECL_INITIAL (decl
) = 0;
2253 DECL_ALIGN (decl
) = 0;
2254 DECL_USER_ALIGN (decl
) = 0;
2260 /* Copy the backend_decl and component backend_decls if
2261 the two derived type symbols are "equal", as described
2262 in 4.4.2 and resolved by gfc_compare_derived_types. */
2265 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2268 gfc_component
*to_cm
;
2269 gfc_component
*from_cm
;
2274 if (from
->backend_decl
== NULL
2275 || !gfc_compare_derived_types (from
, to
))
2278 to
->backend_decl
= from
->backend_decl
;
2280 to_cm
= to
->components
;
2281 from_cm
= from
->components
;
2283 /* Copy the component declarations. If a component is itself
2284 a derived type, we need a copy of its component declarations.
2285 This is done by recursing into gfc_get_derived_type and
2286 ensures that the component's component declarations have
2287 been built. If it is a character, we need the character
2289 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2291 to_cm
->backend_decl
= from_cm
->backend_decl
;
2292 if (from_cm
->ts
.type
== BT_DERIVED
2293 && (!from_cm
->attr
.pointer
|| from_gsym
))
2294 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2295 else if (from_cm
->ts
.type
== BT_CLASS
2296 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2297 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2298 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2299 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2306 /* Build a tree node for a procedure pointer component. */
2309 gfc_get_ppc_type (gfc_component
* c
)
2313 /* Explicit interface. */
2314 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2315 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2317 /* Implicit interface (only return value may be known). */
2318 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2319 t
= gfc_typenode_for_spec (&c
->ts
);
2323 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2327 /* Build a tree node for a derived type. If there are equal
2328 derived types, with different local names, these are built
2329 at the same time. If an equal derived type has been built
2330 in a parent namespace, this is used. */
2333 gfc_get_derived_type (gfc_symbol
* derived
)
2335 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2336 tree canonical
= NULL_TREE
;
2338 bool got_canonical
= false;
2339 bool unlimited_entity
= false;
2344 if (derived
->attr
.unlimited_polymorphic
)
2345 return ptr_type_node
;
2347 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2348 && derived
->attr
.generic
)
2349 derived
= gfc_find_dt_in_generic (derived
);
2351 /* See if it's one of the iso_c_binding derived types. */
2352 if (derived
->attr
.is_iso_c
== 1)
2354 if (derived
->backend_decl
)
2355 return derived
->backend_decl
;
2357 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2358 derived
->backend_decl
= ptr_type_node
;
2360 derived
->backend_decl
= pfunc_type_node
;
2362 derived
->ts
.kind
= gfc_index_integer_kind
;
2363 derived
->ts
.type
= BT_INTEGER
;
2364 /* Set the f90_type to BT_VOID as a way to recognize something of type
2365 BT_INTEGER that needs to fit a void * for the purpose of the
2366 iso_c_binding derived types. */
2367 derived
->ts
.f90_type
= BT_VOID
;
2369 return derived
->backend_decl
;
2372 /* If use associated, use the module type for this one. */
2373 if (gfc_option
.flag_whole_file
2374 && derived
->backend_decl
== NULL
2375 && derived
->attr
.use_assoc
2377 && gfc_get_module_backend_decl (derived
))
2378 goto copy_derived_types
;
2380 /* If a whole file compilation, the derived types from an earlier
2381 namespace can be used as the canonical type. */
2382 if (gfc_option
.flag_whole_file
2383 && derived
->backend_decl
== NULL
2384 && !derived
->attr
.use_assoc
2385 && gfc_global_ns_list
)
2387 for (ns
= gfc_global_ns_list
;
2388 ns
->translated
&& !got_canonical
;
2391 dt
= ns
->derived_types
;
2392 for (; dt
&& !canonical
; dt
= dt
->next
)
2394 gfc_copy_dt_decls_ifequal (dt
->derived
, derived
, true);
2395 if (derived
->backend_decl
)
2396 got_canonical
= true;
2401 /* Store up the canonical type to be added to this one. */
2404 if (TYPE_CANONICAL (derived
->backend_decl
))
2405 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2407 canonical
= derived
->backend_decl
;
2409 derived
->backend_decl
= NULL_TREE
;
2412 /* derived->backend_decl != 0 means we saw it before, but its
2413 components' backend_decl may have not been built. */
2414 if (derived
->backend_decl
)
2416 /* Its components' backend_decl have been built or we are
2417 seeing recursion through the formal arglist of a procedure
2418 pointer component. */
2419 if (TYPE_FIELDS (derived
->backend_decl
)
2420 || derived
->attr
.proc_pointer_comp
)
2421 return derived
->backend_decl
;
2423 typenode
= derived
->backend_decl
;
2427 /* We see this derived type first time, so build the type node. */
2428 typenode
= make_node (RECORD_TYPE
);
2429 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2430 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
2431 derived
->backend_decl
= typenode
;
2434 if (derived
->components
2435 && derived
->components
->ts
.type
== BT_DERIVED
2436 && strcmp (derived
->components
->name
, "_data") == 0
2437 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2438 unlimited_entity
= true;
2440 /* Go through the derived type components, building them as
2441 necessary. The reason for doing this now is that it is
2442 possible to recurse back to this derived type through a
2443 pointer component (PR24092). If this happens, the fields
2444 will be built and so we can return the type. */
2445 for (c
= derived
->components
; c
; c
= c
->next
)
2447 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2450 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
2451 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2452 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
);
2454 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2456 /* Need to copy the modified ts from the derived type. The
2457 typespec was modified because C_PTR/C_FUNPTR are translated
2458 into (void *) from derived types. */
2459 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2460 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2461 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2464 c
->initializer
->ts
.type
= c
->ts
.type
;
2465 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2466 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2467 c
->initializer
->expr_type
= EXPR_NULL
;
2472 if (TYPE_FIELDS (derived
->backend_decl
))
2473 return derived
->backend_decl
;
2475 /* Build the type member list. Install the newly created RECORD_TYPE
2476 node as DECL_CONTEXT of each FIELD_DECL. */
2477 for (c
= derived
->components
; c
; c
= c
->next
)
2479 if (c
->attr
.proc_pointer
)
2480 field_type
= gfc_get_ppc_type (c
);
2481 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2482 field_type
= c
->ts
.u
.derived
->backend_decl
;
2485 if (c
->ts
.type
== BT_CHARACTER
)
2487 /* Evaluate the string length. */
2488 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2489 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2492 field_type
= gfc_typenode_for_spec (&c
->ts
);
2495 /* This returns an array descriptor type. Initialization may be
2497 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2499 if (c
->attr
.pointer
|| c
->attr
.allocatable
)
2501 enum gfc_array_kind akind
;
2502 if (c
->attr
.pointer
)
2503 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2504 : GFC_ARRAY_POINTER
;
2506 akind
= GFC_ARRAY_ALLOCATABLE
;
2507 /* Pointers to arrays aren't actually pointer types. The
2508 descriptors are separate, but the data is common. */
2509 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2511 && !c
->attr
.pointer
,
2512 c
->attr
.contiguous
);
2515 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2519 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
)
2520 && !c
->attr
.proc_pointer
2521 && !(unlimited_entity
&& c
== derived
->components
))
2522 field_type
= build_pointer_type (field_type
);
2524 if (c
->attr
.pointer
)
2525 field_type
= gfc_nonrestricted_type (field_type
);
2527 /* vtype fields can point to different types to the base type. */
2528 if (c
->ts
.type
== BT_DERIVED
2529 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2530 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2533 /* Ensure that the CLASS language specific flag is set. */
2534 if (c
->ts
.type
== BT_CLASS
)
2536 if (POINTER_TYPE_P (field_type
))
2537 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2539 GFC_CLASS_TYPE_P (field_type
) = 1;
2542 field
= gfc_add_field_to_struct (typenode
,
2543 get_identifier (c
->name
),
2544 field_type
, &chain
);
2546 gfc_set_decl_location (field
, &c
->loc
);
2547 else if (derived
->declared_at
.lb
)
2548 gfc_set_decl_location (field
, &derived
->declared_at
);
2550 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2553 if (!c
->backend_decl
)
2554 c
->backend_decl
= field
;
2557 /* Now lay out the derived type, including the fields. */
2559 TYPE_CANONICAL (typenode
) = canonical
;
2561 gfc_finish_type (typenode
);
2562 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2563 if (derived
->module
&& derived
->ns
->proc_name
2564 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2566 if (derived
->ns
->proc_name
->backend_decl
2567 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2570 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2571 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2572 = derived
->ns
->proc_name
->backend_decl
;
2576 derived
->backend_decl
= typenode
;
2580 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2581 gfc_copy_dt_decls_ifequal (derived
, dt
->derived
, false);
2583 return derived
->backend_decl
;
2588 gfc_return_by_reference (gfc_symbol
* sym
)
2590 if (!sym
->attr
.function
)
2593 if (sym
->attr
.dimension
)
2596 if (sym
->ts
.type
== BT_CHARACTER
2597 && !sym
->attr
.is_bind_c
2598 && (!sym
->attr
.result
2599 || !sym
->ns
->proc_name
2600 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2603 /* Possibly return complex numbers by reference for g77 compatibility.
2604 We don't do this for calls to intrinsics (as the library uses the
2605 -fno-f2c calling convention), nor for calls to functions which always
2606 require an explicit interface, as no compatibility problems can
2608 if (gfc_option
.flag_f2c
2609 && sym
->ts
.type
== BT_COMPLEX
2610 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2617 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2621 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2622 gfc_entry_list
*el
, *el2
;
2624 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2625 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2627 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2629 /* Build the type node. */
2630 type
= make_node (UNION_TYPE
);
2632 TYPE_NAME (type
) = get_identifier (name
);
2634 for (el
= ns
->entries
; el
; el
= el
->next
)
2636 /* Search for duplicates. */
2637 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2638 if (el2
->sym
->result
== el
->sym
->result
)
2642 gfc_add_field_to_struct_1 (type
,
2643 get_identifier (el
->sym
->result
->name
),
2644 gfc_sym_type (el
->sym
->result
), &chain
);
2647 /* Finish off the type. */
2648 gfc_finish_type (type
);
2649 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2653 /* Create a "fn spec" based on the formal arguments;
2654 cf. create_function_arglist. */
2657 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2661 gfc_formal_arglist
*f
;
2664 memset (&spec
, 0, sizeof (spec
));
2668 if (sym
->attr
.entry_master
)
2669 spec
[spec_len
++] = 'R';
2670 if (gfc_return_by_reference (sym
))
2672 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2674 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2675 spec
[spec_len
++] = '.';
2677 spec
[spec_len
++] = 'w';
2678 if (sym
->ts
.type
== BT_CHARACTER
)
2679 spec
[spec_len
++] = 'R';
2682 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2683 if (spec_len
< sizeof (spec
))
2685 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2686 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2687 || (f
->sym
->ts
.type
== BT_DERIVED
2688 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2689 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2690 || (f
->sym
->ts
.type
== BT_CLASS
2691 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2692 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2693 spec
[spec_len
++] = '.';
2694 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2695 spec
[spec_len
++] = 'r';
2697 spec
[spec_len
++] = 'w';
2700 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2701 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2702 return build_type_attribute_variant (fntype
, tmp
);
2707 gfc_get_function_type (gfc_symbol
* sym
)
2710 vec
<tree
, va_gc
> *typelist
;
2711 gfc_formal_arglist
*f
;
2713 int alternate_return
;
2714 bool is_varargs
= true, recursive_type
= false;
2716 /* Make sure this symbol is a function, a subroutine or the main
2718 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2719 || sym
->attr
.flavor
== FL_PROGRAM
);
2721 /* To avoid recursing infinitely on recursive types, we use error_mark_node
2722 so that they can be detected here and handled further down. */
2723 if (sym
->backend_decl
== NULL
)
2724 sym
->backend_decl
= error_mark_node
;
2725 else if (sym
->backend_decl
== error_mark_node
)
2726 recursive_type
= true;
2727 else if (sym
->attr
.proc_pointer
)
2728 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
2730 return TREE_TYPE (sym
->backend_decl
);
2732 alternate_return
= 0;
2735 if (sym
->attr
.entry_master
)
2736 /* Additional parameter for selecting an entry point. */
2737 vec_safe_push (typelist
, gfc_array_index_type
);
2744 if (arg
->ts
.type
== BT_CHARACTER
)
2745 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2747 /* Some functions we use an extra parameter for the return value. */
2748 if (gfc_return_by_reference (sym
))
2750 type
= gfc_sym_type (arg
);
2751 if (arg
->ts
.type
== BT_COMPLEX
2752 || arg
->attr
.dimension
2753 || arg
->ts
.type
== BT_CHARACTER
)
2754 type
= build_reference_type (type
);
2756 vec_safe_push (typelist
, type
);
2757 if (arg
->ts
.type
== BT_CHARACTER
)
2759 if (!arg
->ts
.deferred
)
2760 /* Transfer by value. */
2761 vec_safe_push (typelist
, gfc_charlen_type_node
);
2763 /* Deferred character lengths are transferred by reference
2764 so that the value can be returned. */
2765 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
2769 /* Build the argument types for the function. */
2770 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2775 /* Evaluate constant character lengths here so that they can be
2776 included in the type. */
2777 if (arg
->ts
.type
== BT_CHARACTER
)
2778 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2780 if (arg
->attr
.flavor
== FL_PROCEDURE
)
2782 /* We don't know in the general case which argument causes
2783 recursion. But we know that it is a procedure. So we give up
2784 creating the procedure argument type list at the first
2785 procedure argument. */
2787 goto arg_type_list_done
;
2789 type
= gfc_get_function_type (arg
);
2790 type
= build_pointer_type (type
);
2793 type
= gfc_sym_type (arg
);
2795 /* Parameter Passing Convention
2797 We currently pass all parameters by reference.
2798 Parameters with INTENT(IN) could be passed by value.
2799 The problem arises if a function is called via an implicit
2800 prototype. In this situation the INTENT is not known.
2801 For this reason all parameters to global functions must be
2802 passed by reference. Passing by value would potentially
2803 generate bad code. Worse there would be no way of telling that
2804 this code was bad, except that it would give incorrect results.
2806 Contained procedures could pass by value as these are never
2807 used without an explicit interface, and cannot be passed as
2808 actual parameters for a dummy procedure. */
2810 vec_safe_push (typelist
, type
);
2814 if (sym
->attr
.subroutine
)
2815 alternate_return
= 1;
2819 /* Add hidden string length parameters. */
2820 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2823 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2825 if (!arg
->ts
.deferred
)
2826 /* Transfer by value. */
2827 type
= gfc_charlen_type_node
;
2829 /* Deferred character lengths are transferred by reference
2830 so that the value can be returned. */
2831 type
= build_pointer_type (gfc_charlen_type_node
);
2833 vec_safe_push (typelist
, type
);
2837 if (!vec_safe_is_empty (typelist
)
2838 || sym
->attr
.is_main_program
2839 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
2844 if (!recursive_type
&& sym
->backend_decl
== error_mark_node
)
2845 sym
->backend_decl
= NULL_TREE
;
2847 if (alternate_return
)
2848 type
= integer_type_node
;
2849 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
2850 type
= void_type_node
;
2851 else if (sym
->attr
.mixed_entry_master
)
2852 type
= gfc_get_mixed_entry_union (sym
->ns
);
2853 else if (gfc_option
.flag_f2c
2854 && sym
->ts
.type
== BT_REAL
2855 && sym
->ts
.kind
== gfc_default_real_kind
2856 && !sym
->attr
.always_explicit
)
2858 /* Special case: f2c calling conventions require that (scalar)
2859 default REAL functions return the C type double instead. f2c
2860 compatibility is only an issue with functions that don't
2861 require an explicit interface, as only these could be
2862 implemented in Fortran 77. */
2863 sym
->ts
.kind
= gfc_default_double_kind
;
2864 type
= gfc_typenode_for_spec (&sym
->ts
);
2865 sym
->ts
.kind
= gfc_default_real_kind
;
2867 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
2868 /* Procedure pointer return values. */
2870 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
2872 /* Unset proc_pointer as gfc_get_function_type
2873 is called recursively. */
2874 sym
->result
->attr
.proc_pointer
= 0;
2875 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
2876 sym
->result
->attr
.proc_pointer
= 1;
2879 type
= gfc_sym_type (sym
->result
);
2882 type
= gfc_sym_type (sym
);
2884 if (is_varargs
|| recursive_type
)
2885 type
= build_varargs_function_type_vec (type
, typelist
);
2887 type
= build_function_type_vec (type
, typelist
);
2888 type
= create_fn_spec (sym
, type
);
2893 /* Language hooks for middle-end access to type nodes. */
2895 /* Return an integer type with BITS bits of precision,
2896 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2899 gfc_type_for_size (unsigned bits
, int unsignedp
)
2904 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
2906 tree type
= gfc_integer_types
[i
];
2907 if (type
&& bits
== TYPE_PRECISION (type
))
2911 /* Handle TImode as a special case because it is used by some backends
2912 (e.g. ARM) even though it is not available for normal use. */
2913 #if HOST_BITS_PER_WIDE_INT >= 64
2914 if (bits
== TYPE_PRECISION (intTI_type_node
))
2915 return intTI_type_node
;
2918 if (bits
<= TYPE_PRECISION (intQI_type_node
))
2919 return intQI_type_node
;
2920 if (bits
<= TYPE_PRECISION (intHI_type_node
))
2921 return intHI_type_node
;
2922 if (bits
<= TYPE_PRECISION (intSI_type_node
))
2923 return intSI_type_node
;
2924 if (bits
<= TYPE_PRECISION (intDI_type_node
))
2925 return intDI_type_node
;
2926 if (bits
<= TYPE_PRECISION (intTI_type_node
))
2927 return intTI_type_node
;
2931 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
2932 return unsigned_intQI_type_node
;
2933 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
2934 return unsigned_intHI_type_node
;
2935 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
2936 return unsigned_intSI_type_node
;
2937 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
2938 return unsigned_intDI_type_node
;
2939 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
2940 return unsigned_intTI_type_node
;
2946 /* Return a data type that has machine mode MODE. If the mode is an
2947 integer, then UNSIGNEDP selects between signed and unsigned types. */
2950 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
2955 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
2956 base
= gfc_real_types
;
2957 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
2958 base
= gfc_complex_types
;
2959 else if (SCALAR_INT_MODE_P (mode
))
2961 tree type
= gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
2962 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
2964 else if (VECTOR_MODE_P (mode
))
2966 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
2967 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
2968 if (inner_type
!= NULL_TREE
)
2969 return build_vector_type_for_mode (inner_type
, mode
);
2975 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
2977 tree type
= base
[i
];
2978 if (type
&& mode
== TYPE_MODE (type
))
2985 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2989 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
2992 bool indirect
= false;
2993 tree etype
, ptype
, field
, t
, base_decl
;
2994 tree data_off
, dim_off
, dim_size
, elem_size
;
2995 tree lower_suboff
, upper_suboff
, stride_suboff
;
2997 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2999 if (! POINTER_TYPE_P (type
))
3001 type
= TREE_TYPE (type
);
3002 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3007 rank
= GFC_TYPE_ARRAY_RANK (type
);
3008 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3011 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3012 gcc_assert (POINTER_TYPE_P (etype
));
3013 etype
= TREE_TYPE (etype
);
3015 /* If the type is not a scalar coarray. */
3016 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3017 etype
= TREE_TYPE (etype
);
3019 /* Can't handle variable sized elements yet. */
3020 if (int_size_in_bytes (etype
) <= 0)
3022 /* Nor non-constant lower bounds in assumed shape arrays. */
3023 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3024 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3026 for (dim
= 0; dim
< rank
; dim
++)
3027 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3028 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3032 memset (info
, '\0', sizeof (*info
));
3033 info
->ndimensions
= rank
;
3034 info
->element_type
= etype
;
3035 ptype
= build_pointer_type (gfc_array_index_type
);
3036 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3039 base_decl
= build_decl (input_location
, VAR_DECL
, NULL_TREE
,
3040 indirect
? build_pointer_type (ptype
) : ptype
);
3041 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3043 info
->base_decl
= base_decl
;
3045 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3047 if (GFC_TYPE_ARRAY_SPAN (type
))
3048 elem_size
= GFC_TYPE_ARRAY_SPAN (type
);
3050 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
3051 field
= TYPE_FIELDS (TYPE_MAIN_VARIANT (type
));
3052 data_off
= byte_position (field
);
3053 field
= DECL_CHAIN (field
);
3054 field
= DECL_CHAIN (field
);
3055 field
= DECL_CHAIN (field
);
3056 dim_off
= byte_position (field
);
3057 dim_size
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field
)));
3058 field
= TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field
)));
3059 stride_suboff
= byte_position (field
);
3060 field
= DECL_CHAIN (field
);
3061 lower_suboff
= byte_position (field
);
3062 field
= DECL_CHAIN (field
);
3063 upper_suboff
= byte_position (field
);
3066 if (!integer_zerop (data_off
))
3067 t
= fold_build_pointer_plus (t
, data_off
);
3068 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3069 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3070 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3071 info
->allocated
= build2 (NE_EXPR
, boolean_type_node
,
3072 info
->data_location
, null_pointer_node
);
3073 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3074 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3075 info
->associated
= build2 (NE_EXPR
, boolean_type_node
,
3076 info
->data_location
, null_pointer_node
);
3078 for (dim
= 0; dim
< rank
; dim
++)
3080 t
= fold_build_pointer_plus (base_decl
,
3081 size_binop (PLUS_EXPR
,
3082 dim_off
, lower_suboff
));
3083 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3084 info
->dimen
[dim
].lower_bound
= t
;
3085 t
= fold_build_pointer_plus (base_decl
,
3086 size_binop (PLUS_EXPR
,
3087 dim_off
, upper_suboff
));
3088 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3089 info
->dimen
[dim
].upper_bound
= t
;
3090 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3091 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3093 /* Assumed shape arrays have known lower bounds. */
3094 info
->dimen
[dim
].upper_bound
3095 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3096 info
->dimen
[dim
].upper_bound
,
3097 info
->dimen
[dim
].lower_bound
);
3098 info
->dimen
[dim
].lower_bound
3099 = fold_convert (gfc_array_index_type
,
3100 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3101 info
->dimen
[dim
].upper_bound
3102 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3103 info
->dimen
[dim
].lower_bound
,
3104 info
->dimen
[dim
].upper_bound
);
3106 t
= fold_build_pointer_plus (base_decl
,
3107 size_binop (PLUS_EXPR
,
3108 dim_off
, stride_suboff
));
3109 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3110 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3111 info
->dimen
[dim
].stride
= t
;
3112 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3118 #include "gt-fortran-trans-types.h"