1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004 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"
39 #if (GFC_MAX_DIMENSIONS < 10)
40 #define GFC_RANK_DIGITS 1
41 #define GFC_RANK_PRINTF_FORMAT "%01d"
42 #elif (GFC_MAX_DIMENSIONS < 100)
43 #define GFC_RANK_DIGITS 2
44 #define GFC_RANK_PRINTF_FORMAT "%02d"
46 #error If you really need >99 dimensions, continue the sequence above...
49 static tree gfc_get_derived_type (gfc_symbol * derived);
51 tree gfc_type_nodes[NUM_F95_TYPES];
53 tree gfc_array_index_type;
55 tree ppvoid_type_node;
58 static GTY(()) tree gfc_desc_dim_type = NULL;
60 static GTY(()) tree gfc_max_array_element_size;
62 /* Create the backend type nodes. We map them to their
63 equivalent C type, at least for now. We also give
64 names to the types here, and we push them in the
65 global binding level context.*/
71 unsigned HOST_WIDE_INT hi;
72 unsigned HOST_WIDE_INT lo;
75 #define PUSH_TYPE(name, node) \
76 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
78 gfc_int1_type_node = signed_char_type_node;
79 PUSH_TYPE ("int1", gfc_int1_type_node);
80 gfc_int2_type_node = short_integer_type_node;
81 PUSH_TYPE ("int2", gfc_int2_type_node);
82 gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ );
83 PUSH_TYPE ("int4", gfc_int4_type_node);
84 gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ );
85 PUSH_TYPE ("int8", gfc_int8_type_node);
86 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
87 gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ );
88 PUSH_TYPE ("int16", gfc_int16_type_node);
91 gfc_real4_type_node = float_type_node;
92 PUSH_TYPE ("real4", gfc_real4_type_node);
93 gfc_real8_type_node = double_type_node;
94 PUSH_TYPE ("real8", gfc_real8_type_node);
95 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
96 /* Hmm, this will not work. Ref. g77 */
97 gfc_real16_type_node = long_double_type_node;
98 PUSH_TYPE ("real16", gfc_real16_type_node);
101 gfc_complex4_type_node = complex_float_type_node;
102 PUSH_TYPE ("complex4", gfc_complex4_type_node);
103 gfc_complex8_type_node = complex_double_type_node;
104 PUSH_TYPE ("complex8", gfc_complex8_type_node);
105 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
106 /* Hmm, this will not work. Ref. g77 */
107 gfc_complex16_type_node = complex_long_double_type_node;
108 PUSH_TYPE ("complex16", gfc_complex16_type_node);
111 gfc_logical1_type_node = make_node (BOOLEAN_TYPE);
112 TYPE_PRECISION (gfc_logical1_type_node) = 8;
113 fixup_unsigned_type (gfc_logical1_type_node);
114 PUSH_TYPE ("logical1", gfc_logical1_type_node);
115 gfc_logical2_type_node = make_node (BOOLEAN_TYPE);
116 TYPE_PRECISION (gfc_logical2_type_node) = 16;
117 fixup_unsigned_type (gfc_logical2_type_node);
118 PUSH_TYPE ("logical2", gfc_logical2_type_node);
119 gfc_logical4_type_node = make_node (BOOLEAN_TYPE);
120 TYPE_PRECISION (gfc_logical4_type_node) = 32;
121 fixup_unsigned_type (gfc_logical4_type_node);
122 PUSH_TYPE ("logical4", gfc_logical4_type_node);
123 gfc_logical8_type_node = make_node (BOOLEAN_TYPE);
124 TYPE_PRECISION (gfc_logical8_type_node) = 64;
125 fixup_unsigned_type (gfc_logical8_type_node);
126 PUSH_TYPE ("logical8", gfc_logical8_type_node);
127 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
128 gfc_logical16_type_node = make_node (BOOLEAN_TYPE);
129 TYPE_PRECISION (gfc_logical16_type_node) = 128;
130 fixup_unsigned_type (gfc_logical16_type_node);
131 PUSH_TYPE ("logical16", gfc_logical16_type_node);
134 gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
135 PUSH_TYPE ("char", gfc_character1_type_node);
137 PUSH_TYPE ("byte", unsigned_char_type_node);
138 PUSH_TYPE ("void", void_type_node);
140 /* DBX debugging output gets upset if these aren't set. */
141 if (!TYPE_NAME (integer_type_node))
142 PUSH_TYPE ("c_integer", integer_type_node);
143 if (!TYPE_NAME (char_type_node))
144 PUSH_TYPE ("c_char", char_type_node);
147 pvoid_type_node = build_pointer_type (void_type_node);
148 ppvoid_type_node = build_pointer_type (pvoid_type_node);
149 pchar_type_node = build_pointer_type (gfc_character1_type_node);
151 gfc_index_integer_kind = TYPE_PRECISION (long_unsigned_type_node) / 8;
152 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
154 /* The maximum array element size that can be handled is determined
155 by the number of bits available to store this field in the array
158 n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type))
159 - GFC_DTYPE_SIZE_SHIFT;
161 if (n > sizeof (HOST_WIDE_INT) * 8)
163 lo = ~(unsigned HOST_WIDE_INT) 0;
164 hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n);
169 lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n);
171 gfc_max_array_element_size
172 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
174 size_type_node = gfc_array_index_type;
175 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ());
177 boolean_true_node = build_int_cst (boolean_type_node, 1);
178 boolean_false_node = build_int_cst (boolean_type_node, 0);
181 /* Get a type node for an integer kind. */
184 gfc_get_int_type (int kind)
189 return (gfc_int1_type_node);
191 return (gfc_int2_type_node);
193 return (gfc_int4_type_node);
195 return (gfc_int8_type_node);
196 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
198 return (95 _int16_type_node);
201 fatal_error ("integer kind=%d not available", kind);
205 /* Get a type node for a real kind. */
208 gfc_get_real_type (int kind)
213 return (gfc_real4_type_node);
215 return (gfc_real8_type_node);
216 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
218 return (gfc_real16_type_node);
221 fatal_error ("real kind=%d not available", kind);
225 /* Get a type node for a complex kind. */
228 gfc_get_complex_type (int kind)
234 return (gfc_complex4_type_node);
236 return (gfc_complex8_type_node);
237 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
239 return (gfc_complex16_type_node);
242 fatal_error ("complex kind=%d not available", kind);
246 /* Get a type node for a logical kind. */
249 gfc_get_logical_type (int kind)
254 return (gfc_logical1_type_node);
256 return (gfc_logical2_type_node);
258 return (gfc_logical4_type_node);
260 return (gfc_logical8_type_node);
261 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
263 return (gfc_logical16_type_node);
266 fatal_error ("logical kind=%d not available", kind);
270 /* Create a character type with the given kind and length. */
273 gfc_get_character_type_len (int kind, tree len)
282 base = gfc_character1_type_node;
286 fatal_error ("character kind=%d not available", kind);
289 bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
290 type = build_array_type (base, bounds);
291 TYPE_STRING_FLAG (type) = 1;
297 /* Get a type node for a character kind. */
300 gfc_get_character_type (int kind, gfc_charlen * cl)
304 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
306 return gfc_get_character_type_len (kind, len);
309 /* Covert a basic type. This will be an array for character types. */
312 gfc_typenode_for_spec (gfc_typespec * spec)
323 basetype = gfc_get_int_type (spec->kind);
327 basetype = gfc_get_real_type (spec->kind);
331 basetype = gfc_get_complex_type (spec->kind);
335 basetype = gfc_get_logical_type (spec->kind);
339 basetype = gfc_get_character_type (spec->kind, spec->cl);
343 basetype = gfc_get_derived_type (spec->derived);
353 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
356 gfc_conv_array_bound (gfc_expr * expr)
358 /* If expr is an integer constant, return that. */
359 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
360 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
362 /* Otherwise return NULL. */
367 gfc_get_element_type (tree type)
371 if (GFC_ARRAY_TYPE_P (type))
373 if (TREE_CODE (type) == POINTER_TYPE)
374 type = TREE_TYPE (type);
375 assert (TREE_CODE (type) == ARRAY_TYPE);
376 element = TREE_TYPE (type);
380 assert (GFC_DESCRIPTOR_TYPE_P (type));
381 element = TREE_TYPE (TYPE_FIELDS (type));
383 assert (TREE_CODE (element) == POINTER_TYPE);
384 element = TREE_TYPE (element);
386 assert (TREE_CODE (element) == ARRAY_TYPE);
387 element = TREE_TYPE (element);
393 /* Build an array. This function is called from gfc_sym_type().
394 Actually returns array descriptor type.
396 Format of array descriptors is as follows:
398 struct gfc_array_descriptor
403 struct descriptor_dimension dimension[N_DIM];
406 struct descriptor_dimension
413 Translation code should use gfc_conv_descriptor_* rather than accessing
414 the descriptor directly. Any changes to the array descriptor type will
415 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
417 This is represented internally as a RECORD_TYPE. The index nodes are
418 gfc_array_index_type and the data node is a pointer to the data. See below
419 for the handling of character types.
421 The dtype member is formatted as follows:
422 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
423 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
424 size = dtype >> GFC_DTYPE_SIZE_SHIFT
426 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
427 generated poor code for assumed/deferred size arrays. These require
428 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
429 grammar. Also, there is no way to explicitly set the array stride, so
430 all data must be packed(1). I've tried to mark all the functions which
431 would require modification with a GCC ARRAYS comment.
433 The data component points to the first element in the array.
434 The offset field is the position of the origin of the array
435 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
437 An element is accessed by
438 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
439 This gives good performance as the computation does not involve the
440 bounds of the array. For packed arrays, this is optimized further by
441 substituting the known strides.
443 This system has one problem: all array bounds must be withing 2^31 elements
444 of the origin (2^63 on 64-bit machines). For example
445 integer, dimension (80000:90000, 80000:90000, 2) :: array
446 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
447 the calculation for stride02 would overflow. This may still work, but
448 I haven't checked, and it relies on the overflow doing the right thing.
450 The way to fix this problem is to access alements as follows:
451 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
452 Obviously this is much slower. I will make this a compile time option,
453 something like -fsmall-array-offsets. Mixing code compiled with and without
454 this switch will work.
456 (1) This can be worked around by modifying the upper bound of the previous
457 dimension. This requires extra fields in the descriptor (both real_ubound
458 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
459 may allow us to do this. However I can't find mention of this anywhere
463 /* Returns true if the array sym does not require a descriptor. */
466 gfc_is_nodesc_array (gfc_symbol * sym)
468 assert (sym->attr.dimension);
470 /* We only want local arrays. */
471 if (sym->attr.pointer || sym->attr.allocatable)
476 if (sym->as->type != AS_ASSUMED_SHAPE)
482 if (sym->attr.result || sym->attr.function)
485 if (sym->attr.pointer || sym->attr.allocatable)
488 assert (sym->as->type == AS_EXPLICIT);
494 /* Create an array descriptor type. */
497 gfc_build_array_type (tree type, gfc_array_spec * as)
499 tree lbound[GFC_MAX_DIMENSIONS];
500 tree ubound[GFC_MAX_DIMENSIONS];
503 for (n = 0; n < as->rank; n++)
505 /* Create expressions for the known bounds of the array. */
506 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
507 lbound[n] = gfc_index_one_node;
509 lbound[n] = gfc_conv_array_bound (as->lower[n]);
510 ubound[n] = gfc_conv_array_bound (as->upper[n]);
513 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
516 /* Returns the struct descriptor_dimension type. */
519 gfc_get_desc_dim_type (void)
525 if (gfc_desc_dim_type)
526 return gfc_desc_dim_type;
528 /* Build the type node. */
529 type = make_node (RECORD_TYPE);
531 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
532 TYPE_PACKED (type) = 1;
534 /* Consists of the stride, lbound and ubound members. */
535 decl = build_decl (FIELD_DECL,
536 get_identifier ("stride"), gfc_array_index_type);
537 DECL_CONTEXT (decl) = type;
540 decl = build_decl (FIELD_DECL,
541 get_identifier ("lbound"), gfc_array_index_type);
542 DECL_CONTEXT (decl) = type;
543 fieldlist = chainon (fieldlist, decl);
545 decl = build_decl (FIELD_DECL,
546 get_identifier ("ubound"), gfc_array_index_type);
547 DECL_CONTEXT (decl) = type;
548 fieldlist = chainon (fieldlist, decl);
550 /* Finish off the type. */
551 TYPE_FIELDS (type) = fieldlist;
553 gfc_finish_type (type);
555 gfc_desc_dim_type = type;
560 gfc_get_dtype (tree type, int rank)
568 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
569 return (GFC_TYPE_ARRAY_DTYPE (type));
571 /* TODO: Correctly identify LOGICAL types. */
572 switch (TREE_CODE (type))
575 n = GFC_DTYPE_INTEGER;
579 n = GFC_DTYPE_LOGICAL;
587 n = GFC_DTYPE_COMPLEX;
590 /* Arrays have already been dealt with. */
592 n = GFC_DTYPE_DERIVED;
596 n = GFC_DTYPE_CHARACTER;
600 /* TODO: Don't do dtype for temporary descriptorless arrays. */
601 /* We can strange array types for temporary arrays. */
602 return gfc_index_zero_node;
605 assert (rank <= GFC_DTYPE_RANK_MASK);
606 size = TYPE_SIZE_UNIT (type);
608 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
609 if (size && INTEGER_CST_P (size))
611 if (tree_int_cst_lt (gfc_max_array_element_size, size))
612 internal_error ("Array element size too big");
614 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
616 dtype = build_int_cst (gfc_array_index_type, i);
618 if (size && !INTEGER_CST_P (size))
620 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
621 tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
622 dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
624 /* If we don't know the size we leave it as zero. This should never happen
625 for anything that is actually used. */
626 /* TODO: Check this is actually true, particularly when repacking
627 assumed size parameters. */
633 /* Build an array type for use without a descriptor. Valid values of packed
634 are 0=no, 1=partial, 2=full, 3=static. */
637 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
650 mpz_init_set_ui (offset, 0);
651 mpz_init_set_ui (stride, 1);
654 /* We don't use build_array_type because this does not include include
655 lang-specific information (ie. the bounds of the array) when checking
657 type = make_node (ARRAY_TYPE);
659 GFC_ARRAY_TYPE_P (type) = 1;
660 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
661 ggc_alloc_cleared (sizeof (struct lang_type));
663 known_stride = (packed != 0);
665 for (n = 0; n < as->rank; n++)
667 /* Fill in the stride and bound components of the type. */
669 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
672 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
675 if (expr->expr_type == EXPR_CONSTANT)
677 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
678 gfc_index_integer_kind);
685 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
689 /* Calculate the offset. */
690 mpz_mul (delta, stride, as->lower[n]->value.integer);
691 mpz_sub (offset, offset, delta);
697 if (expr && expr->expr_type == EXPR_CONSTANT)
699 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
700 gfc_index_integer_kind);
707 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
711 /* Calculate the stride. */
712 mpz_sub (delta, as->upper[n]->value.integer,
713 as->lower[n]->value.integer);
714 mpz_add_ui (delta, delta, 1);
715 mpz_mul (stride, stride, delta);
718 /* Only the first stride is known for partial packed arrays. */
725 GFC_TYPE_ARRAY_OFFSET (type) =
726 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
729 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
733 GFC_TYPE_ARRAY_SIZE (type) =
734 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
737 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
739 GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
740 GFC_TYPE_ARRAY_RANK (type) = as->rank;
741 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
743 /* TODO: use main type if it is unbounded. */
744 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
745 build_pointer_type (build_array_type (etype, range));
749 mpz_sub_ui (stride, stride, 1);
750 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
755 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
756 TYPE_DOMAIN (type) = range;
758 build_pointer_type (etype);
759 TREE_TYPE (type) = etype;
767 if (packed < 3 || !known_stride)
769 /* For dummy arrays and automatic (heap allocated) arrays we
770 want a pointer to the array. */
771 type = build_pointer_type (type);
772 GFC_ARRAY_TYPE_P (type) = 1;
773 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
779 /* Build an array (descriptor) type with given bounds. */
782 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
783 tree * ubound, int packed)
785 tree fat_type, fat_pointer_type;
790 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
791 const char *typename;
797 /* Build the type node. */
798 fat_type = make_node (RECORD_TYPE);
799 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
800 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
801 ggc_alloc_cleared (sizeof (struct lang_type));
802 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
803 GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
805 tmp = TYPE_NAME (etype);
806 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
807 tmp = DECL_NAME (tmp);
809 typename = IDENTIFIER_POINTER (tmp);
811 typename = "unknown";
813 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
814 GFC_MAX_SYMBOL_LEN, typename);
815 TYPE_NAME (fat_type) = get_identifier (name);
816 TYPE_PACKED (fat_type) = 0;
818 fat_pointer_type = build_pointer_type (fat_type);
820 /* Build an array descriptor record type. */
822 stride = gfc_index_one_node;
826 for (n = 0; n < dimen; n++)
828 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
835 if (lower != NULL_TREE)
837 if (INTEGER_CST_P (lower))
838 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
844 if (upper != NULL_TREE)
846 if (INTEGER_CST_P (upper))
847 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
852 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
854 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, upper, lower));
855 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp,
856 gfc_index_one_node));
858 fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, stride));
859 /* Check the folding worked. */
860 assert (INTEGER_CST_P (stride));
865 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
866 /* TODO: known offsets for descriptors. */
867 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
869 /* We define data as an unknown size array. Much better than doing
870 pointer arithmetic. */
872 build_array_type (etype,
873 build_range_type (gfc_array_index_type,
874 gfc_index_zero_node, NULL_TREE));
875 arraytype = build_pointer_type (arraytype);
876 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
878 /* The pointer to the array data. */
879 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
881 DECL_CONTEXT (decl) = fat_type;
882 /* Add the data member as the first element of the descriptor. */
885 /* Add the base component. */
886 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
887 gfc_array_index_type);
888 DECL_CONTEXT (decl) = fat_type;
889 fieldlist = chainon (fieldlist, decl);
891 /* Add the dtype component. */
892 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
893 gfc_array_index_type);
894 DECL_CONTEXT (decl) = fat_type;
895 fieldlist = chainon (fieldlist, decl);
897 /* Build the array type for the stride and bound components. */
899 build_array_type (gfc_get_desc_dim_type (),
900 build_range_type (gfc_array_index_type,
902 gfc_rank_cst[dimen - 1]));
904 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
905 DECL_CONTEXT (decl) = fat_type;
906 DECL_INITIAL (decl) = NULL_TREE;
907 fieldlist = chainon (fieldlist, decl);
909 /* Finish off the type. */
910 TYPE_FIELDS (fat_type) = fieldlist;
912 gfc_finish_type (fat_type);
917 /* Build a pointer type. This function is called from gfc_sym_type(). */
920 gfc_build_pointer_type (gfc_symbol * sym, tree type)
922 /* Array pointer types aren't actually pointers. */
923 if (sym->attr.dimension)
926 return build_pointer_type (type);
929 /* Return the type for a symbol. Special handling is required for character
930 types to get the correct level of indirection.
931 For functions return the return type.
932 For subroutines return void_type_node.
933 Calling this multiple times for the same symbol should be avoided,
934 especially for character and array types. */
937 gfc_sym_type (gfc_symbol * sym)
942 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
943 return void_type_node;
945 if (sym->backend_decl)
947 if (sym->attr.function)
948 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
950 return TREE_TYPE (sym->backend_decl);
953 /* The frontend doesn't set all the attributes for a function with an
954 explicit result value, so we use that instead when present. */
955 if (sym->attr.function && sym->result)
958 type = gfc_typenode_for_spec (&sym->ts);
960 if (sym->attr.dummy && !sym->attr.function)
965 if (sym->attr.dimension)
967 if (gfc_is_nodesc_array (sym))
969 /* If this is a character argument of unknown length, just use the
971 if (sym->ts.type != BT_CHARACTER
972 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
973 || sym->ts.cl->backend_decl)
975 type = gfc_get_nodesc_array_type (type, sym->as,
981 type = gfc_build_array_type (type, sym->as);
985 if (sym->attr.allocatable || sym->attr.pointer)
986 type = gfc_build_pointer_type (sym, type);
989 /* We currently pass all parameters by reference.
990 See f95_get_function_decl. For dummy function parameters return the
994 /* We must use pointer types for potentially absent variables. The
995 optimizers assume a reference type argument is never NULL. */
996 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
997 type = build_pointer_type (type);
999 type = build_reference_type (type);
1005 /* Layout and output debug info for a record type. */
1008 gfc_finish_type (tree type)
1012 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1013 TYPE_STUB_DECL (type) = decl;
1015 rest_of_type_compilation (type, 1);
1016 rest_of_decl_compilation (decl, 1, 0);
1019 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1020 or RECORD_TYPE pointed to by STYPE. The new field is chained
1021 to the fieldlist pointed to by FIELDLIST.
1023 Returns a pointer to the new field. */
1026 gfc_add_field_to_struct (tree *fieldlist, tree context,
1027 tree name, tree type)
1031 decl = build_decl (FIELD_DECL, name, type);
1033 DECL_CONTEXT (decl) = context;
1034 DECL_INITIAL (decl) = 0;
1035 DECL_ALIGN (decl) = 0;
1036 DECL_USER_ALIGN (decl) = 0;
1037 TREE_CHAIN (decl) = NULL_TREE;
1038 *fieldlist = chainon (*fieldlist, decl);
1044 /* Build a tree node for a derived type. */
1047 gfc_get_derived_type (gfc_symbol * derived)
1049 tree typenode, field, field_type, fieldlist;
1052 assert (derived && derived->attr.flavor == FL_DERIVED);
1054 /* derived->backend_decl != 0 means we saw it before, but its
1055 components' backend_decl may have not been built. */
1056 if (derived->backend_decl)
1058 /* Its components' backend_decl have been built. */
1059 if (TYPE_FIELDS (derived->backend_decl))
1060 return derived->backend_decl;
1062 typenode = derived->backend_decl;
1066 /* We see this derived type first time, so build the type node. */
1067 typenode = make_node (RECORD_TYPE);
1068 TYPE_NAME (typenode) = get_identifier (derived->name);
1069 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1070 derived->backend_decl = typenode;
1073 /* Build the type member list. Install the newly created RECORD_TYPE
1074 node as DECL_CONTEXT of each FIELD_DECL. */
1075 fieldlist = NULL_TREE;
1076 for (c = derived->components; c; c = c->next)
1078 if (c->ts.type == BT_DERIVED && c->pointer)
1080 if (c->ts.derived->backend_decl)
1081 field_type = c->ts.derived->backend_decl;
1084 /* Build the type node. */
1085 field_type = make_node (RECORD_TYPE);
1086 TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1087 TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1088 c->ts.derived->backend_decl = field_type;
1093 if (c->ts.type == BT_CHARACTER)
1095 /* Evaluate the string length. */
1096 gfc_conv_const_charlen (c->ts.cl);
1097 assert (c->ts.cl->backend_decl);
1100 field_type = gfc_typenode_for_spec (&c->ts);
1103 /* This returns an array descriptor type. Initialisation may be
1109 /* Pointers to arrays aren't actualy pointer types. The
1110 descriptors are seperate, but the data is common. */
1111 field_type = gfc_build_array_type (field_type, c->as);
1114 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1116 else if (c->pointer)
1117 field_type = build_pointer_type (field_type);
1119 field = gfc_add_field_to_struct (&fieldlist, typenode,
1120 get_identifier (c->name),
1123 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1125 assert (!c->backend_decl);
1126 c->backend_decl = field;
1129 /* Now we have the final fieldlist. Record it, then lay out the
1130 derived type, including the fields. */
1131 TYPE_FIELDS (typenode) = fieldlist;
1133 gfc_finish_type (typenode);
1135 derived->backend_decl = typenode;
1141 gfc_return_by_reference (gfc_symbol * sym)
1143 if (!sym->attr.function)
1146 assert (sym->attr.function);
1151 if (sym->attr.dimension)
1154 if (sym->ts.type == BT_CHARACTER)
1157 if (sym->ts.type == BT_DERIVED)
1158 gfc_todo_error ("Returning derived types");
1159 /* Possibly return derived types by reference. */
1164 gfc_get_function_type (gfc_symbol * sym)
1168 gfc_formal_arglist *f;
1171 int alternate_return;
1173 /* Make sure this symbol is a function or a subroutine. */
1174 assert (sym->attr.flavor == FL_PROCEDURE);
1176 if (sym->backend_decl)
1177 return TREE_TYPE (sym->backend_decl);
1180 alternate_return = 0;
1181 typelist = NULL_TREE;
1183 if (sym->attr.entry_master)
1185 /* Additional parameter for selecting an entry point. */
1186 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1189 /* Some functions we use an extra parameter for the return value. */
1190 if (gfc_return_by_reference (sym))
1197 if (arg->ts.type == BT_CHARACTER)
1198 gfc_conv_const_charlen (arg->ts.cl);
1200 type = gfc_sym_type (arg);
1201 if (arg->ts.type == BT_DERIVED
1202 || arg->attr.dimension
1203 || arg->ts.type == BT_CHARACTER)
1204 type = build_reference_type (type);
1206 typelist = gfc_chainon_list (typelist, type);
1207 if (arg->ts.type == BT_CHARACTER)
1208 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1211 /* Build the argument types for the function. */
1212 for (f = sym->formal; f; f = f->next)
1217 /* Evaluate constant character lengths here so that they can be
1218 included in the type. */
1219 if (arg->ts.type == BT_CHARACTER)
1220 gfc_conv_const_charlen (arg->ts.cl);
1222 if (arg->attr.flavor == FL_PROCEDURE)
1224 type = gfc_get_function_type (arg);
1225 type = build_pointer_type (type);
1228 type = gfc_sym_type (arg);
1230 /* Parameter Passing Convention
1232 We currently pass all parameters by reference.
1233 Parameters with INTENT(IN) could be passed by value.
1234 The problem arises if a function is called via an implicit
1235 prototype. In this situation the INTENT is not known.
1236 For this reason all parameters to global functions must be
1237 passed by reference. Passing by value would potentialy
1238 generate bad code. Worse there would be no way of telling that
1239 this code was bad, except that it would give incorrect results.
1241 Contained procedures could pass by value as these are never
1242 used without an explicit interface, and connot be passed as
1243 actual parameters for a dummy procedure. */
1244 if (arg->ts.type == BT_CHARACTER)
1246 typelist = gfc_chainon_list (typelist, type);
1250 if (sym->attr.subroutine)
1251 alternate_return = 1;
1255 /* Add hidden string length parameters. */
1257 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1259 typelist = gfc_chainon_list (typelist, void_type_node);
1261 if (alternate_return)
1262 type = integer_type_node;
1263 else if (!sym->attr.function || gfc_return_by_reference (sym))
1264 type = void_type_node;
1266 type = gfc_sym_type (sym);
1268 type = build_function_type (type, typelist);
1273 /* Routines for getting integer type nodes. */
1276 /* Return an integer type with BITS bits of precision,
1277 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1280 gfc_type_for_size (unsigned bits, int unsignedp)
1282 if (bits == TYPE_PRECISION (integer_type_node))
1283 return unsignedp ? unsigned_type_node : integer_type_node;
1285 if (bits == TYPE_PRECISION (signed_char_type_node))
1286 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1288 if (bits == TYPE_PRECISION (short_integer_type_node))
1289 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1291 if (bits == TYPE_PRECISION (long_integer_type_node))
1292 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1294 if (bits == TYPE_PRECISION (long_long_integer_type_node))
1295 return (unsignedp ? long_long_unsigned_type_node
1296 : long_long_integer_type_node);
1297 /*TODO: We currently don't initialise this...
1298 if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1299 return (unsignedp ? widest_unsigned_literal_type_node
1300 : widest_integer_literal_type_node);*/
1302 if (bits <= TYPE_PRECISION (intQI_type_node))
1303 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1305 if (bits <= TYPE_PRECISION (intHI_type_node))
1306 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1308 if (bits <= TYPE_PRECISION (intSI_type_node))
1309 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1311 if (bits <= TYPE_PRECISION (intDI_type_node))
1312 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1317 /* Return a data type that has machine mode MODE.
1318 If the mode is an integer,
1319 then UNSIGNEDP selects between signed and unsigned types. */
1322 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1324 if (mode == TYPE_MODE (integer_type_node))
1325 return unsignedp ? unsigned_type_node : integer_type_node;
1327 if (mode == TYPE_MODE (signed_char_type_node))
1328 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1330 if (mode == TYPE_MODE (short_integer_type_node))
1331 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1333 if (mode == TYPE_MODE (long_integer_type_node))
1334 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1336 if (mode == TYPE_MODE (long_long_integer_type_node))
1337 return unsignedp ? long_long_unsigned_type_node :
1338 long_long_integer_type_node;
1341 if (mode == TYPE_MODE (widest_integer_literal_type_node))
1342 return unsignedp ? widest_unsigned_literal_type_node
1343 : widest_integer_literal_type_node;
1347 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1350 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1353 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1356 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1358 #if HOST_BITS_PER_WIDE_INT >= 64
1359 if (mode == TYPE_MODE (intTI_type_node))
1360 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1363 if (mode == TYPE_MODE (float_type_node))
1364 return float_type_node;
1366 if (mode == TYPE_MODE (double_type_node))
1367 return double_type_node;
1369 if (mode == TYPE_MODE (long_double_type_node))
1370 return long_double_type_node;
1372 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1373 return build_pointer_type (char_type_node);
1375 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1376 return build_pointer_type (integer_type_node);
1378 if (VECTOR_MODE_P (mode))
1380 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1381 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1382 if (inner_type != NULL_TREE)
1383 return build_vector_type_for_mode (inner_type, mode);
1389 /* Return an unsigned type the same as TYPE in other respects. */
1392 gfc_unsigned_type (tree type)
1394 tree type1 = TYPE_MAIN_VARIANT (type);
1396 if (type1 == signed_char_type_node || type1 == char_type_node)
1397 return unsigned_char_type_node;
1398 if (type1 == integer_type_node)
1399 return unsigned_type_node;
1400 if (type1 == short_integer_type_node)
1401 return short_unsigned_type_node;
1402 if (type1 == long_integer_type_node)
1403 return long_unsigned_type_node;
1404 if (type1 == long_long_integer_type_node)
1405 return long_long_unsigned_type_node;
1407 if (type1 == widest_integer_literal_type_node)
1408 return widest_unsigned_literal_type_node;
1410 #if HOST_BITS_PER_WIDE_INT >= 64
1411 if (type1 == intTI_type_node)
1412 return unsigned_intTI_type_node;
1414 if (type1 == intDI_type_node)
1415 return unsigned_intDI_type_node;
1416 if (type1 == intSI_type_node)
1417 return unsigned_intSI_type_node;
1418 if (type1 == intHI_type_node)
1419 return unsigned_intHI_type_node;
1420 if (type1 == intQI_type_node)
1421 return unsigned_intQI_type_node;
1423 return gfc_signed_or_unsigned_type (1, type);
1426 /* Return a signed type the same as TYPE in other respects. */
1429 gfc_signed_type (tree type)
1431 tree type1 = TYPE_MAIN_VARIANT (type);
1433 if (type1 == unsigned_char_type_node || type1 == char_type_node)
1434 return signed_char_type_node;
1435 if (type1 == unsigned_type_node)
1436 return integer_type_node;
1437 if (type1 == short_unsigned_type_node)
1438 return short_integer_type_node;
1439 if (type1 == long_unsigned_type_node)
1440 return long_integer_type_node;
1441 if (type1 == long_long_unsigned_type_node)
1442 return long_long_integer_type_node;
1444 if (type1 == widest_unsigned_literal_type_node)
1445 return widest_integer_literal_type_node;
1447 #if HOST_BITS_PER_WIDE_INT >= 64
1448 if (type1 == unsigned_intTI_type_node)
1449 return intTI_type_node;
1451 if (type1 == unsigned_intDI_type_node)
1452 return intDI_type_node;
1453 if (type1 == unsigned_intSI_type_node)
1454 return intSI_type_node;
1455 if (type1 == unsigned_intHI_type_node)
1456 return intHI_type_node;
1457 if (type1 == unsigned_intQI_type_node)
1458 return intQI_type_node;
1460 return gfc_signed_or_unsigned_type (0, type);
1463 /* Return a type the same as TYPE except unsigned or
1464 signed according to UNSIGNEDP. */
1467 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1469 if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1472 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1473 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1474 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1475 return unsignedp ? unsigned_type_node : integer_type_node;
1476 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1477 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1478 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1479 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1480 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1481 return (unsignedp ? long_long_unsigned_type_node
1482 : long_long_integer_type_node);
1484 if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1485 return (unsignedp ? widest_unsigned_literal_type_node
1486 : widest_integer_literal_type_node);
1488 #if HOST_BITS_PER_WIDE_INT >= 64
1489 if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1490 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1492 if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1493 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1494 if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1495 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1496 if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1497 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1498 if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1499 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1504 #include "gt-fortran-trans-types.h"