1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* trans-types.c -- gfortran backend types */
27 #include "coretypes.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
40 #if (GFC_MAX_DIMENSIONS < 10)
41 #define GFC_RANK_DIGITS 1
42 #define GFC_RANK_PRINTF_FORMAT "%01d"
43 #elif (GFC_MAX_DIMENSIONS < 100)
44 #define GFC_RANK_DIGITS 2
45 #define GFC_RANK_PRINTF_FORMAT "%02d"
47 #error If you really need >99 dimensions, continue the sequence above...
50 static tree gfc_get_derived_type (gfc_symbol * derived);
52 tree gfc_array_index_type;
54 tree ppvoid_type_node;
56 tree gfc_character1_type_node;
57 tree gfc_charlen_type_node;
59 static GTY(()) tree gfc_desc_dim_type;
60 static GTY(()) tree gfc_max_array_element_size;
62 /* Arrays for all integral and real kinds. We'll fill this in at runtime
63 after the target has a chance to process command-line options. */
65 #define MAX_INT_KINDS 5
66 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
67 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
68 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
69 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
71 #define MAX_REAL_KINDS 4
72 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
73 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
74 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
76 /* The integer kind to use for array indices. This will be set to the
77 proper value based on target information from the backend. */
79 int gfc_index_integer_kind;
81 /* The default kinds of the various types. */
83 int gfc_default_integer_kind;
84 int gfc_max_integer_kind;
85 int gfc_default_real_kind;
86 int gfc_default_double_kind;
87 int gfc_default_character_kind;
88 int gfc_default_logical_kind;
89 int gfc_default_complex_kind;
92 /* Query the target to determine which machine modes are available for
93 computation. Choose KIND numbers for them. */
98 enum machine_mode mode;
100 bool saw_i4 = false, saw_i8 = false;
101 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
103 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
107 if (!targetm.scalar_mode_supported_p (mode))
110 /* The middle end doesn't support constants larger than 2*HWI.
111 Perhaps the target hook shouldn't have accepted these either,
112 but just to be safe... */
113 bitsize = GET_MODE_BITSIZE (mode);
114 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
117 gcc_assert (i_index != MAX_INT_KINDS);
119 /* Let the kind equal the bit size divided by 8. This insulates the
120 programmer from the underlying byte size. */
128 gfc_integer_kinds[i_index].kind = kind;
129 gfc_integer_kinds[i_index].radix = 2;
130 gfc_integer_kinds[i_index].digits = bitsize - 1;
131 gfc_integer_kinds[i_index].bit_size = bitsize;
133 gfc_logical_kinds[i_index].kind = kind;
134 gfc_logical_kinds[i_index].bit_size = bitsize;
139 /* Set the maximum integer kind. Used with at least BOZ constants. */
140 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
142 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
144 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
149 if (!targetm.scalar_mode_supported_p (mode))
152 /* Let the kind equal the precision divided by 8, rounding up. Again,
153 this insulates the programmer from the underlying byte size.
155 Also, it effectively deals with IEEE extended formats. There, the
156 total size of the type may equal 16, but it's got 6 bytes of padding
157 and the increased size can get in the way of a real IEEE quad format
158 which may also be supported by the target.
160 We round up so as to handle IA-64 __floatreg (RFmode), which is an
161 82 bit type. Not to be confused with __float80 (XFmode), which is
162 an 80 bit type also supported by IA-64. So XFmode should come out
163 to be kind=10, and RFmode should come out to be kind=11. Egads. */
165 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
174 /* Careful we don't stumble a wierd internal mode. */
175 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
176 /* Or have too many modes for the allocated space. */
177 gcc_assert (r_index != MAX_REAL_KINDS);
179 gfc_real_kinds[r_index].kind = kind;
180 gfc_real_kinds[r_index].radix = fmt->b;
181 gfc_real_kinds[r_index].digits = fmt->p;
182 gfc_real_kinds[r_index].min_exponent = fmt->emin;
183 gfc_real_kinds[r_index].max_exponent = fmt->emax;
184 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
188 /* Choose the default integer kind. We choose 4 unless the user
189 directs us otherwise. */
193 fatal_error ("integer kind=8 not available for -i8 option");
194 gfc_default_integer_kind = 8;
197 gfc_default_integer_kind = 4;
199 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
201 /* Choose the default real kind. Again, we choose 4 when possible. */
205 fatal_error ("real kind=8 not available for -r8 option");
206 gfc_default_real_kind = 8;
209 gfc_default_real_kind = 4;
211 gfc_default_real_kind = gfc_real_kinds[0].kind;
213 /* Choose the default double kind. If -r8 is specified, we use kind=16,
214 if it's available, otherwise we do not change anything. */
215 if (gfc_option.r8 && saw_r16)
216 gfc_default_double_kind = 16;
217 else if (saw_r4 && saw_r8)
218 gfc_default_double_kind = 8;
221 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
222 real ... occupies two contiguous numeric storage units.
224 Therefore we must be supplied a kind twice as large as we chose
225 for single precision. There are loopholes, in that double
226 precision must *occupy* two storage units, though it doesn't have
227 to *use* two storage units. Which means that you can make this
228 kind artificially wide by padding it. But at present there are
229 no GCC targets for which a two-word type does not exist, so we
230 just let gfc_validate_kind abort and tell us if something breaks. */
232 gfc_default_double_kind
233 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
236 /* The default logical kind is constrained to be the same as the
237 default integer kind. Similarly with complex and real. */
238 gfc_default_logical_kind = gfc_default_integer_kind;
239 gfc_default_complex_kind = gfc_default_real_kind;
241 /* Choose the smallest integer kind for our default character. */
242 gfc_default_character_kind = gfc_integer_kinds[0].kind;
244 /* Choose the integer kind the same size as "void*" for our index kind. */
245 gfc_index_integer_kind = POINTER_SIZE / 8;
246 /* Pick a kind the same size as the C "int" type. */
247 gfc_c_int_kind = INT_TYPE_SIZE / 8;
250 /* Make sure that a valid kind is present. Returns an index into the
251 associated kinds array, -1 if the kind is not present. */
254 validate_integer (int kind)
258 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
259 if (gfc_integer_kinds[i].kind == kind)
266 validate_real (int kind)
270 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
271 if (gfc_real_kinds[i].kind == kind)
278 validate_logical (int kind)
282 for (i = 0; gfc_logical_kinds[i].kind; i++)
283 if (gfc_logical_kinds[i].kind == kind)
290 validate_character (int kind)
292 return kind == gfc_default_character_kind ? 0 : -1;
295 /* Validate a kind given a basic type. The return value is the same
296 for the child functions, with -1 indicating nonexistence of the
297 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
300 gfc_validate_kind (bt type, int kind, bool may_fail)
306 case BT_REAL: /* Fall through */
308 rc = validate_real (kind);
311 rc = validate_integer (kind);
314 rc = validate_logical (kind);
317 rc = validate_character (kind);
321 gfc_internal_error ("gfc_validate_kind(): Got bad type");
324 if (rc < 0 && !may_fail)
325 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
331 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
332 Reuse common type nodes where possible. Recognize if the kind matches up
333 with a C type. This will be used later in determining which routines may
334 be scarfed from libm. */
337 gfc_build_int_type (gfc_integer_info *info)
339 int mode_precision = info->bit_size;
341 if (mode_precision == CHAR_TYPE_SIZE)
343 if (mode_precision == SHORT_TYPE_SIZE)
345 if (mode_precision == INT_TYPE_SIZE)
347 if (mode_precision == LONG_TYPE_SIZE)
349 if (mode_precision == LONG_LONG_TYPE_SIZE)
350 info->c_long_long = 1;
352 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
353 return intQI_type_node;
354 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
355 return intHI_type_node;
356 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
357 return intSI_type_node;
358 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
359 return intDI_type_node;
360 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
361 return intTI_type_node;
363 return make_signed_type (mode_precision);
367 gfc_build_real_type (gfc_real_info *info)
369 int mode_precision = info->mode_precision;
372 if (mode_precision == FLOAT_TYPE_SIZE)
374 if (mode_precision == DOUBLE_TYPE_SIZE)
376 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
377 info->c_long_double = 1;
379 if (TYPE_PRECISION (float_type_node) == mode_precision)
380 return float_type_node;
381 if (TYPE_PRECISION (double_type_node) == mode_precision)
382 return double_type_node;
383 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
384 return long_double_type_node;
386 new_type = make_node (REAL_TYPE);
387 TYPE_PRECISION (new_type) = mode_precision;
388 layout_type (new_type);
393 gfc_build_complex_type (tree scalar_type)
397 if (scalar_type == NULL)
399 if (scalar_type == float_type_node)
400 return complex_float_type_node;
401 if (scalar_type == double_type_node)
402 return complex_double_type_node;
403 if (scalar_type == long_double_type_node)
404 return complex_long_double_type_node;
406 new_type = make_node (COMPLEX_TYPE);
407 TREE_TYPE (new_type) = scalar_type;
408 layout_type (new_type);
413 gfc_build_logical_type (gfc_logical_info *info)
415 int bit_size = info->bit_size;
418 if (bit_size == BOOL_TYPE_SIZE)
421 return boolean_type_node;
424 new_type = make_unsigned_type (bit_size);
425 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
426 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
427 TYPE_PRECISION (new_type) = 1;
433 /* Return the bit size of the C "size_t". */
439 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
440 return INT_TYPE_SIZE;
441 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
442 return LONG_TYPE_SIZE;
443 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
444 return SHORT_TYPE_SIZE;
447 return LONG_TYPE_SIZE;
452 /* Create the backend type nodes. We map them to their
453 equivalent C type, at least for now. We also give
454 names to the types here, and we push them in the
455 global binding level context.*/
458 gfc_init_types (void)
464 unsigned HOST_WIDE_INT hi;
465 unsigned HOST_WIDE_INT lo;
467 /* Create and name the types. */
468 #define PUSH_TYPE(name, node) \
469 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
471 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
473 type = gfc_build_int_type (&gfc_integer_kinds[index]);
474 gfc_integer_types[index] = type;
475 snprintf (name_buf, sizeof(name_buf), "int%d",
476 gfc_integer_kinds[index].kind);
477 PUSH_TYPE (name_buf, type);
480 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
482 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
483 gfc_logical_types[index] = type;
484 snprintf (name_buf, sizeof(name_buf), "logical%d",
485 gfc_logical_kinds[index].kind);
486 PUSH_TYPE (name_buf, type);
489 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
491 type = gfc_build_real_type (&gfc_real_kinds[index]);
492 gfc_real_types[index] = type;
493 snprintf (name_buf, sizeof(name_buf), "real%d",
494 gfc_real_kinds[index].kind);
495 PUSH_TYPE (name_buf, type);
497 type = gfc_build_complex_type (type);
498 gfc_complex_types[index] = type;
499 snprintf (name_buf, sizeof(name_buf), "complex%d",
500 gfc_real_kinds[index].kind);
501 PUSH_TYPE (name_buf, type);
504 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
506 PUSH_TYPE ("char", gfc_character1_type_node);
508 PUSH_TYPE ("byte", unsigned_char_type_node);
509 PUSH_TYPE ("void", void_type_node);
511 /* DBX debugging output gets upset if these aren't set. */
512 if (!TYPE_NAME (integer_type_node))
513 PUSH_TYPE ("c_integer", integer_type_node);
514 if (!TYPE_NAME (char_type_node))
515 PUSH_TYPE ("c_char", char_type_node);
519 pvoid_type_node = build_pointer_type (void_type_node);
520 ppvoid_type_node = build_pointer_type (pvoid_type_node);
521 pchar_type_node = build_pointer_type (gfc_character1_type_node);
523 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
525 /* The maximum array element size that can be handled is determined
526 by the number of bits available to store this field in the array
529 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
530 lo = ~ (unsigned HOST_WIDE_INT) 0;
531 if (n > HOST_BITS_PER_WIDE_INT)
532 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
534 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
535 gfc_max_array_element_size
536 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
538 size_type_node = gfc_array_index_type;
540 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
541 boolean_true_node = build_int_cst (boolean_type_node, 1);
542 boolean_false_node = build_int_cst (boolean_type_node, 0);
544 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
545 gfc_charlen_type_node = gfc_get_int_type (4);
548 /* Get the type node for the given type and kind. */
551 gfc_get_int_type (int kind)
553 int index = gfc_validate_kind (BT_INTEGER, kind, false);
554 return gfc_integer_types[index];
558 gfc_get_real_type (int kind)
560 int index = gfc_validate_kind (BT_REAL, kind, false);
561 return gfc_real_types[index];
565 gfc_get_complex_type (int kind)
567 int index = gfc_validate_kind (BT_COMPLEX, kind, false);
568 return gfc_complex_types[index];
572 gfc_get_logical_type (int kind)
574 int index = gfc_validate_kind (BT_LOGICAL, kind, false);
575 return gfc_logical_types[index];
578 /* Create a character type with the given kind and length. */
581 gfc_get_character_type_len (int kind, tree len)
585 gfc_validate_kind (BT_CHARACTER, kind, false);
587 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
588 type = build_array_type (gfc_character1_type_node, bounds);
589 TYPE_STRING_FLAG (type) = 1;
595 /* Get a type node for a character kind. */
598 gfc_get_character_type (int kind, gfc_charlen * cl)
602 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
604 return gfc_get_character_type_len (kind, len);
607 /* Covert a basic type. This will be an array for character types. */
610 gfc_typenode_for_spec (gfc_typespec * spec)
620 basetype = gfc_get_int_type (spec->kind);
624 basetype = gfc_get_real_type (spec->kind);
628 basetype = gfc_get_complex_type (spec->kind);
632 basetype = gfc_get_logical_type (spec->kind);
636 basetype = gfc_get_character_type (spec->kind, spec->cl);
640 basetype = gfc_get_derived_type (spec->derived);
649 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
652 gfc_conv_array_bound (gfc_expr * expr)
654 /* If expr is an integer constant, return that. */
655 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
656 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
658 /* Otherwise return NULL. */
663 gfc_get_element_type (tree type)
667 if (GFC_ARRAY_TYPE_P (type))
669 if (TREE_CODE (type) == POINTER_TYPE)
670 type = TREE_TYPE (type);
671 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
672 element = TREE_TYPE (type);
676 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
677 element = TREE_TYPE (TYPE_FIELDS (type));
679 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
680 element = TREE_TYPE (element);
682 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
683 element = TREE_TYPE (element);
689 /* Build an array. This function is called from gfc_sym_type().
690 Actually returns array descriptor type.
692 Format of array descriptors is as follows:
694 struct gfc_array_descriptor
699 struct descriptor_dimension dimension[N_DIM];
702 struct descriptor_dimension
709 Translation code should use gfc_conv_descriptor_* rather than accessing
710 the descriptor directly. Any changes to the array descriptor type will
711 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
713 This is represented internally as a RECORD_TYPE. The index nodes are
714 gfc_array_index_type and the data node is a pointer to the data. See below
715 for the handling of character types.
717 The dtype member is formatted as follows:
718 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
719 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
720 size = dtype >> GFC_DTYPE_SIZE_SHIFT
722 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
723 generated poor code for assumed/deferred size arrays. These require
724 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
725 grammar. Also, there is no way to explicitly set the array stride, so
726 all data must be packed(1). I've tried to mark all the functions which
727 would require modification with a GCC ARRAYS comment.
729 The data component points to the first element in the array.
730 The offset field is the position of the origin of the array
731 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
733 An element is accessed by
734 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
735 This gives good performance as the computation does not involve the
736 bounds of the array. For packed arrays, this is optimized further by
737 substituting the known strides.
739 This system has one problem: all array bounds must be withing 2^31 elements
740 of the origin (2^63 on 64-bit machines). For example
741 integer, dimension (80000:90000, 80000:90000, 2) :: array
742 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
743 the calculation for stride02 would overflow. This may still work, but
744 I haven't checked, and it relies on the overflow doing the right thing.
746 The way to fix this problem is to access elements as follows:
747 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
748 Obviously this is much slower. I will make this a compile time option,
749 something like -fsmall-array-offsets. Mixing code compiled with and without
750 this switch will work.
752 (1) This can be worked around by modifying the upper bound of the previous
753 dimension. This requires extra fields in the descriptor (both real_ubound
754 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
755 may allow us to do this. However I can't find mention of this anywhere
759 /* Returns true if the array sym does not require a descriptor. */
762 gfc_is_nodesc_array (gfc_symbol * sym)
764 gcc_assert (sym->attr.dimension);
766 /* We only want local arrays. */
767 if (sym->attr.pointer || sym->attr.allocatable)
772 if (sym->as->type != AS_ASSUMED_SHAPE)
778 if (sym->attr.result || sym->attr.function)
781 if (sym->attr.pointer || sym->attr.allocatable)
784 gcc_assert (sym->as->type == AS_EXPLICIT);
790 /* Create an array descriptor type. */
793 gfc_build_array_type (tree type, gfc_array_spec * as)
795 tree lbound[GFC_MAX_DIMENSIONS];
796 tree ubound[GFC_MAX_DIMENSIONS];
799 for (n = 0; n < as->rank; n++)
801 /* Create expressions for the known bounds of the array. */
802 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
803 lbound[n] = gfc_index_one_node;
805 lbound[n] = gfc_conv_array_bound (as->lower[n]);
806 ubound[n] = gfc_conv_array_bound (as->upper[n]);
809 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
812 /* Returns the struct descriptor_dimension type. */
815 gfc_get_desc_dim_type (void)
821 if (gfc_desc_dim_type)
822 return gfc_desc_dim_type;
824 /* Build the type node. */
825 type = make_node (RECORD_TYPE);
827 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
828 TYPE_PACKED (type) = 1;
830 /* Consists of the stride, lbound and ubound members. */
831 decl = build_decl (FIELD_DECL,
832 get_identifier ("stride"), gfc_array_index_type);
833 DECL_CONTEXT (decl) = type;
836 decl = build_decl (FIELD_DECL,
837 get_identifier ("lbound"), gfc_array_index_type);
838 DECL_CONTEXT (decl) = type;
839 fieldlist = chainon (fieldlist, decl);
841 decl = build_decl (FIELD_DECL,
842 get_identifier ("ubound"), gfc_array_index_type);
843 DECL_CONTEXT (decl) = type;
844 fieldlist = chainon (fieldlist, decl);
846 /* Finish off the type. */
847 TYPE_FIELDS (type) = fieldlist;
849 gfc_finish_type (type);
851 gfc_desc_dim_type = type;
856 /* Return the DTYPE for an array. This describes the type and type parameters
858 /* TODO: Only call this when the value is actually used, and make all the
859 unknown cases abort. */
862 gfc_get_dtype (tree type)
872 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
874 if (GFC_TYPE_ARRAY_DTYPE (type))
875 return GFC_TYPE_ARRAY_DTYPE (type);
877 rank = GFC_TYPE_ARRAY_RANK (type);
878 etype = gfc_get_element_type (type);
880 switch (TREE_CODE (etype))
883 n = GFC_DTYPE_INTEGER;
887 n = GFC_DTYPE_LOGICAL;
895 n = GFC_DTYPE_COMPLEX;
898 /* We will never have arrays of arrays. */
900 n = GFC_DTYPE_DERIVED;
904 n = GFC_DTYPE_CHARACTER;
908 /* TODO: Don't do dtype for temporary descriptorless arrays. */
909 /* We can strange array types for temporary arrays. */
910 return gfc_index_zero_node;
913 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
914 size = TYPE_SIZE_UNIT (etype);
916 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
917 if (size && INTEGER_CST_P (size))
919 if (tree_int_cst_lt (gfc_max_array_element_size, size))
920 internal_error ("Array element size too big");
922 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
924 dtype = build_int_cst (gfc_array_index_type, i);
926 if (size && !INTEGER_CST_P (size))
928 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
929 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
930 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
932 /* If we don't know the size we leave it as zero. This should never happen
933 for anything that is actually used. */
934 /* TODO: Check this is actually true, particularly when repacking
935 assumed size parameters. */
937 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
942 /* Build an array type for use without a descriptor. Valid values of packed
943 are 0=no, 1=partial, 2=full, 3=static. */
946 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
959 mpz_init_set_ui (offset, 0);
960 mpz_init_set_ui (stride, 1);
963 /* We don't use build_array_type because this does not include include
964 lang-specific information (i.e. the bounds of the array) when checking
966 type = make_node (ARRAY_TYPE);
968 GFC_ARRAY_TYPE_P (type) = 1;
969 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
970 ggc_alloc_cleared (sizeof (struct lang_type));
972 known_stride = (packed != 0);
974 for (n = 0; n < as->rank; n++)
976 /* Fill in the stride and bound components of the type. */
978 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
981 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
984 if (expr->expr_type == EXPR_CONSTANT)
986 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
987 gfc_index_integer_kind);
994 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
998 /* Calculate the offset. */
999 mpz_mul (delta, stride, as->lower[n]->value.integer);
1000 mpz_sub (offset, offset, delta);
1005 expr = as->upper[n];
1006 if (expr && expr->expr_type == EXPR_CONSTANT)
1008 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1009 gfc_index_integer_kind);
1016 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1020 /* Calculate the stride. */
1021 mpz_sub (delta, as->upper[n]->value.integer,
1022 as->lower[n]->value.integer);
1023 mpz_add_ui (delta, delta, 1);
1024 mpz_mul (stride, stride, delta);
1027 /* Only the first stride is known for partial packed arrays. */
1034 GFC_TYPE_ARRAY_OFFSET (type) =
1035 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1038 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1042 GFC_TYPE_ARRAY_SIZE (type) =
1043 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1046 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1048 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1049 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1050 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1052 /* TODO: use main type if it is unbounded. */
1053 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1054 build_pointer_type (build_array_type (etype, range));
1058 mpz_sub_ui (stride, stride, 1);
1059 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1064 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1065 TYPE_DOMAIN (type) = range;
1067 build_pointer_type (etype);
1068 TREE_TYPE (type) = etype;
1076 if (packed < 3 || !known_stride)
1078 /* For dummy arrays and automatic (heap allocated) arrays we
1079 want a pointer to the array. */
1080 type = build_pointer_type (type);
1081 GFC_ARRAY_TYPE_P (type) = 1;
1082 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1088 /* Build an array (descriptor) type with given bounds. */
1091 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1092 tree * ubound, int packed)
1094 tree fat_type, fat_pointer_type;
1099 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1100 const char *typename;
1106 /* Build the type node. */
1107 fat_type = make_node (RECORD_TYPE);
1108 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1109 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1110 ggc_alloc_cleared (sizeof (struct lang_type));
1111 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1112 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1114 tmp = TYPE_NAME (etype);
1115 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1116 tmp = DECL_NAME (tmp);
1118 typename = IDENTIFIER_POINTER (tmp);
1120 typename = "unknown";
1122 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1123 GFC_MAX_SYMBOL_LEN, typename);
1124 TYPE_NAME (fat_type) = get_identifier (name);
1125 TYPE_PACKED (fat_type) = 0;
1127 fat_pointer_type = build_pointer_type (fat_type);
1129 /* Build an array descriptor record type. */
1131 stride = gfc_index_one_node;
1135 for (n = 0; n < dimen; n++)
1137 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1144 if (lower != NULL_TREE)
1146 if (INTEGER_CST_P (lower))
1147 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1153 if (upper != NULL_TREE)
1155 if (INTEGER_CST_P (upper))
1156 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1161 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1163 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1164 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1165 gfc_index_one_node);
1167 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1168 /* Check the folding worked. */
1169 gcc_assert (INTEGER_CST_P (stride));
1174 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1175 /* TODO: known offsets for descriptors. */
1176 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1178 /* We define data as an unknown size array. Much better than doing
1179 pointer arithmetic. */
1181 build_array_type (etype,
1182 build_range_type (gfc_array_index_type,
1183 gfc_index_zero_node, NULL_TREE));
1184 arraytype = build_pointer_type (arraytype);
1185 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1187 /* The pointer to the array data. */
1188 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
1190 DECL_CONTEXT (decl) = fat_type;
1191 /* Add the data member as the first element of the descriptor. */
1194 /* Add the base component. */
1195 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1196 gfc_array_index_type);
1197 DECL_CONTEXT (decl) = fat_type;
1198 fieldlist = chainon (fieldlist, decl);
1200 /* Add the dtype component. */
1201 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1202 gfc_array_index_type);
1203 DECL_CONTEXT (decl) = fat_type;
1204 fieldlist = chainon (fieldlist, decl);
1206 /* Build the array type for the stride and bound components. */
1208 build_array_type (gfc_get_desc_dim_type (),
1209 build_range_type (gfc_array_index_type,
1210 gfc_index_zero_node,
1211 gfc_rank_cst[dimen - 1]));
1213 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1214 DECL_CONTEXT (decl) = fat_type;
1215 DECL_INITIAL (decl) = NULL_TREE;
1216 fieldlist = chainon (fieldlist, decl);
1218 /* Finish off the type. */
1219 TYPE_FIELDS (fat_type) = fieldlist;
1221 gfc_finish_type (fat_type);
1226 /* Build a pointer type. This function is called from gfc_sym_type(). */
1229 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1231 /* Array pointer types aren't actually pointers. */
1232 if (sym->attr.dimension)
1235 return build_pointer_type (type);
1238 /* Return the type for a symbol. Special handling is required for character
1239 types to get the correct level of indirection.
1240 For functions return the return type.
1241 For subroutines return void_type_node.
1242 Calling this multiple times for the same symbol should be avoided,
1243 especially for character and array types. */
1246 gfc_sym_type (gfc_symbol * sym)
1251 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1252 return void_type_node;
1254 if (sym->backend_decl)
1256 if (sym->attr.function)
1257 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
1259 return TREE_TYPE (sym->backend_decl);
1262 /* The frontend doesn't set all the attributes for a function with an
1263 explicit result value, so we use that instead when present. */
1264 if (sym->attr.function && sym->result)
1267 type = gfc_typenode_for_spec (&sym->ts);
1269 if (sym->attr.dummy && !sym->attr.function)
1274 if (sym->attr.dimension)
1276 if (gfc_is_nodesc_array (sym))
1278 /* If this is a character argument of unknown length, just use the
1280 if (sym->ts.type != BT_CHARACTER
1281 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
1282 || sym->ts.cl->backend_decl)
1284 type = gfc_get_nodesc_array_type (type, sym->as,
1290 type = gfc_build_array_type (type, sym->as);
1294 if (sym->attr.allocatable || sym->attr.pointer)
1295 type = gfc_build_pointer_type (sym, type);
1298 /* We currently pass all parameters by reference.
1299 See f95_get_function_decl. For dummy function parameters return the
1303 /* We must use pointer types for potentially absent variables. The
1304 optimizers assume a reference type argument is never NULL. */
1305 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1306 type = build_pointer_type (type);
1308 type = build_reference_type (type);
1314 /* Layout and output debug info for a record type. */
1317 gfc_finish_type (tree type)
1321 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1322 TYPE_STUB_DECL (type) = decl;
1324 rest_of_type_compilation (type, 1);
1325 rest_of_decl_compilation (decl, 1, 0);
1328 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1329 or RECORD_TYPE pointed to by STYPE. The new field is chained
1330 to the fieldlist pointed to by FIELDLIST.
1332 Returns a pointer to the new field. */
1335 gfc_add_field_to_struct (tree *fieldlist, tree context,
1336 tree name, tree type)
1340 decl = build_decl (FIELD_DECL, name, type);
1342 DECL_CONTEXT (decl) = context;
1343 DECL_INITIAL (decl) = 0;
1344 DECL_ALIGN (decl) = 0;
1345 DECL_USER_ALIGN (decl) = 0;
1346 TREE_CHAIN (decl) = NULL_TREE;
1347 *fieldlist = chainon (*fieldlist, decl);
1353 /* Build a tree node for a derived type. */
1356 gfc_get_derived_type (gfc_symbol * derived)
1358 tree typenode, field, field_type, fieldlist;
1361 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1363 /* derived->backend_decl != 0 means we saw it before, but its
1364 components' backend_decl may have not been built. */
1365 if (derived->backend_decl)
1367 /* Its components' backend_decl have been built. */
1368 if (TYPE_FIELDS (derived->backend_decl))
1369 return derived->backend_decl;
1371 typenode = derived->backend_decl;
1375 /* We see this derived type first time, so build the type node. */
1376 typenode = make_node (RECORD_TYPE);
1377 TYPE_NAME (typenode) = get_identifier (derived->name);
1378 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1379 derived->backend_decl = typenode;
1382 /* Build the type member list. Install the newly created RECORD_TYPE
1383 node as DECL_CONTEXT of each FIELD_DECL. */
1384 fieldlist = NULL_TREE;
1385 for (c = derived->components; c; c = c->next)
1387 if (c->ts.type == BT_DERIVED && c->pointer)
1389 if (c->ts.derived->backend_decl)
1390 /* We already saw this derived type so use the exiting type.
1391 It doesn't matter if it is incomplete. */
1392 field_type = c->ts.derived->backend_decl;
1394 /* Recurse into the type. */
1395 field_type = gfc_get_derived_type (c->ts.derived);
1399 if (c->ts.type == BT_CHARACTER)
1401 /* Evaluate the string length. */
1402 gfc_conv_const_charlen (c->ts.cl);
1403 gcc_assert (c->ts.cl->backend_decl);
1406 field_type = gfc_typenode_for_spec (&c->ts);
1409 /* This returns an array descriptor type. Initialization may be
1415 /* Pointers to arrays aren't actually pointer types. The
1416 descriptors are separate, but the data is common. */
1417 field_type = gfc_build_array_type (field_type, c->as);
1420 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1422 else if (c->pointer)
1423 field_type = build_pointer_type (field_type);
1425 field = gfc_add_field_to_struct (&fieldlist, typenode,
1426 get_identifier (c->name),
1429 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1431 gcc_assert (!c->backend_decl);
1432 c->backend_decl = field;
1435 /* Now we have the final fieldlist. Record it, then lay out the
1436 derived type, including the fields. */
1437 TYPE_FIELDS (typenode) = fieldlist;
1439 gfc_finish_type (typenode);
1441 derived->backend_decl = typenode;
1447 gfc_return_by_reference (gfc_symbol * sym)
1449 if (!sym->attr.function)
1455 if (sym->attr.dimension)
1458 if (sym->ts.type == BT_CHARACTER)
1461 /* Possibly return complex numbers by reference for g77 compatibility. */
1466 gfc_get_function_type (gfc_symbol * sym)
1470 gfc_formal_arglist *f;
1473 int alternate_return;
1475 /* Make sure this symbol is a function or a subroutine. */
1476 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1478 if (sym->backend_decl)
1479 return TREE_TYPE (sym->backend_decl);
1482 alternate_return = 0;
1483 typelist = NULL_TREE;
1485 if (sym->attr.entry_master)
1487 /* Additional parameter for selecting an entry point. */
1488 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1491 /* Some functions we use an extra parameter for the return value. */
1492 if (gfc_return_by_reference (sym))
1499 if (arg->ts.type == BT_CHARACTER)
1500 gfc_conv_const_charlen (arg->ts.cl);
1502 type = gfc_sym_type (arg);
1503 if (arg->ts.type == BT_DERIVED
1504 || arg->attr.dimension
1505 || arg->ts.type == BT_CHARACTER)
1506 type = build_reference_type (type);
1508 typelist = gfc_chainon_list (typelist, type);
1509 if (arg->ts.type == BT_CHARACTER)
1510 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1513 /* Build the argument types for the function. */
1514 for (f = sym->formal; f; f = f->next)
1519 /* Evaluate constant character lengths here so that they can be
1520 included in the type. */
1521 if (arg->ts.type == BT_CHARACTER)
1522 gfc_conv_const_charlen (arg->ts.cl);
1524 if (arg->attr.flavor == FL_PROCEDURE)
1526 type = gfc_get_function_type (arg);
1527 type = build_pointer_type (type);
1530 type = gfc_sym_type (arg);
1532 /* Parameter Passing Convention
1534 We currently pass all parameters by reference.
1535 Parameters with INTENT(IN) could be passed by value.
1536 The problem arises if a function is called via an implicit
1537 prototype. In this situation the INTENT is not known.
1538 For this reason all parameters to global functions must be
1539 passed by reference. Passing by value would potentialy
1540 generate bad code. Worse there would be no way of telling that
1541 this code was bad, except that it would give incorrect results.
1543 Contained procedures could pass by value as these are never
1544 used without an explicit interface, and connot be passed as
1545 actual parameters for a dummy procedure. */
1546 if (arg->ts.type == BT_CHARACTER)
1548 typelist = gfc_chainon_list (typelist, type);
1552 if (sym->attr.subroutine)
1553 alternate_return = 1;
1557 /* Add hidden string length parameters. */
1559 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1561 typelist = gfc_chainon_list (typelist, void_type_node);
1563 if (alternate_return)
1564 type = integer_type_node;
1565 else if (!sym->attr.function || gfc_return_by_reference (sym))
1566 type = void_type_node;
1568 type = gfc_sym_type (sym);
1570 type = build_function_type (type, typelist);
1575 /* Language hooks for middle-end access to type nodes. */
1577 /* Return an integer type with BITS bits of precision,
1578 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1581 gfc_type_for_size (unsigned bits, int unsignedp)
1586 for (i = 0; i <= MAX_INT_KINDS; ++i)
1588 tree type = gfc_integer_types[i];
1589 if (type && bits == TYPE_PRECISION (type))
1595 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1596 return unsigned_intQI_type_node;
1597 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1598 return unsigned_intHI_type_node;
1599 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1600 return unsigned_intSI_type_node;
1601 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1602 return unsigned_intDI_type_node;
1603 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1604 return unsigned_intTI_type_node;
1610 /* Return a data type that has machine mode MODE. If the mode is an
1611 integer, then UNSIGNEDP selects between signed and unsigned types. */
1614 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1619 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1620 base = gfc_real_types;
1621 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1622 base = gfc_complex_types;
1623 else if (SCALAR_INT_MODE_P (mode))
1624 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1625 else if (VECTOR_MODE_P (mode))
1627 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1628 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1629 if (inner_type != NULL_TREE)
1630 return build_vector_type_for_mode (inner_type, mode);
1636 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1638 tree type = base[i];
1639 if (type && mode == TYPE_MODE (type))
1646 /* Return a type the same as TYPE except unsigned or
1647 signed according to UNSIGNEDP. */
1650 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1652 if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
1655 return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
1658 /* Return an unsigned type the same as TYPE in other respects. */
1661 gfc_unsigned_type (tree type)
1663 return gfc_signed_or_unsigned_type (1, type);
1666 /* Return a signed type the same as TYPE in other respects. */
1669 gfc_signed_type (tree type)
1671 return gfc_signed_or_unsigned_type (0, type);
1674 #include "gt-fortran-trans-types.h"