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;
121 int gfc_atomic_int_kind;
122 int gfc_atomic_logical_kind;
124 /* The kind size used for record offsets. If the target system supports
125 kind=8, this will be set to 8, otherwise it is set to 4. */
128 /* The integer kind used to store character lengths. */
129 int gfc_charlen_int_kind;
131 /* The size of the numeric storage unit and character storage unit. */
132 int gfc_numeric_storage_size;
133 int gfc_character_storage_size;
137 gfc_check_any_c_kind (gfc_typespec *ts)
141 for (i = 0; i < ISOCBINDING_NUMBER; i++)
143 /* Check for any C interoperable kind for the given type/kind in ts.
144 This can be used after verify_c_interop to make sure that the
145 Fortran kind being used exists in at least some form for C. */
146 if (c_interop_kinds_table[i].f90_type == ts->type &&
147 c_interop_kinds_table[i].value == ts->kind)
156 get_real_kind_from_node (tree type)
160 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
161 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
162 return gfc_real_kinds[i].kind;
168 get_int_kind_from_node (tree type)
175 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
176 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
177 return gfc_integer_kinds[i].kind;
182 /* Return a typenode for the "standard" C type with a given name. */
184 get_typenode_from_name (const char *name)
186 if (name == NULL || *name == '\0')
189 if (strcmp (name, "char") == 0)
190 return char_type_node;
191 if (strcmp (name, "unsigned char") == 0)
192 return unsigned_char_type_node;
193 if (strcmp (name, "signed char") == 0)
194 return signed_char_type_node;
196 if (strcmp (name, "short int") == 0)
197 return short_integer_type_node;
198 if (strcmp (name, "short unsigned int") == 0)
199 return short_unsigned_type_node;
201 if (strcmp (name, "int") == 0)
202 return integer_type_node;
203 if (strcmp (name, "unsigned int") == 0)
204 return unsigned_type_node;
206 if (strcmp (name, "long int") == 0)
207 return long_integer_type_node;
208 if (strcmp (name, "long unsigned int") == 0)
209 return long_unsigned_type_node;
211 if (strcmp (name, "long long int") == 0)
212 return long_long_integer_type_node;
213 if (strcmp (name, "long long unsigned int") == 0)
214 return long_long_unsigned_type_node;
220 get_int_kind_from_name (const char *name)
222 return get_int_kind_from_node (get_typenode_from_name (name));
226 /* Get the kind number corresponding to an integer of given size,
227 following the required return values for ISO_FORTRAN_ENV INT* constants:
228 -2 is returned if we support a kind of larger size, -1 otherwise. */
230 gfc_get_int_kind_from_width_isofortranenv (int size)
234 /* Look for a kind with matching storage size. */
235 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
236 if (gfc_integer_kinds[i].bit_size == size)
237 return gfc_integer_kinds[i].kind;
239 /* Look for a kind with larger storage size. */
240 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
241 if (gfc_integer_kinds[i].bit_size > size)
247 /* Get the kind number corresponding to a real of given storage size,
248 following the required return values for ISO_FORTRAN_ENV REAL* constants:
249 -2 is returned if we support a kind of larger size, -1 otherwise. */
251 gfc_get_real_kind_from_width_isofortranenv (int size)
257 /* Look for a kind with matching storage size. */
258 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
259 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
260 return gfc_real_kinds[i].kind;
262 /* Look for a kind with larger storage size. */
263 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
264 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
273 get_int_kind_from_width (int size)
277 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
278 if (gfc_integer_kinds[i].bit_size == size)
279 return gfc_integer_kinds[i].kind;
285 get_int_kind_from_minimal_width (int size)
289 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
290 if (gfc_integer_kinds[i].bit_size >= size)
291 return gfc_integer_kinds[i].kind;
297 /* Generate the CInteropKind_t objects for the C interoperable
301 void init_c_interop_kinds (void)
305 /* init all pointers in the list to NULL */
306 for (i = 0; i < ISOCBINDING_NUMBER; i++)
308 /* Initialize the name and value fields. */
309 c_interop_kinds_table[i].name[0] = '\0';
310 c_interop_kinds_table[i].value = -100;
311 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
314 #define NAMED_INTCST(a,b,c,d) \
315 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
316 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
317 c_interop_kinds_table[a].value = c;
318 #define NAMED_REALCST(a,b,c) \
319 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
320 c_interop_kinds_table[a].f90_type = BT_REAL; \
321 c_interop_kinds_table[a].value = c;
322 #define NAMED_CMPXCST(a,b,c) \
323 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
324 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
325 c_interop_kinds_table[a].value = c;
326 #define NAMED_LOGCST(a,b,c) \
327 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
328 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
329 c_interop_kinds_table[a].value = c;
330 #define NAMED_CHARKNDCST(a,b,c) \
331 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
332 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
333 c_interop_kinds_table[a].value = c;
334 #define NAMED_CHARCST(a,b,c) \
335 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
336 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
337 c_interop_kinds_table[a].value = c;
338 #define DERIVED_TYPE(a,b,c) \
339 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
340 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
341 c_interop_kinds_table[a].value = c;
342 #define PROCEDURE(a,b) \
343 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
344 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
345 c_interop_kinds_table[a].value = 0;
346 #include "iso-c-binding.def"
347 #define NAMED_FUNCTION(a,b,c,d) \
348 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
349 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
350 c_interop_kinds_table[a].value = c;
351 #include "iso-c-binding.def"
355 /* Query the target to determine which machine modes are available for
356 computation. Choose KIND numbers for them. */
359 gfc_init_kinds (void)
362 int i_index, r_index, kind;
363 bool saw_i4 = false, saw_i8 = false;
364 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
366 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
370 if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
373 /* The middle end doesn't support constants larger than 2*HWI.
374 Perhaps the target hook shouldn't have accepted these either,
375 but just to be safe... */
376 bitsize = GET_MODE_BITSIZE (mode);
377 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
380 gcc_assert (i_index != MAX_INT_KINDS);
382 /* Let the kind equal the bit size divided by 8. This insulates the
383 programmer from the underlying byte size. */
391 gfc_integer_kinds[i_index].kind = kind;
392 gfc_integer_kinds[i_index].radix = 2;
393 gfc_integer_kinds[i_index].digits = bitsize - 1;
394 gfc_integer_kinds[i_index].bit_size = bitsize;
396 gfc_logical_kinds[i_index].kind = kind;
397 gfc_logical_kinds[i_index].bit_size = bitsize;
402 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
403 used for large file access. */
410 /* If we do not at least have kind = 4, everything is pointless. */
413 /* Set the maximum integer kind. Used with at least BOZ constants. */
414 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
416 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
418 const struct real_format *fmt =
419 REAL_MODE_FORMAT ((enum machine_mode) mode);
424 if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
427 /* Only let float, double, long double and __float128 go through.
428 Runtime support for others is not provided, so they would be
430 if (mode != TYPE_MODE (float_type_node)
431 && (mode != TYPE_MODE (double_type_node))
432 && (mode != TYPE_MODE (long_double_type_node))
433 #if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
439 /* Let the kind equal the precision divided by 8, rounding up. Again,
440 this insulates the programmer from the underlying byte size.
442 Also, it effectively deals with IEEE extended formats. There, the
443 total size of the type may equal 16, but it's got 6 bytes of padding
444 and the increased size can get in the way of a real IEEE quad format
445 which may also be supported by the target.
447 We round up so as to handle IA-64 __floatreg (RFmode), which is an
448 82 bit type. Not to be confused with __float80 (XFmode), which is
449 an 80 bit type also supported by IA-64. So XFmode should come out
450 to be kind=10, and RFmode should come out to be kind=11. Egads. */
452 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
461 /* Careful we don't stumble a weird internal mode. */
462 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
463 /* Or have too many modes for the allocated space. */
464 gcc_assert (r_index != MAX_REAL_KINDS);
466 gfc_real_kinds[r_index].kind = kind;
467 gfc_real_kinds[r_index].radix = fmt->b;
468 gfc_real_kinds[r_index].digits = fmt->p;
469 gfc_real_kinds[r_index].min_exponent = fmt->emin;
470 gfc_real_kinds[r_index].max_exponent = fmt->emax;
471 if (fmt->pnan < fmt->p)
472 /* This is an IBM extended double format (or the MIPS variant)
473 made up of two IEEE doubles. The value of the long double is
474 the sum of the values of the two parts. The most significant
475 part is required to be the value of the long double rounded
476 to the nearest double. If we use emax of 1024 then we can't
477 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
478 rounding will make the most significant part overflow. */
479 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
480 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
484 /* Choose the default integer kind. We choose 4 unless the user
485 directs us otherwise. */
486 if (gfc_option.flag_default_integer)
489 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
490 gfc_default_integer_kind = 8;
492 /* Even if the user specified that the default integer kind be 8,
493 the numeric storage size isn't 64. In this case, a warning will
494 be issued when NUMERIC_STORAGE_SIZE is used. */
495 gfc_numeric_storage_size = 4 * 8;
499 gfc_default_integer_kind = 4;
500 gfc_numeric_storage_size = 4 * 8;
504 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
505 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
508 /* Choose the default real kind. Again, we choose 4 when possible. */
509 if (gfc_option.flag_default_real)
512 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
513 gfc_default_real_kind = 8;
516 gfc_default_real_kind = 4;
518 gfc_default_real_kind = gfc_real_kinds[0].kind;
520 /* Choose the default double kind. If -fdefault-real and -fdefault-double
521 are specified, we use kind=8, if it's available. If -fdefault-real is
522 specified without -fdefault-double, we use kind=16, if it's available.
523 Otherwise we do not change anything. */
524 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
525 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
527 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
528 gfc_default_double_kind = 8;
529 else if (gfc_option.flag_default_real && saw_r16)
530 gfc_default_double_kind = 16;
531 else if (saw_r4 && saw_r8)
532 gfc_default_double_kind = 8;
535 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
536 real ... occupies two contiguous numeric storage units.
538 Therefore we must be supplied a kind twice as large as we chose
539 for single precision. There are loopholes, in that double
540 precision must *occupy* two storage units, though it doesn't have
541 to *use* two storage units. Which means that you can make this
542 kind artificially wide by padding it. But at present there are
543 no GCC targets for which a two-word type does not exist, so we
544 just let gfc_validate_kind abort and tell us if something breaks. */
546 gfc_default_double_kind
547 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
550 /* The default logical kind is constrained to be the same as the
551 default integer kind. Similarly with complex and real. */
552 gfc_default_logical_kind = gfc_default_integer_kind;
553 gfc_default_complex_kind = gfc_default_real_kind;
555 /* We only have two character kinds: ASCII and UCS-4.
556 ASCII corresponds to a 8-bit integer type, if one is available.
557 UCS-4 corresponds to a 32-bit integer type, if one is available. */
559 if ((kind = get_int_kind_from_width (8)) > 0)
561 gfc_character_kinds[i_index].kind = kind;
562 gfc_character_kinds[i_index].bit_size = 8;
563 gfc_character_kinds[i_index].name = "ascii";
566 if ((kind = get_int_kind_from_width (32)) > 0)
568 gfc_character_kinds[i_index].kind = kind;
569 gfc_character_kinds[i_index].bit_size = 32;
570 gfc_character_kinds[i_index].name = "iso_10646";
574 /* Choose the smallest integer kind for our default character. */
575 gfc_default_character_kind = gfc_character_kinds[0].kind;
576 gfc_character_storage_size = gfc_default_character_kind * 8;
578 /* Choose the integer kind the same size as "void*" for our index kind. */
579 gfc_index_integer_kind = POINTER_SIZE / 8;
580 /* Pick a kind the same size as the C "int" type. */
581 gfc_c_int_kind = INT_TYPE_SIZE / 8;
583 /* Choose atomic kinds to match C's int. */
584 gfc_atomic_int_kind = gfc_c_int_kind;
585 gfc_atomic_logical_kind = gfc_c_int_kind;
587 /* initialize the C interoperable kinds */
588 init_c_interop_kinds();
591 /* Make sure that a valid kind is present. Returns an index into the
592 associated kinds array, -1 if the kind is not present. */
595 validate_integer (int kind)
599 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
600 if (gfc_integer_kinds[i].kind == kind)
607 validate_real (int kind)
611 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
612 if (gfc_real_kinds[i].kind == kind)
619 validate_logical (int kind)
623 for (i = 0; gfc_logical_kinds[i].kind; i++)
624 if (gfc_logical_kinds[i].kind == kind)
631 validate_character (int kind)
635 for (i = 0; gfc_character_kinds[i].kind; i++)
636 if (gfc_character_kinds[i].kind == kind)
642 /* Validate a kind given a basic type. The return value is the same
643 for the child functions, with -1 indicating nonexistence of the
644 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
647 gfc_validate_kind (bt type, int kind, bool may_fail)
653 case BT_REAL: /* Fall through */
655 rc = validate_real (kind);
658 rc = validate_integer (kind);
661 rc = validate_logical (kind);
664 rc = validate_character (kind);
668 gfc_internal_error ("gfc_validate_kind(): Got bad type");
671 if (rc < 0 && !may_fail)
672 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
678 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
679 Reuse common type nodes where possible. Recognize if the kind matches up
680 with a C type. This will be used later in determining which routines may
681 be scarfed from libm. */
684 gfc_build_int_type (gfc_integer_info *info)
686 int mode_precision = info->bit_size;
688 if (mode_precision == CHAR_TYPE_SIZE)
690 if (mode_precision == SHORT_TYPE_SIZE)
692 if (mode_precision == INT_TYPE_SIZE)
694 if (mode_precision == LONG_TYPE_SIZE)
696 if (mode_precision == LONG_LONG_TYPE_SIZE)
697 info->c_long_long = 1;
699 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
700 return intQI_type_node;
701 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
702 return intHI_type_node;
703 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
704 return intSI_type_node;
705 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
706 return intDI_type_node;
707 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
708 return intTI_type_node;
710 return make_signed_type (mode_precision);
714 gfc_build_uint_type (int size)
716 if (size == CHAR_TYPE_SIZE)
717 return unsigned_char_type_node;
718 if (size == SHORT_TYPE_SIZE)
719 return short_unsigned_type_node;
720 if (size == INT_TYPE_SIZE)
721 return unsigned_type_node;
722 if (size == LONG_TYPE_SIZE)
723 return long_unsigned_type_node;
724 if (size == LONG_LONG_TYPE_SIZE)
725 return long_long_unsigned_type_node;
727 return make_unsigned_type (size);
732 gfc_build_real_type (gfc_real_info *info)
734 int mode_precision = info->mode_precision;
737 if (mode_precision == FLOAT_TYPE_SIZE)
739 if (mode_precision == DOUBLE_TYPE_SIZE)
741 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
742 info->c_long_double = 1;
743 if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
745 info->c_float128 = 1;
746 gfc_real16_is_float128 = true;
749 if (TYPE_PRECISION (float_type_node) == mode_precision)
750 return float_type_node;
751 if (TYPE_PRECISION (double_type_node) == mode_precision)
752 return double_type_node;
753 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
754 return long_double_type_node;
756 new_type = make_node (REAL_TYPE);
757 TYPE_PRECISION (new_type) = mode_precision;
758 layout_type (new_type);
763 gfc_build_complex_type (tree scalar_type)
767 if (scalar_type == NULL)
769 if (scalar_type == float_type_node)
770 return complex_float_type_node;
771 if (scalar_type == double_type_node)
772 return complex_double_type_node;
773 if (scalar_type == long_double_type_node)
774 return complex_long_double_type_node;
776 new_type = make_node (COMPLEX_TYPE);
777 TREE_TYPE (new_type) = scalar_type;
778 layout_type (new_type);
783 gfc_build_logical_type (gfc_logical_info *info)
785 int bit_size = info->bit_size;
788 if (bit_size == BOOL_TYPE_SIZE)
791 return boolean_type_node;
794 new_type = make_unsigned_type (bit_size);
795 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
796 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
797 TYPE_PRECISION (new_type) = 1;
803 /* Create the backend type nodes. We map them to their
804 equivalent C type, at least for now. We also give
805 names to the types here, and we push them in the
806 global binding level context.*/
809 gfc_init_types (void)
815 unsigned HOST_WIDE_INT hi;
816 unsigned HOST_WIDE_INT lo;
818 /* Create and name the types. */
819 #define PUSH_TYPE(name, node) \
820 pushdecl (build_decl (input_location, \
821 TYPE_DECL, get_identifier (name), node))
823 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
825 type = gfc_build_int_type (&gfc_integer_kinds[index]);
826 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
827 if (TYPE_STRING_FLAG (type))
828 type = make_signed_type (gfc_integer_kinds[index].bit_size);
829 gfc_integer_types[index] = type;
830 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
831 gfc_integer_kinds[index].kind);
832 PUSH_TYPE (name_buf, type);
835 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
837 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
838 gfc_logical_types[index] = type;
839 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
840 gfc_logical_kinds[index].kind);
841 PUSH_TYPE (name_buf, type);
844 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
846 type = gfc_build_real_type (&gfc_real_kinds[index]);
847 gfc_real_types[index] = type;
848 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
849 gfc_real_kinds[index].kind);
850 PUSH_TYPE (name_buf, type);
852 if (gfc_real_kinds[index].c_float128)
853 float128_type_node = type;
855 type = gfc_build_complex_type (type);
856 gfc_complex_types[index] = type;
857 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
858 gfc_real_kinds[index].kind);
859 PUSH_TYPE (name_buf, type);
861 if (gfc_real_kinds[index].c_float128)
862 complex_float128_type_node = type;
865 for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
867 type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
868 type = build_qualified_type (type, TYPE_UNQUALIFIED);
869 snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
870 gfc_character_kinds[index].kind);
871 PUSH_TYPE (name_buf, type);
872 gfc_character_types[index] = type;
873 gfc_pcharacter_types[index] = build_pointer_type (type);
875 gfc_character1_type_node = gfc_character_types[0];
877 PUSH_TYPE ("byte", unsigned_char_type_node);
878 PUSH_TYPE ("void", void_type_node);
880 /* DBX debugging output gets upset if these aren't set. */
881 if (!TYPE_NAME (integer_type_node))
882 PUSH_TYPE ("c_integer", integer_type_node);
883 if (!TYPE_NAME (char_type_node))
884 PUSH_TYPE ("c_char", char_type_node);
888 pvoid_type_node = build_pointer_type (void_type_node);
889 prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
890 ppvoid_type_node = build_pointer_type (pvoid_type_node);
891 pchar_type_node = build_pointer_type (gfc_character1_type_node);
893 = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
895 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
896 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
897 since this function is called before gfc_init_constants. */
899 = build_range_type (gfc_array_index_type,
900 build_int_cst (gfc_array_index_type, 0),
903 /* The maximum array element size that can be handled is determined
904 by the number of bits available to store this field in the array
907 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
908 lo = ~ (unsigned HOST_WIDE_INT) 0;
909 if (n > HOST_BITS_PER_WIDE_INT)
910 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
912 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
913 gfc_max_array_element_size
914 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
916 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
917 boolean_true_node = build_int_cst (boolean_type_node, 1);
918 boolean_false_node = build_int_cst (boolean_type_node, 0);
920 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
921 gfc_charlen_int_kind = 4;
922 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
925 /* Get the type node for the given type and kind. */
928 gfc_get_int_type (int kind)
930 int index = gfc_validate_kind (BT_INTEGER, kind, true);
931 return index < 0 ? 0 : gfc_integer_types[index];
935 gfc_get_real_type (int kind)
937 int index = gfc_validate_kind (BT_REAL, kind, true);
938 return index < 0 ? 0 : gfc_real_types[index];
942 gfc_get_complex_type (int kind)
944 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
945 return index < 0 ? 0 : gfc_complex_types[index];
949 gfc_get_logical_type (int kind)
951 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
952 return index < 0 ? 0 : gfc_logical_types[index];
956 gfc_get_char_type (int kind)
958 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
959 return index < 0 ? 0 : gfc_character_types[index];
963 gfc_get_pchar_type (int kind)
965 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
966 return index < 0 ? 0 : gfc_pcharacter_types[index];
970 /* Create a character type with the given kind and length. */
973 gfc_get_character_type_len_for_eltype (tree eltype, tree len)
977 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
978 type = build_array_type (eltype, bounds);
979 TYPE_STRING_FLAG (type) = 1;
985 gfc_get_character_type_len (int kind, tree len)
987 gfc_validate_kind (BT_CHARACTER, kind, false);
988 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
992 /* Get a type node for a character kind. */
995 gfc_get_character_type (int kind, gfc_charlen * cl)
999 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
1001 return gfc_get_character_type_len (kind, len);
1004 /* Covert a basic type. This will be an array for character types. */
1007 gfc_typenode_for_spec (gfc_typespec * spec)
1017 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1018 has been resolved. This is done so we can convert C_PTR and
1019 C_FUNPTR to simple variables that get translated to (void *). */
1020 if (spec->f90_type == BT_VOID)
1023 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1024 basetype = ptr_type_node;
1026 basetype = pfunc_type_node;
1029 basetype = gfc_get_int_type (spec->kind);
1033 basetype = gfc_get_real_type (spec->kind);
1037 basetype = gfc_get_complex_type (spec->kind);
1041 basetype = gfc_get_logical_type (spec->kind);
1047 basetype = gfc_get_character_type (spec->kind, NULL);
1050 basetype = gfc_get_character_type (spec->kind, spec->u.cl);
1055 basetype = gfc_get_derived_type (spec->u.derived);
1057 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1058 type and kind to fit a (void *) and the basetype returned was a
1059 ptr_type_node. We need to pass up this new information to the
1060 symbol that was declared of type C_PTR or C_FUNPTR. */
1061 if (spec->u.derived->attr.is_iso_c)
1063 spec->type = spec->u.derived->ts.type;
1064 spec->kind = spec->u.derived->ts.kind;
1065 spec->f90_type = spec->u.derived->ts.f90_type;
1069 /* This is for the second arg to c_f_pointer and c_f_procpointer
1070 of the iso_c_binding module, to accept any ptr type. */
1071 basetype = ptr_type_node;
1072 if (spec->f90_type == BT_VOID)
1075 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1076 basetype = ptr_type_node;
1078 basetype = pfunc_type_node;
1087 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1090 gfc_conv_array_bound (gfc_expr * expr)
1092 /* If expr is an integer constant, return that. */
1093 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
1094 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
1096 /* Otherwise return NULL. */
1101 gfc_get_element_type (tree type)
1105 if (GFC_ARRAY_TYPE_P (type))
1107 if (TREE_CODE (type) == POINTER_TYPE)
1108 type = TREE_TYPE (type);
1109 if (GFC_TYPE_ARRAY_RANK (type) == 0)
1111 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
1116 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1117 element = TREE_TYPE (type);
1122 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
1123 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
1125 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
1126 element = TREE_TYPE (element);
1128 /* For arrays, which are not scalar coarrays. */
1129 if (TREE_CODE (element) == ARRAY_TYPE)
1130 element = TREE_TYPE (element);
1136 /* Build an array. This function is called from gfc_sym_type().
1137 Actually returns array descriptor type.
1139 Format of array descriptors is as follows:
1141 struct gfc_array_descriptor
1146 struct descriptor_dimension dimension[N_DIM];
1149 struct descriptor_dimension
1156 Translation code should use gfc_conv_descriptor_* rather than
1157 accessing the descriptor directly. Any changes to the array
1158 descriptor type will require changes in gfc_conv_descriptor_* and
1159 gfc_build_array_initializer.
1161 This is represented internally as a RECORD_TYPE. The index nodes
1162 are gfc_array_index_type and the data node is a pointer to the
1163 data. See below for the handling of character types.
1165 The dtype member is formatted as follows:
1166 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1167 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1168 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1170 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1171 this generated poor code for assumed/deferred size arrays. These
1172 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1173 of the GENERIC grammar. Also, there is no way to explicitly set
1174 the array stride, so all data must be packed(1). I've tried to
1175 mark all the functions which would require modification with a GCC
1178 The data component points to the first element in the array. The
1179 offset field is the position of the origin of the array (i.e. element
1180 (0, 0 ...)). This may be outside the bounds of the array.
1182 An element is accessed by
1183 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1184 This gives good performance as the computation does not involve the
1185 bounds of the array. For packed arrays, this is optimized further
1186 by substituting the known strides.
1188 This system has one problem: all array bounds must be within 2^31
1189 elements of the origin (2^63 on 64-bit machines). For example
1190 integer, dimension (80000:90000, 80000:90000, 2) :: array
1191 may not work properly on 32-bit machines because 80000*80000 >
1192 2^31, so the calculation for stride2 would overflow. This may
1193 still work, but I haven't checked, and it relies on the overflow
1194 doing the right thing.
1196 The way to fix this problem is to access elements as follows:
1197 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1198 Obviously this is much slower. I will make this a compile time
1199 option, something like -fsmall-array-offsets. Mixing code compiled
1200 with and without this switch will work.
1202 (1) This can be worked around by modifying the upper bound of the
1203 previous dimension. This requires extra fields in the descriptor
1204 (both real_ubound and fake_ubound). */
1207 /* Returns true if the array sym does not require a descriptor. */
1210 gfc_is_nodesc_array (gfc_symbol * sym)
1212 gcc_assert (sym->attr.dimension || sym->attr.codimension);
1214 /* We only want local arrays. */
1215 if (sym->attr.pointer || sym->attr.allocatable)
1218 /* We want a descriptor for associate-name arrays that do not have an
1219 explicitely known shape already. */
1220 if (sym->assoc && sym->as->type != AS_EXPLICIT)
1223 if (sym->attr.dummy)
1224 return sym->as->type != AS_ASSUMED_SHAPE;
1226 if (sym->attr.result || sym->attr.function)
1229 gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed);
1235 /* Create an array descriptor type. */
1238 gfc_build_array_type (tree type, gfc_array_spec * as,
1239 enum gfc_array_kind akind, bool restricted,
1242 tree lbound[GFC_MAX_DIMENSIONS];
1243 tree ubound[GFC_MAX_DIMENSIONS];
1246 for (n = 0; n < as->rank; n++)
1248 /* Create expressions for the known bounds of the array. */
1249 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1250 lbound[n] = gfc_index_one_node;
1252 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1253 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1256 for (n = as->rank; n < as->rank + as->corank; n++)
1258 if (as->lower[n] == NULL)
1259 lbound[n] = gfc_index_one_node;
1261 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1263 if (n < as->rank + as->corank - 1)
1264 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1267 if (as->type == AS_ASSUMED_SHAPE)
1268 akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
1269 : GFC_ARRAY_ASSUMED_SHAPE;
1270 return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
1271 ubound, 0, akind, restricted);
1274 /* Returns the struct descriptor_dimension type. */
1277 gfc_get_desc_dim_type (void)
1280 tree decl, *chain = NULL;
1282 if (gfc_desc_dim_type)
1283 return gfc_desc_dim_type;
1285 /* Build the type node. */
1286 type = make_node (RECORD_TYPE);
1288 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1289 TYPE_PACKED (type) = 1;
1291 /* Consists of the stride, lbound and ubound members. */
1292 decl = gfc_add_field_to_struct_1 (type,
1293 get_identifier ("stride"),
1294 gfc_array_index_type, &chain);
1295 TREE_NO_WARNING (decl) = 1;
1297 decl = gfc_add_field_to_struct_1 (type,
1298 get_identifier ("lbound"),
1299 gfc_array_index_type, &chain);
1300 TREE_NO_WARNING (decl) = 1;
1302 decl = gfc_add_field_to_struct_1 (type,
1303 get_identifier ("ubound"),
1304 gfc_array_index_type, &chain);
1305 TREE_NO_WARNING (decl) = 1;
1307 /* Finish off the type. */
1308 gfc_finish_type (type);
1309 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1311 gfc_desc_dim_type = type;
1316 /* Return the DTYPE for an array. This describes the type and type parameters
1318 /* TODO: Only call this when the value is actually used, and make all the
1319 unknown cases abort. */
1322 gfc_get_dtype (tree type)
1332 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1334 if (GFC_TYPE_ARRAY_DTYPE (type))
1335 return GFC_TYPE_ARRAY_DTYPE (type);
1337 rank = GFC_TYPE_ARRAY_RANK (type);
1338 etype = gfc_get_element_type (type);
1340 switch (TREE_CODE (etype))
1358 /* We will never have arrays of arrays. */
1368 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1369 /* We can strange array types for temporary arrays. */
1370 return gfc_index_zero_node;
1373 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1374 size = TYPE_SIZE_UNIT (etype);
1376 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1377 if (size && INTEGER_CST_P (size))
1379 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1380 internal_error ("Array element size too big");
1382 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1384 dtype = build_int_cst (gfc_array_index_type, i);
1386 if (size && !INTEGER_CST_P (size))
1388 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1389 tmp = fold_build2_loc (input_location, LSHIFT_EXPR,
1390 gfc_array_index_type,
1391 fold_convert (gfc_array_index_type, size), tmp);
1392 dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1395 /* If we don't know the size we leave it as zero. This should never happen
1396 for anything that is actually used. */
1397 /* TODO: Check this is actually true, particularly when repacking
1398 assumed size parameters. */
1400 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1405 /* Build an array type for use without a descriptor, packed according
1406 to the value of PACKED. */
1409 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
1423 mpz_init_set_ui (offset, 0);
1424 mpz_init_set_ui (stride, 1);
1427 /* We don't use build_array_type because this does not include include
1428 lang-specific information (i.e. the bounds of the array) when checking
1431 type = make_node (ARRAY_TYPE);
1433 type = build_variant_type_copy (etype);
1435 GFC_ARRAY_TYPE_P (type) = 1;
1436 TYPE_LANG_SPECIFIC (type)
1437 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
1439 known_stride = (packed != PACKED_NO);
1441 for (n = 0; n < as->rank; n++)
1443 /* Fill in the stride and bound components of the type. */
1445 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1448 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1450 expr = as->lower[n];
1451 if (expr->expr_type == EXPR_CONSTANT)
1453 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1454 gfc_index_integer_kind);
1461 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1465 /* Calculate the offset. */
1466 mpz_mul (delta, stride, as->lower[n]->value.integer);
1467 mpz_sub (offset, offset, delta);
1472 expr = as->upper[n];
1473 if (expr && expr->expr_type == EXPR_CONSTANT)
1475 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1476 gfc_index_integer_kind);
1483 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1487 /* Calculate the stride. */
1488 mpz_sub (delta, as->upper[n]->value.integer,
1489 as->lower[n]->value.integer);
1490 mpz_add_ui (delta, delta, 1);
1491 mpz_mul (stride, stride, delta);
1494 /* Only the first stride is known for partial packed arrays. */
1495 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1498 for (n = as->rank; n < as->rank + as->corank; n++)
1500 expr = as->lower[n];
1501 if (expr->expr_type == EXPR_CONSTANT)
1502 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1503 gfc_index_integer_kind);
1506 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1508 expr = as->upper[n];
1509 if (expr && expr->expr_type == EXPR_CONSTANT)
1510 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1511 gfc_index_integer_kind);
1514 if (n < as->rank + as->corank - 1)
1515 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1520 GFC_TYPE_ARRAY_OFFSET (type) =
1521 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1524 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1528 GFC_TYPE_ARRAY_SIZE (type) =
1529 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1532 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1534 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1535 GFC_TYPE_ARRAY_CORANK (type) = as->corank;
1536 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1537 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1539 /* TODO: use main type if it is unbounded. */
1540 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1541 build_pointer_type (build_array_type (etype, range));
1543 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1544 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
1545 TYPE_QUAL_RESTRICT);
1549 if (packed != PACKED_STATIC || gfc_option.coarray == GFC_FCOARRAY_LIB)
1551 type = build_pointer_type (type);
1554 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1556 GFC_ARRAY_TYPE_P (type) = 1;
1557 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1565 mpz_sub_ui (stride, stride, 1);
1566 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1571 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1572 TYPE_DOMAIN (type) = range;
1574 build_pointer_type (etype);
1575 TREE_TYPE (type) = etype;
1583 /* Represent packed arrays as multi-dimensional if they have rank >
1584 1 and with proper bounds, instead of flat arrays. This makes for
1585 better debug info. */
1588 tree gtype = etype, rtype, type_decl;
1590 for (n = as->rank - 1; n >= 0; n--)
1592 rtype = build_range_type (gfc_array_index_type,
1593 GFC_TYPE_ARRAY_LBOUND (type, n),
1594 GFC_TYPE_ARRAY_UBOUND (type, n));
1595 gtype = build_array_type (gtype, rtype);
1597 TYPE_NAME (type) = type_decl = build_decl (input_location,
1598 TYPE_DECL, NULL, gtype);
1599 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1602 if (packed != PACKED_STATIC || !known_stride
1603 || (as->corank && gfc_option.coarray == GFC_FCOARRAY_LIB))
1605 /* For dummy arrays and automatic (heap allocated) arrays we
1606 want a pointer to the array. */
1607 type = build_pointer_type (type);
1609 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1610 GFC_ARRAY_TYPE_P (type) = 1;
1611 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1616 /* Return or create the base type for an array descriptor. */
1619 gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
1621 tree fat_type, decl, arraytype, *chain = NULL;
1622 char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
1623 int idx = 2 * (codimen + dimen - 1) + restricted;
1625 gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
1626 if (gfc_array_descriptor_base[idx])
1627 return gfc_array_descriptor_base[idx];
1629 /* Build the type node. */
1630 fat_type = make_node (RECORD_TYPE);
1632 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
1633 TYPE_NAME (fat_type) = get_identifier (name);
1634 TYPE_NAMELESS (fat_type) = 1;
1636 /* Add the data member as the first element of the descriptor. */
1637 decl = gfc_add_field_to_struct_1 (fat_type,
1638 get_identifier ("data"),
1641 : ptr_type_node), &chain);
1643 /* Add the base component. */
1644 decl = gfc_add_field_to_struct_1 (fat_type,
1645 get_identifier ("offset"),
1646 gfc_array_index_type, &chain);
1647 TREE_NO_WARNING (decl) = 1;
1649 /* Add the dtype component. */
1650 decl = gfc_add_field_to_struct_1 (fat_type,
1651 get_identifier ("dtype"),
1652 gfc_array_index_type, &chain);
1653 TREE_NO_WARNING (decl) = 1;
1655 /* Build the array type for the stride and bound components. */
1657 build_array_type (gfc_get_desc_dim_type (),
1658 build_range_type (gfc_array_index_type,
1659 gfc_index_zero_node,
1660 gfc_rank_cst[codimen + dimen - 1]));
1662 decl = gfc_add_field_to_struct_1 (fat_type,
1663 get_identifier ("dim"),
1665 TREE_NO_WARNING (decl) = 1;
1667 /* Finish off the type. */
1668 gfc_finish_type (fat_type);
1669 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1671 gfc_array_descriptor_base[idx] = fat_type;
1675 /* Build an array (descriptor) type with given bounds. */
1678 gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
1679 tree * ubound, int packed,
1680 enum gfc_array_kind akind, bool restricted)
1682 char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
1683 tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
1684 const char *type_name;
1687 base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
1688 fat_type = build_distinct_type_copy (base_type);
1689 /* Make sure that nontarget and target array type have the same canonical
1690 type (and same stub decl for debug info). */
1691 base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
1692 TYPE_CANONICAL (fat_type) = base_type;
1693 TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
1695 tmp = TYPE_NAME (etype);
1696 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1697 tmp = DECL_NAME (tmp);
1699 type_name = IDENTIFIER_POINTER (tmp);
1701 type_name = "unknown";
1702 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
1703 GFC_MAX_SYMBOL_LEN, type_name);
1704 TYPE_NAME (fat_type) = get_identifier (name);
1705 TYPE_NAMELESS (fat_type) = 1;
1707 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1708 TYPE_LANG_SPECIFIC (fat_type)
1709 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
1711 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1712 GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
1713 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1714 GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1716 /* Build an array descriptor record type. */
1718 stride = gfc_index_one_node;
1721 for (n = 0; n < dimen + codimen; n++)
1724 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1731 if (lower != NULL_TREE)
1733 if (INTEGER_CST_P (lower))
1734 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1739 if (codimen && n == dimen + codimen - 1)
1743 if (upper != NULL_TREE)
1745 if (INTEGER_CST_P (upper))
1746 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1754 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1756 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1757 gfc_array_index_type, upper, lower);
1758 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1759 gfc_array_index_type, tmp,
1760 gfc_index_one_node);
1761 stride = fold_build2_loc (input_location, MULT_EXPR,
1762 gfc_array_index_type, tmp, stride);
1763 /* Check the folding worked. */
1764 gcc_assert (INTEGER_CST_P (stride));
1769 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1771 /* TODO: known offsets for descriptors. */
1772 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1776 arraytype = build_pointer_type (etype);
1778 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
1780 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1784 /* We define data as an array with the correct size if possible.
1785 Much better than doing pointer arithmetic. */
1787 rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1788 int_const_binop (MINUS_EXPR, stride,
1791 rtype = gfc_array_range_type;
1792 arraytype = build_array_type (etype, rtype);
1793 arraytype = build_pointer_type (arraytype);
1795 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
1796 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1798 /* This will generate the base declarations we need to emit debug
1799 information for this type. FIXME: there must be a better way to
1800 avoid divergence between compilations with and without debug
1803 struct array_descr_info info;
1804 gfc_get_array_descr_info (fat_type, &info);
1805 gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
1811 /* Build a pointer type. This function is called from gfc_sym_type(). */
1814 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1816 /* Array pointer types aren't actually pointers. */
1817 if (sym->attr.dimension)
1820 return build_pointer_type (type);
1823 static tree gfc_nonrestricted_type (tree t);
1824 /* Given two record or union type nodes TO and FROM, ensure
1825 that all fields in FROM have a corresponding field in TO,
1826 their type being nonrestrict variants. This accepts a TO
1827 node that already has a prefix of the fields in FROM. */
1829 mirror_fields (tree to, tree from)
1834 /* Forward to the end of TOs fields. */
1835 fto = TYPE_FIELDS (to);
1836 ffrom = TYPE_FIELDS (from);
1837 chain = &TYPE_FIELDS (to);
1840 gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
1841 chain = &DECL_CHAIN (fto);
1842 fto = DECL_CHAIN (fto);
1843 ffrom = DECL_CHAIN (ffrom);
1846 /* Now add all fields remaining in FROM (starting with ffrom). */
1847 for (; ffrom; ffrom = DECL_CHAIN (ffrom))
1849 tree newfield = copy_node (ffrom);
1850 DECL_CONTEXT (newfield) = to;
1851 /* The store to DECL_CHAIN might seem redundant with the
1852 stores to *chain, but not clearing it here would mean
1853 leaving a chain into the old fields. If ever
1854 our called functions would look at them confusion
1856 DECL_CHAIN (newfield) = NULL_TREE;
1858 chain = &DECL_CHAIN (newfield);
1860 if (TREE_CODE (ffrom) == FIELD_DECL)
1862 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
1863 TREE_TYPE (newfield) = elemtype;
1869 /* Given a type T, returns a different type of the same structure,
1870 except that all types it refers to (recursively) are always
1871 non-restrict qualified types. */
1873 gfc_nonrestricted_type (tree t)
1877 /* If the type isn't layed out yet, don't copy it. If something
1878 needs it for real it should wait until the type got finished. */
1882 if (!TYPE_LANG_SPECIFIC (t))
1883 TYPE_LANG_SPECIFIC (t)
1884 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
1885 /* If we're dealing with this very node already further up
1886 the call chain (recursion via pointers and struct members)
1887 we haven't yet determined if we really need a new type node.
1888 Assume we don't, return T itself. */
1889 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
1892 /* If we have calculated this all already, just return it. */
1893 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
1894 return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
1896 /* Mark this type. */
1897 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
1899 switch (TREE_CODE (t))
1905 case REFERENCE_TYPE:
1907 tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
1908 if (totype == TREE_TYPE (t))
1910 else if (TREE_CODE (t) == POINTER_TYPE)
1911 ret = build_pointer_type (totype);
1913 ret = build_reference_type (totype);
1914 ret = build_qualified_type (ret,
1915 TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
1921 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
1922 if (elemtype == TREE_TYPE (t))
1926 ret = build_variant_type_copy (t);
1927 TREE_TYPE (ret) = elemtype;
1928 if (TYPE_LANG_SPECIFIC (t)
1929 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
1931 tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
1932 dataptr_type = gfc_nonrestricted_type (dataptr_type);
1933 if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
1935 TYPE_LANG_SPECIFIC (ret)
1936 = ggc_alloc_cleared_lang_type (sizeof (struct
1938 *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
1939 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
1948 case QUAL_UNION_TYPE:
1951 /* First determine if we need a new type at all.
1952 Careful, the two calls to gfc_nonrestricted_type per field
1953 might return different values. That happens exactly when
1954 one of the fields reaches back to this very record type
1955 (via pointers). The first calls will assume that we don't
1956 need to copy T (see the error_mark_node marking). If there
1957 are any reasons for copying T apart from having to copy T,
1958 we'll indeed copy it, and the second calls to
1959 gfc_nonrestricted_type will use that new node if they
1961 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
1962 if (TREE_CODE (field) == FIELD_DECL)
1964 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
1965 if (elemtype != TREE_TYPE (field))
1970 ret = build_variant_type_copy (t);
1971 TYPE_FIELDS (ret) = NULL_TREE;
1973 /* Here we make sure that as soon as we know we have to copy
1974 T, that also fields reaching back to us will use the new
1975 copy. It's okay if that copy still contains the old fields,
1976 we won't look at them. */
1977 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
1978 mirror_fields (ret, t);
1983 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
1988 /* Return the type for a symbol. Special handling is required for character
1989 types to get the correct level of indirection.
1990 For functions return the return type.
1991 For subroutines return void_type_node.
1992 Calling this multiple times for the same symbol should be avoided,
1993 especially for character and array types. */
1996 gfc_sym_type (gfc_symbol * sym)
2002 /* Procedure Pointers inside COMMON blocks. */
2003 if (sym->attr.proc_pointer && sym->attr.in_common)
2005 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2006 sym->attr.proc_pointer = 0;
2007 type = build_pointer_type (gfc_get_function_type (sym));
2008 sym->attr.proc_pointer = 1;
2012 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2013 return void_type_node;
2015 /* In the case of a function the fake result variable may have a
2016 type different from the function type, so don't return early in
2018 if (sym->backend_decl && !sym->attr.function)
2019 return TREE_TYPE (sym->backend_decl);
2021 if (sym->ts.type == BT_CHARACTER
2022 && ((sym->attr.function && sym->attr.is_bind_c)
2023 || (sym->attr.result
2024 && sym->ns->proc_name
2025 && sym->ns->proc_name->attr.is_bind_c)))
2026 type = gfc_character1_type_node;
2028 type = gfc_typenode_for_spec (&sym->ts);
2030 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
2035 restricted = !sym->attr.target && !sym->attr.pointer
2036 && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
2038 type = gfc_nonrestricted_type (type);
2040 if (sym->attr.dimension || sym->attr.codimension)
2042 if (gfc_is_nodesc_array (sym))
2044 /* If this is a character argument of unknown length, just use the
2046 if (sym->ts.type != BT_CHARACTER
2047 || !(sym->attr.dummy || sym->attr.function)
2048 || sym->ts.u.cl->backend_decl)
2050 type = gfc_get_nodesc_array_type (type, sym->as,
2057 if (sym->attr.cray_pointee)
2058 GFC_POINTER_TYPE_P (type) = 1;
2062 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
2063 if (sym->attr.pointer)
2064 akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2065 : GFC_ARRAY_POINTER;
2066 else if (sym->attr.allocatable)
2067 akind = GFC_ARRAY_ALLOCATABLE;
2068 type = gfc_build_array_type (type, sym->as, akind, restricted,
2069 sym->attr.contiguous);
2074 if (sym->attr.allocatable || sym->attr.pointer
2075 || gfc_is_associate_pointer (sym))
2076 type = gfc_build_pointer_type (sym, type);
2077 if (sym->attr.pointer || sym->attr.cray_pointee)
2078 GFC_POINTER_TYPE_P (type) = 1;
2081 /* We currently pass all parameters by reference.
2082 See f95_get_function_decl. For dummy function parameters return the
2086 /* We must use pointer types for potentially absent variables. The
2087 optimizers assume a reference type argument is never NULL. */
2088 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
2089 type = build_pointer_type (type);
2092 type = build_reference_type (type);
2094 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
2101 /* Layout and output debug info for a record type. */
2104 gfc_finish_type (tree type)
2108 decl = build_decl (input_location,
2109 TYPE_DECL, NULL_TREE, type);
2110 TYPE_STUB_DECL (type) = decl;
2112 rest_of_type_compilation (type, 1);
2113 rest_of_decl_compilation (decl, 1, 0);
2116 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2117 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2118 to the end of the field list pointed to by *CHAIN.
2120 Returns a pointer to the new field. */
2123 gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
2125 tree decl = build_decl (input_location, FIELD_DECL, name, type);
2127 DECL_CONTEXT (decl) = context;
2128 DECL_CHAIN (decl) = NULL_TREE;
2129 if (TYPE_FIELDS (context) == NULL_TREE)
2130 TYPE_FIELDS (context) = decl;
2135 *chain = &DECL_CHAIN (decl);
2141 /* Like `gfc_add_field_to_struct_1', but adds alignment
2145 gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
2147 tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
2149 DECL_INITIAL (decl) = 0;
2150 DECL_ALIGN (decl) = 0;
2151 DECL_USER_ALIGN (decl) = 0;
2157 /* Copy the backend_decl and component backend_decls if
2158 the two derived type symbols are "equal", as described
2159 in 4.4.2 and resolved by gfc_compare_derived_types. */
2162 gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
2165 gfc_component *to_cm;
2166 gfc_component *from_cm;
2168 if (from->backend_decl == NULL
2169 || !gfc_compare_derived_types (from, to))
2172 to->backend_decl = from->backend_decl;
2174 to_cm = to->components;
2175 from_cm = from->components;
2177 /* Copy the component declarations. If a component is itself
2178 a derived type, we need a copy of its component declarations.
2179 This is done by recursing into gfc_get_derived_type and
2180 ensures that the component's component declarations have
2181 been built. If it is a character, we need the character
2183 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
2185 to_cm->backend_decl = from_cm->backend_decl;
2186 if (from_cm->ts.type == BT_DERIVED
2187 && (!from_cm->attr.pointer || from_gsym))
2188 gfc_get_derived_type (to_cm->ts.u.derived);
2189 else if (from_cm->ts.type == BT_CLASS
2190 && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
2191 gfc_get_derived_type (to_cm->ts.u.derived);
2192 else if (from_cm->ts.type == BT_CHARACTER)
2193 to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
2200 /* Build a tree node for a procedure pointer component. */
2203 gfc_get_ppc_type (gfc_component* c)
2207 /* Explicit interface. */
2208 if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
2209 return build_pointer_type (gfc_get_function_type (c->ts.interface));
2211 /* Implicit interface (only return value may be known). */
2212 if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
2213 t = gfc_typenode_for_spec (&c->ts);
2217 return build_pointer_type (build_function_type_list (t, NULL_TREE));
2221 /* Build a tree node for a derived type. If there are equal
2222 derived types, with different local names, these are built
2223 at the same time. If an equal derived type has been built
2224 in a parent namespace, this is used. */
2227 gfc_get_derived_type (gfc_symbol * derived)
2229 tree typenode = NULL, field = NULL, field_type = NULL;
2230 tree canonical = NULL_TREE;
2232 bool got_canonical = false;
2237 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
2239 /* See if it's one of the iso_c_binding derived types. */
2240 if (derived->attr.is_iso_c == 1)
2242 if (derived->backend_decl)
2243 return derived->backend_decl;
2245 if (derived->intmod_sym_id == ISOCBINDING_PTR)
2246 derived->backend_decl = ptr_type_node;
2248 derived->backend_decl = pfunc_type_node;
2250 derived->ts.kind = gfc_index_integer_kind;
2251 derived->ts.type = BT_INTEGER;
2252 /* Set the f90_type to BT_VOID as a way to recognize something of type
2253 BT_INTEGER that needs to fit a void * for the purpose of the
2254 iso_c_binding derived types. */
2255 derived->ts.f90_type = BT_VOID;
2257 return derived->backend_decl;
2260 /* If use associated, use the module type for this one. */
2261 if (gfc_option.flag_whole_file
2262 && derived->backend_decl == NULL
2263 && derived->attr.use_assoc
2265 && gfc_get_module_backend_decl (derived))
2266 goto copy_derived_types;
2268 /* If a whole file compilation, the derived types from an earlier
2269 namespace can be used as the canonical type. */
2270 if (gfc_option.flag_whole_file
2271 && derived->backend_decl == NULL
2272 && !derived->attr.use_assoc
2273 && gfc_global_ns_list)
2275 for (ns = gfc_global_ns_list;
2276 ns->translated && !got_canonical;
2279 dt = ns->derived_types;
2280 for (; dt && !canonical; dt = dt->next)
2282 gfc_copy_dt_decls_ifequal (dt->derived, derived, true);
2283 if (derived->backend_decl)
2284 got_canonical = true;
2289 /* Store up the canonical type to be added to this one. */
2292 if (TYPE_CANONICAL (derived->backend_decl))
2293 canonical = TYPE_CANONICAL (derived->backend_decl);
2295 canonical = derived->backend_decl;
2297 derived->backend_decl = NULL_TREE;
2300 /* derived->backend_decl != 0 means we saw it before, but its
2301 components' backend_decl may have not been built. */
2302 if (derived->backend_decl)
2304 /* Its components' backend_decl have been built or we are
2305 seeing recursion through the formal arglist of a procedure
2306 pointer component. */
2307 if (TYPE_FIELDS (derived->backend_decl)
2308 || derived->attr.proc_pointer_comp)
2309 return derived->backend_decl;
2311 typenode = derived->backend_decl;
2315 /* We see this derived type first time, so build the type node. */
2316 typenode = make_node (RECORD_TYPE);
2317 TYPE_NAME (typenode) = get_identifier (derived->name);
2318 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2319 derived->backend_decl = typenode;
2322 /* Go through the derived type components, building them as
2323 necessary. The reason for doing this now is that it is
2324 possible to recurse back to this derived type through a
2325 pointer component (PR24092). If this happens, the fields
2326 will be built and so we can return the type. */
2327 for (c = derived->components; c; c = c->next)
2329 if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
2332 if ((!c->attr.pointer && !c->attr.proc_pointer)
2333 || c->ts.u.derived->backend_decl == NULL)
2334 c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
2336 if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
2338 /* Need to copy the modified ts from the derived type. The
2339 typespec was modified because C_PTR/C_FUNPTR are translated
2340 into (void *) from derived types. */
2341 c->ts.type = c->ts.u.derived->ts.type;
2342 c->ts.kind = c->ts.u.derived->ts.kind;
2343 c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2346 c->initializer->ts.type = c->ts.type;
2347 c->initializer->ts.kind = c->ts.kind;
2348 c->initializer->ts.f90_type = c->ts.f90_type;
2349 c->initializer->expr_type = EXPR_NULL;
2354 if (TYPE_FIELDS (derived->backend_decl))
2355 return derived->backend_decl;
2357 /* Build the type member list. Install the newly created RECORD_TYPE
2358 node as DECL_CONTEXT of each FIELD_DECL. */
2359 for (c = derived->components; c; c = c->next)
2361 if (c->attr.proc_pointer)
2362 field_type = gfc_get_ppc_type (c);
2363 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2364 field_type = c->ts.u.derived->backend_decl;
2367 if (c->ts.type == BT_CHARACTER)
2369 /* Evaluate the string length. */
2370 gfc_conv_const_charlen (c->ts.u.cl);
2371 gcc_assert (c->ts.u.cl->backend_decl);
2374 field_type = gfc_typenode_for_spec (&c->ts);
2377 /* This returns an array descriptor type. Initialization may be
2379 if (c->attr.dimension && !c->attr.proc_pointer)
2381 if (c->attr.pointer || c->attr.allocatable)
2383 enum gfc_array_kind akind;
2384 if (c->attr.pointer)
2385 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2386 : GFC_ARRAY_POINTER;
2388 akind = GFC_ARRAY_ALLOCATABLE;
2389 /* Pointers to arrays aren't actually pointer types. The
2390 descriptors are separate, but the data is common. */
2391 field_type = gfc_build_array_type (field_type, c->as, akind,
2393 && !c->attr.pointer,
2394 c->attr.contiguous);
2397 field_type = gfc_get_nodesc_array_type (field_type, c->as,
2401 else if ((c->attr.pointer || c->attr.allocatable)
2402 && !c->attr.proc_pointer)
2403 field_type = build_pointer_type (field_type);
2405 /* vtype fields can point to different types to the base type. */
2406 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.vtype)
2407 field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
2410 field = gfc_add_field_to_struct (typenode,
2411 get_identifier (c->name),
2412 field_type, &chain);
2414 gfc_set_decl_location (field, &c->loc);
2415 else if (derived->declared_at.lb)
2416 gfc_set_decl_location (field, &derived->declared_at);
2418 DECL_PACKED (field) |= TYPE_PACKED (typenode);
2421 if (!c->backend_decl)
2422 c->backend_decl = field;
2425 /* Now lay out the derived type, including the fields. */
2427 TYPE_CANONICAL (typenode) = canonical;
2429 gfc_finish_type (typenode);
2430 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2431 if (derived->module && derived->ns->proc_name
2432 && derived->ns->proc_name->attr.flavor == FL_MODULE)
2434 if (derived->ns->proc_name->backend_decl
2435 && TREE_CODE (derived->ns->proc_name->backend_decl)
2438 TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2439 DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2440 = derived->ns->proc_name->backend_decl;
2444 derived->backend_decl = typenode;
2448 for (dt = gfc_derived_types; dt; dt = dt->next)
2449 gfc_copy_dt_decls_ifequal (derived, dt->derived, false);
2451 return derived->backend_decl;
2456 gfc_return_by_reference (gfc_symbol * sym)
2458 if (!sym->attr.function)
2461 if (sym->attr.dimension)
2464 if (sym->ts.type == BT_CHARACTER
2465 && !sym->attr.is_bind_c
2466 && (!sym->attr.result
2467 || !sym->ns->proc_name
2468 || !sym->ns->proc_name->attr.is_bind_c))
2471 /* Possibly return complex numbers by reference for g77 compatibility.
2472 We don't do this for calls to intrinsics (as the library uses the
2473 -fno-f2c calling convention), nor for calls to functions which always
2474 require an explicit interface, as no compatibility problems can
2476 if (gfc_option.flag_f2c
2477 && sym->ts.type == BT_COMPLEX
2478 && !sym->attr.intrinsic && !sym->attr.always_explicit)
2485 gfc_get_mixed_entry_union (gfc_namespace *ns)
2489 char name[GFC_MAX_SYMBOL_LEN + 1];
2490 gfc_entry_list *el, *el2;
2492 gcc_assert (ns->proc_name->attr.mixed_entry_master);
2493 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2495 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
2497 /* Build the type node. */
2498 type = make_node (UNION_TYPE);
2500 TYPE_NAME (type) = get_identifier (name);
2502 for (el = ns->entries; el; el = el->next)
2504 /* Search for duplicates. */
2505 for (el2 = ns->entries; el2 != el; el2 = el2->next)
2506 if (el2->sym->result == el->sym->result)
2510 gfc_add_field_to_struct_1 (type,
2511 get_identifier (el->sym->result->name),
2512 gfc_sym_type (el->sym->result), &chain);
2515 /* Finish off the type. */
2516 gfc_finish_type (type);
2517 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
2521 /* Create a "fn spec" based on the formal arguments;
2522 cf. create_function_arglist. */
2525 create_fn_spec (gfc_symbol *sym, tree fntype)
2529 gfc_formal_arglist *f;
2532 memset (&spec, 0, sizeof (spec));
2536 if (sym->attr.entry_master)
2537 spec[spec_len++] = 'R';
2538 if (gfc_return_by_reference (sym))
2540 gfc_symbol *result = sym->result ? sym->result : sym;
2542 if (result->attr.pointer || sym->attr.proc_pointer)
2543 spec[spec_len++] = '.';
2545 spec[spec_len++] = 'w';
2546 if (sym->ts.type == BT_CHARACTER)
2547 spec[spec_len++] = 'R';
2550 for (f = sym->formal; f; f = f->next)
2551 if (spec_len < sizeof (spec))
2553 if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
2554 || f->sym->attr.external || f->sym->attr.cray_pointer
2555 || (f->sym->ts.type == BT_DERIVED
2556 && (f->sym->ts.u.derived->attr.proc_pointer_comp
2557 || f->sym->ts.u.derived->attr.pointer_comp))
2558 || (f->sym->ts.type == BT_CLASS
2559 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
2560 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)))
2561 spec[spec_len++] = '.';
2562 else if (f->sym->attr.intent == INTENT_IN)
2563 spec[spec_len++] = 'r';
2565 spec[spec_len++] = 'w';
2568 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
2569 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
2570 return build_type_attribute_variant (fntype, tmp);
2575 gfc_get_function_type (gfc_symbol * sym)
2578 VEC(tree,gc) *typelist;
2579 gfc_formal_arglist *f;
2581 int alternate_return;
2582 bool is_varargs = true;
2584 /* Make sure this symbol is a function, a subroutine or the main
2586 gcc_assert (sym->attr.flavor == FL_PROCEDURE
2587 || sym->attr.flavor == FL_PROGRAM);
2589 if (sym->backend_decl)
2590 return TREE_TYPE (sym->backend_decl);
2592 alternate_return = 0;
2595 if (sym->attr.entry_master)
2596 /* Additional parameter for selecting an entry point. */
2597 VEC_safe_push (tree, gc, typelist, gfc_array_index_type);
2604 if (arg->ts.type == BT_CHARACTER)
2605 gfc_conv_const_charlen (arg->ts.u.cl);
2607 /* Some functions we use an extra parameter for the return value. */
2608 if (gfc_return_by_reference (sym))
2610 type = gfc_sym_type (arg);
2611 if (arg->ts.type == BT_COMPLEX
2612 || arg->attr.dimension
2613 || arg->ts.type == BT_CHARACTER)
2614 type = build_reference_type (type);
2616 VEC_safe_push (tree, gc, typelist, type);
2617 if (arg->ts.type == BT_CHARACTER)
2619 if (!arg->ts.deferred)
2620 /* Transfer by value. */
2621 VEC_safe_push (tree, gc, typelist, gfc_charlen_type_node);
2623 /* Deferred character lengths are transferred by reference
2624 so that the value can be returned. */
2625 VEC_safe_push (tree, gc, typelist,
2626 build_pointer_type (gfc_charlen_type_node));
2630 /* Build the argument types for the function. */
2631 for (f = sym->formal; f; f = f->next)
2636 /* Evaluate constant character lengths here so that they can be
2637 included in the type. */
2638 if (arg->ts.type == BT_CHARACTER)
2639 gfc_conv_const_charlen (arg->ts.u.cl);
2641 if (arg->attr.flavor == FL_PROCEDURE)
2643 type = gfc_get_function_type (arg);
2644 type = build_pointer_type (type);
2647 type = gfc_sym_type (arg);
2649 /* Parameter Passing Convention
2651 We currently pass all parameters by reference.
2652 Parameters with INTENT(IN) could be passed by value.
2653 The problem arises if a function is called via an implicit
2654 prototype. In this situation the INTENT is not known.
2655 For this reason all parameters to global functions must be
2656 passed by reference. Passing by value would potentially
2657 generate bad code. Worse there would be no way of telling that
2658 this code was bad, except that it would give incorrect results.
2660 Contained procedures could pass by value as these are never
2661 used without an explicit interface, and cannot be passed as
2662 actual parameters for a dummy procedure. */
2664 VEC_safe_push (tree, gc, typelist, type);
2668 if (sym->attr.subroutine)
2669 alternate_return = 1;
2673 /* Add hidden string length parameters. */
2674 for (f = sym->formal; f; f = f->next)
2677 if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2679 if (!arg->ts.deferred)
2680 /* Transfer by value. */
2681 type = gfc_charlen_type_node;
2683 /* Deferred character lengths are transferred by reference
2684 so that the value can be returned. */
2685 type = build_pointer_type (gfc_charlen_type_node);
2687 VEC_safe_push (tree, gc, typelist, type);
2691 if (!VEC_empty (tree, typelist)
2692 || sym->attr.is_main_program
2693 || sym->attr.if_source != IFSRC_UNKNOWN)
2696 if (alternate_return)
2697 type = integer_type_node;
2698 else if (!sym->attr.function || gfc_return_by_reference (sym))
2699 type = void_type_node;
2700 else if (sym->attr.mixed_entry_master)
2701 type = gfc_get_mixed_entry_union (sym->ns);
2702 else if (gfc_option.flag_f2c
2703 && sym->ts.type == BT_REAL
2704 && sym->ts.kind == gfc_default_real_kind
2705 && !sym->attr.always_explicit)
2707 /* Special case: f2c calling conventions require that (scalar)
2708 default REAL functions return the C type double instead. f2c
2709 compatibility is only an issue with functions that don't
2710 require an explicit interface, as only these could be
2711 implemented in Fortran 77. */
2712 sym->ts.kind = gfc_default_double_kind;
2713 type = gfc_typenode_for_spec (&sym->ts);
2714 sym->ts.kind = gfc_default_real_kind;
2716 else if (sym->result && sym->result->attr.proc_pointer)
2717 /* Procedure pointer return values. */
2719 if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
2721 /* Unset proc_pointer as gfc_get_function_type
2722 is called recursively. */
2723 sym->result->attr.proc_pointer = 0;
2724 type = build_pointer_type (gfc_get_function_type (sym->result));
2725 sym->result->attr.proc_pointer = 1;
2728 type = gfc_sym_type (sym->result);
2731 type = gfc_sym_type (sym);
2734 type = build_varargs_function_type_vec (type, typelist);
2736 type = build_function_type_vec (type, typelist);
2737 type = create_fn_spec (sym, type);
2742 /* Language hooks for middle-end access to type nodes. */
2744 /* Return an integer type with BITS bits of precision,
2745 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2748 gfc_type_for_size (unsigned bits, int unsignedp)
2753 for (i = 0; i <= MAX_INT_KINDS; ++i)
2755 tree type = gfc_integer_types[i];
2756 if (type && bits == TYPE_PRECISION (type))
2760 /* Handle TImode as a special case because it is used by some backends
2761 (e.g. ARM) even though it is not available for normal use. */
2762 #if HOST_BITS_PER_WIDE_INT >= 64
2763 if (bits == TYPE_PRECISION (intTI_type_node))
2764 return intTI_type_node;
2769 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2770 return unsigned_intQI_type_node;
2771 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2772 return unsigned_intHI_type_node;
2773 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2774 return unsigned_intSI_type_node;
2775 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2776 return unsigned_intDI_type_node;
2777 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2778 return unsigned_intTI_type_node;
2784 /* Return a data type that has machine mode MODE. If the mode is an
2785 integer, then UNSIGNEDP selects between signed and unsigned types. */
2788 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2793 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2794 base = gfc_real_types;
2795 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2796 base = gfc_complex_types;
2797 else if (SCALAR_INT_MODE_P (mode))
2798 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2799 else if (VECTOR_MODE_P (mode))
2801 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2802 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2803 if (inner_type != NULL_TREE)
2804 return build_vector_type_for_mode (inner_type, mode);
2810 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2812 tree type = base[i];
2813 if (type && mode == TYPE_MODE (type))
2820 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2824 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
2827 bool indirect = false;
2828 tree etype, ptype, field, t, base_decl;
2829 tree data_off, dim_off, dim_size, elem_size;
2830 tree lower_suboff, upper_suboff, stride_suboff;
2832 if (! GFC_DESCRIPTOR_TYPE_P (type))
2834 if (! POINTER_TYPE_P (type))
2836 type = TREE_TYPE (type);
2837 if (! GFC_DESCRIPTOR_TYPE_P (type))
2842 rank = GFC_TYPE_ARRAY_RANK (type);
2843 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
2846 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2847 gcc_assert (POINTER_TYPE_P (etype));
2848 etype = TREE_TYPE (etype);
2850 /* If the type is not a scalar coarray. */
2851 if (TREE_CODE (etype) == ARRAY_TYPE)
2852 etype = TREE_TYPE (etype);
2854 /* Can't handle variable sized elements yet. */
2855 if (int_size_in_bytes (etype) <= 0)
2857 /* Nor non-constant lower bounds in assumed shape arrays. */
2858 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
2859 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
2861 for (dim = 0; dim < rank; dim++)
2862 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
2863 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
2867 memset (info, '\0', sizeof (*info));
2868 info->ndimensions = rank;
2869 info->element_type = etype;
2870 ptype = build_pointer_type (gfc_array_index_type);
2871 base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
2874 base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
2875 indirect ? build_pointer_type (ptype) : ptype);
2876 GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
2878 info->base_decl = base_decl;
2880 base_decl = build1 (INDIRECT_REF, ptype, base_decl);
2882 if (GFC_TYPE_ARRAY_SPAN (type))
2883 elem_size = GFC_TYPE_ARRAY_SPAN (type);
2885 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
2886 field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
2887 data_off = byte_position (field);
2888 field = DECL_CHAIN (field);
2889 field = DECL_CHAIN (field);
2890 field = DECL_CHAIN (field);
2891 dim_off = byte_position (field);
2892 dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
2893 field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
2894 stride_suboff = byte_position (field);
2895 field = DECL_CHAIN (field);
2896 lower_suboff = byte_position (field);
2897 field = DECL_CHAIN (field);
2898 upper_suboff = byte_position (field);
2901 if (!integer_zerop (data_off))
2902 t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
2903 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
2904 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
2905 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
2906 info->allocated = build2 (NE_EXPR, boolean_type_node,
2907 info->data_location, null_pointer_node);
2908 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
2909 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
2910 info->associated = build2 (NE_EXPR, boolean_type_node,
2911 info->data_location, null_pointer_node);
2913 for (dim = 0; dim < rank; dim++)
2915 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2916 size_binop (PLUS_EXPR, dim_off, lower_suboff));
2917 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2918 info->dimen[dim].lower_bound = t;
2919 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2920 size_binop (PLUS_EXPR, dim_off, upper_suboff));
2921 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2922 info->dimen[dim].upper_bound = t;
2923 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
2924 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
2926 /* Assumed shape arrays have known lower bounds. */
2927 info->dimen[dim].upper_bound
2928 = build2 (MINUS_EXPR, gfc_array_index_type,
2929 info->dimen[dim].upper_bound,
2930 info->dimen[dim].lower_bound);
2931 info->dimen[dim].lower_bound
2932 = fold_convert (gfc_array_index_type,
2933 GFC_TYPE_ARRAY_LBOUND (type, dim));
2934 info->dimen[dim].upper_bound
2935 = build2 (PLUS_EXPR, gfc_array_index_type,
2936 info->dimen[dim].lower_bound,
2937 info->dimen[dim].upper_bound);
2939 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2940 size_binop (PLUS_EXPR, dim_off, stride_suboff));
2941 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2942 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
2943 info->dimen[dim].stride = t;
2944 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
2950 #include "gt-fortran-trans-types.h"