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"
41 #if (GFC_MAX_DIMENSIONS < 10)
42 #define GFC_RANK_DIGITS 1
43 #define GFC_RANK_PRINTF_FORMAT "%01d"
44 #elif (GFC_MAX_DIMENSIONS < 100)
45 #define GFC_RANK_DIGITS 2
46 #define GFC_RANK_PRINTF_FORMAT "%02d"
48 #error If you really need >99 dimensions, continue the sequence above...
51 static tree gfc_get_derived_type (gfc_symbol * derived);
53 tree gfc_array_index_type;
55 tree ppvoid_type_node;
57 tree gfc_character1_type_node;
58 tree gfc_strlen_type_node;
60 static GTY(()) tree gfc_desc_dim_type;
61 static GTY(()) tree gfc_max_array_element_size;
63 /* Arrays for all integral and real kinds. We'll fill this in at runtime
64 after the target has a chance to process command-line options. */
66 #define MAX_INT_KINDS 5
67 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
68 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
69 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
70 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
72 #define MAX_REAL_KINDS 4
73 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
74 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
75 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
77 /* The integer kind to use for array indices. This will be set to the
78 proper value based on target information from the backend. */
80 int gfc_index_integer_kind;
82 /* The default kinds of the various types. */
84 int gfc_default_integer_kind;
85 int gfc_default_real_kind;
86 int gfc_default_double_kind;
87 int gfc_default_character_kind;
88 int gfc_default_logical_kind;
89 int gfc_default_complex_kind;
92 /* Query the target to determine which machine modes are available for
93 computation. Choose KIND numbers for them. */
98 enum machine_mode mode;
100 bool saw_i4 = false, saw_i8 = false;
101 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
103 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
107 if (!targetm.scalar_mode_supported_p (mode))
110 /* The middle end doesn't support constants larger than 2*HWI.
111 Perhaps the target hook shouldn't have accepted these either,
112 but just to be safe... */
113 bitsize = GET_MODE_BITSIZE (mode);
114 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
117 if (i_index == MAX_INT_KINDS)
120 /* Let the kind equal the bit size divided by 8. This insulates the
121 programmer from the underlying byte size. */
129 gfc_integer_kinds[i_index].kind = kind;
130 gfc_integer_kinds[i_index].radix = 2;
131 gfc_integer_kinds[i_index].digits = bitsize - 1;
132 gfc_integer_kinds[i_index].bit_size = bitsize;
134 gfc_logical_kinds[i_index].kind = kind;
135 gfc_logical_kinds[i_index].bit_size = bitsize;
140 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
142 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
147 if (!targetm.scalar_mode_supported_p (mode))
150 /* Let the kind equal the precision divided by 8, rounding up. Again,
151 this insulates the programmer from the underlying byte size.
153 Also, it effectively deals with IEEE extended formats. There, the
154 total size of the type may equal 16, but it's got 6 bytes of padding
155 and the increased size can get in the way of a real IEEE quad format
156 which may also be supported by the target.
158 We round up so as to handle IA-64 __floatreg (RFmode), which is an
159 82 bit type. Not to be confused with __float80 (XFmode), which is
160 an 80 bit type also supported by IA-64. So XFmode should come out
161 to be kind=10, and RFmode should come out to be kind=11. Egads. */
163 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
172 /* Careful we don't stumble a wierd internal mode. */
173 if (r_index > 0 && gfc_real_kinds[r_index-1].kind == kind)
175 /* Or have too many modes for the allocated space. */
176 if (r_index == MAX_REAL_KINDS)
179 gfc_real_kinds[r_index].kind = kind;
180 gfc_real_kinds[r_index].radix = fmt->b;
181 gfc_real_kinds[r_index].digits = fmt->p;
182 gfc_real_kinds[r_index].min_exponent = fmt->emin;
183 gfc_real_kinds[r_index].max_exponent = fmt->emax;
184 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
188 /* Choose the default integer kind. We choose 4 unless the user
189 directs us otherwise. */
193 fatal_error ("integer kind=8 not available for -i8 option");
194 gfc_default_integer_kind = 8;
197 gfc_default_integer_kind = 4;
199 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
201 /* Choose the default real kind. Again, we choose 4 when possible. */
205 fatal_error ("real kind=8 not available for -r8 option");
206 gfc_default_real_kind = 8;
209 gfc_default_real_kind = 4;
211 gfc_default_real_kind = gfc_real_kinds[0].kind;
213 /* Choose the default double kind. If -r8 is specified, we use kind=16,
214 if it's available, otherwise we do not change anything. */
215 if (gfc_option.r8 && saw_r16)
216 gfc_default_double_kind = 16;
217 else if (saw_r4 && saw_r8)
218 gfc_default_double_kind = 8;
221 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
222 real ... occupies two contiguous numeric storage units.
224 Therefore we must be supplied a kind twice as large as we chose
225 for single precision. There are loopholes, in that double
226 precision must *occupy* two storage units, though it doesn't have
227 to *use* two storage units. Which means that you can make this
228 kind artificially wide by padding it. But at present there are
229 no GCC targets for which a two-word type does not exist, so we
230 just let gfc_validate_kind abort and tell us if something breaks. */
232 gfc_default_double_kind
233 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
236 /* The default logical kind is constrained to be the same as the
237 default integer kind. Similarly with complex and real. */
238 gfc_default_logical_kind = gfc_default_integer_kind;
239 gfc_default_complex_kind = gfc_default_real_kind;
241 /* Choose the smallest integer kind for our default character. */
242 gfc_default_character_kind = gfc_integer_kinds[0].kind;
244 /* Choose the integer kind the same size as "void*" for our index kind. */
245 gfc_index_integer_kind = POINTER_SIZE / 8;
246 /* Pick a kind the same size as the C "int" type. */
247 gfc_c_int_kind = INT_TYPE_SIZE / 8;
250 /* Make sure that a valid kind is present. Returns an index into the
251 associated kinds array, -1 if the kind is not present. */
254 validate_integer (int kind)
258 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
259 if (gfc_integer_kinds[i].kind == kind)
266 validate_real (int kind)
270 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
271 if (gfc_real_kinds[i].kind == kind)
278 validate_logical (int kind)
282 for (i = 0; gfc_logical_kinds[i].kind; i++)
283 if (gfc_logical_kinds[i].kind == kind)
290 validate_character (int kind)
292 return kind == gfc_default_character_kind ? 0 : -1;
295 /* Validate a kind given a basic type. The return value is the same
296 for the child functions, with -1 indicating nonexistence of the
297 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
300 gfc_validate_kind (bt type, int kind, bool may_fail)
306 case BT_REAL: /* Fall through */
308 rc = validate_real (kind);
311 rc = validate_integer (kind);
314 rc = validate_logical (kind);
317 rc = validate_character (kind);
321 gfc_internal_error ("gfc_validate_kind(): Got bad type");
324 if (rc < 0 && !may_fail)
325 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
331 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
332 Reuse common type nodes where possible. Recognize if the kind matches up
333 with a C type. This will be used later in determining which routines may
334 be scarfed from libm. */
337 gfc_build_int_type (gfc_integer_info *info)
339 int mode_precision = info->bit_size;
341 if (mode_precision == CHAR_TYPE_SIZE)
343 if (mode_precision == SHORT_TYPE_SIZE)
345 if (mode_precision == INT_TYPE_SIZE)
347 if (mode_precision == LONG_TYPE_SIZE)
349 if (mode_precision == LONG_LONG_TYPE_SIZE)
350 info->c_long_long = 1;
352 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
353 return intQI_type_node;
354 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
355 return intHI_type_node;
356 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
357 return intSI_type_node;
358 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
359 return intDI_type_node;
360 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
361 return intTI_type_node;
363 return make_signed_type (mode_precision);
367 gfc_build_real_type (gfc_real_info *info)
369 int mode_precision = info->mode_precision;
372 if (mode_precision == FLOAT_TYPE_SIZE)
374 if (mode_precision == DOUBLE_TYPE_SIZE)
376 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
377 info->c_long_double = 1;
379 if (TYPE_PRECISION (float_type_node) == mode_precision)
380 return float_type_node;
381 if (TYPE_PRECISION (double_type_node) == mode_precision)
382 return double_type_node;
383 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
384 return long_double_type_node;
386 new_type = make_node (REAL_TYPE);
387 TYPE_PRECISION (new_type) = mode_precision;
388 layout_type (new_type);
393 gfc_build_complex_type (tree scalar_type)
397 if (scalar_type == NULL)
399 if (scalar_type == float_type_node)
400 return complex_float_type_node;
401 if (scalar_type == double_type_node)
402 return complex_double_type_node;
403 if (scalar_type == long_double_type_node)
404 return complex_long_double_type_node;
406 new_type = make_node (COMPLEX_TYPE);
407 TREE_TYPE (new_type) = scalar_type;
408 layout_type (new_type);
413 gfc_build_logical_type (gfc_logical_info *info)
415 int bit_size = info->bit_size;
418 if (bit_size == BOOL_TYPE_SIZE)
421 return boolean_type_node;
424 new_type = make_unsigned_type (bit_size);
425 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
426 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
427 TYPE_PRECISION (new_type) = 1;
433 /* Return the bit size of the C "size_t". */
439 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
440 return INT_TYPE_SIZE;
441 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
442 return LONG_TYPE_SIZE;
443 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
444 return SHORT_TYPE_SIZE;
447 return LONG_TYPE_SIZE;
452 /* Create the backend type nodes. We map them to their
453 equivalent C type, at least for now. We also give
454 names to the types here, and we push them in the
455 global binding level context.*/
458 gfc_init_types (void)
464 unsigned HOST_WIDE_INT hi;
465 unsigned HOST_WIDE_INT lo;
467 /* Create and name the types. */
468 #define PUSH_TYPE(name, node) \
469 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
471 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
473 type = gfc_build_int_type (&gfc_integer_kinds[index]);
474 gfc_integer_types[index] = type;
475 snprintf (name_buf, sizeof(name_buf), "int%d",
476 gfc_integer_kinds[index].kind);
477 PUSH_TYPE (name_buf, type);
480 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
482 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
483 gfc_logical_types[index] = type;
484 snprintf (name_buf, sizeof(name_buf), "logical%d",
485 gfc_logical_kinds[index].kind);
486 PUSH_TYPE (name_buf, type);
489 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
491 type = gfc_build_real_type (&gfc_real_kinds[index]);
492 gfc_real_types[index] = type;
493 snprintf (name_buf, sizeof(name_buf), "real%d",
494 gfc_real_kinds[index].kind);
495 PUSH_TYPE (name_buf, type);
497 type = gfc_build_complex_type (type);
498 gfc_complex_types[index] = type;
499 snprintf (name_buf, sizeof(name_buf), "complex%d",
500 gfc_real_kinds[index].kind);
501 PUSH_TYPE (name_buf, type);
504 gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
505 PUSH_TYPE ("char", gfc_character1_type_node);
507 PUSH_TYPE ("byte", unsigned_char_type_node);
508 PUSH_TYPE ("void", void_type_node);
510 /* DBX debugging output gets upset if these aren't set. */
511 if (!TYPE_NAME (integer_type_node))
512 PUSH_TYPE ("c_integer", integer_type_node);
513 if (!TYPE_NAME (char_type_node))
514 PUSH_TYPE ("c_char", char_type_node);
518 pvoid_type_node = build_pointer_type (void_type_node);
519 ppvoid_type_node = build_pointer_type (pvoid_type_node);
520 pchar_type_node = build_pointer_type (gfc_character1_type_node);
522 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
524 /* The maximum array element size that can be handled is determined
525 by the number of bits available to store this field in the array
528 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
529 lo = ~ (unsigned HOST_WIDE_INT) 0;
530 if (n > HOST_BITS_PER_WIDE_INT)
531 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
533 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
534 gfc_max_array_element_size
535 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
537 size_type_node = gfc_array_index_type;
539 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
540 boolean_true_node = build_int_cst (boolean_type_node, 1);
541 boolean_false_node = build_int_cst (boolean_type_node, 0);
543 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
544 gfc_strlen_type_node = gfc_get_int_type (4);
547 /* Get the type node for the given type and kind. */
550 gfc_get_int_type (int kind)
552 int index = gfc_validate_kind (BT_INTEGER, kind, false);
553 return gfc_integer_types[index];
557 gfc_get_real_type (int kind)
559 int index = gfc_validate_kind (BT_REAL, kind, false);
560 return gfc_real_types[index];
564 gfc_get_complex_type (int kind)
566 int index = gfc_validate_kind (BT_COMPLEX, kind, false);
567 return gfc_complex_types[index];
571 gfc_get_logical_type (int kind)
573 int index = gfc_validate_kind (BT_LOGICAL, kind, false);
574 return gfc_logical_types[index];
577 /* Create a character type with the given kind and length. */
580 gfc_get_character_type_len (int kind, tree len)
584 gfc_validate_kind (BT_CHARACTER, kind, false);
586 bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
587 type = build_array_type (gfc_character1_type_node, bounds);
588 TYPE_STRING_FLAG (type) = 1;
594 /* Get a type node for a character kind. */
597 gfc_get_character_type (int kind, gfc_charlen * cl)
601 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
603 return gfc_get_character_type_len (kind, len);
606 /* Covert a basic type. This will be an array for character types. */
609 gfc_typenode_for_spec (gfc_typespec * spec)
620 basetype = gfc_get_int_type (spec->kind);
624 basetype = gfc_get_real_type (spec->kind);
628 basetype = gfc_get_complex_type (spec->kind);
632 basetype = gfc_get_logical_type (spec->kind);
636 basetype = gfc_get_character_type (spec->kind, spec->cl);
640 basetype = gfc_get_derived_type (spec->derived);
650 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
653 gfc_conv_array_bound (gfc_expr * expr)
655 /* If expr is an integer constant, return that. */
656 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
657 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
659 /* Otherwise return NULL. */
664 gfc_get_element_type (tree type)
668 if (GFC_ARRAY_TYPE_P (type))
670 if (TREE_CODE (type) == POINTER_TYPE)
671 type = TREE_TYPE (type);
672 assert (TREE_CODE (type) == ARRAY_TYPE);
673 element = TREE_TYPE (type);
677 assert (GFC_DESCRIPTOR_TYPE_P (type));
678 element = TREE_TYPE (TYPE_FIELDS (type));
680 assert (TREE_CODE (element) == POINTER_TYPE);
681 element = TREE_TYPE (element);
683 assert (TREE_CODE (element) == ARRAY_TYPE);
684 element = TREE_TYPE (element);
690 /* Build an array. This function is called from gfc_sym_type().
691 Actually returns array descriptor type.
693 Format of array descriptors is as follows:
695 struct gfc_array_descriptor
700 struct descriptor_dimension dimension[N_DIM];
703 struct descriptor_dimension
710 Translation code should use gfc_conv_descriptor_* rather than accessing
711 the descriptor directly. Any changes to the array descriptor type will
712 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
714 This is represented internally as a RECORD_TYPE. The index nodes are
715 gfc_array_index_type and the data node is a pointer to the data. See below
716 for the handling of character types.
718 The dtype member is formatted as follows:
719 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
720 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
721 size = dtype >> GFC_DTYPE_SIZE_SHIFT
723 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
724 generated poor code for assumed/deferred size arrays. These require
725 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
726 grammar. Also, there is no way to explicitly set the array stride, so
727 all data must be packed(1). I've tried to mark all the functions which
728 would require modification with a GCC ARRAYS comment.
730 The data component points to the first element in the array.
731 The offset field is the position of the origin of the array
732 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
734 An element is accessed by
735 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
736 This gives good performance as the computation does not involve the
737 bounds of the array. For packed arrays, this is optimized further by
738 substituting the known strides.
740 This system has one problem: all array bounds must be withing 2^31 elements
741 of the origin (2^63 on 64-bit machines). For example
742 integer, dimension (80000:90000, 80000:90000, 2) :: array
743 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
744 the calculation for stride02 would overflow. This may still work, but
745 I haven't checked, and it relies on the overflow doing the right thing.
747 The way to fix this problem is to access alements as follows:
748 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
749 Obviously this is much slower. I will make this a compile time option,
750 something like -fsmall-array-offsets. Mixing code compiled with and without
751 this switch will work.
753 (1) This can be worked around by modifying the upper bound of the previous
754 dimension. This requires extra fields in the descriptor (both real_ubound
755 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
756 may allow us to do this. However I can't find mention of this anywhere
760 /* Returns true if the array sym does not require a descriptor. */
763 gfc_is_nodesc_array (gfc_symbol * sym)
765 assert (sym->attr.dimension);
767 /* We only want local arrays. */
768 if (sym->attr.pointer || sym->attr.allocatable)
773 if (sym->as->type != AS_ASSUMED_SHAPE)
779 if (sym->attr.result || sym->attr.function)
782 if (sym->attr.pointer || sym->attr.allocatable)
785 assert (sym->as->type == AS_EXPLICIT);
791 /* Create an array descriptor type. */
794 gfc_build_array_type (tree type, gfc_array_spec * as)
796 tree lbound[GFC_MAX_DIMENSIONS];
797 tree ubound[GFC_MAX_DIMENSIONS];
800 for (n = 0; n < as->rank; n++)
802 /* Create expressions for the known bounds of the array. */
803 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
804 lbound[n] = gfc_index_one_node;
806 lbound[n] = gfc_conv_array_bound (as->lower[n]);
807 ubound[n] = gfc_conv_array_bound (as->upper[n]);
810 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
813 /* Returns the struct descriptor_dimension type. */
816 gfc_get_desc_dim_type (void)
822 if (gfc_desc_dim_type)
823 return gfc_desc_dim_type;
825 /* Build the type node. */
826 type = make_node (RECORD_TYPE);
828 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
829 TYPE_PACKED (type) = 1;
831 /* Consists of the stride, lbound and ubound members. */
832 decl = build_decl (FIELD_DECL,
833 get_identifier ("stride"), gfc_array_index_type);
834 DECL_CONTEXT (decl) = type;
837 decl = build_decl (FIELD_DECL,
838 get_identifier ("lbound"), gfc_array_index_type);
839 DECL_CONTEXT (decl) = type;
840 fieldlist = chainon (fieldlist, decl);
842 decl = build_decl (FIELD_DECL,
843 get_identifier ("ubound"), gfc_array_index_type);
844 DECL_CONTEXT (decl) = type;
845 fieldlist = chainon (fieldlist, decl);
847 /* Finish off the type. */
848 TYPE_FIELDS (type) = fieldlist;
850 gfc_finish_type (type);
852 gfc_desc_dim_type = type;
857 gfc_get_dtype (tree type, int rank)
865 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
866 return (GFC_TYPE_ARRAY_DTYPE (type));
868 /* TODO: Correctly identify LOGICAL types. */
869 switch (TREE_CODE (type))
872 n = GFC_DTYPE_INTEGER;
876 n = GFC_DTYPE_LOGICAL;
884 n = GFC_DTYPE_COMPLEX;
887 /* Arrays have already been dealt with. */
889 n = GFC_DTYPE_DERIVED;
893 n = GFC_DTYPE_CHARACTER;
897 /* TODO: Don't do dtype for temporary descriptorless arrays. */
898 /* We can strange array types for temporary arrays. */
899 return gfc_index_zero_node;
902 assert (rank <= GFC_DTYPE_RANK_MASK);
903 size = TYPE_SIZE_UNIT (type);
905 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
906 if (size && INTEGER_CST_P (size))
908 if (tree_int_cst_lt (gfc_max_array_element_size, size))
909 internal_error ("Array element size too big");
911 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
913 dtype = build_int_cst (gfc_array_index_type, i);
915 if (size && !INTEGER_CST_P (size))
917 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
918 tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
919 dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
921 /* If we don't know the size we leave it as zero. This should never happen
922 for anything that is actually used. */
923 /* TODO: Check this is actually true, particularly when repacking
924 assumed size parameters. */
930 /* Build an array type for use without a descriptor. Valid values of packed
931 are 0=no, 1=partial, 2=full, 3=static. */
934 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
947 mpz_init_set_ui (offset, 0);
948 mpz_init_set_ui (stride, 1);
951 /* We don't use build_array_type because this does not include include
952 lang-specific information (ie. the bounds of the array) when checking
954 type = make_node (ARRAY_TYPE);
956 GFC_ARRAY_TYPE_P (type) = 1;
957 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
958 ggc_alloc_cleared (sizeof (struct lang_type));
960 known_stride = (packed != 0);
962 for (n = 0; n < as->rank; n++)
964 /* Fill in the stride and bound components of the type. */
966 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
969 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
972 if (expr->expr_type == EXPR_CONSTANT)
974 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
975 gfc_index_integer_kind);
982 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
986 /* Calculate the offset. */
987 mpz_mul (delta, stride, as->lower[n]->value.integer);
988 mpz_sub (offset, offset, delta);
994 if (expr && expr->expr_type == EXPR_CONSTANT)
996 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
997 gfc_index_integer_kind);
1004 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1008 /* Calculate the stride. */
1009 mpz_sub (delta, as->upper[n]->value.integer,
1010 as->lower[n]->value.integer);
1011 mpz_add_ui (delta, delta, 1);
1012 mpz_mul (stride, stride, delta);
1015 /* Only the first stride is known for partial packed arrays. */
1022 GFC_TYPE_ARRAY_OFFSET (type) =
1023 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1026 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1030 GFC_TYPE_ARRAY_SIZE (type) =
1031 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1034 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1036 GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
1037 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1038 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1040 /* TODO: use main type if it is unbounded. */
1041 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1042 build_pointer_type (build_array_type (etype, range));
1046 mpz_sub_ui (stride, stride, 1);
1047 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1052 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1053 TYPE_DOMAIN (type) = range;
1055 build_pointer_type (etype);
1056 TREE_TYPE (type) = etype;
1064 if (packed < 3 || !known_stride)
1066 /* For dummy arrays and automatic (heap allocated) arrays we
1067 want a pointer to the array. */
1068 type = build_pointer_type (type);
1069 GFC_ARRAY_TYPE_P (type) = 1;
1070 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1076 /* Build an array (descriptor) type with given bounds. */
1079 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1080 tree * ubound, int packed)
1082 tree fat_type, fat_pointer_type;
1087 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1088 const char *typename;
1094 /* Build the type node. */
1095 fat_type = make_node (RECORD_TYPE);
1096 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1097 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1098 ggc_alloc_cleared (sizeof (struct lang_type));
1099 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1100 GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
1102 tmp = TYPE_NAME (etype);
1103 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1104 tmp = DECL_NAME (tmp);
1106 typename = IDENTIFIER_POINTER (tmp);
1108 typename = "unknown";
1110 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1111 GFC_MAX_SYMBOL_LEN, typename);
1112 TYPE_NAME (fat_type) = get_identifier (name);
1113 TYPE_PACKED (fat_type) = 0;
1115 fat_pointer_type = build_pointer_type (fat_type);
1117 /* Build an array descriptor record type. */
1119 stride = gfc_index_one_node;
1123 for (n = 0; n < dimen; n++)
1125 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1132 if (lower != NULL_TREE)
1134 if (INTEGER_CST_P (lower))
1135 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1141 if (upper != NULL_TREE)
1143 if (INTEGER_CST_P (upper))
1144 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1149 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1151 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, upper, lower));
1152 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1153 gfc_index_one_node));
1155 fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, stride));
1156 /* Check the folding worked. */
1157 assert (INTEGER_CST_P (stride));
1162 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1163 /* TODO: known offsets for descriptors. */
1164 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1166 /* We define data as an unknown size array. Much better than doing
1167 pointer arithmetic. */
1169 build_array_type (etype,
1170 build_range_type (gfc_array_index_type,
1171 gfc_index_zero_node, NULL_TREE));
1172 arraytype = build_pointer_type (arraytype);
1173 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1175 /* The pointer to the array data. */
1176 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
1178 DECL_CONTEXT (decl) = fat_type;
1179 /* Add the data member as the first element of the descriptor. */
1182 /* Add the base component. */
1183 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1184 gfc_array_index_type);
1185 DECL_CONTEXT (decl) = fat_type;
1186 fieldlist = chainon (fieldlist, decl);
1188 /* Add the dtype component. */
1189 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1190 gfc_array_index_type);
1191 DECL_CONTEXT (decl) = fat_type;
1192 fieldlist = chainon (fieldlist, decl);
1194 /* Build the array type for the stride and bound components. */
1196 build_array_type (gfc_get_desc_dim_type (),
1197 build_range_type (gfc_array_index_type,
1198 gfc_index_zero_node,
1199 gfc_rank_cst[dimen - 1]));
1201 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1202 DECL_CONTEXT (decl) = fat_type;
1203 DECL_INITIAL (decl) = NULL_TREE;
1204 fieldlist = chainon (fieldlist, decl);
1206 /* Finish off the type. */
1207 TYPE_FIELDS (fat_type) = fieldlist;
1209 gfc_finish_type (fat_type);
1214 /* Build a pointer type. This function is called from gfc_sym_type(). */
1217 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1219 /* Array pointer types aren't actually pointers. */
1220 if (sym->attr.dimension)
1223 return build_pointer_type (type);
1226 /* Return the type for a symbol. Special handling is required for character
1227 types to get the correct level of indirection.
1228 For functions return the return type.
1229 For subroutines return void_type_node.
1230 Calling this multiple times for the same symbol should be avoided,
1231 especially for character and array types. */
1234 gfc_sym_type (gfc_symbol * sym)
1239 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1240 return void_type_node;
1242 if (sym->backend_decl)
1244 if (sym->attr.function)
1245 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
1247 return TREE_TYPE (sym->backend_decl);
1250 /* The frontend doesn't set all the attributes for a function with an
1251 explicit result value, so we use that instead when present. */
1252 if (sym->attr.function && sym->result)
1255 type = gfc_typenode_for_spec (&sym->ts);
1257 if (sym->attr.dummy && !sym->attr.function)
1262 if (sym->attr.dimension)
1264 if (gfc_is_nodesc_array (sym))
1266 /* If this is a character argument of unknown length, just use the
1268 if (sym->ts.type != BT_CHARACTER
1269 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
1270 || sym->ts.cl->backend_decl)
1272 type = gfc_get_nodesc_array_type (type, sym->as,
1278 type = gfc_build_array_type (type, sym->as);
1282 if (sym->attr.allocatable || sym->attr.pointer)
1283 type = gfc_build_pointer_type (sym, type);
1286 /* We currently pass all parameters by reference.
1287 See f95_get_function_decl. For dummy function parameters return the
1291 /* We must use pointer types for potentially absent variables. The
1292 optimizers assume a reference type argument is never NULL. */
1293 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1294 type = build_pointer_type (type);
1296 type = build_reference_type (type);
1302 /* Layout and output debug info for a record type. */
1305 gfc_finish_type (tree type)
1309 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1310 TYPE_STUB_DECL (type) = decl;
1312 rest_of_type_compilation (type, 1);
1313 rest_of_decl_compilation (decl, 1, 0);
1316 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1317 or RECORD_TYPE pointed to by STYPE. The new field is chained
1318 to the fieldlist pointed to by FIELDLIST.
1320 Returns a pointer to the new field. */
1323 gfc_add_field_to_struct (tree *fieldlist, tree context,
1324 tree name, tree type)
1328 decl = build_decl (FIELD_DECL, name, type);
1330 DECL_CONTEXT (decl) = context;
1331 DECL_INITIAL (decl) = 0;
1332 DECL_ALIGN (decl) = 0;
1333 DECL_USER_ALIGN (decl) = 0;
1334 TREE_CHAIN (decl) = NULL_TREE;
1335 *fieldlist = chainon (*fieldlist, decl);
1341 /* Build a tree node for a derived type. */
1344 gfc_get_derived_type (gfc_symbol * derived)
1346 tree typenode, field, field_type, fieldlist;
1349 assert (derived && derived->attr.flavor == FL_DERIVED);
1351 /* derived->backend_decl != 0 means we saw it before, but its
1352 components' backend_decl may have not been built. */
1353 if (derived->backend_decl)
1355 /* Its components' backend_decl have been built. */
1356 if (TYPE_FIELDS (derived->backend_decl))
1357 return derived->backend_decl;
1359 typenode = derived->backend_decl;
1363 /* We see this derived type first time, so build the type node. */
1364 typenode = make_node (RECORD_TYPE);
1365 TYPE_NAME (typenode) = get_identifier (derived->name);
1366 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1367 derived->backend_decl = typenode;
1370 /* Build the type member list. Install the newly created RECORD_TYPE
1371 node as DECL_CONTEXT of each FIELD_DECL. */
1372 fieldlist = NULL_TREE;
1373 for (c = derived->components; c; c = c->next)
1375 if (c->ts.type == BT_DERIVED && c->pointer)
1377 if (c->ts.derived->backend_decl)
1378 field_type = c->ts.derived->backend_decl;
1381 /* Build the type node. */
1382 field_type = make_node (RECORD_TYPE);
1383 TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1384 TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1385 c->ts.derived->backend_decl = field_type;
1390 if (c->ts.type == BT_CHARACTER)
1392 /* Evaluate the string length. */
1393 gfc_conv_const_charlen (c->ts.cl);
1394 assert (c->ts.cl->backend_decl);
1397 field_type = gfc_typenode_for_spec (&c->ts);
1400 /* This returns an array descriptor type. Initialisation may be
1406 /* Pointers to arrays aren't actualy pointer types. The
1407 descriptors are seperate, but the data is common. */
1408 field_type = gfc_build_array_type (field_type, c->as);
1411 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1413 else if (c->pointer)
1414 field_type = build_pointer_type (field_type);
1416 field = gfc_add_field_to_struct (&fieldlist, typenode,
1417 get_identifier (c->name),
1420 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1422 assert (!c->backend_decl);
1423 c->backend_decl = field;
1426 /* Now we have the final fieldlist. Record it, then lay out the
1427 derived type, including the fields. */
1428 TYPE_FIELDS (typenode) = fieldlist;
1430 gfc_finish_type (typenode);
1432 derived->backend_decl = typenode;
1438 gfc_return_by_reference (gfc_symbol * sym)
1440 if (!sym->attr.function)
1443 assert (sym->attr.function);
1448 if (sym->attr.dimension)
1451 if (sym->ts.type == BT_CHARACTER)
1454 if (sym->ts.type == BT_DERIVED)
1455 gfc_todo_error ("Returning derived types");
1456 /* Possibly return derived types by reference. */
1461 gfc_get_function_type (gfc_symbol * sym)
1465 gfc_formal_arglist *f;
1468 int alternate_return;
1470 /* Make sure this symbol is a function or a subroutine. */
1471 assert (sym->attr.flavor == FL_PROCEDURE);
1473 if (sym->backend_decl)
1474 return TREE_TYPE (sym->backend_decl);
1477 alternate_return = 0;
1478 typelist = NULL_TREE;
1480 if (sym->attr.entry_master)
1482 /* Additional parameter for selecting an entry point. */
1483 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1486 /* Some functions we use an extra parameter for the return value. */
1487 if (gfc_return_by_reference (sym))
1494 if (arg->ts.type == BT_CHARACTER)
1495 gfc_conv_const_charlen (arg->ts.cl);
1497 type = gfc_sym_type (arg);
1498 if (arg->ts.type == BT_DERIVED
1499 || arg->attr.dimension
1500 || arg->ts.type == BT_CHARACTER)
1501 type = build_reference_type (type);
1503 typelist = gfc_chainon_list (typelist, type);
1504 if (arg->ts.type == BT_CHARACTER)
1505 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1508 /* Build the argument types for the function. */
1509 for (f = sym->formal; f; f = f->next)
1514 /* Evaluate constant character lengths here so that they can be
1515 included in the type. */
1516 if (arg->ts.type == BT_CHARACTER)
1517 gfc_conv_const_charlen (arg->ts.cl);
1519 if (arg->attr.flavor == FL_PROCEDURE)
1521 type = gfc_get_function_type (arg);
1522 type = build_pointer_type (type);
1525 type = gfc_sym_type (arg);
1527 /* Parameter Passing Convention
1529 We currently pass all parameters by reference.
1530 Parameters with INTENT(IN) could be passed by value.
1531 The problem arises if a function is called via an implicit
1532 prototype. In this situation the INTENT is not known.
1533 For this reason all parameters to global functions must be
1534 passed by reference. Passing by value would potentialy
1535 generate bad code. Worse there would be no way of telling that
1536 this code was bad, except that it would give incorrect results.
1538 Contained procedures could pass by value as these are never
1539 used without an explicit interface, and connot be passed as
1540 actual parameters for a dummy procedure. */
1541 if (arg->ts.type == BT_CHARACTER)
1543 typelist = gfc_chainon_list (typelist, type);
1547 if (sym->attr.subroutine)
1548 alternate_return = 1;
1552 /* Add hidden string length parameters. */
1554 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1556 typelist = gfc_chainon_list (typelist, void_type_node);
1558 if (alternate_return)
1559 type = integer_type_node;
1560 else if (!sym->attr.function || gfc_return_by_reference (sym))
1561 type = void_type_node;
1563 type = gfc_sym_type (sym);
1565 type = build_function_type (type, typelist);
1570 /* Language hooks for middle-end access to type nodes. */
1572 /* Return an integer type with BITS bits of precision,
1573 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1576 gfc_type_for_size (unsigned bits, int unsignedp)
1581 for (i = 0; i <= MAX_INT_KINDS; ++i)
1583 tree type = gfc_integer_types[i];
1584 if (type && bits == TYPE_PRECISION (type))
1590 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1591 return unsigned_intQI_type_node;
1592 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1593 return unsigned_intHI_type_node;
1594 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1595 return unsigned_intSI_type_node;
1596 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1597 return unsigned_intDI_type_node;
1598 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1599 return unsigned_intTI_type_node;
1605 /* Return a data type that has machine mode MODE. If the mode is an
1606 integer, then UNSIGNEDP selects between signed and unsigned types. */
1609 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1614 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1615 base = gfc_real_types;
1616 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1617 base = gfc_complex_types;
1618 else if (SCALAR_INT_MODE_P (mode))
1619 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1620 else if (VECTOR_MODE_P (mode))
1622 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1623 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1624 if (inner_type != NULL_TREE)
1625 return build_vector_type_for_mode (inner_type, mode);
1631 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1633 tree type = base[i];
1634 if (type && mode == TYPE_MODE (type))
1641 /* Return a type the same as TYPE except unsigned or
1642 signed according to UNSIGNEDP. */
1645 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1647 if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
1650 return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
1653 /* Return an unsigned type the same as TYPE in other respects. */
1656 gfc_unsigned_type (tree type)
1658 return gfc_signed_or_unsigned_type (1, type);
1661 /* Return a signed type the same as TYPE in other respects. */
1664 gfc_signed_type (tree type)
1666 return gfc_signed_or_unsigned_type (0, type);
1669 #include "gt-fortran-trans-types.h"