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"
40 #include "dwarf2out.h"
43 #if (GFC_MAX_DIMENSIONS < 10)
44 #define GFC_RANK_DIGITS 1
45 #define GFC_RANK_PRINTF_FORMAT "%01d"
46 #elif (GFC_MAX_DIMENSIONS < 100)
47 #define GFC_RANK_DIGITS 2
48 #define GFC_RANK_PRINTF_FORMAT "%02d"
50 #error If you really need >99 dimensions, continue the sequence above...
53 /* array of structs so we don't have to worry about xmalloc or free */
54 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
56 static tree gfc_get_derived_type (gfc_symbol * derived);
58 tree gfc_array_index_type;
59 tree gfc_array_range_type;
60 tree gfc_character1_type_node;
62 tree ppvoid_type_node;
66 tree gfc_charlen_type_node;
68 static GTY(()) tree gfc_desc_dim_type;
69 static GTY(()) tree gfc_max_array_element_size;
70 static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
72 /* Arrays for all integral and real kinds. We'll fill this in at runtime
73 after the target has a chance to process command-line options. */
75 #define MAX_INT_KINDS 5
76 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
77 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
78 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
79 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
81 #define MAX_REAL_KINDS 5
82 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
83 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
84 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
87 /* The integer kind to use for array indices. This will be set to the
88 proper value based on target information from the backend. */
90 int gfc_index_integer_kind;
92 /* The default kinds of the various types. */
94 int gfc_default_integer_kind;
95 int gfc_max_integer_kind;
96 int gfc_default_real_kind;
97 int gfc_default_double_kind;
98 int gfc_default_character_kind;
99 int gfc_default_logical_kind;
100 int gfc_default_complex_kind;
103 /* The kind size used for record offsets. If the target system supports
104 kind=8, this will be set to 8, otherwise it is set to 4. */
107 /* The integer kind used to store character lengths. */
108 int gfc_charlen_int_kind;
110 /* The size of the numeric storage unit and character storage unit. */
111 int gfc_numeric_storage_size;
112 int gfc_character_storage_size;
115 /* Validate that the f90_type of the given gfc_typespec is valid for
116 the type it represents. The f90_type represents the Fortran types
117 this C kind can be used with. For example, c_int has a f90_type of
118 BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
119 if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
123 gfc_validate_c_kind (gfc_typespec *ts)
125 return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
130 gfc_check_any_c_kind (gfc_typespec *ts)
134 for (i = 0; i < ISOCBINDING_NUMBER; i++)
136 /* Check for any C interoperable kind for the given type/kind in ts.
137 This can be used after verify_c_interop to make sure that the
138 Fortran kind being used exists in at least some form for C. */
139 if (c_interop_kinds_table[i].f90_type == ts->type &&
140 c_interop_kinds_table[i].value == ts->kind)
149 get_real_kind_from_node (tree type)
153 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
154 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
155 return gfc_real_kinds[i].kind;
161 get_int_kind_from_node (tree type)
168 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
169 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
170 return gfc_integer_kinds[i].kind;
176 get_int_kind_from_width (int size)
180 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
181 if (gfc_integer_kinds[i].bit_size == size)
182 return gfc_integer_kinds[i].kind;
188 get_int_kind_from_minimal_width (int size)
192 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
193 if (gfc_integer_kinds[i].bit_size >= size)
194 return gfc_integer_kinds[i].kind;
200 /* Generate the CInteropKind_t objects for the C interoperable
204 void init_c_interop_kinds (void)
207 tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
209 (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
210 long_integer_type_node :
211 long_long_integer_type_node);
213 /* init all pointers in the list to NULL */
214 for (i = 0; i < ISOCBINDING_NUMBER; i++)
216 /* Initialize the name and value fields. */
217 c_interop_kinds_table[i].name[0] = '\0';
218 c_interop_kinds_table[i].value = -100;
219 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
222 #define NAMED_INTCST(a,b,c) \
223 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
224 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
225 c_interop_kinds_table[a].value = c;
226 #define NAMED_REALCST(a,b,c) \
227 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
228 c_interop_kinds_table[a].f90_type = BT_REAL; \
229 c_interop_kinds_table[a].value = c;
230 #define NAMED_CMPXCST(a,b,c) \
231 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
232 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
233 c_interop_kinds_table[a].value = c;
234 #define NAMED_LOGCST(a,b,c) \
235 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
236 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
237 c_interop_kinds_table[a].value = c;
238 #define NAMED_CHARKNDCST(a,b,c) \
239 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
240 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
241 c_interop_kinds_table[a].value = c;
242 #define NAMED_CHARCST(a,b,c) \
243 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
244 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
245 c_interop_kinds_table[a].value = c;
246 #define DERIVED_TYPE(a,b,c) \
247 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
248 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
249 c_interop_kinds_table[a].value = c;
250 #define PROCEDURE(a,b) \
251 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
252 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
253 c_interop_kinds_table[a].value = 0;
254 #include "iso-c-binding.def"
258 /* Query the target to determine which machine modes are available for
259 computation. Choose KIND numbers for them. */
262 gfc_init_kinds (void)
264 enum machine_mode mode;
265 int i_index, r_index;
266 bool saw_i4 = false, saw_i8 = false;
267 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
269 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
273 if (!targetm.scalar_mode_supported_p (mode))
276 /* The middle end doesn't support constants larger than 2*HWI.
277 Perhaps the target hook shouldn't have accepted these either,
278 but just to be safe... */
279 bitsize = GET_MODE_BITSIZE (mode);
280 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
283 gcc_assert (i_index != MAX_INT_KINDS);
285 /* Let the kind equal the bit size divided by 8. This insulates the
286 programmer from the underlying byte size. */
294 gfc_integer_kinds[i_index].kind = kind;
295 gfc_integer_kinds[i_index].radix = 2;
296 gfc_integer_kinds[i_index].digits = bitsize - 1;
297 gfc_integer_kinds[i_index].bit_size = bitsize;
299 gfc_logical_kinds[i_index].kind = kind;
300 gfc_logical_kinds[i_index].bit_size = bitsize;
305 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
306 used for large file access. */
313 /* If we do not at least have kind = 4, everything is pointless. */
316 /* Set the maximum integer kind. Used with at least BOZ constants. */
317 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
319 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
321 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
326 if (!targetm.scalar_mode_supported_p (mode))
329 /* Only let float/double/long double go through because the fortran
330 library assumes these are the only floating point types. */
332 if (mode != TYPE_MODE (float_type_node)
333 && (mode != TYPE_MODE (double_type_node))
334 && (mode != TYPE_MODE (long_double_type_node)))
337 /* Let the kind equal the precision divided by 8, rounding up. Again,
338 this insulates the programmer from the underlying byte size.
340 Also, it effectively deals with IEEE extended formats. There, the
341 total size of the type may equal 16, but it's got 6 bytes of padding
342 and the increased size can get in the way of a real IEEE quad format
343 which may also be supported by the target.
345 We round up so as to handle IA-64 __floatreg (RFmode), which is an
346 82 bit type. Not to be confused with __float80 (XFmode), which is
347 an 80 bit type also supported by IA-64. So XFmode should come out
348 to be kind=10, and RFmode should come out to be kind=11. Egads. */
350 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
359 /* Careful we don't stumble a wierd internal mode. */
360 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
361 /* Or have too many modes for the allocated space. */
362 gcc_assert (r_index != MAX_REAL_KINDS);
364 gfc_real_kinds[r_index].kind = kind;
365 gfc_real_kinds[r_index].radix = fmt->b;
366 gfc_real_kinds[r_index].digits = fmt->p;
367 gfc_real_kinds[r_index].min_exponent = fmt->emin;
368 gfc_real_kinds[r_index].max_exponent = fmt->emax;
369 if (fmt->pnan < fmt->p)
370 /* This is an IBM extended double format (or the MIPS variant)
371 made up of two IEEE doubles. The value of the long double is
372 the sum of the values of the two parts. The most significant
373 part is required to be the value of the long double rounded
374 to the nearest double. If we use emax of 1024 then we can't
375 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
376 rounding will make the most significant part overflow. */
377 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
378 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
382 /* Choose the default integer kind. We choose 4 unless the user
383 directs us otherwise. */
384 if (gfc_option.flag_default_integer)
387 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
388 gfc_default_integer_kind = 8;
390 /* Even if the user specified that the default integer kind be 8,
391 the numerica storage size isn't 64. In this case, a warning will
392 be issued when NUMERIC_STORAGE_SIZE is used. */
393 gfc_numeric_storage_size = 4 * 8;
397 gfc_default_integer_kind = 4;
398 gfc_numeric_storage_size = 4 * 8;
402 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
403 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
406 /* Choose the default real kind. Again, we choose 4 when possible. */
407 if (gfc_option.flag_default_real)
410 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
411 gfc_default_real_kind = 8;
414 gfc_default_real_kind = 4;
416 gfc_default_real_kind = gfc_real_kinds[0].kind;
418 /* Choose the default double kind. If -fdefault-real and -fdefault-double
419 are specified, we use kind=8, if it's available. If -fdefault-real is
420 specified without -fdefault-double, we use kind=16, if it's available.
421 Otherwise we do not change anything. */
422 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
423 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
425 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
426 gfc_default_double_kind = 8;
427 else if (gfc_option.flag_default_real && saw_r16)
428 gfc_default_double_kind = 16;
429 else if (saw_r4 && saw_r8)
430 gfc_default_double_kind = 8;
433 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
434 real ... occupies two contiguous numeric storage units.
436 Therefore we must be supplied a kind twice as large as we chose
437 for single precision. There are loopholes, in that double
438 precision must *occupy* two storage units, though it doesn't have
439 to *use* two storage units. Which means that you can make this
440 kind artificially wide by padding it. But at present there are
441 no GCC targets for which a two-word type does not exist, so we
442 just let gfc_validate_kind abort and tell us if something breaks. */
444 gfc_default_double_kind
445 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
448 /* The default logical kind is constrained to be the same as the
449 default integer kind. Similarly with complex and real. */
450 gfc_default_logical_kind = gfc_default_integer_kind;
451 gfc_default_complex_kind = gfc_default_real_kind;
453 /* Choose the smallest integer kind for our default character. */
454 gfc_default_character_kind = gfc_integer_kinds[0].kind;
455 gfc_character_storage_size = gfc_default_character_kind * 8;
457 /* Choose the integer kind the same size as "void*" for our index kind. */
458 gfc_index_integer_kind = POINTER_SIZE / 8;
459 /* Pick a kind the same size as the C "int" type. */
460 gfc_c_int_kind = INT_TYPE_SIZE / 8;
462 /* initialize the C interoperable kinds */
463 init_c_interop_kinds();
466 /* Make sure that a valid kind is present. Returns an index into the
467 associated kinds array, -1 if the kind is not present. */
470 validate_integer (int kind)
474 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
475 if (gfc_integer_kinds[i].kind == kind)
482 validate_real (int kind)
486 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
487 if (gfc_real_kinds[i].kind == kind)
494 validate_logical (int kind)
498 for (i = 0; gfc_logical_kinds[i].kind; i++)
499 if (gfc_logical_kinds[i].kind == kind)
506 validate_character (int kind)
508 return kind == gfc_default_character_kind ? 0 : -1;
511 /* Validate a kind given a basic type. The return value is the same
512 for the child functions, with -1 indicating nonexistence of the
513 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
516 gfc_validate_kind (bt type, int kind, bool may_fail)
522 case BT_REAL: /* Fall through */
524 rc = validate_real (kind);
527 rc = validate_integer (kind);
530 rc = validate_logical (kind);
533 rc = validate_character (kind);
537 gfc_internal_error ("gfc_validate_kind(): Got bad type");
540 if (rc < 0 && !may_fail)
541 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
547 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
548 Reuse common type nodes where possible. Recognize if the kind matches up
549 with a C type. This will be used later in determining which routines may
550 be scarfed from libm. */
553 gfc_build_int_type (gfc_integer_info *info)
555 int mode_precision = info->bit_size;
557 if (mode_precision == CHAR_TYPE_SIZE)
559 if (mode_precision == SHORT_TYPE_SIZE)
561 if (mode_precision == INT_TYPE_SIZE)
563 if (mode_precision == LONG_TYPE_SIZE)
565 if (mode_precision == LONG_LONG_TYPE_SIZE)
566 info->c_long_long = 1;
568 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
569 return intQI_type_node;
570 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
571 return intHI_type_node;
572 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
573 return intSI_type_node;
574 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
575 return intDI_type_node;
576 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
577 return intTI_type_node;
579 return make_signed_type (mode_precision);
583 gfc_build_real_type (gfc_real_info *info)
585 int mode_precision = info->mode_precision;
588 if (mode_precision == FLOAT_TYPE_SIZE)
590 if (mode_precision == DOUBLE_TYPE_SIZE)
592 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
593 info->c_long_double = 1;
595 if (TYPE_PRECISION (float_type_node) == mode_precision)
596 return float_type_node;
597 if (TYPE_PRECISION (double_type_node) == mode_precision)
598 return double_type_node;
599 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
600 return long_double_type_node;
602 new_type = make_node (REAL_TYPE);
603 TYPE_PRECISION (new_type) = mode_precision;
604 layout_type (new_type);
609 gfc_build_complex_type (tree scalar_type)
613 if (scalar_type == NULL)
615 if (scalar_type == float_type_node)
616 return complex_float_type_node;
617 if (scalar_type == double_type_node)
618 return complex_double_type_node;
619 if (scalar_type == long_double_type_node)
620 return complex_long_double_type_node;
622 new_type = make_node (COMPLEX_TYPE);
623 TREE_TYPE (new_type) = scalar_type;
624 layout_type (new_type);
629 gfc_build_logical_type (gfc_logical_info *info)
631 int bit_size = info->bit_size;
634 if (bit_size == BOOL_TYPE_SIZE)
637 return boolean_type_node;
640 new_type = make_unsigned_type (bit_size);
641 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
642 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
643 TYPE_PRECISION (new_type) = 1;
649 /* Return the bit size of the C "size_t". */
655 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
656 return INT_TYPE_SIZE;
657 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
658 return LONG_TYPE_SIZE;
659 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
660 return SHORT_TYPE_SIZE;
663 return LONG_TYPE_SIZE;
668 /* Create the backend type nodes. We map them to their
669 equivalent C type, at least for now. We also give
670 names to the types here, and we push them in the
671 global binding level context.*/
674 gfc_init_types (void)
680 unsigned HOST_WIDE_INT hi;
681 unsigned HOST_WIDE_INT lo;
683 /* Create and name the types. */
684 #define PUSH_TYPE(name, node) \
685 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
687 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
689 type = gfc_build_int_type (&gfc_integer_kinds[index]);
690 gfc_integer_types[index] = type;
691 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
692 gfc_integer_kinds[index].kind);
693 PUSH_TYPE (name_buf, type);
696 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
698 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
699 gfc_logical_types[index] = type;
700 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
701 gfc_logical_kinds[index].kind);
702 PUSH_TYPE (name_buf, type);
705 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
707 type = gfc_build_real_type (&gfc_real_kinds[index]);
708 gfc_real_types[index] = type;
709 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
710 gfc_real_kinds[index].kind);
711 PUSH_TYPE (name_buf, type);
713 type = gfc_build_complex_type (type);
714 gfc_complex_types[index] = type;
715 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
716 gfc_real_kinds[index].kind);
717 PUSH_TYPE (name_buf, type);
720 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
722 PUSH_TYPE ("character(kind=1)", gfc_character1_type_node);
724 PUSH_TYPE ("byte", unsigned_char_type_node);
725 PUSH_TYPE ("void", void_type_node);
727 /* DBX debugging output gets upset if these aren't set. */
728 if (!TYPE_NAME (integer_type_node))
729 PUSH_TYPE ("c_integer", integer_type_node);
730 if (!TYPE_NAME (char_type_node))
731 PUSH_TYPE ("c_char", char_type_node);
735 pvoid_type_node = build_pointer_type (void_type_node);
736 ppvoid_type_node = build_pointer_type (pvoid_type_node);
737 pchar_type_node = build_pointer_type (gfc_character1_type_node);
739 = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
741 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
742 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
743 since this function is called before gfc_init_constants. */
745 = build_range_type (gfc_array_index_type,
746 build_int_cst (gfc_array_index_type, 0),
749 /* The maximum array element size that can be handled is determined
750 by the number of bits available to store this field in the array
753 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
754 lo = ~ (unsigned HOST_WIDE_INT) 0;
755 if (n > HOST_BITS_PER_WIDE_INT)
756 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
758 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
759 gfc_max_array_element_size
760 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
762 size_type_node = gfc_array_index_type;
764 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
765 boolean_true_node = build_int_cst (boolean_type_node, 1);
766 boolean_false_node = build_int_cst (boolean_type_node, 0);
768 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
769 gfc_charlen_int_kind = 4;
770 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
773 /* Get the type node for the given type and kind. */
776 gfc_get_int_type (int kind)
778 int index = gfc_validate_kind (BT_INTEGER, kind, true);
779 return index < 0 ? 0 : gfc_integer_types[index];
783 gfc_get_real_type (int kind)
785 int index = gfc_validate_kind (BT_REAL, kind, true);
786 return index < 0 ? 0 : gfc_real_types[index];
790 gfc_get_complex_type (int kind)
792 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
793 return index < 0 ? 0 : gfc_complex_types[index];
797 gfc_get_logical_type (int kind)
799 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
800 return index < 0 ? 0 : gfc_logical_types[index];
803 /* Create a character type with the given kind and length. */
806 gfc_get_character_type_len (int kind, tree len)
810 gfc_validate_kind (BT_CHARACTER, kind, false);
812 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
813 type = build_array_type (gfc_character1_type_node, bounds);
814 TYPE_STRING_FLAG (type) = 1;
820 /* Get a type node for a character kind. */
823 gfc_get_character_type (int kind, gfc_charlen * cl)
827 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
829 return gfc_get_character_type_len (kind, len);
832 /* Covert a basic type. This will be an array for character types. */
835 gfc_typenode_for_spec (gfc_typespec * spec)
845 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
846 has been resolved. This is done so we can convert C_PTR and
847 C_FUNPTR to simple variables that get translated to (void *). */
848 if (spec->f90_type == BT_VOID)
851 && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
852 basetype = ptr_type_node;
854 basetype = pfunc_type_node;
857 basetype = gfc_get_int_type (spec->kind);
861 basetype = gfc_get_real_type (spec->kind);
865 basetype = gfc_get_complex_type (spec->kind);
869 basetype = gfc_get_logical_type (spec->kind);
873 basetype = gfc_get_character_type (spec->kind, spec->cl);
877 basetype = gfc_get_derived_type (spec->derived);
879 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
880 type and kind to fit a (void *) and the basetype returned was a
881 ptr_type_node. We need to pass up this new information to the
882 symbol that was declared of type C_PTR or C_FUNPTR. */
883 if (spec->derived->attr.is_iso_c)
885 spec->type = spec->derived->ts.type;
886 spec->kind = spec->derived->ts.kind;
887 spec->f90_type = spec->derived->ts.f90_type;
891 /* This is for the second arg to c_f_pointer and c_f_procpointer
892 of the iso_c_binding module, to accept any ptr type. */
893 basetype = ptr_type_node;
894 if (spec->f90_type == BT_VOID)
897 && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
898 basetype = ptr_type_node;
900 basetype = pfunc_type_node;
909 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
912 gfc_conv_array_bound (gfc_expr * expr)
914 /* If expr is an integer constant, return that. */
915 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
916 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
918 /* Otherwise return NULL. */
923 gfc_get_element_type (tree type)
927 if (GFC_ARRAY_TYPE_P (type))
929 if (TREE_CODE (type) == POINTER_TYPE)
930 type = TREE_TYPE (type);
931 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
932 element = TREE_TYPE (type);
936 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
937 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
939 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
940 element = TREE_TYPE (element);
942 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
943 element = TREE_TYPE (element);
949 /* Build an array. This function is called from gfc_sym_type().
950 Actually returns array descriptor type.
952 Format of array descriptors is as follows:
954 struct gfc_array_descriptor
959 struct descriptor_dimension dimension[N_DIM];
962 struct descriptor_dimension
969 Translation code should use gfc_conv_descriptor_* rather than
970 accessing the descriptor directly. Any changes to the array
971 descriptor type will require changes in gfc_conv_descriptor_* and
972 gfc_build_array_initializer.
974 This is represented internally as a RECORD_TYPE. The index nodes
975 are gfc_array_index_type and the data node is a pointer to the
976 data. See below for the handling of character types.
978 The dtype member is formatted as follows:
979 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
980 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
981 size = dtype >> GFC_DTYPE_SIZE_SHIFT
983 I originally used nested ARRAY_TYPE nodes to represent arrays, but
984 this generated poor code for assumed/deferred size arrays. These
985 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
986 of the GENERIC grammar. Also, there is no way to explicitly set
987 the array stride, so all data must be packed(1). I've tried to
988 mark all the functions which would require modification with a GCC
991 The data component points to the first element in the array. The
992 offset field is the position of the origin of the array (ie element
993 (0, 0 ...)). This may be outsite the bounds of the array.
995 An element is accessed by
996 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
997 This gives good performance as the computation does not involve the
998 bounds of the array. For packed arrays, this is optimized further
999 by substituting the known strides.
1001 This system has one problem: all array bounds must be within 2^31
1002 elements of the origin (2^63 on 64-bit machines). For example
1003 integer, dimension (80000:90000, 80000:90000, 2) :: array
1004 may not work properly on 32-bit machines because 80000*80000 >
1005 2^31, so the calculation for stride02 would overflow. This may
1006 still work, but I haven't checked, and it relies on the overflow
1007 doing the right thing.
1009 The way to fix this problem is to access elements as follows:
1010 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1011 Obviously this is much slower. I will make this a compile time
1012 option, something like -fsmall-array-offsets. Mixing code compiled
1013 with and without this switch will work.
1015 (1) This can be worked around by modifying the upper bound of the
1016 previous dimension. This requires extra fields in the descriptor
1017 (both real_ubound and fake_ubound). */
1020 /* Returns true if the array sym does not require a descriptor. */
1023 gfc_is_nodesc_array (gfc_symbol * sym)
1025 gcc_assert (sym->attr.dimension);
1027 /* We only want local arrays. */
1028 if (sym->attr.pointer || sym->attr.allocatable)
1031 if (sym->attr.dummy)
1033 if (sym->as->type != AS_ASSUMED_SHAPE)
1039 if (sym->attr.result || sym->attr.function)
1042 gcc_assert (sym->as->type == AS_EXPLICIT);
1048 /* Create an array descriptor type. */
1051 gfc_build_array_type (tree type, gfc_array_spec * as,
1052 enum gfc_array_kind akind)
1054 tree lbound[GFC_MAX_DIMENSIONS];
1055 tree ubound[GFC_MAX_DIMENSIONS];
1058 for (n = 0; n < as->rank; n++)
1060 /* Create expressions for the known bounds of the array. */
1061 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1062 lbound[n] = gfc_index_one_node;
1064 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1065 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1068 if (as->type == AS_ASSUMED_SHAPE)
1069 akind = GFC_ARRAY_ASSUMED_SHAPE;
1070 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind);
1073 /* Returns the struct descriptor_dimension type. */
1076 gfc_get_desc_dim_type (void)
1082 if (gfc_desc_dim_type)
1083 return gfc_desc_dim_type;
1085 /* Build the type node. */
1086 type = make_node (RECORD_TYPE);
1088 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1089 TYPE_PACKED (type) = 1;
1091 /* Consists of the stride, lbound and ubound members. */
1092 decl = build_decl (FIELD_DECL,
1093 get_identifier ("stride"), gfc_array_index_type);
1094 DECL_CONTEXT (decl) = type;
1095 TREE_NO_WARNING (decl) = 1;
1098 decl = build_decl (FIELD_DECL,
1099 get_identifier ("lbound"), gfc_array_index_type);
1100 DECL_CONTEXT (decl) = type;
1101 TREE_NO_WARNING (decl) = 1;
1102 fieldlist = chainon (fieldlist, decl);
1104 decl = build_decl (FIELD_DECL,
1105 get_identifier ("ubound"), gfc_array_index_type);
1106 DECL_CONTEXT (decl) = type;
1107 TREE_NO_WARNING (decl) = 1;
1108 fieldlist = chainon (fieldlist, decl);
1110 /* Finish off the type. */
1111 TYPE_FIELDS (type) = fieldlist;
1113 gfc_finish_type (type);
1114 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1116 gfc_desc_dim_type = type;
1121 /* Return the DTYPE for an array. This describes the type and type parameters
1123 /* TODO: Only call this when the value is actually used, and make all the
1124 unknown cases abort. */
1127 gfc_get_dtype (tree type)
1137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1139 if (GFC_TYPE_ARRAY_DTYPE (type))
1140 return GFC_TYPE_ARRAY_DTYPE (type);
1142 rank = GFC_TYPE_ARRAY_RANK (type);
1143 etype = gfc_get_element_type (type);
1145 switch (TREE_CODE (etype))
1148 n = GFC_DTYPE_INTEGER;
1152 n = GFC_DTYPE_LOGICAL;
1160 n = GFC_DTYPE_COMPLEX;
1163 /* We will never have arrays of arrays. */
1165 n = GFC_DTYPE_DERIVED;
1169 n = GFC_DTYPE_CHARACTER;
1173 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1174 /* We can strange array types for temporary arrays. */
1175 return gfc_index_zero_node;
1178 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1179 size = TYPE_SIZE_UNIT (etype);
1181 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1182 if (size && INTEGER_CST_P (size))
1184 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1185 internal_error ("Array element size too big");
1187 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1189 dtype = build_int_cst (gfc_array_index_type, i);
1191 if (size && !INTEGER_CST_P (size))
1193 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1194 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
1195 fold_convert (gfc_array_index_type, size), tmp);
1196 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
1198 /* If we don't know the size we leave it as zero. This should never happen
1199 for anything that is actually used. */
1200 /* TODO: Check this is actually true, particularly when repacking
1201 assumed size parameters. */
1203 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1208 /* Build an array type for use without a descriptor, packed according
1209 to the value of PACKED. */
1212 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
1225 mpz_init_set_ui (offset, 0);
1226 mpz_init_set_ui (stride, 1);
1229 /* We don't use build_array_type because this does not include include
1230 lang-specific information (i.e. the bounds of the array) when checking
1232 type = make_node (ARRAY_TYPE);
1234 GFC_ARRAY_TYPE_P (type) = 1;
1235 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1236 ggc_alloc_cleared (sizeof (struct lang_type));
1238 known_stride = (packed != PACKED_NO);
1240 for (n = 0; n < as->rank; n++)
1242 /* Fill in the stride and bound components of the type. */
1244 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1247 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1249 expr = as->lower[n];
1250 if (expr->expr_type == EXPR_CONSTANT)
1252 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1253 gfc_index_integer_kind);
1260 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1264 /* Calculate the offset. */
1265 mpz_mul (delta, stride, as->lower[n]->value.integer);
1266 mpz_sub (offset, offset, delta);
1271 expr = as->upper[n];
1272 if (expr && expr->expr_type == EXPR_CONSTANT)
1274 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1275 gfc_index_integer_kind);
1282 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1286 /* Calculate the stride. */
1287 mpz_sub (delta, as->upper[n]->value.integer,
1288 as->lower[n]->value.integer);
1289 mpz_add_ui (delta, delta, 1);
1290 mpz_mul (stride, stride, delta);
1293 /* Only the first stride is known for partial packed arrays. */
1294 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1300 GFC_TYPE_ARRAY_OFFSET (type) =
1301 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1304 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1308 GFC_TYPE_ARRAY_SIZE (type) =
1309 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1312 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1314 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1315 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1316 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1318 /* TODO: use main type if it is unbounded. */
1319 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1320 build_pointer_type (build_array_type (etype, range));
1324 mpz_sub_ui (stride, stride, 1);
1325 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1330 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1331 TYPE_DOMAIN (type) = range;
1333 build_pointer_type (etype);
1334 TREE_TYPE (type) = etype;
1342 /* In debug info represent packed arrays as multi-dimensional
1343 if they have rank > 1 and with proper bounds, instead of flat
1345 if (known_offset && write_symbols != NO_DEBUG)
1347 tree gtype = etype, rtype, type_decl;
1349 for (n = as->rank - 1; n >= 0; n--)
1351 rtype = build_range_type (gfc_array_index_type,
1352 GFC_TYPE_ARRAY_LBOUND (type, n),
1353 GFC_TYPE_ARRAY_UBOUND (type, n));
1354 gtype = build_array_type (gtype, rtype);
1356 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
1357 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1360 if (packed != PACKED_STATIC || !known_stride)
1362 /* For dummy arrays and automatic (heap allocated) arrays we
1363 want a pointer to the array. */
1364 type = build_pointer_type (type);
1365 GFC_ARRAY_TYPE_P (type) = 1;
1366 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1371 /* Return or create the base type for an array descriptor. */
1374 gfc_get_array_descriptor_base (int dimen)
1376 tree fat_type, fieldlist, decl, arraytype;
1377 char name[16 + GFC_RANK_DIGITS + 1];
1379 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1380 if (gfc_array_descriptor_base[dimen - 1])
1381 return gfc_array_descriptor_base[dimen - 1];
1383 /* Build the type node. */
1384 fat_type = make_node (RECORD_TYPE);
1386 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1387 TYPE_NAME (fat_type) = get_identifier (name);
1389 /* Add the data member as the first element of the descriptor. */
1390 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1392 DECL_CONTEXT (decl) = fat_type;
1395 /* Add the base component. */
1396 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1397 gfc_array_index_type);
1398 DECL_CONTEXT (decl) = fat_type;
1399 TREE_NO_WARNING (decl) = 1;
1400 fieldlist = chainon (fieldlist, decl);
1402 /* Add the dtype component. */
1403 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1404 gfc_array_index_type);
1405 DECL_CONTEXT (decl) = fat_type;
1406 TREE_NO_WARNING (decl) = 1;
1407 fieldlist = chainon (fieldlist, decl);
1409 /* Build the array type for the stride and bound components. */
1411 build_array_type (gfc_get_desc_dim_type (),
1412 build_range_type (gfc_array_index_type,
1413 gfc_index_zero_node,
1414 gfc_rank_cst[dimen - 1]));
1416 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1417 DECL_CONTEXT (decl) = fat_type;
1418 TREE_NO_WARNING (decl) = 1;
1419 fieldlist = chainon (fieldlist, decl);
1421 /* Finish off the type. */
1422 TYPE_FIELDS (fat_type) = fieldlist;
1424 gfc_finish_type (fat_type);
1425 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1427 gfc_array_descriptor_base[dimen - 1] = fat_type;
1431 /* Build an array (descriptor) type with given bounds. */
1434 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1435 tree * ubound, int packed,
1436 enum gfc_array_kind akind)
1438 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1439 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1440 const char *typename;
1443 base_type = gfc_get_array_descriptor_base (dimen);
1444 fat_type = build_variant_type_copy (base_type);
1446 tmp = TYPE_NAME (etype);
1447 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1448 tmp = DECL_NAME (tmp);
1450 typename = IDENTIFIER_POINTER (tmp);
1452 typename = "unknown";
1453 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1454 GFC_MAX_SYMBOL_LEN, typename);
1455 TYPE_NAME (fat_type) = get_identifier (name);
1457 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1458 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1459 ggc_alloc_cleared (sizeof (struct lang_type));
1461 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1462 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1463 GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1465 /* Build an array descriptor record type. */
1467 stride = gfc_index_one_node;
1470 for (n = 0; n < dimen; n++)
1472 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1479 if (lower != NULL_TREE)
1481 if (INTEGER_CST_P (lower))
1482 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1488 if (upper != NULL_TREE)
1490 if (INTEGER_CST_P (upper))
1491 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1496 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1498 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1499 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1500 gfc_index_one_node);
1502 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1503 /* Check the folding worked. */
1504 gcc_assert (INTEGER_CST_P (stride));
1509 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1511 /* TODO: known offsets for descriptors. */
1512 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1514 /* We define data as an unknown size array. Much better than doing
1515 pointer arithmetic. */
1517 build_array_type (etype, gfc_array_range_type);
1518 arraytype = build_pointer_type (arraytype);
1519 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1524 /* Build a pointer type. This function is called from gfc_sym_type(). */
1527 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1529 /* Array pointer types aren't actually pointers. */
1530 if (sym->attr.dimension)
1533 return build_pointer_type (type);
1536 /* Return the type for a symbol. Special handling is required for character
1537 types to get the correct level of indirection.
1538 For functions return the return type.
1539 For subroutines return void_type_node.
1540 Calling this multiple times for the same symbol should be avoided,
1541 especially for character and array types. */
1544 gfc_sym_type (gfc_symbol * sym)
1549 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1550 return void_type_node;
1552 /* In the case of a function the fake result variable may have a
1553 type different from the function type, so don't return early in
1555 if (sym->backend_decl && !sym->attr.function)
1556 return TREE_TYPE (sym->backend_decl);
1558 type = gfc_typenode_for_spec (&sym->ts);
1560 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1565 if (sym->attr.dimension)
1567 if (gfc_is_nodesc_array (sym))
1569 /* If this is a character argument of unknown length, just use the
1571 if (sym->ts.type != BT_CHARACTER
1572 || !(sym->attr.dummy || sym->attr.function)
1573 || sym->ts.cl->backend_decl)
1575 type = gfc_get_nodesc_array_type (type, sym->as,
1583 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
1584 if (sym->attr.pointer)
1585 akind = GFC_ARRAY_POINTER;
1586 else if (sym->attr.allocatable)
1587 akind = GFC_ARRAY_ALLOCATABLE;
1588 type = gfc_build_array_type (type, sym->as, akind);
1593 if (sym->attr.allocatable || sym->attr.pointer)
1594 type = gfc_build_pointer_type (sym, type);
1595 if (sym->attr.pointer)
1596 GFC_POINTER_TYPE_P (type) = 1;
1599 /* We currently pass all parameters by reference.
1600 See f95_get_function_decl. For dummy function parameters return the
1604 /* We must use pointer types for potentially absent variables. The
1605 optimizers assume a reference type argument is never NULL. */
1606 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1607 type = build_pointer_type (type);
1609 type = build_reference_type (type);
1615 /* Layout and output debug info for a record type. */
1618 gfc_finish_type (tree type)
1622 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1623 TYPE_STUB_DECL (type) = decl;
1625 rest_of_type_compilation (type, 1);
1626 rest_of_decl_compilation (decl, 1, 0);
1629 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1630 or RECORD_TYPE pointed to by STYPE. The new field is chained
1631 to the fieldlist pointed to by FIELDLIST.
1633 Returns a pointer to the new field. */
1636 gfc_add_field_to_struct (tree *fieldlist, tree context,
1637 tree name, tree type)
1641 decl = build_decl (FIELD_DECL, name, type);
1643 DECL_CONTEXT (decl) = context;
1644 DECL_INITIAL (decl) = 0;
1645 DECL_ALIGN (decl) = 0;
1646 DECL_USER_ALIGN (decl) = 0;
1647 TREE_CHAIN (decl) = NULL_TREE;
1648 *fieldlist = chainon (*fieldlist, decl);
1654 /* Copy the backend_decl and component backend_decls if
1655 the two derived type symbols are "equal", as described
1656 in 4.4.2 and resolved by gfc_compare_derived_types. */
1659 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1661 gfc_component *to_cm;
1662 gfc_component *from_cm;
1664 if (from->backend_decl == NULL
1665 || !gfc_compare_derived_types (from, to))
1668 to->backend_decl = from->backend_decl;
1670 to_cm = to->components;
1671 from_cm = from->components;
1673 /* Copy the component declarations. If a component is itself
1674 a derived type, we need a copy of its component declarations.
1675 This is done by recursing into gfc_get_derived_type and
1676 ensures that the component's component declarations have
1677 been built. If it is a character, we need the character
1679 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1681 to_cm->backend_decl = from_cm->backend_decl;
1682 if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
1683 gfc_get_derived_type (to_cm->ts.derived);
1685 else if (from_cm->ts.type == BT_CHARACTER)
1686 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1693 /* Build a tree node for a derived type. If there are equal
1694 derived types, with different local names, these are built
1695 at the same time. If an equal derived type has been built
1696 in a parent namespace, this is used. */
1699 gfc_get_derived_type (gfc_symbol * derived)
1701 tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1705 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1707 /* See if it's one of the iso_c_binding derived types. */
1708 if (derived->attr.is_iso_c == 1)
1710 if (derived->backend_decl)
1711 return derived->backend_decl;
1713 if (derived->intmod_sym_id == ISOCBINDING_PTR)
1714 derived->backend_decl = ptr_type_node;
1716 derived->backend_decl = pfunc_type_node;
1718 /* Create a backend_decl for the __c_ptr_c_address field. */
1719 derived->components->backend_decl =
1720 gfc_add_field_to_struct (&(derived->backend_decl->type.values),
1721 derived->backend_decl,
1722 get_identifier (derived->components->name),
1723 gfc_typenode_for_spec (
1724 &(derived->components->ts)));
1726 derived->ts.kind = gfc_index_integer_kind;
1727 derived->ts.type = BT_INTEGER;
1728 /* Set the f90_type to BT_VOID as a way to recognize something of type
1729 BT_INTEGER that needs to fit a void * for the purpose of the
1730 iso_c_binding derived types. */
1731 derived->ts.f90_type = BT_VOID;
1733 return derived->backend_decl;
1736 /* derived->backend_decl != 0 means we saw it before, but its
1737 components' backend_decl may have not been built. */
1738 if (derived->backend_decl)
1740 /* Its components' backend_decl have been built. */
1741 if (TYPE_FIELDS (derived->backend_decl))
1742 return derived->backend_decl;
1744 typenode = derived->backend_decl;
1749 /* We see this derived type first time, so build the type node. */
1750 typenode = make_node (RECORD_TYPE);
1751 TYPE_NAME (typenode) = get_identifier (derived->name);
1752 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1753 derived->backend_decl = typenode;
1756 /* Go through the derived type components, building them as
1757 necessary. The reason for doing this now is that it is
1758 possible to recurse back to this derived type through a
1759 pointer component (PR24092). If this happens, the fields
1760 will be built and so we can return the type. */
1761 for (c = derived->components; c; c = c->next)
1763 if (c->ts.type != BT_DERIVED)
1766 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1767 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1769 if (c->ts.derived && c->ts.derived->attr.is_iso_c)
1771 /* Need to copy the modified ts from the derived type. The
1772 typespec was modified because C_PTR/C_FUNPTR are translated
1773 into (void *) from derived types. */
1774 c->ts.type = c->ts.derived->ts.type;
1775 c->ts.kind = c->ts.derived->ts.kind;
1776 c->ts.f90_type = c->ts.derived->ts.f90_type;
1779 c->initializer->ts.type = c->ts.type;
1780 c->initializer->ts.kind = c->ts.kind;
1781 c->initializer->ts.f90_type = c->ts.f90_type;
1782 c->initializer->expr_type = EXPR_NULL;
1787 if (TYPE_FIELDS (derived->backend_decl))
1788 return derived->backend_decl;
1790 /* Build the type member list. Install the newly created RECORD_TYPE
1791 node as DECL_CONTEXT of each FIELD_DECL. */
1792 fieldlist = NULL_TREE;
1793 for (c = derived->components; c; c = c->next)
1795 if (c->ts.type == BT_DERIVED)
1796 field_type = c->ts.derived->backend_decl;
1799 if (c->ts.type == BT_CHARACTER)
1801 /* Evaluate the string length. */
1802 gfc_conv_const_charlen (c->ts.cl);
1803 gcc_assert (c->ts.cl->backend_decl);
1806 field_type = gfc_typenode_for_spec (&c->ts);
1809 /* This returns an array descriptor type. Initialization may be
1813 if (c->pointer || c->allocatable)
1815 enum gfc_array_kind akind;
1817 akind = GFC_ARRAY_POINTER;
1819 akind = GFC_ARRAY_ALLOCATABLE;
1820 /* Pointers to arrays aren't actually pointer types. The
1821 descriptors are separate, but the data is common. */
1822 field_type = gfc_build_array_type (field_type, c->as, akind);
1825 field_type = gfc_get_nodesc_array_type (field_type, c->as,
1828 else if (c->pointer)
1829 field_type = build_pointer_type (field_type);
1831 field = gfc_add_field_to_struct (&fieldlist, typenode,
1832 get_identifier (c->name),
1835 gfc_set_decl_location (field, &c->loc);
1836 else if (derived->declared_at.lb)
1837 gfc_set_decl_location (field, &derived->declared_at);
1839 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1842 if (!c->backend_decl)
1843 c->backend_decl = field;
1846 /* Now we have the final fieldlist. Record it, then lay out the
1847 derived type, including the fields. */
1848 TYPE_FIELDS (typenode) = fieldlist;
1850 gfc_finish_type (typenode);
1851 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
1853 derived->backend_decl = typenode;
1855 /* Add this backend_decl to all the other, equal derived types. */
1856 for (dt = gfc_derived_types; dt; dt = dt->next)
1857 copy_dt_decls_ifequal (derived, dt->derived);
1859 return derived->backend_decl;
1864 gfc_return_by_reference (gfc_symbol * sym)
1866 if (!sym->attr.function)
1869 if (sym->attr.dimension)
1872 if (sym->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
1875 /* Possibly return complex numbers by reference for g77 compatibility.
1876 We don't do this for calls to intrinsics (as the library uses the
1877 -fno-f2c calling convention), nor for calls to functions which always
1878 require an explicit interface, as no compatibility problems can
1880 if (gfc_option.flag_f2c
1881 && sym->ts.type == BT_COMPLEX
1882 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1889 gfc_get_mixed_entry_union (gfc_namespace *ns)
1894 char name[GFC_MAX_SYMBOL_LEN + 1];
1895 gfc_entry_list *el, *el2;
1897 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1898 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1900 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1902 /* Build the type node. */
1903 type = make_node (UNION_TYPE);
1905 TYPE_NAME (type) = get_identifier (name);
1908 for (el = ns->entries; el; el = el->next)
1910 /* Search for duplicates. */
1911 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1912 if (el2->sym->result == el->sym->result)
1917 decl = build_decl (FIELD_DECL,
1918 get_identifier (el->sym->result->name),
1919 gfc_sym_type (el->sym->result));
1920 DECL_CONTEXT (decl) = type;
1921 fieldlist = chainon (fieldlist, decl);
1925 /* Finish off the type. */
1926 TYPE_FIELDS (type) = fieldlist;
1928 gfc_finish_type (type);
1929 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1934 gfc_get_function_type (gfc_symbol * sym)
1938 gfc_formal_arglist *f;
1941 int alternate_return;
1943 /* Make sure this symbol is a function, a subroutine or the main
1945 gcc_assert (sym->attr.flavor == FL_PROCEDURE
1946 || sym->attr.flavor == FL_PROGRAM);
1948 if (sym->backend_decl)
1949 return TREE_TYPE (sym->backend_decl);
1952 alternate_return = 0;
1953 typelist = NULL_TREE;
1955 if (sym->attr.entry_master)
1957 /* Additional parameter for selecting an entry point. */
1958 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1966 if (arg->ts.type == BT_CHARACTER)
1967 gfc_conv_const_charlen (arg->ts.cl);
1969 /* Some functions we use an extra parameter for the return value. */
1970 if (gfc_return_by_reference (sym))
1972 type = gfc_sym_type (arg);
1973 if (arg->ts.type == BT_COMPLEX
1974 || arg->attr.dimension
1975 || arg->ts.type == BT_CHARACTER)
1976 type = build_reference_type (type);
1978 typelist = gfc_chainon_list (typelist, type);
1979 if (arg->ts.type == BT_CHARACTER)
1980 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1983 /* Build the argument types for the function. */
1984 for (f = sym->formal; f; f = f->next)
1989 /* Evaluate constant character lengths here so that they can be
1990 included in the type. */
1991 if (arg->ts.type == BT_CHARACTER)
1992 gfc_conv_const_charlen (arg->ts.cl);
1994 if (arg->attr.flavor == FL_PROCEDURE)
1996 type = gfc_get_function_type (arg);
1997 type = build_pointer_type (type);
2000 type = gfc_sym_type (arg);
2002 /* Parameter Passing Convention
2004 We currently pass all parameters by reference.
2005 Parameters with INTENT(IN) could be passed by value.
2006 The problem arises if a function is called via an implicit
2007 prototype. In this situation the INTENT is not known.
2008 For this reason all parameters to global functions must be
2009 passed by reference. Passing by value would potentially
2010 generate bad code. Worse there would be no way of telling that
2011 this code was bad, except that it would give incorrect results.
2013 Contained procedures could pass by value as these are never
2014 used without an explicit interface, and cannot be passed as
2015 actual parameters for a dummy procedure. */
2016 if (arg->ts.type == BT_CHARACTER)
2018 typelist = gfc_chainon_list (typelist, type);
2022 if (sym->attr.subroutine)
2023 alternate_return = 1;
2027 /* Add hidden string length parameters. */
2029 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2032 typelist = gfc_chainon_list (typelist, void_type_node);
2034 if (alternate_return)
2035 type = integer_type_node;
2036 else if (!sym->attr.function || gfc_return_by_reference (sym))
2037 type = void_type_node;
2038 else if (sym->attr.mixed_entry_master)
2039 type = gfc_get_mixed_entry_union (sym->ns);
2040 else if (gfc_option.flag_f2c
2041 && sym->ts.type == BT_REAL
2042 && sym->ts.kind == gfc_default_real_kind
2043 && !sym->attr.always_explicit)
2045 /* Special case: f2c calling conventions require that (scalar)
2046 default REAL functions return the C type double instead. f2c
2047 compatibility is only an issue with functions that don't
2048 require an explicit interface, as only these could be
2049 implemented in Fortran 77. */
2050 sym->ts.kind = gfc_default_double_kind;
2051 type = gfc_typenode_for_spec (&sym->ts);
2052 sym->ts.kind = gfc_default_real_kind;
2055 type = gfc_sym_type (sym);
2057 type = build_function_type (type, typelist);
2062 /* Language hooks for middle-end access to type nodes. */
2064 /* Return an integer type with BITS bits of precision,
2065 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2068 gfc_type_for_size (unsigned bits, int unsignedp)
2073 for (i = 0; i <= MAX_INT_KINDS; ++i)
2075 tree type = gfc_integer_types[i];
2076 if (type && bits == TYPE_PRECISION (type))
2080 /* Handle TImode as a special case because it is used by some backends
2081 (eg. ARM) even though it is not available for normal use. */
2082 #if HOST_BITS_PER_WIDE_INT >= 64
2083 if (bits == TYPE_PRECISION (intTI_type_node))
2084 return intTI_type_node;
2089 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2090 return unsigned_intQI_type_node;
2091 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2092 return unsigned_intHI_type_node;
2093 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2094 return unsigned_intSI_type_node;
2095 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2096 return unsigned_intDI_type_node;
2097 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2098 return unsigned_intTI_type_node;
2104 /* Return a data type that has machine mode MODE. If the mode is an
2105 integer, then UNSIGNEDP selects between signed and unsigned types. */
2108 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2113 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2114 base = gfc_real_types;
2115 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2116 base = gfc_complex_types;
2117 else if (SCALAR_INT_MODE_P (mode))
2118 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2119 else if (VECTOR_MODE_P (mode))
2121 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2122 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2123 if (inner_type != NULL_TREE)
2124 return build_vector_type_for_mode (inner_type, mode);
2130 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2132 tree type = base[i];
2133 if (type && mode == TYPE_MODE (type))
2140 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2144 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
2147 bool indirect = false;
2148 tree etype, ptype, field, t, base_decl;
2149 tree data_off, offset_off, dim_off, dim_size, elem_size;
2150 tree lower_suboff, upper_suboff, stride_suboff;
2152 if (! GFC_DESCRIPTOR_TYPE_P (type))
2154 if (! POINTER_TYPE_P (type))
2156 type = TREE_TYPE (type);
2157 if (! GFC_DESCRIPTOR_TYPE_P (type))
2162 rank = GFC_TYPE_ARRAY_RANK (type);
2163 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
2166 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2167 gcc_assert (POINTER_TYPE_P (etype));
2168 etype = TREE_TYPE (etype);
2169 gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
2170 etype = TREE_TYPE (etype);
2171 /* Can't handle variable sized elements yet. */
2172 if (int_size_in_bytes (etype) <= 0)
2174 /* Nor non-constant lower bounds in assumed shape arrays. */
2175 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2177 for (dim = 0; dim < rank; dim++)
2178 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
2179 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
2183 memset (info, '\0', sizeof (*info));
2184 info->ndimensions = rank;
2185 info->element_type = etype;
2186 ptype = build_pointer_type (gfc_array_index_type);
2189 info->base_decl = build_decl (VAR_DECL, NULL_TREE,
2190 build_pointer_type (ptype));
2191 base_decl = build1 (INDIRECT_REF, ptype, info->base_decl);
2194 info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
2196 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
2197 field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
2198 data_off = byte_position (field);
2199 field = TREE_CHAIN (field);
2200 offset_off = byte_position (field);
2201 field = TREE_CHAIN (field);
2202 field = TREE_CHAIN (field);
2203 dim_off = byte_position (field);
2204 dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
2205 field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
2206 stride_suboff = byte_position (field);
2207 field = TREE_CHAIN (field);
2208 lower_suboff = byte_position (field);
2209 field = TREE_CHAIN (field);
2210 upper_suboff = byte_position (field);
2213 if (!integer_zerop (data_off))
2214 t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
2215 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
2216 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
2217 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
2218 info->allocated = build2 (NE_EXPR, boolean_type_node,
2219 info->data_location, null_pointer_node);
2220 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
2221 info->associated = build2 (NE_EXPR, boolean_type_node,
2222 info->data_location, null_pointer_node);
2224 for (dim = 0; dim < rank; dim++)
2226 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2227 size_binop (PLUS_EXPR, dim_off, lower_suboff));
2228 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2229 info->dimen[dim].lower_bound = t;
2230 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2231 size_binop (PLUS_EXPR, dim_off, upper_suboff));
2232 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2233 info->dimen[dim].upper_bound = t;
2234 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2236 /* Assumed shape arrays have known lower bounds. */
2237 info->dimen[dim].upper_bound
2238 = build2 (MINUS_EXPR, gfc_array_index_type,
2239 info->dimen[dim].upper_bound,
2240 info->dimen[dim].lower_bound);
2241 info->dimen[dim].lower_bound
2242 = fold_convert (gfc_array_index_type,
2243 GFC_TYPE_ARRAY_LBOUND (type, dim));
2244 info->dimen[dim].upper_bound
2245 = build2 (PLUS_EXPR, gfc_array_index_type,
2246 info->dimen[dim].lower_bound,
2247 info->dimen[dim].upper_bound);
2249 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2250 size_binop (PLUS_EXPR, dim_off, stride_suboff));
2251 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2252 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
2253 info->dimen[dim].stride = t;
2254 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
2260 #include "gt-fortran-trans-types.h"