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 /* Get a type node for a character kind. */
273 gfc_get_character_type (int kind, gfc_charlen * cl)
283 base = gfc_character1_type_node;
287 fatal_error ("character kind=%d not available", kind);
290 len = (cl == 0) ? NULL_TREE : cl->backend_decl;
292 bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
293 type = build_array_type (base, bounds);
294 TYPE_STRING_FLAG (type) = 1;
299 /* Covert a basic type. This will be an array for character types. */
302 gfc_typenode_for_spec (gfc_typespec * spec)
313 basetype = gfc_get_int_type (spec->kind);
317 basetype = gfc_get_real_type (spec->kind);
321 basetype = gfc_get_complex_type (spec->kind);
325 basetype = gfc_get_logical_type (spec->kind);
329 basetype = gfc_get_character_type (spec->kind, spec->cl);
333 basetype = gfc_get_derived_type (spec->derived);
343 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
346 gfc_conv_array_bound (gfc_expr * expr)
348 /* If expr is an integer constant, return that. */
349 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
350 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
352 /* Otherwise return NULL. */
357 gfc_get_element_type (tree type)
361 if (GFC_ARRAY_TYPE_P (type))
363 if (TREE_CODE (type) == POINTER_TYPE)
364 type = TREE_TYPE (type);
365 assert (TREE_CODE (type) == ARRAY_TYPE);
366 element = TREE_TYPE (type);
370 assert (GFC_DESCRIPTOR_TYPE_P (type));
371 element = TREE_TYPE (TYPE_FIELDS (type));
373 assert (TREE_CODE (element) == POINTER_TYPE);
374 element = TREE_TYPE (element);
376 assert (TREE_CODE (element) == ARRAY_TYPE);
377 element = TREE_TYPE (element);
383 /* Build an array. This function is called from gfc_sym_type().
384 Actually returns array descriptor type.
386 Format of array descriptors is as follows:
388 struct gfc_array_descriptor
393 struct descriptor_dimension dimension[N_DIM];
396 struct descriptor_dimension
403 Translation code should use gfc_conv_descriptor_* rather than accessing
404 the descriptor directly. Any changes to the array descriptor type will
405 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
407 This is represented internally as a RECORD_TYPE. The index nodes are
408 gfc_array_index_type and the data node is a pointer to the data. See below
409 for the handling of character types.
411 The dtype member is formatted as follows:
412 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
413 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
414 size = dtype >> GFC_DTYPE_SIZE_SHIFT
416 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
417 generated poor code for assumed/deferred size arrays. These require
418 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
419 grammar. Also, there is no way to explicitly set the array stride, so
420 all data must be packed(1). I've tried to mark all the functions which
421 would require modification with a GCC ARRAYS comment.
423 The data component points to the first element in the array.
424 The offset field is the position of the origin of the array
425 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
427 An element is accessed by
428 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
429 This gives good performance as the computation does not involve the
430 bounds of the array. For packed arrays, this is optimized further by
431 substituting the known strides.
433 This system has one problem: all array bounds must be withing 2^31 elements
434 of the origin (2^63 on 64-bit machines). For example
435 integer, dimension (80000:90000, 80000:90000, 2) :: array
436 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
437 the calculation for stride02 would overflow. This may still work, but
438 I haven't checked, and it relies on the overflow doing the right thing.
440 The way to fix this problem is to access alements as follows:
441 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
442 Obviously this is much slower. I will make this a compile time option,
443 something like -fsmall-array-offsets. Mixing code compiled with and without
444 this switch will work.
446 (1) This can be worked around by modifying the upper bound of the previous
447 dimension. This requires extra fields in the descriptor (both real_ubound
448 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
449 may allow us to do this. However I can't find mention of this anywhere
453 /* Returns true if the array sym does not require a descriptor. */
456 gfc_is_nodesc_array (gfc_symbol * sym)
458 assert (sym->attr.dimension);
460 /* We only want local arrays. */
461 if (sym->attr.pointer || sym->attr.allocatable)
466 if (sym->as->type != AS_ASSUMED_SHAPE)
472 if (sym->attr.result || sym->attr.function)
475 if (sym->attr.pointer || sym->attr.allocatable)
478 assert (sym->as->type == AS_EXPLICIT);
484 gfc_build_array_type (tree type, gfc_array_spec * as)
486 tree lbound[GFC_MAX_DIMENSIONS];
487 tree ubound[GFC_MAX_DIMENSIONS];
490 for (n = 0; n < as->rank; n++)
492 /* Create expressions for the known bounds of the array. */
493 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
494 lbound[n] = gfc_index_one_node;
496 lbound[n] = gfc_conv_array_bound (as->lower[n]);
497 ubound[n] = gfc_conv_array_bound (as->upper[n]);
500 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
503 /* Returns the struct descriptor_dimension type. */
506 gfc_get_desc_dim_type (void)
512 if (gfc_desc_dim_type)
513 return gfc_desc_dim_type;
515 /* Build the type node. */
516 type = make_node (RECORD_TYPE);
518 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
519 TYPE_PACKED (type) = 1;
521 /* Consists of the stride, lbound and ubound members. */
522 decl = build_decl (FIELD_DECL,
523 get_identifier ("stride"), gfc_array_index_type);
524 DECL_CONTEXT (decl) = type;
527 decl = build_decl (FIELD_DECL,
528 get_identifier ("lbound"), gfc_array_index_type);
529 DECL_CONTEXT (decl) = type;
530 fieldlist = chainon (fieldlist, decl);
532 decl = build_decl (FIELD_DECL,
533 get_identifier ("ubound"), gfc_array_index_type);
534 DECL_CONTEXT (decl) = type;
535 fieldlist = chainon (fieldlist, decl);
537 /* Finish off the type. */
538 TYPE_FIELDS (type) = fieldlist;
540 gfc_finish_type (type);
542 gfc_desc_dim_type = type;
547 gfc_get_dtype (tree type, int rank)
555 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
556 return (GFC_TYPE_ARRAY_DTYPE (type));
558 /* TODO: Correctly identify LOGICAL types. */
559 switch (TREE_CODE (type))
562 n = GFC_DTYPE_INTEGER;
566 n = GFC_DTYPE_LOGICAL;
574 n = GFC_DTYPE_COMPLEX;
577 /* Arrays have already been dealt with. */
579 n = GFC_DTYPE_DERIVED;
583 n = GFC_DTYPE_CHARACTER;
590 assert (rank <= GFC_DTYPE_RANK_MASK);
591 size = TYPE_SIZE_UNIT (type);
593 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
594 if (size && INTEGER_CST_P (size))
596 if (tree_int_cst_lt (gfc_max_array_element_size, size))
597 internal_error ("Array element size too big");
599 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
601 dtype = build_int_cst (gfc_array_index_type, i);
603 if (size && !INTEGER_CST_P (size))
605 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
606 tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
607 dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
609 /* If we don't know the size we leave it as zero. This should never happen
610 for anything that is actually used. */
611 /* TODO: Check this is actually true, particularly when repacking
612 assumed size parameters. */
618 /* Build an array type for use without a descriptor. Valid values of packed
619 are 0=no, 1=partial, 2=full, 3=static. */
622 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
635 mpz_init_set_ui (offset, 0);
636 mpz_init_set_ui (stride, 1);
639 /* We don't use build_array_type because this does not include include
640 lang-specific information (ie. the bounds of the array) when checking
642 type = make_node (ARRAY_TYPE);
644 GFC_ARRAY_TYPE_P (type) = 1;
645 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
646 ggc_alloc_cleared (sizeof (struct lang_type));
648 known_stride = (packed != 0);
650 for (n = 0; n < as->rank; n++)
652 /* Fill in the stride and bound components of the type. */
654 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
657 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
660 if (expr->expr_type == EXPR_CONSTANT)
662 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
663 gfc_index_integer_kind);
670 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
674 /* Calculate the offset. */
675 mpz_mul (delta, stride, as->lower[n]->value.integer);
676 mpz_sub (offset, offset, delta);
682 if (expr && expr->expr_type == EXPR_CONSTANT)
684 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
685 gfc_index_integer_kind);
692 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
696 /* Calculate the stride. */
697 mpz_sub (delta, as->upper[n]->value.integer,
698 as->lower[n]->value.integer);
699 mpz_add_ui (delta, delta, 1);
700 mpz_mul (stride, stride, delta);
703 /* Only the first stride is known for partial packed arrays. */
710 GFC_TYPE_ARRAY_OFFSET (type) =
711 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
714 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
718 GFC_TYPE_ARRAY_SIZE (type) =
719 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
722 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
724 GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
725 GFC_TYPE_ARRAY_RANK (type) = as->rank;
726 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
728 /* TODO: use main type if it is unbounded. */
729 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
730 build_pointer_type (build_array_type (etype, range));
734 mpz_sub_ui (stride, stride, 1);
735 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
740 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
741 TYPE_DOMAIN (type) = range;
743 build_pointer_type (etype);
744 TREE_TYPE (type) = etype;
752 if (packed < 3 || !known_stride)
754 /* For dummy arrays and automatic (heap allocated) arrays we
755 want a pointer to the array. */
756 type = build_pointer_type (type);
757 GFC_ARRAY_TYPE_P (type) = 1;
758 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
764 /* Build an array (descriptor) type with given bounds. */
767 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
768 tree * ubound, int packed)
770 tree fat_type, fat_pointer_type;
775 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
776 const char *typename;
782 /* Build the type node. */
783 fat_type = make_node (RECORD_TYPE);
784 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
785 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
786 ggc_alloc_cleared (sizeof (struct lang_type));
787 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
788 GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
790 tmp = TYPE_NAME (etype);
791 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
792 tmp = DECL_NAME (tmp);
794 typename = IDENTIFIER_POINTER (tmp);
796 typename = "unknown";
798 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
799 GFC_MAX_SYMBOL_LEN, typename);
800 TYPE_NAME (fat_type) = get_identifier (name);
801 TYPE_PACKED (fat_type) = 0;
803 fat_pointer_type = build_pointer_type (fat_type);
805 /* Build an array descriptor record type. */
807 stride = gfc_index_one_node;
811 for (n = 0; n < dimen; n++)
813 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
820 if (lower != NULL_TREE)
822 if (INTEGER_CST_P (lower))
823 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
829 if (upper != NULL_TREE)
831 if (INTEGER_CST_P (upper))
832 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
837 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
839 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, upper, lower));
840 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp,
841 gfc_index_one_node));
843 fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, stride));
844 /* Check the folding worked. */
845 assert (INTEGER_CST_P (stride));
850 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
851 /* TODO: known offsets for descriptors. */
852 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
854 /* We define data as an unknown size array. Much better than doing
855 pointer arithmetic. */
857 build_array_type (etype,
858 build_range_type (gfc_array_index_type,
859 gfc_index_zero_node, NULL_TREE));
860 arraytype = build_pointer_type (arraytype);
861 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
863 /* The pointer to the array data. */
864 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
866 DECL_CONTEXT (decl) = fat_type;
867 /* Add the data member as the first element of the descriptor. */
870 /* Add the base component. */
871 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
872 gfc_array_index_type);
873 DECL_CONTEXT (decl) = fat_type;
874 fieldlist = chainon (fieldlist, decl);
876 /* Add the dtype component. */
877 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
878 gfc_array_index_type);
879 DECL_CONTEXT (decl) = fat_type;
880 fieldlist = chainon (fieldlist, decl);
882 /* Build the array type for the stride and bound components. */
884 build_array_type (gfc_get_desc_dim_type (),
885 build_range_type (gfc_array_index_type,
887 gfc_rank_cst[dimen - 1]));
889 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
890 DECL_CONTEXT (decl) = fat_type;
891 DECL_INITIAL (decl) = NULL_TREE;
892 fieldlist = chainon (fieldlist, decl);
894 /* Finish off the type. */
895 TYPE_FIELDS (fat_type) = fieldlist;
897 gfc_finish_type (fat_type);
902 /* Build a pointer type. This function is called from gfc_sym_type(). */
905 gfc_build_pointer_type (gfc_symbol * sym, tree type)
907 /* Array pointer types aren't actually pointers. */
908 if (sym->attr.dimension)
911 return build_pointer_type (type);
914 /* Return the type for a symbol. Special handling is required for character
915 types to get the correct level of indirection.
916 For functions return the return type.
917 For subroutines return void_type_node.
918 Calling this multiple times for the same symbol should be avoided,
919 especially for character and array types. */
922 gfc_sym_type (gfc_symbol * sym)
927 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
928 return void_type_node;
930 if (sym->backend_decl)
932 if (sym->attr.function)
933 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
935 return TREE_TYPE (sym->backend_decl);
938 /* The frontend doesn't set all the attributes for a function with an
939 explicit result value, so we use that instead when present. */
940 if (sym->attr.function && sym->result)
943 type = gfc_typenode_for_spec (&sym->ts);
945 if (sym->attr.dummy && !sym->attr.function)
950 if (sym->attr.dimension)
952 if (gfc_is_nodesc_array (sym))
954 /* If this is a character argument of unknown length, just use the
956 if (sym->ts.type != BT_CHARACTER
957 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
958 || sym->ts.cl->backend_decl)
960 type = gfc_get_nodesc_array_type (type, sym->as,
966 type = gfc_build_array_type (type, sym->as);
970 if (sym->attr.allocatable || sym->attr.pointer)
971 type = gfc_build_pointer_type (sym, type);
974 /* We currently pass all parameters by reference.
975 See f95_get_function_decl. For dummy function parameters return the
979 /* We must use pointer types for potentially absent variables. The
980 optimizers assume a reference type argument is never NULL. */
981 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
982 type = build_pointer_type (type);
984 type = build_reference_type (type);
990 /* Layout and output debug info for a record type. */
993 gfc_finish_type (tree type)
997 decl = build_decl (TYPE_DECL, NULL_TREE, type);
998 TYPE_STUB_DECL (type) = decl;
1000 rest_of_type_compilation (type, 1);
1001 rest_of_decl_compilation (decl, 1, 0);
1004 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1005 or RECORD_TYPE pointed to by STYPE. The new field is chained
1006 to the fieldlist pointed to by FIELDLIST.
1008 Returns a pointer to the new field. */
1011 gfc_add_field_to_struct (tree *fieldlist, tree context,
1012 tree name, tree type)
1016 decl = build_decl (FIELD_DECL, name, type);
1018 DECL_CONTEXT (decl) = context;
1019 DECL_INITIAL (decl) = 0;
1020 DECL_ALIGN (decl) = 0;
1021 DECL_USER_ALIGN (decl) = 0;
1022 TREE_CHAIN (decl) = NULL_TREE;
1023 *fieldlist = chainon (*fieldlist, decl);
1029 /* Build a tree node for a derived type. */
1032 gfc_get_derived_type (gfc_symbol * derived)
1034 tree typenode, field, field_type, fieldlist;
1037 assert (derived && derived->attr.flavor == FL_DERIVED);
1039 /* derived->backend_decl != 0 means we saw it before, but its
1040 components' backend_decl may have not been built. */
1041 if (derived->backend_decl)
1043 /* Its components' backend_decl have been built. */
1044 if (TYPE_FIELDS (derived->backend_decl))
1045 return derived->backend_decl;
1047 typenode = derived->backend_decl;
1051 /* We see this derived type first time, so build the type node. */
1052 typenode = make_node (RECORD_TYPE);
1053 TYPE_NAME (typenode) = get_identifier (derived->name);
1054 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1055 derived->backend_decl = typenode;
1058 /* Build the type member list. Install the newly created RECORD_TYPE
1059 node as DECL_CONTEXT of each FIELD_DECL. */
1060 fieldlist = NULL_TREE;
1061 for (c = derived->components; c; c = c->next)
1063 if (c->ts.type == BT_DERIVED && c->pointer)
1065 if (c->ts.derived->backend_decl)
1066 field_type = c->ts.derived->backend_decl;
1069 /* Build the type node. */
1070 field_type = make_node (RECORD_TYPE);
1071 TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1072 TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1073 c->ts.derived->backend_decl = field_type;
1078 if (c->ts.type == BT_CHARACTER)
1080 /* Evaluate the string length. */
1081 gfc_conv_const_charlen (c->ts.cl);
1082 assert (c->ts.cl->backend_decl);
1085 field_type = gfc_typenode_for_spec (&c->ts);
1088 /* This returns an array descriptor type. Initialisation may be
1094 /* Pointers to arrays aren't actualy pointer types. The
1095 descriptors are seperate, but the data is common. */
1096 field_type = gfc_build_array_type (field_type, c->as);
1099 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1101 else if (c->pointer)
1102 field_type = build_pointer_type (field_type);
1104 field = gfc_add_field_to_struct (&fieldlist, typenode,
1105 get_identifier (c->name),
1108 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1110 assert (!c->backend_decl);
1111 c->backend_decl = field;
1114 /* Now we have the final fieldlist. Record it, then lay out the
1115 derived type, including the fields. */
1116 TYPE_FIELDS (typenode) = fieldlist;
1118 gfc_finish_type (typenode);
1120 derived->backend_decl = typenode;
1126 gfc_return_by_reference (gfc_symbol * sym)
1128 if (!sym->attr.function)
1131 assert (sym->attr.function);
1136 if (sym->attr.dimension)
1139 if (sym->ts.type == BT_CHARACTER)
1142 if (sym->ts.type == BT_DERIVED)
1143 gfc_todo_error ("Returning derived types");
1144 /* Possibly return derived types by reference. */
1149 gfc_get_function_type (gfc_symbol * sym)
1153 gfc_formal_arglist *f;
1156 int alternate_return;
1158 /* Make sure this symbol is a function or a subroutine. */
1159 assert (sym->attr.flavor == FL_PROCEDURE);
1161 if (sym->backend_decl)
1162 return TREE_TYPE (sym->backend_decl);
1165 alternate_return = 0;
1166 typelist = NULL_TREE;
1168 if (sym->attr.entry_master)
1170 /* Additional parameter for selecting an entry point. */
1171 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1174 /* Some functions we use an extra parameter for the return value. */
1175 if (gfc_return_by_reference (sym))
1182 if (arg->ts.type == BT_CHARACTER)
1183 gfc_conv_const_charlen (arg->ts.cl);
1185 type = gfc_sym_type (arg);
1186 if (arg->ts.type == BT_DERIVED
1187 || arg->attr.dimension
1188 || arg->ts.type == BT_CHARACTER)
1189 type = build_reference_type (type);
1191 typelist = gfc_chainon_list (typelist, type);
1192 if (arg->ts.type == BT_CHARACTER)
1193 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1196 /* Build the argument types for the function. */
1197 for (f = sym->formal; f; f = f->next)
1202 /* Evaluate constant character lengths here so that they can be
1203 included in the type. */
1204 if (arg->ts.type == BT_CHARACTER)
1205 gfc_conv_const_charlen (arg->ts.cl);
1207 if (arg->attr.flavor == FL_PROCEDURE)
1209 type = gfc_get_function_type (arg);
1210 type = build_pointer_type (type);
1213 type = gfc_sym_type (arg);
1215 /* Parameter Passing Convention
1217 We currently pass all parameters by reference.
1218 Parameters with INTENT(IN) could be passed by value.
1219 The problem arises if a function is called via an implicit
1220 prototype. In this situation the INTENT is not known.
1221 For this reason all parameters to global functions must be
1222 passed by reference. Passing by value would potentialy
1223 generate bad code. Worse there would be no way of telling that
1224 this code was bad, except that it would give incorrect results.
1226 Contained procedures could pass by value as these are never
1227 used without an explicit interface, and connot be passed as
1228 actual parameters for a dummy procedure. */
1229 if (arg->ts.type == BT_CHARACTER)
1231 typelist = gfc_chainon_list (typelist, type);
1235 if (sym->attr.subroutine)
1236 alternate_return = 1;
1240 /* Add hidden string length parameters. */
1242 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1244 typelist = gfc_chainon_list (typelist, void_type_node);
1246 if (alternate_return)
1247 type = integer_type_node;
1248 else if (!sym->attr.function || gfc_return_by_reference (sym))
1249 type = void_type_node;
1251 type = gfc_sym_type (sym);
1253 type = build_function_type (type, typelist);
1258 /* Routines for getting integer type nodes. */
1261 /* Return an integer type with BITS bits of precision,
1262 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1265 gfc_type_for_size (unsigned bits, int unsignedp)
1267 if (bits == TYPE_PRECISION (integer_type_node))
1268 return unsignedp ? unsigned_type_node : integer_type_node;
1270 if (bits == TYPE_PRECISION (signed_char_type_node))
1271 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1273 if (bits == TYPE_PRECISION (short_integer_type_node))
1274 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1276 if (bits == TYPE_PRECISION (long_integer_type_node))
1277 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1279 if (bits == TYPE_PRECISION (long_long_integer_type_node))
1280 return (unsignedp ? long_long_unsigned_type_node
1281 : long_long_integer_type_node);
1282 /*TODO: We currently don't initialise this...
1283 if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1284 return (unsignedp ? widest_unsigned_literal_type_node
1285 : widest_integer_literal_type_node);*/
1287 if (bits <= TYPE_PRECISION (intQI_type_node))
1288 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1290 if (bits <= TYPE_PRECISION (intHI_type_node))
1291 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1293 if (bits <= TYPE_PRECISION (intSI_type_node))
1294 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1296 if (bits <= TYPE_PRECISION (intDI_type_node))
1297 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1302 /* Return a data type that has machine mode MODE.
1303 If the mode is an integer,
1304 then UNSIGNEDP selects between signed and unsigned types. */
1307 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1309 if (mode == TYPE_MODE (integer_type_node))
1310 return unsignedp ? unsigned_type_node : integer_type_node;
1312 if (mode == TYPE_MODE (signed_char_type_node))
1313 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1315 if (mode == TYPE_MODE (short_integer_type_node))
1316 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1318 if (mode == TYPE_MODE (long_integer_type_node))
1319 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1321 if (mode == TYPE_MODE (long_long_integer_type_node))
1322 return unsignedp ? long_long_unsigned_type_node :
1323 long_long_integer_type_node;
1326 if (mode == TYPE_MODE (widest_integer_literal_type_node))
1327 return unsignedp ? widest_unsigned_literal_type_node
1328 : widest_integer_literal_type_node;
1332 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1335 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1338 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1341 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1343 #if HOST_BITS_PER_WIDE_INT >= 64
1344 if (mode == TYPE_MODE (intTI_type_node))
1345 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1348 if (mode == TYPE_MODE (float_type_node))
1349 return float_type_node;
1351 if (mode == TYPE_MODE (double_type_node))
1352 return double_type_node;
1354 if (mode == TYPE_MODE (long_double_type_node))
1355 return long_double_type_node;
1357 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1358 return build_pointer_type (char_type_node);
1360 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1361 return build_pointer_type (integer_type_node);
1363 if (VECTOR_MODE_P (mode))
1365 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1366 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1367 if (inner_type != NULL_TREE)
1368 return build_vector_type_for_mode (inner_type, mode);
1374 /* Return an unsigned type the same as TYPE in other respects. */
1377 gfc_unsigned_type (tree type)
1379 tree type1 = TYPE_MAIN_VARIANT (type);
1381 if (type1 == signed_char_type_node || type1 == char_type_node)
1382 return unsigned_char_type_node;
1383 if (type1 == integer_type_node)
1384 return unsigned_type_node;
1385 if (type1 == short_integer_type_node)
1386 return short_unsigned_type_node;
1387 if (type1 == long_integer_type_node)
1388 return long_unsigned_type_node;
1389 if (type1 == long_long_integer_type_node)
1390 return long_long_unsigned_type_node;
1392 if (type1 == widest_integer_literal_type_node)
1393 return widest_unsigned_literal_type_node;
1395 #if HOST_BITS_PER_WIDE_INT >= 64
1396 if (type1 == intTI_type_node)
1397 return unsigned_intTI_type_node;
1399 if (type1 == intDI_type_node)
1400 return unsigned_intDI_type_node;
1401 if (type1 == intSI_type_node)
1402 return unsigned_intSI_type_node;
1403 if (type1 == intHI_type_node)
1404 return unsigned_intHI_type_node;
1405 if (type1 == intQI_type_node)
1406 return unsigned_intQI_type_node;
1408 return gfc_signed_or_unsigned_type (1, type);
1411 /* Return a signed type the same as TYPE in other respects. */
1414 gfc_signed_type (tree type)
1416 tree type1 = TYPE_MAIN_VARIANT (type);
1418 if (type1 == unsigned_char_type_node || type1 == char_type_node)
1419 return signed_char_type_node;
1420 if (type1 == unsigned_type_node)
1421 return integer_type_node;
1422 if (type1 == short_unsigned_type_node)
1423 return short_integer_type_node;
1424 if (type1 == long_unsigned_type_node)
1425 return long_integer_type_node;
1426 if (type1 == long_long_unsigned_type_node)
1427 return long_long_integer_type_node;
1429 if (type1 == widest_unsigned_literal_type_node)
1430 return widest_integer_literal_type_node;
1432 #if HOST_BITS_PER_WIDE_INT >= 64
1433 if (type1 == unsigned_intTI_type_node)
1434 return intTI_type_node;
1436 if (type1 == unsigned_intDI_type_node)
1437 return intDI_type_node;
1438 if (type1 == unsigned_intSI_type_node)
1439 return intSI_type_node;
1440 if (type1 == unsigned_intHI_type_node)
1441 return intHI_type_node;
1442 if (type1 == unsigned_intQI_type_node)
1443 return intQI_type_node;
1445 return gfc_signed_or_unsigned_type (0, type);
1448 /* Return a type the same as TYPE except unsigned or
1449 signed according to UNSIGNEDP. */
1452 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1454 if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1457 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1458 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1459 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1460 return unsignedp ? unsigned_type_node : integer_type_node;
1461 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1462 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1463 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1464 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1465 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1466 return (unsignedp ? long_long_unsigned_type_node
1467 : long_long_integer_type_node);
1469 if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1470 return (unsignedp ? widest_unsigned_literal_type_node
1471 : widest_integer_literal_type_node);
1473 #if HOST_BITS_PER_WIDE_INT >= 64
1474 if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1475 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1477 if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1478 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1479 if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1480 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1481 if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1482 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1483 if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1484 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1489 #include "gt-fortran-trans-types.h"