1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-types.c -- gfortran backend types */
28 #include "coretypes.h"
29 #include "tm.h" /* For INTMAX_TYPE, INT8_TYPE, INT16_TYPE, INT32_TYPE,
30 INT64_TYPE, INT_LEAST8_TYPE, INT_LEAST16_TYPE,
31 INT_LEAST32_TYPE, INT_LEAST64_TYPE, INT_FAST8_TYPE,
32 INT_FAST16_TYPE, INT_FAST32_TYPE, INT_FAST64_TYPE,
33 BOOL_TYPE_SIZE, BITS_PER_UNIT, POINTER_SIZE,
34 INT_TYPE_SIZE, CHAR_TYPE_SIZE, SHORT_TYPE_SIZE,
35 LONG_TYPE_SIZE, LONG_LONG_TYPE_SIZE,
36 FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE,
37 LONG_DOUBLE_TYPE_SIZE and LIBGCC2_HAS_TF_MODE. */
39 #include "langhooks.h" /* For iso-c-bindings.def. */
42 #include "diagnostic-core.h" /* For fatal_error. */
43 #include "toplev.h" /* For rest_of_decl_compilation. */
46 #include "trans-types.h"
47 #include "trans-const.h"
49 #include "dwarf2out.h" /* For struct array_descr_info. */
52 #if (GFC_MAX_DIMENSIONS < 10)
53 #define GFC_RANK_DIGITS 1
54 #define GFC_RANK_PRINTF_FORMAT "%01d"
55 #elif (GFC_MAX_DIMENSIONS < 100)
56 #define GFC_RANK_DIGITS 2
57 #define GFC_RANK_PRINTF_FORMAT "%02d"
59 #error If you really need >99 dimensions, continue the sequence above...
62 /* array of structs so we don't have to worry about xmalloc or free */
63 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
65 tree gfc_array_index_type;
66 tree gfc_array_range_type;
67 tree gfc_character1_type_node;
69 tree prvoid_type_node;
70 tree ppvoid_type_node;
74 tree gfc_charlen_type_node;
76 tree float128_type_node = NULL_TREE;
77 tree complex_float128_type_node = NULL_TREE;
79 bool gfc_real16_is_float128 = false;
81 static GTY(()) tree gfc_desc_dim_type;
82 static GTY(()) tree gfc_max_array_element_size;
83 static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
85 /* Arrays for all integral and real kinds. We'll fill this in at runtime
86 after the target has a chance to process command-line options. */
88 #define MAX_INT_KINDS 5
89 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
90 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
91 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
92 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
94 #define MAX_REAL_KINDS 5
95 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
96 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
97 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
99 #define MAX_CHARACTER_KINDS 2
100 gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
101 static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
102 static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
104 static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **);
106 /* The integer kind to use for array indices. This will be set to the
107 proper value based on target information from the backend. */
109 int gfc_index_integer_kind;
111 /* The default kinds of the various types. */
113 int gfc_default_integer_kind;
114 int gfc_max_integer_kind;
115 int gfc_default_real_kind;
116 int gfc_default_double_kind;
117 int gfc_default_character_kind;
118 int gfc_default_logical_kind;
119 int gfc_default_complex_kind;
122 /* The kind size used for record offsets. If the target system supports
123 kind=8, this will be set to 8, otherwise it is set to 4. */
126 /* The integer kind used to store character lengths. */
127 int gfc_charlen_int_kind;
129 /* The size of the numeric storage unit and character storage unit. */
130 int gfc_numeric_storage_size;
131 int gfc_character_storage_size;
135 gfc_check_any_c_kind (gfc_typespec *ts)
139 for (i = 0; i < ISOCBINDING_NUMBER; i++)
141 /* Check for any C interoperable kind for the given type/kind in ts.
142 This can be used after verify_c_interop to make sure that the
143 Fortran kind being used exists in at least some form for C. */
144 if (c_interop_kinds_table[i].f90_type == ts->type &&
145 c_interop_kinds_table[i].value == ts->kind)
154 get_real_kind_from_node (tree type)
158 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
159 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
160 return gfc_real_kinds[i].kind;
166 get_int_kind_from_node (tree type)
173 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
174 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
175 return gfc_integer_kinds[i].kind;
180 /* Return a typenode for the "standard" C type with a given name. */
182 get_typenode_from_name (const char *name)
184 if (name == NULL || *name == '\0')
187 if (strcmp (name, "char") == 0)
188 return char_type_node;
189 if (strcmp (name, "unsigned char") == 0)
190 return unsigned_char_type_node;
191 if (strcmp (name, "signed char") == 0)
192 return signed_char_type_node;
194 if (strcmp (name, "short int") == 0)
195 return short_integer_type_node;
196 if (strcmp (name, "short unsigned int") == 0)
197 return short_unsigned_type_node;
199 if (strcmp (name, "int") == 0)
200 return integer_type_node;
201 if (strcmp (name, "unsigned int") == 0)
202 return unsigned_type_node;
204 if (strcmp (name, "long int") == 0)
205 return long_integer_type_node;
206 if (strcmp (name, "long unsigned int") == 0)
207 return long_unsigned_type_node;
209 if (strcmp (name, "long long int") == 0)
210 return long_long_integer_type_node;
211 if (strcmp (name, "long long unsigned int") == 0)
212 return long_long_unsigned_type_node;
218 get_int_kind_from_name (const char *name)
220 return get_int_kind_from_node (get_typenode_from_name (name));
224 /* Get the kind number corresponding to an integer of given size,
225 following the required return values for ISO_FORTRAN_ENV INT* constants:
226 -2 is returned if we support a kind of larger size, -1 otherwise. */
228 gfc_get_int_kind_from_width_isofortranenv (int size)
232 /* Look for a kind with matching storage size. */
233 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
234 if (gfc_integer_kinds[i].bit_size == size)
235 return gfc_integer_kinds[i].kind;
237 /* Look for a kind with larger storage size. */
238 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
239 if (gfc_integer_kinds[i].bit_size > size)
245 /* Get the kind number corresponding to a real of given storage size,
246 following the required return values for ISO_FORTRAN_ENV REAL* constants:
247 -2 is returned if we support a kind of larger size, -1 otherwise. */
249 gfc_get_real_kind_from_width_isofortranenv (int size)
255 /* Look for a kind with matching storage size. */
256 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
257 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
258 return gfc_real_kinds[i].kind;
260 /* Look for a kind with larger storage size. */
261 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
262 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
271 get_int_kind_from_width (int size)
275 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
276 if (gfc_integer_kinds[i].bit_size == size)
277 return gfc_integer_kinds[i].kind;
283 get_int_kind_from_minimal_width (int size)
287 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
288 if (gfc_integer_kinds[i].bit_size >= size)
289 return gfc_integer_kinds[i].kind;
295 /* Generate the CInteropKind_t objects for the C interoperable
299 void init_c_interop_kinds (void)
303 /* init all pointers in the list to NULL */
304 for (i = 0; i < ISOCBINDING_NUMBER; i++)
306 /* Initialize the name and value fields. */
307 c_interop_kinds_table[i].name[0] = '\0';
308 c_interop_kinds_table[i].value = -100;
309 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
312 #define NAMED_INTCST(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_INTEGER; \
315 c_interop_kinds_table[a].value = c;
316 #define NAMED_REALCST(a,b,c) \
317 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
318 c_interop_kinds_table[a].f90_type = BT_REAL; \
319 c_interop_kinds_table[a].value = c;
320 #define NAMED_CMPXCST(a,b,c) \
321 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
322 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
323 c_interop_kinds_table[a].value = c;
324 #define NAMED_LOGCST(a,b,c) \
325 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
326 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
327 c_interop_kinds_table[a].value = c;
328 #define NAMED_CHARKNDCST(a,b,c) \
329 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
330 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
331 c_interop_kinds_table[a].value = c;
332 #define NAMED_CHARCST(a,b,c) \
333 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
334 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
335 c_interop_kinds_table[a].value = c;
336 #define DERIVED_TYPE(a,b,c) \
337 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
338 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
339 c_interop_kinds_table[a].value = c;
340 #define PROCEDURE(a,b) \
341 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
342 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
343 c_interop_kinds_table[a].value = 0;
344 #include "iso-c-binding.def"
345 #define NAMED_FUNCTION(a,b,c,d) \
346 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
347 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
348 c_interop_kinds_table[a].value = c;
349 #include "iso-c-binding.def"
353 /* Query the target to determine which machine modes are available for
354 computation. Choose KIND numbers for them. */
357 gfc_init_kinds (void)
360 int i_index, r_index, kind;
361 bool saw_i4 = false, saw_i8 = false;
362 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
364 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
368 if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
371 /* The middle end doesn't support constants larger than 2*HWI.
372 Perhaps the target hook shouldn't have accepted these either,
373 but just to be safe... */
374 bitsize = GET_MODE_BITSIZE (mode);
375 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
378 gcc_assert (i_index != MAX_INT_KINDS);
380 /* Let the kind equal the bit size divided by 8. This insulates the
381 programmer from the underlying byte size. */
389 gfc_integer_kinds[i_index].kind = kind;
390 gfc_integer_kinds[i_index].radix = 2;
391 gfc_integer_kinds[i_index].digits = bitsize - 1;
392 gfc_integer_kinds[i_index].bit_size = bitsize;
394 gfc_logical_kinds[i_index].kind = kind;
395 gfc_logical_kinds[i_index].bit_size = bitsize;
400 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
401 used for large file access. */
408 /* If we do not at least have kind = 4, everything is pointless. */
411 /* Set the maximum integer kind. Used with at least BOZ constants. */
412 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
414 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
416 const struct real_format *fmt =
417 REAL_MODE_FORMAT ((enum machine_mode) mode);
422 if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
425 /* Only let float, double, long double and __float128 go through.
426 Runtime support for others is not provided, so they would be
428 if (mode != TYPE_MODE (float_type_node)
429 && (mode != TYPE_MODE (double_type_node))
430 && (mode != TYPE_MODE (long_double_type_node))
431 #if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
437 /* Let the kind equal the precision divided by 8, rounding up. Again,
438 this insulates the programmer from the underlying byte size.
440 Also, it effectively deals with IEEE extended formats. There, the
441 total size of the type may equal 16, but it's got 6 bytes of padding
442 and the increased size can get in the way of a real IEEE quad format
443 which may also be supported by the target.
445 We round up so as to handle IA-64 __floatreg (RFmode), which is an
446 82 bit type. Not to be confused with __float80 (XFmode), which is
447 an 80 bit type also supported by IA-64. So XFmode should come out
448 to be kind=10, and RFmode should come out to be kind=11. Egads. */
450 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
459 /* Careful we don't stumble a weird internal mode. */
460 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
461 /* Or have too many modes for the allocated space. */
462 gcc_assert (r_index != MAX_REAL_KINDS);
464 gfc_real_kinds[r_index].kind = kind;
465 gfc_real_kinds[r_index].radix = fmt->b;
466 gfc_real_kinds[r_index].digits = fmt->p;
467 gfc_real_kinds[r_index].min_exponent = fmt->emin;
468 gfc_real_kinds[r_index].max_exponent = fmt->emax;
469 if (fmt->pnan < fmt->p)
470 /* This is an IBM extended double format (or the MIPS variant)
471 made up of two IEEE doubles. The value of the long double is
472 the sum of the values of the two parts. The most significant
473 part is required to be the value of the long double rounded
474 to the nearest double. If we use emax of 1024 then we can't
475 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
476 rounding will make the most significant part overflow. */
477 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
478 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
482 /* Choose the default integer kind. We choose 4 unless the user
483 directs us otherwise. */
484 if (gfc_option.flag_default_integer)
487 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
488 gfc_default_integer_kind = 8;
490 /* Even if the user specified that the default integer kind be 8,
491 the numeric storage size isn't 64. In this case, a warning will
492 be issued when NUMERIC_STORAGE_SIZE is used. */
493 gfc_numeric_storage_size = 4 * 8;
497 gfc_default_integer_kind = 4;
498 gfc_numeric_storage_size = 4 * 8;
502 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
503 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
506 /* Choose the default real kind. Again, we choose 4 when possible. */
507 if (gfc_option.flag_default_real)
510 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
511 gfc_default_real_kind = 8;
514 gfc_default_real_kind = 4;
516 gfc_default_real_kind = gfc_real_kinds[0].kind;
518 /* Choose the default double kind. If -fdefault-real and -fdefault-double
519 are specified, we use kind=8, if it's available. If -fdefault-real is
520 specified without -fdefault-double, we use kind=16, if it's available.
521 Otherwise we do not change anything. */
522 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
523 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
525 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
526 gfc_default_double_kind = 8;
527 else if (gfc_option.flag_default_real && saw_r16)
528 gfc_default_double_kind = 16;
529 else if (saw_r4 && saw_r8)
530 gfc_default_double_kind = 8;
533 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
534 real ... occupies two contiguous numeric storage units.
536 Therefore we must be supplied a kind twice as large as we chose
537 for single precision. There are loopholes, in that double
538 precision must *occupy* two storage units, though it doesn't have
539 to *use* two storage units. Which means that you can make this
540 kind artificially wide by padding it. But at present there are
541 no GCC targets for which a two-word type does not exist, so we
542 just let gfc_validate_kind abort and tell us if something breaks. */
544 gfc_default_double_kind
545 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
548 /* The default logical kind is constrained to be the same as the
549 default integer kind. Similarly with complex and real. */
550 gfc_default_logical_kind = gfc_default_integer_kind;
551 gfc_default_complex_kind = gfc_default_real_kind;
553 /* We only have two character kinds: ASCII and UCS-4.
554 ASCII corresponds to a 8-bit integer type, if one is available.
555 UCS-4 corresponds to a 32-bit integer type, if one is available. */
557 if ((kind = get_int_kind_from_width (8)) > 0)
559 gfc_character_kinds[i_index].kind = kind;
560 gfc_character_kinds[i_index].bit_size = 8;
561 gfc_character_kinds[i_index].name = "ascii";
564 if ((kind = get_int_kind_from_width (32)) > 0)
566 gfc_character_kinds[i_index].kind = kind;
567 gfc_character_kinds[i_index].bit_size = 32;
568 gfc_character_kinds[i_index].name = "iso_10646";
572 /* Choose the smallest integer kind for our default character. */
573 gfc_default_character_kind = gfc_character_kinds[0].kind;
574 gfc_character_storage_size = gfc_default_character_kind * 8;
576 /* Choose the integer kind the same size as "void*" for our index kind. */
577 gfc_index_integer_kind = POINTER_SIZE / 8;
578 /* Pick a kind the same size as the C "int" type. */
579 gfc_c_int_kind = INT_TYPE_SIZE / 8;
581 /* initialize the C interoperable kinds */
582 init_c_interop_kinds();
585 /* Make sure that a valid kind is present. Returns an index into the
586 associated kinds array, -1 if the kind is not present. */
589 validate_integer (int kind)
593 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
594 if (gfc_integer_kinds[i].kind == kind)
601 validate_real (int kind)
605 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
606 if (gfc_real_kinds[i].kind == kind)
613 validate_logical (int kind)
617 for (i = 0; gfc_logical_kinds[i].kind; i++)
618 if (gfc_logical_kinds[i].kind == kind)
625 validate_character (int kind)
629 for (i = 0; gfc_character_kinds[i].kind; i++)
630 if (gfc_character_kinds[i].kind == kind)
636 /* Validate a kind given a basic type. The return value is the same
637 for the child functions, with -1 indicating nonexistence of the
638 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
641 gfc_validate_kind (bt type, int kind, bool may_fail)
647 case BT_REAL: /* Fall through */
649 rc = validate_real (kind);
652 rc = validate_integer (kind);
655 rc = validate_logical (kind);
658 rc = validate_character (kind);
662 gfc_internal_error ("gfc_validate_kind(): Got bad type");
665 if (rc < 0 && !may_fail)
666 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
672 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
673 Reuse common type nodes where possible. Recognize if the kind matches up
674 with a C type. This will be used later in determining which routines may
675 be scarfed from libm. */
678 gfc_build_int_type (gfc_integer_info *info)
680 int mode_precision = info->bit_size;
682 if (mode_precision == CHAR_TYPE_SIZE)
684 if (mode_precision == SHORT_TYPE_SIZE)
686 if (mode_precision == INT_TYPE_SIZE)
688 if (mode_precision == LONG_TYPE_SIZE)
690 if (mode_precision == LONG_LONG_TYPE_SIZE)
691 info->c_long_long = 1;
693 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
694 return intQI_type_node;
695 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
696 return intHI_type_node;
697 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
698 return intSI_type_node;
699 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
700 return intDI_type_node;
701 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
702 return intTI_type_node;
704 return make_signed_type (mode_precision);
708 gfc_build_uint_type (int size)
710 if (size == CHAR_TYPE_SIZE)
711 return unsigned_char_type_node;
712 if (size == SHORT_TYPE_SIZE)
713 return short_unsigned_type_node;
714 if (size == INT_TYPE_SIZE)
715 return unsigned_type_node;
716 if (size == LONG_TYPE_SIZE)
717 return long_unsigned_type_node;
718 if (size == LONG_LONG_TYPE_SIZE)
719 return long_long_unsigned_type_node;
721 return make_unsigned_type (size);
726 gfc_build_real_type (gfc_real_info *info)
728 int mode_precision = info->mode_precision;
731 if (mode_precision == FLOAT_TYPE_SIZE)
733 if (mode_precision == DOUBLE_TYPE_SIZE)
735 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
736 info->c_long_double = 1;
737 if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
739 info->c_float128 = 1;
740 gfc_real16_is_float128 = true;
743 if (TYPE_PRECISION (float_type_node) == mode_precision)
744 return float_type_node;
745 if (TYPE_PRECISION (double_type_node) == mode_precision)
746 return double_type_node;
747 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
748 return long_double_type_node;
750 new_type = make_node (REAL_TYPE);
751 TYPE_PRECISION (new_type) = mode_precision;
752 layout_type (new_type);
757 gfc_build_complex_type (tree scalar_type)
761 if (scalar_type == NULL)
763 if (scalar_type == float_type_node)
764 return complex_float_type_node;
765 if (scalar_type == double_type_node)
766 return complex_double_type_node;
767 if (scalar_type == long_double_type_node)
768 return complex_long_double_type_node;
770 new_type = make_node (COMPLEX_TYPE);
771 TREE_TYPE (new_type) = scalar_type;
772 layout_type (new_type);
777 gfc_build_logical_type (gfc_logical_info *info)
779 int bit_size = info->bit_size;
782 if (bit_size == BOOL_TYPE_SIZE)
785 return boolean_type_node;
788 new_type = make_unsigned_type (bit_size);
789 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
790 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
791 TYPE_PRECISION (new_type) = 1;
797 /* Create the backend type nodes. We map them to their
798 equivalent C type, at least for now. We also give
799 names to the types here, and we push them in the
800 global binding level context.*/
803 gfc_init_types (void)
809 unsigned HOST_WIDE_INT hi;
810 unsigned HOST_WIDE_INT lo;
812 /* Create and name the types. */
813 #define PUSH_TYPE(name, node) \
814 pushdecl (build_decl (input_location, \
815 TYPE_DECL, get_identifier (name), node))
817 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
819 type = gfc_build_int_type (&gfc_integer_kinds[index]);
820 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
821 if (TYPE_STRING_FLAG (type))
822 type = make_signed_type (gfc_integer_kinds[index].bit_size);
823 gfc_integer_types[index] = type;
824 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
825 gfc_integer_kinds[index].kind);
826 PUSH_TYPE (name_buf, type);
829 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
831 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
832 gfc_logical_types[index] = type;
833 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
834 gfc_logical_kinds[index].kind);
835 PUSH_TYPE (name_buf, type);
838 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
840 type = gfc_build_real_type (&gfc_real_kinds[index]);
841 gfc_real_types[index] = type;
842 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
843 gfc_real_kinds[index].kind);
844 PUSH_TYPE (name_buf, type);
846 if (gfc_real_kinds[index].c_float128)
847 float128_type_node = type;
849 type = gfc_build_complex_type (type);
850 gfc_complex_types[index] = type;
851 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
852 gfc_real_kinds[index].kind);
853 PUSH_TYPE (name_buf, type);
855 if (gfc_real_kinds[index].c_float128)
856 complex_float128_type_node = type;
859 for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
861 type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
862 type = build_qualified_type (type, TYPE_UNQUALIFIED);
863 snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
864 gfc_character_kinds[index].kind);
865 PUSH_TYPE (name_buf, type);
866 gfc_character_types[index] = type;
867 gfc_pcharacter_types[index] = build_pointer_type (type);
869 gfc_character1_type_node = gfc_character_types[0];
871 PUSH_TYPE ("byte", unsigned_char_type_node);
872 PUSH_TYPE ("void", void_type_node);
874 /* DBX debugging output gets upset if these aren't set. */
875 if (!TYPE_NAME (integer_type_node))
876 PUSH_TYPE ("c_integer", integer_type_node);
877 if (!TYPE_NAME (char_type_node))
878 PUSH_TYPE ("c_char", char_type_node);
882 pvoid_type_node = build_pointer_type (void_type_node);
883 prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
884 ppvoid_type_node = build_pointer_type (pvoid_type_node);
885 pchar_type_node = build_pointer_type (gfc_character1_type_node);
887 = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
889 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
890 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
891 since this function is called before gfc_init_constants. */
893 = build_range_type (gfc_array_index_type,
894 build_int_cst (gfc_array_index_type, 0),
897 /* The maximum array element size that can be handled is determined
898 by the number of bits available to store this field in the array
901 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
902 lo = ~ (unsigned HOST_WIDE_INT) 0;
903 if (n > HOST_BITS_PER_WIDE_INT)
904 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
906 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
907 gfc_max_array_element_size
908 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
910 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
911 boolean_true_node = build_int_cst (boolean_type_node, 1);
912 boolean_false_node = build_int_cst (boolean_type_node, 0);
914 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
915 gfc_charlen_int_kind = 4;
916 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
919 /* Get the type node for the given type and kind. */
922 gfc_get_int_type (int kind)
924 int index = gfc_validate_kind (BT_INTEGER, kind, true);
925 return index < 0 ? 0 : gfc_integer_types[index];
929 gfc_get_real_type (int kind)
931 int index = gfc_validate_kind (BT_REAL, kind, true);
932 return index < 0 ? 0 : gfc_real_types[index];
936 gfc_get_complex_type (int kind)
938 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
939 return index < 0 ? 0 : gfc_complex_types[index];
943 gfc_get_logical_type (int kind)
945 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
946 return index < 0 ? 0 : gfc_logical_types[index];
950 gfc_get_char_type (int kind)
952 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
953 return index < 0 ? 0 : gfc_character_types[index];
957 gfc_get_pchar_type (int kind)
959 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
960 return index < 0 ? 0 : gfc_pcharacter_types[index];
964 /* Create a character type with the given kind and length. */
967 gfc_get_character_type_len_for_eltype (tree eltype, tree len)
971 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
972 type = build_array_type (eltype, bounds);
973 TYPE_STRING_FLAG (type) = 1;
979 gfc_get_character_type_len (int kind, tree len)
981 gfc_validate_kind (BT_CHARACTER, kind, false);
982 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
986 /* Get a type node for a character kind. */
989 gfc_get_character_type (int kind, gfc_charlen * cl)
993 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
995 return gfc_get_character_type_len (kind, len);
998 /* Covert a basic type. This will be an array for character types. */
1001 gfc_typenode_for_spec (gfc_typespec * spec)
1011 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1012 has been resolved. This is done so we can convert C_PTR and
1013 C_FUNPTR to simple variables that get translated to (void *). */
1014 if (spec->f90_type == BT_VOID)
1017 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1018 basetype = ptr_type_node;
1020 basetype = pfunc_type_node;
1023 basetype = gfc_get_int_type (spec->kind);
1027 basetype = gfc_get_real_type (spec->kind);
1031 basetype = gfc_get_complex_type (spec->kind);
1035 basetype = gfc_get_logical_type (spec->kind);
1041 basetype = gfc_get_character_type (spec->kind, NULL);
1044 basetype = gfc_get_character_type (spec->kind, spec->u.cl);
1049 basetype = gfc_get_derived_type (spec->u.derived);
1051 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1052 type and kind to fit a (void *) and the basetype returned was a
1053 ptr_type_node. We need to pass up this new information to the
1054 symbol that was declared of type C_PTR or C_FUNPTR. */
1055 if (spec->u.derived->attr.is_iso_c)
1057 spec->type = spec->u.derived->ts.type;
1058 spec->kind = spec->u.derived->ts.kind;
1059 spec->f90_type = spec->u.derived->ts.f90_type;
1063 /* This is for the second arg to c_f_pointer and c_f_procpointer
1064 of the iso_c_binding module, to accept any ptr type. */
1065 basetype = ptr_type_node;
1066 if (spec->f90_type == BT_VOID)
1069 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1070 basetype = ptr_type_node;
1072 basetype = pfunc_type_node;
1081 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1084 gfc_conv_array_bound (gfc_expr * expr)
1086 /* If expr is an integer constant, return that. */
1087 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
1088 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
1090 /* Otherwise return NULL. */
1095 gfc_get_element_type (tree type)
1099 if (GFC_ARRAY_TYPE_P (type))
1101 if (TREE_CODE (type) == POINTER_TYPE)
1102 type = TREE_TYPE (type);
1103 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1104 element = TREE_TYPE (type);
1108 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
1109 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
1111 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
1112 element = TREE_TYPE (element);
1114 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
1115 element = TREE_TYPE (element);
1121 /* Build an array. This function is called from gfc_sym_type().
1122 Actually returns array descriptor type.
1124 Format of array descriptors is as follows:
1126 struct gfc_array_descriptor
1131 struct descriptor_dimension dimension[N_DIM];
1134 struct descriptor_dimension
1141 Translation code should use gfc_conv_descriptor_* rather than
1142 accessing the descriptor directly. Any changes to the array
1143 descriptor type will require changes in gfc_conv_descriptor_* and
1144 gfc_build_array_initializer.
1146 This is represented internally as a RECORD_TYPE. The index nodes
1147 are gfc_array_index_type and the data node is a pointer to the
1148 data. See below for the handling of character types.
1150 The dtype member is formatted as follows:
1151 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1152 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1153 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1155 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1156 this generated poor code for assumed/deferred size arrays. These
1157 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1158 of the GENERIC grammar. Also, there is no way to explicitly set
1159 the array stride, so all data must be packed(1). I've tried to
1160 mark all the functions which would require modification with a GCC
1163 The data component points to the first element in the array. The
1164 offset field is the position of the origin of the array (i.e. element
1165 (0, 0 ...)). This may be outside the bounds of the array.
1167 An element is accessed by
1168 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1169 This gives good performance as the computation does not involve the
1170 bounds of the array. For packed arrays, this is optimized further
1171 by substituting the known strides.
1173 This system has one problem: all array bounds must be within 2^31
1174 elements of the origin (2^63 on 64-bit machines). For example
1175 integer, dimension (80000:90000, 80000:90000, 2) :: array
1176 may not work properly on 32-bit machines because 80000*80000 >
1177 2^31, so the calculation for stride2 would overflow. This may
1178 still work, but I haven't checked, and it relies on the overflow
1179 doing the right thing.
1181 The way to fix this problem is to access elements as follows:
1182 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1183 Obviously this is much slower. I will make this a compile time
1184 option, something like -fsmall-array-offsets. Mixing code compiled
1185 with and without this switch will work.
1187 (1) This can be worked around by modifying the upper bound of the
1188 previous dimension. This requires extra fields in the descriptor
1189 (both real_ubound and fake_ubound). */
1192 /* Returns true if the array sym does not require a descriptor. */
1195 gfc_is_nodesc_array (gfc_symbol * sym)
1197 gcc_assert (sym->attr.dimension || sym->attr.codimension);
1199 /* We only want local arrays. */
1200 if (sym->attr.pointer || sym->attr.allocatable)
1203 /* We want a descriptor for associate-name arrays that do not have an
1204 explicitely known shape already. */
1205 if (sym->assoc && sym->as->type != AS_EXPLICIT)
1208 if (sym->attr.dummy)
1209 return sym->as->type != AS_ASSUMED_SHAPE;
1211 if (sym->attr.result || sym->attr.function)
1214 gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed);
1220 /* Create an array descriptor type. */
1223 gfc_build_array_type (tree type, gfc_array_spec * as,
1224 enum gfc_array_kind akind, bool restricted,
1227 tree lbound[GFC_MAX_DIMENSIONS];
1228 tree ubound[GFC_MAX_DIMENSIONS];
1231 for (n = 0; n < as->rank; n++)
1233 /* Create expressions for the known bounds of the array. */
1234 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1235 lbound[n] = gfc_index_one_node;
1237 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1238 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1241 for (n = as->rank; n < as->rank + as->corank; n++)
1243 if (as->lower[n] == NULL)
1244 lbound[n] = gfc_index_one_node;
1246 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1248 if (n < as->rank + as->corank - 1)
1249 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1252 if (as->type == AS_ASSUMED_SHAPE)
1253 akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
1254 : GFC_ARRAY_ASSUMED_SHAPE;
1255 return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
1256 ubound, 0, akind, restricted);
1259 /* Returns the struct descriptor_dimension type. */
1262 gfc_get_desc_dim_type (void)
1265 tree decl, *chain = NULL;
1267 if (gfc_desc_dim_type)
1268 return gfc_desc_dim_type;
1270 /* Build the type node. */
1271 type = make_node (RECORD_TYPE);
1273 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1274 TYPE_PACKED (type) = 1;
1276 /* Consists of the stride, lbound and ubound members. */
1277 decl = gfc_add_field_to_struct_1 (type,
1278 get_identifier ("stride"),
1279 gfc_array_index_type, &chain);
1280 TREE_NO_WARNING (decl) = 1;
1282 decl = gfc_add_field_to_struct_1 (type,
1283 get_identifier ("lbound"),
1284 gfc_array_index_type, &chain);
1285 TREE_NO_WARNING (decl) = 1;
1287 decl = gfc_add_field_to_struct_1 (type,
1288 get_identifier ("ubound"),
1289 gfc_array_index_type, &chain);
1290 TREE_NO_WARNING (decl) = 1;
1292 /* Finish off the type. */
1293 gfc_finish_type (type);
1294 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1296 gfc_desc_dim_type = type;
1301 /* Return the DTYPE for an array. This describes the type and type parameters
1303 /* TODO: Only call this when the value is actually used, and make all the
1304 unknown cases abort. */
1307 gfc_get_dtype (tree type)
1317 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1319 if (GFC_TYPE_ARRAY_DTYPE (type))
1320 return GFC_TYPE_ARRAY_DTYPE (type);
1322 rank = GFC_TYPE_ARRAY_RANK (type);
1323 etype = gfc_get_element_type (type);
1325 switch (TREE_CODE (etype))
1343 /* We will never have arrays of arrays. */
1353 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1354 /* We can strange array types for temporary arrays. */
1355 return gfc_index_zero_node;
1358 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1359 size = TYPE_SIZE_UNIT (etype);
1361 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1362 if (size && INTEGER_CST_P (size))
1364 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1365 internal_error ("Array element size too big");
1367 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1369 dtype = build_int_cst (gfc_array_index_type, i);
1371 if (size && !INTEGER_CST_P (size))
1373 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1374 tmp = fold_build2_loc (input_location, LSHIFT_EXPR,
1375 gfc_array_index_type,
1376 fold_convert (gfc_array_index_type, size), tmp);
1377 dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1380 /* If we don't know the size we leave it as zero. This should never happen
1381 for anything that is actually used. */
1382 /* TODO: Check this is actually true, particularly when repacking
1383 assumed size parameters. */
1385 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1390 /* Build an array type for use without a descriptor, packed according
1391 to the value of PACKED. */
1394 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
1408 mpz_init_set_ui (offset, 0);
1409 mpz_init_set_ui (stride, 1);
1412 /* We don't use build_array_type because this does not include include
1413 lang-specific information (i.e. the bounds of the array) when checking
1415 type = make_node (ARRAY_TYPE);
1417 GFC_ARRAY_TYPE_P (type) = 1;
1418 TYPE_LANG_SPECIFIC (type)
1419 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
1421 known_stride = (packed != PACKED_NO);
1423 for (n = 0; n < as->rank; n++)
1425 /* Fill in the stride and bound components of the type. */
1427 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1430 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1432 expr = as->lower[n];
1433 if (expr->expr_type == EXPR_CONSTANT)
1435 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1436 gfc_index_integer_kind);
1443 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1447 /* Calculate the offset. */
1448 mpz_mul (delta, stride, as->lower[n]->value.integer);
1449 mpz_sub (offset, offset, delta);
1454 expr = as->upper[n];
1455 if (expr && expr->expr_type == EXPR_CONSTANT)
1457 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1458 gfc_index_integer_kind);
1465 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1469 /* Calculate the stride. */
1470 mpz_sub (delta, as->upper[n]->value.integer,
1471 as->lower[n]->value.integer);
1472 mpz_add_ui (delta, delta, 1);
1473 mpz_mul (stride, stride, delta);
1476 /* Only the first stride is known for partial packed arrays. */
1477 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1480 for (n = as->rank; n < as->rank + as->corank; n++)
1482 expr = as->lower[n];
1483 if (expr->expr_type == EXPR_CONSTANT)
1484 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1485 gfc_index_integer_kind);
1488 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1490 expr = as->upper[n];
1491 if (expr && expr->expr_type == EXPR_CONSTANT)
1492 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1493 gfc_index_integer_kind);
1496 if (n < as->rank + as->corank - 1)
1497 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1502 GFC_TYPE_ARRAY_OFFSET (type) =
1503 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1506 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1510 GFC_TYPE_ARRAY_SIZE (type) =
1511 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1514 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1516 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1517 GFC_TYPE_ARRAY_CORANK (type) = as->corank;
1518 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1519 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1521 /* TODO: use main type if it is unbounded. */
1522 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1523 build_pointer_type (build_array_type (etype, range));
1525 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1526 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
1527 TYPE_QUAL_RESTRICT);
1531 mpz_sub_ui (stride, stride, 1);
1532 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1537 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1538 TYPE_DOMAIN (type) = range;
1540 build_pointer_type (etype);
1541 TREE_TYPE (type) = etype;
1549 /* Represent packed arrays as multi-dimensional if they have rank >
1550 1 and with proper bounds, instead of flat arrays. This makes for
1551 better debug info. */
1554 tree gtype = etype, rtype, type_decl;
1556 for (n = as->rank - 1; n >= 0; n--)
1558 rtype = build_range_type (gfc_array_index_type,
1559 GFC_TYPE_ARRAY_LBOUND (type, n),
1560 GFC_TYPE_ARRAY_UBOUND (type, n));
1561 gtype = build_array_type (gtype, rtype);
1563 TYPE_NAME (type) = type_decl = build_decl (input_location,
1564 TYPE_DECL, NULL, gtype);
1565 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1568 if (packed != PACKED_STATIC || !known_stride)
1570 /* For dummy arrays and automatic (heap allocated) arrays we
1571 want a pointer to the array. */
1572 type = build_pointer_type (type);
1574 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1575 GFC_ARRAY_TYPE_P (type) = 1;
1576 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1581 /* Return or create the base type for an array descriptor. */
1584 gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
1586 tree fat_type, decl, arraytype, *chain = NULL;
1587 char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
1588 int idx = 2 * (codimen + dimen - 1) + restricted;
1590 gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
1591 if (gfc_array_descriptor_base[idx])
1592 return gfc_array_descriptor_base[idx];
1594 /* Build the type node. */
1595 fat_type = make_node (RECORD_TYPE);
1597 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
1598 TYPE_NAME (fat_type) = get_identifier (name);
1599 TYPE_NAMELESS (fat_type) = 1;
1601 /* Add the data member as the first element of the descriptor. */
1602 decl = gfc_add_field_to_struct_1 (fat_type,
1603 get_identifier ("data"),
1606 : ptr_type_node), &chain);
1608 /* Add the base component. */
1609 decl = gfc_add_field_to_struct_1 (fat_type,
1610 get_identifier ("offset"),
1611 gfc_array_index_type, &chain);
1612 TREE_NO_WARNING (decl) = 1;
1614 /* Add the dtype component. */
1615 decl = gfc_add_field_to_struct_1 (fat_type,
1616 get_identifier ("dtype"),
1617 gfc_array_index_type, &chain);
1618 TREE_NO_WARNING (decl) = 1;
1620 /* Build the array type for the stride and bound components. */
1622 build_array_type (gfc_get_desc_dim_type (),
1623 build_range_type (gfc_array_index_type,
1624 gfc_index_zero_node,
1625 gfc_rank_cst[codimen + dimen - 1]));
1627 decl = gfc_add_field_to_struct_1 (fat_type,
1628 get_identifier ("dim"),
1630 TREE_NO_WARNING (decl) = 1;
1632 /* Finish off the type. */
1633 gfc_finish_type (fat_type);
1634 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1636 gfc_array_descriptor_base[idx] = fat_type;
1640 /* Build an array (descriptor) type with given bounds. */
1643 gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
1644 tree * ubound, int packed,
1645 enum gfc_array_kind akind, bool restricted)
1647 char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
1648 tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
1649 const char *type_name;
1652 base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
1653 fat_type = build_distinct_type_copy (base_type);
1654 /* Make sure that nontarget and target array type have the same canonical
1655 type (and same stub decl for debug info). */
1656 base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
1657 TYPE_CANONICAL (fat_type) = base_type;
1658 TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
1660 tmp = TYPE_NAME (etype);
1661 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1662 tmp = DECL_NAME (tmp);
1664 type_name = IDENTIFIER_POINTER (tmp);
1666 type_name = "unknown";
1667 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
1668 GFC_MAX_SYMBOL_LEN, type_name);
1669 TYPE_NAME (fat_type) = get_identifier (name);
1670 TYPE_NAMELESS (fat_type) = 1;
1672 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1673 TYPE_LANG_SPECIFIC (fat_type)
1674 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
1676 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1677 GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
1678 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1679 GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1681 /* Build an array descriptor record type. */
1683 stride = gfc_index_one_node;
1686 for (n = 0; n < dimen + codimen; n++)
1689 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1696 if (lower != NULL_TREE)
1698 if (INTEGER_CST_P (lower))
1699 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1704 if (codimen && n == dimen + codimen - 1)
1708 if (upper != NULL_TREE)
1710 if (INTEGER_CST_P (upper))
1711 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1719 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1721 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1722 gfc_array_index_type, upper, lower);
1723 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1724 gfc_array_index_type, tmp,
1725 gfc_index_one_node);
1726 stride = fold_build2_loc (input_location, MULT_EXPR,
1727 gfc_array_index_type, tmp, stride);
1728 /* Check the folding worked. */
1729 gcc_assert (INTEGER_CST_P (stride));
1734 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1736 /* TODO: known offsets for descriptors. */
1737 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1739 /* We define data as an array with the correct size if possible.
1740 Much better than doing pointer arithmetic. */
1742 rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1743 int_const_binop (MINUS_EXPR, stride,
1746 rtype = gfc_array_range_type;
1747 arraytype = build_array_type (etype, rtype);
1748 arraytype = build_pointer_type (arraytype);
1750 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
1751 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1753 /* This will generate the base declarations we need to emit debug
1754 information for this type. FIXME: there must be a better way to
1755 avoid divergence between compilations with and without debug
1758 struct array_descr_info info;
1759 gfc_get_array_descr_info (fat_type, &info);
1760 gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
1766 /* Build a pointer type. This function is called from gfc_sym_type(). */
1769 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1771 /* Array pointer types aren't actually pointers. */
1772 if (sym->attr.dimension)
1775 return build_pointer_type (type);
1778 static tree gfc_nonrestricted_type (tree t);
1779 /* Given two record or union type nodes TO and FROM, ensure
1780 that all fields in FROM have a corresponding field in TO,
1781 their type being nonrestrict variants. This accepts a TO
1782 node that already has a prefix of the fields in FROM. */
1784 mirror_fields (tree to, tree from)
1789 /* Forward to the end of TOs fields. */
1790 fto = TYPE_FIELDS (to);
1791 ffrom = TYPE_FIELDS (from);
1792 chain = &TYPE_FIELDS (to);
1795 gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
1796 chain = &DECL_CHAIN (fto);
1797 fto = DECL_CHAIN (fto);
1798 ffrom = DECL_CHAIN (ffrom);
1801 /* Now add all fields remaining in FROM (starting with ffrom). */
1802 for (; ffrom; ffrom = DECL_CHAIN (ffrom))
1804 tree newfield = copy_node (ffrom);
1805 DECL_CONTEXT (newfield) = to;
1806 /* The store to DECL_CHAIN might seem redundant with the
1807 stores to *chain, but not clearing it here would mean
1808 leaving a chain into the old fields. If ever
1809 our called functions would look at them confusion
1811 DECL_CHAIN (newfield) = NULL_TREE;
1813 chain = &DECL_CHAIN (newfield);
1815 if (TREE_CODE (ffrom) == FIELD_DECL)
1817 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
1818 TREE_TYPE (newfield) = elemtype;
1824 /* Given a type T, returns a different type of the same structure,
1825 except that all types it refers to (recursively) are always
1826 non-restrict qualified types. */
1828 gfc_nonrestricted_type (tree t)
1832 /* If the type isn't layed out yet, don't copy it. If something
1833 needs it for real it should wait until the type got finished. */
1837 if (!TYPE_LANG_SPECIFIC (t))
1838 TYPE_LANG_SPECIFIC (t)
1839 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
1840 /* If we're dealing with this very node already further up
1841 the call chain (recursion via pointers and struct members)
1842 we haven't yet determined if we really need a new type node.
1843 Assume we don't, return T itself. */
1844 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
1847 /* If we have calculated this all already, just return it. */
1848 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
1849 return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
1851 /* Mark this type. */
1852 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
1854 switch (TREE_CODE (t))
1860 case REFERENCE_TYPE:
1862 tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
1863 if (totype == TREE_TYPE (t))
1865 else if (TREE_CODE (t) == POINTER_TYPE)
1866 ret = build_pointer_type (totype);
1868 ret = build_reference_type (totype);
1869 ret = build_qualified_type (ret,
1870 TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
1876 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
1877 if (elemtype == TREE_TYPE (t))
1881 ret = build_variant_type_copy (t);
1882 TREE_TYPE (ret) = elemtype;
1883 if (TYPE_LANG_SPECIFIC (t)
1884 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
1886 tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
1887 dataptr_type = gfc_nonrestricted_type (dataptr_type);
1888 if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
1890 TYPE_LANG_SPECIFIC (ret)
1891 = ggc_alloc_cleared_lang_type (sizeof (struct
1893 *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
1894 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
1903 case QUAL_UNION_TYPE:
1906 /* First determine if we need a new type at all.
1907 Careful, the two calls to gfc_nonrestricted_type per field
1908 might return different values. That happens exactly when
1909 one of the fields reaches back to this very record type
1910 (via pointers). The first calls will assume that we don't
1911 need to copy T (see the error_mark_node marking). If there
1912 are any reasons for copying T apart from having to copy T,
1913 we'll indeed copy it, and the second calls to
1914 gfc_nonrestricted_type will use that new node if they
1916 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
1917 if (TREE_CODE (field) == FIELD_DECL)
1919 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
1920 if (elemtype != TREE_TYPE (field))
1925 ret = build_variant_type_copy (t);
1926 TYPE_FIELDS (ret) = NULL_TREE;
1928 /* Here we make sure that as soon as we know we have to copy
1929 T, that also fields reaching back to us will use the new
1930 copy. It's okay if that copy still contains the old fields,
1931 we won't look at them. */
1932 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
1933 mirror_fields (ret, t);
1938 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
1943 /* Return the type for a symbol. Special handling is required for character
1944 types to get the correct level of indirection.
1945 For functions return the return type.
1946 For subroutines return void_type_node.
1947 Calling this multiple times for the same symbol should be avoided,
1948 especially for character and array types. */
1951 gfc_sym_type (gfc_symbol * sym)
1957 /* Procedure Pointers inside COMMON blocks. */
1958 if (sym->attr.proc_pointer && sym->attr.in_common)
1960 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
1961 sym->attr.proc_pointer = 0;
1962 type = build_pointer_type (gfc_get_function_type (sym));
1963 sym->attr.proc_pointer = 1;
1967 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1968 return void_type_node;
1970 /* In the case of a function the fake result variable may have a
1971 type different from the function type, so don't return early in
1973 if (sym->backend_decl && !sym->attr.function)
1974 return TREE_TYPE (sym->backend_decl);
1976 if (sym->ts.type == BT_CHARACTER
1977 && ((sym->attr.function && sym->attr.is_bind_c)
1978 || (sym->attr.result
1979 && sym->ns->proc_name
1980 && sym->ns->proc_name->attr.is_bind_c)))
1981 type = gfc_character1_type_node;
1983 type = gfc_typenode_for_spec (&sym->ts);
1985 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1990 restricted = !sym->attr.target && !sym->attr.pointer
1991 && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
1993 type = gfc_nonrestricted_type (type);
1995 if (sym->attr.dimension || sym->attr.codimension)
1997 if (gfc_is_nodesc_array (sym))
1999 /* If this is a character argument of unknown length, just use the
2001 if (sym->ts.type != BT_CHARACTER
2002 || !(sym->attr.dummy || sym->attr.function)
2003 || sym->ts.u.cl->backend_decl)
2005 type = gfc_get_nodesc_array_type (type, sym->as,
2012 if (sym->attr.cray_pointee)
2013 GFC_POINTER_TYPE_P (type) = 1;
2017 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
2018 if (sym->attr.pointer)
2019 akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2020 : GFC_ARRAY_POINTER;
2021 else if (sym->attr.allocatable)
2022 akind = GFC_ARRAY_ALLOCATABLE;
2023 type = gfc_build_array_type (type, sym->as, akind, restricted,
2024 sym->attr.contiguous);
2029 if (sym->attr.allocatable || sym->attr.pointer
2030 || gfc_is_associate_pointer (sym))
2031 type = gfc_build_pointer_type (sym, type);
2032 if (sym->attr.pointer || sym->attr.cray_pointee)
2033 GFC_POINTER_TYPE_P (type) = 1;
2036 /* We currently pass all parameters by reference.
2037 See f95_get_function_decl. For dummy function parameters return the
2041 /* We must use pointer types for potentially absent variables. The
2042 optimizers assume a reference type argument is never NULL. */
2043 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
2044 type = build_pointer_type (type);
2047 type = build_reference_type (type);
2049 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
2056 /* Layout and output debug info for a record type. */
2059 gfc_finish_type (tree type)
2063 decl = build_decl (input_location,
2064 TYPE_DECL, NULL_TREE, type);
2065 TYPE_STUB_DECL (type) = decl;
2067 rest_of_type_compilation (type, 1);
2068 rest_of_decl_compilation (decl, 1, 0);
2071 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2072 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2073 to the end of the field list pointed to by *CHAIN.
2075 Returns a pointer to the new field. */
2078 gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
2080 tree decl = build_decl (input_location, FIELD_DECL, name, type);
2082 DECL_CONTEXT (decl) = context;
2083 DECL_CHAIN (decl) = NULL_TREE;
2084 if (TYPE_FIELDS (context) == NULL_TREE)
2085 TYPE_FIELDS (context) = decl;
2090 *chain = &DECL_CHAIN (decl);
2096 /* Like `gfc_add_field_to_struct_1', but adds alignment
2100 gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
2102 tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
2104 DECL_INITIAL (decl) = 0;
2105 DECL_ALIGN (decl) = 0;
2106 DECL_USER_ALIGN (decl) = 0;
2112 /* Copy the backend_decl and component backend_decls if
2113 the two derived type symbols are "equal", as described
2114 in 4.4.2 and resolved by gfc_compare_derived_types. */
2117 gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
2120 gfc_component *to_cm;
2121 gfc_component *from_cm;
2123 if (from->backend_decl == NULL
2124 || !gfc_compare_derived_types (from, to))
2127 to->backend_decl = from->backend_decl;
2129 to_cm = to->components;
2130 from_cm = from->components;
2132 /* Copy the component declarations. If a component is itself
2133 a derived type, we need a copy of its component declarations.
2134 This is done by recursing into gfc_get_derived_type and
2135 ensures that the component's component declarations have
2136 been built. If it is a character, we need the character
2138 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
2140 to_cm->backend_decl = from_cm->backend_decl;
2141 if (from_cm->ts.type == BT_DERIVED
2142 && (!from_cm->attr.pointer || from_gsym))
2143 gfc_get_derived_type (to_cm->ts.u.derived);
2144 else if (from_cm->ts.type == BT_CLASS
2145 && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
2146 gfc_get_derived_type (to_cm->ts.u.derived);
2147 else if (from_cm->ts.type == BT_CHARACTER)
2148 to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
2155 /* Build a tree node for a procedure pointer component. */
2158 gfc_get_ppc_type (gfc_component* c)
2162 /* Explicit interface. */
2163 if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
2164 return build_pointer_type (gfc_get_function_type (c->ts.interface));
2166 /* Implicit interface (only return value may be known). */
2167 if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
2168 t = gfc_typenode_for_spec (&c->ts);
2172 return build_pointer_type (build_function_type_list (t, NULL_TREE));
2176 /* Build a tree node for a derived type. If there are equal
2177 derived types, with different local names, these are built
2178 at the same time. If an equal derived type has been built
2179 in a parent namespace, this is used. */
2182 gfc_get_derived_type (gfc_symbol * derived)
2184 tree typenode = NULL, field = NULL, field_type = NULL;
2185 tree canonical = NULL_TREE;
2187 bool got_canonical = false;
2192 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
2194 /* See if it's one of the iso_c_binding derived types. */
2195 if (derived->attr.is_iso_c == 1)
2197 if (derived->backend_decl)
2198 return derived->backend_decl;
2200 if (derived->intmod_sym_id == ISOCBINDING_PTR)
2201 derived->backend_decl = ptr_type_node;
2203 derived->backend_decl = pfunc_type_node;
2205 derived->ts.kind = gfc_index_integer_kind;
2206 derived->ts.type = BT_INTEGER;
2207 /* Set the f90_type to BT_VOID as a way to recognize something of type
2208 BT_INTEGER that needs to fit a void * for the purpose of the
2209 iso_c_binding derived types. */
2210 derived->ts.f90_type = BT_VOID;
2212 return derived->backend_decl;
2215 /* If use associated, use the module type for this one. */
2216 if (gfc_option.flag_whole_file
2217 && derived->backend_decl == NULL
2218 && derived->attr.use_assoc
2220 && gfc_get_module_backend_decl (derived))
2221 goto copy_derived_types;
2223 /* If a whole file compilation, the derived types from an earlier
2224 namespace can be used as the canonical type. */
2225 if (gfc_option.flag_whole_file
2226 && derived->backend_decl == NULL
2227 && !derived->attr.use_assoc
2228 && gfc_global_ns_list)
2230 for (ns = gfc_global_ns_list;
2231 ns->translated && !got_canonical;
2234 dt = ns->derived_types;
2235 for (; dt && !canonical; dt = dt->next)
2237 gfc_copy_dt_decls_ifequal (dt->derived, derived, true);
2238 if (derived->backend_decl)
2239 got_canonical = true;
2244 /* Store up the canonical type to be added to this one. */
2247 if (TYPE_CANONICAL (derived->backend_decl))
2248 canonical = TYPE_CANONICAL (derived->backend_decl);
2250 canonical = derived->backend_decl;
2252 derived->backend_decl = NULL_TREE;
2255 /* derived->backend_decl != 0 means we saw it before, but its
2256 components' backend_decl may have not been built. */
2257 if (derived->backend_decl)
2259 /* Its components' backend_decl have been built or we are
2260 seeing recursion through the formal arglist of a procedure
2261 pointer component. */
2262 if (TYPE_FIELDS (derived->backend_decl)
2263 || derived->attr.proc_pointer_comp)
2264 return derived->backend_decl;
2266 typenode = derived->backend_decl;
2270 /* We see this derived type first time, so build the type node. */
2271 typenode = make_node (RECORD_TYPE);
2272 TYPE_NAME (typenode) = get_identifier (derived->name);
2273 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2274 derived->backend_decl = typenode;
2277 /* Go through the derived type components, building them as
2278 necessary. The reason for doing this now is that it is
2279 possible to recurse back to this derived type through a
2280 pointer component (PR24092). If this happens, the fields
2281 will be built and so we can return the type. */
2282 for (c = derived->components; c; c = c->next)
2284 if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
2287 if ((!c->attr.pointer && !c->attr.proc_pointer)
2288 || c->ts.u.derived->backend_decl == NULL)
2289 c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
2291 if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
2293 /* Need to copy the modified ts from the derived type. The
2294 typespec was modified because C_PTR/C_FUNPTR are translated
2295 into (void *) from derived types. */
2296 c->ts.type = c->ts.u.derived->ts.type;
2297 c->ts.kind = c->ts.u.derived->ts.kind;
2298 c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2301 c->initializer->ts.type = c->ts.type;
2302 c->initializer->ts.kind = c->ts.kind;
2303 c->initializer->ts.f90_type = c->ts.f90_type;
2304 c->initializer->expr_type = EXPR_NULL;
2309 if (TYPE_FIELDS (derived->backend_decl))
2310 return derived->backend_decl;
2312 /* Build the type member list. Install the newly created RECORD_TYPE
2313 node as DECL_CONTEXT of each FIELD_DECL. */
2314 for (c = derived->components; c; c = c->next)
2316 if (c->attr.proc_pointer)
2317 field_type = gfc_get_ppc_type (c);
2318 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2319 field_type = c->ts.u.derived->backend_decl;
2322 if (c->ts.type == BT_CHARACTER)
2324 /* Evaluate the string length. */
2325 gfc_conv_const_charlen (c->ts.u.cl);
2326 gcc_assert (c->ts.u.cl->backend_decl);
2329 field_type = gfc_typenode_for_spec (&c->ts);
2332 /* This returns an array descriptor type. Initialization may be
2334 if (c->attr.dimension && !c->attr.proc_pointer)
2336 if (c->attr.pointer || c->attr.allocatable)
2338 enum gfc_array_kind akind;
2339 if (c->attr.pointer)
2340 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2341 : GFC_ARRAY_POINTER;
2343 akind = GFC_ARRAY_ALLOCATABLE;
2344 /* Pointers to arrays aren't actually pointer types. The
2345 descriptors are separate, but the data is common. */
2346 field_type = gfc_build_array_type (field_type, c->as, akind,
2348 && !c->attr.pointer,
2349 c->attr.contiguous);
2352 field_type = gfc_get_nodesc_array_type (field_type, c->as,
2356 else if ((c->attr.pointer || c->attr.allocatable)
2357 && !c->attr.proc_pointer)
2358 field_type = build_pointer_type (field_type);
2360 /* vtype fields can point to different types to the base type. */
2361 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.vtype)
2362 field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
2365 field = gfc_add_field_to_struct (typenode,
2366 get_identifier (c->name),
2367 field_type, &chain);
2369 gfc_set_decl_location (field, &c->loc);
2370 else if (derived->declared_at.lb)
2371 gfc_set_decl_location (field, &derived->declared_at);
2373 DECL_PACKED (field) |= TYPE_PACKED (typenode);
2376 if (!c->backend_decl)
2377 c->backend_decl = field;
2380 /* Now lay out the derived type, including the fields. */
2382 TYPE_CANONICAL (typenode) = canonical;
2384 gfc_finish_type (typenode);
2385 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2386 if (derived->module && derived->ns->proc_name
2387 && derived->ns->proc_name->attr.flavor == FL_MODULE)
2389 if (derived->ns->proc_name->backend_decl
2390 && TREE_CODE (derived->ns->proc_name->backend_decl)
2393 TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2394 DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2395 = derived->ns->proc_name->backend_decl;
2399 derived->backend_decl = typenode;
2403 for (dt = gfc_derived_types; dt; dt = dt->next)
2404 gfc_copy_dt_decls_ifequal (derived, dt->derived, false);
2406 return derived->backend_decl;
2411 gfc_return_by_reference (gfc_symbol * sym)
2413 if (!sym->attr.function)
2416 if (sym->attr.dimension)
2419 if (sym->ts.type == BT_CHARACTER
2420 && !sym->attr.is_bind_c
2421 && (!sym->attr.result
2422 || !sym->ns->proc_name
2423 || !sym->ns->proc_name->attr.is_bind_c))
2426 /* Possibly return complex numbers by reference for g77 compatibility.
2427 We don't do this for calls to intrinsics (as the library uses the
2428 -fno-f2c calling convention), nor for calls to functions which always
2429 require an explicit interface, as no compatibility problems can
2431 if (gfc_option.flag_f2c
2432 && sym->ts.type == BT_COMPLEX
2433 && !sym->attr.intrinsic && !sym->attr.always_explicit)
2440 gfc_get_mixed_entry_union (gfc_namespace *ns)
2444 char name[GFC_MAX_SYMBOL_LEN + 1];
2445 gfc_entry_list *el, *el2;
2447 gcc_assert (ns->proc_name->attr.mixed_entry_master);
2448 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2450 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
2452 /* Build the type node. */
2453 type = make_node (UNION_TYPE);
2455 TYPE_NAME (type) = get_identifier (name);
2457 for (el = ns->entries; el; el = el->next)
2459 /* Search for duplicates. */
2460 for (el2 = ns->entries; el2 != el; el2 = el2->next)
2461 if (el2->sym->result == el->sym->result)
2465 gfc_add_field_to_struct_1 (type,
2466 get_identifier (el->sym->result->name),
2467 gfc_sym_type (el->sym->result), &chain);
2470 /* Finish off the type. */
2471 gfc_finish_type (type);
2472 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
2476 /* Create a "fn spec" based on the formal arguments;
2477 cf. create_function_arglist. */
2480 create_fn_spec (gfc_symbol *sym, tree fntype)
2484 gfc_formal_arglist *f;
2487 memset (&spec, 0, sizeof (spec));
2491 if (sym->attr.entry_master)
2492 spec[spec_len++] = 'R';
2493 if (gfc_return_by_reference (sym))
2495 gfc_symbol *result = sym->result ? sym->result : sym;
2497 if (result->attr.pointer || sym->attr.proc_pointer)
2498 spec[spec_len++] = '.';
2500 spec[spec_len++] = 'w';
2501 if (sym->ts.type == BT_CHARACTER)
2502 spec[spec_len++] = 'R';
2505 for (f = sym->formal; f; f = f->next)
2506 if (spec_len < sizeof (spec))
2508 if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
2509 || f->sym->attr.external || f->sym->attr.cray_pointer
2510 || (f->sym->ts.type == BT_DERIVED
2511 && (f->sym->ts.u.derived->attr.proc_pointer_comp
2512 || f->sym->ts.u.derived->attr.pointer_comp))
2513 || (f->sym->ts.type == BT_CLASS
2514 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
2515 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)))
2516 spec[spec_len++] = '.';
2517 else if (f->sym->attr.intent == INTENT_IN)
2518 spec[spec_len++] = 'r';
2520 spec[spec_len++] = 'w';
2523 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
2524 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
2525 return build_type_attribute_variant (fntype, tmp);
2530 gfc_get_function_type (gfc_symbol * sym)
2533 VEC(tree,gc) *typelist;
2534 gfc_formal_arglist *f;
2536 int alternate_return;
2537 bool is_varargs = true;
2539 /* Make sure this symbol is a function, a subroutine or the main
2541 gcc_assert (sym->attr.flavor == FL_PROCEDURE
2542 || sym->attr.flavor == FL_PROGRAM);
2544 if (sym->backend_decl)
2545 return TREE_TYPE (sym->backend_decl);
2547 alternate_return = 0;
2550 if (sym->attr.entry_master)
2551 /* Additional parameter for selecting an entry point. */
2552 VEC_safe_push (tree, gc, typelist, gfc_array_index_type);
2559 if (arg->ts.type == BT_CHARACTER)
2560 gfc_conv_const_charlen (arg->ts.u.cl);
2562 /* Some functions we use an extra parameter for the return value. */
2563 if (gfc_return_by_reference (sym))
2565 type = gfc_sym_type (arg);
2566 if (arg->ts.type == BT_COMPLEX
2567 || arg->attr.dimension
2568 || arg->ts.type == BT_CHARACTER)
2569 type = build_reference_type (type);
2571 VEC_safe_push (tree, gc, typelist, type);
2572 if (arg->ts.type == BT_CHARACTER)
2574 if (!arg->ts.deferred)
2575 /* Transfer by value. */
2576 VEC_safe_push (tree, gc, typelist, gfc_charlen_type_node);
2578 /* Deferred character lengths are transferred by reference
2579 so that the value can be returned. */
2580 VEC_safe_push (tree, gc, typelist,
2581 build_pointer_type (gfc_charlen_type_node));
2585 /* Build the argument types for the function. */
2586 for (f = sym->formal; f; f = f->next)
2591 /* Evaluate constant character lengths here so that they can be
2592 included in the type. */
2593 if (arg->ts.type == BT_CHARACTER)
2594 gfc_conv_const_charlen (arg->ts.u.cl);
2596 if (arg->attr.flavor == FL_PROCEDURE)
2598 type = gfc_get_function_type (arg);
2599 type = build_pointer_type (type);
2602 type = gfc_sym_type (arg);
2604 /* Parameter Passing Convention
2606 We currently pass all parameters by reference.
2607 Parameters with INTENT(IN) could be passed by value.
2608 The problem arises if a function is called via an implicit
2609 prototype. In this situation the INTENT is not known.
2610 For this reason all parameters to global functions must be
2611 passed by reference. Passing by value would potentially
2612 generate bad code. Worse there would be no way of telling that
2613 this code was bad, except that it would give incorrect results.
2615 Contained procedures could pass by value as these are never
2616 used without an explicit interface, and cannot be passed as
2617 actual parameters for a dummy procedure. */
2619 VEC_safe_push (tree, gc, typelist, type);
2623 if (sym->attr.subroutine)
2624 alternate_return = 1;
2628 /* Add hidden string length parameters. */
2629 for (f = sym->formal; f; f = f->next)
2632 if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2634 if (!arg->ts.deferred)
2635 /* Transfer by value. */
2636 type = gfc_charlen_type_node;
2638 /* Deferred character lengths are transferred by reference
2639 so that the value can be returned. */
2640 type = build_pointer_type (gfc_charlen_type_node);
2642 VEC_safe_push (tree, gc, typelist, type);
2646 if (!VEC_empty (tree, typelist)
2647 || sym->attr.is_main_program
2648 || sym->attr.if_source != IFSRC_UNKNOWN)
2651 if (alternate_return)
2652 type = integer_type_node;
2653 else if (!sym->attr.function || gfc_return_by_reference (sym))
2654 type = void_type_node;
2655 else if (sym->attr.mixed_entry_master)
2656 type = gfc_get_mixed_entry_union (sym->ns);
2657 else if (gfc_option.flag_f2c
2658 && sym->ts.type == BT_REAL
2659 && sym->ts.kind == gfc_default_real_kind
2660 && !sym->attr.always_explicit)
2662 /* Special case: f2c calling conventions require that (scalar)
2663 default REAL functions return the C type double instead. f2c
2664 compatibility is only an issue with functions that don't
2665 require an explicit interface, as only these could be
2666 implemented in Fortran 77. */
2667 sym->ts.kind = gfc_default_double_kind;
2668 type = gfc_typenode_for_spec (&sym->ts);
2669 sym->ts.kind = gfc_default_real_kind;
2671 else if (sym->result && sym->result->attr.proc_pointer)
2672 /* Procedure pointer return values. */
2674 if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
2676 /* Unset proc_pointer as gfc_get_function_type
2677 is called recursively. */
2678 sym->result->attr.proc_pointer = 0;
2679 type = build_pointer_type (gfc_get_function_type (sym->result));
2680 sym->result->attr.proc_pointer = 1;
2683 type = gfc_sym_type (sym->result);
2686 type = gfc_sym_type (sym);
2689 type = build_varargs_function_type_vec (type, typelist);
2691 type = build_function_type_vec (type, typelist);
2692 type = create_fn_spec (sym, type);
2697 /* Language hooks for middle-end access to type nodes. */
2699 /* Return an integer type with BITS bits of precision,
2700 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2703 gfc_type_for_size (unsigned bits, int unsignedp)
2708 for (i = 0; i <= MAX_INT_KINDS; ++i)
2710 tree type = gfc_integer_types[i];
2711 if (type && bits == TYPE_PRECISION (type))
2715 /* Handle TImode as a special case because it is used by some backends
2716 (e.g. ARM) even though it is not available for normal use. */
2717 #if HOST_BITS_PER_WIDE_INT >= 64
2718 if (bits == TYPE_PRECISION (intTI_type_node))
2719 return intTI_type_node;
2724 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2725 return unsigned_intQI_type_node;
2726 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2727 return unsigned_intHI_type_node;
2728 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2729 return unsigned_intSI_type_node;
2730 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2731 return unsigned_intDI_type_node;
2732 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2733 return unsigned_intTI_type_node;
2739 /* Return a data type that has machine mode MODE. If the mode is an
2740 integer, then UNSIGNEDP selects between signed and unsigned types. */
2743 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2748 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2749 base = gfc_real_types;
2750 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2751 base = gfc_complex_types;
2752 else if (SCALAR_INT_MODE_P (mode))
2753 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2754 else if (VECTOR_MODE_P (mode))
2756 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2757 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2758 if (inner_type != NULL_TREE)
2759 return build_vector_type_for_mode (inner_type, mode);
2765 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2767 tree type = base[i];
2768 if (type && mode == TYPE_MODE (type))
2775 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2779 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
2782 bool indirect = false;
2783 tree etype, ptype, field, t, base_decl;
2784 tree data_off, dim_off, dim_size, elem_size;
2785 tree lower_suboff, upper_suboff, stride_suboff;
2787 if (! GFC_DESCRIPTOR_TYPE_P (type))
2789 if (! POINTER_TYPE_P (type))
2791 type = TREE_TYPE (type);
2792 if (! GFC_DESCRIPTOR_TYPE_P (type))
2797 rank = GFC_TYPE_ARRAY_RANK (type);
2798 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
2801 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2802 gcc_assert (POINTER_TYPE_P (etype));
2803 etype = TREE_TYPE (etype);
2804 gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
2805 etype = TREE_TYPE (etype);
2806 /* Can't handle variable sized elements yet. */
2807 if (int_size_in_bytes (etype) <= 0)
2809 /* Nor non-constant lower bounds in assumed shape arrays. */
2810 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
2811 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
2813 for (dim = 0; dim < rank; dim++)
2814 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
2815 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
2819 memset (info, '\0', sizeof (*info));
2820 info->ndimensions = rank;
2821 info->element_type = etype;
2822 ptype = build_pointer_type (gfc_array_index_type);
2823 base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
2826 base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
2827 indirect ? build_pointer_type (ptype) : ptype);
2828 GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
2830 info->base_decl = base_decl;
2832 base_decl = build1 (INDIRECT_REF, ptype, base_decl);
2834 if (GFC_TYPE_ARRAY_SPAN (type))
2835 elem_size = GFC_TYPE_ARRAY_SPAN (type);
2837 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
2838 field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
2839 data_off = byte_position (field);
2840 field = DECL_CHAIN (field);
2841 field = DECL_CHAIN (field);
2842 field = DECL_CHAIN (field);
2843 dim_off = byte_position (field);
2844 dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
2845 field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
2846 stride_suboff = byte_position (field);
2847 field = DECL_CHAIN (field);
2848 lower_suboff = byte_position (field);
2849 field = DECL_CHAIN (field);
2850 upper_suboff = byte_position (field);
2853 if (!integer_zerop (data_off))
2854 t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
2855 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
2856 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
2857 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
2858 info->allocated = build2 (NE_EXPR, boolean_type_node,
2859 info->data_location, null_pointer_node);
2860 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
2861 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
2862 info->associated = build2 (NE_EXPR, boolean_type_node,
2863 info->data_location, null_pointer_node);
2865 for (dim = 0; dim < rank; dim++)
2867 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2868 size_binop (PLUS_EXPR, dim_off, lower_suboff));
2869 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2870 info->dimen[dim].lower_bound = t;
2871 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2872 size_binop (PLUS_EXPR, dim_off, upper_suboff));
2873 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2874 info->dimen[dim].upper_bound = t;
2875 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
2876 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
2878 /* Assumed shape arrays have known lower bounds. */
2879 info->dimen[dim].upper_bound
2880 = build2 (MINUS_EXPR, gfc_array_index_type,
2881 info->dimen[dim].upper_bound,
2882 info->dimen[dim].lower_bound);
2883 info->dimen[dim].lower_bound
2884 = fold_convert (gfc_array_index_type,
2885 GFC_TYPE_ARRAY_LBOUND (type, dim));
2886 info->dimen[dim].upper_bound
2887 = build2 (PLUS_EXPR, gfc_array_index_type,
2888 info->dimen[dim].lower_bound,
2889 info->dimen[dim].upper_bound);
2891 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2892 size_binop (PLUS_EXPR, dim_off, stride_suboff));
2893 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2894 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
2895 info->dimen[dim].stride = t;
2896 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
2902 #include "gt-fortran-trans-types.h"