1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2016 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 "dwarf2out.h" /* For struct array_descr_info. */
41 #if (GFC_MAX_DIMENSIONS < 10)
42 #define GFC_RANK_DIGITS 1
43 #define GFC_RANK_PRINTF_FORMAT "%01d"
44 #elif (GFC_MAX_DIMENSIONS < 100)
45 #define GFC_RANK_DIGITS 2
46 #define GFC_RANK_PRINTF_FORMAT "%02d"
48 #error If you really need >99 dimensions, continue the sequence above...
51 /* array of structs so we don't have to worry about xmalloc or free */
52 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
54 tree gfc_array_index_type
;
55 tree gfc_array_range_type
;
56 tree gfc_character1_type_node
;
58 tree prvoid_type_node
;
59 tree ppvoid_type_node
;
63 tree gfc_charlen_type_node
;
65 tree float128_type_node
= NULL_TREE
;
66 tree complex_float128_type_node
= NULL_TREE
;
68 bool gfc_real16_is_float128
= false;
70 static GTY(()) tree gfc_desc_dim_type
;
71 static GTY(()) tree gfc_max_array_element_size
;
72 static GTY(()) tree gfc_array_descriptor_base
[2 * (GFC_MAX_DIMENSIONS
+1)];
73 static GTY(()) tree gfc_array_descriptor_base_caf
[2 * (GFC_MAX_DIMENSIONS
+1)];
75 /* Arrays for all integral and real kinds. We'll fill this in at runtime
76 after the target has a chance to process command-line options. */
78 #define MAX_INT_KINDS 5
79 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
80 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
81 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
82 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
84 #define MAX_REAL_KINDS 5
85 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
86 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
87 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
89 #define MAX_CHARACTER_KINDS 2
90 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
91 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
92 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
94 static tree
gfc_add_field_to_struct_1 (tree
, tree
, tree
, tree
**);
96 /* The integer kind to use for array indices. This will be set to the
97 proper value based on target information from the backend. */
99 int gfc_index_integer_kind
;
101 /* The default kinds of the various types. */
103 int gfc_default_integer_kind
;
104 int gfc_max_integer_kind
;
105 int gfc_default_real_kind
;
106 int gfc_default_double_kind
;
107 int gfc_default_character_kind
;
108 int gfc_default_logical_kind
;
109 int gfc_default_complex_kind
;
111 int gfc_atomic_int_kind
;
112 int gfc_atomic_logical_kind
;
114 /* The kind size used for record offsets. If the target system supports
115 kind=8, this will be set to 8, otherwise it is set to 4. */
118 /* The integer kind used to store character lengths. */
119 int gfc_charlen_int_kind
;
121 /* The size of the numeric storage unit and character storage unit. */
122 int gfc_numeric_storage_size
;
123 int gfc_character_storage_size
;
127 gfc_check_any_c_kind (gfc_typespec
*ts
)
131 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
133 /* Check for any C interoperable kind for the given type/kind in ts.
134 This can be used after verify_c_interop to make sure that the
135 Fortran kind being used exists in at least some form for C. */
136 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
137 c_interop_kinds_table
[i
].value
== ts
->kind
)
146 get_real_kind_from_node (tree type
)
150 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
151 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
152 return gfc_real_kinds
[i
].kind
;
158 get_int_kind_from_node (tree type
)
165 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
166 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
167 return gfc_integer_kinds
[i
].kind
;
172 /* Return a typenode for the "standard" C type with a given name. */
174 get_typenode_from_name (const char *name
)
176 if (name
== NULL
|| *name
== '\0')
179 if (strcmp (name
, "char") == 0)
180 return char_type_node
;
181 if (strcmp (name
, "unsigned char") == 0)
182 return unsigned_char_type_node
;
183 if (strcmp (name
, "signed char") == 0)
184 return signed_char_type_node
;
186 if (strcmp (name
, "short int") == 0)
187 return short_integer_type_node
;
188 if (strcmp (name
, "short unsigned int") == 0)
189 return short_unsigned_type_node
;
191 if (strcmp (name
, "int") == 0)
192 return integer_type_node
;
193 if (strcmp (name
, "unsigned int") == 0)
194 return unsigned_type_node
;
196 if (strcmp (name
, "long int") == 0)
197 return long_integer_type_node
;
198 if (strcmp (name
, "long unsigned int") == 0)
199 return long_unsigned_type_node
;
201 if (strcmp (name
, "long long int") == 0)
202 return long_long_integer_type_node
;
203 if (strcmp (name
, "long long unsigned int") == 0)
204 return long_long_unsigned_type_node
;
210 get_int_kind_from_name (const char *name
)
212 return get_int_kind_from_node (get_typenode_from_name (name
));
216 /* Get the kind number corresponding to an integer of given size,
217 following the required return values for ISO_FORTRAN_ENV INT* constants:
218 -2 is returned if we support a kind of larger size, -1 otherwise. */
220 gfc_get_int_kind_from_width_isofortranenv (int size
)
224 /* Look for a kind with matching storage size. */
225 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
226 if (gfc_integer_kinds
[i
].bit_size
== size
)
227 return gfc_integer_kinds
[i
].kind
;
229 /* Look for a kind with larger storage size. */
230 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
231 if (gfc_integer_kinds
[i
].bit_size
> size
)
237 /* Get the kind number corresponding to a real of given storage size,
238 following the required return values for ISO_FORTRAN_ENV REAL* constants:
239 -2 is returned if we support a kind of larger size, -1 otherwise. */
241 gfc_get_real_kind_from_width_isofortranenv (int size
)
247 /* Look for a kind with matching storage size. */
248 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
249 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
250 return gfc_real_kinds
[i
].kind
;
252 /* Look for a kind with larger storage size. */
253 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
254 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
263 get_int_kind_from_width (int size
)
267 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
268 if (gfc_integer_kinds
[i
].bit_size
== size
)
269 return gfc_integer_kinds
[i
].kind
;
275 get_int_kind_from_minimal_width (int size
)
279 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
280 if (gfc_integer_kinds
[i
].bit_size
>= size
)
281 return gfc_integer_kinds
[i
].kind
;
287 /* Generate the CInteropKind_t objects for the C interoperable
291 gfc_init_c_interop_kinds (void)
295 /* init all pointers in the list to NULL */
296 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
298 /* Initialize the name and value fields. */
299 c_interop_kinds_table
[i
].name
[0] = '\0';
300 c_interop_kinds_table
[i
].value
= -100;
301 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
304 #define NAMED_INTCST(a,b,c,d) \
305 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
306 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
307 c_interop_kinds_table[a].value = c;
308 #define NAMED_REALCST(a,b,c,d) \
309 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
310 c_interop_kinds_table[a].f90_type = BT_REAL; \
311 c_interop_kinds_table[a].value = c;
312 #define NAMED_CMPXCST(a,b,c,d) \
313 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
314 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
315 c_interop_kinds_table[a].value = c;
316 #define NAMED_LOGCST(a,b,c) \
317 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
318 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
319 c_interop_kinds_table[a].value = c;
320 #define NAMED_CHARKNDCST(a,b,c) \
321 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
322 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
323 c_interop_kinds_table[a].value = c;
324 #define NAMED_CHARCST(a,b,c) \
325 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
326 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
327 c_interop_kinds_table[a].value = c;
328 #define DERIVED_TYPE(a,b,c) \
329 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
330 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
331 c_interop_kinds_table[a].value = c;
332 #define NAMED_FUNCTION(a,b,c,d) \
333 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
334 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
335 c_interop_kinds_table[a].value = c;
336 #define NAMED_SUBROUTINE(a,b,c,d) \
337 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
338 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
339 c_interop_kinds_table[a].value = c;
340 #include "iso-c-binding.def"
344 /* Query the target to determine which machine modes are available for
345 computation. Choose KIND numbers for them. */
348 gfc_init_kinds (void)
351 int i_index
, r_index
, kind
;
352 bool saw_i4
= false, saw_i8
= false;
353 bool saw_r4
= false, saw_r8
= false, saw_r10
= false, saw_r16
= false;
355 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
359 if (!targetm
.scalar_mode_supported_p ((machine_mode
) mode
))
362 /* The middle end doesn't support constants larger than 2*HWI.
363 Perhaps the target hook shouldn't have accepted these either,
364 but just to be safe... */
365 bitsize
= GET_MODE_BITSIZE ((machine_mode
) mode
);
366 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
369 gcc_assert (i_index
!= MAX_INT_KINDS
);
371 /* Let the kind equal the bit size divided by 8. This insulates the
372 programmer from the underlying byte size. */
380 gfc_integer_kinds
[i_index
].kind
= kind
;
381 gfc_integer_kinds
[i_index
].radix
= 2;
382 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
383 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
385 gfc_logical_kinds
[i_index
].kind
= kind
;
386 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
391 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
392 used for large file access. */
399 /* If we do not at least have kind = 4, everything is pointless. */
402 /* Set the maximum integer kind. Used with at least BOZ constants. */
403 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
405 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
407 const struct real_format
*fmt
=
408 REAL_MODE_FORMAT ((machine_mode
) mode
);
413 if (!targetm
.scalar_mode_supported_p ((machine_mode
) mode
))
416 /* Only let float, double, long double and __float128 go through.
417 Runtime support for others is not provided, so they would be
419 if (!targetm
.libgcc_floating_mode_supported_p ((machine_mode
)
422 if (mode
!= TYPE_MODE (float_type_node
)
423 && (mode
!= TYPE_MODE (double_type_node
))
424 && (mode
!= TYPE_MODE (long_double_type_node
))
425 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
431 /* Let the kind equal the precision divided by 8, rounding up. Again,
432 this insulates the programmer from the underlying byte size.
434 Also, it effectively deals with IEEE extended formats. There, the
435 total size of the type may equal 16, but it's got 6 bytes of padding
436 and the increased size can get in the way of a real IEEE quad format
437 which may also be supported by the target.
439 We round up so as to handle IA-64 __floatreg (RFmode), which is an
440 82 bit type. Not to be confused with __float80 (XFmode), which is
441 an 80 bit type also supported by IA-64. So XFmode should come out
442 to be kind=10, and RFmode should come out to be kind=11. Egads. */
444 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
455 /* Careful we don't stumble a weird internal mode. */
456 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
457 /* Or have too many modes for the allocated space. */
458 gcc_assert (r_index
!= MAX_REAL_KINDS
);
460 gfc_real_kinds
[r_index
].kind
= kind
;
461 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
462 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
463 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
464 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
465 if (fmt
->pnan
< fmt
->p
)
466 /* This is an IBM extended double format (or the MIPS variant)
467 made up of two IEEE doubles. The value of the long double is
468 the sum of the values of the two parts. The most significant
469 part is required to be the value of the long double rounded
470 to the nearest double. If we use emax of 1024 then we can't
471 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
472 rounding will make the most significant part overflow. */
473 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
474 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
478 /* Choose the default integer kind. We choose 4 unless the user directs us
479 otherwise. Even if the user specified that the default integer kind is 8,
480 the numeric storage size is not 64 bits. In this case, a warning will be
481 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
483 gfc_numeric_storage_size
= 4 * 8;
485 if (flag_default_integer
)
488 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
489 "%<-fdefault-integer-8%> option");
491 gfc_default_integer_kind
= 8;
494 else if (flag_integer4_kind
== 8)
497 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
498 "%<-finteger-4-integer-8%> option");
500 gfc_default_integer_kind
= 8;
504 gfc_default_integer_kind
= 4;
508 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
509 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
512 /* Choose the default real kind. Again, we choose 4 when possible. */
513 if (flag_default_real
)
516 gfc_fatal_error ("REAL(KIND=8) is not available for "
517 "%<-fdefault-real-8%> option");
519 gfc_default_real_kind
= 8;
521 else if (flag_real4_kind
== 8)
524 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
527 gfc_default_real_kind
= 8;
529 else if (flag_real4_kind
== 10)
532 gfc_fatal_error ("REAL(KIND=10) is not available for "
533 "%<-freal-4-real-10%> option");
535 gfc_default_real_kind
= 10;
537 else if (flag_real4_kind
== 16)
540 gfc_fatal_error ("REAL(KIND=16) is not available for "
541 "%<-freal-4-real-16%> option");
543 gfc_default_real_kind
= 16;
546 gfc_default_real_kind
= 4;
548 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
550 /* Choose the default double kind. If -fdefault-real and -fdefault-double
551 are specified, we use kind=8, if it's available. If -fdefault-real is
552 specified without -fdefault-double, we use kind=16, if it's available.
553 Otherwise we do not change anything. */
554 if (flag_default_double
&& !flag_default_real
)
555 gfc_fatal_error ("Use of %<-fdefault-double-8%> requires "
556 "%<-fdefault-real-8%>");
558 if (flag_default_real
&& flag_default_double
&& saw_r8
)
559 gfc_default_double_kind
= 8;
560 else if (flag_default_real
&& saw_r16
)
561 gfc_default_double_kind
= 16;
562 else if (flag_real8_kind
== 4)
565 gfc_fatal_error ("REAL(KIND=4) is not available for "
566 "%<-freal-8-real-4%> option");
568 gfc_default_double_kind
= 4;
570 else if (flag_real8_kind
== 10 )
573 gfc_fatal_error ("REAL(KIND=10) is not available for "
574 "%<-freal-8-real-10%> option");
576 gfc_default_double_kind
= 10;
578 else if (flag_real8_kind
== 16 )
581 gfc_fatal_error ("REAL(KIND=10) is not available for "
582 "%<-freal-8-real-16%> option");
584 gfc_default_double_kind
= 16;
586 else if (saw_r4
&& saw_r8
)
587 gfc_default_double_kind
= 8;
590 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
591 real ... occupies two contiguous numeric storage units.
593 Therefore we must be supplied a kind twice as large as we chose
594 for single precision. There are loopholes, in that double
595 precision must *occupy* two storage units, though it doesn't have
596 to *use* two storage units. Which means that you can make this
597 kind artificially wide by padding it. But at present there are
598 no GCC targets for which a two-word type does not exist, so we
599 just let gfc_validate_kind abort and tell us if something breaks. */
601 gfc_default_double_kind
602 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
605 /* The default logical kind is constrained to be the same as the
606 default integer kind. Similarly with complex and real. */
607 gfc_default_logical_kind
= gfc_default_integer_kind
;
608 gfc_default_complex_kind
= gfc_default_real_kind
;
610 /* We only have two character kinds: ASCII and UCS-4.
611 ASCII corresponds to a 8-bit integer type, if one is available.
612 UCS-4 corresponds to a 32-bit integer type, if one is available. */
614 if ((kind
= get_int_kind_from_width (8)) > 0)
616 gfc_character_kinds
[i_index
].kind
= kind
;
617 gfc_character_kinds
[i_index
].bit_size
= 8;
618 gfc_character_kinds
[i_index
].name
= "ascii";
621 if ((kind
= get_int_kind_from_width (32)) > 0)
623 gfc_character_kinds
[i_index
].kind
= kind
;
624 gfc_character_kinds
[i_index
].bit_size
= 32;
625 gfc_character_kinds
[i_index
].name
= "iso_10646";
629 /* Choose the smallest integer kind for our default character. */
630 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
631 gfc_character_storage_size
= gfc_default_character_kind
* 8;
633 gfc_index_integer_kind
= get_int_kind_from_name (PTRDIFF_TYPE
);
635 /* Pick a kind the same size as the C "int" type. */
636 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
638 /* Choose atomic kinds to match C's int. */
639 gfc_atomic_int_kind
= gfc_c_int_kind
;
640 gfc_atomic_logical_kind
= gfc_c_int_kind
;
644 /* Make sure that a valid kind is present. Returns an index into the
645 associated kinds array, -1 if the kind is not present. */
648 validate_integer (int kind
)
652 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
653 if (gfc_integer_kinds
[i
].kind
== kind
)
660 validate_real (int kind
)
664 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
665 if (gfc_real_kinds
[i
].kind
== kind
)
672 validate_logical (int kind
)
676 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
677 if (gfc_logical_kinds
[i
].kind
== kind
)
684 validate_character (int kind
)
688 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
689 if (gfc_character_kinds
[i
].kind
== kind
)
695 /* Validate a kind given a basic type. The return value is the same
696 for the child functions, with -1 indicating nonexistence of the
697 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
700 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
706 case BT_REAL
: /* Fall through */
708 rc
= validate_real (kind
);
711 rc
= validate_integer (kind
);
714 rc
= validate_logical (kind
);
717 rc
= validate_character (kind
);
721 gfc_internal_error ("gfc_validate_kind(): Got bad type");
724 if (rc
< 0 && !may_fail
)
725 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
731 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
732 Reuse common type nodes where possible. Recognize if the kind matches up
733 with a C type. This will be used later in determining which routines may
734 be scarfed from libm. */
737 gfc_build_int_type (gfc_integer_info
*info
)
739 int mode_precision
= info
->bit_size
;
741 if (mode_precision
== CHAR_TYPE_SIZE
)
743 if (mode_precision
== SHORT_TYPE_SIZE
)
745 if (mode_precision
== INT_TYPE_SIZE
)
747 if (mode_precision
== LONG_TYPE_SIZE
)
749 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
750 info
->c_long_long
= 1;
752 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
753 return intQI_type_node
;
754 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
755 return intHI_type_node
;
756 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
757 return intSI_type_node
;
758 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
759 return intDI_type_node
;
760 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
761 return intTI_type_node
;
763 return make_signed_type (mode_precision
);
767 gfc_build_uint_type (int size
)
769 if (size
== CHAR_TYPE_SIZE
)
770 return unsigned_char_type_node
;
771 if (size
== SHORT_TYPE_SIZE
)
772 return short_unsigned_type_node
;
773 if (size
== INT_TYPE_SIZE
)
774 return unsigned_type_node
;
775 if (size
== LONG_TYPE_SIZE
)
776 return long_unsigned_type_node
;
777 if (size
== LONG_LONG_TYPE_SIZE
)
778 return long_long_unsigned_type_node
;
780 return make_unsigned_type (size
);
785 gfc_build_real_type (gfc_real_info
*info
)
787 int mode_precision
= info
->mode_precision
;
790 if (mode_precision
== FLOAT_TYPE_SIZE
)
792 if (mode_precision
== DOUBLE_TYPE_SIZE
)
794 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
795 info
->c_long_double
= 1;
796 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
798 info
->c_float128
= 1;
799 gfc_real16_is_float128
= true;
802 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
803 return float_type_node
;
804 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
805 return double_type_node
;
806 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
807 return long_double_type_node
;
809 new_type
= make_node (REAL_TYPE
);
810 TYPE_PRECISION (new_type
) = mode_precision
;
811 layout_type (new_type
);
816 gfc_build_complex_type (tree scalar_type
)
820 if (scalar_type
== NULL
)
822 if (scalar_type
== float_type_node
)
823 return complex_float_type_node
;
824 if (scalar_type
== double_type_node
)
825 return complex_double_type_node
;
826 if (scalar_type
== long_double_type_node
)
827 return complex_long_double_type_node
;
829 new_type
= make_node (COMPLEX_TYPE
);
830 TREE_TYPE (new_type
) = scalar_type
;
831 layout_type (new_type
);
836 gfc_build_logical_type (gfc_logical_info
*info
)
838 int bit_size
= info
->bit_size
;
841 if (bit_size
== BOOL_TYPE_SIZE
)
844 return boolean_type_node
;
847 new_type
= make_unsigned_type (bit_size
);
848 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
849 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
850 TYPE_PRECISION (new_type
) = 1;
856 /* Create the backend type nodes. We map them to their
857 equivalent C type, at least for now. We also give
858 names to the types here, and we push them in the
859 global binding level context.*/
862 gfc_init_types (void)
869 /* Create and name the types. */
870 #define PUSH_TYPE(name, node) \
871 pushdecl (build_decl (input_location, \
872 TYPE_DECL, get_identifier (name), node))
874 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
876 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
877 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
878 if (TYPE_STRING_FLAG (type
))
879 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
880 gfc_integer_types
[index
] = type
;
881 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
882 gfc_integer_kinds
[index
].kind
);
883 PUSH_TYPE (name_buf
, type
);
886 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
888 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
889 gfc_logical_types
[index
] = type
;
890 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
891 gfc_logical_kinds
[index
].kind
);
892 PUSH_TYPE (name_buf
, type
);
895 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
897 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
898 gfc_real_types
[index
] = type
;
899 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
900 gfc_real_kinds
[index
].kind
);
901 PUSH_TYPE (name_buf
, type
);
903 if (gfc_real_kinds
[index
].c_float128
)
904 float128_type_node
= type
;
906 type
= gfc_build_complex_type (type
);
907 gfc_complex_types
[index
] = type
;
908 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
909 gfc_real_kinds
[index
].kind
);
910 PUSH_TYPE (name_buf
, type
);
912 if (gfc_real_kinds
[index
].c_float128
)
913 complex_float128_type_node
= type
;
916 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
918 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
919 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
920 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
921 gfc_character_kinds
[index
].kind
);
922 PUSH_TYPE (name_buf
, type
);
923 gfc_character_types
[index
] = type
;
924 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
926 gfc_character1_type_node
= gfc_character_types
[0];
928 PUSH_TYPE ("byte", unsigned_char_type_node
);
929 PUSH_TYPE ("void", void_type_node
);
931 /* DBX debugging output gets upset if these aren't set. */
932 if (!TYPE_NAME (integer_type_node
))
933 PUSH_TYPE ("c_integer", integer_type_node
);
934 if (!TYPE_NAME (char_type_node
))
935 PUSH_TYPE ("c_char", char_type_node
);
939 pvoid_type_node
= build_pointer_type (void_type_node
);
940 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
941 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
942 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
944 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
946 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
947 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
948 since this function is called before gfc_init_constants. */
950 = build_range_type (gfc_array_index_type
,
951 build_int_cst (gfc_array_index_type
, 0),
954 /* The maximum array element size that can be handled is determined
955 by the number of bits available to store this field in the array
958 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
959 gfc_max_array_element_size
960 = wide_int_to_tree (size_type_node
,
961 wi::mask (n
, UNSIGNED
,
962 TYPE_PRECISION (size_type_node
)));
964 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
965 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
966 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
968 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
969 gfc_charlen_int_kind
= 4;
970 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
973 /* Get the type node for the given type and kind. */
976 gfc_get_int_type (int kind
)
978 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
979 return index
< 0 ? 0 : gfc_integer_types
[index
];
983 gfc_get_real_type (int kind
)
985 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
986 return index
< 0 ? 0 : gfc_real_types
[index
];
990 gfc_get_complex_type (int kind
)
992 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
993 return index
< 0 ? 0 : gfc_complex_types
[index
];
997 gfc_get_logical_type (int kind
)
999 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
1000 return index
< 0 ? 0 : gfc_logical_types
[index
];
1004 gfc_get_char_type (int kind
)
1006 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1007 return index
< 0 ? 0 : gfc_character_types
[index
];
1011 gfc_get_pchar_type (int kind
)
1013 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1014 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
1018 /* Create a character type with the given kind and length. */
1021 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
1025 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
1026 type
= build_array_type (eltype
, bounds
);
1027 TYPE_STRING_FLAG (type
) = 1;
1033 gfc_get_character_type_len (int kind
, tree len
)
1035 gfc_validate_kind (BT_CHARACTER
, kind
, false);
1036 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
1040 /* Get a type node for a character kind. */
1043 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
1047 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1048 if (len
&& POINTER_TYPE_P (TREE_TYPE (len
)))
1049 len
= build_fold_indirect_ref (len
);
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
);
1095 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1099 /* Since this cannot be used, return a length one character. */
1100 basetype
= gfc_get_character_type_len (gfc_default_character_kind
,
1101 gfc_index_one_node
);
1106 basetype
= gfc_get_derived_type (spec
->u
.derived
);
1108 if (spec
->type
== BT_CLASS
)
1109 GFC_CLASS_TYPE_P (basetype
) = 1;
1111 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1112 type and kind to fit a (void *) and the basetype returned was a
1113 ptr_type_node. We need to pass up this new information to the
1114 symbol that was declared of type C_PTR or C_FUNPTR. */
1115 if (spec
->u
.derived
->ts
.f90_type
== BT_VOID
)
1117 spec
->type
= BT_INTEGER
;
1118 spec
->kind
= gfc_index_integer_kind
;
1119 spec
->f90_type
= BT_VOID
;
1124 /* This is for the second arg to c_f_pointer and c_f_procpointer
1125 of the iso_c_binding module, to accept any ptr type. */
1126 basetype
= ptr_type_node
;
1127 if (spec
->f90_type
== BT_VOID
)
1130 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1131 basetype
= ptr_type_node
;
1133 basetype
= pfunc_type_node
;
1142 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1145 gfc_conv_array_bound (gfc_expr
* expr
)
1147 /* If expr is an integer constant, return that. */
1148 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1149 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1151 /* Otherwise return NULL. */
1155 /* Return the type of an element of the array. Note that scalar coarrays
1156 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1157 (with POINTER_TYPE stripped) is returned. */
1160 gfc_get_element_type (tree type
)
1164 if (GFC_ARRAY_TYPE_P (type
))
1166 if (TREE_CODE (type
) == POINTER_TYPE
)
1167 type
= TREE_TYPE (type
);
1168 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1170 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1175 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1176 element
= TREE_TYPE (type
);
1181 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1182 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1184 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1185 element
= TREE_TYPE (element
);
1187 /* For arrays, which are not scalar coarrays. */
1188 if (TREE_CODE (element
) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (element
))
1189 element
= TREE_TYPE (element
);
1195 /* Build an array. This function is called from gfc_sym_type().
1196 Actually returns array descriptor type.
1198 Format of array descriptors is as follows:
1200 struct gfc_array_descriptor
1205 struct descriptor_dimension dimension[N_DIM];
1208 struct descriptor_dimension
1215 Translation code should use gfc_conv_descriptor_* rather than
1216 accessing the descriptor directly. Any changes to the array
1217 descriptor type will require changes in gfc_conv_descriptor_* and
1218 gfc_build_array_initializer.
1220 This is represented internally as a RECORD_TYPE. The index nodes
1221 are gfc_array_index_type and the data node is a pointer to the
1222 data. See below for the handling of character types.
1224 The dtype member is formatted as follows:
1225 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1226 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1227 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1229 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1230 this generated poor code for assumed/deferred size arrays. These
1231 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1232 of the GENERIC grammar. Also, there is no way to explicitly set
1233 the array stride, so all data must be packed(1). I've tried to
1234 mark all the functions which would require modification with a GCC
1237 The data component points to the first element in the array. The
1238 offset field is the position of the origin of the array (i.e. element
1239 (0, 0 ...)). This may be outside the bounds of the array.
1241 An element is accessed by
1242 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1243 This gives good performance as the computation does not involve the
1244 bounds of the array. For packed arrays, this is optimized further
1245 by substituting the known strides.
1247 This system has one problem: all array bounds must be within 2^31
1248 elements of the origin (2^63 on 64-bit machines). For example
1249 integer, dimension (80000:90000, 80000:90000, 2) :: array
1250 may not work properly on 32-bit machines because 80000*80000 >
1251 2^31, so the calculation for stride2 would overflow. This may
1252 still work, but I haven't checked, and it relies on the overflow
1253 doing the right thing.
1255 The way to fix this problem is to access elements as follows:
1256 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1257 Obviously this is much slower. I will make this a compile time
1258 option, something like -fsmall-array-offsets. Mixing code compiled
1259 with and without this switch will work.
1261 (1) This can be worked around by modifying the upper bound of the
1262 previous dimension. This requires extra fields in the descriptor
1263 (both real_ubound and fake_ubound). */
1266 /* Returns true if the array sym does not require a descriptor. */
1269 gfc_is_nodesc_array (gfc_symbol
* sym
)
1271 symbol_attribute
*array_attr
;
1273 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1275 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1276 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1278 gcc_assert (array_attr
->dimension
|| array_attr
->codimension
);
1280 /* We only want local arrays. */
1281 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1282 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1283 || array_attr
->allocatable
)
1286 /* We want a descriptor for associate-name arrays that do not have an
1287 explicitly known shape already. */
1288 if (sym
->assoc
&& as
->type
!= AS_EXPLICIT
)
1291 /* The dummy is stored in sym and not in the component. */
1292 if (sym
->attr
.dummy
)
1293 return as
->type
!= AS_ASSUMED_SHAPE
1294 && as
->type
!= AS_ASSUMED_RANK
;
1296 if (sym
->attr
.result
|| sym
->attr
.function
)
1299 gcc_assert (as
->type
== AS_EXPLICIT
|| as
->cp_was_assumed
);
1305 /* Create an array descriptor type. */
1308 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1309 enum gfc_array_kind akind
, bool restricted
,
1312 tree lbound
[GFC_MAX_DIMENSIONS
];
1313 tree ubound
[GFC_MAX_DIMENSIONS
];
1316 /* Assumed-shape arrays do not have codimension information stored in the
1318 corank
= as
->corank
;
1319 if (as
->type
== AS_ASSUMED_SHAPE
||
1320 (as
->type
== AS_ASSUMED_RANK
&& akind
== GFC_ARRAY_ALLOCATABLE
))
1323 if (as
->type
== AS_ASSUMED_RANK
)
1324 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1326 lbound
[n
] = NULL_TREE
;
1327 ubound
[n
] = NULL_TREE
;
1330 for (n
= 0; n
< as
->rank
; n
++)
1332 /* Create expressions for the known bounds of the array. */
1333 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1334 lbound
[n
] = gfc_index_one_node
;
1336 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1337 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1340 for (n
= as
->rank
; n
< as
->rank
+ corank
; n
++)
1342 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1343 lbound
[n
] = gfc_index_one_node
;
1345 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1347 if (n
< as
->rank
+ corank
- 1)
1348 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1351 if (as
->type
== AS_ASSUMED_SHAPE
)
1352 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1353 : GFC_ARRAY_ASSUMED_SHAPE
;
1354 else if (as
->type
== AS_ASSUMED_RANK
)
1355 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1356 : GFC_ARRAY_ASSUMED_RANK
;
1357 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1358 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1360 ubound
, 0, akind
, restricted
);
1363 /* Returns the struct descriptor_dimension type. */
1366 gfc_get_desc_dim_type (void)
1369 tree decl
, *chain
= NULL
;
1371 if (gfc_desc_dim_type
)
1372 return gfc_desc_dim_type
;
1374 /* Build the type node. */
1375 type
= make_node (RECORD_TYPE
);
1377 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1378 TYPE_PACKED (type
) = 1;
1380 /* Consists of the stride, lbound and ubound members. */
1381 decl
= gfc_add_field_to_struct_1 (type
,
1382 get_identifier ("stride"),
1383 gfc_array_index_type
, &chain
);
1384 TREE_NO_WARNING (decl
) = 1;
1386 decl
= gfc_add_field_to_struct_1 (type
,
1387 get_identifier ("lbound"),
1388 gfc_array_index_type
, &chain
);
1389 TREE_NO_WARNING (decl
) = 1;
1391 decl
= gfc_add_field_to_struct_1 (type
,
1392 get_identifier ("ubound"),
1393 gfc_array_index_type
, &chain
);
1394 TREE_NO_WARNING (decl
) = 1;
1396 /* Finish off the type. */
1397 gfc_finish_type (type
);
1398 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1400 gfc_desc_dim_type
= type
;
1405 /* Return the DTYPE for an array. This describes the type and type parameters
1407 /* TODO: Only call this when the value is actually used, and make all the
1408 unknown cases abort. */
1411 gfc_get_dtype_rank_type (int rank
, tree etype
)
1419 switch (TREE_CODE (etype
))
1437 /* We will never have arrays of arrays. */
1451 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1452 /* We can strange array types for temporary arrays. */
1453 return gfc_index_zero_node
;
1456 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1457 size
= TYPE_SIZE_UNIT (etype
);
1459 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1460 if (size
&& INTEGER_CST_P (size
))
1462 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1463 gfc_fatal_error ("Array element size too big at %C");
1465 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1467 dtype
= build_int_cst (gfc_array_index_type
, i
);
1469 if (size
&& !INTEGER_CST_P (size
))
1471 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1472 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
,
1473 gfc_array_index_type
,
1474 fold_convert (gfc_array_index_type
, size
), tmp
);
1475 dtype
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1478 /* If we don't know the size we leave it as zero. This should never happen
1479 for anything that is actually used. */
1480 /* TODO: Check this is actually true, particularly when repacking
1481 assumed size parameters. */
1488 gfc_get_dtype (tree type
)
1494 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1496 if (GFC_TYPE_ARRAY_DTYPE (type
))
1497 return GFC_TYPE_ARRAY_DTYPE (type
);
1499 rank
= GFC_TYPE_ARRAY_RANK (type
);
1500 etype
= gfc_get_element_type (type
);
1501 dtype
= gfc_get_dtype_rank_type (rank
, etype
);
1503 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1508 /* Build an array type for use without a descriptor, packed according
1509 to the value of PACKED. */
1512 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1526 mpz_init_set_ui (offset
, 0);
1527 mpz_init_set_ui (stride
, 1);
1530 /* We don't use build_array_type because this does not include include
1531 lang-specific information (i.e. the bounds of the array) when checking
1534 type
= make_node (ARRAY_TYPE
);
1536 type
= build_variant_type_copy (etype
);
1538 GFC_ARRAY_TYPE_P (type
) = 1;
1539 TYPE_LANG_SPECIFIC (type
) = ggc_cleared_alloc
<struct lang_type
> ();
1541 known_stride
= (packed
!= PACKED_NO
);
1543 for (n
= 0; n
< as
->rank
; n
++)
1545 /* Fill in the stride and bound components of the type. */
1547 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1550 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1552 expr
= as
->lower
[n
];
1553 if (expr
->expr_type
== EXPR_CONSTANT
)
1555 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1556 gfc_index_integer_kind
);
1563 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1567 /* Calculate the offset. */
1568 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1569 mpz_sub (offset
, offset
, delta
);
1574 expr
= as
->upper
[n
];
1575 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1577 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1578 gfc_index_integer_kind
);
1585 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1589 /* Calculate the stride. */
1590 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1591 as
->lower
[n
]->value
.integer
);
1592 mpz_add_ui (delta
, delta
, 1);
1593 mpz_mul (stride
, stride
, delta
);
1596 /* Only the first stride is known for partial packed arrays. */
1597 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1600 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1602 expr
= as
->lower
[n
];
1603 if (expr
->expr_type
== EXPR_CONSTANT
)
1604 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1605 gfc_index_integer_kind
);
1608 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1610 expr
= as
->upper
[n
];
1611 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1612 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1613 gfc_index_integer_kind
);
1616 if (n
< as
->rank
+ as
->corank
- 1)
1617 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1622 GFC_TYPE_ARRAY_OFFSET (type
) =
1623 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1626 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1630 GFC_TYPE_ARRAY_SIZE (type
) =
1631 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1634 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1636 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1637 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1638 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1639 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1641 /* TODO: use main type if it is unbounded. */
1642 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1643 build_pointer_type (build_array_type (etype
, range
));
1645 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1646 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1647 TYPE_QUAL_RESTRICT
);
1651 if (packed
!= PACKED_STATIC
|| flag_coarray
== GFC_FCOARRAY_LIB
)
1653 type
= build_pointer_type (type
);
1656 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1658 GFC_ARRAY_TYPE_P (type
) = 1;
1659 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1667 mpz_sub_ui (stride
, stride
, 1);
1668 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1673 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1674 TYPE_DOMAIN (type
) = range
;
1676 build_pointer_type (etype
);
1677 TREE_TYPE (type
) = etype
;
1685 /* Represent packed arrays as multi-dimensional if they have rank >
1686 1 and with proper bounds, instead of flat arrays. This makes for
1687 better debug info. */
1690 tree gtype
= etype
, rtype
, type_decl
;
1692 for (n
= as
->rank
- 1; n
>= 0; n
--)
1694 rtype
= build_range_type (gfc_array_index_type
,
1695 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1696 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1697 gtype
= build_array_type (gtype
, rtype
);
1699 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1700 TYPE_DECL
, NULL
, gtype
);
1701 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1704 if (packed
!= PACKED_STATIC
|| !known_stride
1705 || (as
->corank
&& flag_coarray
== GFC_FCOARRAY_LIB
))
1707 /* For dummy arrays and automatic (heap allocated) arrays we
1708 want a pointer to the array. */
1709 type
= build_pointer_type (type
);
1711 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1712 GFC_ARRAY_TYPE_P (type
) = 1;
1713 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1719 /* Return or create the base type for an array descriptor. */
1722 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
,
1723 enum gfc_array_kind akind
)
1725 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1726 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1729 /* Assumed-rank array. */
1731 dimen
= GFC_MAX_DIMENSIONS
;
1733 idx
= 2 * (codimen
+ dimen
) + restricted
;
1735 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1737 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1739 if (gfc_array_descriptor_base_caf
[idx
])
1740 return gfc_array_descriptor_base_caf
[idx
];
1742 else if (gfc_array_descriptor_base
[idx
])
1743 return gfc_array_descriptor_base
[idx
];
1745 /* Build the type node. */
1746 fat_type
= make_node (RECORD_TYPE
);
1748 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1749 TYPE_NAME (fat_type
) = get_identifier (name
);
1750 TYPE_NAMELESS (fat_type
) = 1;
1752 /* Add the data member as the first element of the descriptor. */
1753 decl
= gfc_add_field_to_struct_1 (fat_type
,
1754 get_identifier ("data"),
1757 : ptr_type_node
), &chain
);
1759 /* Add the base component. */
1760 decl
= gfc_add_field_to_struct_1 (fat_type
,
1761 get_identifier ("offset"),
1762 gfc_array_index_type
, &chain
);
1763 TREE_NO_WARNING (decl
) = 1;
1765 /* Add the dtype component. */
1766 decl
= gfc_add_field_to_struct_1 (fat_type
,
1767 get_identifier ("dtype"),
1768 gfc_array_index_type
, &chain
);
1769 TREE_NO_WARNING (decl
) = 1;
1771 /* Build the array type for the stride and bound components. */
1772 if (dimen
+ codimen
> 0)
1775 build_array_type (gfc_get_desc_dim_type (),
1776 build_range_type (gfc_array_index_type
,
1777 gfc_index_zero_node
,
1778 gfc_rank_cst
[codimen
+ dimen
- 1]));
1780 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1782 TREE_NO_WARNING (decl
) = 1;
1785 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
1786 && akind
== GFC_ARRAY_ALLOCATABLE
)
1788 decl
= gfc_add_field_to_struct_1 (fat_type
,
1789 get_identifier ("token"),
1790 prvoid_type_node
, &chain
);
1791 TREE_NO_WARNING (decl
) = 1;
1794 /* Finish off the type. */
1795 gfc_finish_type (fat_type
);
1796 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1798 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
1799 && akind
== GFC_ARRAY_ALLOCATABLE
)
1800 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1802 gfc_array_descriptor_base
[idx
] = fat_type
;
1808 /* Build an array (descriptor) type with given bounds. */
1811 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1812 tree
* ubound
, int packed
,
1813 enum gfc_array_kind akind
, bool restricted
)
1815 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1816 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1817 const char *type_name
;
1820 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
, akind
);
1821 fat_type
= build_distinct_type_copy (base_type
);
1822 /* Make sure that nontarget and target array type have the same canonical
1823 type (and same stub decl for debug info). */
1824 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false, akind
);
1825 TYPE_CANONICAL (fat_type
) = base_type
;
1826 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1828 tmp
= TYPE_NAME (etype
);
1829 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1830 tmp
= DECL_NAME (tmp
);
1832 type_name
= IDENTIFIER_POINTER (tmp
);
1834 type_name
= "unknown";
1835 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1836 GFC_MAX_SYMBOL_LEN
, type_name
);
1837 TYPE_NAME (fat_type
) = get_identifier (name
);
1838 TYPE_NAMELESS (fat_type
) = 1;
1840 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1841 TYPE_LANG_SPECIFIC (fat_type
) = ggc_cleared_alloc
<struct lang_type
> ();
1843 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1844 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1845 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1846 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1848 /* Build an array descriptor record type. */
1850 stride
= gfc_index_one_node
;
1853 for (n
= 0; n
< dimen
+ codimen
; n
++)
1856 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1863 if (lower
!= NULL_TREE
)
1865 if (INTEGER_CST_P (lower
))
1866 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1871 if (codimen
&& n
== dimen
+ codimen
- 1)
1875 if (upper
!= NULL_TREE
)
1877 if (INTEGER_CST_P (upper
))
1878 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1886 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1888 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1889 gfc_array_index_type
, upper
, lower
);
1890 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1891 gfc_array_index_type
, tmp
,
1892 gfc_index_one_node
);
1893 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1894 gfc_array_index_type
, tmp
, stride
);
1895 /* Check the folding worked. */
1896 gcc_assert (INTEGER_CST_P (stride
));
1901 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1903 /* TODO: known offsets for descriptors. */
1904 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1908 arraytype
= build_pointer_type (etype
);
1910 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1912 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1916 /* We define data as an array with the correct size if possible.
1917 Much better than doing pointer arithmetic. */
1919 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1920 int_const_binop (MINUS_EXPR
, stride
,
1921 build_int_cst (TREE_TYPE (stride
), 1)));
1923 rtype
= gfc_array_range_type
;
1924 arraytype
= build_array_type (etype
, rtype
);
1925 arraytype
= build_pointer_type (arraytype
);
1927 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1928 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1930 /* This will generate the base declarations we need to emit debug
1931 information for this type. FIXME: there must be a better way to
1932 avoid divergence between compilations with and without debug
1935 struct array_descr_info info
;
1936 gfc_get_array_descr_info (fat_type
, &info
);
1937 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
1943 /* Build a pointer type. This function is called from gfc_sym_type(). */
1946 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1948 /* Array pointer types aren't actually pointers. */
1949 if (sym
->attr
.dimension
)
1952 return build_pointer_type (type
);
1955 static tree
gfc_nonrestricted_type (tree t
);
1956 /* Given two record or union type nodes TO and FROM, ensure
1957 that all fields in FROM have a corresponding field in TO,
1958 their type being nonrestrict variants. This accepts a TO
1959 node that already has a prefix of the fields in FROM. */
1961 mirror_fields (tree to
, tree from
)
1966 /* Forward to the end of TOs fields. */
1967 fto
= TYPE_FIELDS (to
);
1968 ffrom
= TYPE_FIELDS (from
);
1969 chain
= &TYPE_FIELDS (to
);
1972 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
1973 chain
= &DECL_CHAIN (fto
);
1974 fto
= DECL_CHAIN (fto
);
1975 ffrom
= DECL_CHAIN (ffrom
);
1978 /* Now add all fields remaining in FROM (starting with ffrom). */
1979 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
1981 tree newfield
= copy_node (ffrom
);
1982 DECL_CONTEXT (newfield
) = to
;
1983 /* The store to DECL_CHAIN might seem redundant with the
1984 stores to *chain, but not clearing it here would mean
1985 leaving a chain into the old fields. If ever
1986 our called functions would look at them confusion
1988 DECL_CHAIN (newfield
) = NULL_TREE
;
1990 chain
= &DECL_CHAIN (newfield
);
1992 if (TREE_CODE (ffrom
) == FIELD_DECL
)
1994 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
1995 TREE_TYPE (newfield
) = elemtype
;
2001 /* Given a type T, returns a different type of the same structure,
2002 except that all types it refers to (recursively) are always
2003 non-restrict qualified types. */
2005 gfc_nonrestricted_type (tree t
)
2009 /* If the type isn't laid out yet, don't copy it. If something
2010 needs it for real it should wait until the type got finished. */
2014 if (!TYPE_LANG_SPECIFIC (t
))
2015 TYPE_LANG_SPECIFIC (t
) = ggc_cleared_alloc
<struct lang_type
> ();
2016 /* If we're dealing with this very node already further up
2017 the call chain (recursion via pointers and struct members)
2018 we haven't yet determined if we really need a new type node.
2019 Assume we don't, return T itself. */
2020 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
2023 /* If we have calculated this all already, just return it. */
2024 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
2025 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
2027 /* Mark this type. */
2028 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2030 switch (TREE_CODE (t
))
2036 case REFERENCE_TYPE
:
2038 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2039 if (totype
== TREE_TYPE (t
))
2041 else if (TREE_CODE (t
) == POINTER_TYPE
)
2042 ret
= build_pointer_type (totype
);
2044 ret
= build_reference_type (totype
);
2045 ret
= build_qualified_type (ret
,
2046 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2052 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2053 if (elemtype
== TREE_TYPE (t
))
2057 ret
= build_variant_type_copy (t
);
2058 TREE_TYPE (ret
) = elemtype
;
2059 if (TYPE_LANG_SPECIFIC (t
)
2060 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2062 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2063 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2064 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2066 TYPE_LANG_SPECIFIC (ret
)
2067 = ggc_cleared_alloc
<struct lang_type
> ();
2068 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2069 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2078 case QUAL_UNION_TYPE
:
2081 /* First determine if we need a new type at all.
2082 Careful, the two calls to gfc_nonrestricted_type per field
2083 might return different values. That happens exactly when
2084 one of the fields reaches back to this very record type
2085 (via pointers). The first calls will assume that we don't
2086 need to copy T (see the error_mark_node marking). If there
2087 are any reasons for copying T apart from having to copy T,
2088 we'll indeed copy it, and the second calls to
2089 gfc_nonrestricted_type will use that new node if they
2091 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2092 if (TREE_CODE (field
) == FIELD_DECL
)
2094 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2095 if (elemtype
!= TREE_TYPE (field
))
2100 ret
= build_variant_type_copy (t
);
2101 TYPE_FIELDS (ret
) = NULL_TREE
;
2103 /* Here we make sure that as soon as we know we have to copy
2104 T, that also fields reaching back to us will use the new
2105 copy. It's okay if that copy still contains the old fields,
2106 we won't look at them. */
2107 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2108 mirror_fields (ret
, t
);
2113 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2118 /* Return the type for a symbol. Special handling is required for character
2119 types to get the correct level of indirection.
2120 For functions return the return type.
2121 For subroutines return void_type_node.
2122 Calling this multiple times for the same symbol should be avoided,
2123 especially for character and array types. */
2126 gfc_sym_type (gfc_symbol
* sym
)
2132 /* Procedure Pointers inside COMMON blocks. */
2133 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2135 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2136 sym
->attr
.proc_pointer
= 0;
2137 type
= build_pointer_type (gfc_get_function_type (sym
));
2138 sym
->attr
.proc_pointer
= 1;
2142 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2143 return void_type_node
;
2145 /* In the case of a function the fake result variable may have a
2146 type different from the function type, so don't return early in
2148 if (sym
->backend_decl
&& !sym
->attr
.function
)
2149 return TREE_TYPE (sym
->backend_decl
);
2151 if (sym
->ts
.type
== BT_CHARACTER
2152 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2153 || (sym
->attr
.result
2154 && sym
->ns
->proc_name
2155 && sym
->ns
->proc_name
->attr
.is_bind_c
)
2156 || (sym
->ts
.deferred
&& (!sym
->ts
.u
.cl
2157 || !sym
->ts
.u
.cl
->backend_decl
))))
2158 type
= gfc_character1_type_node
;
2160 type
= gfc_typenode_for_spec (&sym
->ts
);
2162 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2167 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2168 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2170 type
= gfc_nonrestricted_type (type
);
2172 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2174 if (gfc_is_nodesc_array (sym
))
2176 /* If this is a character argument of unknown length, just use the
2178 if (sym
->ts
.type
!= BT_CHARACTER
2179 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2180 || sym
->ts
.u
.cl
->backend_decl
)
2182 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2191 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2192 if (sym
->attr
.pointer
)
2193 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2194 : GFC_ARRAY_POINTER
;
2195 else if (sym
->attr
.allocatable
)
2196 akind
= GFC_ARRAY_ALLOCATABLE
;
2197 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2198 sym
->attr
.contiguous
);
2203 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2204 || gfc_is_associate_pointer (sym
))
2205 type
= gfc_build_pointer_type (sym
, type
);
2208 /* We currently pass all parameters by reference.
2209 See f95_get_function_decl. For dummy function parameters return the
2213 /* We must use pointer types for potentially absent variables. The
2214 optimizers assume a reference type argument is never NULL. */
2215 if (sym
->attr
.optional
2216 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2217 type
= build_pointer_type (type
);
2220 type
= build_reference_type (type
);
2222 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2229 /* Layout and output debug info for a record type. */
2232 gfc_finish_type (tree type
)
2236 decl
= build_decl (input_location
,
2237 TYPE_DECL
, NULL_TREE
, type
);
2238 TYPE_STUB_DECL (type
) = decl
;
2240 rest_of_type_compilation (type
, 1);
2241 rest_of_decl_compilation (decl
, 1, 0);
2244 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2245 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2246 to the end of the field list pointed to by *CHAIN.
2248 Returns a pointer to the new field. */
2251 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2253 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2255 DECL_CONTEXT (decl
) = context
;
2256 DECL_CHAIN (decl
) = NULL_TREE
;
2257 if (TYPE_FIELDS (context
) == NULL_TREE
)
2258 TYPE_FIELDS (context
) = decl
;
2263 *chain
= &DECL_CHAIN (decl
);
2269 /* Like `gfc_add_field_to_struct_1', but adds alignment
2273 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2275 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2277 DECL_INITIAL (decl
) = 0;
2278 DECL_ALIGN (decl
) = 0;
2279 DECL_USER_ALIGN (decl
) = 0;
2285 /* Copy the backend_decl and component backend_decls if
2286 the two derived type symbols are "equal", as described
2287 in 4.4.2 and resolved by gfc_compare_derived_types. */
2290 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2293 gfc_component
*to_cm
;
2294 gfc_component
*from_cm
;
2299 if (from
->backend_decl
== NULL
2300 || !gfc_compare_derived_types (from
, to
))
2303 to
->backend_decl
= from
->backend_decl
;
2305 to_cm
= to
->components
;
2306 from_cm
= from
->components
;
2308 /* Copy the component declarations. If a component is itself
2309 a derived type, we need a copy of its component declarations.
2310 This is done by recursing into gfc_get_derived_type and
2311 ensures that the component's component declarations have
2312 been built. If it is a character, we need the character
2314 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2316 to_cm
->backend_decl
= from_cm
->backend_decl
;
2317 if (from_cm
->ts
.type
== BT_DERIVED
2318 && (!from_cm
->attr
.pointer
|| from_gsym
))
2319 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2320 else if (from_cm
->ts
.type
== BT_CLASS
2321 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2322 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2323 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2324 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2331 /* Build a tree node for a procedure pointer component. */
2334 gfc_get_ppc_type (gfc_component
* c
)
2338 /* Explicit interface. */
2339 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2340 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2342 /* Implicit interface (only return value may be known). */
2343 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2344 t
= gfc_typenode_for_spec (&c
->ts
);
2348 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2352 /* Build a tree node for a derived type. If there are equal
2353 derived types, with different local names, these are built
2354 at the same time. If an equal derived type has been built
2355 in a parent namespace, this is used. */
2358 gfc_get_derived_type (gfc_symbol
* derived
)
2360 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2361 tree canonical
= NULL_TREE
;
2363 bool got_canonical
= false;
2364 bool unlimited_entity
= false;
2370 if (derived
->attr
.unlimited_polymorphic
2371 || (flag_coarray
== GFC_FCOARRAY_LIB
2372 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2373 && derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
))
2374 return ptr_type_node
;
2376 if (flag_coarray
!= GFC_FCOARRAY_LIB
2377 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2378 && derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2379 return gfc_get_int_type (gfc_default_integer_kind
);
2381 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2382 && derived
->attr
.generic
)
2383 derived
= gfc_find_dt_in_generic (derived
);
2385 /* See if it's one of the iso_c_binding derived types. */
2386 if (derived
->attr
.is_iso_c
== 1 || derived
->ts
.f90_type
== BT_VOID
)
2388 if (derived
->backend_decl
)
2389 return derived
->backend_decl
;
2391 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2392 derived
->backend_decl
= ptr_type_node
;
2394 derived
->backend_decl
= pfunc_type_node
;
2396 derived
->ts
.kind
= gfc_index_integer_kind
;
2397 derived
->ts
.type
= BT_INTEGER
;
2398 /* Set the f90_type to BT_VOID as a way to recognize something of type
2399 BT_INTEGER that needs to fit a void * for the purpose of the
2400 iso_c_binding derived types. */
2401 derived
->ts
.f90_type
= BT_VOID
;
2403 return derived
->backend_decl
;
2406 /* If use associated, use the module type for this one. */
2407 if (derived
->backend_decl
== NULL
2408 && derived
->attr
.use_assoc
2410 && gfc_get_module_backend_decl (derived
))
2411 goto copy_derived_types
;
2413 /* The derived types from an earlier namespace can be used as the
2415 if (derived
->backend_decl
== NULL
&& !derived
->attr
.use_assoc
2416 && gfc_global_ns_list
)
2418 for (ns
= gfc_global_ns_list
;
2419 ns
->translated
&& !got_canonical
;
2422 dt
= ns
->derived_types
;
2423 for (; dt
&& !canonical
; dt
= dt
->next
)
2425 gfc_copy_dt_decls_ifequal (dt
->derived
, derived
, true);
2426 if (derived
->backend_decl
)
2427 got_canonical
= true;
2432 /* Store up the canonical type to be added to this one. */
2435 if (TYPE_CANONICAL (derived
->backend_decl
))
2436 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2438 canonical
= derived
->backend_decl
;
2440 derived
->backend_decl
= NULL_TREE
;
2443 /* derived->backend_decl != 0 means we saw it before, but its
2444 components' backend_decl may have not been built. */
2445 if (derived
->backend_decl
)
2447 /* Its components' backend_decl have been built or we are
2448 seeing recursion through the formal arglist of a procedure
2449 pointer component. */
2450 if (TYPE_FIELDS (derived
->backend_decl
))
2451 return derived
->backend_decl
;
2452 else if (derived
->attr
.abstract
2453 && derived
->attr
.proc_pointer_comp
)
2455 /* If an abstract derived type with procedure pointer
2456 components has no other type of component, return the
2457 backend_decl. Otherwise build the components if any of the
2458 non-procedure pointer components have no backend_decl. */
2459 for (c
= derived
->components
; c
; c
= c
->next
)
2461 if (!c
->attr
.proc_pointer
&& c
->backend_decl
== NULL
)
2463 else if (c
->next
== NULL
)
2464 return derived
->backend_decl
;
2466 typenode
= derived
->backend_decl
;
2469 typenode
= derived
->backend_decl
;
2473 /* We see this derived type first time, so build the type node. */
2474 typenode
= make_node (RECORD_TYPE
);
2475 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2476 TYPE_PACKED (typenode
) = flag_pack_derived
;
2477 derived
->backend_decl
= typenode
;
2480 if (derived
->components
2481 && derived
->components
->ts
.type
== BT_DERIVED
2482 && strcmp (derived
->components
->name
, "_data") == 0
2483 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2484 unlimited_entity
= true;
2486 /* Go through the derived type components, building them as
2487 necessary. The reason for doing this now is that it is
2488 possible to recurse back to this derived type through a
2489 pointer component (PR24092). If this happens, the fields
2490 will be built and so we can return the type. */
2491 for (c
= derived
->components
; c
; c
= c
->next
)
2493 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2496 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
2497 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2498 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
);
2500 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2502 /* Need to copy the modified ts from the derived type. The
2503 typespec was modified because C_PTR/C_FUNPTR are translated
2504 into (void *) from derived types. */
2505 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2506 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2507 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2510 c
->initializer
->ts
.type
= c
->ts
.type
;
2511 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2512 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2513 c
->initializer
->expr_type
= EXPR_NULL
;
2518 if (TYPE_FIELDS (derived
->backend_decl
))
2519 return derived
->backend_decl
;
2521 /* Build the type member list. Install the newly created RECORD_TYPE
2522 node as DECL_CONTEXT of each FIELD_DECL. */
2523 for (c
= derived
->components
; c
; c
= c
->next
)
2525 /* Prevent infinite recursion, when the procedure pointer type is
2526 the same as derived, by forcing the procedure pointer component to
2527 be built as if the explicit interface does not exist. */
2528 if (c
->attr
.proc_pointer
2529 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2531 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
))))
2532 field_type
= gfc_get_ppc_type (c
);
2533 else if (c
->attr
.proc_pointer
&& derived
->backend_decl
)
2535 tmp
= build_function_type_list (derived
->backend_decl
, NULL_TREE
);
2536 field_type
= build_pointer_type (tmp
);
2538 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2539 field_type
= c
->ts
.u
.derived
->backend_decl
;
2542 if (c
->ts
.type
== BT_CHARACTER
&& !c
->ts
.deferred
)
2544 /* Evaluate the string length. */
2545 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2546 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2548 else if (c
->ts
.type
== BT_CHARACTER
)
2549 c
->ts
.u
.cl
->backend_decl
2550 = build_int_cst (gfc_charlen_type_node
, 0);
2552 field_type
= gfc_typenode_for_spec (&c
->ts
);
2555 /* This returns an array descriptor type. Initialization may be
2557 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2559 if (c
->attr
.pointer
|| c
->attr
.allocatable
)
2561 enum gfc_array_kind akind
;
2562 if (c
->attr
.pointer
)
2563 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2564 : GFC_ARRAY_POINTER
;
2566 akind
= GFC_ARRAY_ALLOCATABLE
;
2567 /* Pointers to arrays aren't actually pointer types. The
2568 descriptors are separate, but the data is common. */
2569 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2571 && !c
->attr
.pointer
,
2572 c
->attr
.contiguous
);
2575 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2579 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
)
2580 && !c
->attr
.proc_pointer
2581 && !(unlimited_entity
&& c
== derived
->components
))
2582 field_type
= build_pointer_type (field_type
);
2584 if (c
->attr
.pointer
)
2585 field_type
= gfc_nonrestricted_type (field_type
);
2587 /* vtype fields can point to different types to the base type. */
2588 if (c
->ts
.type
== BT_DERIVED
2589 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2590 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2593 /* Ensure that the CLASS language specific flag is set. */
2594 if (c
->ts
.type
== BT_CLASS
)
2596 if (POINTER_TYPE_P (field_type
))
2597 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2599 GFC_CLASS_TYPE_P (field_type
) = 1;
2602 field
= gfc_add_field_to_struct (typenode
,
2603 get_identifier (c
->name
),
2604 field_type
, &chain
);
2606 gfc_set_decl_location (field
, &c
->loc
);
2607 else if (derived
->declared_at
.lb
)
2608 gfc_set_decl_location (field
, &derived
->declared_at
);
2610 gfc_finish_decl_attrs (field
, &c
->attr
);
2612 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2615 if (!c
->backend_decl
)
2616 c
->backend_decl
= field
;
2619 /* Now lay out the derived type, including the fields. */
2621 TYPE_CANONICAL (typenode
) = canonical
;
2623 gfc_finish_type (typenode
);
2624 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2625 if (derived
->module
&& derived
->ns
->proc_name
2626 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2628 if (derived
->ns
->proc_name
->backend_decl
2629 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2632 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2633 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2634 = derived
->ns
->proc_name
->backend_decl
;
2638 derived
->backend_decl
= typenode
;
2642 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2643 gfc_copy_dt_decls_ifequal (derived
, dt
->derived
, false);
2645 return derived
->backend_decl
;
2650 gfc_return_by_reference (gfc_symbol
* sym
)
2652 if (!sym
->attr
.function
)
2655 if (sym
->attr
.dimension
)
2658 if (sym
->ts
.type
== BT_CHARACTER
2659 && !sym
->attr
.is_bind_c
2660 && (!sym
->attr
.result
2661 || !sym
->ns
->proc_name
2662 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2665 /* Possibly return complex numbers by reference for g77 compatibility.
2666 We don't do this for calls to intrinsics (as the library uses the
2667 -fno-f2c calling convention), nor for calls to functions which always
2668 require an explicit interface, as no compatibility problems can
2670 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2671 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2678 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2682 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2683 gfc_entry_list
*el
, *el2
;
2685 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2686 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2688 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2690 /* Build the type node. */
2691 type
= make_node (UNION_TYPE
);
2693 TYPE_NAME (type
) = get_identifier (name
);
2695 for (el
= ns
->entries
; el
; el
= el
->next
)
2697 /* Search for duplicates. */
2698 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2699 if (el2
->sym
->result
== el
->sym
->result
)
2703 gfc_add_field_to_struct_1 (type
,
2704 get_identifier (el
->sym
->result
->name
),
2705 gfc_sym_type (el
->sym
->result
), &chain
);
2708 /* Finish off the type. */
2709 gfc_finish_type (type
);
2710 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2714 /* Create a "fn spec" based on the formal arguments;
2715 cf. create_function_arglist. */
2718 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2722 gfc_formal_arglist
*f
;
2725 memset (&spec
, 0, sizeof (spec
));
2729 if (sym
->attr
.entry_master
)
2730 spec
[spec_len
++] = 'R';
2731 if (gfc_return_by_reference (sym
))
2733 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2735 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2736 spec
[spec_len
++] = '.';
2738 spec
[spec_len
++] = 'w';
2739 if (sym
->ts
.type
== BT_CHARACTER
)
2740 spec
[spec_len
++] = 'R';
2743 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2744 if (spec_len
< sizeof (spec
))
2746 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2747 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2748 || (f
->sym
->ts
.type
== BT_DERIVED
2749 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2750 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2751 || (f
->sym
->ts
.type
== BT_CLASS
2752 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2753 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2754 spec
[spec_len
++] = '.';
2755 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2756 spec
[spec_len
++] = 'r';
2758 spec
[spec_len
++] = 'w';
2761 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2762 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2763 return build_type_attribute_variant (fntype
, tmp
);
2768 gfc_get_function_type (gfc_symbol
* sym
)
2771 vec
<tree
, va_gc
> *typelist
= NULL
;
2772 gfc_formal_arglist
*f
;
2774 int alternate_return
= 0;
2775 bool is_varargs
= true;
2777 /* Make sure this symbol is a function, a subroutine or the main
2779 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2780 || sym
->attr
.flavor
== FL_PROGRAM
);
2782 /* To avoid recursing infinitely on recursive types, we use error_mark_node
2783 so that they can be detected here and handled further down. */
2784 if (sym
->backend_decl
== NULL
)
2785 sym
->backend_decl
= error_mark_node
;
2786 else if (sym
->backend_decl
== error_mark_node
)
2787 goto arg_type_list_done
;
2788 else if (sym
->attr
.proc_pointer
)
2789 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
2791 return TREE_TYPE (sym
->backend_decl
);
2793 if (sym
->attr
.entry_master
)
2794 /* Additional parameter for selecting an entry point. */
2795 vec_safe_push (typelist
, gfc_array_index_type
);
2802 if (arg
->ts
.type
== BT_CHARACTER
)
2803 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2805 /* Some functions we use an extra parameter for the return value. */
2806 if (gfc_return_by_reference (sym
))
2808 type
= gfc_sym_type (arg
);
2809 if (arg
->ts
.type
== BT_COMPLEX
2810 || arg
->attr
.dimension
2811 || arg
->ts
.type
== BT_CHARACTER
)
2812 type
= build_reference_type (type
);
2814 vec_safe_push (typelist
, type
);
2815 if (arg
->ts
.type
== BT_CHARACTER
)
2817 if (!arg
->ts
.deferred
)
2818 /* Transfer by value. */
2819 vec_safe_push (typelist
, gfc_charlen_type_node
);
2821 /* Deferred character lengths are transferred by reference
2822 so that the value can be returned. */
2823 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
2827 /* Build the argument types for the function. */
2828 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2833 /* Evaluate constant character lengths here so that they can be
2834 included in the type. */
2835 if (arg
->ts
.type
== BT_CHARACTER
)
2836 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2838 if (arg
->attr
.flavor
== FL_PROCEDURE
)
2840 type
= gfc_get_function_type (arg
);
2841 type
= build_pointer_type (type
);
2844 type
= gfc_sym_type (arg
);
2846 /* Parameter Passing Convention
2848 We currently pass all parameters by reference.
2849 Parameters with INTENT(IN) could be passed by value.
2850 The problem arises if a function is called via an implicit
2851 prototype. In this situation the INTENT is not known.
2852 For this reason all parameters to global functions must be
2853 passed by reference. Passing by value would potentially
2854 generate bad code. Worse there would be no way of telling that
2855 this code was bad, except that it would give incorrect results.
2857 Contained procedures could pass by value as these are never
2858 used without an explicit interface, and cannot be passed as
2859 actual parameters for a dummy procedure. */
2861 vec_safe_push (typelist
, type
);
2865 if (sym
->attr
.subroutine
)
2866 alternate_return
= 1;
2870 /* Add hidden string length parameters. */
2871 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2874 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2876 if (!arg
->ts
.deferred
)
2877 /* Transfer by value. */
2878 type
= gfc_charlen_type_node
;
2880 /* Deferred character lengths are transferred by reference
2881 so that the value can be returned. */
2882 type
= build_pointer_type (gfc_charlen_type_node
);
2884 vec_safe_push (typelist
, type
);
2888 if (!vec_safe_is_empty (typelist
)
2889 || sym
->attr
.is_main_program
2890 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
2893 if (sym
->backend_decl
== error_mark_node
)
2894 sym
->backend_decl
= NULL_TREE
;
2898 if (alternate_return
)
2899 type
= integer_type_node
;
2900 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
2901 type
= void_type_node
;
2902 else if (sym
->attr
.mixed_entry_master
)
2903 type
= gfc_get_mixed_entry_union (sym
->ns
);
2904 else if (flag_f2c
&& sym
->ts
.type
== BT_REAL
2905 && sym
->ts
.kind
== gfc_default_real_kind
2906 && !sym
->attr
.always_explicit
)
2908 /* Special case: f2c calling conventions require that (scalar)
2909 default REAL functions return the C type double instead. f2c
2910 compatibility is only an issue with functions that don't
2911 require an explicit interface, as only these could be
2912 implemented in Fortran 77. */
2913 sym
->ts
.kind
= gfc_default_double_kind
;
2914 type
= gfc_typenode_for_spec (&sym
->ts
);
2915 sym
->ts
.kind
= gfc_default_real_kind
;
2917 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
2918 /* Procedure pointer return values. */
2920 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
2922 /* Unset proc_pointer as gfc_get_function_type
2923 is called recursively. */
2924 sym
->result
->attr
.proc_pointer
= 0;
2925 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
2926 sym
->result
->attr
.proc_pointer
= 1;
2929 type
= gfc_sym_type (sym
->result
);
2932 type
= gfc_sym_type (sym
);
2935 type
= build_varargs_function_type_vec (type
, typelist
);
2937 type
= build_function_type_vec (type
, typelist
);
2938 type
= create_fn_spec (sym
, type
);
2943 /* Language hooks for middle-end access to type nodes. */
2945 /* Return an integer type with BITS bits of precision,
2946 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2949 gfc_type_for_size (unsigned bits
, int unsignedp
)
2954 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
2956 tree type
= gfc_integer_types
[i
];
2957 if (type
&& bits
== TYPE_PRECISION (type
))
2961 /* Handle TImode as a special case because it is used by some backends
2962 (e.g. ARM) even though it is not available for normal use. */
2963 #if HOST_BITS_PER_WIDE_INT >= 64
2964 if (bits
== TYPE_PRECISION (intTI_type_node
))
2965 return intTI_type_node
;
2968 if (bits
<= TYPE_PRECISION (intQI_type_node
))
2969 return intQI_type_node
;
2970 if (bits
<= TYPE_PRECISION (intHI_type_node
))
2971 return intHI_type_node
;
2972 if (bits
<= TYPE_PRECISION (intSI_type_node
))
2973 return intSI_type_node
;
2974 if (bits
<= TYPE_PRECISION (intDI_type_node
))
2975 return intDI_type_node
;
2976 if (bits
<= TYPE_PRECISION (intTI_type_node
))
2977 return intTI_type_node
;
2981 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
2982 return unsigned_intQI_type_node
;
2983 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
2984 return unsigned_intHI_type_node
;
2985 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
2986 return unsigned_intSI_type_node
;
2987 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
2988 return unsigned_intDI_type_node
;
2989 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
2990 return unsigned_intTI_type_node
;
2996 /* Return a data type that has machine mode MODE. If the mode is an
2997 integer, then UNSIGNEDP selects between signed and unsigned types. */
3000 gfc_type_for_mode (machine_mode mode
, int unsignedp
)
3005 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
3006 base
= gfc_real_types
;
3007 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
3008 base
= gfc_complex_types
;
3009 else if (SCALAR_INT_MODE_P (mode
))
3011 tree type
= gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
3012 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
3014 else if (VECTOR_MODE_P (mode
))
3016 machine_mode inner_mode
= GET_MODE_INNER (mode
);
3017 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
3018 if (inner_type
!= NULL_TREE
)
3019 return build_vector_type_for_mode (inner_type
, mode
);
3025 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
3027 tree type
= base
[i
];
3028 if (type
&& mode
== TYPE_MODE (type
))
3035 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3039 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
3042 bool indirect
= false;
3043 tree etype
, ptype
, field
, t
, base_decl
;
3044 tree data_off
, dim_off
, dim_size
, elem_size
;
3045 tree lower_suboff
, upper_suboff
, stride_suboff
;
3047 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3049 if (! POINTER_TYPE_P (type
))
3051 type
= TREE_TYPE (type
);
3052 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3057 rank
= GFC_TYPE_ARRAY_RANK (type
);
3058 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3061 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3062 gcc_assert (POINTER_TYPE_P (etype
));
3063 etype
= TREE_TYPE (etype
);
3065 /* If the type is not a scalar coarray. */
3066 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3067 etype
= TREE_TYPE (etype
);
3069 /* Can't handle variable sized elements yet. */
3070 if (int_size_in_bytes (etype
) <= 0)
3072 /* Nor non-constant lower bounds in assumed shape arrays. */
3073 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3074 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3076 for (dim
= 0; dim
< rank
; dim
++)
3077 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3078 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3082 memset (info
, '\0', sizeof (*info
));
3083 info
->ndimensions
= rank
;
3084 info
->ordering
= array_descr_ordering_column_major
;
3085 info
->element_type
= etype
;
3086 ptype
= build_pointer_type (gfc_array_index_type
);
3087 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3090 base_decl
= make_node (DEBUG_EXPR_DECL
);
3091 DECL_ARTIFICIAL (base_decl
) = 1;
3092 TREE_TYPE (base_decl
) = indirect
? build_pointer_type (ptype
) : ptype
;
3093 DECL_MODE (base_decl
) = TYPE_MODE (TREE_TYPE (base_decl
));
3094 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3096 info
->base_decl
= base_decl
;
3098 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3100 if (GFC_TYPE_ARRAY_SPAN (type
))
3101 elem_size
= GFC_TYPE_ARRAY_SPAN (type
);
3103 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
3104 field
= TYPE_FIELDS (TYPE_MAIN_VARIANT (type
));
3105 data_off
= byte_position (field
);
3106 field
= DECL_CHAIN (field
);
3107 field
= DECL_CHAIN (field
);
3108 field
= DECL_CHAIN (field
);
3109 dim_off
= byte_position (field
);
3110 dim_size
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field
)));
3111 field
= TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field
)));
3112 stride_suboff
= byte_position (field
);
3113 field
= DECL_CHAIN (field
);
3114 lower_suboff
= byte_position (field
);
3115 field
= DECL_CHAIN (field
);
3116 upper_suboff
= byte_position (field
);
3119 if (!integer_zerop (data_off
))
3120 t
= fold_build_pointer_plus (t
, data_off
);
3121 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3122 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3123 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3124 info
->allocated
= build2 (NE_EXPR
, boolean_type_node
,
3125 info
->data_location
, null_pointer_node
);
3126 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3127 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3128 info
->associated
= build2 (NE_EXPR
, boolean_type_node
,
3129 info
->data_location
, null_pointer_node
);
3131 for (dim
= 0; dim
< rank
; dim
++)
3133 t
= fold_build_pointer_plus (base_decl
,
3134 size_binop (PLUS_EXPR
,
3135 dim_off
, lower_suboff
));
3136 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3137 info
->dimen
[dim
].lower_bound
= t
;
3138 t
= fold_build_pointer_plus (base_decl
,
3139 size_binop (PLUS_EXPR
,
3140 dim_off
, upper_suboff
));
3141 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3142 info
->dimen
[dim
].upper_bound
= t
;
3143 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3144 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3146 /* Assumed shape arrays have known lower bounds. */
3147 info
->dimen
[dim
].upper_bound
3148 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3149 info
->dimen
[dim
].upper_bound
,
3150 info
->dimen
[dim
].lower_bound
);
3151 info
->dimen
[dim
].lower_bound
3152 = fold_convert (gfc_array_index_type
,
3153 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3154 info
->dimen
[dim
].upper_bound
3155 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3156 info
->dimen
[dim
].lower_bound
,
3157 info
->dimen
[dim
].upper_bound
);
3159 t
= fold_build_pointer_plus (base_decl
,
3160 size_binop (PLUS_EXPR
,
3161 dim_off
, stride_suboff
));
3162 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3163 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3164 info
->dimen
[dim
].stride
= t
;
3165 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3172 /* Create a type to handle vector subscripts for coarray library calls. It
3174 struct caf_vector_t {
3175 size_t nvec; // size of the vector
3182 ptrdiff_t lower_bound;
3183 ptrdiff_t upper_bound;
3188 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3189 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3192 gfc_get_caf_vector_type (int dim
)
3194 static tree vector_types
[GFC_MAX_DIMENSIONS
];
3195 static tree vec_type
= NULL_TREE
;
3196 tree triplet_struct_type
, vect_struct_type
, union_type
, tmp
, *chain
;
3198 if (vector_types
[dim
-1] != NULL_TREE
)
3199 return vector_types
[dim
-1];
3201 if (vec_type
== NULL_TREE
)
3204 vect_struct_type
= make_node (RECORD_TYPE
);
3205 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3206 get_identifier ("vector"),
3207 pvoid_type_node
, &chain
);
3208 TREE_NO_WARNING (tmp
) = 1;
3209 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3210 get_identifier ("kind"),
3211 integer_type_node
, &chain
);
3212 TREE_NO_WARNING (tmp
) = 1;
3213 gfc_finish_type (vect_struct_type
);
3216 triplet_struct_type
= make_node (RECORD_TYPE
);
3217 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3218 get_identifier ("lower_bound"),
3219 gfc_array_index_type
, &chain
);
3220 TREE_NO_WARNING (tmp
) = 1;
3221 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3222 get_identifier ("upper_bound"),
3223 gfc_array_index_type
, &chain
);
3224 TREE_NO_WARNING (tmp
) = 1;
3225 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
, get_identifier ("stride"),
3226 gfc_array_index_type
, &chain
);
3227 TREE_NO_WARNING (tmp
) = 1;
3228 gfc_finish_type (triplet_struct_type
);
3231 union_type
= make_node (UNION_TYPE
);
3232 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3233 vect_struct_type
, &chain
);
3234 TREE_NO_WARNING (tmp
) = 1;
3235 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("triplet"),
3236 triplet_struct_type
, &chain
);
3237 TREE_NO_WARNING (tmp
) = 1;
3238 gfc_finish_type (union_type
);
3241 vec_type
= make_node (RECORD_TYPE
);
3242 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("nvec"),
3243 size_type_node
, &chain
);
3244 TREE_NO_WARNING (tmp
) = 1;
3245 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("u"),
3246 union_type
, &chain
);
3247 TREE_NO_WARNING (tmp
) = 1;
3248 gfc_finish_type (vec_type
);
3249 TYPE_NAME (vec_type
) = get_identifier ("caf_vector_t");
3252 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3253 gfc_rank_cst
[dim
-1]);
3254 vector_types
[dim
-1] = build_array_type (vec_type
, tmp
);
3255 return vector_types
[dim
-1];
3258 #include "gt-fortran-trans-types.h"