1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-types.c -- gfortran backend types */
27 #include "coretypes.h"
29 #include "langhooks.h"
36 #include "trans-types.h"
37 #include "trans-const.h"
42 #if (GFC_MAX_DIMENSIONS < 10)
43 #define GFC_RANK_DIGITS 1
44 #define GFC_RANK_PRINTF_FORMAT "%01d"
45 #elif (GFC_MAX_DIMENSIONS < 100)
46 #define GFC_RANK_DIGITS 2
47 #define GFC_RANK_PRINTF_FORMAT "%02d"
49 #error If you really need >99 dimensions, continue the sequence above...
52 /* array of structs so we don't have to worry about xmalloc or free */
53 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
55 static tree gfc_get_derived_type (gfc_symbol * derived);
57 tree gfc_array_index_type;
58 tree gfc_array_range_type;
59 tree gfc_character1_type_node;
61 tree ppvoid_type_node;
65 tree gfc_charlen_type_node;
67 static GTY(()) tree gfc_desc_dim_type;
68 static GTY(()) tree gfc_max_array_element_size;
69 static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
71 /* Arrays for all integral and real kinds. We'll fill this in at runtime
72 after the target has a chance to process command-line options. */
74 #define MAX_INT_KINDS 5
75 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
76 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
77 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
78 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
80 #define MAX_REAL_KINDS 5
81 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
82 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
83 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
86 /* The integer kind to use for array indices. This will be set to the
87 proper value based on target information from the backend. */
89 int gfc_index_integer_kind;
91 /* The default kinds of the various types. */
93 int gfc_default_integer_kind;
94 int gfc_max_integer_kind;
95 int gfc_default_real_kind;
96 int gfc_default_double_kind;
97 int gfc_default_character_kind;
98 int gfc_default_logical_kind;
99 int gfc_default_complex_kind;
102 /* The kind size used for record offsets. If the target system supports
103 kind=8, this will be set to 8, otherwise it is set to 4. */
106 /* The integer kind used to store character lengths. */
107 int gfc_charlen_int_kind;
109 /* The size of the numeric storage unit and character storage unit. */
110 int gfc_numeric_storage_size;
111 int gfc_character_storage_size;
114 /* Validate that the f90_type of the given gfc_typespec is valid for
115 the type it represents. The f90_type represents the Fortran types
116 this C kind can be used with. For example, c_int has a f90_type of
117 BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
118 if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
122 gfc_validate_c_kind (gfc_typespec *ts)
124 return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
129 gfc_check_any_c_kind (gfc_typespec *ts)
133 for (i = 0; i < ISOCBINDING_NUMBER; i++)
135 /* Check for any C interoperable kind for the given type/kind in ts.
136 This can be used after verify_c_interop to make sure that the
137 Fortran kind being used exists in at least some form for C. */
138 if (c_interop_kinds_table[i].f90_type == ts->type &&
139 c_interop_kinds_table[i].value == ts->kind)
148 get_real_kind_from_node (tree type)
152 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
153 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
154 return gfc_real_kinds[i].kind;
160 get_int_kind_from_node (tree type)
167 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
168 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
169 return gfc_integer_kinds[i].kind;
175 get_int_kind_from_width (int size)
179 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
180 if (gfc_integer_kinds[i].bit_size == size)
181 return gfc_integer_kinds[i].kind;
187 get_int_kind_from_minimal_width (int size)
191 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
192 if (gfc_integer_kinds[i].bit_size >= size)
193 return gfc_integer_kinds[i].kind;
199 /* Generate the CInteropKind_t objects for the C interoperable
203 void init_c_interop_kinds (void)
206 tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
208 (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
209 long_integer_type_node :
210 long_long_integer_type_node);
212 /* init all pointers in the list to NULL */
213 for (i = 0; i < ISOCBINDING_NUMBER; i++)
215 /* Initialize the name and value fields. */
216 c_interop_kinds_table[i].name[0] = '\0';
217 c_interop_kinds_table[i].value = -100;
218 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
221 #define NAMED_INTCST(a,b,c) \
222 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
223 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
224 c_interop_kinds_table[a].value = c;
225 #define NAMED_REALCST(a,b,c) \
226 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
227 c_interop_kinds_table[a].f90_type = BT_REAL; \
228 c_interop_kinds_table[a].value = c;
229 #define NAMED_CMPXCST(a,b,c) \
230 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
231 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
232 c_interop_kinds_table[a].value = c;
233 #define NAMED_LOGCST(a,b,c) \
234 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
235 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
236 c_interop_kinds_table[a].value = c;
237 #define NAMED_CHARKNDCST(a,b,c) \
238 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
239 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
240 c_interop_kinds_table[a].value = c;
241 #define NAMED_CHARCST(a,b,c) \
242 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
243 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
244 c_interop_kinds_table[a].value = c;
245 #define DERIVED_TYPE(a,b,c) \
246 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
247 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
248 c_interop_kinds_table[a].value = c;
249 #define PROCEDURE(a,b) \
250 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
251 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
252 c_interop_kinds_table[a].value = 0;
253 #include "iso-c-binding.def"
257 /* Query the target to determine which machine modes are available for
258 computation. Choose KIND numbers for them. */
261 gfc_init_kinds (void)
263 enum machine_mode mode;
264 int i_index, r_index;
265 bool saw_i4 = false, saw_i8 = false;
266 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
268 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
272 if (!targetm.scalar_mode_supported_p (mode))
275 /* The middle end doesn't support constants larger than 2*HWI.
276 Perhaps the target hook shouldn't have accepted these either,
277 but just to be safe... */
278 bitsize = GET_MODE_BITSIZE (mode);
279 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
282 gcc_assert (i_index != MAX_INT_KINDS);
284 /* Let the kind equal the bit size divided by 8. This insulates the
285 programmer from the underlying byte size. */
293 gfc_integer_kinds[i_index].kind = kind;
294 gfc_integer_kinds[i_index].radix = 2;
295 gfc_integer_kinds[i_index].digits = bitsize - 1;
296 gfc_integer_kinds[i_index].bit_size = bitsize;
298 gfc_logical_kinds[i_index].kind = kind;
299 gfc_logical_kinds[i_index].bit_size = bitsize;
304 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
305 used for large file access. */
312 /* If we do not at least have kind = 4, everything is pointless. */
315 /* Set the maximum integer kind. Used with at least BOZ constants. */
316 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
318 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
320 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
325 if (!targetm.scalar_mode_supported_p (mode))
328 /* Only let float/double/long double go through because the fortran
329 library assumes these are the only floating point types. */
331 if (mode != TYPE_MODE (float_type_node)
332 && (mode != TYPE_MODE (double_type_node))
333 && (mode != TYPE_MODE (long_double_type_node)))
336 /* Let the kind equal the precision divided by 8, rounding up. Again,
337 this insulates the programmer from the underlying byte size.
339 Also, it effectively deals with IEEE extended formats. There, the
340 total size of the type may equal 16, but it's got 6 bytes of padding
341 and the increased size can get in the way of a real IEEE quad format
342 which may also be supported by the target.
344 We round up so as to handle IA-64 __floatreg (RFmode), which is an
345 82 bit type. Not to be confused with __float80 (XFmode), which is
346 an 80 bit type also supported by IA-64. So XFmode should come out
347 to be kind=10, and RFmode should come out to be kind=11. Egads. */
349 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
358 /* Careful we don't stumble a wierd internal mode. */
359 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
360 /* Or have too many modes for the allocated space. */
361 gcc_assert (r_index != MAX_REAL_KINDS);
363 gfc_real_kinds[r_index].kind = kind;
364 gfc_real_kinds[r_index].radix = fmt->b;
365 gfc_real_kinds[r_index].digits = fmt->p;
366 gfc_real_kinds[r_index].min_exponent = fmt->emin;
367 gfc_real_kinds[r_index].max_exponent = fmt->emax;
368 if (fmt->pnan < fmt->p)
369 /* This is an IBM extended double format (or the MIPS variant)
370 made up of two IEEE doubles. The value of the long double is
371 the sum of the values of the two parts. The most significant
372 part is required to be the value of the long double rounded
373 to the nearest double. If we use emax of 1024 then we can't
374 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
375 rounding will make the most significant part overflow. */
376 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
377 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
381 /* Choose the default integer kind. We choose 4 unless the user
382 directs us otherwise. */
383 if (gfc_option.flag_default_integer)
386 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
387 gfc_default_integer_kind = 8;
389 /* Even if the user specified that the default integer kind be 8,
390 the numerica storage size isn't 64. In this case, a warning will
391 be issued when NUMERIC_STORAGE_SIZE is used. */
392 gfc_numeric_storage_size = 4 * 8;
396 gfc_default_integer_kind = 4;
397 gfc_numeric_storage_size = 4 * 8;
401 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
402 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
405 /* Choose the default real kind. Again, we choose 4 when possible. */
406 if (gfc_option.flag_default_real)
409 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
410 gfc_default_real_kind = 8;
413 gfc_default_real_kind = 4;
415 gfc_default_real_kind = gfc_real_kinds[0].kind;
417 /* Choose the default double kind. If -fdefault-real and -fdefault-double
418 are specified, we use kind=8, if it's available. If -fdefault-real is
419 specified without -fdefault-double, we use kind=16, if it's available.
420 Otherwise we do not change anything. */
421 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
422 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
424 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
425 gfc_default_double_kind = 8;
426 else if (gfc_option.flag_default_real && saw_r16)
427 gfc_default_double_kind = 16;
428 else if (saw_r4 && saw_r8)
429 gfc_default_double_kind = 8;
432 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
433 real ... occupies two contiguous numeric storage units.
435 Therefore we must be supplied a kind twice as large as we chose
436 for single precision. There are loopholes, in that double
437 precision must *occupy* two storage units, though it doesn't have
438 to *use* two storage units. Which means that you can make this
439 kind artificially wide by padding it. But at present there are
440 no GCC targets for which a two-word type does not exist, so we
441 just let gfc_validate_kind abort and tell us if something breaks. */
443 gfc_default_double_kind
444 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
447 /* The default logical kind is constrained to be the same as the
448 default integer kind. Similarly with complex and real. */
449 gfc_default_logical_kind = gfc_default_integer_kind;
450 gfc_default_complex_kind = gfc_default_real_kind;
452 /* Choose the smallest integer kind for our default character. */
453 gfc_default_character_kind = gfc_integer_kinds[0].kind;
454 gfc_character_storage_size = gfc_default_character_kind * 8;
456 /* Choose the integer kind the same size as "void*" for our index kind. */
457 gfc_index_integer_kind = POINTER_SIZE / 8;
458 /* Pick a kind the same size as the C "int" type. */
459 gfc_c_int_kind = INT_TYPE_SIZE / 8;
461 /* initialize the C interoperable kinds */
462 init_c_interop_kinds();
465 /* Make sure that a valid kind is present. Returns an index into the
466 associated kinds array, -1 if the kind is not present. */
469 validate_integer (int kind)
473 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
474 if (gfc_integer_kinds[i].kind == kind)
481 validate_real (int kind)
485 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
486 if (gfc_real_kinds[i].kind == kind)
493 validate_logical (int kind)
497 for (i = 0; gfc_logical_kinds[i].kind; i++)
498 if (gfc_logical_kinds[i].kind == kind)
505 validate_character (int kind)
507 return kind == gfc_default_character_kind ? 0 : -1;
510 /* Validate a kind given a basic type. The return value is the same
511 for the child functions, with -1 indicating nonexistence of the
512 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
515 gfc_validate_kind (bt type, int kind, bool may_fail)
521 case BT_REAL: /* Fall through */
523 rc = validate_real (kind);
526 rc = validate_integer (kind);
529 rc = validate_logical (kind);
532 rc = validate_character (kind);
536 gfc_internal_error ("gfc_validate_kind(): Got bad type");
539 if (rc < 0 && !may_fail)
540 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
546 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
547 Reuse common type nodes where possible. Recognize if the kind matches up
548 with a C type. This will be used later in determining which routines may
549 be scarfed from libm. */
552 gfc_build_int_type (gfc_integer_info *info)
554 int mode_precision = info->bit_size;
556 if (mode_precision == CHAR_TYPE_SIZE)
558 if (mode_precision == SHORT_TYPE_SIZE)
560 if (mode_precision == INT_TYPE_SIZE)
562 if (mode_precision == LONG_TYPE_SIZE)
564 if (mode_precision == LONG_LONG_TYPE_SIZE)
565 info->c_long_long = 1;
567 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
568 return intQI_type_node;
569 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
570 return intHI_type_node;
571 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
572 return intSI_type_node;
573 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
574 return intDI_type_node;
575 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
576 return intTI_type_node;
578 return make_signed_type (mode_precision);
582 gfc_build_real_type (gfc_real_info *info)
584 int mode_precision = info->mode_precision;
587 if (mode_precision == FLOAT_TYPE_SIZE)
589 if (mode_precision == DOUBLE_TYPE_SIZE)
591 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
592 info->c_long_double = 1;
594 if (TYPE_PRECISION (float_type_node) == mode_precision)
595 return float_type_node;
596 if (TYPE_PRECISION (double_type_node) == mode_precision)
597 return double_type_node;
598 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
599 return long_double_type_node;
601 new_type = make_node (REAL_TYPE);
602 TYPE_PRECISION (new_type) = mode_precision;
603 layout_type (new_type);
608 gfc_build_complex_type (tree scalar_type)
612 if (scalar_type == NULL)
614 if (scalar_type == float_type_node)
615 return complex_float_type_node;
616 if (scalar_type == double_type_node)
617 return complex_double_type_node;
618 if (scalar_type == long_double_type_node)
619 return complex_long_double_type_node;
621 new_type = make_node (COMPLEX_TYPE);
622 TREE_TYPE (new_type) = scalar_type;
623 layout_type (new_type);
628 gfc_build_logical_type (gfc_logical_info *info)
630 int bit_size = info->bit_size;
633 if (bit_size == BOOL_TYPE_SIZE)
636 return boolean_type_node;
639 new_type = make_unsigned_type (bit_size);
640 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
641 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
642 TYPE_PRECISION (new_type) = 1;
648 /* Return the bit size of the C "size_t". */
654 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
655 return INT_TYPE_SIZE;
656 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
657 return LONG_TYPE_SIZE;
658 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
659 return SHORT_TYPE_SIZE;
662 return LONG_TYPE_SIZE;
667 /* Create the backend type nodes. We map them to their
668 equivalent C type, at least for now. We also give
669 names to the types here, and we push them in the
670 global binding level context.*/
673 gfc_init_types (void)
679 unsigned HOST_WIDE_INT hi;
680 unsigned HOST_WIDE_INT lo;
682 /* Create and name the types. */
683 #define PUSH_TYPE(name, node) \
684 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
686 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
688 type = gfc_build_int_type (&gfc_integer_kinds[index]);
689 gfc_integer_types[index] = type;
690 snprintf (name_buf, sizeof(name_buf), "int%d",
691 gfc_integer_kinds[index].kind);
692 PUSH_TYPE (name_buf, type);
695 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
697 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
698 gfc_logical_types[index] = type;
699 snprintf (name_buf, sizeof(name_buf), "logical%d",
700 gfc_logical_kinds[index].kind);
701 PUSH_TYPE (name_buf, type);
704 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
706 type = gfc_build_real_type (&gfc_real_kinds[index]);
707 gfc_real_types[index] = type;
708 snprintf (name_buf, sizeof(name_buf), "real%d",
709 gfc_real_kinds[index].kind);
710 PUSH_TYPE (name_buf, type);
712 type = gfc_build_complex_type (type);
713 gfc_complex_types[index] = type;
714 snprintf (name_buf, sizeof(name_buf), "complex%d",
715 gfc_real_kinds[index].kind);
716 PUSH_TYPE (name_buf, type);
719 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
721 PUSH_TYPE ("char", gfc_character1_type_node);
723 PUSH_TYPE ("byte", unsigned_char_type_node);
724 PUSH_TYPE ("void", void_type_node);
726 /* DBX debugging output gets upset if these aren't set. */
727 if (!TYPE_NAME (integer_type_node))
728 PUSH_TYPE ("c_integer", integer_type_node);
729 if (!TYPE_NAME (char_type_node))
730 PUSH_TYPE ("c_char", char_type_node);
734 pvoid_type_node = build_pointer_type (void_type_node);
735 ppvoid_type_node = build_pointer_type (pvoid_type_node);
736 pchar_type_node = build_pointer_type (gfc_character1_type_node);
738 = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
740 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
741 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
742 since this function is called before gfc_init_constants. */
744 = build_range_type (gfc_array_index_type,
745 build_int_cst (gfc_array_index_type, 0),
748 /* The maximum array element size that can be handled is determined
749 by the number of bits available to store this field in the array
752 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
753 lo = ~ (unsigned HOST_WIDE_INT) 0;
754 if (n > HOST_BITS_PER_WIDE_INT)
755 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
757 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
758 gfc_max_array_element_size
759 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
761 size_type_node = gfc_array_index_type;
763 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
764 boolean_true_node = build_int_cst (boolean_type_node, 1);
765 boolean_false_node = build_int_cst (boolean_type_node, 0);
767 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
768 gfc_charlen_int_kind = 4;
769 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
772 /* Get the type node for the given type and kind. */
775 gfc_get_int_type (int kind)
777 int index = gfc_validate_kind (BT_INTEGER, kind, true);
778 return index < 0 ? 0 : gfc_integer_types[index];
782 gfc_get_real_type (int kind)
784 int index = gfc_validate_kind (BT_REAL, kind, true);
785 return index < 0 ? 0 : gfc_real_types[index];
789 gfc_get_complex_type (int kind)
791 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
792 return index < 0 ? 0 : gfc_complex_types[index];
796 gfc_get_logical_type (int kind)
798 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
799 return index < 0 ? 0 : gfc_logical_types[index];
802 /* Create a character type with the given kind and length. */
805 gfc_get_character_type_len (int kind, tree len)
809 gfc_validate_kind (BT_CHARACTER, kind, false);
811 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
812 type = build_array_type (gfc_character1_type_node, bounds);
813 TYPE_STRING_FLAG (type) = 1;
819 /* Get a type node for a character kind. */
822 gfc_get_character_type (int kind, gfc_charlen * cl)
826 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
828 return gfc_get_character_type_len (kind, len);
831 /* Covert a basic type. This will be an array for character types. */
834 gfc_typenode_for_spec (gfc_typespec * spec)
844 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
845 has been resolved. This is done so we can convert C_PTR and
846 C_FUNPTR to simple variables that get translated to (void *). */
847 if (spec->f90_type == BT_VOID)
850 && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
851 basetype = ptr_type_node;
853 basetype = pfunc_type_node;
856 basetype = gfc_get_int_type (spec->kind);
860 basetype = gfc_get_real_type (spec->kind);
864 basetype = gfc_get_complex_type (spec->kind);
868 basetype = gfc_get_logical_type (spec->kind);
872 basetype = gfc_get_character_type (spec->kind, spec->cl);
876 basetype = gfc_get_derived_type (spec->derived);
878 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
879 type and kind to fit a (void *) and the basetype returned was a
880 ptr_type_node. We need to pass up this new information to the
881 symbol that was declared of type C_PTR or C_FUNPTR. */
882 if (spec->derived->attr.is_iso_c)
884 spec->type = spec->derived->ts.type;
885 spec->kind = spec->derived->ts.kind;
886 spec->f90_type = spec->derived->ts.f90_type;
890 /* This is for the second arg to c_f_pointer and c_f_procpointer
891 of the iso_c_binding module, to accept any ptr type. */
892 basetype = ptr_type_node;
893 if (spec->f90_type == BT_VOID)
896 && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
897 basetype = ptr_type_node;
899 basetype = pfunc_type_node;
908 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
911 gfc_conv_array_bound (gfc_expr * expr)
913 /* If expr is an integer constant, return that. */
914 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
915 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
917 /* Otherwise return NULL. */
922 gfc_get_element_type (tree type)
926 if (GFC_ARRAY_TYPE_P (type))
928 if (TREE_CODE (type) == POINTER_TYPE)
929 type = TREE_TYPE (type);
930 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
931 element = TREE_TYPE (type);
935 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
936 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
938 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
939 element = TREE_TYPE (element);
941 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
942 element = TREE_TYPE (element);
948 /* Build an array. This function is called from gfc_sym_type().
949 Actually returns array descriptor type.
951 Format of array descriptors is as follows:
953 struct gfc_array_descriptor
958 struct descriptor_dimension dimension[N_DIM];
961 struct descriptor_dimension
968 Translation code should use gfc_conv_descriptor_* rather than
969 accessing the descriptor directly. Any changes to the array
970 descriptor type will require changes in gfc_conv_descriptor_* and
971 gfc_build_array_initializer.
973 This is represented internally as a RECORD_TYPE. The index nodes
974 are gfc_array_index_type and the data node is a pointer to the
975 data. See below for the handling of character types.
977 The dtype member is formatted as follows:
978 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
979 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
980 size = dtype >> GFC_DTYPE_SIZE_SHIFT
982 I originally used nested ARRAY_TYPE nodes to represent arrays, but
983 this generated poor code for assumed/deferred size arrays. These
984 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
985 of the GENERIC grammar. Also, there is no way to explicitly set
986 the array stride, so all data must be packed(1). I've tried to
987 mark all the functions which would require modification with a GCC
990 The data component points to the first element in the array. The
991 offset field is the position of the origin of the array (ie element
992 (0, 0 ...)). This may be outsite the bounds of the array.
994 An element is accessed by
995 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
996 This gives good performance as the computation does not involve the
997 bounds of the array. For packed arrays, this is optimized further
998 by substituting the known strides.
1000 This system has one problem: all array bounds must be within 2^31
1001 elements of the origin (2^63 on 64-bit machines). For example
1002 integer, dimension (80000:90000, 80000:90000, 2) :: array
1003 may not work properly on 32-bit machines because 80000*80000 >
1004 2^31, so the calculation for stride02 would overflow. This may
1005 still work, but I haven't checked, and it relies on the overflow
1006 doing the right thing.
1008 The way to fix this problem is to access elements as follows:
1009 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1010 Obviously this is much slower. I will make this a compile time
1011 option, something like -fsmall-array-offsets. Mixing code compiled
1012 with and without this switch will work.
1014 (1) This can be worked around by modifying the upper bound of the
1015 previous dimension. This requires extra fields in the descriptor
1016 (both real_ubound and fake_ubound). */
1019 /* Returns true if the array sym does not require a descriptor. */
1022 gfc_is_nodesc_array (gfc_symbol * sym)
1024 gcc_assert (sym->attr.dimension);
1026 /* We only want local arrays. */
1027 if (sym->attr.pointer || sym->attr.allocatable)
1030 if (sym->attr.dummy)
1032 if (sym->as->type != AS_ASSUMED_SHAPE)
1038 if (sym->attr.result || sym->attr.function)
1041 gcc_assert (sym->as->type == AS_EXPLICIT);
1047 /* Create an array descriptor type. */
1050 gfc_build_array_type (tree type, gfc_array_spec * as)
1052 tree lbound[GFC_MAX_DIMENSIONS];
1053 tree ubound[GFC_MAX_DIMENSIONS];
1056 for (n = 0; n < as->rank; n++)
1058 /* Create expressions for the known bounds of the array. */
1059 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1060 lbound[n] = gfc_index_one_node;
1062 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1063 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1066 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
1069 /* Returns the struct descriptor_dimension type. */
1072 gfc_get_desc_dim_type (void)
1078 if (gfc_desc_dim_type)
1079 return gfc_desc_dim_type;
1081 /* Build the type node. */
1082 type = make_node (RECORD_TYPE);
1084 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1085 TYPE_PACKED (type) = 1;
1087 /* Consists of the stride, lbound and ubound members. */
1088 decl = build_decl (FIELD_DECL,
1089 get_identifier ("stride"), gfc_array_index_type);
1090 DECL_CONTEXT (decl) = type;
1093 decl = build_decl (FIELD_DECL,
1094 get_identifier ("lbound"), gfc_array_index_type);
1095 DECL_CONTEXT (decl) = type;
1096 fieldlist = chainon (fieldlist, decl);
1098 decl = build_decl (FIELD_DECL,
1099 get_identifier ("ubound"), gfc_array_index_type);
1100 DECL_CONTEXT (decl) = type;
1101 fieldlist = chainon (fieldlist, decl);
1103 /* Finish off the type. */
1104 TYPE_FIELDS (type) = fieldlist;
1106 gfc_finish_type (type);
1107 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1109 gfc_desc_dim_type = type;
1114 /* Return the DTYPE for an array. This describes the type and type parameters
1116 /* TODO: Only call this when the value is actually used, and make all the
1117 unknown cases abort. */
1120 gfc_get_dtype (tree type)
1130 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1132 if (GFC_TYPE_ARRAY_DTYPE (type))
1133 return GFC_TYPE_ARRAY_DTYPE (type);
1135 rank = GFC_TYPE_ARRAY_RANK (type);
1136 etype = gfc_get_element_type (type);
1138 switch (TREE_CODE (etype))
1141 n = GFC_DTYPE_INTEGER;
1145 n = GFC_DTYPE_LOGICAL;
1153 n = GFC_DTYPE_COMPLEX;
1156 /* We will never have arrays of arrays. */
1158 n = GFC_DTYPE_DERIVED;
1162 n = GFC_DTYPE_CHARACTER;
1166 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1167 /* We can strange array types for temporary arrays. */
1168 return gfc_index_zero_node;
1171 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1172 size = TYPE_SIZE_UNIT (etype);
1174 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1175 if (size && INTEGER_CST_P (size))
1177 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1178 internal_error ("Array element size too big");
1180 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1182 dtype = build_int_cst (gfc_array_index_type, i);
1184 if (size && !INTEGER_CST_P (size))
1186 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1187 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
1188 fold_convert (gfc_array_index_type, size), tmp);
1189 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
1191 /* If we don't know the size we leave it as zero. This should never happen
1192 for anything that is actually used. */
1193 /* TODO: Check this is actually true, particularly when repacking
1194 assumed size parameters. */
1196 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1201 /* Build an array type for use without a descriptor, packed according
1202 to the value of PACKED. */
1205 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
1218 mpz_init_set_ui (offset, 0);
1219 mpz_init_set_ui (stride, 1);
1222 /* We don't use build_array_type because this does not include include
1223 lang-specific information (i.e. the bounds of the array) when checking
1225 type = make_node (ARRAY_TYPE);
1227 GFC_ARRAY_TYPE_P (type) = 1;
1228 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1229 ggc_alloc_cleared (sizeof (struct lang_type));
1231 known_stride = (packed != PACKED_NO);
1233 for (n = 0; n < as->rank; n++)
1235 /* Fill in the stride and bound components of the type. */
1237 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1240 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1242 expr = as->lower[n];
1243 if (expr->expr_type == EXPR_CONSTANT)
1245 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1246 gfc_index_integer_kind);
1253 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1257 /* Calculate the offset. */
1258 mpz_mul (delta, stride, as->lower[n]->value.integer);
1259 mpz_sub (offset, offset, delta);
1264 expr = as->upper[n];
1265 if (expr && expr->expr_type == EXPR_CONSTANT)
1267 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1268 gfc_index_integer_kind);
1275 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1279 /* Calculate the stride. */
1280 mpz_sub (delta, as->upper[n]->value.integer,
1281 as->lower[n]->value.integer);
1282 mpz_add_ui (delta, delta, 1);
1283 mpz_mul (stride, stride, delta);
1286 /* Only the first stride is known for partial packed arrays. */
1287 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1293 GFC_TYPE_ARRAY_OFFSET (type) =
1294 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1297 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1301 GFC_TYPE_ARRAY_SIZE (type) =
1302 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1305 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1307 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1308 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1309 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1311 /* TODO: use main type if it is unbounded. */
1312 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1313 build_pointer_type (build_array_type (etype, range));
1317 mpz_sub_ui (stride, stride, 1);
1318 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1323 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1324 TYPE_DOMAIN (type) = range;
1326 build_pointer_type (etype);
1327 TREE_TYPE (type) = etype;
1335 /* In debug info represent packed arrays as multi-dimensional
1336 if they have rank > 1 and with proper bounds, instead of flat
1338 if (known_stride && write_symbols != NO_DEBUG)
1340 tree gtype = etype, rtype, type_decl;
1342 for (n = as->rank - 1; n >= 0; n--)
1344 rtype = build_range_type (gfc_array_index_type,
1345 GFC_TYPE_ARRAY_LBOUND (type, n),
1346 GFC_TYPE_ARRAY_UBOUND (type, n));
1347 gtype = build_array_type (gtype, rtype);
1349 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
1350 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1353 if (packed != PACKED_STATIC || !known_stride)
1355 /* For dummy arrays and automatic (heap allocated) arrays we
1356 want a pointer to the array. */
1357 type = build_pointer_type (type);
1358 GFC_ARRAY_TYPE_P (type) = 1;
1359 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1364 /* Return or create the base type for an array descriptor. */
1367 gfc_get_array_descriptor_base (int dimen)
1369 tree fat_type, fieldlist, decl, arraytype;
1370 char name[16 + GFC_RANK_DIGITS + 1];
1372 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1373 if (gfc_array_descriptor_base[dimen - 1])
1374 return gfc_array_descriptor_base[dimen - 1];
1376 /* Build the type node. */
1377 fat_type = make_node (RECORD_TYPE);
1379 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1380 TYPE_NAME (fat_type) = get_identifier (name);
1382 /* Add the data member as the first element of the descriptor. */
1383 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1385 DECL_CONTEXT (decl) = fat_type;
1388 /* Add the base component. */
1389 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1390 gfc_array_index_type);
1391 DECL_CONTEXT (decl) = fat_type;
1392 fieldlist = chainon (fieldlist, decl);
1394 /* Add the dtype component. */
1395 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1396 gfc_array_index_type);
1397 DECL_CONTEXT (decl) = fat_type;
1398 fieldlist = chainon (fieldlist, decl);
1400 /* Build the array type for the stride and bound components. */
1402 build_array_type (gfc_get_desc_dim_type (),
1403 build_range_type (gfc_array_index_type,
1404 gfc_index_zero_node,
1405 gfc_rank_cst[dimen - 1]));
1407 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1408 DECL_CONTEXT (decl) = fat_type;
1409 fieldlist = chainon (fieldlist, decl);
1411 /* Finish off the type. */
1412 TYPE_FIELDS (fat_type) = fieldlist;
1414 gfc_finish_type (fat_type);
1415 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1417 gfc_array_descriptor_base[dimen - 1] = fat_type;
1421 /* Build an array (descriptor) type with given bounds. */
1424 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1425 tree * ubound, int packed)
1427 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1428 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1429 const char *typename;
1432 base_type = gfc_get_array_descriptor_base (dimen);
1433 fat_type = build_variant_type_copy (base_type);
1435 tmp = TYPE_NAME (etype);
1436 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1437 tmp = DECL_NAME (tmp);
1439 typename = IDENTIFIER_POINTER (tmp);
1441 typename = "unknown";
1442 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1443 GFC_MAX_SYMBOL_LEN, typename);
1444 TYPE_NAME (fat_type) = get_identifier (name);
1446 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1447 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1448 ggc_alloc_cleared (sizeof (struct lang_type));
1450 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1451 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1453 /* Build an array descriptor record type. */
1455 stride = gfc_index_one_node;
1458 for (n = 0; n < dimen; n++)
1460 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1467 if (lower != NULL_TREE)
1469 if (INTEGER_CST_P (lower))
1470 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1476 if (upper != NULL_TREE)
1478 if (INTEGER_CST_P (upper))
1479 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1484 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1486 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1487 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1488 gfc_index_one_node);
1490 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1491 /* Check the folding worked. */
1492 gcc_assert (INTEGER_CST_P (stride));
1497 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1499 /* TODO: known offsets for descriptors. */
1500 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1502 /* We define data as an unknown size array. Much better than doing
1503 pointer arithmetic. */
1505 build_array_type (etype, gfc_array_range_type);
1506 arraytype = build_pointer_type (arraytype);
1507 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1512 /* Build a pointer type. This function is called from gfc_sym_type(). */
1515 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1517 /* Array pointer types aren't actually pointers. */
1518 if (sym->attr.dimension)
1521 return build_pointer_type (type);
1524 /* Return the type for a symbol. Special handling is required for character
1525 types to get the correct level of indirection.
1526 For functions return the return type.
1527 For subroutines return void_type_node.
1528 Calling this multiple times for the same symbol should be avoided,
1529 especially for character and array types. */
1532 gfc_sym_type (gfc_symbol * sym)
1537 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1538 return void_type_node;
1540 /* In the case of a function the fake result variable may have a
1541 type different from the function type, so don't return early in
1543 if (sym->backend_decl && !sym->attr.function)
1544 return TREE_TYPE (sym->backend_decl);
1546 type = gfc_typenode_for_spec (&sym->ts);
1548 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1553 if (sym->attr.dimension)
1555 if (gfc_is_nodesc_array (sym))
1557 /* If this is a character argument of unknown length, just use the
1559 if (sym->ts.type != BT_CHARACTER
1560 || !(sym->attr.dummy || sym->attr.function)
1561 || sym->ts.cl->backend_decl)
1563 type = gfc_get_nodesc_array_type (type, sym->as,
1571 type = gfc_build_array_type (type, sym->as);
1576 if (sym->attr.allocatable || sym->attr.pointer)
1577 type = gfc_build_pointer_type (sym, type);
1578 if (sym->attr.pointer)
1579 GFC_POINTER_TYPE_P (type) = 1;
1582 /* We currently pass all parameters by reference.
1583 See f95_get_function_decl. For dummy function parameters return the
1587 /* We must use pointer types for potentially absent variables. The
1588 optimizers assume a reference type argument is never NULL. */
1589 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1590 type = build_pointer_type (type);
1592 type = build_reference_type (type);
1598 /* Layout and output debug info for a record type. */
1601 gfc_finish_type (tree type)
1605 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1606 TYPE_STUB_DECL (type) = decl;
1608 rest_of_type_compilation (type, 1);
1609 rest_of_decl_compilation (decl, 1, 0);
1612 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1613 or RECORD_TYPE pointed to by STYPE. The new field is chained
1614 to the fieldlist pointed to by FIELDLIST.
1616 Returns a pointer to the new field. */
1619 gfc_add_field_to_struct (tree *fieldlist, tree context,
1620 tree name, tree type)
1624 decl = build_decl (FIELD_DECL, name, type);
1626 DECL_CONTEXT (decl) = context;
1627 DECL_INITIAL (decl) = 0;
1628 DECL_ALIGN (decl) = 0;
1629 DECL_USER_ALIGN (decl) = 0;
1630 TREE_CHAIN (decl) = NULL_TREE;
1631 *fieldlist = chainon (*fieldlist, decl);
1637 /* Copy the backend_decl and component backend_decls if
1638 the two derived type symbols are "equal", as described
1639 in 4.4.2 and resolved by gfc_compare_derived_types. */
1642 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1644 gfc_component *to_cm;
1645 gfc_component *from_cm;
1647 if (from->backend_decl == NULL
1648 || !gfc_compare_derived_types (from, to))
1651 to->backend_decl = from->backend_decl;
1653 to_cm = to->components;
1654 from_cm = from->components;
1656 /* Copy the component declarations. If a component is itself
1657 a derived type, we need a copy of its component declarations.
1658 This is done by recursing into gfc_get_derived_type and
1659 ensures that the component's component declarations have
1660 been built. If it is a character, we need the character
1662 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1664 to_cm->backend_decl = from_cm->backend_decl;
1665 if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
1666 gfc_get_derived_type (to_cm->ts.derived);
1668 else if (from_cm->ts.type == BT_CHARACTER)
1669 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1676 /* Build a tree node for a derived type. If there are equal
1677 derived types, with different local names, these are built
1678 at the same time. If an equal derived type has been built
1679 in a parent namespace, this is used. */
1682 gfc_get_derived_type (gfc_symbol * derived)
1684 tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1688 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1690 /* See if it's one of the iso_c_binding derived types. */
1691 if (derived->attr.is_iso_c == 1)
1693 if (derived->backend_decl)
1694 return derived->backend_decl;
1696 if (derived->intmod_sym_id == ISOCBINDING_PTR)
1697 derived->backend_decl = ptr_type_node;
1699 derived->backend_decl = pfunc_type_node;
1701 /* Create a backend_decl for the __c_ptr_c_address field. */
1702 derived->components->backend_decl =
1703 gfc_add_field_to_struct (&(derived->backend_decl->type.values),
1704 derived->backend_decl,
1705 get_identifier (derived->components->name),
1706 gfc_typenode_for_spec (
1707 &(derived->components->ts)));
1709 derived->ts.kind = gfc_index_integer_kind;
1710 derived->ts.type = BT_INTEGER;
1711 /* Set the f90_type to BT_VOID as a way to recognize something of type
1712 BT_INTEGER that needs to fit a void * for the purpose of the
1713 iso_c_binding derived types. */
1714 derived->ts.f90_type = BT_VOID;
1716 return derived->backend_decl;
1719 /* derived->backend_decl != 0 means we saw it before, but its
1720 components' backend_decl may have not been built. */
1721 if (derived->backend_decl)
1723 /* Its components' backend_decl have been built. */
1724 if (TYPE_FIELDS (derived->backend_decl))
1725 return derived->backend_decl;
1727 typenode = derived->backend_decl;
1732 /* We see this derived type first time, so build the type node. */
1733 typenode = make_node (RECORD_TYPE);
1734 TYPE_NAME (typenode) = get_identifier (derived->name);
1735 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1736 derived->backend_decl = typenode;
1739 /* Go through the derived type components, building them as
1740 necessary. The reason for doing this now is that it is
1741 possible to recurse back to this derived type through a
1742 pointer component (PR24092). If this happens, the fields
1743 will be built and so we can return the type. */
1744 for (c = derived->components; c; c = c->next)
1746 if (c->ts.type != BT_DERIVED)
1749 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1750 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1752 if (c->ts.derived && c->ts.derived->attr.is_iso_c)
1754 /* Need to copy the modified ts from the derived type. The
1755 typespec was modified because C_PTR/C_FUNPTR are translated
1756 into (void *) from derived types. */
1757 c->ts.type = c->ts.derived->ts.type;
1758 c->ts.kind = c->ts.derived->ts.kind;
1759 c->ts.f90_type = c->ts.derived->ts.f90_type;
1762 c->initializer->ts.type = c->ts.type;
1763 c->initializer->ts.kind = c->ts.kind;
1764 c->initializer->ts.f90_type = c->ts.f90_type;
1765 c->initializer->expr_type = EXPR_NULL;
1770 if (TYPE_FIELDS (derived->backend_decl))
1771 return derived->backend_decl;
1773 /* Build the type member list. Install the newly created RECORD_TYPE
1774 node as DECL_CONTEXT of each FIELD_DECL. */
1775 fieldlist = NULL_TREE;
1776 for (c = derived->components; c; c = c->next)
1778 if (c->ts.type == BT_DERIVED)
1779 field_type = c->ts.derived->backend_decl;
1782 if (c->ts.type == BT_CHARACTER)
1784 /* Evaluate the string length. */
1785 gfc_conv_const_charlen (c->ts.cl);
1786 gcc_assert (c->ts.cl->backend_decl);
1789 field_type = gfc_typenode_for_spec (&c->ts);
1792 /* This returns an array descriptor type. Initialization may be
1796 if (c->pointer || c->allocatable)
1798 /* Pointers to arrays aren't actually pointer types. The
1799 descriptors are separate, but the data is common. */
1800 field_type = gfc_build_array_type (field_type, c->as);
1803 field_type = gfc_get_nodesc_array_type (field_type, c->as,
1806 else if (c->pointer)
1807 field_type = build_pointer_type (field_type);
1809 field = gfc_add_field_to_struct (&fieldlist, typenode,
1810 get_identifier (c->name),
1813 gfc_set_decl_location (field, &c->loc);
1814 else if (derived->declared_at.lb)
1815 gfc_set_decl_location (field, &derived->declared_at);
1817 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1820 if (!c->backend_decl)
1821 c->backend_decl = field;
1824 /* Now we have the final fieldlist. Record it, then lay out the
1825 derived type, including the fields. */
1826 TYPE_FIELDS (typenode) = fieldlist;
1828 gfc_finish_type (typenode);
1829 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
1831 derived->backend_decl = typenode;
1833 /* Add this backend_decl to all the other, equal derived types. */
1834 for (dt = gfc_derived_types; dt; dt = dt->next)
1835 copy_dt_decls_ifequal (derived, dt->derived);
1837 return derived->backend_decl;
1842 gfc_return_by_reference (gfc_symbol * sym)
1844 if (!sym->attr.function)
1847 if (sym->attr.dimension)
1850 if (sym->ts.type == BT_CHARACTER)
1853 /* Possibly return complex numbers by reference for g77 compatibility.
1854 We don't do this for calls to intrinsics (as the library uses the
1855 -fno-f2c calling convention), nor for calls to functions which always
1856 require an explicit interface, as no compatibility problems can
1858 if (gfc_option.flag_f2c
1859 && sym->ts.type == BT_COMPLEX
1860 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1867 gfc_get_mixed_entry_union (gfc_namespace *ns)
1872 char name[GFC_MAX_SYMBOL_LEN + 1];
1873 gfc_entry_list *el, *el2;
1875 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1876 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1878 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1880 /* Build the type node. */
1881 type = make_node (UNION_TYPE);
1883 TYPE_NAME (type) = get_identifier (name);
1886 for (el = ns->entries; el; el = el->next)
1888 /* Search for duplicates. */
1889 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1890 if (el2->sym->result == el->sym->result)
1895 decl = build_decl (FIELD_DECL,
1896 get_identifier (el->sym->result->name),
1897 gfc_sym_type (el->sym->result));
1898 DECL_CONTEXT (decl) = type;
1899 fieldlist = chainon (fieldlist, decl);
1903 /* Finish off the type. */
1904 TYPE_FIELDS (type) = fieldlist;
1906 gfc_finish_type (type);
1907 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1912 gfc_get_function_type (gfc_symbol * sym)
1916 gfc_formal_arglist *f;
1919 int alternate_return;
1921 /* Make sure this symbol is a function or a subroutine. */
1922 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1924 if (sym->backend_decl)
1925 return TREE_TYPE (sym->backend_decl);
1928 alternate_return = 0;
1929 typelist = NULL_TREE;
1931 if (sym->attr.entry_master)
1933 /* Additional parameter for selecting an entry point. */
1934 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1937 /* Some functions we use an extra parameter for the return value. */
1938 if (gfc_return_by_reference (sym))
1945 if (arg->ts.type == BT_CHARACTER)
1946 gfc_conv_const_charlen (arg->ts.cl);
1948 type = gfc_sym_type (arg);
1949 if (arg->ts.type == BT_COMPLEX
1950 || arg->attr.dimension
1951 || arg->ts.type == BT_CHARACTER)
1952 type = build_reference_type (type);
1954 typelist = gfc_chainon_list (typelist, type);
1955 if (arg->ts.type == BT_CHARACTER)
1956 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1959 /* Build the argument types for the function. */
1960 for (f = sym->formal; f; f = f->next)
1965 /* Evaluate constant character lengths here so that they can be
1966 included in the type. */
1967 if (arg->ts.type == BT_CHARACTER)
1968 gfc_conv_const_charlen (arg->ts.cl);
1970 if (arg->attr.flavor == FL_PROCEDURE)
1972 type = gfc_get_function_type (arg);
1973 type = build_pointer_type (type);
1976 type = gfc_sym_type (arg);
1978 /* Parameter Passing Convention
1980 We currently pass all parameters by reference.
1981 Parameters with INTENT(IN) could be passed by value.
1982 The problem arises if a function is called via an implicit
1983 prototype. In this situation the INTENT is not known.
1984 For this reason all parameters to global functions must be
1985 passed by reference. Passing by value would potentially
1986 generate bad code. Worse there would be no way of telling that
1987 this code was bad, except that it would give incorrect results.
1989 Contained procedures could pass by value as these are never
1990 used without an explicit interface, and cannot be passed as
1991 actual parameters for a dummy procedure. */
1992 if (arg->ts.type == BT_CHARACTER)
1994 typelist = gfc_chainon_list (typelist, type);
1998 if (sym->attr.subroutine)
1999 alternate_return = 1;
2003 /* Add hidden string length parameters. */
2005 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2008 typelist = gfc_chainon_list (typelist, void_type_node);
2010 if (alternate_return)
2011 type = integer_type_node;
2012 else if (!sym->attr.function || gfc_return_by_reference (sym))
2013 type = void_type_node;
2014 else if (sym->attr.mixed_entry_master)
2015 type = gfc_get_mixed_entry_union (sym->ns);
2016 else if (gfc_option.flag_f2c
2017 && sym->ts.type == BT_REAL
2018 && sym->ts.kind == gfc_default_real_kind
2019 && !sym->attr.always_explicit)
2021 /* Special case: f2c calling conventions require that (scalar)
2022 default REAL functions return the C type double instead. f2c
2023 compatibility is only an issue with functions that don't
2024 require an explicit interface, as only these could be
2025 implemented in Fortran 77. */
2026 sym->ts.kind = gfc_default_double_kind;
2027 type = gfc_typenode_for_spec (&sym->ts);
2028 sym->ts.kind = gfc_default_real_kind;
2031 type = gfc_sym_type (sym);
2033 type = build_function_type (type, typelist);
2038 /* Language hooks for middle-end access to type nodes. */
2040 /* Return an integer type with BITS bits of precision,
2041 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2044 gfc_type_for_size (unsigned bits, int unsignedp)
2049 for (i = 0; i <= MAX_INT_KINDS; ++i)
2051 tree type = gfc_integer_types[i];
2052 if (type && bits == TYPE_PRECISION (type))
2056 /* Handle TImode as a special case because it is used by some backends
2057 (eg. ARM) even though it is not available for normal use. */
2058 #if HOST_BITS_PER_WIDE_INT >= 64
2059 if (bits == TYPE_PRECISION (intTI_type_node))
2060 return intTI_type_node;
2065 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2066 return unsigned_intQI_type_node;
2067 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2068 return unsigned_intHI_type_node;
2069 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2070 return unsigned_intSI_type_node;
2071 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2072 return unsigned_intDI_type_node;
2073 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2074 return unsigned_intTI_type_node;
2080 /* Return a data type that has machine mode MODE. If the mode is an
2081 integer, then UNSIGNEDP selects between signed and unsigned types. */
2084 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2089 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2090 base = gfc_real_types;
2091 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2092 base = gfc_complex_types;
2093 else if (SCALAR_INT_MODE_P (mode))
2094 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2095 else if (VECTOR_MODE_P (mode))
2097 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2098 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2099 if (inner_type != NULL_TREE)
2100 return build_vector_type_for_mode (inner_type, mode);
2106 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2108 tree type = base[i];
2109 if (type && mode == TYPE_MODE (type))
2116 #include "gt-fortran-trans-types.h"