1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-types.c -- gfortran backend types */
28 #include "coretypes.h"
36 #include "trans-types.h"
37 #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;
54 tree gfc_array_range_type;
55 tree gfc_character1_type_node;
57 tree ppvoid_type_node;
60 tree gfc_charlen_type_node;
62 static GTY(()) tree gfc_desc_dim_type;
63 static GTY(()) tree gfc_max_array_element_size;
64 static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
66 /* Arrays for all integral and real kinds. We'll fill this in at runtime
67 after the target has a chance to process command-line options. */
69 #define MAX_INT_KINDS 5
70 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
71 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
72 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
73 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
75 #define MAX_REAL_KINDS 5
76 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
77 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
78 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
80 /* The integer kind to use for array indices. This will be set to the
81 proper value based on target information from the backend. */
83 int gfc_index_integer_kind;
85 /* The default kinds of the various types. */
87 int gfc_default_integer_kind;
88 int gfc_max_integer_kind;
89 int gfc_default_real_kind;
90 int gfc_default_double_kind;
91 int gfc_default_character_kind;
92 int gfc_default_logical_kind;
93 int gfc_default_complex_kind;
96 /* The kind size used for record offsets. If the target system supports
97 kind=8, this will be set to 8, otherwise it is set to 4. */
100 /* Query the target to determine which machine modes are available for
101 computation. Choose KIND numbers for them. */
104 gfc_init_kinds (void)
106 enum machine_mode mode;
107 int i_index, r_index;
108 bool saw_i4 = false, saw_i8 = false;
109 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
111 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
115 if (!targetm.scalar_mode_supported_p (mode))
118 /* The middle end doesn't support constants larger than 2*HWI.
119 Perhaps the target hook shouldn't have accepted these either,
120 but just to be safe... */
121 bitsize = GET_MODE_BITSIZE (mode);
122 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
125 gcc_assert (i_index != MAX_INT_KINDS);
127 /* Let the kind equal the bit size divided by 8. This insulates the
128 programmer from the underlying byte size. */
136 gfc_integer_kinds[i_index].kind = kind;
137 gfc_integer_kinds[i_index].radix = 2;
138 gfc_integer_kinds[i_index].digits = bitsize - 1;
139 gfc_integer_kinds[i_index].bit_size = bitsize;
141 gfc_logical_kinds[i_index].kind = kind;
142 gfc_logical_kinds[i_index].bit_size = bitsize;
147 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
148 used for large file access. */
155 /* If we do not at least have kind = 4, everything is pointless. */
158 /* Set the maximum integer kind. Used with at least BOZ constants. */
159 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
161 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
163 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
168 if (!targetm.scalar_mode_supported_p (mode))
171 /* Only let float/double/long double go through because the fortran
172 library assumes these are the only floating point types. */
174 if (mode != TYPE_MODE (float_type_node)
175 && (mode != TYPE_MODE (double_type_node))
176 && (mode != TYPE_MODE (long_double_type_node)))
179 /* Let the kind equal the precision divided by 8, rounding up. Again,
180 this insulates the programmer from the underlying byte size.
182 Also, it effectively deals with IEEE extended formats. There, the
183 total size of the type may equal 16, but it's got 6 bytes of padding
184 and the increased size can get in the way of a real IEEE quad format
185 which may also be supported by the target.
187 We round up so as to handle IA-64 __floatreg (RFmode), which is an
188 82 bit type. Not to be confused with __float80 (XFmode), which is
189 an 80 bit type also supported by IA-64. So XFmode should come out
190 to be kind=10, and RFmode should come out to be kind=11. Egads. */
192 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
201 /* Careful we don't stumble a wierd internal mode. */
202 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
203 /* Or have too many modes for the allocated space. */
204 gcc_assert (r_index != MAX_REAL_KINDS);
206 gfc_real_kinds[r_index].kind = kind;
207 gfc_real_kinds[r_index].radix = fmt->b;
208 gfc_real_kinds[r_index].digits = fmt->p;
209 gfc_real_kinds[r_index].min_exponent = fmt->emin;
210 gfc_real_kinds[r_index].max_exponent = fmt->emax;
211 if (fmt->pnan < fmt->p)
212 /* This is an IBM extended double format (or the MIPS variant)
213 made up of two IEEE doubles. The value of the long double is
214 the sum of the values of the two parts. The most significant
215 part is required to be the value of the long double rounded
216 to the nearest double. If we use emax of 1024 then we can't
217 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
218 rounding will make the most significant part overflow. */
219 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
220 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
224 /* Choose the default integer kind. We choose 4 unless the user
225 directs us otherwise. */
226 if (gfc_option.flag_default_integer)
229 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
230 gfc_default_integer_kind = 8;
233 gfc_default_integer_kind = 4;
235 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
237 /* Choose the default real kind. Again, we choose 4 when possible. */
238 if (gfc_option.flag_default_real)
241 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
242 gfc_default_real_kind = 8;
245 gfc_default_real_kind = 4;
247 gfc_default_real_kind = gfc_real_kinds[0].kind;
249 /* Choose the default double kind. If -fdefault-real and -fdefault-double
250 are specified, we use kind=8, if it's available. If -fdefault-real is
251 specified without -fdefault-double, we use kind=16, if it's available.
252 Otherwise we do not change anything. */
253 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
254 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
256 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
257 gfc_default_double_kind = 8;
258 else if (gfc_option.flag_default_real && saw_r16)
259 gfc_default_double_kind = 16;
260 else if (saw_r4 && saw_r8)
261 gfc_default_double_kind = 8;
264 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
265 real ... occupies two contiguous numeric storage units.
267 Therefore we must be supplied a kind twice as large as we chose
268 for single precision. There are loopholes, in that double
269 precision must *occupy* two storage units, though it doesn't have
270 to *use* two storage units. Which means that you can make this
271 kind artificially wide by padding it. But at present there are
272 no GCC targets for which a two-word type does not exist, so we
273 just let gfc_validate_kind abort and tell us if something breaks. */
275 gfc_default_double_kind
276 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
279 /* The default logical kind is constrained to be the same as the
280 default integer kind. Similarly with complex and real. */
281 gfc_default_logical_kind = gfc_default_integer_kind;
282 gfc_default_complex_kind = gfc_default_real_kind;
284 /* Choose the smallest integer kind for our default character. */
285 gfc_default_character_kind = gfc_integer_kinds[0].kind;
287 /* Choose the integer kind the same size as "void*" for our index kind. */
288 gfc_index_integer_kind = POINTER_SIZE / 8;
289 /* Pick a kind the same size as the C "int" type. */
290 gfc_c_int_kind = INT_TYPE_SIZE / 8;
293 /* Make sure that a valid kind is present. Returns an index into the
294 associated kinds array, -1 if the kind is not present. */
297 validate_integer (int kind)
301 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
302 if (gfc_integer_kinds[i].kind == kind)
309 validate_real (int kind)
313 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
314 if (gfc_real_kinds[i].kind == kind)
321 validate_logical (int kind)
325 for (i = 0; gfc_logical_kinds[i].kind; i++)
326 if (gfc_logical_kinds[i].kind == kind)
333 validate_character (int kind)
335 return kind == gfc_default_character_kind ? 0 : -1;
338 /* Validate a kind given a basic type. The return value is the same
339 for the child functions, with -1 indicating nonexistence of the
340 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
343 gfc_validate_kind (bt type, int kind, bool may_fail)
349 case BT_REAL: /* Fall through */
351 rc = validate_real (kind);
354 rc = validate_integer (kind);
357 rc = validate_logical (kind);
360 rc = validate_character (kind);
364 gfc_internal_error ("gfc_validate_kind(): Got bad type");
367 if (rc < 0 && !may_fail)
368 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
374 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
375 Reuse common type nodes where possible. Recognize if the kind matches up
376 with a C type. This will be used later in determining which routines may
377 be scarfed from libm. */
380 gfc_build_int_type (gfc_integer_info *info)
382 int mode_precision = info->bit_size;
384 if (mode_precision == CHAR_TYPE_SIZE)
386 if (mode_precision == SHORT_TYPE_SIZE)
388 if (mode_precision == INT_TYPE_SIZE)
390 if (mode_precision == LONG_TYPE_SIZE)
392 if (mode_precision == LONG_LONG_TYPE_SIZE)
393 info->c_long_long = 1;
395 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
396 return intQI_type_node;
397 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
398 return intHI_type_node;
399 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
400 return intSI_type_node;
401 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
402 return intDI_type_node;
403 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
404 return intTI_type_node;
406 return make_signed_type (mode_precision);
410 gfc_build_real_type (gfc_real_info *info)
412 int mode_precision = info->mode_precision;
415 if (mode_precision == FLOAT_TYPE_SIZE)
417 if (mode_precision == DOUBLE_TYPE_SIZE)
419 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
420 info->c_long_double = 1;
422 if (TYPE_PRECISION (float_type_node) == mode_precision)
423 return float_type_node;
424 if (TYPE_PRECISION (double_type_node) == mode_precision)
425 return double_type_node;
426 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
427 return long_double_type_node;
429 new_type = make_node (REAL_TYPE);
430 TYPE_PRECISION (new_type) = mode_precision;
431 layout_type (new_type);
436 gfc_build_complex_type (tree scalar_type)
440 if (scalar_type == NULL)
442 if (scalar_type == float_type_node)
443 return complex_float_type_node;
444 if (scalar_type == double_type_node)
445 return complex_double_type_node;
446 if (scalar_type == long_double_type_node)
447 return complex_long_double_type_node;
449 new_type = make_node (COMPLEX_TYPE);
450 TREE_TYPE (new_type) = scalar_type;
451 layout_type (new_type);
456 gfc_build_logical_type (gfc_logical_info *info)
458 int bit_size = info->bit_size;
461 if (bit_size == BOOL_TYPE_SIZE)
464 return boolean_type_node;
467 new_type = make_unsigned_type (bit_size);
468 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
469 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
470 TYPE_PRECISION (new_type) = 1;
476 /* Return the bit size of the C "size_t". */
482 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
483 return INT_TYPE_SIZE;
484 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
485 return LONG_TYPE_SIZE;
486 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
487 return SHORT_TYPE_SIZE;
490 return LONG_TYPE_SIZE;
495 /* Create the backend type nodes. We map them to their
496 equivalent C type, at least for now. We also give
497 names to the types here, and we push them in the
498 global binding level context.*/
501 gfc_init_types (void)
507 unsigned HOST_WIDE_INT hi;
508 unsigned HOST_WIDE_INT lo;
510 /* Create and name the types. */
511 #define PUSH_TYPE(name, node) \
512 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
514 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
516 type = gfc_build_int_type (&gfc_integer_kinds[index]);
517 gfc_integer_types[index] = type;
518 snprintf (name_buf, sizeof(name_buf), "int%d",
519 gfc_integer_kinds[index].kind);
520 PUSH_TYPE (name_buf, type);
523 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
525 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
526 gfc_logical_types[index] = type;
527 snprintf (name_buf, sizeof(name_buf), "logical%d",
528 gfc_logical_kinds[index].kind);
529 PUSH_TYPE (name_buf, type);
532 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
534 type = gfc_build_real_type (&gfc_real_kinds[index]);
535 gfc_real_types[index] = type;
536 snprintf (name_buf, sizeof(name_buf), "real%d",
537 gfc_real_kinds[index].kind);
538 PUSH_TYPE (name_buf, type);
540 type = gfc_build_complex_type (type);
541 gfc_complex_types[index] = type;
542 snprintf (name_buf, sizeof(name_buf), "complex%d",
543 gfc_real_kinds[index].kind);
544 PUSH_TYPE (name_buf, type);
547 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
549 PUSH_TYPE ("char", gfc_character1_type_node);
551 PUSH_TYPE ("byte", unsigned_char_type_node);
552 PUSH_TYPE ("void", void_type_node);
554 /* DBX debugging output gets upset if these aren't set. */
555 if (!TYPE_NAME (integer_type_node))
556 PUSH_TYPE ("c_integer", integer_type_node);
557 if (!TYPE_NAME (char_type_node))
558 PUSH_TYPE ("c_char", char_type_node);
562 pvoid_type_node = build_pointer_type (void_type_node);
563 ppvoid_type_node = build_pointer_type (pvoid_type_node);
564 pchar_type_node = build_pointer_type (gfc_character1_type_node);
566 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
567 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
568 since this function is called before gfc_init_constants. */
570 = build_range_type (gfc_array_index_type,
571 build_int_cst (gfc_array_index_type, 0),
574 /* The maximum array element size that can be handled is determined
575 by the number of bits available to store this field in the array
578 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
579 lo = ~ (unsigned HOST_WIDE_INT) 0;
580 if (n > HOST_BITS_PER_WIDE_INT)
581 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
583 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
584 gfc_max_array_element_size
585 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
587 size_type_node = gfc_array_index_type;
589 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
590 boolean_true_node = build_int_cst (boolean_type_node, 1);
591 boolean_false_node = build_int_cst (boolean_type_node, 0);
593 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
594 gfc_charlen_type_node = gfc_get_int_type (4);
597 /* Get the type node for the given type and kind. */
600 gfc_get_int_type (int kind)
602 int index = gfc_validate_kind (BT_INTEGER, kind, true);
603 return index < 0 ? 0 : gfc_integer_types[index];
607 gfc_get_real_type (int kind)
609 int index = gfc_validate_kind (BT_REAL, kind, true);
610 return index < 0 ? 0 : gfc_real_types[index];
614 gfc_get_complex_type (int kind)
616 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
617 return index < 0 ? 0 : gfc_complex_types[index];
621 gfc_get_logical_type (int kind)
623 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
624 return index < 0 ? 0 : gfc_logical_types[index];
627 /* Create a character type with the given kind and length. */
630 gfc_get_character_type_len (int kind, tree len)
634 gfc_validate_kind (BT_CHARACTER, kind, false);
636 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
637 type = build_array_type (gfc_character1_type_node, bounds);
638 TYPE_STRING_FLAG (type) = 1;
644 /* Get a type node for a character kind. */
647 gfc_get_character_type (int kind, gfc_charlen * cl)
651 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
653 return gfc_get_character_type_len (kind, len);
656 /* Covert a basic type. This will be an array for character types. */
659 gfc_typenode_for_spec (gfc_typespec * spec)
669 basetype = gfc_get_int_type (spec->kind);
673 basetype = gfc_get_real_type (spec->kind);
677 basetype = gfc_get_complex_type (spec->kind);
681 basetype = gfc_get_logical_type (spec->kind);
685 basetype = gfc_get_character_type (spec->kind, spec->cl);
689 basetype = gfc_get_derived_type (spec->derived);
698 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
701 gfc_conv_array_bound (gfc_expr * expr)
703 /* If expr is an integer constant, return that. */
704 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
705 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
707 /* Otherwise return NULL. */
712 gfc_get_element_type (tree type)
716 if (GFC_ARRAY_TYPE_P (type))
718 if (TREE_CODE (type) == POINTER_TYPE)
719 type = TREE_TYPE (type);
720 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
721 element = TREE_TYPE (type);
725 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
726 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
728 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
729 element = TREE_TYPE (element);
731 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
732 element = TREE_TYPE (element);
738 /* Build an array. This function is called from gfc_sym_type().
739 Actually returns array descriptor type.
741 Format of array descriptors is as follows:
743 struct gfc_array_descriptor
748 struct descriptor_dimension dimension[N_DIM];
751 struct descriptor_dimension
758 Translation code should use gfc_conv_descriptor_* rather than accessing
759 the descriptor directly. Any changes to the array descriptor type will
760 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
762 This is represented internally as a RECORD_TYPE. The index nodes are
763 gfc_array_index_type and the data node is a pointer to the data. See below
764 for the handling of character types.
766 The dtype member is formatted as follows:
767 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
768 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
769 size = dtype >> GFC_DTYPE_SIZE_SHIFT
771 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
772 generated poor code for assumed/deferred size arrays. These require
773 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
774 grammar. Also, there is no way to explicitly set the array stride, so
775 all data must be packed(1). I've tried to mark all the functions which
776 would require modification with a GCC ARRAYS comment.
778 The data component points to the first element in the array.
779 The offset field is the position of the origin of the array
780 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
782 An element is accessed by
783 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
784 This gives good performance as the computation does not involve the
785 bounds of the array. For packed arrays, this is optimized further by
786 substituting the known strides.
788 This system has one problem: all array bounds must be withing 2^31 elements
789 of the origin (2^63 on 64-bit machines). For example
790 integer, dimension (80000:90000, 80000:90000, 2) :: array
791 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
792 the calculation for stride02 would overflow. This may still work, but
793 I haven't checked, and it relies on the overflow doing the right thing.
795 The way to fix this problem is to access elements as follows:
796 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
797 Obviously this is much slower. I will make this a compile time option,
798 something like -fsmall-array-offsets. Mixing code compiled with and without
799 this switch will work.
801 (1) This can be worked around by modifying the upper bound of the previous
802 dimension. This requires extra fields in the descriptor (both real_ubound
803 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
804 may allow us to do this. However I can't find mention of this anywhere
808 /* Returns true if the array sym does not require a descriptor. */
811 gfc_is_nodesc_array (gfc_symbol * sym)
813 gcc_assert (sym->attr.dimension);
815 /* We only want local arrays. */
816 if (sym->attr.pointer || sym->attr.allocatable)
821 if (sym->as->type != AS_ASSUMED_SHAPE)
827 if (sym->attr.result || sym->attr.function)
830 gcc_assert (sym->as->type == AS_EXPLICIT);
836 /* Create an array descriptor type. */
839 gfc_build_array_type (tree type, gfc_array_spec * as)
841 tree lbound[GFC_MAX_DIMENSIONS];
842 tree ubound[GFC_MAX_DIMENSIONS];
845 for (n = 0; n < as->rank; n++)
847 /* Create expressions for the known bounds of the array. */
848 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
849 lbound[n] = gfc_index_one_node;
851 lbound[n] = gfc_conv_array_bound (as->lower[n]);
852 ubound[n] = gfc_conv_array_bound (as->upper[n]);
855 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
858 /* Returns the struct descriptor_dimension type. */
861 gfc_get_desc_dim_type (void)
867 if (gfc_desc_dim_type)
868 return gfc_desc_dim_type;
870 /* Build the type node. */
871 type = make_node (RECORD_TYPE);
873 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
874 TYPE_PACKED (type) = 1;
876 /* Consists of the stride, lbound and ubound members. */
877 decl = build_decl (FIELD_DECL,
878 get_identifier ("stride"), gfc_array_index_type);
879 DECL_CONTEXT (decl) = type;
882 decl = build_decl (FIELD_DECL,
883 get_identifier ("lbound"), gfc_array_index_type);
884 DECL_CONTEXT (decl) = type;
885 fieldlist = chainon (fieldlist, decl);
887 decl = build_decl (FIELD_DECL,
888 get_identifier ("ubound"), gfc_array_index_type);
889 DECL_CONTEXT (decl) = type;
890 fieldlist = chainon (fieldlist, decl);
892 /* Finish off the type. */
893 TYPE_FIELDS (type) = fieldlist;
895 gfc_finish_type (type);
897 gfc_desc_dim_type = type;
902 /* Return the DTYPE for an array. This describes the type and type parameters
904 /* TODO: Only call this when the value is actually used, and make all the
905 unknown cases abort. */
908 gfc_get_dtype (tree type)
918 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
920 if (GFC_TYPE_ARRAY_DTYPE (type))
921 return GFC_TYPE_ARRAY_DTYPE (type);
923 rank = GFC_TYPE_ARRAY_RANK (type);
924 etype = gfc_get_element_type (type);
926 switch (TREE_CODE (etype))
929 n = GFC_DTYPE_INTEGER;
933 n = GFC_DTYPE_LOGICAL;
941 n = GFC_DTYPE_COMPLEX;
944 /* We will never have arrays of arrays. */
946 n = GFC_DTYPE_DERIVED;
950 n = GFC_DTYPE_CHARACTER;
954 /* TODO: Don't do dtype for temporary descriptorless arrays. */
955 /* We can strange array types for temporary arrays. */
956 return gfc_index_zero_node;
959 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
960 size = TYPE_SIZE_UNIT (etype);
962 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
963 if (size && INTEGER_CST_P (size))
965 if (tree_int_cst_lt (gfc_max_array_element_size, size))
966 internal_error ("Array element size too big");
968 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
970 dtype = build_int_cst (gfc_array_index_type, i);
972 if (size && !INTEGER_CST_P (size))
974 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
975 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
976 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
978 /* If we don't know the size we leave it as zero. This should never happen
979 for anything that is actually used. */
980 /* TODO: Check this is actually true, particularly when repacking
981 assumed size parameters. */
983 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
988 /* Build an array type for use without a descriptor. Valid values of packed
989 are 0=no, 1=partial, 2=full, 3=static. */
992 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
1005 mpz_init_set_ui (offset, 0);
1006 mpz_init_set_ui (stride, 1);
1009 /* We don't use build_array_type because this does not include include
1010 lang-specific information (i.e. the bounds of the array) when checking
1012 type = make_node (ARRAY_TYPE);
1014 GFC_ARRAY_TYPE_P (type) = 1;
1015 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1016 ggc_alloc_cleared (sizeof (struct lang_type));
1018 known_stride = (packed != 0);
1020 for (n = 0; n < as->rank; n++)
1022 /* Fill in the stride and bound components of the type. */
1024 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1027 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1029 expr = as->lower[n];
1030 if (expr->expr_type == EXPR_CONSTANT)
1032 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1033 gfc_index_integer_kind);
1040 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1044 /* Calculate the offset. */
1045 mpz_mul (delta, stride, as->lower[n]->value.integer);
1046 mpz_sub (offset, offset, delta);
1051 expr = as->upper[n];
1052 if (expr && expr->expr_type == EXPR_CONSTANT)
1054 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1055 gfc_index_integer_kind);
1062 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1066 /* Calculate the stride. */
1067 mpz_sub (delta, as->upper[n]->value.integer,
1068 as->lower[n]->value.integer);
1069 mpz_add_ui (delta, delta, 1);
1070 mpz_mul (stride, stride, delta);
1073 /* Only the first stride is known for partial packed arrays. */
1080 GFC_TYPE_ARRAY_OFFSET (type) =
1081 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1084 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1088 GFC_TYPE_ARRAY_SIZE (type) =
1089 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1092 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1094 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1095 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1096 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1098 /* TODO: use main type if it is unbounded. */
1099 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1100 build_pointer_type (build_array_type (etype, range));
1104 mpz_sub_ui (stride, stride, 1);
1105 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1110 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1111 TYPE_DOMAIN (type) = range;
1113 build_pointer_type (etype);
1114 TREE_TYPE (type) = etype;
1122 if (packed < 3 || !known_stride)
1124 /* For dummy arrays and automatic (heap allocated) arrays we
1125 want a pointer to the array. */
1126 type = build_pointer_type (type);
1127 GFC_ARRAY_TYPE_P (type) = 1;
1128 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1133 /* Return or create the base type for an array descriptor. */
1136 gfc_get_array_descriptor_base (int dimen)
1138 tree fat_type, fieldlist, decl, arraytype;
1139 char name[16 + GFC_RANK_DIGITS + 1];
1141 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1142 if (gfc_array_descriptor_base[dimen - 1])
1143 return gfc_array_descriptor_base[dimen - 1];
1145 /* Build the type node. */
1146 fat_type = make_node (RECORD_TYPE);
1148 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1149 TYPE_NAME (fat_type) = get_identifier (name);
1151 /* Add the data member as the first element of the descriptor. */
1152 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1154 DECL_CONTEXT (decl) = fat_type;
1157 /* Add the base component. */
1158 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1159 gfc_array_index_type);
1160 DECL_CONTEXT (decl) = fat_type;
1161 fieldlist = chainon (fieldlist, decl);
1163 /* Add the dtype component. */
1164 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1165 gfc_array_index_type);
1166 DECL_CONTEXT (decl) = fat_type;
1167 fieldlist = chainon (fieldlist, decl);
1169 /* Build the array type for the stride and bound components. */
1171 build_array_type (gfc_get_desc_dim_type (),
1172 build_range_type (gfc_array_index_type,
1173 gfc_index_zero_node,
1174 gfc_rank_cst[dimen - 1]));
1176 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1177 DECL_CONTEXT (decl) = fat_type;
1178 fieldlist = chainon (fieldlist, decl);
1180 /* Finish off the type. */
1181 TYPE_FIELDS (fat_type) = fieldlist;
1183 gfc_finish_type (fat_type);
1185 gfc_array_descriptor_base[dimen - 1] = fat_type;
1189 /* Build an array (descriptor) type with given bounds. */
1192 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1193 tree * ubound, int packed)
1195 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1196 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1197 const char *typename;
1200 base_type = gfc_get_array_descriptor_base (dimen);
1201 fat_type = build_variant_type_copy (base_type);
1203 tmp = TYPE_NAME (etype);
1204 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1205 tmp = DECL_NAME (tmp);
1207 typename = IDENTIFIER_POINTER (tmp);
1209 typename = "unknown";
1210 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1211 GFC_MAX_SYMBOL_LEN, typename);
1212 TYPE_NAME (fat_type) = get_identifier (name);
1214 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1215 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1216 ggc_alloc_cleared (sizeof (struct lang_type));
1218 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1219 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1221 /* Build an array descriptor record type. */
1223 stride = gfc_index_one_node;
1226 for (n = 0; n < dimen; n++)
1228 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1235 if (lower != NULL_TREE)
1237 if (INTEGER_CST_P (lower))
1238 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1244 if (upper != NULL_TREE)
1246 if (INTEGER_CST_P (upper))
1247 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1252 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1254 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1255 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1256 gfc_index_one_node);
1258 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1259 /* Check the folding worked. */
1260 gcc_assert (INTEGER_CST_P (stride));
1265 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1267 /* TODO: known offsets for descriptors. */
1268 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1270 /* We define data as an unknown size array. Much better than doing
1271 pointer arithmetic. */
1273 build_array_type (etype, gfc_array_range_type);
1274 arraytype = build_pointer_type (arraytype);
1275 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1280 /* Build a pointer type. This function is called from gfc_sym_type(). */
1283 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1285 /* Array pointer types aren't actually pointers. */
1286 if (sym->attr.dimension)
1289 return build_pointer_type (type);
1292 /* Return the type for a symbol. Special handling is required for character
1293 types to get the correct level of indirection.
1294 For functions return the return type.
1295 For subroutines return void_type_node.
1296 Calling this multiple times for the same symbol should be avoided,
1297 especially for character and array types. */
1300 gfc_sym_type (gfc_symbol * sym)
1305 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1306 return void_type_node;
1308 if (sym->backend_decl)
1310 if (sym->attr.function)
1311 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
1313 return TREE_TYPE (sym->backend_decl);
1316 type = gfc_typenode_for_spec (&sym->ts);
1317 if (gfc_option.flag_f2c
1318 && sym->attr.function
1319 && sym->ts.type == BT_REAL
1320 && sym->ts.kind == gfc_default_real_kind
1321 && !sym->attr.always_explicit)
1323 /* Special case: f2c calling conventions require that (scalar)
1324 default REAL functions return the C type double instead. */
1325 sym->ts.kind = gfc_default_double_kind;
1326 type = gfc_typenode_for_spec (&sym->ts);
1327 sym->ts.kind = gfc_default_real_kind;
1330 if (sym->attr.dummy && !sym->attr.function)
1335 if (sym->attr.dimension)
1337 if (gfc_is_nodesc_array (sym))
1339 /* If this is a character argument of unknown length, just use the
1341 if (sym->ts.type != BT_CHARACTER
1342 || !(sym->attr.dummy || sym->attr.function)
1343 || sym->ts.cl->backend_decl)
1345 type = gfc_get_nodesc_array_type (type, sym->as,
1351 type = gfc_build_array_type (type, sym->as);
1355 if (sym->attr.allocatable || sym->attr.pointer)
1356 type = gfc_build_pointer_type (sym, type);
1359 /* We currently pass all parameters by reference.
1360 See f95_get_function_decl. For dummy function parameters return the
1364 /* We must use pointer types for potentially absent variables. The
1365 optimizers assume a reference type argument is never NULL. */
1366 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1367 type = build_pointer_type (type);
1369 type = build_reference_type (type);
1375 /* Layout and output debug info for a record type. */
1378 gfc_finish_type (tree type)
1382 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1383 TYPE_STUB_DECL (type) = decl;
1385 rest_of_type_compilation (type, 1);
1386 rest_of_decl_compilation (decl, 1, 0);
1389 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1390 or RECORD_TYPE pointed to by STYPE. The new field is chained
1391 to the fieldlist pointed to by FIELDLIST.
1393 Returns a pointer to the new field. */
1396 gfc_add_field_to_struct (tree *fieldlist, tree context,
1397 tree name, tree type)
1401 decl = build_decl (FIELD_DECL, name, type);
1403 DECL_CONTEXT (decl) = context;
1404 DECL_INITIAL (decl) = 0;
1405 DECL_ALIGN (decl) = 0;
1406 DECL_USER_ALIGN (decl) = 0;
1407 TREE_CHAIN (decl) = NULL_TREE;
1408 *fieldlist = chainon (*fieldlist, decl);
1414 /* Copy the backend_decl and component backend_decls if
1415 the two derived type symbols are "equal", as described
1416 in 4.4.2 and resolved by gfc_compare_derived_types. */
1419 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1421 gfc_component *to_cm;
1422 gfc_component *from_cm;
1424 if (from->backend_decl == NULL
1425 || !gfc_compare_derived_types (from, to))
1428 to->backend_decl = from->backend_decl;
1430 to_cm = to->components;
1431 from_cm = from->components;
1433 /* Copy the component declarations. If a component is itself
1434 a derived type, we need a copy of its component declarations.
1435 This is done by recursing into gfc_get_derived_type and
1436 ensures that the component's component declarations have
1437 been built. If it is a character, we need the character
1439 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1441 to_cm->backend_decl = from_cm->backend_decl;
1442 if (from_cm->ts.type == BT_DERIVED)
1443 gfc_get_derived_type (to_cm->ts.derived);
1445 else if (from_cm->ts.type == BT_CHARACTER)
1446 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1453 /* Build a tree node for a derived type. If there are equal
1454 derived types, with different local names, these are built
1455 at the same time. If an equal derived type has been built
1456 in a parent namespace, this is used. */
1459 gfc_get_derived_type (gfc_symbol * derived)
1461 tree typenode, field, field_type, fieldlist;
1466 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1468 /* derived->backend_decl != 0 means we saw it before, but its
1469 components' backend_decl may have not been built. */
1470 if (derived->backend_decl)
1472 /* Its components' backend_decl have been built. */
1473 if (TYPE_FIELDS (derived->backend_decl))
1474 return derived->backend_decl;
1476 typenode = derived->backend_decl;
1480 /* In a module, if an equal derived type is already available in the
1481 specification block, use its backend declaration and those of its
1482 components, rather than building anew so that potential dummy and
1483 actual arguments use the same TREE_TYPE. Non-module structures,
1484 need to be built, if found, because the order of visits to the
1485 namespaces is different. */
1487 for (ns = derived->ns->parent; ns; ns = ns->parent)
1489 for (dt = ns->derived_types; dt; dt = dt->next)
1491 if (derived->module == NULL
1492 && dt->derived->backend_decl == NULL
1493 && gfc_compare_derived_types (dt->derived, derived))
1494 gfc_get_derived_type (dt->derived);
1496 if (copy_dt_decls_ifequal (dt->derived, derived))
1499 if (derived->backend_decl)
1500 goto other_equal_dts;
1503 /* We see this derived type first time, so build the type node. */
1504 typenode = make_node (RECORD_TYPE);
1505 TYPE_NAME (typenode) = get_identifier (derived->name);
1506 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1507 derived->backend_decl = typenode;
1510 /* Go through the derived type components, building them as
1511 necessary. The reason for doing this now is that it is
1512 possible to recurse back to this derived type through a
1513 pointer component (PR24092). If this happens, the fields
1514 will be built and so we can return the type. */
1515 for (c = derived->components; c; c = c->next)
1517 if (c->ts.type != BT_DERIVED)
1520 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1521 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1524 if (TYPE_FIELDS (derived->backend_decl))
1525 return derived->backend_decl;
1527 /* Build the type member list. Install the newly created RECORD_TYPE
1528 node as DECL_CONTEXT of each FIELD_DECL. */
1529 fieldlist = NULL_TREE;
1530 for (c = derived->components; c; c = c->next)
1532 if (c->ts.type == BT_DERIVED)
1533 field_type = c->ts.derived->backend_decl;
1536 if (c->ts.type == BT_CHARACTER)
1538 /* Evaluate the string length. */
1539 gfc_conv_const_charlen (c->ts.cl);
1540 gcc_assert (c->ts.cl->backend_decl);
1543 field_type = gfc_typenode_for_spec (&c->ts);
1546 /* This returns an array descriptor type. Initialization may be
1552 /* Pointers to arrays aren't actually pointer types. The
1553 descriptors are separate, but the data is common. */
1554 field_type = gfc_build_array_type (field_type, c->as);
1557 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1559 else if (c->pointer)
1560 field_type = build_pointer_type (field_type);
1562 field = gfc_add_field_to_struct (&fieldlist, typenode,
1563 get_identifier (c->name),
1566 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1569 if (!c->backend_decl)
1570 c->backend_decl = field;
1573 /* Now we have the final fieldlist. Record it, then lay out the
1574 derived type, including the fields. */
1575 TYPE_FIELDS (typenode) = fieldlist;
1577 gfc_finish_type (typenode);
1579 derived->backend_decl = typenode;
1582 /* Add this backend_decl to all the other, equal derived types and
1583 their components in this namespace. */
1584 for (dt = derived->ns->derived_types; dt; dt = dt->next)
1585 copy_dt_decls_ifequal (derived, dt->derived);
1587 return derived->backend_decl;
1592 gfc_return_by_reference (gfc_symbol * sym)
1594 if (!sym->attr.function)
1597 if (sym->attr.dimension)
1600 if (sym->ts.type == BT_CHARACTER)
1603 /* Possibly return complex numbers by reference for g77 compatibility.
1604 We don't do this for calls to intrinsics (as the library uses the
1605 -fno-f2c calling convention), nor for calls to functions which always
1606 require an explicit interface, as no compatibility problems can
1608 if (gfc_option.flag_f2c
1609 && sym->ts.type == BT_COMPLEX
1610 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1617 gfc_get_mixed_entry_union (gfc_namespace *ns)
1622 char name[GFC_MAX_SYMBOL_LEN + 1];
1623 gfc_entry_list *el, *el2;
1625 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1626 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1628 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1630 /* Build the type node. */
1631 type = make_node (UNION_TYPE);
1633 TYPE_NAME (type) = get_identifier (name);
1636 for (el = ns->entries; el; el = el->next)
1638 /* Search for duplicates. */
1639 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1640 if (el2->sym->result == el->sym->result)
1645 decl = build_decl (FIELD_DECL,
1646 get_identifier (el->sym->result->name),
1647 gfc_sym_type (el->sym->result));
1648 DECL_CONTEXT (decl) = type;
1649 fieldlist = chainon (fieldlist, decl);
1653 /* Finish off the type. */
1654 TYPE_FIELDS (type) = fieldlist;
1656 gfc_finish_type (type);
1661 gfc_get_function_type (gfc_symbol * sym)
1665 gfc_formal_arglist *f;
1668 int alternate_return;
1670 /* Make sure this symbol is a function or a subroutine. */
1671 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1673 if (sym->backend_decl)
1674 return TREE_TYPE (sym->backend_decl);
1677 alternate_return = 0;
1678 typelist = NULL_TREE;
1680 if (sym->attr.entry_master)
1682 /* Additional parameter for selecting an entry point. */
1683 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1686 /* Some functions we use an extra parameter for the return value. */
1687 if (gfc_return_by_reference (sym))
1694 if (arg->ts.type == BT_CHARACTER)
1695 gfc_conv_const_charlen (arg->ts.cl);
1697 type = gfc_sym_type (arg);
1698 if (arg->ts.type == BT_COMPLEX
1699 || arg->attr.dimension
1700 || arg->ts.type == BT_CHARACTER)
1701 type = build_reference_type (type);
1703 typelist = gfc_chainon_list (typelist, type);
1704 if (arg->ts.type == BT_CHARACTER)
1705 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1708 /* Build the argument types for the function. */
1709 for (f = sym->formal; f; f = f->next)
1714 /* Evaluate constant character lengths here so that they can be
1715 included in the type. */
1716 if (arg->ts.type == BT_CHARACTER)
1717 gfc_conv_const_charlen (arg->ts.cl);
1719 if (arg->attr.flavor == FL_PROCEDURE)
1721 type = gfc_get_function_type (arg);
1722 type = build_pointer_type (type);
1725 type = gfc_sym_type (arg);
1727 /* Parameter Passing Convention
1729 We currently pass all parameters by reference.
1730 Parameters with INTENT(IN) could be passed by value.
1731 The problem arises if a function is called via an implicit
1732 prototype. In this situation the INTENT is not known.
1733 For this reason all parameters to global functions must be
1734 passed by reference. Passing by value would potentially
1735 generate bad code. Worse there would be no way of telling that
1736 this code was bad, except that it would give incorrect results.
1738 Contained procedures could pass by value as these are never
1739 used without an explicit interface, and cannot be passed as
1740 actual parameters for a dummy procedure. */
1741 if (arg->ts.type == BT_CHARACTER)
1743 typelist = gfc_chainon_list (typelist, type);
1747 if (sym->attr.subroutine)
1748 alternate_return = 1;
1752 /* Add hidden string length parameters. */
1754 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1756 typelist = gfc_chainon_list (typelist, void_type_node);
1758 if (alternate_return)
1759 type = integer_type_node;
1760 else if (!sym->attr.function || gfc_return_by_reference (sym))
1761 type = void_type_node;
1762 else if (sym->attr.mixed_entry_master)
1763 type = gfc_get_mixed_entry_union (sym->ns);
1765 type = gfc_sym_type (sym);
1767 type = build_function_type (type, typelist);
1772 /* Language hooks for middle-end access to type nodes. */
1774 /* Return an integer type with BITS bits of precision,
1775 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1778 gfc_type_for_size (unsigned bits, int unsignedp)
1783 for (i = 0; i <= MAX_INT_KINDS; ++i)
1785 tree type = gfc_integer_types[i];
1786 if (type && bits == TYPE_PRECISION (type))
1792 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1793 return unsigned_intQI_type_node;
1794 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1795 return unsigned_intHI_type_node;
1796 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1797 return unsigned_intSI_type_node;
1798 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1799 return unsigned_intDI_type_node;
1800 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1801 return unsigned_intTI_type_node;
1807 /* Return a data type that has machine mode MODE. If the mode is an
1808 integer, then UNSIGNEDP selects between signed and unsigned types. */
1811 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1816 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1817 base = gfc_real_types;
1818 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1819 base = gfc_complex_types;
1820 else if (SCALAR_INT_MODE_P (mode))
1821 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1822 else if (VECTOR_MODE_P (mode))
1824 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1825 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1826 if (inner_type != NULL_TREE)
1827 return build_vector_type_for_mode (inner_type, mode);
1833 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1835 tree type = base[i];
1836 if (type && mode == TYPE_MODE (type))
1843 /* Return a type the same as TYPE except unsigned or
1844 signed according to UNSIGNEDP. */
1847 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1849 if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
1852 return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
1855 /* Return an unsigned type the same as TYPE in other respects. */
1858 gfc_unsigned_type (tree type)
1860 return gfc_signed_or_unsigned_type (1, type);
1863 /* Return a signed type the same as TYPE in other respects. */
1866 gfc_signed_type (tree type)
1868 return gfc_signed_or_unsigned_type (0, type);
1871 #include "gt-fortran-trans-types.h"