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 /* The size of the numeric storage unit and character storage unit. */
101 int gfc_numeric_storage_size;
102 int gfc_character_storage_size;
104 /* Query the target to determine which machine modes are available for
105 computation. Choose KIND numbers for them. */
108 gfc_init_kinds (void)
110 enum machine_mode mode;
111 int i_index, r_index;
112 bool saw_i4 = false, saw_i8 = false;
113 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
115 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
119 if (!targetm.scalar_mode_supported_p (mode))
122 /* The middle end doesn't support constants larger than 2*HWI.
123 Perhaps the target hook shouldn't have accepted these either,
124 but just to be safe... */
125 bitsize = GET_MODE_BITSIZE (mode);
126 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
129 gcc_assert (i_index != MAX_INT_KINDS);
131 /* Let the kind equal the bit size divided by 8. This insulates the
132 programmer from the underlying byte size. */
140 gfc_integer_kinds[i_index].kind = kind;
141 gfc_integer_kinds[i_index].radix = 2;
142 gfc_integer_kinds[i_index].digits = bitsize - 1;
143 gfc_integer_kinds[i_index].bit_size = bitsize;
145 gfc_logical_kinds[i_index].kind = kind;
146 gfc_logical_kinds[i_index].bit_size = bitsize;
151 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
152 used for large file access. */
159 /* If we do not at least have kind = 4, everything is pointless. */
162 /* Set the maximum integer kind. Used with at least BOZ constants. */
163 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
165 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
167 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
172 if (!targetm.scalar_mode_supported_p (mode))
175 /* Only let float/double/long double go through because the fortran
176 library assumes these are the only floating point types. */
178 if (mode != TYPE_MODE (float_type_node)
179 && (mode != TYPE_MODE (double_type_node))
180 && (mode != TYPE_MODE (long_double_type_node)))
183 /* Let the kind equal the precision divided by 8, rounding up. Again,
184 this insulates the programmer from the underlying byte size.
186 Also, it effectively deals with IEEE extended formats. There, the
187 total size of the type may equal 16, but it's got 6 bytes of padding
188 and the increased size can get in the way of a real IEEE quad format
189 which may also be supported by the target.
191 We round up so as to handle IA-64 __floatreg (RFmode), which is an
192 82 bit type. Not to be confused with __float80 (XFmode), which is
193 an 80 bit type also supported by IA-64. So XFmode should come out
194 to be kind=10, and RFmode should come out to be kind=11. Egads. */
196 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
205 /* Careful we don't stumble a wierd internal mode. */
206 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
207 /* Or have too many modes for the allocated space. */
208 gcc_assert (r_index != MAX_REAL_KINDS);
210 gfc_real_kinds[r_index].kind = kind;
211 gfc_real_kinds[r_index].radix = fmt->b;
212 gfc_real_kinds[r_index].digits = fmt->p;
213 gfc_real_kinds[r_index].min_exponent = fmt->emin;
214 gfc_real_kinds[r_index].max_exponent = fmt->emax;
215 if (fmt->pnan < fmt->p)
216 /* This is an IBM extended double format (or the MIPS variant)
217 made up of two IEEE doubles. The value of the long double is
218 the sum of the values of the two parts. The most significant
219 part is required to be the value of the long double rounded
220 to the nearest double. If we use emax of 1024 then we can't
221 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
222 rounding will make the most significant part overflow. */
223 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
224 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
228 /* Choose the default integer kind. We choose 4 unless the user
229 directs us otherwise. */
230 if (gfc_option.flag_default_integer)
233 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
234 gfc_default_integer_kind = 8;
236 /* Even if the user specified that the default integer kind be 8,
237 the numerica storage size isn't 64. In this case, a warning will
238 be issued when NUMERIC_STORAGE_SIZE is used. */
239 gfc_numeric_storage_size = 4 * 8;
243 gfc_default_integer_kind = 4;
244 gfc_numeric_storage_size = 4 * 8;
248 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
249 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
252 /* Choose the default real kind. Again, we choose 4 when possible. */
253 if (gfc_option.flag_default_real)
256 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
257 gfc_default_real_kind = 8;
260 gfc_default_real_kind = 4;
262 gfc_default_real_kind = gfc_real_kinds[0].kind;
264 /* Choose the default double kind. If -fdefault-real and -fdefault-double
265 are specified, we use kind=8, if it's available. If -fdefault-real is
266 specified without -fdefault-double, we use kind=16, if it's available.
267 Otherwise we do not change anything. */
268 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
269 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
271 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
272 gfc_default_double_kind = 8;
273 else if (gfc_option.flag_default_real && saw_r16)
274 gfc_default_double_kind = 16;
275 else if (saw_r4 && saw_r8)
276 gfc_default_double_kind = 8;
279 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
280 real ... occupies two contiguous numeric storage units.
282 Therefore we must be supplied a kind twice as large as we chose
283 for single precision. There are loopholes, in that double
284 precision must *occupy* two storage units, though it doesn't have
285 to *use* two storage units. Which means that you can make this
286 kind artificially wide by padding it. But at present there are
287 no GCC targets for which a two-word type does not exist, so we
288 just let gfc_validate_kind abort and tell us if something breaks. */
290 gfc_default_double_kind
291 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
294 /* The default logical kind is constrained to be the same as the
295 default integer kind. Similarly with complex and real. */
296 gfc_default_logical_kind = gfc_default_integer_kind;
297 gfc_default_complex_kind = gfc_default_real_kind;
299 /* Choose the smallest integer kind for our default character. */
300 gfc_default_character_kind = gfc_integer_kinds[0].kind;
301 gfc_character_storage_size = gfc_default_character_kind * 8;
303 /* Choose the integer kind the same size as "void*" for our index kind. */
304 gfc_index_integer_kind = POINTER_SIZE / 8;
305 /* Pick a kind the same size as the C "int" type. */
306 gfc_c_int_kind = INT_TYPE_SIZE / 8;
309 /* Make sure that a valid kind is present. Returns an index into the
310 associated kinds array, -1 if the kind is not present. */
313 validate_integer (int kind)
317 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
318 if (gfc_integer_kinds[i].kind == kind)
325 validate_real (int kind)
329 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
330 if (gfc_real_kinds[i].kind == kind)
337 validate_logical (int kind)
341 for (i = 0; gfc_logical_kinds[i].kind; i++)
342 if (gfc_logical_kinds[i].kind == kind)
349 validate_character (int kind)
351 return kind == gfc_default_character_kind ? 0 : -1;
354 /* Validate a kind given a basic type. The return value is the same
355 for the child functions, with -1 indicating nonexistence of the
356 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
359 gfc_validate_kind (bt type, int kind, bool may_fail)
365 case BT_REAL: /* Fall through */
367 rc = validate_real (kind);
370 rc = validate_integer (kind);
373 rc = validate_logical (kind);
376 rc = validate_character (kind);
380 gfc_internal_error ("gfc_validate_kind(): Got bad type");
383 if (rc < 0 && !may_fail)
384 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
390 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
391 Reuse common type nodes where possible. Recognize if the kind matches up
392 with a C type. This will be used later in determining which routines may
393 be scarfed from libm. */
396 gfc_build_int_type (gfc_integer_info *info)
398 int mode_precision = info->bit_size;
400 if (mode_precision == CHAR_TYPE_SIZE)
402 if (mode_precision == SHORT_TYPE_SIZE)
404 if (mode_precision == INT_TYPE_SIZE)
406 if (mode_precision == LONG_TYPE_SIZE)
408 if (mode_precision == LONG_LONG_TYPE_SIZE)
409 info->c_long_long = 1;
411 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
412 return intQI_type_node;
413 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
414 return intHI_type_node;
415 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
416 return intSI_type_node;
417 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
418 return intDI_type_node;
419 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
420 return intTI_type_node;
422 return make_signed_type (mode_precision);
426 gfc_build_real_type (gfc_real_info *info)
428 int mode_precision = info->mode_precision;
431 if (mode_precision == FLOAT_TYPE_SIZE)
433 if (mode_precision == DOUBLE_TYPE_SIZE)
435 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
436 info->c_long_double = 1;
438 if (TYPE_PRECISION (float_type_node) == mode_precision)
439 return float_type_node;
440 if (TYPE_PRECISION (double_type_node) == mode_precision)
441 return double_type_node;
442 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
443 return long_double_type_node;
445 new_type = make_node (REAL_TYPE);
446 TYPE_PRECISION (new_type) = mode_precision;
447 layout_type (new_type);
452 gfc_build_complex_type (tree scalar_type)
456 if (scalar_type == NULL)
458 if (scalar_type == float_type_node)
459 return complex_float_type_node;
460 if (scalar_type == double_type_node)
461 return complex_double_type_node;
462 if (scalar_type == long_double_type_node)
463 return complex_long_double_type_node;
465 new_type = make_node (COMPLEX_TYPE);
466 TREE_TYPE (new_type) = scalar_type;
467 layout_type (new_type);
472 gfc_build_logical_type (gfc_logical_info *info)
474 int bit_size = info->bit_size;
477 if (bit_size == BOOL_TYPE_SIZE)
480 return boolean_type_node;
483 new_type = make_unsigned_type (bit_size);
484 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
485 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
486 TYPE_PRECISION (new_type) = 1;
492 /* Return the bit size of the C "size_t". */
498 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
499 return INT_TYPE_SIZE;
500 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
501 return LONG_TYPE_SIZE;
502 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
503 return SHORT_TYPE_SIZE;
506 return LONG_TYPE_SIZE;
511 /* Create the backend type nodes. We map them to their
512 equivalent C type, at least for now. We also give
513 names to the types here, and we push them in the
514 global binding level context.*/
517 gfc_init_types (void)
523 unsigned HOST_WIDE_INT hi;
524 unsigned HOST_WIDE_INT lo;
526 /* Create and name the types. */
527 #define PUSH_TYPE(name, node) \
528 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
530 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
532 type = gfc_build_int_type (&gfc_integer_kinds[index]);
533 gfc_integer_types[index] = type;
534 snprintf (name_buf, sizeof(name_buf), "int%d",
535 gfc_integer_kinds[index].kind);
536 PUSH_TYPE (name_buf, type);
539 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
541 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
542 gfc_logical_types[index] = type;
543 snprintf (name_buf, sizeof(name_buf), "logical%d",
544 gfc_logical_kinds[index].kind);
545 PUSH_TYPE (name_buf, type);
548 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
550 type = gfc_build_real_type (&gfc_real_kinds[index]);
551 gfc_real_types[index] = type;
552 snprintf (name_buf, sizeof(name_buf), "real%d",
553 gfc_real_kinds[index].kind);
554 PUSH_TYPE (name_buf, type);
556 type = gfc_build_complex_type (type);
557 gfc_complex_types[index] = type;
558 snprintf (name_buf, sizeof(name_buf), "complex%d",
559 gfc_real_kinds[index].kind);
560 PUSH_TYPE (name_buf, type);
563 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
565 PUSH_TYPE ("char", gfc_character1_type_node);
567 PUSH_TYPE ("byte", unsigned_char_type_node);
568 PUSH_TYPE ("void", void_type_node);
570 /* DBX debugging output gets upset if these aren't set. */
571 if (!TYPE_NAME (integer_type_node))
572 PUSH_TYPE ("c_integer", integer_type_node);
573 if (!TYPE_NAME (char_type_node))
574 PUSH_TYPE ("c_char", char_type_node);
578 pvoid_type_node = build_pointer_type (void_type_node);
579 ppvoid_type_node = build_pointer_type (pvoid_type_node);
580 pchar_type_node = build_pointer_type (gfc_character1_type_node);
582 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
583 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
584 since this function is called before gfc_init_constants. */
586 = build_range_type (gfc_array_index_type,
587 build_int_cst (gfc_array_index_type, 0),
590 /* The maximum array element size that can be handled is determined
591 by the number of bits available to store this field in the array
594 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
595 lo = ~ (unsigned HOST_WIDE_INT) 0;
596 if (n > HOST_BITS_PER_WIDE_INT)
597 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
599 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
600 gfc_max_array_element_size
601 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
603 size_type_node = gfc_array_index_type;
605 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
606 boolean_true_node = build_int_cst (boolean_type_node, 1);
607 boolean_false_node = build_int_cst (boolean_type_node, 0);
609 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
610 gfc_charlen_type_node = gfc_get_int_type (4);
613 /* Get the type node for the given type and kind. */
616 gfc_get_int_type (int kind)
618 int index = gfc_validate_kind (BT_INTEGER, kind, true);
619 return index < 0 ? 0 : gfc_integer_types[index];
623 gfc_get_real_type (int kind)
625 int index = gfc_validate_kind (BT_REAL, kind, true);
626 return index < 0 ? 0 : gfc_real_types[index];
630 gfc_get_complex_type (int kind)
632 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
633 return index < 0 ? 0 : gfc_complex_types[index];
637 gfc_get_logical_type (int kind)
639 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
640 return index < 0 ? 0 : gfc_logical_types[index];
643 /* Create a character type with the given kind and length. */
646 gfc_get_character_type_len (int kind, tree len)
650 gfc_validate_kind (BT_CHARACTER, kind, false);
652 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
653 type = build_array_type (gfc_character1_type_node, bounds);
654 TYPE_STRING_FLAG (type) = 1;
660 /* Get a type node for a character kind. */
663 gfc_get_character_type (int kind, gfc_charlen * cl)
667 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
669 return gfc_get_character_type_len (kind, len);
672 /* Covert a basic type. This will be an array for character types. */
675 gfc_typenode_for_spec (gfc_typespec * spec)
685 basetype = gfc_get_int_type (spec->kind);
689 basetype = gfc_get_real_type (spec->kind);
693 basetype = gfc_get_complex_type (spec->kind);
697 basetype = gfc_get_logical_type (spec->kind);
701 basetype = gfc_get_character_type (spec->kind, spec->cl);
705 basetype = gfc_get_derived_type (spec->derived);
714 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
717 gfc_conv_array_bound (gfc_expr * expr)
719 /* If expr is an integer constant, return that. */
720 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
721 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
723 /* Otherwise return NULL. */
728 gfc_get_element_type (tree type)
732 if (GFC_ARRAY_TYPE_P (type))
734 if (TREE_CODE (type) == POINTER_TYPE)
735 type = TREE_TYPE (type);
736 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
737 element = TREE_TYPE (type);
741 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
742 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
744 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
745 element = TREE_TYPE (element);
747 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
748 element = TREE_TYPE (element);
754 /* Build an array. This function is called from gfc_sym_type().
755 Actually returns array descriptor type.
757 Format of array descriptors is as follows:
759 struct gfc_array_descriptor
764 struct descriptor_dimension dimension[N_DIM];
767 struct descriptor_dimension
774 Translation code should use gfc_conv_descriptor_* rather than accessing
775 the descriptor directly. Any changes to the array descriptor type will
776 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
778 This is represented internally as a RECORD_TYPE. The index nodes are
779 gfc_array_index_type and the data node is a pointer to the data. See below
780 for the handling of character types.
782 The dtype member is formatted as follows:
783 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
784 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
785 size = dtype >> GFC_DTYPE_SIZE_SHIFT
787 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
788 generated poor code for assumed/deferred size arrays. These require
789 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
790 grammar. Also, there is no way to explicitly set the array stride, so
791 all data must be packed(1). I've tried to mark all the functions which
792 would require modification with a GCC ARRAYS comment.
794 The data component points to the first element in the array.
795 The offset field is the position of the origin of the array
796 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
798 An element is accessed by
799 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
800 This gives good performance as the computation does not involve the
801 bounds of the array. For packed arrays, this is optimized further by
802 substituting the known strides.
804 This system has one problem: all array bounds must be withing 2^31 elements
805 of the origin (2^63 on 64-bit machines). For example
806 integer, dimension (80000:90000, 80000:90000, 2) :: array
807 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
808 the calculation for stride02 would overflow. This may still work, but
809 I haven't checked, and it relies on the overflow doing the right thing.
811 The way to fix this problem is to access elements as follows:
812 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
813 Obviously this is much slower. I will make this a compile time option,
814 something like -fsmall-array-offsets. Mixing code compiled with and without
815 this switch will work.
817 (1) This can be worked around by modifying the upper bound of the previous
818 dimension. This requires extra fields in the descriptor (both real_ubound
819 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
820 may allow us to do this. However I can't find mention of this anywhere
824 /* Returns true if the array sym does not require a descriptor. */
827 gfc_is_nodesc_array (gfc_symbol * sym)
829 gcc_assert (sym->attr.dimension);
831 /* We only want local arrays. */
832 if (sym->attr.pointer || sym->attr.allocatable)
837 if (sym->as->type != AS_ASSUMED_SHAPE)
843 if (sym->attr.result || sym->attr.function)
846 gcc_assert (sym->as->type == AS_EXPLICIT);
852 /* Create an array descriptor type. */
855 gfc_build_array_type (tree type, gfc_array_spec * as)
857 tree lbound[GFC_MAX_DIMENSIONS];
858 tree ubound[GFC_MAX_DIMENSIONS];
861 for (n = 0; n < as->rank; n++)
863 /* Create expressions for the known bounds of the array. */
864 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
865 lbound[n] = gfc_index_one_node;
867 lbound[n] = gfc_conv_array_bound (as->lower[n]);
868 ubound[n] = gfc_conv_array_bound (as->upper[n]);
871 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
874 /* Returns the struct descriptor_dimension type. */
877 gfc_get_desc_dim_type (void)
883 if (gfc_desc_dim_type)
884 return gfc_desc_dim_type;
886 /* Build the type node. */
887 type = make_node (RECORD_TYPE);
889 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
890 TYPE_PACKED (type) = 1;
892 /* Consists of the stride, lbound and ubound members. */
893 decl = build_decl (FIELD_DECL,
894 get_identifier ("stride"), gfc_array_index_type);
895 DECL_CONTEXT (decl) = type;
898 decl = build_decl (FIELD_DECL,
899 get_identifier ("lbound"), gfc_array_index_type);
900 DECL_CONTEXT (decl) = type;
901 fieldlist = chainon (fieldlist, decl);
903 decl = build_decl (FIELD_DECL,
904 get_identifier ("ubound"), gfc_array_index_type);
905 DECL_CONTEXT (decl) = type;
906 fieldlist = chainon (fieldlist, decl);
908 /* Finish off the type. */
909 TYPE_FIELDS (type) = fieldlist;
911 gfc_finish_type (type);
913 gfc_desc_dim_type = type;
918 /* Return the DTYPE for an array. This describes the type and type parameters
920 /* TODO: Only call this when the value is actually used, and make all the
921 unknown cases abort. */
924 gfc_get_dtype (tree type)
934 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
936 if (GFC_TYPE_ARRAY_DTYPE (type))
937 return GFC_TYPE_ARRAY_DTYPE (type);
939 rank = GFC_TYPE_ARRAY_RANK (type);
940 etype = gfc_get_element_type (type);
942 switch (TREE_CODE (etype))
945 n = GFC_DTYPE_INTEGER;
949 n = GFC_DTYPE_LOGICAL;
957 n = GFC_DTYPE_COMPLEX;
960 /* We will never have arrays of arrays. */
962 n = GFC_DTYPE_DERIVED;
966 n = GFC_DTYPE_CHARACTER;
970 /* TODO: Don't do dtype for temporary descriptorless arrays. */
971 /* We can strange array types for temporary arrays. */
972 return gfc_index_zero_node;
975 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
976 size = TYPE_SIZE_UNIT (etype);
978 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
979 if (size && INTEGER_CST_P (size))
981 if (tree_int_cst_lt (gfc_max_array_element_size, size))
982 internal_error ("Array element size too big");
984 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
986 dtype = build_int_cst (gfc_array_index_type, i);
988 if (size && !INTEGER_CST_P (size))
990 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
991 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
992 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
994 /* If we don't know the size we leave it as zero. This should never happen
995 for anything that is actually used. */
996 /* TODO: Check this is actually true, particularly when repacking
997 assumed size parameters. */
999 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1004 /* Build an array type for use without a descriptor. Valid values of packed
1005 are 0=no, 1=partial, 2=full, 3=static. */
1008 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
1021 mpz_init_set_ui (offset, 0);
1022 mpz_init_set_ui (stride, 1);
1025 /* We don't use build_array_type because this does not include include
1026 lang-specific information (i.e. the bounds of the array) when checking
1028 type = make_node (ARRAY_TYPE);
1030 GFC_ARRAY_TYPE_P (type) = 1;
1031 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1032 ggc_alloc_cleared (sizeof (struct lang_type));
1034 known_stride = (packed != 0);
1036 for (n = 0; n < as->rank; n++)
1038 /* Fill in the stride and bound components of the type. */
1040 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1043 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1045 expr = as->lower[n];
1046 if (expr->expr_type == EXPR_CONSTANT)
1048 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1049 gfc_index_integer_kind);
1056 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1060 /* Calculate the offset. */
1061 mpz_mul (delta, stride, as->lower[n]->value.integer);
1062 mpz_sub (offset, offset, delta);
1067 expr = as->upper[n];
1068 if (expr && expr->expr_type == EXPR_CONSTANT)
1070 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1071 gfc_index_integer_kind);
1078 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1082 /* Calculate the stride. */
1083 mpz_sub (delta, as->upper[n]->value.integer,
1084 as->lower[n]->value.integer);
1085 mpz_add_ui (delta, delta, 1);
1086 mpz_mul (stride, stride, delta);
1089 /* Only the first stride is known for partial packed arrays. */
1096 GFC_TYPE_ARRAY_OFFSET (type) =
1097 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1100 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1104 GFC_TYPE_ARRAY_SIZE (type) =
1105 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1108 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1110 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1111 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1112 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1114 /* TODO: use main type if it is unbounded. */
1115 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1116 build_pointer_type (build_array_type (etype, range));
1120 mpz_sub_ui (stride, stride, 1);
1121 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1126 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1127 TYPE_DOMAIN (type) = range;
1129 build_pointer_type (etype);
1130 TREE_TYPE (type) = etype;
1138 if (packed < 3 || !known_stride)
1140 /* For dummy arrays and automatic (heap allocated) arrays we
1141 want a pointer to the array. */
1142 type = build_pointer_type (type);
1143 GFC_ARRAY_TYPE_P (type) = 1;
1144 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1149 /* Return or create the base type for an array descriptor. */
1152 gfc_get_array_descriptor_base (int dimen)
1154 tree fat_type, fieldlist, decl, arraytype;
1155 char name[16 + GFC_RANK_DIGITS + 1];
1157 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1158 if (gfc_array_descriptor_base[dimen - 1])
1159 return gfc_array_descriptor_base[dimen - 1];
1161 /* Build the type node. */
1162 fat_type = make_node (RECORD_TYPE);
1164 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1165 TYPE_NAME (fat_type) = get_identifier (name);
1167 /* Add the data member as the first element of the descriptor. */
1168 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1170 DECL_CONTEXT (decl) = fat_type;
1173 /* Add the base component. */
1174 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1175 gfc_array_index_type);
1176 DECL_CONTEXT (decl) = fat_type;
1177 fieldlist = chainon (fieldlist, decl);
1179 /* Add the dtype component. */
1180 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1181 gfc_array_index_type);
1182 DECL_CONTEXT (decl) = fat_type;
1183 fieldlist = chainon (fieldlist, decl);
1185 /* Build the array type for the stride and bound components. */
1187 build_array_type (gfc_get_desc_dim_type (),
1188 build_range_type (gfc_array_index_type,
1189 gfc_index_zero_node,
1190 gfc_rank_cst[dimen - 1]));
1192 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1193 DECL_CONTEXT (decl) = fat_type;
1194 fieldlist = chainon (fieldlist, decl);
1196 /* Finish off the type. */
1197 TYPE_FIELDS (fat_type) = fieldlist;
1199 gfc_finish_type (fat_type);
1201 gfc_array_descriptor_base[dimen - 1] = fat_type;
1205 /* Build an array (descriptor) type with given bounds. */
1208 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1209 tree * ubound, int packed)
1211 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1212 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1213 const char *typename;
1216 base_type = gfc_get_array_descriptor_base (dimen);
1217 fat_type = build_variant_type_copy (base_type);
1219 tmp = TYPE_NAME (etype);
1220 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1221 tmp = DECL_NAME (tmp);
1223 typename = IDENTIFIER_POINTER (tmp);
1225 typename = "unknown";
1226 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1227 GFC_MAX_SYMBOL_LEN, typename);
1228 TYPE_NAME (fat_type) = get_identifier (name);
1230 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1231 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1232 ggc_alloc_cleared (sizeof (struct lang_type));
1234 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1235 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1237 /* Build an array descriptor record type. */
1239 stride = gfc_index_one_node;
1242 for (n = 0; n < dimen; n++)
1244 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1251 if (lower != NULL_TREE)
1253 if (INTEGER_CST_P (lower))
1254 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1260 if (upper != NULL_TREE)
1262 if (INTEGER_CST_P (upper))
1263 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1268 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1270 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1271 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1272 gfc_index_one_node);
1274 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1275 /* Check the folding worked. */
1276 gcc_assert (INTEGER_CST_P (stride));
1281 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1283 /* TODO: known offsets for descriptors. */
1284 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1286 /* We define data as an unknown size array. Much better than doing
1287 pointer arithmetic. */
1289 build_array_type (etype, gfc_array_range_type);
1290 arraytype = build_pointer_type (arraytype);
1291 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1296 /* Build a pointer type. This function is called from gfc_sym_type(). */
1299 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1301 /* Array pointer types aren't actually pointers. */
1302 if (sym->attr.dimension)
1305 return build_pointer_type (type);
1308 /* Return the type for a symbol. Special handling is required for character
1309 types to get the correct level of indirection.
1310 For functions return the return type.
1311 For subroutines return void_type_node.
1312 Calling this multiple times for the same symbol should be avoided,
1313 especially for character and array types. */
1316 gfc_sym_type (gfc_symbol * sym)
1321 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1322 return void_type_node;
1324 if (sym->backend_decl)
1326 if (sym->attr.function)
1327 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
1329 return TREE_TYPE (sym->backend_decl);
1332 type = gfc_typenode_for_spec (&sym->ts);
1333 if (gfc_option.flag_f2c
1334 && sym->attr.function
1335 && sym->ts.type == BT_REAL
1336 && sym->ts.kind == gfc_default_real_kind
1337 && !sym->attr.always_explicit)
1339 /* Special case: f2c calling conventions require that (scalar)
1340 default REAL functions return the C type double instead. */
1341 sym->ts.kind = gfc_default_double_kind;
1342 type = gfc_typenode_for_spec (&sym->ts);
1343 sym->ts.kind = gfc_default_real_kind;
1346 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1351 if (sym->attr.dimension)
1353 if (gfc_is_nodesc_array (sym))
1355 /* If this is a character argument of unknown length, just use the
1357 if (sym->ts.type != BT_CHARACTER
1358 || !(sym->attr.dummy || sym->attr.function)
1359 || sym->ts.cl->backend_decl)
1361 type = gfc_get_nodesc_array_type (type, sym->as,
1367 type = gfc_build_array_type (type, sym->as);
1371 if (sym->attr.allocatable || sym->attr.pointer)
1372 type = gfc_build_pointer_type (sym, type);
1375 /* We currently pass all parameters by reference.
1376 See f95_get_function_decl. For dummy function parameters return the
1380 /* We must use pointer types for potentially absent variables. The
1381 optimizers assume a reference type argument is never NULL. */
1382 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1383 type = build_pointer_type (type);
1385 type = build_reference_type (type);
1391 /* Layout and output debug info for a record type. */
1394 gfc_finish_type (tree type)
1398 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1399 TYPE_STUB_DECL (type) = decl;
1401 rest_of_type_compilation (type, 1);
1402 rest_of_decl_compilation (decl, 1, 0);
1405 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1406 or RECORD_TYPE pointed to by STYPE. The new field is chained
1407 to the fieldlist pointed to by FIELDLIST.
1409 Returns a pointer to the new field. */
1412 gfc_add_field_to_struct (tree *fieldlist, tree context,
1413 tree name, tree type)
1417 decl = build_decl (FIELD_DECL, name, type);
1419 DECL_CONTEXT (decl) = context;
1420 DECL_INITIAL (decl) = 0;
1421 DECL_ALIGN (decl) = 0;
1422 DECL_USER_ALIGN (decl) = 0;
1423 TREE_CHAIN (decl) = NULL_TREE;
1424 *fieldlist = chainon (*fieldlist, decl);
1430 /* Copy the backend_decl and component backend_decls if
1431 the two derived type symbols are "equal", as described
1432 in 4.4.2 and resolved by gfc_compare_derived_types. */
1435 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1437 gfc_component *to_cm;
1438 gfc_component *from_cm;
1440 if (from->backend_decl == NULL
1441 || !gfc_compare_derived_types (from, to))
1444 to->backend_decl = from->backend_decl;
1446 to_cm = to->components;
1447 from_cm = from->components;
1449 /* Copy the component declarations. If a component is itself
1450 a derived type, we need a copy of its component declarations.
1451 This is done by recursing into gfc_get_derived_type and
1452 ensures that the component's component declarations have
1453 been built. If it is a character, we need the character
1455 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1457 to_cm->backend_decl = from_cm->backend_decl;
1458 if (from_cm->ts.type == BT_DERIVED)
1459 gfc_get_derived_type (to_cm->ts.derived);
1461 else if (from_cm->ts.type == BT_CHARACTER)
1462 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1469 /* Build a tree node for a derived type. If there are equal
1470 derived types, with different local names, these are built
1471 at the same time. If an equal derived type has been built
1472 in a parent namespace, this is used. */
1475 gfc_get_derived_type (gfc_symbol * derived)
1477 tree typenode, field, field_type, fieldlist;
1482 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1484 /* derived->backend_decl != 0 means we saw it before, but its
1485 components' backend_decl may have not been built. */
1486 if (derived->backend_decl)
1488 /* Its components' backend_decl have been built. */
1489 if (TYPE_FIELDS (derived->backend_decl))
1490 return derived->backend_decl;
1492 typenode = derived->backend_decl;
1496 /* If an equal derived type is already available in the parent namespace,
1497 use its backend declaration and those of its components, rather than
1498 building anew so that potential dummy and actual arguments use the
1499 same TREE_TYPE. If an equal type is found without a backend_decl,
1500 build the parent version and use it in the current namespace. */
1501 if (derived->ns->parent)
1502 ns = derived->ns->parent;
1503 else if (derived->ns->proc_name
1504 && derived->ns->proc_name->ns != derived->ns)
1505 /* Derived types in an interface body obtain their parent reference
1506 through the proc_name symbol. */
1507 ns = derived->ns->proc_name->ns;
1509 /* Sometimes there isn't a parent reference! */
1512 for (; ns; ns = ns->parent)
1514 for (dt = ns->derived_types; dt; dt = dt->next)
1516 if (dt->derived == derived)
1519 if (dt->derived->backend_decl == NULL
1520 && gfc_compare_derived_types (dt->derived, derived))
1521 gfc_get_derived_type (dt->derived);
1523 if (copy_dt_decls_ifequal (dt->derived, derived))
1526 if (derived->backend_decl)
1527 goto other_equal_dts;
1530 /* We see this derived type first time, so build the type node. */
1531 typenode = make_node (RECORD_TYPE);
1532 TYPE_NAME (typenode) = get_identifier (derived->name);
1533 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1534 derived->backend_decl = typenode;
1537 /* Go through the derived type components, building them as
1538 necessary. The reason for doing this now is that it is
1539 possible to recurse back to this derived type through a
1540 pointer component (PR24092). If this happens, the fields
1541 will be built and so we can return the type. */
1542 for (c = derived->components; c; c = c->next)
1544 if (c->ts.type != BT_DERIVED)
1547 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1548 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1551 if (TYPE_FIELDS (derived->backend_decl))
1552 return derived->backend_decl;
1554 /* Build the type member list. Install the newly created RECORD_TYPE
1555 node as DECL_CONTEXT of each FIELD_DECL. */
1556 fieldlist = NULL_TREE;
1557 for (c = derived->components; c; c = c->next)
1559 if (c->ts.type == BT_DERIVED)
1560 field_type = c->ts.derived->backend_decl;
1563 if (c->ts.type == BT_CHARACTER)
1565 /* Evaluate the string length. */
1566 gfc_conv_const_charlen (c->ts.cl);
1567 gcc_assert (c->ts.cl->backend_decl);
1570 field_type = gfc_typenode_for_spec (&c->ts);
1573 /* This returns an array descriptor type. Initialization may be
1577 if (c->pointer || c->allocatable)
1579 /* Pointers to arrays aren't actually pointer types. The
1580 descriptors are separate, but the data is common. */
1581 field_type = gfc_build_array_type (field_type, c->as);
1584 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1586 else if (c->pointer)
1587 field_type = build_pointer_type (field_type);
1589 field = gfc_add_field_to_struct (&fieldlist, typenode,
1590 get_identifier (c->name),
1593 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1596 if (!c->backend_decl)
1597 c->backend_decl = field;
1600 /* Now we have the final fieldlist. Record it, then lay out the
1601 derived type, including the fields. */
1602 TYPE_FIELDS (typenode) = fieldlist;
1604 gfc_finish_type (typenode);
1606 derived->backend_decl = typenode;
1609 /* Add this backend_decl to all the other, equal derived types and
1610 their components in this and sibling namespaces. */
1611 ns = derived->ns->parent ? derived->ns->parent->contained : derived->ns;
1612 for (; ns; ns = ns->sibling)
1613 for (dt = ns->derived_types; dt; dt = dt->next)
1614 copy_dt_decls_ifequal (derived, dt->derived);
1616 return derived->backend_decl;
1621 gfc_return_by_reference (gfc_symbol * sym)
1623 if (!sym->attr.function)
1626 if (sym->attr.dimension)
1629 if (sym->ts.type == BT_CHARACTER)
1632 /* Possibly return complex numbers by reference for g77 compatibility.
1633 We don't do this for calls to intrinsics (as the library uses the
1634 -fno-f2c calling convention), nor for calls to functions which always
1635 require an explicit interface, as no compatibility problems can
1637 if (gfc_option.flag_f2c
1638 && sym->ts.type == BT_COMPLEX
1639 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1646 gfc_get_mixed_entry_union (gfc_namespace *ns)
1651 char name[GFC_MAX_SYMBOL_LEN + 1];
1652 gfc_entry_list *el, *el2;
1654 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1655 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1657 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1659 /* Build the type node. */
1660 type = make_node (UNION_TYPE);
1662 TYPE_NAME (type) = get_identifier (name);
1665 for (el = ns->entries; el; el = el->next)
1667 /* Search for duplicates. */
1668 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1669 if (el2->sym->result == el->sym->result)
1674 decl = build_decl (FIELD_DECL,
1675 get_identifier (el->sym->result->name),
1676 gfc_sym_type (el->sym->result));
1677 DECL_CONTEXT (decl) = type;
1678 fieldlist = chainon (fieldlist, decl);
1682 /* Finish off the type. */
1683 TYPE_FIELDS (type) = fieldlist;
1685 gfc_finish_type (type);
1690 gfc_get_function_type (gfc_symbol * sym)
1694 gfc_formal_arglist *f;
1697 int alternate_return;
1699 /* Make sure this symbol is a function or a subroutine. */
1700 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1702 if (sym->backend_decl)
1703 return TREE_TYPE (sym->backend_decl);
1706 alternate_return = 0;
1707 typelist = NULL_TREE;
1709 if (sym->attr.entry_master)
1711 /* Additional parameter for selecting an entry point. */
1712 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1715 /* Some functions we use an extra parameter for the return value. */
1716 if (gfc_return_by_reference (sym))
1723 if (arg->ts.type == BT_CHARACTER)
1724 gfc_conv_const_charlen (arg->ts.cl);
1726 type = gfc_sym_type (arg);
1727 if (arg->ts.type == BT_COMPLEX
1728 || arg->attr.dimension
1729 || arg->ts.type == BT_CHARACTER)
1730 type = build_reference_type (type);
1732 typelist = gfc_chainon_list (typelist, type);
1733 if (arg->ts.type == BT_CHARACTER)
1734 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1737 /* Build the argument types for the function. */
1738 for (f = sym->formal; f; f = f->next)
1743 /* Evaluate constant character lengths here so that they can be
1744 included in the type. */
1745 if (arg->ts.type == BT_CHARACTER)
1746 gfc_conv_const_charlen (arg->ts.cl);
1748 if (arg->attr.flavor == FL_PROCEDURE)
1750 type = gfc_get_function_type (arg);
1751 type = build_pointer_type (type);
1754 type = gfc_sym_type (arg);
1756 /* Parameter Passing Convention
1758 We currently pass all parameters by reference.
1759 Parameters with INTENT(IN) could be passed by value.
1760 The problem arises if a function is called via an implicit
1761 prototype. In this situation the INTENT is not known.
1762 For this reason all parameters to global functions must be
1763 passed by reference. Passing by value would potentially
1764 generate bad code. Worse there would be no way of telling that
1765 this code was bad, except that it would give incorrect results.
1767 Contained procedures could pass by value as these are never
1768 used without an explicit interface, and cannot be passed as
1769 actual parameters for a dummy procedure. */
1770 if (arg->ts.type == BT_CHARACTER)
1772 typelist = gfc_chainon_list (typelist, type);
1776 if (sym->attr.subroutine)
1777 alternate_return = 1;
1781 /* Add hidden string length parameters. */
1783 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1785 typelist = gfc_chainon_list (typelist, void_type_node);
1787 if (alternate_return)
1788 type = integer_type_node;
1789 else if (!sym->attr.function || gfc_return_by_reference (sym))
1790 type = void_type_node;
1791 else if (sym->attr.mixed_entry_master)
1792 type = gfc_get_mixed_entry_union (sym->ns);
1794 type = gfc_sym_type (sym);
1796 type = build_function_type (type, typelist);
1801 /* Language hooks for middle-end access to type nodes. */
1803 /* Return an integer type with BITS bits of precision,
1804 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1807 gfc_type_for_size (unsigned bits, int unsignedp)
1812 for (i = 0; i <= MAX_INT_KINDS; ++i)
1814 tree type = gfc_integer_types[i];
1815 if (type && bits == TYPE_PRECISION (type))
1821 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1822 return unsigned_intQI_type_node;
1823 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1824 return unsigned_intHI_type_node;
1825 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1826 return unsigned_intSI_type_node;
1827 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1828 return unsigned_intDI_type_node;
1829 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1830 return unsigned_intTI_type_node;
1836 /* Return a data type that has machine mode MODE. If the mode is an
1837 integer, then UNSIGNEDP selects between signed and unsigned types. */
1840 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1845 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1846 base = gfc_real_types;
1847 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1848 base = gfc_complex_types;
1849 else if (SCALAR_INT_MODE_P (mode))
1850 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1851 else if (VECTOR_MODE_P (mode))
1853 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1854 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1855 if (inner_type != NULL_TREE)
1856 return build_vector_type_for_mode (inner_type, mode);
1862 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1864 tree type = base[i];
1865 if (type && mode == TYPE_MODE (type))
1872 /* Return a type the same as TYPE except unsigned or
1873 signed according to UNSIGNEDP. */
1876 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1878 if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
1881 return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
1884 /* Return an unsigned type the same as TYPE in other respects. */
1887 gfc_unsigned_type (tree type)
1889 return gfc_signed_or_unsigned_type (1, type);
1892 /* Return a signed type the same as TYPE in other respects. */
1895 gfc_signed_type (tree type)
1897 return gfc_signed_or_unsigned_type (0, type);
1900 #include "gt-fortran-trans-types.h"