1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003 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 GNU G95.
8 GNU G95 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU G95 is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU G95; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
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.*/
70 unsigned HOST_WIDE_INT hi;
71 unsigned HOST_WIDE_INT lo;
74 #define PUSH_TYPE(name, node) \
75 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
77 gfc_int1_type_node = signed_char_type_node;
78 PUSH_TYPE ("int1", gfc_int1_type_node);
79 gfc_int2_type_node = short_integer_type_node;
80 PUSH_TYPE ("int2", gfc_int2_type_node);
81 gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ );
82 PUSH_TYPE ("int4", gfc_int4_type_node);
83 gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ );
84 PUSH_TYPE ("int8", gfc_int8_type_node);
85 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
86 gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ );
87 PUSH_TYPE ("int16", gfc_int16_type_node);
90 gfc_real4_type_node = float_type_node;
91 PUSH_TYPE ("real4", gfc_real4_type_node);
92 gfc_real8_type_node = double_type_node;
93 PUSH_TYPE ("real8", gfc_real8_type_node);
94 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
95 /* Hmm, this will not work. Ref. g77 */
96 gfc_real16_type_node = long_double_type_node;
97 PUSH_TYPE ("real16", gfc_real16_type_node);
100 gfc_complex4_type_node = complex_float_type_node;
101 PUSH_TYPE ("complex4", gfc_complex4_type_node);
102 gfc_complex8_type_node = complex_double_type_node;
103 PUSH_TYPE ("complex8", gfc_complex8_type_node);
104 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
105 /* Hmm, this will not work. Ref. g77 */
106 gfc_complex16_type_node = complex_long_double_type_node;
107 PUSH_TYPE ("complex16", gfc_complex16_type_node);
110 gfc_logical1_type_node = make_node (BOOLEAN_TYPE);
111 TYPE_PRECISION (gfc_logical1_type_node) = 8;
112 fixup_unsigned_type (gfc_logical1_type_node);
113 PUSH_TYPE ("logical1", gfc_logical1_type_node);
114 gfc_logical2_type_node = make_node (BOOLEAN_TYPE);
115 TYPE_PRECISION (gfc_logical2_type_node) = 16;
116 fixup_unsigned_type (gfc_logical2_type_node);
117 PUSH_TYPE ("logical2", gfc_logical2_type_node);
118 gfc_logical4_type_node = make_node (BOOLEAN_TYPE);
119 TYPE_PRECISION (gfc_logical4_type_node) = 32;
120 fixup_unsigned_type (gfc_logical4_type_node);
121 PUSH_TYPE ("logical4", gfc_logical4_type_node);
122 gfc_logical8_type_node = make_node (BOOLEAN_TYPE);
123 TYPE_PRECISION (gfc_logical8_type_node) = 64;
124 fixup_unsigned_type (gfc_logical8_type_node);
125 PUSH_TYPE ("logical8", gfc_logical8_type_node);
126 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
127 gfc_logical16_type_node = make_node (BOOLEAN_TYPE);
128 TYPE_PRECISION (gfc_logical16_type_node) = 128;
129 fixup_unsigned_type (gfc_logical16_type_node);
130 PUSH_TYPE ("logical16", gfc_logical16_type_node);
133 gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
134 PUSH_TYPE ("char", gfc_character1_type_node);
136 PUSH_TYPE ("byte", unsigned_char_type_node);
137 PUSH_TYPE ("void", void_type_node);
139 /* DBX debugging output gets upset if these aren't set. */
140 if (!TYPE_NAME (integer_type_node))
141 PUSH_TYPE ("c_integer", integer_type_node);
142 if (!TYPE_NAME (char_type_node))
143 PUSH_TYPE ("c_char", char_type_node);
146 pvoid_type_node = build_pointer_type (void_type_node);
147 ppvoid_type_node = build_pointer_type (pvoid_type_node);
148 pchar_type_node = build_pointer_type (gfc_character1_type_node);
150 gfc_index_integer_kind = TYPE_PRECISION (long_unsigned_type_node) / 8;
151 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
153 /* The maximum array element size that can be handled is determined
154 by the number of bits available to store this field in the array
157 n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type))
158 - GFC_DTYPE_SIZE_SHIFT;
160 if (n > sizeof (HOST_WIDE_INT) * 8)
162 lo = ~(unsigned HOST_WIDE_INT) 0;
163 hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n);
168 lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n);
170 gfc_max_array_element_size = build_int_2 (lo, hi);
171 TREE_TYPE (gfc_max_array_element_size) = long_unsigned_type_node;
173 size_type_node = gfc_array_index_type;
174 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ());
176 boolean_true_node = build_int_2 (1, 0);
177 TREE_TYPE (boolean_true_node) = boolean_type_node;
178 boolean_false_node = build_int_2 (0, 0);
179 TREE_TYPE (boolean_false_node) = boolean_type_node;
182 /* 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 */
207 gfc_get_real_type (int kind)
212 return (gfc_real4_type_node);
214 return (gfc_real8_type_node);
215 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
217 return (gfc_real16_type_node);
220 fatal_error ("real kind=%d not available", kind);
224 /* Get a type node for a complex kind */
226 gfc_get_complex_type (int kind)
231 return (gfc_complex4_type_node);
233 return (gfc_complex8_type_node);
234 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
236 return (gfc_complex16_type_node);
239 fatal_error ("complex kind=%d not available", kind);
243 /* Get a type node for a logical kind */
245 gfc_get_logical_type (int kind)
250 return (gfc_logical1_type_node);
252 return (gfc_logical2_type_node);
254 return (gfc_logical4_type_node);
256 return (gfc_logical8_type_node);
257 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
259 return (gfc_logical16_type_node);
262 fatal_error ("logical kind=%d not available", kind);
266 /* Get a type node for a character kind. */
268 gfc_get_character_type (int kind, gfc_charlen * cl)
278 base = gfc_character1_type_node;
282 fatal_error ("character kind=%d not available", kind);
285 len = (cl == 0) ? NULL_TREE : cl->backend_decl;
287 bounds = build_range_type (gfc_array_index_type, integer_one_node, len);
288 type = build_array_type (base, bounds);
289 TYPE_STRING_FLAG (type) = 1;
294 /* Covert a basic type. This will be an array for character types. */
296 gfc_typenode_for_spec (gfc_typespec * spec)
307 basetype = gfc_get_int_type (spec->kind);
311 basetype = gfc_get_real_type (spec->kind);
315 basetype = gfc_get_complex_type (spec->kind);
319 basetype = gfc_get_logical_type (spec->kind);
323 basetype = gfc_get_character_type (spec->kind, spec->cl);
327 basetype = gfc_get_derived_type (spec->derived);
337 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
339 gfc_conv_array_bound (gfc_expr * expr)
341 /* If expr is an integer constant, return that. */
342 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
343 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
345 /* Otherwise return NULL. */
350 gfc_get_element_type (tree type)
354 if (GFC_ARRAY_TYPE_P (type))
356 if (TREE_CODE (type) == POINTER_TYPE)
357 type = TREE_TYPE (type);
358 assert (TREE_CODE (type) == ARRAY_TYPE);
359 element = TREE_TYPE (type);
363 assert (GFC_DESCRIPTOR_TYPE_P (type));
364 element = TREE_TYPE (TYPE_FIELDS (type));
366 assert (TREE_CODE (element) == POINTER_TYPE);
367 element = TREE_TYPE (element);
369 assert (TREE_CODE (element) == ARRAY_TYPE);
370 element = TREE_TYPE (element);
376 /* Build an array. This function is called from gfc_sym_type().
377 Actualy returns array descriptor type.
379 Format of array descriptors is as follows:
381 struct gfc_array_descriptor
386 struct descriptor_dimension dimension[N_DIM];
389 struct descriptor_dimension
396 Translation code should use gfc_conv_descriptor_* rather than accessing
397 the descriptor directly. Any changes to the array descriptor type will
398 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
400 This is represented internaly as a RECORD_TYPE. The index nodes are
401 gfc_array_index_type and the data node is a pointer to the data. See below
402 for the handling of character types.
404 The dtype member is formatted as follows:
405 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
406 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
407 size = dtype >> GFC_DTYPE_SIZE_SHIFT
409 I originaly used nested ARRAY_TYPE nodes to represent arrays, but this
410 generated poor code for assumed/deferred size arrays. These require
411 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of GIMPLE
412 grammar. Also, there is no way to explicitly set the array stride, so
413 all data must be packed(1). I've tried to mark all the functions which
414 would require modification with a GCC ARRAYS comment.
416 The data component points to the first element in the array.
417 The offset field is the position of the origin of the array
418 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
420 An element is accessed by
421 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
422 This gives good performance as it computation does not involve the
423 bounds of the array. For packed arrays, this is optimized further by
424 substituting the known strides.
426 This system has one problem: all array bounds must be withing 2^31 elements
427 of the origin (2^63 on 64-bit machines). For example
428 integer, dimension (80000:90000, 80000:90000, 2) :: array
429 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
430 the calculation for stride02 would overflow. This may still work, but
431 I haven't checked, and it relies on the overflow doing the right thing.
433 The way to fix this problem is to access alements as follows:
434 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
435 Obviously this is much slower. I will make this a compile time option,
436 something like -fsmall-array-offsets. Mixing code compiled with and without
437 this switch will work.
439 (1) This can be worked around by modifying the upper bound of the previous
440 dimension. This requires extra fields in the descriptor (both real_ubound
441 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
442 may allow us to do this. However I can't find mention of this anywhere
447 /* Returns true if the array sym does not require a descriptor. */
450 gfc_is_nodesc_array (gfc_symbol * sym)
452 assert (sym->attr.dimension);
454 /* We only want local arrays. */
455 if (sym->attr.pointer || sym->attr.allocatable)
460 if (sym->as->type != AS_ASSUMED_SHAPE)
466 if (sym->attr.result || sym->attr.function)
469 if (sym->attr.pointer || sym->attr.allocatable)
472 assert (sym->as->type == AS_EXPLICIT);
478 gfc_build_array_type (tree type, gfc_array_spec * as)
480 tree lbound[GFC_MAX_DIMENSIONS];
481 tree ubound[GFC_MAX_DIMENSIONS];
484 for (n = 0; n < as->rank; n++)
486 /* Create expressions for the known bounds of the array. */
487 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
488 lbound[n] = integer_one_node;
490 lbound[n] = gfc_conv_array_bound (as->lower[n]);
491 ubound[n] = gfc_conv_array_bound (as->upper[n]);
494 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
497 /* Returns the struct descriptor_dimension type. */
499 gfc_get_desc_dim_type (void)
505 if (gfc_desc_dim_type)
506 return gfc_desc_dim_type;
508 /* Build the type node. */
509 type = make_node (RECORD_TYPE);
511 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
512 TYPE_PACKED (type) = 1;
514 /* Consists of the stride, lbound and ubound members. */
515 decl = build_decl (FIELD_DECL,
516 get_identifier ("stride"), gfc_array_index_type);
517 DECL_CONTEXT (decl) = type;
520 decl = build_decl (FIELD_DECL,
521 get_identifier ("lbound"), gfc_array_index_type);
522 DECL_CONTEXT (decl) = type;
523 fieldlist = chainon (fieldlist, decl);
525 decl = build_decl (FIELD_DECL,
526 get_identifier ("ubound"), gfc_array_index_type);
527 DECL_CONTEXT (decl) = type;
528 fieldlist = chainon (fieldlist, decl);
530 /* Finish off the type. */
531 TYPE_FIELDS (type) = fieldlist;
533 gfc_finish_type (type);
535 gfc_desc_dim_type = type;
540 gfc_get_dtype (tree type, int rank)
548 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
549 return (GFC_TYPE_ARRAY_DTYPE (type));
551 /* TODO: Correctly identify LOGICAL types. */
552 switch (TREE_CODE (type))
555 n = GFC_DTYPE_INTEGER;
559 n = GFC_DTYPE_LOGICAL;
567 n = GFC_DTYPE_COMPLEX;
570 /* Arrays have already been dealt with. */
572 n = GFC_DTYPE_DERIVED;
576 n = GFC_DTYPE_CHARACTER;
583 assert (rank <= GFC_DTYPE_RANK_MASK);
584 size = TYPE_SIZE_UNIT (type);
586 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
587 if (size && INTEGER_CST_P (size))
589 if (tree_int_cst_lt (gfc_max_array_element_size, size))
590 internal_error ("Array element size too big");
592 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
594 dtype = build_int_2 (i, 0);
595 TREE_TYPE (dtype) = gfc_array_index_type;
597 if (size && !INTEGER_CST_P (size))
599 tmp = build_int_2 (GFC_DTYPE_SIZE_SHIFT, 0);
600 TREE_TYPE (tmp) = gfc_array_index_type;
601 tmp = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
602 dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
604 /* If we don't know the size we leave it as zero. This should never happen
605 for anything that is actually used. */
606 /* TODO: Check this is actually true, particularly when repacking
607 assumed size parameters. */
613 /* Build an array type for use without a descriptor. Valid values of packed
614 are 0=no, 1=partial, 2=full, 3=static. */
617 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
630 mpz_init_set_ui (offset, 0);
631 mpz_init_set_ui (stride, 1);
634 /* We don't use build_array_type because this does not include include
635 lang-specific information (ie. the bounds of the array) when checking
637 type = make_node (ARRAY_TYPE);
639 GFC_ARRAY_TYPE_P (type) = 1;
640 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
641 ggc_alloc_cleared (sizeof (struct lang_type));
643 known_stride = (packed != 0);
645 for (n = 0; n < as->rank; n++)
647 /* Fill in the stride and bound components of the type. */
649 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
652 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
655 if (expr->expr_type == EXPR_CONSTANT)
657 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
658 gfc_index_integer_kind);
665 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
669 /* Calculate the offset. */
670 mpz_mul (delta, stride, as->lower[n]->value.integer);
671 mpz_sub (offset, offset, delta);
677 if (expr && expr->expr_type == EXPR_CONSTANT)
679 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
680 gfc_index_integer_kind);
687 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
691 /* Calculate the stride. */
692 mpz_sub (delta, as->upper[n]->value.integer,
693 as->lower[n]->value.integer);
694 mpz_add_ui (delta, delta, 1);
695 mpz_mul (stride, stride, delta);
698 /* Only the first stride is known for partial packed arrays. */
705 GFC_TYPE_ARRAY_OFFSET (type) =
706 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
709 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
713 GFC_TYPE_ARRAY_SIZE (type) =
714 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
717 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
719 GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
720 GFC_TYPE_ARRAY_RANK (type) = as->rank;
721 range = build_range_type (gfc_array_index_type, integer_zero_node,
723 /* TODO: use main type if it is unbounded. */
724 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
725 build_pointer_type (build_array_type (etype, range));
729 mpz_sub_ui (stride, stride, 1);
730 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
735 range = build_range_type (gfc_array_index_type, integer_zero_node, range);
736 TYPE_DOMAIN (type) = range;
738 build_pointer_type (etype);
739 TREE_TYPE (type) = etype;
747 if (packed < 3 || !known_stride)
749 type = build_pointer_type (type);
750 GFC_ARRAY_TYPE_P (type) = 1;
751 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
757 /* Build an array (descriptor) type with given bounds. */
760 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
761 tree * ubound, int packed)
763 tree fat_type, fat_pointer_type;
768 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
769 const char *typename;
775 /* Build the type node. */
776 fat_type = make_node (RECORD_TYPE);
777 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
778 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
779 ggc_alloc_cleared (sizeof (struct lang_type));
780 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
781 GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
783 tmp = TYPE_NAME (etype);
784 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
785 tmp = DECL_NAME (tmp);
787 typename = IDENTIFIER_POINTER (tmp);
789 typename = "unknown";
791 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
792 GFC_MAX_SYMBOL_LEN, typename);
793 TYPE_NAME (fat_type) = get_identifier (name);
794 TYPE_PACKED (fat_type) = 0;
796 fat_pointer_type = build_pointer_type (fat_type);
798 /* Build an array descriptor record type. */
800 stride = integer_one_node;
804 for (n = 0; n < dimen; n++)
806 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
813 if (lower != NULL_TREE)
815 if (INTEGER_CST_P (lower))
816 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
822 if (upper != NULL_TREE)
824 if (INTEGER_CST_P (upper))
825 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
830 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
832 tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower));
833 tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp,
836 fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride));
837 /* Check the folding worked. */
838 assert (INTEGER_CST_P (stride));
843 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
844 /* TODO: known offsets for descriptors. */
845 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
847 /* We define data as an unknown size array. Much better than doing
848 pointer arithmetic. */
850 build_array_type (etype,
851 build_range_type (gfc_array_index_type,
852 integer_zero_node, NULL_TREE));
853 arraytype = build_pointer_type (arraytype);
854 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
856 /* The pointer to the array data. */
857 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
859 DECL_CONTEXT (decl) = fat_type;
860 /* Add the data member as the first element of the descriptor. */
863 /* Add the base component. */
864 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
865 gfc_array_index_type);
866 DECL_CONTEXT (decl) = fat_type;
867 fieldlist = chainon (fieldlist, decl);
869 /* Add the dtype component. */
870 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
871 gfc_array_index_type);
872 DECL_CONTEXT (decl) = fat_type;
873 fieldlist = chainon (fieldlist, decl);
875 /* Build the array type for the stride and bound components. */
877 build_array_type (gfc_get_desc_dim_type (),
878 build_range_type (gfc_array_index_type,
880 gfc_rank_cst[dimen - 1]));
882 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
883 DECL_CONTEXT (decl) = fat_type;
884 DECL_INITIAL (decl) = NULL_TREE;
885 fieldlist = chainon (fieldlist, decl);
887 /* Finish off the type. */
888 TYPE_FIELDS (fat_type) = fieldlist;
890 gfc_finish_type (fat_type);
895 /* Build a pointer type. This function is called from gfc_sym_type(). */
897 gfc_build_pointer_type (gfc_symbol * sym, tree type)
899 /* Array pointer types aren't actualy pointers. */
900 if (sym->attr.dimension)
903 return build_pointer_type (type);
906 /* Return the type for a symbol. Special handling is required for character
907 types to get the correct level of indirection.
908 For functions return the return type.
909 For subroutines return void_type_node.
912 gfc_sym_type (gfc_symbol * sym)
917 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
918 return void_type_node;
920 if (sym->backend_decl)
922 if (sym->attr.function)
923 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
925 return TREE_TYPE (sym->backend_decl);
928 /* The frontend doesn't set all the attributes for a function with an
929 explicit result value, so we use that instead when present. */
930 if (sym->attr.function && sym->result)
933 type = gfc_typenode_for_spec (&sym->ts);
935 if (sym->attr.dummy && !sym->attr.function)
940 if (sym->attr.dimension)
942 if (gfc_is_nodesc_array (sym))
944 /* If this is a character argument of unknown length, just use the
946 if (sym->ts.type != BT_CHARACTER
947 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
948 || sym->ts.cl->backend_decl)
950 type = gfc_get_nodesc_array_type (type, sym->as,
956 type = gfc_build_array_type (type, sym->as);
960 if (sym->attr.allocatable || sym->attr.pointer)
961 type = gfc_build_pointer_type (sym, type);
964 /* We currently pass all parameters by reference.
965 See f95_get_function_decl. For dummy function parameters return the
968 type = build_reference_type (type);
973 /* Layout and output debug info for a record type. */
975 gfc_finish_type (tree type)
979 decl = build_decl (TYPE_DECL, NULL_TREE, type);
980 TYPE_STUB_DECL (type) = decl;
982 rest_of_type_compilation (type, 1);
983 rest_of_decl_compilation (decl, NULL, 1, 0);
986 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
987 or RECORD_TYPE pointed to by STYPE. The new field is chained
988 to the fieldlist pointed to by FIELDLIST.
990 Returns a pointer to the new field. */
992 gfc_add_field_to_struct (tree *fieldlist, tree context,
993 tree name, tree type)
997 decl = build_decl (FIELD_DECL, name, type);
999 DECL_CONTEXT (decl) = context;
1000 DECL_INITIAL (decl) = 0;
1001 DECL_ALIGN (decl) = 0;
1002 DECL_USER_ALIGN (decl) = 0;
1003 TREE_CHAIN (decl) = NULL_TREE;
1004 *fieldlist = chainon (*fieldlist, decl);
1010 /* Build a tree node for a derived type. */
1012 gfc_get_derived_type (gfc_symbol * derived)
1014 tree typenode, field, field_type, fieldlist;
1017 assert (derived && derived->attr.flavor == FL_DERIVED);
1019 /* derived->backend_decl != 0 means we saw it before, but its
1020 component's backend_decl may have not been built. */
1021 if (derived->backend_decl)
1023 /* Its component's backend_decl has been built. */
1024 if (TYPE_FIELDS (derived->backend_decl))
1025 return derived->backend_decl;
1027 typenode = derived->backend_decl;
1031 /* We see this derived type first time, so build the type node. */
1032 typenode = make_node (RECORD_TYPE);
1033 TYPE_NAME (typenode) = get_identifier (derived->name);
1034 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1035 derived->backend_decl = typenode;
1038 /* Build the type member list. Install the newly created RECORD_TYPE
1039 node as DECL_CONTEXT of each FIELD_DECL. */
1040 fieldlist = NULL_TREE;
1041 for (c = derived->components; c; c = c->next)
1043 if (c->ts.type == BT_DERIVED && c->pointer)
1045 if (c->ts.derived->backend_decl)
1046 field_type = c->ts.derived->backend_decl;
1049 /* Build the type node. */
1050 field_type = make_node (RECORD_TYPE);
1051 TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1052 TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1053 c->ts.derived->backend_decl = field_type;
1058 if (c->ts.type == BT_CHARACTER)
1060 /* Evaluate the string length. */
1061 gfc_conv_const_charlen (c->ts.cl);
1062 assert (c->ts.cl->backend_decl);
1065 field_type = gfc_typenode_for_spec (&c->ts);
1068 /* This returns an array descriptor type. Initialisation may be
1074 /* Pointers to arrays aren't actualy pointer types. The
1075 descriptors are seperate, but the data is common. */
1076 field_type = gfc_build_array_type (field_type, c->as);
1079 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1081 else if (c->pointer)
1082 field_type = build_pointer_type (field_type);
1084 field = gfc_add_field_to_struct (&fieldlist, typenode,
1085 get_identifier (c->name),
1088 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1090 assert (!c->backend_decl);
1091 c->backend_decl = field;
1094 /* Now we have the final fieldlist. Record it, then lay out the
1095 derived type, including the fields. */
1096 TYPE_FIELDS (typenode) = fieldlist;
1098 gfc_finish_type (typenode);
1100 derived->backend_decl = typenode;
1106 gfc_return_by_reference (gfc_symbol * sym)
1108 if (!sym->attr.function)
1111 assert (sym->attr.function);
1116 if (sym->attr.dimension)
1119 if (sym->ts.type == BT_CHARACTER)
1122 if (sym->ts.type == BT_DERIVED)
1123 gfc_todo_error ("Returning derived types");
1124 /* Possibly return derived types by reference. */
1129 gfc_get_function_type (gfc_symbol * sym)
1133 gfc_formal_arglist *f;
1136 int alternate_return;
1138 /* Make sure this symbol is a function or a subroutine. */
1139 assert (sym->attr.flavor == FL_PROCEDURE);
1141 if (sym->backend_decl)
1142 return TREE_TYPE (sym->backend_decl);
1145 alternate_return = 0;
1146 typelist = NULL_TREE;
1147 /* Some functions we use an extra parameter for the return value. */
1148 if (gfc_return_by_reference (sym))
1155 if (arg->ts.type == BT_CHARACTER)
1156 gfc_conv_const_charlen (arg->ts.cl);
1158 type = gfc_sym_type (arg);
1159 if (arg->ts.type == BT_DERIVED
1160 || arg->attr.dimension
1161 || arg->ts.type == BT_CHARACTER)
1162 type = build_reference_type (type);
1164 typelist = gfc_chainon_list (typelist, type);
1165 if (arg->ts.type == BT_CHARACTER)
1166 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1169 /* Build the argument types for the function */
1170 for (f = sym->formal; f; f = f->next)
1175 /* Evaluate constant character lengths here so that they can be
1176 included in the type. */
1177 if (arg->ts.type == BT_CHARACTER)
1178 gfc_conv_const_charlen (arg->ts.cl);
1180 if (arg->attr.flavor == FL_PROCEDURE)
1182 type = gfc_get_function_type (arg);
1183 type = build_pointer_type (type);
1186 type = gfc_sym_type (arg);
1188 /* Parameter Passing Convention
1190 We currently pass all parameters by reference.
1191 Parameters with INTENT(IN) could be passed by value.
1192 The problem arises if a function is called via an implicit
1193 prototype. In this situation the INTENT is not known.
1194 For this reason all parameters to global functions must be
1195 passed by reference. Passing by value would potentialy
1196 generate bad code. Worse there would be no way of telling that
1197 this code wad bad, except that it would give incorrect results.
1199 Contained procedures could pass by value as these are never
1200 used without an explicit interface, and connot be passed as
1201 actual parameters for a dummy procedure.
1203 if (arg->ts.type == BT_CHARACTER)
1205 typelist = gfc_chainon_list (typelist, type);
1209 if (sym->attr.subroutine)
1210 alternate_return = 1;
1214 /* Add hidden string length parameters. */
1216 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1218 typelist = gfc_chainon_list (typelist, void_type_node);
1220 if (alternate_return)
1221 type = integer_type_node;
1222 else if (!sym->attr.function || gfc_return_by_reference (sym))
1223 type = void_type_node;
1225 type = gfc_sym_type (sym);
1227 type = build_function_type (type, typelist);
1232 /* Routines for getting integer type nodes */
1235 /* Return an integer type with BITS bits of precision,
1236 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1239 gfc_type_for_size (unsigned bits, int unsignedp)
1241 if (bits == TYPE_PRECISION (integer_type_node))
1242 return unsignedp ? unsigned_type_node : integer_type_node;
1244 if (bits == TYPE_PRECISION (signed_char_type_node))
1245 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1247 if (bits == TYPE_PRECISION (short_integer_type_node))
1248 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1250 if (bits == TYPE_PRECISION (long_integer_type_node))
1251 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1253 if (bits == TYPE_PRECISION (long_long_integer_type_node))
1254 return (unsignedp ? long_long_unsigned_type_node
1255 : long_long_integer_type_node);
1256 /*TODO: We currently don't initialise this...
1257 if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1258 return (unsignedp ? widest_unsigned_literal_type_node
1259 : widest_integer_literal_type_node);*/
1261 if (bits <= TYPE_PRECISION (intQI_type_node))
1262 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1264 if (bits <= TYPE_PRECISION (intHI_type_node))
1265 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1267 if (bits <= TYPE_PRECISION (intSI_type_node))
1268 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1270 if (bits <= TYPE_PRECISION (intDI_type_node))
1271 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1276 /* Return a data type that has machine mode MODE.
1277 If the mode is an integer,
1278 then UNSIGNEDP selects between signed and unsigned types. */
1281 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1283 if (mode == TYPE_MODE (integer_type_node))
1284 return unsignedp ? unsigned_type_node : integer_type_node;
1286 if (mode == TYPE_MODE (signed_char_type_node))
1287 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1289 if (mode == TYPE_MODE (short_integer_type_node))
1290 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1292 if (mode == TYPE_MODE (long_integer_type_node))
1293 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1295 if (mode == TYPE_MODE (long_long_integer_type_node))
1296 return unsignedp ? long_long_unsigned_type_node :
1297 long_long_integer_type_node;
1300 if (mode == TYPE_MODE (widest_integer_literal_type_node))
1301 return unsignedp ? widest_unsigned_literal_type_node
1302 : widest_integer_literal_type_node;
1306 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1309 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1312 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1315 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1317 #if HOST_BITS_PER_WIDE_INT >= 64
1318 if (mode == TYPE_MODE (intTI_type_node))
1319 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1322 if (mode == TYPE_MODE (float_type_node))
1323 return float_type_node;
1325 if (mode == TYPE_MODE (double_type_node))
1326 return double_type_node;
1328 if (mode == TYPE_MODE (long_double_type_node))
1329 return long_double_type_node;
1331 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1332 return build_pointer_type (char_type_node);
1334 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1335 return build_pointer_type (integer_type_node);
1337 #ifdef VECTOR_MODE_SUPPORTED_P
1338 if (VECTOR_MODE_SUPPORTED_P (mode))
1343 return unsignedp ? unsigned_V16QI_type_node : V16QI_type_node;
1345 return unsignedp ? unsigned_V8HI_type_node : V8HI_type_node;
1347 return unsignedp ? unsigned_V4SI_type_node : V4SI_type_node;
1349 return unsignedp ? unsigned_V2DI_type_node : V2DI_type_node;
1351 return unsignedp ? unsigned_V2SI_type_node : V2SI_type_node;
1353 return unsignedp ? unsigned_V4HI_type_node : V4HI_type_node;
1355 return unsignedp ? unsigned_V8QI_type_node : V8QI_type_node;
1357 return V16SF_type_node;
1359 return V4SF_type_node;
1361 return V2SF_type_node;
1363 return V2DF_type_node;
1373 /* Return an unsigned type the same as TYPE in other respects. */
1375 gfc_unsigned_type (tree type)
1377 tree type1 = TYPE_MAIN_VARIANT (type);
1378 if (type1 == signed_char_type_node || type1 == char_type_node)
1379 return unsigned_char_type_node;
1380 if (type1 == integer_type_node)
1381 return unsigned_type_node;
1382 if (type1 == short_integer_type_node)
1383 return short_unsigned_type_node;
1384 if (type1 == long_integer_type_node)
1385 return long_unsigned_type_node;
1386 if (type1 == long_long_integer_type_node)
1387 return long_long_unsigned_type_node;
1389 if (type1 == widest_integer_literal_type_node)
1390 return widest_unsigned_literal_type_node;
1392 #if HOST_BITS_PER_WIDE_INT >= 64
1393 if (type1 == intTI_type_node)
1394 return unsigned_intTI_type_node;
1396 if (type1 == intDI_type_node)
1397 return unsigned_intDI_type_node;
1398 if (type1 == intSI_type_node)
1399 return unsigned_intSI_type_node;
1400 if (type1 == intHI_type_node)
1401 return unsigned_intHI_type_node;
1402 if (type1 == intQI_type_node)
1403 return unsigned_intQI_type_node;
1405 return gfc_signed_or_unsigned_type (1, type);
1408 /* Return a signed type the same as TYPE in other respects. */
1411 gfc_signed_type (tree type)
1413 tree type1 = TYPE_MAIN_VARIANT (type);
1414 if (type1 == unsigned_char_type_node || type1 == char_type_node)
1415 return signed_char_type_node;
1416 if (type1 == unsigned_type_node)
1417 return integer_type_node;
1418 if (type1 == short_unsigned_type_node)
1419 return short_integer_type_node;
1420 if (type1 == long_unsigned_type_node)
1421 return long_integer_type_node;
1422 if (type1 == long_long_unsigned_type_node)
1423 return long_long_integer_type_node;
1425 if (type1 == widest_unsigned_literal_type_node)
1426 return widest_integer_literal_type_node;
1428 #if HOST_BITS_PER_WIDE_INT >= 64
1429 if (type1 == unsigned_intTI_type_node)
1430 return intTI_type_node;
1432 if (type1 == unsigned_intDI_type_node)
1433 return intDI_type_node;
1434 if (type1 == unsigned_intSI_type_node)
1435 return intSI_type_node;
1436 if (type1 == unsigned_intHI_type_node)
1437 return intHI_type_node;
1438 if (type1 == unsigned_intQI_type_node)
1439 return intQI_type_node;
1441 return gfc_signed_or_unsigned_type (0, type);
1444 /* Return a type the same as TYPE except unsigned or
1445 signed according to UNSIGNEDP. */
1448 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1450 if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1453 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1454 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1455 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1456 return unsignedp ? unsigned_type_node : integer_type_node;
1457 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1458 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1459 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1460 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1461 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1462 return (unsignedp ? long_long_unsigned_type_node
1463 : long_long_integer_type_node);
1465 if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1466 return (unsignedp ? widest_unsigned_literal_type_node
1467 : widest_integer_literal_type_node);
1469 #if HOST_BITS_PER_WIDE_INT >= 64
1470 if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1471 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1473 if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1474 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1475 if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1476 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1477 if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1478 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1479 if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1480 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1485 #include "gt-fortran-trans-types.h"