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;
1091 TREE_NO_WARNING (decl) = 1;
1094 decl = build_decl (FIELD_DECL,
1095 get_identifier ("lbound"), gfc_array_index_type);
1096 DECL_CONTEXT (decl) = type;
1097 TREE_NO_WARNING (decl) = 1;
1098 fieldlist = chainon (fieldlist, decl);
1100 decl = build_decl (FIELD_DECL,
1101 get_identifier ("ubound"), gfc_array_index_type);
1102 DECL_CONTEXT (decl) = type;
1103 TREE_NO_WARNING (decl) = 1;
1104 fieldlist = chainon (fieldlist, decl);
1106 /* Finish off the type. */
1107 TYPE_FIELDS (type) = fieldlist;
1109 gfc_finish_type (type);
1110 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1112 gfc_desc_dim_type = type;
1117 /* Return the DTYPE for an array. This describes the type and type parameters
1119 /* TODO: Only call this when the value is actually used, and make all the
1120 unknown cases abort. */
1123 gfc_get_dtype (tree type)
1133 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1135 if (GFC_TYPE_ARRAY_DTYPE (type))
1136 return GFC_TYPE_ARRAY_DTYPE (type);
1138 rank = GFC_TYPE_ARRAY_RANK (type);
1139 etype = gfc_get_element_type (type);
1141 switch (TREE_CODE (etype))
1144 n = GFC_DTYPE_INTEGER;
1148 n = GFC_DTYPE_LOGICAL;
1156 n = GFC_DTYPE_COMPLEX;
1159 /* We will never have arrays of arrays. */
1161 n = GFC_DTYPE_DERIVED;
1165 n = GFC_DTYPE_CHARACTER;
1169 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1170 /* We can strange array types for temporary arrays. */
1171 return gfc_index_zero_node;
1174 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1175 size = TYPE_SIZE_UNIT (etype);
1177 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1178 if (size && INTEGER_CST_P (size))
1180 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1181 internal_error ("Array element size too big");
1183 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1185 dtype = build_int_cst (gfc_array_index_type, i);
1187 if (size && !INTEGER_CST_P (size))
1189 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1190 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
1191 fold_convert (gfc_array_index_type, size), tmp);
1192 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
1194 /* If we don't know the size we leave it as zero. This should never happen
1195 for anything that is actually used. */
1196 /* TODO: Check this is actually true, particularly when repacking
1197 assumed size parameters. */
1199 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1204 /* Build an array type for use without a descriptor, packed according
1205 to the value of PACKED. */
1208 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
1221 mpz_init_set_ui (offset, 0);
1222 mpz_init_set_ui (stride, 1);
1225 /* We don't use build_array_type because this does not include include
1226 lang-specific information (i.e. the bounds of the array) when checking
1228 type = make_node (ARRAY_TYPE);
1230 GFC_ARRAY_TYPE_P (type) = 1;
1231 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1232 ggc_alloc_cleared (sizeof (struct lang_type));
1234 known_stride = (packed != PACKED_NO);
1236 for (n = 0; n < as->rank; n++)
1238 /* Fill in the stride and bound components of the type. */
1240 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1243 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1245 expr = as->lower[n];
1246 if (expr->expr_type == EXPR_CONSTANT)
1248 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1249 gfc_index_integer_kind);
1256 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1260 /* Calculate the offset. */
1261 mpz_mul (delta, stride, as->lower[n]->value.integer);
1262 mpz_sub (offset, offset, delta);
1267 expr = as->upper[n];
1268 if (expr && expr->expr_type == EXPR_CONSTANT)
1270 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1271 gfc_index_integer_kind);
1278 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1282 /* Calculate the stride. */
1283 mpz_sub (delta, as->upper[n]->value.integer,
1284 as->lower[n]->value.integer);
1285 mpz_add_ui (delta, delta, 1);
1286 mpz_mul (stride, stride, delta);
1289 /* Only the first stride is known for partial packed arrays. */
1290 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1296 GFC_TYPE_ARRAY_OFFSET (type) =
1297 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1300 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1304 GFC_TYPE_ARRAY_SIZE (type) =
1305 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1308 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1310 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1311 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1312 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1314 /* TODO: use main type if it is unbounded. */
1315 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1316 build_pointer_type (build_array_type (etype, range));
1320 mpz_sub_ui (stride, stride, 1);
1321 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1326 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1327 TYPE_DOMAIN (type) = range;
1329 build_pointer_type (etype);
1330 TREE_TYPE (type) = etype;
1338 /* In debug info represent packed arrays as multi-dimensional
1339 if they have rank > 1 and with proper bounds, instead of flat
1341 if (known_stride && write_symbols != NO_DEBUG)
1343 tree gtype = etype, rtype, type_decl;
1345 for (n = as->rank - 1; n >= 0; n--)
1347 rtype = build_range_type (gfc_array_index_type,
1348 GFC_TYPE_ARRAY_LBOUND (type, n),
1349 GFC_TYPE_ARRAY_UBOUND (type, n));
1350 gtype = build_array_type (gtype, rtype);
1352 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
1353 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1356 if (packed != PACKED_STATIC || !known_stride)
1358 /* For dummy arrays and automatic (heap allocated) arrays we
1359 want a pointer to the array. */
1360 type = build_pointer_type (type);
1361 GFC_ARRAY_TYPE_P (type) = 1;
1362 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1367 /* Return or create the base type for an array descriptor. */
1370 gfc_get_array_descriptor_base (int dimen)
1372 tree fat_type, fieldlist, decl, arraytype;
1373 char name[16 + GFC_RANK_DIGITS + 1];
1375 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1376 if (gfc_array_descriptor_base[dimen - 1])
1377 return gfc_array_descriptor_base[dimen - 1];
1379 /* Build the type node. */
1380 fat_type = make_node (RECORD_TYPE);
1382 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1383 TYPE_NAME (fat_type) = get_identifier (name);
1385 /* Add the data member as the first element of the descriptor. */
1386 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1388 DECL_CONTEXT (decl) = fat_type;
1391 /* Add the base component. */
1392 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1393 gfc_array_index_type);
1394 DECL_CONTEXT (decl) = fat_type;
1395 TREE_NO_WARNING (decl) = 1;
1396 fieldlist = chainon (fieldlist, decl);
1398 /* Add the dtype component. */
1399 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1400 gfc_array_index_type);
1401 DECL_CONTEXT (decl) = fat_type;
1402 TREE_NO_WARNING (decl) = 1;
1403 fieldlist = chainon (fieldlist, decl);
1405 /* Build the array type for the stride and bound components. */
1407 build_array_type (gfc_get_desc_dim_type (),
1408 build_range_type (gfc_array_index_type,
1409 gfc_index_zero_node,
1410 gfc_rank_cst[dimen - 1]));
1412 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1413 DECL_CONTEXT (decl) = fat_type;
1414 TREE_NO_WARNING (decl) = 1;
1415 fieldlist = chainon (fieldlist, decl);
1417 /* Finish off the type. */
1418 TYPE_FIELDS (fat_type) = fieldlist;
1420 gfc_finish_type (fat_type);
1421 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1423 gfc_array_descriptor_base[dimen - 1] = fat_type;
1427 /* Build an array (descriptor) type with given bounds. */
1430 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1431 tree * ubound, int packed)
1433 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1434 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1435 const char *typename;
1438 base_type = gfc_get_array_descriptor_base (dimen);
1439 fat_type = build_variant_type_copy (base_type);
1441 tmp = TYPE_NAME (etype);
1442 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1443 tmp = DECL_NAME (tmp);
1445 typename = IDENTIFIER_POINTER (tmp);
1447 typename = "unknown";
1448 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1449 GFC_MAX_SYMBOL_LEN, typename);
1450 TYPE_NAME (fat_type) = get_identifier (name);
1452 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1453 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1454 ggc_alloc_cleared (sizeof (struct lang_type));
1456 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1457 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1459 /* Build an array descriptor record type. */
1461 stride = gfc_index_one_node;
1464 for (n = 0; n < dimen; n++)
1466 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1473 if (lower != NULL_TREE)
1475 if (INTEGER_CST_P (lower))
1476 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1482 if (upper != NULL_TREE)
1484 if (INTEGER_CST_P (upper))
1485 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1490 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1492 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1493 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1494 gfc_index_one_node);
1496 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1497 /* Check the folding worked. */
1498 gcc_assert (INTEGER_CST_P (stride));
1503 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1505 /* TODO: known offsets for descriptors. */
1506 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1508 /* We define data as an unknown size array. Much better than doing
1509 pointer arithmetic. */
1511 build_array_type (etype, gfc_array_range_type);
1512 arraytype = build_pointer_type (arraytype);
1513 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1518 /* Build a pointer type. This function is called from gfc_sym_type(). */
1521 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1523 /* Array pointer types aren't actually pointers. */
1524 if (sym->attr.dimension)
1527 return build_pointer_type (type);
1530 /* Return the type for a symbol. Special handling is required for character
1531 types to get the correct level of indirection.
1532 For functions return the return type.
1533 For subroutines return void_type_node.
1534 Calling this multiple times for the same symbol should be avoided,
1535 especially for character and array types. */
1538 gfc_sym_type (gfc_symbol * sym)
1543 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1544 return void_type_node;
1546 /* In the case of a function the fake result variable may have a
1547 type different from the function type, so don't return early in
1549 if (sym->backend_decl && !sym->attr.function)
1550 return TREE_TYPE (sym->backend_decl);
1552 type = gfc_typenode_for_spec (&sym->ts);
1554 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1559 if (sym->attr.dimension)
1561 if (gfc_is_nodesc_array (sym))
1563 /* If this is a character argument of unknown length, just use the
1565 if (sym->ts.type != BT_CHARACTER
1566 || !(sym->attr.dummy || sym->attr.function)
1567 || sym->ts.cl->backend_decl)
1569 type = gfc_get_nodesc_array_type (type, sym->as,
1577 type = gfc_build_array_type (type, sym->as);
1582 if (sym->attr.allocatable || sym->attr.pointer)
1583 type = gfc_build_pointer_type (sym, type);
1584 if (sym->attr.pointer)
1585 GFC_POINTER_TYPE_P (type) = 1;
1588 /* We currently pass all parameters by reference.
1589 See f95_get_function_decl. For dummy function parameters return the
1593 /* We must use pointer types for potentially absent variables. The
1594 optimizers assume a reference type argument is never NULL. */
1595 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1596 type = build_pointer_type (type);
1598 type = build_reference_type (type);
1604 /* Layout and output debug info for a record type. */
1607 gfc_finish_type (tree type)
1611 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1612 TYPE_STUB_DECL (type) = decl;
1614 rest_of_type_compilation (type, 1);
1615 rest_of_decl_compilation (decl, 1, 0);
1618 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1619 or RECORD_TYPE pointed to by STYPE. The new field is chained
1620 to the fieldlist pointed to by FIELDLIST.
1622 Returns a pointer to the new field. */
1625 gfc_add_field_to_struct (tree *fieldlist, tree context,
1626 tree name, tree type)
1630 decl = build_decl (FIELD_DECL, name, type);
1632 DECL_CONTEXT (decl) = context;
1633 DECL_INITIAL (decl) = 0;
1634 DECL_ALIGN (decl) = 0;
1635 DECL_USER_ALIGN (decl) = 0;
1636 TREE_CHAIN (decl) = NULL_TREE;
1637 *fieldlist = chainon (*fieldlist, decl);
1643 /* Copy the backend_decl and component backend_decls if
1644 the two derived type symbols are "equal", as described
1645 in 4.4.2 and resolved by gfc_compare_derived_types. */
1648 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1650 gfc_component *to_cm;
1651 gfc_component *from_cm;
1653 if (from->backend_decl == NULL
1654 || !gfc_compare_derived_types (from, to))
1657 to->backend_decl = from->backend_decl;
1659 to_cm = to->components;
1660 from_cm = from->components;
1662 /* Copy the component declarations. If a component is itself
1663 a derived type, we need a copy of its component declarations.
1664 This is done by recursing into gfc_get_derived_type and
1665 ensures that the component's component declarations have
1666 been built. If it is a character, we need the character
1668 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1670 to_cm->backend_decl = from_cm->backend_decl;
1671 if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
1672 gfc_get_derived_type (to_cm->ts.derived);
1674 else if (from_cm->ts.type == BT_CHARACTER)
1675 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1682 /* Build a tree node for a derived type. If there are equal
1683 derived types, with different local names, these are built
1684 at the same time. If an equal derived type has been built
1685 in a parent namespace, this is used. */
1688 gfc_get_derived_type (gfc_symbol * derived)
1690 tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1694 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1696 /* See if it's one of the iso_c_binding derived types. */
1697 if (derived->attr.is_iso_c == 1)
1699 if (derived->backend_decl)
1700 return derived->backend_decl;
1702 if (derived->intmod_sym_id == ISOCBINDING_PTR)
1703 derived->backend_decl = ptr_type_node;
1705 derived->backend_decl = pfunc_type_node;
1707 /* Create a backend_decl for the __c_ptr_c_address field. */
1708 derived->components->backend_decl =
1709 gfc_add_field_to_struct (&(derived->backend_decl->type.values),
1710 derived->backend_decl,
1711 get_identifier (derived->components->name),
1712 gfc_typenode_for_spec (
1713 &(derived->components->ts)));
1715 derived->ts.kind = gfc_index_integer_kind;
1716 derived->ts.type = BT_INTEGER;
1717 /* Set the f90_type to BT_VOID as a way to recognize something of type
1718 BT_INTEGER that needs to fit a void * for the purpose of the
1719 iso_c_binding derived types. */
1720 derived->ts.f90_type = BT_VOID;
1722 return derived->backend_decl;
1725 /* derived->backend_decl != 0 means we saw it before, but its
1726 components' backend_decl may have not been built. */
1727 if (derived->backend_decl)
1729 /* Its components' backend_decl have been built. */
1730 if (TYPE_FIELDS (derived->backend_decl))
1731 return derived->backend_decl;
1733 typenode = derived->backend_decl;
1738 /* We see this derived type first time, so build the type node. */
1739 typenode = make_node (RECORD_TYPE);
1740 TYPE_NAME (typenode) = get_identifier (derived->name);
1741 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1742 derived->backend_decl = typenode;
1745 /* Go through the derived type components, building them as
1746 necessary. The reason for doing this now is that it is
1747 possible to recurse back to this derived type through a
1748 pointer component (PR24092). If this happens, the fields
1749 will be built and so we can return the type. */
1750 for (c = derived->components; c; c = c->next)
1752 if (c->ts.type != BT_DERIVED)
1755 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1756 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1758 if (c->ts.derived && c->ts.derived->attr.is_iso_c)
1760 /* Need to copy the modified ts from the derived type. The
1761 typespec was modified because C_PTR/C_FUNPTR are translated
1762 into (void *) from derived types. */
1763 c->ts.type = c->ts.derived->ts.type;
1764 c->ts.kind = c->ts.derived->ts.kind;
1765 c->ts.f90_type = c->ts.derived->ts.f90_type;
1768 c->initializer->ts.type = c->ts.type;
1769 c->initializer->ts.kind = c->ts.kind;
1770 c->initializer->ts.f90_type = c->ts.f90_type;
1771 c->initializer->expr_type = EXPR_NULL;
1776 if (TYPE_FIELDS (derived->backend_decl))
1777 return derived->backend_decl;
1779 /* Build the type member list. Install the newly created RECORD_TYPE
1780 node as DECL_CONTEXT of each FIELD_DECL. */
1781 fieldlist = NULL_TREE;
1782 for (c = derived->components; c; c = c->next)
1784 if (c->ts.type == BT_DERIVED)
1785 field_type = c->ts.derived->backend_decl;
1788 if (c->ts.type == BT_CHARACTER)
1790 /* Evaluate the string length. */
1791 gfc_conv_const_charlen (c->ts.cl);
1792 gcc_assert (c->ts.cl->backend_decl);
1795 field_type = gfc_typenode_for_spec (&c->ts);
1798 /* This returns an array descriptor type. Initialization may be
1802 if (c->pointer || c->allocatable)
1804 /* Pointers to arrays aren't actually pointer types. The
1805 descriptors are separate, but the data is common. */
1806 field_type = gfc_build_array_type (field_type, c->as);
1809 field_type = gfc_get_nodesc_array_type (field_type, c->as,
1812 else if (c->pointer)
1813 field_type = build_pointer_type (field_type);
1815 field = gfc_add_field_to_struct (&fieldlist, typenode,
1816 get_identifier (c->name),
1819 gfc_set_decl_location (field, &c->loc);
1820 else if (derived->declared_at.lb)
1821 gfc_set_decl_location (field, &derived->declared_at);
1823 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1826 if (!c->backend_decl)
1827 c->backend_decl = field;
1830 /* Now we have the final fieldlist. Record it, then lay out the
1831 derived type, including the fields. */
1832 TYPE_FIELDS (typenode) = fieldlist;
1834 gfc_finish_type (typenode);
1835 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
1837 derived->backend_decl = typenode;
1839 /* Add this backend_decl to all the other, equal derived types. */
1840 for (dt = gfc_derived_types; dt; dt = dt->next)
1841 copy_dt_decls_ifequal (derived, dt->derived);
1843 return derived->backend_decl;
1848 gfc_return_by_reference (gfc_symbol * sym)
1850 if (!sym->attr.function)
1853 if (sym->attr.dimension)
1856 if (sym->ts.type == BT_CHARACTER)
1859 /* Possibly return complex numbers by reference for g77 compatibility.
1860 We don't do this for calls to intrinsics (as the library uses the
1861 -fno-f2c calling convention), nor for calls to functions which always
1862 require an explicit interface, as no compatibility problems can
1864 if (gfc_option.flag_f2c
1865 && sym->ts.type == BT_COMPLEX
1866 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1873 gfc_get_mixed_entry_union (gfc_namespace *ns)
1878 char name[GFC_MAX_SYMBOL_LEN + 1];
1879 gfc_entry_list *el, *el2;
1881 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1882 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1884 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1886 /* Build the type node. */
1887 type = make_node (UNION_TYPE);
1889 TYPE_NAME (type) = get_identifier (name);
1892 for (el = ns->entries; el; el = el->next)
1894 /* Search for duplicates. */
1895 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1896 if (el2->sym->result == el->sym->result)
1901 decl = build_decl (FIELD_DECL,
1902 get_identifier (el->sym->result->name),
1903 gfc_sym_type (el->sym->result));
1904 DECL_CONTEXT (decl) = type;
1905 fieldlist = chainon (fieldlist, decl);
1909 /* Finish off the type. */
1910 TYPE_FIELDS (type) = fieldlist;
1912 gfc_finish_type (type);
1913 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1918 gfc_get_function_type (gfc_symbol * sym)
1922 gfc_formal_arglist *f;
1925 int alternate_return;
1927 /* Make sure this symbol is a function or a subroutine. */
1928 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1930 if (sym->backend_decl)
1931 return TREE_TYPE (sym->backend_decl);
1934 alternate_return = 0;
1935 typelist = NULL_TREE;
1937 if (sym->attr.entry_master)
1939 /* Additional parameter for selecting an entry point. */
1940 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1943 /* Some functions we use an extra parameter for the return value. */
1944 if (gfc_return_by_reference (sym))
1951 if (arg->ts.type == BT_CHARACTER)
1952 gfc_conv_const_charlen (arg->ts.cl);
1954 type = gfc_sym_type (arg);
1955 if (arg->ts.type == BT_COMPLEX
1956 || arg->attr.dimension
1957 || arg->ts.type == BT_CHARACTER)
1958 type = build_reference_type (type);
1960 typelist = gfc_chainon_list (typelist, type);
1961 if (arg->ts.type == BT_CHARACTER)
1962 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1965 /* Build the argument types for the function. */
1966 for (f = sym->formal; f; f = f->next)
1971 /* Evaluate constant character lengths here so that they can be
1972 included in the type. */
1973 if (arg->ts.type == BT_CHARACTER)
1974 gfc_conv_const_charlen (arg->ts.cl);
1976 if (arg->attr.flavor == FL_PROCEDURE)
1978 type = gfc_get_function_type (arg);
1979 type = build_pointer_type (type);
1982 type = gfc_sym_type (arg);
1984 /* Parameter Passing Convention
1986 We currently pass all parameters by reference.
1987 Parameters with INTENT(IN) could be passed by value.
1988 The problem arises if a function is called via an implicit
1989 prototype. In this situation the INTENT is not known.
1990 For this reason all parameters to global functions must be
1991 passed by reference. Passing by value would potentially
1992 generate bad code. Worse there would be no way of telling that
1993 this code was bad, except that it would give incorrect results.
1995 Contained procedures could pass by value as these are never
1996 used without an explicit interface, and cannot be passed as
1997 actual parameters for a dummy procedure. */
1998 if (arg->ts.type == BT_CHARACTER)
2000 typelist = gfc_chainon_list (typelist, type);
2004 if (sym->attr.subroutine)
2005 alternate_return = 1;
2009 /* Add hidden string length parameters. */
2011 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2014 typelist = gfc_chainon_list (typelist, void_type_node);
2016 if (alternate_return)
2017 type = integer_type_node;
2018 else if (!sym->attr.function || gfc_return_by_reference (sym))
2019 type = void_type_node;
2020 else if (sym->attr.mixed_entry_master)
2021 type = gfc_get_mixed_entry_union (sym->ns);
2022 else if (gfc_option.flag_f2c
2023 && sym->ts.type == BT_REAL
2024 && sym->ts.kind == gfc_default_real_kind
2025 && !sym->attr.always_explicit)
2027 /* Special case: f2c calling conventions require that (scalar)
2028 default REAL functions return the C type double instead. f2c
2029 compatibility is only an issue with functions that don't
2030 require an explicit interface, as only these could be
2031 implemented in Fortran 77. */
2032 sym->ts.kind = gfc_default_double_kind;
2033 type = gfc_typenode_for_spec (&sym->ts);
2034 sym->ts.kind = gfc_default_real_kind;
2037 type = gfc_sym_type (sym);
2039 type = build_function_type (type, typelist);
2044 /* Language hooks for middle-end access to type nodes. */
2046 /* Return an integer type with BITS bits of precision,
2047 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2050 gfc_type_for_size (unsigned bits, int unsignedp)
2055 for (i = 0; i <= MAX_INT_KINDS; ++i)
2057 tree type = gfc_integer_types[i];
2058 if (type && bits == TYPE_PRECISION (type))
2062 /* Handle TImode as a special case because it is used by some backends
2063 (eg. ARM) even though it is not available for normal use. */
2064 #if HOST_BITS_PER_WIDE_INT >= 64
2065 if (bits == TYPE_PRECISION (intTI_type_node))
2066 return intTI_type_node;
2071 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2072 return unsigned_intQI_type_node;
2073 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2074 return unsigned_intHI_type_node;
2075 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2076 return unsigned_intSI_type_node;
2077 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2078 return unsigned_intDI_type_node;
2079 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2080 return unsigned_intTI_type_node;
2086 /* Return a data type that has machine mode MODE. If the mode is an
2087 integer, then UNSIGNEDP selects between signed and unsigned types. */
2090 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2095 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2096 base = gfc_real_types;
2097 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2098 base = gfc_complex_types;
2099 else if (SCALAR_INT_MODE_P (mode))
2100 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2101 else if (VECTOR_MODE_P (mode))
2103 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2104 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2105 if (inner_type != NULL_TREE)
2106 return build_vector_type_for_mode (inner_type, mode);
2112 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2114 tree type = base[i];
2115 if (type && mode == TYPE_MODE (type))
2122 #include "gt-fortran-trans-types.h"