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);
1108 gfc_desc_dim_type = type;
1113 /* Return the DTYPE for an array. This describes the type and type parameters
1115 /* TODO: Only call this when the value is actually used, and make all the
1116 unknown cases abort. */
1119 gfc_get_dtype (tree type)
1129 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1131 if (GFC_TYPE_ARRAY_DTYPE (type))
1132 return GFC_TYPE_ARRAY_DTYPE (type);
1134 rank = GFC_TYPE_ARRAY_RANK (type);
1135 etype = gfc_get_element_type (type);
1137 switch (TREE_CODE (etype))
1140 n = GFC_DTYPE_INTEGER;
1144 n = GFC_DTYPE_LOGICAL;
1152 n = GFC_DTYPE_COMPLEX;
1155 /* We will never have arrays of arrays. */
1157 n = GFC_DTYPE_DERIVED;
1161 n = GFC_DTYPE_CHARACTER;
1165 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1166 /* We can strange array types for temporary arrays. */
1167 return gfc_index_zero_node;
1170 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1171 size = TYPE_SIZE_UNIT (etype);
1173 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1174 if (size && INTEGER_CST_P (size))
1176 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1177 internal_error ("Array element size too big");
1179 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1181 dtype = build_int_cst (gfc_array_index_type, i);
1183 if (size && !INTEGER_CST_P (size))
1185 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1186 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
1187 fold_convert (gfc_array_index_type, size), tmp);
1188 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
1190 /* If we don't know the size we leave it as zero. This should never happen
1191 for anything that is actually used. */
1192 /* TODO: Check this is actually true, particularly when repacking
1193 assumed size parameters. */
1195 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1200 /* Build an array type for use without a descriptor, packed according
1201 to the value of PACKED. */
1204 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
1217 mpz_init_set_ui (offset, 0);
1218 mpz_init_set_ui (stride, 1);
1221 /* We don't use build_array_type because this does not include include
1222 lang-specific information (i.e. the bounds of the array) when checking
1224 type = make_node (ARRAY_TYPE);
1226 GFC_ARRAY_TYPE_P (type) = 1;
1227 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1228 ggc_alloc_cleared (sizeof (struct lang_type));
1230 known_stride = (packed != PACKED_NO);
1232 for (n = 0; n < as->rank; n++)
1234 /* Fill in the stride and bound components of the type. */
1236 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1239 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1241 expr = as->lower[n];
1242 if (expr->expr_type == EXPR_CONSTANT)
1244 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1245 gfc_index_integer_kind);
1252 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1256 /* Calculate the offset. */
1257 mpz_mul (delta, stride, as->lower[n]->value.integer);
1258 mpz_sub (offset, offset, delta);
1263 expr = as->upper[n];
1264 if (expr && expr->expr_type == EXPR_CONSTANT)
1266 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1267 gfc_index_integer_kind);
1274 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1278 /* Calculate the stride. */
1279 mpz_sub (delta, as->upper[n]->value.integer,
1280 as->lower[n]->value.integer);
1281 mpz_add_ui (delta, delta, 1);
1282 mpz_mul (stride, stride, delta);
1285 /* Only the first stride is known for partial packed arrays. */
1286 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1292 GFC_TYPE_ARRAY_OFFSET (type) =
1293 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1296 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1300 GFC_TYPE_ARRAY_SIZE (type) =
1301 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1304 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1306 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1307 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1308 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1310 /* TODO: use main type if it is unbounded. */
1311 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1312 build_pointer_type (build_array_type (etype, range));
1316 mpz_sub_ui (stride, stride, 1);
1317 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1322 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1323 TYPE_DOMAIN (type) = range;
1325 build_pointer_type (etype);
1326 TREE_TYPE (type) = etype;
1334 /* In debug info represent packed arrays as multi-dimensional
1335 if they have rank > 1 and with proper bounds, instead of flat
1337 if (known_stride && write_symbols != NO_DEBUG)
1339 tree gtype = etype, rtype, type_decl;
1341 for (n = as->rank - 1; n >= 0; n--)
1343 rtype = build_range_type (gfc_array_index_type,
1344 GFC_TYPE_ARRAY_LBOUND (type, n),
1345 GFC_TYPE_ARRAY_UBOUND (type, n));
1346 gtype = build_array_type (gtype, rtype);
1348 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
1349 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1352 if (packed != PACKED_STATIC || !known_stride)
1354 /* For dummy arrays and automatic (heap allocated) arrays we
1355 want a pointer to the array. */
1356 type = build_pointer_type (type);
1357 GFC_ARRAY_TYPE_P (type) = 1;
1358 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1363 /* Return or create the base type for an array descriptor. */
1366 gfc_get_array_descriptor_base (int dimen)
1368 tree fat_type, fieldlist, decl, arraytype;
1369 char name[16 + GFC_RANK_DIGITS + 1];
1371 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1372 if (gfc_array_descriptor_base[dimen - 1])
1373 return gfc_array_descriptor_base[dimen - 1];
1375 /* Build the type node. */
1376 fat_type = make_node (RECORD_TYPE);
1378 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1379 TYPE_NAME (fat_type) = get_identifier (name);
1381 /* Add the data member as the first element of the descriptor. */
1382 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1384 DECL_CONTEXT (decl) = fat_type;
1387 /* Add the base component. */
1388 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1389 gfc_array_index_type);
1390 DECL_CONTEXT (decl) = fat_type;
1391 fieldlist = chainon (fieldlist, decl);
1393 /* Add the dtype component. */
1394 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1395 gfc_array_index_type);
1396 DECL_CONTEXT (decl) = fat_type;
1397 fieldlist = chainon (fieldlist, decl);
1399 /* Build the array type for the stride and bound components. */
1401 build_array_type (gfc_get_desc_dim_type (),
1402 build_range_type (gfc_array_index_type,
1403 gfc_index_zero_node,
1404 gfc_rank_cst[dimen - 1]));
1406 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1407 DECL_CONTEXT (decl) = fat_type;
1408 fieldlist = chainon (fieldlist, decl);
1410 /* Finish off the type. */
1411 TYPE_FIELDS (fat_type) = fieldlist;
1413 gfc_finish_type (fat_type);
1415 gfc_array_descriptor_base[dimen - 1] = fat_type;
1419 /* Build an array (descriptor) type with given bounds. */
1422 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1423 tree * ubound, int packed)
1425 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1426 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1427 const char *typename;
1430 base_type = gfc_get_array_descriptor_base (dimen);
1431 fat_type = build_variant_type_copy (base_type);
1433 tmp = TYPE_NAME (etype);
1434 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1435 tmp = DECL_NAME (tmp);
1437 typename = IDENTIFIER_POINTER (tmp);
1439 typename = "unknown";
1440 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1441 GFC_MAX_SYMBOL_LEN, typename);
1442 TYPE_NAME (fat_type) = get_identifier (name);
1444 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1445 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1446 ggc_alloc_cleared (sizeof (struct lang_type));
1448 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1449 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1451 /* Build an array descriptor record type. */
1453 stride = gfc_index_one_node;
1456 for (n = 0; n < dimen; n++)
1458 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1465 if (lower != NULL_TREE)
1467 if (INTEGER_CST_P (lower))
1468 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1474 if (upper != NULL_TREE)
1476 if (INTEGER_CST_P (upper))
1477 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1482 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1484 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1485 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1486 gfc_index_one_node);
1488 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1489 /* Check the folding worked. */
1490 gcc_assert (INTEGER_CST_P (stride));
1495 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1497 /* TODO: known offsets for descriptors. */
1498 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1500 /* We define data as an unknown size array. Much better than doing
1501 pointer arithmetic. */
1503 build_array_type (etype, gfc_array_range_type);
1504 arraytype = build_pointer_type (arraytype);
1505 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1510 /* Build a pointer type. This function is called from gfc_sym_type(). */
1513 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1515 /* Array pointer types aren't actually pointers. */
1516 if (sym->attr.dimension)
1519 return build_pointer_type (type);
1522 /* Return the type for a symbol. Special handling is required for character
1523 types to get the correct level of indirection.
1524 For functions return the return type.
1525 For subroutines return void_type_node.
1526 Calling this multiple times for the same symbol should be avoided,
1527 especially for character and array types. */
1530 gfc_sym_type (gfc_symbol * sym)
1535 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1536 return void_type_node;
1538 /* In the case of a function the fake result variable may have a
1539 type different from the function type, so don't return early in
1541 if (sym->backend_decl && !sym->attr.function)
1542 return TREE_TYPE (sym->backend_decl);
1544 type = gfc_typenode_for_spec (&sym->ts);
1546 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1551 if (sym->attr.dimension)
1553 if (gfc_is_nodesc_array (sym))
1555 /* If this is a character argument of unknown length, just use the
1557 if (sym->ts.type != BT_CHARACTER
1558 || !(sym->attr.dummy || sym->attr.function)
1559 || sym->ts.cl->backend_decl)
1561 type = gfc_get_nodesc_array_type (type, sym->as,
1569 type = gfc_build_array_type (type, sym->as);
1574 if (sym->attr.allocatable || sym->attr.pointer)
1575 type = gfc_build_pointer_type (sym, type);
1576 if (sym->attr.pointer)
1577 GFC_POINTER_TYPE_P (type) = 1;
1580 /* We currently pass all parameters by reference.
1581 See f95_get_function_decl. For dummy function parameters return the
1585 /* We must use pointer types for potentially absent variables. The
1586 optimizers assume a reference type argument is never NULL. */
1587 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1588 type = build_pointer_type (type);
1590 type = build_reference_type (type);
1596 /* Layout and output debug info for a record type. */
1599 gfc_finish_type (tree type)
1603 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1604 TYPE_STUB_DECL (type) = decl;
1606 rest_of_type_compilation (type, 1);
1607 rest_of_decl_compilation (decl, 1, 0);
1610 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1611 or RECORD_TYPE pointed to by STYPE. The new field is chained
1612 to the fieldlist pointed to by FIELDLIST.
1614 Returns a pointer to the new field. */
1617 gfc_add_field_to_struct (tree *fieldlist, tree context,
1618 tree name, tree type)
1622 decl = build_decl (FIELD_DECL, name, type);
1624 DECL_CONTEXT (decl) = context;
1625 DECL_INITIAL (decl) = 0;
1626 DECL_ALIGN (decl) = 0;
1627 DECL_USER_ALIGN (decl) = 0;
1628 TREE_CHAIN (decl) = NULL_TREE;
1629 *fieldlist = chainon (*fieldlist, decl);
1635 /* Copy the backend_decl and component backend_decls if
1636 the two derived type symbols are "equal", as described
1637 in 4.4.2 and resolved by gfc_compare_derived_types. */
1640 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1642 gfc_component *to_cm;
1643 gfc_component *from_cm;
1645 if (from->backend_decl == NULL
1646 || !gfc_compare_derived_types (from, to))
1649 to->backend_decl = from->backend_decl;
1651 to_cm = to->components;
1652 from_cm = from->components;
1654 /* Copy the component declarations. If a component is itself
1655 a derived type, we need a copy of its component declarations.
1656 This is done by recursing into gfc_get_derived_type and
1657 ensures that the component's component declarations have
1658 been built. If it is a character, we need the character
1660 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1662 to_cm->backend_decl = from_cm->backend_decl;
1663 if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
1664 gfc_get_derived_type (to_cm->ts.derived);
1666 else if (from_cm->ts.type == BT_CHARACTER)
1667 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1674 /* Build a tree node for a derived type. If there are equal
1675 derived types, with different local names, these are built
1676 at the same time. If an equal derived type has been built
1677 in a parent namespace, this is used. */
1680 gfc_get_derived_type (gfc_symbol * derived)
1682 tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1686 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1688 /* See if it's one of the iso_c_binding derived types. */
1689 if (derived->attr.is_iso_c == 1)
1691 if (derived->intmod_sym_id == ISOCBINDING_PTR)
1692 derived->backend_decl = ptr_type_node;
1694 derived->backend_decl = pfunc_type_node;
1695 derived->ts.kind = gfc_index_integer_kind;
1696 derived->ts.type = BT_INTEGER;
1697 /* Set the f90_type to BT_VOID as a way to recognize something of type
1698 BT_INTEGER that needs to fit a void * for the purpose of the
1699 iso_c_binding derived types. */
1700 derived->ts.f90_type = BT_VOID;
1701 return derived->backend_decl;
1704 /* derived->backend_decl != 0 means we saw it before, but its
1705 components' backend_decl may have not been built. */
1706 if (derived->backend_decl)
1708 /* Its components' backend_decl have been built. */
1709 if (TYPE_FIELDS (derived->backend_decl))
1710 return derived->backend_decl;
1712 typenode = derived->backend_decl;
1717 /* We see this derived type first time, so build the type node. */
1718 typenode = make_node (RECORD_TYPE);
1719 TYPE_NAME (typenode) = get_identifier (derived->name);
1720 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1721 derived->backend_decl = typenode;
1724 /* Go through the derived type components, building them as
1725 necessary. The reason for doing this now is that it is
1726 possible to recurse back to this derived type through a
1727 pointer component (PR24092). If this happens, the fields
1728 will be built and so we can return the type. */
1729 for (c = derived->components; c; c = c->next)
1731 if (c->ts.type != BT_DERIVED)
1734 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1735 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1737 if (c->ts.derived && c->ts.derived->attr.is_iso_c)
1739 /* Need to copy the modified ts from the derived type. The
1740 typespec was modified because C_PTR/C_FUNPTR are translated
1741 into (void *) from derived types. */
1742 c->ts.type = c->ts.derived->ts.type;
1743 c->ts.kind = c->ts.derived->ts.kind;
1744 c->ts.f90_type = c->ts.derived->ts.f90_type;
1748 if (TYPE_FIELDS (derived->backend_decl))
1749 return derived->backend_decl;
1751 /* Build the type member list. Install the newly created RECORD_TYPE
1752 node as DECL_CONTEXT of each FIELD_DECL. */
1753 fieldlist = NULL_TREE;
1754 for (c = derived->components; c; c = c->next)
1756 if (c->ts.type == BT_DERIVED)
1757 field_type = c->ts.derived->backend_decl;
1760 if (c->ts.type == BT_CHARACTER)
1762 /* Evaluate the string length. */
1763 gfc_conv_const_charlen (c->ts.cl);
1764 gcc_assert (c->ts.cl->backend_decl);
1767 field_type = gfc_typenode_for_spec (&c->ts);
1770 /* This returns an array descriptor type. Initialization may be
1774 if (c->pointer || c->allocatable)
1776 /* Pointers to arrays aren't actually pointer types. The
1777 descriptors are separate, but the data is common. */
1778 field_type = gfc_build_array_type (field_type, c->as);
1781 field_type = gfc_get_nodesc_array_type (field_type, c->as,
1784 else if (c->pointer)
1785 field_type = build_pointer_type (field_type);
1787 field = gfc_add_field_to_struct (&fieldlist, typenode,
1788 get_identifier (c->name),
1791 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1794 if (!c->backend_decl)
1795 c->backend_decl = field;
1798 /* Now we have the final fieldlist. Record it, then lay out the
1799 derived type, including the fields. */
1800 TYPE_FIELDS (typenode) = fieldlist;
1802 gfc_finish_type (typenode);
1804 derived->backend_decl = typenode;
1806 /* Add this backend_decl to all the other, equal derived types. */
1807 for (dt = gfc_derived_types; dt; dt = dt->next)
1808 copy_dt_decls_ifequal (derived, dt->derived);
1810 return derived->backend_decl;
1815 gfc_return_by_reference (gfc_symbol * sym)
1817 if (!sym->attr.function)
1820 if (sym->attr.dimension)
1823 if (sym->ts.type == BT_CHARACTER)
1826 /* Possibly return complex numbers by reference for g77 compatibility.
1827 We don't do this for calls to intrinsics (as the library uses the
1828 -fno-f2c calling convention), nor for calls to functions which always
1829 require an explicit interface, as no compatibility problems can
1831 if (gfc_option.flag_f2c
1832 && sym->ts.type == BT_COMPLEX
1833 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1840 gfc_get_mixed_entry_union (gfc_namespace *ns)
1845 char name[GFC_MAX_SYMBOL_LEN + 1];
1846 gfc_entry_list *el, *el2;
1848 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1849 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1851 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1853 /* Build the type node. */
1854 type = make_node (UNION_TYPE);
1856 TYPE_NAME (type) = get_identifier (name);
1859 for (el = ns->entries; el; el = el->next)
1861 /* Search for duplicates. */
1862 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1863 if (el2->sym->result == el->sym->result)
1868 decl = build_decl (FIELD_DECL,
1869 get_identifier (el->sym->result->name),
1870 gfc_sym_type (el->sym->result));
1871 DECL_CONTEXT (decl) = type;
1872 fieldlist = chainon (fieldlist, decl);
1876 /* Finish off the type. */
1877 TYPE_FIELDS (type) = fieldlist;
1879 gfc_finish_type (type);
1884 gfc_get_function_type (gfc_symbol * sym)
1888 gfc_formal_arglist *f;
1891 int alternate_return;
1893 /* Make sure this symbol is a function or a subroutine. */
1894 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1896 if (sym->backend_decl)
1897 return TREE_TYPE (sym->backend_decl);
1900 alternate_return = 0;
1901 typelist = NULL_TREE;
1903 if (sym->attr.entry_master)
1905 /* Additional parameter for selecting an entry point. */
1906 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1909 /* Some functions we use an extra parameter for the return value. */
1910 if (gfc_return_by_reference (sym))
1917 if (arg->ts.type == BT_CHARACTER)
1918 gfc_conv_const_charlen (arg->ts.cl);
1920 type = gfc_sym_type (arg);
1921 if (arg->ts.type == BT_COMPLEX
1922 || arg->attr.dimension
1923 || arg->ts.type == BT_CHARACTER)
1924 type = build_reference_type (type);
1926 typelist = gfc_chainon_list (typelist, type);
1927 if (arg->ts.type == BT_CHARACTER)
1928 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1931 /* Build the argument types for the function. */
1932 for (f = sym->formal; f; f = f->next)
1937 /* Evaluate constant character lengths here so that they can be
1938 included in the type. */
1939 if (arg->ts.type == BT_CHARACTER)
1940 gfc_conv_const_charlen (arg->ts.cl);
1942 if (arg->attr.flavor == FL_PROCEDURE)
1944 type = gfc_get_function_type (arg);
1945 type = build_pointer_type (type);
1948 type = gfc_sym_type (arg);
1950 /* Parameter Passing Convention
1952 We currently pass all parameters by reference.
1953 Parameters with INTENT(IN) could be passed by value.
1954 The problem arises if a function is called via an implicit
1955 prototype. In this situation the INTENT is not known.
1956 For this reason all parameters to global functions must be
1957 passed by reference. Passing by value would potentially
1958 generate bad code. Worse there would be no way of telling that
1959 this code was bad, except that it would give incorrect results.
1961 Contained procedures could pass by value as these are never
1962 used without an explicit interface, and cannot be passed as
1963 actual parameters for a dummy procedure. */
1964 if (arg->ts.type == BT_CHARACTER)
1966 typelist = gfc_chainon_list (typelist, type);
1970 if (sym->attr.subroutine)
1971 alternate_return = 1;
1975 /* Add hidden string length parameters. */
1977 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1980 typelist = gfc_chainon_list (typelist, void_type_node);
1982 if (alternate_return)
1983 type = integer_type_node;
1984 else if (!sym->attr.function || gfc_return_by_reference (sym))
1985 type = void_type_node;
1986 else if (sym->attr.mixed_entry_master)
1987 type = gfc_get_mixed_entry_union (sym->ns);
1988 else if (gfc_option.flag_f2c
1989 && sym->ts.type == BT_REAL
1990 && sym->ts.kind == gfc_default_real_kind
1991 && !sym->attr.always_explicit)
1993 /* Special case: f2c calling conventions require that (scalar)
1994 default REAL functions return the C type double instead. f2c
1995 compatibility is only an issue with functions that don't
1996 require an explicit interface, as only these could be
1997 implemented in Fortran 77. */
1998 sym->ts.kind = gfc_default_double_kind;
1999 type = gfc_typenode_for_spec (&sym->ts);
2000 sym->ts.kind = gfc_default_real_kind;
2003 type = gfc_sym_type (sym);
2005 type = build_function_type (type, typelist);
2010 /* Language hooks for middle-end access to type nodes. */
2012 /* Return an integer type with BITS bits of precision,
2013 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2016 gfc_type_for_size (unsigned bits, int unsignedp)
2021 for (i = 0; i <= MAX_INT_KINDS; ++i)
2023 tree type = gfc_integer_types[i];
2024 if (type && bits == TYPE_PRECISION (type))
2028 /* Handle TImode as a special case because it is used by some backends
2029 (eg. ARM) even though it is not available for normal use. */
2030 #if HOST_BITS_PER_WIDE_INT >= 64
2031 if (bits == TYPE_PRECISION (intTI_type_node))
2032 return intTI_type_node;
2037 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2038 return unsigned_intQI_type_node;
2039 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2040 return unsigned_intHI_type_node;
2041 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2042 return unsigned_intSI_type_node;
2043 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2044 return unsigned_intDI_type_node;
2045 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2046 return unsigned_intTI_type_node;
2052 /* Return a data type that has machine mode MODE. If the mode is an
2053 integer, then UNSIGNEDP selects between signed and unsigned types. */
2056 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2061 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2062 base = gfc_real_types;
2063 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2064 base = gfc_complex_types;
2065 else if (SCALAR_INT_MODE_P (mode))
2066 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2067 else if (VECTOR_MODE_P (mode))
2069 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2070 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2071 if (inner_type != NULL_TREE)
2072 return build_vector_type_for_mode (inner_type, mode);
2078 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2080 tree type = base[i];
2081 if (type && mode == TYPE_MODE (type))
2088 #include "gt-fortran-trans-types.h"