1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
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 prvoid_type_node;
63 tree ppvoid_type_node;
67 tree gfc_charlen_type_node;
69 static GTY(()) tree gfc_desc_dim_type;
70 static GTY(()) tree gfc_max_array_element_size;
71 static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
73 /* Arrays for all integral and real kinds. We'll fill this in at runtime
74 after the target has a chance to process command-line options. */
76 #define MAX_INT_KINDS 5
77 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
78 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
79 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
80 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
82 #define MAX_REAL_KINDS 5
83 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
84 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
85 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
87 #define MAX_CHARACTER_KINDS 2
88 gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
89 static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
90 static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
93 /* The integer kind to use for array indices. This will be set to the
94 proper value based on target information from the backend. */
96 int gfc_index_integer_kind;
98 /* The default kinds of the various types. */
100 int gfc_default_integer_kind;
101 int gfc_max_integer_kind;
102 int gfc_default_real_kind;
103 int gfc_default_double_kind;
104 int gfc_default_character_kind;
105 int gfc_default_logical_kind;
106 int gfc_default_complex_kind;
109 /* The kind size used for record offsets. If the target system supports
110 kind=8, this will be set to 8, otherwise it is set to 4. */
113 /* The integer kind used to store character lengths. */
114 int gfc_charlen_int_kind;
116 /* The size of the numeric storage unit and character storage unit. */
117 int gfc_numeric_storage_size;
118 int gfc_character_storage_size;
122 gfc_check_any_c_kind (gfc_typespec *ts)
126 for (i = 0; i < ISOCBINDING_NUMBER; i++)
128 /* Check for any C interoperable kind for the given type/kind in ts.
129 This can be used after verify_c_interop to make sure that the
130 Fortran kind being used exists in at least some form for C. */
131 if (c_interop_kinds_table[i].f90_type == ts->type &&
132 c_interop_kinds_table[i].value == ts->kind)
141 get_real_kind_from_node (tree type)
145 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
146 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
147 return gfc_real_kinds[i].kind;
153 get_int_kind_from_node (tree type)
160 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
161 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
162 return gfc_integer_kinds[i].kind;
167 /* Return a typenode for the "standard" C type with a given name. */
169 get_typenode_from_name (const char *name)
171 if (name == NULL || *name == '\0')
174 if (strcmp (name, "char") == 0)
175 return char_type_node;
176 if (strcmp (name, "unsigned char") == 0)
177 return unsigned_char_type_node;
178 if (strcmp (name, "signed char") == 0)
179 return signed_char_type_node;
181 if (strcmp (name, "short int") == 0)
182 return short_integer_type_node;
183 if (strcmp (name, "short unsigned int") == 0)
184 return short_unsigned_type_node;
186 if (strcmp (name, "int") == 0)
187 return integer_type_node;
188 if (strcmp (name, "unsigned int") == 0)
189 return unsigned_type_node;
191 if (strcmp (name, "long int") == 0)
192 return long_integer_type_node;
193 if (strcmp (name, "long unsigned int") == 0)
194 return long_unsigned_type_node;
196 if (strcmp (name, "long long int") == 0)
197 return long_long_integer_type_node;
198 if (strcmp (name, "long long unsigned int") == 0)
199 return long_long_unsigned_type_node;
205 get_int_kind_from_name (const char *name)
207 return get_int_kind_from_node (get_typenode_from_name (name));
211 /* Get the kind number corresponding to an integer of given size,
212 following the required return values for ISO_FORTRAN_ENV INT* constants:
213 -2 is returned if we support a kind of larger size, -1 otherwise. */
215 gfc_get_int_kind_from_width_isofortranenv (int size)
219 /* Look for a kind with matching storage size. */
220 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
221 if (gfc_integer_kinds[i].bit_size == size)
222 return gfc_integer_kinds[i].kind;
224 /* Look for a kind with larger storage size. */
225 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
226 if (gfc_integer_kinds[i].bit_size > size)
232 /* Get the kind number corresponding to a real of given storage size,
233 following the required return values for ISO_FORTRAN_ENV REAL* constants:
234 -2 is returned if we support a kind of larger size, -1 otherwise. */
236 gfc_get_real_kind_from_width_isofortranenv (int size)
242 /* Look for a kind with matching storage size. */
243 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
244 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
245 return gfc_real_kinds[i].kind;
247 /* Look for a kind with larger storage size. */
248 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
249 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
258 get_int_kind_from_width (int size)
262 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
263 if (gfc_integer_kinds[i].bit_size == size)
264 return gfc_integer_kinds[i].kind;
270 get_int_kind_from_minimal_width (int size)
274 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
275 if (gfc_integer_kinds[i].bit_size >= size)
276 return gfc_integer_kinds[i].kind;
282 /* Generate the CInteropKind_t objects for the C interoperable
286 void init_c_interop_kinds (void)
290 /* init all pointers in the list to NULL */
291 for (i = 0; i < ISOCBINDING_NUMBER; i++)
293 /* Initialize the name and value fields. */
294 c_interop_kinds_table[i].name[0] = '\0';
295 c_interop_kinds_table[i].value = -100;
296 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
299 #define NAMED_INTCST(a,b,c,d) \
300 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
301 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
302 c_interop_kinds_table[a].value = c;
303 #define NAMED_REALCST(a,b,c) \
304 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
305 c_interop_kinds_table[a].f90_type = BT_REAL; \
306 c_interop_kinds_table[a].value = c;
307 #define NAMED_CMPXCST(a,b,c) \
308 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
309 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
310 c_interop_kinds_table[a].value = c;
311 #define NAMED_LOGCST(a,b,c) \
312 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
313 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
314 c_interop_kinds_table[a].value = c;
315 #define NAMED_CHARKNDCST(a,b,c) \
316 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
317 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
318 c_interop_kinds_table[a].value = c;
319 #define NAMED_CHARCST(a,b,c) \
320 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
321 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
322 c_interop_kinds_table[a].value = c;
323 #define DERIVED_TYPE(a,b,c) \
324 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
325 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
326 c_interop_kinds_table[a].value = c;
327 #define PROCEDURE(a,b) \
328 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
329 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
330 c_interop_kinds_table[a].value = 0;
331 #include "iso-c-binding.def"
335 /* Query the target to determine which machine modes are available for
336 computation. Choose KIND numbers for them. */
339 gfc_init_kinds (void)
342 int i_index, r_index, kind;
343 bool saw_i4 = false, saw_i8 = false;
344 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
346 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
350 if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
353 /* The middle end doesn't support constants larger than 2*HWI.
354 Perhaps the target hook shouldn't have accepted these either,
355 but just to be safe... */
356 bitsize = GET_MODE_BITSIZE (mode);
357 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
360 gcc_assert (i_index != MAX_INT_KINDS);
362 /* Let the kind equal the bit size divided by 8. This insulates the
363 programmer from the underlying byte size. */
371 gfc_integer_kinds[i_index].kind = kind;
372 gfc_integer_kinds[i_index].radix = 2;
373 gfc_integer_kinds[i_index].digits = bitsize - 1;
374 gfc_integer_kinds[i_index].bit_size = bitsize;
376 gfc_logical_kinds[i_index].kind = kind;
377 gfc_logical_kinds[i_index].bit_size = bitsize;
382 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
383 used for large file access. */
390 /* If we do not at least have kind = 4, everything is pointless. */
393 /* Set the maximum integer kind. Used with at least BOZ constants. */
394 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
396 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
398 const struct real_format *fmt =
399 REAL_MODE_FORMAT ((enum machine_mode) mode);
404 if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
407 /* Only let float/double/long double go through because the fortran
408 library assumes these are the only floating point types. */
410 if (mode != TYPE_MODE (float_type_node)
411 && (mode != TYPE_MODE (double_type_node))
412 && (mode != TYPE_MODE (long_double_type_node)))
415 /* Let the kind equal the precision divided by 8, rounding up. Again,
416 this insulates the programmer from the underlying byte size.
418 Also, it effectively deals with IEEE extended formats. There, the
419 total size of the type may equal 16, but it's got 6 bytes of padding
420 and the increased size can get in the way of a real IEEE quad format
421 which may also be supported by the target.
423 We round up so as to handle IA-64 __floatreg (RFmode), which is an
424 82 bit type. Not to be confused with __float80 (XFmode), which is
425 an 80 bit type also supported by IA-64. So XFmode should come out
426 to be kind=10, and RFmode should come out to be kind=11. Egads. */
428 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
437 /* Careful we don't stumble a weird internal mode. */
438 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
439 /* Or have too many modes for the allocated space. */
440 gcc_assert (r_index != MAX_REAL_KINDS);
442 gfc_real_kinds[r_index].kind = kind;
443 gfc_real_kinds[r_index].radix = fmt->b;
444 gfc_real_kinds[r_index].digits = fmt->p;
445 gfc_real_kinds[r_index].min_exponent = fmt->emin;
446 gfc_real_kinds[r_index].max_exponent = fmt->emax;
447 if (fmt->pnan < fmt->p)
448 /* This is an IBM extended double format (or the MIPS variant)
449 made up of two IEEE doubles. The value of the long double is
450 the sum of the values of the two parts. The most significant
451 part is required to be the value of the long double rounded
452 to the nearest double. If we use emax of 1024 then we can't
453 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
454 rounding will make the most significant part overflow. */
455 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
456 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
460 /* Choose the default integer kind. We choose 4 unless the user
461 directs us otherwise. */
462 if (gfc_option.flag_default_integer)
465 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
466 gfc_default_integer_kind = 8;
468 /* Even if the user specified that the default integer kind be 8,
469 the numeric storage size isn't 64. In this case, a warning will
470 be issued when NUMERIC_STORAGE_SIZE is used. */
471 gfc_numeric_storage_size = 4 * 8;
475 gfc_default_integer_kind = 4;
476 gfc_numeric_storage_size = 4 * 8;
480 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
481 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
484 /* Choose the default real kind. Again, we choose 4 when possible. */
485 if (gfc_option.flag_default_real)
488 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
489 gfc_default_real_kind = 8;
492 gfc_default_real_kind = 4;
494 gfc_default_real_kind = gfc_real_kinds[0].kind;
496 /* Choose the default double kind. If -fdefault-real and -fdefault-double
497 are specified, we use kind=8, if it's available. If -fdefault-real is
498 specified without -fdefault-double, we use kind=16, if it's available.
499 Otherwise we do not change anything. */
500 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
501 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
503 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
504 gfc_default_double_kind = 8;
505 else if (gfc_option.flag_default_real && saw_r16)
506 gfc_default_double_kind = 16;
507 else if (saw_r4 && saw_r8)
508 gfc_default_double_kind = 8;
511 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
512 real ... occupies two contiguous numeric storage units.
514 Therefore we must be supplied a kind twice as large as we chose
515 for single precision. There are loopholes, in that double
516 precision must *occupy* two storage units, though it doesn't have
517 to *use* two storage units. Which means that you can make this
518 kind artificially wide by padding it. But at present there are
519 no GCC targets for which a two-word type does not exist, so we
520 just let gfc_validate_kind abort and tell us if something breaks. */
522 gfc_default_double_kind
523 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
526 /* The default logical kind is constrained to be the same as the
527 default integer kind. Similarly with complex and real. */
528 gfc_default_logical_kind = gfc_default_integer_kind;
529 gfc_default_complex_kind = gfc_default_real_kind;
531 /* We only have two character kinds: ASCII and UCS-4.
532 ASCII corresponds to a 8-bit integer type, if one is available.
533 UCS-4 corresponds to a 32-bit integer type, if one is available. */
535 if ((kind = get_int_kind_from_width (8)) > 0)
537 gfc_character_kinds[i_index].kind = kind;
538 gfc_character_kinds[i_index].bit_size = 8;
539 gfc_character_kinds[i_index].name = "ascii";
542 if ((kind = get_int_kind_from_width (32)) > 0)
544 gfc_character_kinds[i_index].kind = kind;
545 gfc_character_kinds[i_index].bit_size = 32;
546 gfc_character_kinds[i_index].name = "iso_10646";
550 /* Choose the smallest integer kind for our default character. */
551 gfc_default_character_kind = gfc_character_kinds[0].kind;
552 gfc_character_storage_size = gfc_default_character_kind * 8;
554 /* Choose the integer kind the same size as "void*" for our index kind. */
555 gfc_index_integer_kind = POINTER_SIZE / 8;
556 /* Pick a kind the same size as the C "int" type. */
557 gfc_c_int_kind = INT_TYPE_SIZE / 8;
559 /* initialize the C interoperable kinds */
560 init_c_interop_kinds();
563 /* Make sure that a valid kind is present. Returns an index into the
564 associated kinds array, -1 if the kind is not present. */
567 validate_integer (int kind)
571 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
572 if (gfc_integer_kinds[i].kind == kind)
579 validate_real (int kind)
583 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
584 if (gfc_real_kinds[i].kind == kind)
591 validate_logical (int kind)
595 for (i = 0; gfc_logical_kinds[i].kind; i++)
596 if (gfc_logical_kinds[i].kind == kind)
603 validate_character (int kind)
607 for (i = 0; gfc_character_kinds[i].kind; i++)
608 if (gfc_character_kinds[i].kind == kind)
614 /* Validate a kind given a basic type. The return value is the same
615 for the child functions, with -1 indicating nonexistence of the
616 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
619 gfc_validate_kind (bt type, int kind, bool may_fail)
625 case BT_REAL: /* Fall through */
627 rc = validate_real (kind);
630 rc = validate_integer (kind);
633 rc = validate_logical (kind);
636 rc = validate_character (kind);
640 gfc_internal_error ("gfc_validate_kind(): Got bad type");
643 if (rc < 0 && !may_fail)
644 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
650 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
651 Reuse common type nodes where possible. Recognize if the kind matches up
652 with a C type. This will be used later in determining which routines may
653 be scarfed from libm. */
656 gfc_build_int_type (gfc_integer_info *info)
658 int mode_precision = info->bit_size;
660 if (mode_precision == CHAR_TYPE_SIZE)
662 if (mode_precision == SHORT_TYPE_SIZE)
664 if (mode_precision == INT_TYPE_SIZE)
666 if (mode_precision == LONG_TYPE_SIZE)
668 if (mode_precision == LONG_LONG_TYPE_SIZE)
669 info->c_long_long = 1;
671 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
672 return intQI_type_node;
673 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
674 return intHI_type_node;
675 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
676 return intSI_type_node;
677 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
678 return intDI_type_node;
679 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
680 return intTI_type_node;
682 return make_signed_type (mode_precision);
686 gfc_build_uint_type (int size)
688 if (size == CHAR_TYPE_SIZE)
689 return unsigned_char_type_node;
690 if (size == SHORT_TYPE_SIZE)
691 return short_unsigned_type_node;
692 if (size == INT_TYPE_SIZE)
693 return unsigned_type_node;
694 if (size == LONG_TYPE_SIZE)
695 return long_unsigned_type_node;
696 if (size == LONG_LONG_TYPE_SIZE)
697 return long_long_unsigned_type_node;
699 return make_unsigned_type (size);
704 gfc_build_real_type (gfc_real_info *info)
706 int mode_precision = info->mode_precision;
709 if (mode_precision == FLOAT_TYPE_SIZE)
711 if (mode_precision == DOUBLE_TYPE_SIZE)
713 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
714 info->c_long_double = 1;
716 if (TYPE_PRECISION (float_type_node) == mode_precision)
717 return float_type_node;
718 if (TYPE_PRECISION (double_type_node) == mode_precision)
719 return double_type_node;
720 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
721 return long_double_type_node;
723 new_type = make_node (REAL_TYPE);
724 TYPE_PRECISION (new_type) = mode_precision;
725 layout_type (new_type);
730 gfc_build_complex_type (tree scalar_type)
734 if (scalar_type == NULL)
736 if (scalar_type == float_type_node)
737 return complex_float_type_node;
738 if (scalar_type == double_type_node)
739 return complex_double_type_node;
740 if (scalar_type == long_double_type_node)
741 return complex_long_double_type_node;
743 new_type = make_node (COMPLEX_TYPE);
744 TREE_TYPE (new_type) = scalar_type;
745 layout_type (new_type);
750 gfc_build_logical_type (gfc_logical_info *info)
752 int bit_size = info->bit_size;
755 if (bit_size == BOOL_TYPE_SIZE)
758 return boolean_type_node;
761 new_type = make_unsigned_type (bit_size);
762 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
763 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
764 TYPE_PRECISION (new_type) = 1;
771 /* Return the bit size of the C "size_t". */
777 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
778 return INT_TYPE_SIZE;
779 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
780 return LONG_TYPE_SIZE;
781 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
782 return SHORT_TYPE_SIZE;
785 return LONG_TYPE_SIZE;
790 /* Create the backend type nodes. We map them to their
791 equivalent C type, at least for now. We also give
792 names to the types here, and we push them in the
793 global binding level context.*/
796 gfc_init_types (void)
802 unsigned HOST_WIDE_INT hi;
803 unsigned HOST_WIDE_INT lo;
805 /* Create and name the types. */
806 #define PUSH_TYPE(name, node) \
807 pushdecl (build_decl (input_location, \
808 TYPE_DECL, get_identifier (name), node))
810 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
812 type = gfc_build_int_type (&gfc_integer_kinds[index]);
813 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
814 if (TYPE_STRING_FLAG (type))
815 type = make_signed_type (gfc_integer_kinds[index].bit_size);
816 gfc_integer_types[index] = type;
817 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
818 gfc_integer_kinds[index].kind);
819 PUSH_TYPE (name_buf, type);
822 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
824 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
825 gfc_logical_types[index] = type;
826 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
827 gfc_logical_kinds[index].kind);
828 PUSH_TYPE (name_buf, type);
831 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
833 type = gfc_build_real_type (&gfc_real_kinds[index]);
834 gfc_real_types[index] = type;
835 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
836 gfc_real_kinds[index].kind);
837 PUSH_TYPE (name_buf, type);
839 type = gfc_build_complex_type (type);
840 gfc_complex_types[index] = type;
841 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
842 gfc_real_kinds[index].kind);
843 PUSH_TYPE (name_buf, type);
846 for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
848 type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
849 type = build_qualified_type (type, TYPE_UNQUALIFIED);
850 snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
851 gfc_character_kinds[index].kind);
852 PUSH_TYPE (name_buf, type);
853 gfc_character_types[index] = type;
854 gfc_pcharacter_types[index] = build_pointer_type (type);
856 gfc_character1_type_node = gfc_character_types[0];
858 PUSH_TYPE ("byte", unsigned_char_type_node);
859 PUSH_TYPE ("void", void_type_node);
861 /* DBX debugging output gets upset if these aren't set. */
862 if (!TYPE_NAME (integer_type_node))
863 PUSH_TYPE ("c_integer", integer_type_node);
864 if (!TYPE_NAME (char_type_node))
865 PUSH_TYPE ("c_char", char_type_node);
869 pvoid_type_node = build_pointer_type (void_type_node);
870 prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
871 ppvoid_type_node = build_pointer_type (pvoid_type_node);
872 pchar_type_node = build_pointer_type (gfc_character1_type_node);
874 = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
876 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
877 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
878 since this function is called before gfc_init_constants. */
880 = build_range_type (gfc_array_index_type,
881 build_int_cst (gfc_array_index_type, 0),
884 /* The maximum array element size that can be handled is determined
885 by the number of bits available to store this field in the array
888 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
889 lo = ~ (unsigned HOST_WIDE_INT) 0;
890 if (n > HOST_BITS_PER_WIDE_INT)
891 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
893 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
894 gfc_max_array_element_size
895 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
897 size_type_node = gfc_array_index_type;
899 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
900 boolean_true_node = build_int_cst (boolean_type_node, 1);
901 boolean_false_node = build_int_cst (boolean_type_node, 0);
903 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
904 gfc_charlen_int_kind = 4;
905 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
908 /* Get the type node for the given type and kind. */
911 gfc_get_int_type (int kind)
913 int index = gfc_validate_kind (BT_INTEGER, kind, true);
914 return index < 0 ? 0 : gfc_integer_types[index];
918 gfc_get_real_type (int kind)
920 int index = gfc_validate_kind (BT_REAL, kind, true);
921 return index < 0 ? 0 : gfc_real_types[index];
925 gfc_get_complex_type (int kind)
927 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
928 return index < 0 ? 0 : gfc_complex_types[index];
932 gfc_get_logical_type (int kind)
934 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
935 return index < 0 ? 0 : gfc_logical_types[index];
939 gfc_get_char_type (int kind)
941 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
942 return index < 0 ? 0 : gfc_character_types[index];
946 gfc_get_pchar_type (int kind)
948 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
949 return index < 0 ? 0 : gfc_pcharacter_types[index];
953 /* Create a character type with the given kind and length. */
956 gfc_get_character_type_len_for_eltype (tree eltype, tree len)
960 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
961 type = build_array_type (eltype, bounds);
962 TYPE_STRING_FLAG (type) = 1;
968 gfc_get_character_type_len (int kind, tree len)
970 gfc_validate_kind (BT_CHARACTER, kind, false);
971 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
975 /* Get a type node for a character kind. */
978 gfc_get_character_type (int kind, gfc_charlen * cl)
982 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
984 return gfc_get_character_type_len (kind, len);
987 /* Covert a basic type. This will be an array for character types. */
990 gfc_typenode_for_spec (gfc_typespec * spec)
1000 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1001 has been resolved. This is done so we can convert C_PTR and
1002 C_FUNPTR to simple variables that get translated to (void *). */
1003 if (spec->f90_type == BT_VOID)
1006 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1007 basetype = ptr_type_node;
1009 basetype = pfunc_type_node;
1012 basetype = gfc_get_int_type (spec->kind);
1016 basetype = gfc_get_real_type (spec->kind);
1020 basetype = gfc_get_complex_type (spec->kind);
1024 basetype = gfc_get_logical_type (spec->kind);
1028 basetype = gfc_get_character_type (spec->kind, spec->u.cl);
1033 basetype = gfc_get_derived_type (spec->u.derived);
1035 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1036 type and kind to fit a (void *) and the basetype returned was a
1037 ptr_type_node. We need to pass up this new information to the
1038 symbol that was declared of type C_PTR or C_FUNPTR. */
1039 if (spec->u.derived->attr.is_iso_c)
1041 spec->type = spec->u.derived->ts.type;
1042 spec->kind = spec->u.derived->ts.kind;
1043 spec->f90_type = spec->u.derived->ts.f90_type;
1047 /* This is for the second arg to c_f_pointer and c_f_procpointer
1048 of the iso_c_binding module, to accept any ptr type. */
1049 basetype = ptr_type_node;
1050 if (spec->f90_type == BT_VOID)
1053 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1054 basetype = ptr_type_node;
1056 basetype = pfunc_type_node;
1065 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1068 gfc_conv_array_bound (gfc_expr * expr)
1070 /* If expr is an integer constant, return that. */
1071 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
1072 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
1074 /* Otherwise return NULL. */
1079 gfc_get_element_type (tree type)
1083 if (GFC_ARRAY_TYPE_P (type))
1085 if (TREE_CODE (type) == POINTER_TYPE)
1086 type = TREE_TYPE (type);
1087 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1088 element = TREE_TYPE (type);
1092 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
1093 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
1095 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
1096 element = TREE_TYPE (element);
1098 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
1099 element = TREE_TYPE (element);
1105 /* Build an array. This function is called from gfc_sym_type().
1106 Actually returns array descriptor type.
1108 Format of array descriptors is as follows:
1110 struct gfc_array_descriptor
1115 struct descriptor_dimension dimension[N_DIM];
1118 struct descriptor_dimension
1125 Translation code should use gfc_conv_descriptor_* rather than
1126 accessing the descriptor directly. Any changes to the array
1127 descriptor type will require changes in gfc_conv_descriptor_* and
1128 gfc_build_array_initializer.
1130 This is represented internally as a RECORD_TYPE. The index nodes
1131 are gfc_array_index_type and the data node is a pointer to the
1132 data. See below for the handling of character types.
1134 The dtype member is formatted as follows:
1135 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1136 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1137 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1139 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1140 this generated poor code for assumed/deferred size arrays. These
1141 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1142 of the GENERIC grammar. Also, there is no way to explicitly set
1143 the array stride, so all data must be packed(1). I've tried to
1144 mark all the functions which would require modification with a GCC
1147 The data component points to the first element in the array. The
1148 offset field is the position of the origin of the array (i.e. element
1149 (0, 0 ...)). This may be outside the bounds of the array.
1151 An element is accessed by
1152 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1153 This gives good performance as the computation does not involve the
1154 bounds of the array. For packed arrays, this is optimized further
1155 by substituting the known strides.
1157 This system has one problem: all array bounds must be within 2^31
1158 elements of the origin (2^63 on 64-bit machines). For example
1159 integer, dimension (80000:90000, 80000:90000, 2) :: array
1160 may not work properly on 32-bit machines because 80000*80000 >
1161 2^31, so the calculation for stride2 would overflow. This may
1162 still work, but I haven't checked, and it relies on the overflow
1163 doing the right thing.
1165 The way to fix this problem is to access elements as follows:
1166 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1167 Obviously this is much slower. I will make this a compile time
1168 option, something like -fsmall-array-offsets. Mixing code compiled
1169 with and without this switch will work.
1171 (1) This can be worked around by modifying the upper bound of the
1172 previous dimension. This requires extra fields in the descriptor
1173 (both real_ubound and fake_ubound). */
1176 /* Returns true if the array sym does not require a descriptor. */
1179 gfc_is_nodesc_array (gfc_symbol * sym)
1181 gcc_assert (sym->attr.dimension);
1183 /* We only want local arrays. */
1184 if (sym->attr.pointer || sym->attr.allocatable)
1187 if (sym->attr.dummy)
1189 if (sym->as->type != AS_ASSUMED_SHAPE)
1195 if (sym->attr.result || sym->attr.function)
1198 gcc_assert (sym->as->type == AS_EXPLICIT);
1204 /* Create an array descriptor type. */
1207 gfc_build_array_type (tree type, gfc_array_spec * as,
1208 enum gfc_array_kind akind, bool restricted)
1210 tree lbound[GFC_MAX_DIMENSIONS];
1211 tree ubound[GFC_MAX_DIMENSIONS];
1214 for (n = 0; n < as->rank; n++)
1216 /* Create expressions for the known bounds of the array. */
1217 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1218 lbound[n] = gfc_index_one_node;
1220 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1221 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1224 if (as->type == AS_ASSUMED_SHAPE)
1225 akind = GFC_ARRAY_ASSUMED_SHAPE;
1226 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind,
1230 /* Returns the struct descriptor_dimension type. */
1233 gfc_get_desc_dim_type (void)
1239 if (gfc_desc_dim_type)
1240 return gfc_desc_dim_type;
1242 /* Build the type node. */
1243 type = make_node (RECORD_TYPE);
1245 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1246 TYPE_PACKED (type) = 1;
1248 /* Consists of the stride, lbound and ubound members. */
1249 decl = build_decl (input_location,
1251 get_identifier ("stride"), gfc_array_index_type);
1252 DECL_CONTEXT (decl) = type;
1253 TREE_NO_WARNING (decl) = 1;
1256 decl = build_decl (input_location,
1258 get_identifier ("lbound"), gfc_array_index_type);
1259 DECL_CONTEXT (decl) = type;
1260 TREE_NO_WARNING (decl) = 1;
1261 fieldlist = chainon (fieldlist, decl);
1263 decl = build_decl (input_location,
1265 get_identifier ("ubound"), gfc_array_index_type);
1266 DECL_CONTEXT (decl) = type;
1267 TREE_NO_WARNING (decl) = 1;
1268 fieldlist = chainon (fieldlist, decl);
1270 /* Finish off the type. */
1271 TYPE_FIELDS (type) = fieldlist;
1273 gfc_finish_type (type);
1274 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1276 gfc_desc_dim_type = type;
1281 /* Return the DTYPE for an array. This describes the type and type parameters
1283 /* TODO: Only call this when the value is actually used, and make all the
1284 unknown cases abort. */
1287 gfc_get_dtype (tree type)
1297 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1299 if (GFC_TYPE_ARRAY_DTYPE (type))
1300 return GFC_TYPE_ARRAY_DTYPE (type);
1302 rank = GFC_TYPE_ARRAY_RANK (type);
1303 etype = gfc_get_element_type (type);
1305 switch (TREE_CODE (etype))
1308 n = GFC_DTYPE_INTEGER;
1312 n = GFC_DTYPE_LOGICAL;
1320 n = GFC_DTYPE_COMPLEX;
1323 /* We will never have arrays of arrays. */
1325 n = GFC_DTYPE_DERIVED;
1329 n = GFC_DTYPE_CHARACTER;
1333 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1334 /* We can strange array types for temporary arrays. */
1335 return gfc_index_zero_node;
1338 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1339 size = TYPE_SIZE_UNIT (etype);
1341 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1342 if (size && INTEGER_CST_P (size))
1344 if (tree_int_cst_lt (gfc_max_array_element_size, size))
1345 internal_error ("Array element size too big");
1347 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1349 dtype = build_int_cst (gfc_array_index_type, i);
1351 if (size && !INTEGER_CST_P (size))
1353 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1354 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
1355 fold_convert (gfc_array_index_type, size), tmp);
1356 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
1358 /* If we don't know the size we leave it as zero. This should never happen
1359 for anything that is actually used. */
1360 /* TODO: Check this is actually true, particularly when repacking
1361 assumed size parameters. */
1363 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1368 /* Build an array type for use without a descriptor, packed according
1369 to the value of PACKED. */
1372 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
1386 mpz_init_set_ui (offset, 0);
1387 mpz_init_set_ui (stride, 1);
1390 /* We don't use build_array_type because this does not include include
1391 lang-specific information (i.e. the bounds of the array) when checking
1393 type = make_node (ARRAY_TYPE);
1395 GFC_ARRAY_TYPE_P (type) = 1;
1396 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1397 ggc_alloc_cleared (sizeof (struct lang_type));
1399 known_stride = (packed != PACKED_NO);
1401 for (n = 0; n < as->rank; n++)
1403 /* Fill in the stride and bound components of the type. */
1405 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1408 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1410 expr = as->lower[n];
1411 if (expr->expr_type == EXPR_CONSTANT)
1413 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1414 gfc_index_integer_kind);
1421 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1425 /* Calculate the offset. */
1426 mpz_mul (delta, stride, as->lower[n]->value.integer);
1427 mpz_sub (offset, offset, delta);
1432 expr = as->upper[n];
1433 if (expr && expr->expr_type == EXPR_CONSTANT)
1435 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1436 gfc_index_integer_kind);
1443 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1447 /* Calculate the stride. */
1448 mpz_sub (delta, as->upper[n]->value.integer,
1449 as->lower[n]->value.integer);
1450 mpz_add_ui (delta, delta, 1);
1451 mpz_mul (stride, stride, delta);
1454 /* Only the first stride is known for partial packed arrays. */
1455 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1461 GFC_TYPE_ARRAY_OFFSET (type) =
1462 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1465 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1469 GFC_TYPE_ARRAY_SIZE (type) =
1470 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1473 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1475 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1476 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1477 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1479 /* TODO: use main type if it is unbounded. */
1480 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1481 build_pointer_type (build_array_type (etype, range));
1483 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1484 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
1485 TYPE_QUAL_RESTRICT);
1489 mpz_sub_ui (stride, stride, 1);
1490 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1495 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1496 TYPE_DOMAIN (type) = range;
1498 build_pointer_type (etype);
1499 TREE_TYPE (type) = etype;
1507 /* Represent packed arrays as multi-dimensional if they have rank >
1508 1 and with proper bounds, instead of flat arrays. This makes for
1509 better debug info. */
1512 tree gtype = etype, rtype, type_decl;
1514 for (n = as->rank - 1; n >= 0; n--)
1516 rtype = build_range_type (gfc_array_index_type,
1517 GFC_TYPE_ARRAY_LBOUND (type, n),
1518 GFC_TYPE_ARRAY_UBOUND (type, n));
1519 gtype = build_array_type (gtype, rtype);
1521 TYPE_NAME (type) = type_decl = build_decl (input_location,
1522 TYPE_DECL, NULL, gtype);
1523 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1526 if (packed != PACKED_STATIC || !known_stride)
1528 /* For dummy arrays and automatic (heap allocated) arrays we
1529 want a pointer to the array. */
1530 type = build_pointer_type (type);
1532 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1533 GFC_ARRAY_TYPE_P (type) = 1;
1534 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1539 /* Return or create the base type for an array descriptor. */
1542 gfc_get_array_descriptor_base (int dimen, bool restricted)
1544 tree fat_type, fieldlist, decl, arraytype;
1545 char name[16 + GFC_RANK_DIGITS + 1];
1546 int idx = 2 * (dimen - 1) + restricted;
1548 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1549 if (gfc_array_descriptor_base[idx])
1550 return gfc_array_descriptor_base[idx];
1552 /* Build the type node. */
1553 fat_type = make_node (RECORD_TYPE);
1555 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1556 TYPE_NAME (fat_type) = get_identifier (name);
1558 /* Add the data member as the first element of the descriptor. */
1559 decl = build_decl (input_location,
1560 FIELD_DECL, get_identifier ("data"),
1561 restricted ? prvoid_type_node : ptr_type_node);
1563 DECL_CONTEXT (decl) = fat_type;
1566 /* Add the base component. */
1567 decl = build_decl (input_location,
1568 FIELD_DECL, get_identifier ("offset"),
1569 gfc_array_index_type);
1570 DECL_CONTEXT (decl) = fat_type;
1571 TREE_NO_WARNING (decl) = 1;
1572 fieldlist = chainon (fieldlist, decl);
1574 /* Add the dtype component. */
1575 decl = build_decl (input_location,
1576 FIELD_DECL, get_identifier ("dtype"),
1577 gfc_array_index_type);
1578 DECL_CONTEXT (decl) = fat_type;
1579 TREE_NO_WARNING (decl) = 1;
1580 fieldlist = chainon (fieldlist, decl);
1582 /* Build the array type for the stride and bound components. */
1584 build_array_type (gfc_get_desc_dim_type (),
1585 build_range_type (gfc_array_index_type,
1586 gfc_index_zero_node,
1587 gfc_rank_cst[dimen - 1]));
1589 decl = build_decl (input_location,
1590 FIELD_DECL, get_identifier ("dim"), arraytype);
1591 DECL_CONTEXT (decl) = fat_type;
1592 TREE_NO_WARNING (decl) = 1;
1593 fieldlist = chainon (fieldlist, decl);
1595 /* Finish off the type. */
1596 TYPE_FIELDS (fat_type) = fieldlist;
1598 gfc_finish_type (fat_type);
1599 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1601 gfc_array_descriptor_base[idx] = fat_type;
1605 /* Build an array (descriptor) type with given bounds. */
1608 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1609 tree * ubound, int packed,
1610 enum gfc_array_kind akind, bool restricted)
1612 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1613 tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
1614 const char *type_name;
1617 base_type = gfc_get_array_descriptor_base (dimen, restricted);
1618 fat_type = build_distinct_type_copy (base_type);
1619 /* Make sure that nontarget and target array type have the same canonical
1620 type (and same stub decl for debug info). */
1621 base_type = gfc_get_array_descriptor_base (dimen, false);
1622 TYPE_CANONICAL (fat_type) = base_type;
1623 TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
1625 tmp = TYPE_NAME (etype);
1626 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1627 tmp = DECL_NAME (tmp);
1629 type_name = IDENTIFIER_POINTER (tmp);
1631 type_name = "unknown";
1632 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1633 GFC_MAX_SYMBOL_LEN, type_name);
1634 TYPE_NAME (fat_type) = get_identifier (name);
1636 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1637 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1638 ggc_alloc_cleared (sizeof (struct lang_type));
1640 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1641 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1642 GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1644 /* Build an array descriptor record type. */
1646 stride = gfc_index_one_node;
1649 for (n = 0; n < dimen; n++)
1651 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1658 if (lower != NULL_TREE)
1660 if (INTEGER_CST_P (lower))
1661 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1667 if (upper != NULL_TREE)
1669 if (INTEGER_CST_P (upper))
1670 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1675 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1677 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1678 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1679 gfc_index_one_node);
1681 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1682 /* Check the folding worked. */
1683 gcc_assert (INTEGER_CST_P (stride));
1688 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1690 /* TODO: known offsets for descriptors. */
1691 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1693 /* We define data as an array with the correct size if possible.
1694 Much better than doing pointer arithmetic. */
1696 rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1697 int_const_binop (MINUS_EXPR, stride,
1698 integer_one_node, 0));
1700 rtype = gfc_array_range_type;
1701 arraytype = build_array_type (etype, rtype);
1702 arraytype = build_pointer_type (arraytype);
1704 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
1705 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1707 /* This will generate the base declarations we need to emit debug
1708 information for this type. FIXME: there must be a better way to
1709 avoid divergence between compilations with and without debug
1712 struct array_descr_info info;
1713 gfc_get_array_descr_info (fat_type, &info);
1714 gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
1720 /* Build a pointer type. This function is called from gfc_sym_type(). */
1723 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1725 /* Array pointer types aren't actually pointers. */
1726 if (sym->attr.dimension)
1729 return build_pointer_type (type);
1732 /* Return the type for a symbol. Special handling is required for character
1733 types to get the correct level of indirection.
1734 For functions return the return type.
1735 For subroutines return void_type_node.
1736 Calling this multiple times for the same symbol should be avoided,
1737 especially for character and array types. */
1740 gfc_sym_type (gfc_symbol * sym)
1746 /* Procedure Pointers inside COMMON blocks. */
1747 if (sym->attr.proc_pointer && sym->attr.in_common)
1749 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
1750 sym->attr.proc_pointer = 0;
1751 type = build_pointer_type (gfc_get_function_type (sym));
1752 sym->attr.proc_pointer = 1;
1756 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1757 return void_type_node;
1759 /* In the case of a function the fake result variable may have a
1760 type different from the function type, so don't return early in
1762 if (sym->backend_decl && !sym->attr.function)
1763 return TREE_TYPE (sym->backend_decl);
1765 if (sym->ts.type == BT_CHARACTER
1766 && ((sym->attr.function && sym->attr.is_bind_c)
1767 || (sym->attr.result
1768 && sym->ns->proc_name
1769 && sym->ns->proc_name->attr.is_bind_c)))
1770 type = gfc_character1_type_node;
1772 type = gfc_typenode_for_spec (&sym->ts);
1774 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1779 restricted = !sym->attr.target && !sym->attr.pointer
1780 && !sym->attr.proc_pointer;
1781 if (sym->attr.dimension)
1783 if (gfc_is_nodesc_array (sym))
1785 /* If this is a character argument of unknown length, just use the
1787 if (sym->ts.type != BT_CHARACTER
1788 || !(sym->attr.dummy || sym->attr.function)
1789 || sym->ts.u.cl->backend_decl)
1791 type = gfc_get_nodesc_array_type (type, sym->as,
1800 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
1801 if (sym->attr.pointer)
1802 akind = GFC_ARRAY_POINTER;
1803 else if (sym->attr.allocatable)
1804 akind = GFC_ARRAY_ALLOCATABLE;
1805 type = gfc_build_array_type (type, sym->as, akind, restricted);
1810 if (sym->attr.allocatable || sym->attr.pointer)
1811 type = gfc_build_pointer_type (sym, type);
1812 if (sym->attr.pointer)
1813 GFC_POINTER_TYPE_P (type) = 1;
1816 /* We currently pass all parameters by reference.
1817 See f95_get_function_decl. For dummy function parameters return the
1821 /* We must use pointer types for potentially absent variables. The
1822 optimizers assume a reference type argument is never NULL. */
1823 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1824 type = build_pointer_type (type);
1827 type = build_reference_type (type);
1829 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1836 /* Layout and output debug info for a record type. */
1839 gfc_finish_type (tree type)
1843 decl = build_decl (input_location,
1844 TYPE_DECL, NULL_TREE, type);
1845 TYPE_STUB_DECL (type) = decl;
1847 rest_of_type_compilation (type, 1);
1848 rest_of_decl_compilation (decl, 1, 0);
1851 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1852 or RECORD_TYPE pointed to by STYPE. The new field is chained
1853 to the fieldlist pointed to by FIELDLIST.
1855 Returns a pointer to the new field. */
1858 gfc_add_field_to_struct (tree *fieldlist, tree context,
1859 tree name, tree type)
1863 decl = build_decl (input_location,
1864 FIELD_DECL, name, type);
1866 DECL_CONTEXT (decl) = context;
1867 DECL_INITIAL (decl) = 0;
1868 DECL_ALIGN (decl) = 0;
1869 DECL_USER_ALIGN (decl) = 0;
1870 TREE_CHAIN (decl) = NULL_TREE;
1871 *fieldlist = chainon (*fieldlist, decl);
1877 /* Copy the backend_decl and component backend_decls if
1878 the two derived type symbols are "equal", as described
1879 in 4.4.2 and resolved by gfc_compare_derived_types. */
1882 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
1885 gfc_component *to_cm;
1886 gfc_component *from_cm;
1888 if (from->backend_decl == NULL
1889 || !gfc_compare_derived_types (from, to))
1892 to->backend_decl = from->backend_decl;
1894 to_cm = to->components;
1895 from_cm = from->components;
1897 /* Copy the component declarations. If a component is itself
1898 a derived type, we need a copy of its component declarations.
1899 This is done by recursing into gfc_get_derived_type and
1900 ensures that the component's component declarations have
1901 been built. If it is a character, we need the character
1903 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1905 to_cm->backend_decl = from_cm->backend_decl;
1906 if ((!from_cm->attr.pointer || from_gsym)
1907 && from_cm->ts.type == BT_DERIVED)
1908 gfc_get_derived_type (to_cm->ts.u.derived);
1910 else if (from_cm->ts.type == BT_CHARACTER)
1911 to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
1918 /* Build a tree node for a procedure pointer component. */
1921 gfc_get_ppc_type (gfc_component* c)
1925 /* Explicit interface. */
1926 if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
1927 return build_pointer_type (gfc_get_function_type (c->ts.interface));
1929 /* Implicit interface (only return value may be known). */
1930 if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
1931 t = gfc_typenode_for_spec (&c->ts);
1935 return build_pointer_type (build_function_type (t, NULL_TREE));
1939 /* Build a tree node for a derived type. If there are equal
1940 derived types, with different local names, these are built
1941 at the same time. If an equal derived type has been built
1942 in a parent namespace, this is used. */
1945 gfc_get_derived_type (gfc_symbol * derived)
1947 tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1948 tree canonical = NULL_TREE;
1949 bool got_canonical = false;
1955 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1957 /* See if it's one of the iso_c_binding derived types. */
1958 if (derived->attr.is_iso_c == 1)
1960 if (derived->backend_decl)
1961 return derived->backend_decl;
1963 if (derived->intmod_sym_id == ISOCBINDING_PTR)
1964 derived->backend_decl = ptr_type_node;
1966 derived->backend_decl = pfunc_type_node;
1968 /* Create a backend_decl for the __c_ptr_c_address field. */
1969 derived->components->backend_decl =
1970 gfc_add_field_to_struct (&(derived->backend_decl->type.values),
1971 derived->backend_decl,
1972 get_identifier (derived->components->name),
1973 gfc_typenode_for_spec (
1974 &(derived->components->ts)));
1976 derived->ts.kind = gfc_index_integer_kind;
1977 derived->ts.type = BT_INTEGER;
1978 /* Set the f90_type to BT_VOID as a way to recognize something of type
1979 BT_INTEGER that needs to fit a void * for the purpose of the
1980 iso_c_binding derived types. */
1981 derived->ts.f90_type = BT_VOID;
1983 return derived->backend_decl;
1986 /* If use associated, use the module type for this one. */
1987 if (gfc_option.flag_whole_file
1988 && derived->backend_decl == NULL
1989 && derived->attr.use_assoc
1992 gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
1993 if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1997 gfc_find_symbol (derived->name, gsym->ns, 0, &s);
1998 if (s && s->backend_decl)
2000 copy_dt_decls_ifequal (s, derived, true);
2001 goto copy_derived_types;
2006 /* If a whole file compilation, the derived types from an earlier
2007 namespace can be used as the the canonical type. */
2008 if (gfc_option.flag_whole_file
2009 && derived->backend_decl == NULL
2010 && !derived->attr.use_assoc
2011 && gfc_global_ns_list)
2013 for (ns = gfc_global_ns_list;
2014 ns->translated && !got_canonical;
2017 dt = ns->derived_types;
2018 for (; dt && !canonical; dt = dt->next)
2020 copy_dt_decls_ifequal (dt->derived, derived, true);
2021 if (derived->backend_decl)
2022 got_canonical = true;
2027 /* Store up the canonical type to be added to this one. */
2030 if (TYPE_CANONICAL (derived->backend_decl))
2031 canonical = TYPE_CANONICAL (derived->backend_decl);
2033 canonical = derived->backend_decl;
2035 derived->backend_decl = NULL_TREE;
2038 /* derived->backend_decl != 0 means we saw it before, but its
2039 components' backend_decl may have not been built. */
2040 if (derived->backend_decl)
2042 /* Its components' backend_decl have been built or we are
2043 seeing recursion through the formal arglist of a procedure
2044 pointer component. */
2045 if (TYPE_FIELDS (derived->backend_decl)
2046 || derived->attr.proc_pointer_comp)
2047 return derived->backend_decl;
2049 typenode = derived->backend_decl;
2053 /* We see this derived type first time, so build the type node. */
2054 typenode = make_node (RECORD_TYPE);
2055 TYPE_NAME (typenode) = get_identifier (derived->name);
2056 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2057 derived->backend_decl = typenode;
2060 /* Go through the derived type components, building them as
2061 necessary. The reason for doing this now is that it is
2062 possible to recurse back to this derived type through a
2063 pointer component (PR24092). If this happens, the fields
2064 will be built and so we can return the type. */
2065 for (c = derived->components; c; c = c->next)
2067 if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
2070 if ((!c->attr.pointer && !c->attr.proc_pointer)
2071 || c->ts.u.derived->backend_decl == NULL)
2072 c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
2074 if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
2076 /* Need to copy the modified ts from the derived type. The
2077 typespec was modified because C_PTR/C_FUNPTR are translated
2078 into (void *) from derived types. */
2079 c->ts.type = c->ts.u.derived->ts.type;
2080 c->ts.kind = c->ts.u.derived->ts.kind;
2081 c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2084 c->initializer->ts.type = c->ts.type;
2085 c->initializer->ts.kind = c->ts.kind;
2086 c->initializer->ts.f90_type = c->ts.f90_type;
2087 c->initializer->expr_type = EXPR_NULL;
2092 if (TYPE_FIELDS (derived->backend_decl))
2093 return derived->backend_decl;
2095 /* Build the type member list. Install the newly created RECORD_TYPE
2096 node as DECL_CONTEXT of each FIELD_DECL. */
2097 fieldlist = NULL_TREE;
2098 for (c = derived->components; c; c = c->next)
2100 if (c->attr.proc_pointer)
2101 field_type = gfc_get_ppc_type (c);
2102 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2103 field_type = c->ts.u.derived->backend_decl;
2106 if (c->ts.type == BT_CHARACTER)
2108 /* Evaluate the string length. */
2109 gfc_conv_const_charlen (c->ts.u.cl);
2110 gcc_assert (c->ts.u.cl->backend_decl);
2113 field_type = gfc_typenode_for_spec (&c->ts);
2116 /* This returns an array descriptor type. Initialization may be
2118 if (c->attr.dimension && !c->attr.proc_pointer)
2120 if (c->attr.pointer || c->attr.allocatable)
2122 enum gfc_array_kind akind;
2123 if (c->attr.pointer)
2124 akind = GFC_ARRAY_POINTER;
2126 akind = GFC_ARRAY_ALLOCATABLE;
2127 /* Pointers to arrays aren't actually pointer types. The
2128 descriptors are separate, but the data is common. */
2129 field_type = gfc_build_array_type (field_type, c->as, akind,
2131 && !c->attr.pointer);
2134 field_type = gfc_get_nodesc_array_type (field_type, c->as,
2138 else if ((c->attr.pointer || c->attr.allocatable)
2139 && !c->attr.proc_pointer)
2140 field_type = build_pointer_type (field_type);
2142 field = gfc_add_field_to_struct (&fieldlist, typenode,
2143 get_identifier (c->name), field_type);
2145 gfc_set_decl_location (field, &c->loc);
2146 else if (derived->declared_at.lb)
2147 gfc_set_decl_location (field, &derived->declared_at);
2149 DECL_PACKED (field) |= TYPE_PACKED (typenode);
2152 if (!c->backend_decl)
2153 c->backend_decl = field;
2156 /* Now we have the final fieldlist. Record it, then lay out the
2157 derived type, including the fields. */
2158 TYPE_FIELDS (typenode) = fieldlist;
2160 TYPE_CANONICAL (typenode) = canonical;
2162 gfc_finish_type (typenode);
2163 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2164 if (derived->module && derived->ns->proc_name
2165 && derived->ns->proc_name->attr.flavor == FL_MODULE)
2167 if (derived->ns->proc_name->backend_decl
2168 && TREE_CODE (derived->ns->proc_name->backend_decl)
2171 TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2172 DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2173 = derived->ns->proc_name->backend_decl;
2177 derived->backend_decl = typenode;
2181 for (dt = gfc_derived_types; dt; dt = dt->next)
2182 copy_dt_decls_ifequal (derived, dt->derived, false);
2184 return derived->backend_decl;
2189 gfc_return_by_reference (gfc_symbol * sym)
2191 if (!sym->attr.function)
2194 if (sym->attr.dimension)
2197 if (sym->ts.type == BT_CHARACTER
2198 && !sym->attr.is_bind_c
2199 && (!sym->attr.result
2200 || !sym->ns->proc_name
2201 || !sym->ns->proc_name->attr.is_bind_c))
2204 /* Possibly return complex numbers by reference for g77 compatibility.
2205 We don't do this for calls to intrinsics (as the library uses the
2206 -fno-f2c calling convention), nor for calls to functions which always
2207 require an explicit interface, as no compatibility problems can
2209 if (gfc_option.flag_f2c
2210 && sym->ts.type == BT_COMPLEX
2211 && !sym->attr.intrinsic && !sym->attr.always_explicit)
2218 gfc_get_mixed_entry_union (gfc_namespace *ns)
2223 char name[GFC_MAX_SYMBOL_LEN + 1];
2224 gfc_entry_list *el, *el2;
2226 gcc_assert (ns->proc_name->attr.mixed_entry_master);
2227 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2229 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
2231 /* Build the type node. */
2232 type = make_node (UNION_TYPE);
2234 TYPE_NAME (type) = get_identifier (name);
2237 for (el = ns->entries; el; el = el->next)
2239 /* Search for duplicates. */
2240 for (el2 = ns->entries; el2 != el; el2 = el2->next)
2241 if (el2->sym->result == el->sym->result)
2246 decl = build_decl (input_location,
2248 get_identifier (el->sym->result->name),
2249 gfc_sym_type (el->sym->result));
2250 DECL_CONTEXT (decl) = type;
2251 fieldlist = chainon (fieldlist, decl);
2255 /* Finish off the type. */
2256 TYPE_FIELDS (type) = fieldlist;
2258 gfc_finish_type (type);
2259 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
2264 gfc_get_function_type (gfc_symbol * sym)
2268 gfc_formal_arglist *f;
2271 int alternate_return;
2273 /* Make sure this symbol is a function, a subroutine or the main
2275 gcc_assert (sym->attr.flavor == FL_PROCEDURE
2276 || sym->attr.flavor == FL_PROGRAM);
2278 if (sym->backend_decl)
2279 return TREE_TYPE (sym->backend_decl);
2282 alternate_return = 0;
2283 typelist = NULL_TREE;
2285 if (sym->attr.entry_master)
2287 /* Additional parameter for selecting an entry point. */
2288 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
2296 if (arg->ts.type == BT_CHARACTER)
2297 gfc_conv_const_charlen (arg->ts.u.cl);
2299 /* Some functions we use an extra parameter for the return value. */
2300 if (gfc_return_by_reference (sym))
2302 type = gfc_sym_type (arg);
2303 if (arg->ts.type == BT_COMPLEX
2304 || arg->attr.dimension
2305 || arg->ts.type == BT_CHARACTER)
2306 type = build_reference_type (type);
2308 typelist = gfc_chainon_list (typelist, type);
2309 if (arg->ts.type == BT_CHARACTER)
2310 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2313 /* Build the argument types for the function. */
2314 for (f = sym->formal; f; f = f->next)
2319 /* Evaluate constant character lengths here so that they can be
2320 included in the type. */
2321 if (arg->ts.type == BT_CHARACTER)
2322 gfc_conv_const_charlen (arg->ts.u.cl);
2324 if (arg->attr.flavor == FL_PROCEDURE)
2326 type = gfc_get_function_type (arg);
2327 type = build_pointer_type (type);
2330 type = gfc_sym_type (arg);
2332 /* Parameter Passing Convention
2334 We currently pass all parameters by reference.
2335 Parameters with INTENT(IN) could be passed by value.
2336 The problem arises if a function is called via an implicit
2337 prototype. In this situation the INTENT is not known.
2338 For this reason all parameters to global functions must be
2339 passed by reference. Passing by value would potentially
2340 generate bad code. Worse there would be no way of telling that
2341 this code was bad, except that it would give incorrect results.
2343 Contained procedures could pass by value as these are never
2344 used without an explicit interface, and cannot be passed as
2345 actual parameters for a dummy procedure. */
2346 if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2348 typelist = gfc_chainon_list (typelist, type);
2352 if (sym->attr.subroutine)
2353 alternate_return = 1;
2357 /* Add hidden string length parameters. */
2359 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2362 typelist = gfc_chainon_list (typelist, void_type_node);
2364 if (alternate_return)
2365 type = integer_type_node;
2366 else if (!sym->attr.function || gfc_return_by_reference (sym))
2367 type = void_type_node;
2368 else if (sym->attr.mixed_entry_master)
2369 type = gfc_get_mixed_entry_union (sym->ns);
2370 else if (gfc_option.flag_f2c
2371 && sym->ts.type == BT_REAL
2372 && sym->ts.kind == gfc_default_real_kind
2373 && !sym->attr.always_explicit)
2375 /* Special case: f2c calling conventions require that (scalar)
2376 default REAL functions return the C type double instead. f2c
2377 compatibility is only an issue with functions that don't
2378 require an explicit interface, as only these could be
2379 implemented in Fortran 77. */
2380 sym->ts.kind = gfc_default_double_kind;
2381 type = gfc_typenode_for_spec (&sym->ts);
2382 sym->ts.kind = gfc_default_real_kind;
2384 else if (sym->result && sym->result->attr.proc_pointer)
2385 /* Procedure pointer return values. */
2387 if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
2389 /* Unset proc_pointer as gfc_get_function_type
2390 is called recursively. */
2391 sym->result->attr.proc_pointer = 0;
2392 type = build_pointer_type (gfc_get_function_type (sym->result));
2393 sym->result->attr.proc_pointer = 1;
2396 type = gfc_sym_type (sym->result);
2399 type = gfc_sym_type (sym);
2401 type = build_function_type (type, typelist);
2406 /* Language hooks for middle-end access to type nodes. */
2408 /* Return an integer type with BITS bits of precision,
2409 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2412 gfc_type_for_size (unsigned bits, int unsignedp)
2417 for (i = 0; i <= MAX_INT_KINDS; ++i)
2419 tree type = gfc_integer_types[i];
2420 if (type && bits == TYPE_PRECISION (type))
2424 /* Handle TImode as a special case because it is used by some backends
2425 (e.g. ARM) even though it is not available for normal use. */
2426 #if HOST_BITS_PER_WIDE_INT >= 64
2427 if (bits == TYPE_PRECISION (intTI_type_node))
2428 return intTI_type_node;
2433 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2434 return unsigned_intQI_type_node;
2435 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2436 return unsigned_intHI_type_node;
2437 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2438 return unsigned_intSI_type_node;
2439 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2440 return unsigned_intDI_type_node;
2441 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2442 return unsigned_intTI_type_node;
2448 /* Return a data type that has machine mode MODE. If the mode is an
2449 integer, then UNSIGNEDP selects between signed and unsigned types. */
2452 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2457 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2458 base = gfc_real_types;
2459 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2460 base = gfc_complex_types;
2461 else if (SCALAR_INT_MODE_P (mode))
2462 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2463 else if (VECTOR_MODE_P (mode))
2465 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2466 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2467 if (inner_type != NULL_TREE)
2468 return build_vector_type_for_mode (inner_type, mode);
2474 for (i = 0; i <= MAX_REAL_KINDS; ++i)
2476 tree type = base[i];
2477 if (type && mode == TYPE_MODE (type))
2484 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2488 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
2491 bool indirect = false;
2492 tree etype, ptype, field, t, base_decl;
2493 tree data_off, offset_off, dim_off, dim_size, elem_size;
2494 tree lower_suboff, upper_suboff, stride_suboff;
2496 if (! GFC_DESCRIPTOR_TYPE_P (type))
2498 if (! POINTER_TYPE_P (type))
2500 type = TREE_TYPE (type);
2501 if (! GFC_DESCRIPTOR_TYPE_P (type))
2506 rank = GFC_TYPE_ARRAY_RANK (type);
2507 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
2510 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2511 gcc_assert (POINTER_TYPE_P (etype));
2512 etype = TREE_TYPE (etype);
2513 gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
2514 etype = TREE_TYPE (etype);
2515 /* Can't handle variable sized elements yet. */
2516 if (int_size_in_bytes (etype) <= 0)
2518 /* Nor non-constant lower bounds in assumed shape arrays. */
2519 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2521 for (dim = 0; dim < rank; dim++)
2522 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
2523 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
2527 memset (info, '\0', sizeof (*info));
2528 info->ndimensions = rank;
2529 info->element_type = etype;
2530 ptype = build_pointer_type (gfc_array_index_type);
2531 base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
2534 base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
2535 indirect ? build_pointer_type (ptype) : ptype);
2536 GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
2538 info->base_decl = base_decl;
2540 base_decl = build1 (INDIRECT_REF, ptype, base_decl);
2542 if (GFC_TYPE_ARRAY_SPAN (type))
2543 elem_size = GFC_TYPE_ARRAY_SPAN (type);
2545 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
2546 field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
2547 data_off = byte_position (field);
2548 field = TREE_CHAIN (field);
2549 offset_off = byte_position (field);
2550 field = TREE_CHAIN (field);
2551 field = TREE_CHAIN (field);
2552 dim_off = byte_position (field);
2553 dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
2554 field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
2555 stride_suboff = byte_position (field);
2556 field = TREE_CHAIN (field);
2557 lower_suboff = byte_position (field);
2558 field = TREE_CHAIN (field);
2559 upper_suboff = byte_position (field);
2562 if (!integer_zerop (data_off))
2563 t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
2564 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
2565 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
2566 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
2567 info->allocated = build2 (NE_EXPR, boolean_type_node,
2568 info->data_location, null_pointer_node);
2569 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
2570 info->associated = build2 (NE_EXPR, boolean_type_node,
2571 info->data_location, null_pointer_node);
2573 for (dim = 0; dim < rank; dim++)
2575 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2576 size_binop (PLUS_EXPR, dim_off, lower_suboff));
2577 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2578 info->dimen[dim].lower_bound = t;
2579 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2580 size_binop (PLUS_EXPR, dim_off, upper_suboff));
2581 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2582 info->dimen[dim].upper_bound = t;
2583 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2585 /* Assumed shape arrays have known lower bounds. */
2586 info->dimen[dim].upper_bound
2587 = build2 (MINUS_EXPR, gfc_array_index_type,
2588 info->dimen[dim].upper_bound,
2589 info->dimen[dim].lower_bound);
2590 info->dimen[dim].lower_bound
2591 = fold_convert (gfc_array_index_type,
2592 GFC_TYPE_ARRAY_LBOUND (type, dim));
2593 info->dimen[dim].upper_bound
2594 = build2 (PLUS_EXPR, gfc_array_index_type,
2595 info->dimen[dim].lower_bound,
2596 info->dimen[dim].upper_bound);
2598 t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2599 size_binop (PLUS_EXPR, dim_off, stride_suboff));
2600 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2601 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
2602 info->dimen[dim].stride = t;
2603 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
2609 #include "gt-fortran-trans-types.h"