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 = build_int_2 (lo, hi);
172 TREE_TYPE (gfc_max_array_element_size) = long_unsigned_type_node;
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_2 (1, 0);
178 TREE_TYPE (boolean_true_node) = boolean_type_node;
179 boolean_false_node = build_int_2 (0, 0);
180 TREE_TYPE (boolean_false_node) = boolean_type_node;
183 /* Get a type node for an integer kind */
186 gfc_get_int_type (int kind)
191 return (gfc_int1_type_node);
193 return (gfc_int2_type_node);
195 return (gfc_int4_type_node);
197 return (gfc_int8_type_node);
198 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
200 return (95 _int16_type_node);
203 fatal_error ("integer kind=%d not available", kind);
207 /* Get a type node for a real kind */
210 gfc_get_real_type (int kind)
215 return (gfc_real4_type_node);
217 return (gfc_real8_type_node);
218 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
220 return (gfc_real16_type_node);
223 fatal_error ("real kind=%d not available", kind);
227 /* Get a type node for a complex kind */
230 gfc_get_complex_type (int kind)
235 return (gfc_complex4_type_node);
237 return (gfc_complex8_type_node);
238 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
240 return (gfc_complex16_type_node);
243 fatal_error ("complex kind=%d not available", kind);
247 /* Get a type node for a logical kind */
250 gfc_get_logical_type (int kind)
255 return (gfc_logical1_type_node);
257 return (gfc_logical2_type_node);
259 return (gfc_logical4_type_node);
261 return (gfc_logical8_type_node);
262 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
264 return (gfc_logical16_type_node);
267 fatal_error ("logical kind=%d not available", kind);
271 /* Get a type node for a character kind. */
274 gfc_get_character_type (int kind, gfc_charlen * cl)
284 base = gfc_character1_type_node;
288 fatal_error ("character kind=%d not available", kind);
291 len = (cl == 0) ? NULL_TREE : cl->backend_decl;
293 bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
294 type = build_array_type (base, bounds);
295 TYPE_STRING_FLAG (type) = 1;
300 /* Covert a basic type. This will be an array for character types. */
303 gfc_typenode_for_spec (gfc_typespec * spec)
314 basetype = gfc_get_int_type (spec->kind);
318 basetype = gfc_get_real_type (spec->kind);
322 basetype = gfc_get_complex_type (spec->kind);
326 basetype = gfc_get_logical_type (spec->kind);
330 basetype = gfc_get_character_type (spec->kind, spec->cl);
334 basetype = gfc_get_derived_type (spec->derived);
344 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
347 gfc_conv_array_bound (gfc_expr * expr)
349 /* If expr is an integer constant, return that. */
350 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
351 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
353 /* Otherwise return NULL. */
358 gfc_get_element_type (tree type)
362 if (GFC_ARRAY_TYPE_P (type))
364 if (TREE_CODE (type) == POINTER_TYPE)
365 type = TREE_TYPE (type);
366 assert (TREE_CODE (type) == ARRAY_TYPE);
367 element = TREE_TYPE (type);
371 assert (GFC_DESCRIPTOR_TYPE_P (type));
372 element = TREE_TYPE (TYPE_FIELDS (type));
374 assert (TREE_CODE (element) == POINTER_TYPE);
375 element = TREE_TYPE (element);
377 assert (TREE_CODE (element) == ARRAY_TYPE);
378 element = TREE_TYPE (element);
384 /* Build an array. This function is called from gfc_sym_type().
385 Actually returns array descriptor type.
387 Format of array descriptors is as follows:
389 struct gfc_array_descriptor
394 struct descriptor_dimension dimension[N_DIM];
397 struct descriptor_dimension
404 Translation code should use gfc_conv_descriptor_* rather than accessing
405 the descriptor directly. Any changes to the array descriptor type will
406 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
408 This is represented internally as a RECORD_TYPE. The index nodes are
409 gfc_array_index_type and the data node is a pointer to the data. See below
410 for the handling of character types.
412 The dtype member is formatted as follows:
413 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
414 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
415 size = dtype >> GFC_DTYPE_SIZE_SHIFT
417 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
418 generated poor code for assumed/deferred size arrays. These require
419 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
420 grammar. Also, there is no way to explicitly set the array stride, so
421 all data must be packed(1). I've tried to mark all the functions which
422 would require modification with a GCC ARRAYS comment.
424 The data component points to the first element in the array.
425 The offset field is the position of the origin of the array
426 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
428 An element is accessed by
429 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
430 This gives good performance as the computation does not involve the
431 bounds of the array. For packed arrays, this is optimized further by
432 substituting the known strides.
434 This system has one problem: all array bounds must be withing 2^31 elements
435 of the origin (2^63 on 64-bit machines). For example
436 integer, dimension (80000:90000, 80000:90000, 2) :: array
437 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
438 the calculation for stride02 would overflow. This may still work, but
439 I haven't checked, and it relies on the overflow doing the right thing.
441 The way to fix this problem is to access alements as follows:
442 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
443 Obviously this is much slower. I will make this a compile time option,
444 something like -fsmall-array-offsets. Mixing code compiled with and without
445 this switch will work.
447 (1) This can be worked around by modifying the upper bound of the previous
448 dimension. This requires extra fields in the descriptor (both real_ubound
449 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
450 may allow us to do this. However I can't find mention of this anywhere
455 /* Returns true if the array sym does not require a descriptor. */
458 gfc_is_nodesc_array (gfc_symbol * sym)
460 assert (sym->attr.dimension);
462 /* We only want local arrays. */
463 if (sym->attr.pointer || sym->attr.allocatable)
468 if (sym->as->type != AS_ASSUMED_SHAPE)
474 if (sym->attr.result || sym->attr.function)
477 if (sym->attr.pointer || sym->attr.allocatable)
480 assert (sym->as->type == AS_EXPLICIT);
486 gfc_build_array_type (tree type, gfc_array_spec * as)
488 tree lbound[GFC_MAX_DIMENSIONS];
489 tree ubound[GFC_MAX_DIMENSIONS];
492 for (n = 0; n < as->rank; n++)
494 /* Create expressions for the known bounds of the array. */
495 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
496 lbound[n] = gfc_index_one_node;
498 lbound[n] = gfc_conv_array_bound (as->lower[n]);
499 ubound[n] = gfc_conv_array_bound (as->upper[n]);
502 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
505 /* Returns the struct descriptor_dimension type. */
508 gfc_get_desc_dim_type (void)
514 if (gfc_desc_dim_type)
515 return gfc_desc_dim_type;
517 /* Build the type node. */
518 type = make_node (RECORD_TYPE);
520 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
521 TYPE_PACKED (type) = 1;
523 /* Consists of the stride, lbound and ubound members. */
524 decl = build_decl (FIELD_DECL,
525 get_identifier ("stride"), gfc_array_index_type);
526 DECL_CONTEXT (decl) = type;
529 decl = build_decl (FIELD_DECL,
530 get_identifier ("lbound"), gfc_array_index_type);
531 DECL_CONTEXT (decl) = type;
532 fieldlist = chainon (fieldlist, decl);
534 decl = build_decl (FIELD_DECL,
535 get_identifier ("ubound"), gfc_array_index_type);
536 DECL_CONTEXT (decl) = type;
537 fieldlist = chainon (fieldlist, decl);
539 /* Finish off the type. */
540 TYPE_FIELDS (type) = fieldlist;
542 gfc_finish_type (type);
544 gfc_desc_dim_type = type;
549 gfc_get_dtype (tree type, int rank)
557 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
558 return (GFC_TYPE_ARRAY_DTYPE (type));
560 /* TODO: Correctly identify LOGICAL types. */
561 switch (TREE_CODE (type))
564 n = GFC_DTYPE_INTEGER;
568 n = GFC_DTYPE_LOGICAL;
576 n = GFC_DTYPE_COMPLEX;
579 /* Arrays have already been dealt with. */
581 n = GFC_DTYPE_DERIVED;
585 n = GFC_DTYPE_CHARACTER;
592 assert (rank <= GFC_DTYPE_RANK_MASK);
593 size = TYPE_SIZE_UNIT (type);
595 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
596 if (size && INTEGER_CST_P (size))
598 if (tree_int_cst_lt (gfc_max_array_element_size, size))
599 internal_error ("Array element size too big");
601 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
603 dtype = build_int_2 (i, 0);
604 TREE_TYPE (dtype) = gfc_array_index_type;
606 if (size && !INTEGER_CST_P (size))
608 tmp = build_int_2 (GFC_DTYPE_SIZE_SHIFT, 0);
609 TREE_TYPE (tmp) = gfc_array_index_type;
610 tmp = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
611 dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
613 /* If we don't know the size we leave it as zero. This should never happen
614 for anything that is actually used. */
615 /* TODO: Check this is actually true, particularly when repacking
616 assumed size parameters. */
622 /* Build an array type for use without a descriptor. Valid values of packed
623 are 0=no, 1=partial, 2=full, 3=static. */
626 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
639 mpz_init_set_ui (offset, 0);
640 mpz_init_set_ui (stride, 1);
643 /* We don't use build_array_type because this does not include include
644 lang-specific information (ie. the bounds of the array) when checking
646 type = make_node (ARRAY_TYPE);
648 GFC_ARRAY_TYPE_P (type) = 1;
649 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
650 ggc_alloc_cleared (sizeof (struct lang_type));
652 known_stride = (packed != 0);
654 for (n = 0; n < as->rank; n++)
656 /* Fill in the stride and bound components of the type. */
658 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
661 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
664 if (expr->expr_type == EXPR_CONSTANT)
666 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
667 gfc_index_integer_kind);
674 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
678 /* Calculate the offset. */
679 mpz_mul (delta, stride, as->lower[n]->value.integer);
680 mpz_sub (offset, offset, delta);
686 if (expr && expr->expr_type == EXPR_CONSTANT)
688 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
689 gfc_index_integer_kind);
696 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
700 /* Calculate the stride. */
701 mpz_sub (delta, as->upper[n]->value.integer,
702 as->lower[n]->value.integer);
703 mpz_add_ui (delta, delta, 1);
704 mpz_mul (stride, stride, delta);
707 /* Only the first stride is known for partial packed arrays. */
714 GFC_TYPE_ARRAY_OFFSET (type) =
715 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
718 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
722 GFC_TYPE_ARRAY_SIZE (type) =
723 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
726 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
728 GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
729 GFC_TYPE_ARRAY_RANK (type) = as->rank;
730 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
732 /* TODO: use main type if it is unbounded. */
733 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
734 build_pointer_type (build_array_type (etype, range));
738 mpz_sub_ui (stride, stride, 1);
739 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
744 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
745 TYPE_DOMAIN (type) = range;
747 build_pointer_type (etype);
748 TREE_TYPE (type) = etype;
756 if (packed < 3 || !known_stride)
758 type = build_pointer_type (type);
759 GFC_ARRAY_TYPE_P (type) = 1;
760 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
766 /* Build an array (descriptor) type with given bounds. */
769 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
770 tree * ubound, int packed)
772 tree fat_type, fat_pointer_type;
777 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
778 const char *typename;
784 /* Build the type node. */
785 fat_type = make_node (RECORD_TYPE);
786 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
787 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
788 ggc_alloc_cleared (sizeof (struct lang_type));
789 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
790 GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
792 tmp = TYPE_NAME (etype);
793 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
794 tmp = DECL_NAME (tmp);
796 typename = IDENTIFIER_POINTER (tmp);
798 typename = "unknown";
800 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
801 GFC_MAX_SYMBOL_LEN, typename);
802 TYPE_NAME (fat_type) = get_identifier (name);
803 TYPE_PACKED (fat_type) = 0;
805 fat_pointer_type = build_pointer_type (fat_type);
807 /* Build an array descriptor record type. */
809 stride = gfc_index_one_node;
813 for (n = 0; n < dimen; n++)
815 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
822 if (lower != NULL_TREE)
824 if (INTEGER_CST_P (lower))
825 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
831 if (upper != NULL_TREE)
833 if (INTEGER_CST_P (upper))
834 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
839 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
841 tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower));
842 tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp,
843 gfc_index_one_node));
845 fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride));
846 /* Check the folding worked. */
847 assert (INTEGER_CST_P (stride));
852 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
853 /* TODO: known offsets for descriptors. */
854 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
856 /* We define data as an unknown size array. Much better than doing
857 pointer arithmetic. */
859 build_array_type (etype,
860 build_range_type (gfc_array_index_type,
861 gfc_index_zero_node, NULL_TREE));
862 arraytype = build_pointer_type (arraytype);
863 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
865 /* The pointer to the array data. */
866 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
868 DECL_CONTEXT (decl) = fat_type;
869 /* Add the data member as the first element of the descriptor. */
872 /* Add the base component. */
873 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
874 gfc_array_index_type);
875 DECL_CONTEXT (decl) = fat_type;
876 fieldlist = chainon (fieldlist, decl);
878 /* Add the dtype component. */
879 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
880 gfc_array_index_type);
881 DECL_CONTEXT (decl) = fat_type;
882 fieldlist = chainon (fieldlist, decl);
884 /* Build the array type for the stride and bound components. */
886 build_array_type (gfc_get_desc_dim_type (),
887 build_range_type (gfc_array_index_type,
889 gfc_rank_cst[dimen - 1]));
891 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
892 DECL_CONTEXT (decl) = fat_type;
893 DECL_INITIAL (decl) = NULL_TREE;
894 fieldlist = chainon (fieldlist, decl);
896 /* Finish off the type. */
897 TYPE_FIELDS (fat_type) = fieldlist;
899 gfc_finish_type (fat_type);
904 /* Build a pointer type. This function is called from gfc_sym_type(). */
907 gfc_build_pointer_type (gfc_symbol * sym, tree type)
909 /* Array pointer types aren't actualy pointers. */
910 if (sym->attr.dimension)
913 return build_pointer_type (type);
916 /* Return the type for a symbol. Special handling is required for character
917 types to get the correct level of indirection.
918 For functions return the return type.
919 For subroutines return void_type_node.
920 Calling this multiple times for the same symbol should be avoided,
921 especially for character and array types. */
924 gfc_sym_type (gfc_symbol * sym)
929 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
930 return void_type_node;
932 if (sym->backend_decl)
934 if (sym->attr.function)
935 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
937 return TREE_TYPE (sym->backend_decl);
940 /* The frontend doesn't set all the attributes for a function with an
941 explicit result value, so we use that instead when present. */
942 if (sym->attr.function && sym->result)
945 type = gfc_typenode_for_spec (&sym->ts);
947 if (sym->attr.dummy && !sym->attr.function)
952 if (sym->attr.dimension)
954 if (gfc_is_nodesc_array (sym))
956 /* If this is a character argument of unknown length, just use the
958 if (sym->ts.type != BT_CHARACTER
959 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
960 || sym->ts.cl->backend_decl)
962 type = gfc_get_nodesc_array_type (type, sym->as,
968 type = gfc_build_array_type (type, sym->as);
972 if (sym->attr.allocatable || sym->attr.pointer)
973 type = gfc_build_pointer_type (sym, type);
976 /* We currently pass all parameters by reference.
977 See f95_get_function_decl. For dummy function parameters return the
980 type = build_reference_type (type);
985 /* Layout and output debug info for a record type. */
988 gfc_finish_type (tree type)
992 decl = build_decl (TYPE_DECL, NULL_TREE, type);
993 TYPE_STUB_DECL (type) = decl;
995 rest_of_type_compilation (type, 1);
996 rest_of_decl_compilation (decl, 1, 0);
999 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1000 or RECORD_TYPE pointed to by STYPE. The new field is chained
1001 to the fieldlist pointed to by FIELDLIST.
1003 Returns a pointer to the new field. */
1006 gfc_add_field_to_struct (tree *fieldlist, tree context,
1007 tree name, tree type)
1011 decl = build_decl (FIELD_DECL, name, type);
1013 DECL_CONTEXT (decl) = context;
1014 DECL_INITIAL (decl) = 0;
1015 DECL_ALIGN (decl) = 0;
1016 DECL_USER_ALIGN (decl) = 0;
1017 TREE_CHAIN (decl) = NULL_TREE;
1018 *fieldlist = chainon (*fieldlist, decl);
1024 /* Build a tree node for a derived type. */
1027 gfc_get_derived_type (gfc_symbol * derived)
1029 tree typenode, field, field_type, fieldlist;
1032 assert (derived && derived->attr.flavor == FL_DERIVED);
1034 /* derived->backend_decl != 0 means we saw it before, but its
1035 component's backend_decl may have not been built. */
1036 if (derived->backend_decl)
1038 /* Its component's backend_decl has been built. */
1039 if (TYPE_FIELDS (derived->backend_decl))
1040 return derived->backend_decl;
1042 typenode = derived->backend_decl;
1046 /* We see this derived type first time, so build the type node. */
1047 typenode = make_node (RECORD_TYPE);
1048 TYPE_NAME (typenode) = get_identifier (derived->name);
1049 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1050 derived->backend_decl = typenode;
1053 /* Build the type member list. Install the newly created RECORD_TYPE
1054 node as DECL_CONTEXT of each FIELD_DECL. */
1055 fieldlist = NULL_TREE;
1056 for (c = derived->components; c; c = c->next)
1058 if (c->ts.type == BT_DERIVED && c->pointer)
1060 if (c->ts.derived->backend_decl)
1061 field_type = c->ts.derived->backend_decl;
1064 /* Build the type node. */
1065 field_type = make_node (RECORD_TYPE);
1066 TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1067 TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1068 c->ts.derived->backend_decl = field_type;
1073 if (c->ts.type == BT_CHARACTER)
1075 /* Evaluate the string length. */
1076 gfc_conv_const_charlen (c->ts.cl);
1077 assert (c->ts.cl->backend_decl);
1080 field_type = gfc_typenode_for_spec (&c->ts);
1083 /* This returns an array descriptor type. Initialisation may be
1089 /* Pointers to arrays aren't actualy pointer types. The
1090 descriptors are seperate, but the data is common. */
1091 field_type = gfc_build_array_type (field_type, c->as);
1094 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1096 else if (c->pointer)
1097 field_type = build_pointer_type (field_type);
1099 field = gfc_add_field_to_struct (&fieldlist, typenode,
1100 get_identifier (c->name),
1103 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1105 assert (!c->backend_decl);
1106 c->backend_decl = field;
1109 /* Now we have the final fieldlist. Record it, then lay out the
1110 derived type, including the fields. */
1111 TYPE_FIELDS (typenode) = fieldlist;
1113 gfc_finish_type (typenode);
1115 derived->backend_decl = typenode;
1121 gfc_return_by_reference (gfc_symbol * sym)
1123 if (!sym->attr.function)
1126 assert (sym->attr.function);
1131 if (sym->attr.dimension)
1134 if (sym->ts.type == BT_CHARACTER)
1137 if (sym->ts.type == BT_DERIVED)
1138 gfc_todo_error ("Returning derived types");
1139 /* Possibly return derived types by reference. */
1145 gfc_get_function_type (gfc_symbol * sym)
1149 gfc_formal_arglist *f;
1152 int alternate_return;
1154 /* Make sure this symbol is a function or a subroutine. */
1155 assert (sym->attr.flavor == FL_PROCEDURE);
1157 if (sym->backend_decl)
1158 return TREE_TYPE (sym->backend_decl);
1161 alternate_return = 0;
1162 typelist = NULL_TREE;
1163 /* Some functions we use an extra parameter for the return value. */
1164 if (gfc_return_by_reference (sym))
1171 if (arg->ts.type == BT_CHARACTER)
1172 gfc_conv_const_charlen (arg->ts.cl);
1174 type = gfc_sym_type (arg);
1175 if (arg->ts.type == BT_DERIVED
1176 || arg->attr.dimension
1177 || arg->ts.type == BT_CHARACTER)
1178 type = build_reference_type (type);
1180 typelist = gfc_chainon_list (typelist, type);
1181 if (arg->ts.type == BT_CHARACTER)
1182 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1185 /* Build the argument types for the function */
1186 for (f = sym->formal; f; f = f->next)
1191 /* Evaluate constant character lengths here so that they can be
1192 included in the type. */
1193 if (arg->ts.type == BT_CHARACTER)
1194 gfc_conv_const_charlen (arg->ts.cl);
1196 if (arg->attr.flavor == FL_PROCEDURE)
1198 type = gfc_get_function_type (arg);
1199 type = build_pointer_type (type);
1202 type = gfc_sym_type (arg);
1204 /* Parameter Passing Convention
1206 We currently pass all parameters by reference.
1207 Parameters with INTENT(IN) could be passed by value.
1208 The problem arises if a function is called via an implicit
1209 prototype. In this situation the INTENT is not known.
1210 For this reason all parameters to global functions must be
1211 passed by reference. Passing by value would potentialy
1212 generate bad code. Worse there would be no way of telling that
1213 this code was bad, except that it would give incorrect results.
1215 Contained procedures could pass by value as these are never
1216 used without an explicit interface, and connot be passed as
1217 actual parameters for a dummy procedure. */
1218 if (arg->ts.type == BT_CHARACTER)
1220 typelist = gfc_chainon_list (typelist, type);
1224 if (sym->attr.subroutine)
1225 alternate_return = 1;
1229 /* Add hidden string length parameters. */
1231 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1233 typelist = gfc_chainon_list (typelist, void_type_node);
1235 if (alternate_return)
1236 type = integer_type_node;
1237 else if (!sym->attr.function || gfc_return_by_reference (sym))
1238 type = void_type_node;
1240 type = gfc_sym_type (sym);
1242 type = build_function_type (type, typelist);
1247 /* Routines for getting integer type nodes */
1250 /* Return an integer type with BITS bits of precision,
1251 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1254 gfc_type_for_size (unsigned bits, int unsignedp)
1256 if (bits == TYPE_PRECISION (integer_type_node))
1257 return unsignedp ? unsigned_type_node : integer_type_node;
1259 if (bits == TYPE_PRECISION (signed_char_type_node))
1260 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1262 if (bits == TYPE_PRECISION (short_integer_type_node))
1263 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1265 if (bits == TYPE_PRECISION (long_integer_type_node))
1266 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1268 if (bits == TYPE_PRECISION (long_long_integer_type_node))
1269 return (unsignedp ? long_long_unsigned_type_node
1270 : long_long_integer_type_node);
1271 /*TODO: We currently don't initialise this...
1272 if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1273 return (unsignedp ? widest_unsigned_literal_type_node
1274 : widest_integer_literal_type_node);*/
1276 if (bits <= TYPE_PRECISION (intQI_type_node))
1277 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1279 if (bits <= TYPE_PRECISION (intHI_type_node))
1280 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1282 if (bits <= TYPE_PRECISION (intSI_type_node))
1283 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1285 if (bits <= TYPE_PRECISION (intDI_type_node))
1286 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1291 /* Return a data type that has machine mode MODE.
1292 If the mode is an integer,
1293 then UNSIGNEDP selects between signed and unsigned types. */
1296 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1298 if (mode == TYPE_MODE (integer_type_node))
1299 return unsignedp ? unsigned_type_node : integer_type_node;
1301 if (mode == TYPE_MODE (signed_char_type_node))
1302 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1304 if (mode == TYPE_MODE (short_integer_type_node))
1305 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1307 if (mode == TYPE_MODE (long_integer_type_node))
1308 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1310 if (mode == TYPE_MODE (long_long_integer_type_node))
1311 return unsignedp ? long_long_unsigned_type_node :
1312 long_long_integer_type_node;
1315 if (mode == TYPE_MODE (widest_integer_literal_type_node))
1316 return unsignedp ? widest_unsigned_literal_type_node
1317 : widest_integer_literal_type_node;
1321 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1324 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1327 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1330 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1332 #if HOST_BITS_PER_WIDE_INT >= 64
1333 if (mode == TYPE_MODE (intTI_type_node))
1334 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1337 if (mode == TYPE_MODE (float_type_node))
1338 return float_type_node;
1340 if (mode == TYPE_MODE (double_type_node))
1341 return double_type_node;
1343 if (mode == TYPE_MODE (long_double_type_node))
1344 return long_double_type_node;
1346 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1347 return build_pointer_type (char_type_node);
1349 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1350 return build_pointer_type (integer_type_node);
1352 #ifdef VECTOR_MODE_SUPPORTED_P
1353 if (VECTOR_MODE_SUPPORTED_P (mode))
1358 return unsignedp ? unsigned_V16QI_type_node : V16QI_type_node;
1360 return unsignedp ? unsigned_V8HI_type_node : V8HI_type_node;
1362 return unsignedp ? unsigned_V4SI_type_node : V4SI_type_node;
1364 return unsignedp ? unsigned_V2DI_type_node : V2DI_type_node;
1366 return unsignedp ? unsigned_V2SI_type_node : V2SI_type_node;
1368 return unsignedp ? unsigned_V4HI_type_node : V4HI_type_node;
1370 return unsignedp ? unsigned_V8QI_type_node : V8QI_type_node;
1372 return V16SF_type_node;
1374 return V4SF_type_node;
1376 return V2SF_type_node;
1378 return V2DF_type_node;
1388 /* Return an unsigned type the same as TYPE in other respects. */
1391 gfc_unsigned_type (tree type)
1393 tree type1 = TYPE_MAIN_VARIANT (type);
1394 if (type1 == signed_char_type_node || type1 == char_type_node)
1395 return unsigned_char_type_node;
1396 if (type1 == integer_type_node)
1397 return unsigned_type_node;
1398 if (type1 == short_integer_type_node)
1399 return short_unsigned_type_node;
1400 if (type1 == long_integer_type_node)
1401 return long_unsigned_type_node;
1402 if (type1 == long_long_integer_type_node)
1403 return long_long_unsigned_type_node;
1405 if (type1 == widest_integer_literal_type_node)
1406 return widest_unsigned_literal_type_node;
1408 #if HOST_BITS_PER_WIDE_INT >= 64
1409 if (type1 == intTI_type_node)
1410 return unsigned_intTI_type_node;
1412 if (type1 == intDI_type_node)
1413 return unsigned_intDI_type_node;
1414 if (type1 == intSI_type_node)
1415 return unsigned_intSI_type_node;
1416 if (type1 == intHI_type_node)
1417 return unsigned_intHI_type_node;
1418 if (type1 == intQI_type_node)
1419 return unsigned_intQI_type_node;
1421 return gfc_signed_or_unsigned_type (1, type);
1424 /* Return a signed type the same as TYPE in other respects. */
1427 gfc_signed_type (tree type)
1429 tree type1 = TYPE_MAIN_VARIANT (type);
1430 if (type1 == unsigned_char_type_node || type1 == char_type_node)
1431 return signed_char_type_node;
1432 if (type1 == unsigned_type_node)
1433 return integer_type_node;
1434 if (type1 == short_unsigned_type_node)
1435 return short_integer_type_node;
1436 if (type1 == long_unsigned_type_node)
1437 return long_integer_type_node;
1438 if (type1 == long_long_unsigned_type_node)
1439 return long_long_integer_type_node;
1441 if (type1 == widest_unsigned_literal_type_node)
1442 return widest_integer_literal_type_node;
1444 #if HOST_BITS_PER_WIDE_INT >= 64
1445 if (type1 == unsigned_intTI_type_node)
1446 return intTI_type_node;
1448 if (type1 == unsigned_intDI_type_node)
1449 return intDI_type_node;
1450 if (type1 == unsigned_intSI_type_node)
1451 return intSI_type_node;
1452 if (type1 == unsigned_intHI_type_node)
1453 return intHI_type_node;
1454 if (type1 == unsigned_intQI_type_node)
1455 return intQI_type_node;
1457 return gfc_signed_or_unsigned_type (0, type);
1460 /* Return a type the same as TYPE except unsigned or
1461 signed according to UNSIGNEDP. */
1464 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1466 if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1469 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1470 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1471 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1472 return unsignedp ? unsigned_type_node : integer_type_node;
1473 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1474 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1475 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1476 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1477 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1478 return (unsignedp ? long_long_unsigned_type_node
1479 : long_long_integer_type_node);
1481 if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1482 return (unsignedp ? widest_unsigned_literal_type_node
1483 : widest_integer_literal_type_node);
1485 #if HOST_BITS_PER_WIDE_INT >= 64
1486 if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1487 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1489 if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1490 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1491 if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1492 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1493 if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1494 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1495 if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1496 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1501 #include "gt-fortran-trans-types.h"