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 /* In the case of a function the fake result variable may have a
1325 type different from the function type, so don't return early in
1327 if (sym->backend_decl && !sym->attr.function)
1328 return TREE_TYPE (sym->backend_decl);
1330 type = gfc_typenode_for_spec (&sym->ts);
1332 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1337 if (sym->attr.dimension)
1339 if (gfc_is_nodesc_array (sym))
1341 /* If this is a character argument of unknown length, just use the
1343 if (sym->ts.type != BT_CHARACTER
1344 || !(sym->attr.dummy || sym->attr.function)
1345 || sym->ts.cl->backend_decl)
1347 type = gfc_get_nodesc_array_type (type, sym->as,
1353 type = gfc_build_array_type (type, sym->as);
1357 if (sym->attr.allocatable || sym->attr.pointer)
1358 type = gfc_build_pointer_type (sym, type);
1361 /* We currently pass all parameters by reference.
1362 See f95_get_function_decl. For dummy function parameters return the
1366 /* We must use pointer types for potentially absent variables. The
1367 optimizers assume a reference type argument is never NULL. */
1368 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1369 type = build_pointer_type (type);
1371 type = build_reference_type (type);
1377 /* Layout and output debug info for a record type. */
1380 gfc_finish_type (tree type)
1384 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1385 TYPE_STUB_DECL (type) = decl;
1387 rest_of_type_compilation (type, 1);
1388 rest_of_decl_compilation (decl, 1, 0);
1391 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1392 or RECORD_TYPE pointed to by STYPE. The new field is chained
1393 to the fieldlist pointed to by FIELDLIST.
1395 Returns a pointer to the new field. */
1398 gfc_add_field_to_struct (tree *fieldlist, tree context,
1399 tree name, tree type)
1403 decl = build_decl (FIELD_DECL, name, type);
1405 DECL_CONTEXT (decl) = context;
1406 DECL_INITIAL (decl) = 0;
1407 DECL_ALIGN (decl) = 0;
1408 DECL_USER_ALIGN (decl) = 0;
1409 TREE_CHAIN (decl) = NULL_TREE;
1410 *fieldlist = chainon (*fieldlist, decl);
1416 /* Copy the backend_decl and component backend_decls if
1417 the two derived type symbols are "equal", as described
1418 in 4.4.2 and resolved by gfc_compare_derived_types. */
1421 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1423 gfc_component *to_cm;
1424 gfc_component *from_cm;
1426 if (from->backend_decl == NULL
1427 || !gfc_compare_derived_types (from, to))
1430 to->backend_decl = from->backend_decl;
1432 to_cm = to->components;
1433 from_cm = from->components;
1435 /* Copy the component declarations. If a component is itself
1436 a derived type, we need a copy of its component declarations.
1437 This is done by recursing into gfc_get_derived_type and
1438 ensures that the component's component declarations have
1439 been built. If it is a character, we need the character
1441 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1443 to_cm->backend_decl = from_cm->backend_decl;
1444 if (from_cm->ts.type == BT_DERIVED)
1445 gfc_get_derived_type (to_cm->ts.derived);
1447 else if (from_cm->ts.type == BT_CHARACTER)
1448 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1455 /* Build a tree node for a derived type. If there are equal
1456 derived types, with different local names, these are built
1457 at the same time. If an equal derived type has been built
1458 in a parent namespace, this is used. */
1461 gfc_get_derived_type (gfc_symbol * derived)
1463 tree typenode, field, field_type, fieldlist;
1467 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1469 /* derived->backend_decl != 0 means we saw it before, but its
1470 components' backend_decl may have not been built. */
1471 if (derived->backend_decl)
1473 /* Its components' backend_decl have been built. */
1474 if (TYPE_FIELDS (derived->backend_decl))
1475 return derived->backend_decl;
1477 typenode = derived->backend_decl;
1482 /* We see this derived type first time, so build the type node. */
1483 typenode = make_node (RECORD_TYPE);
1484 TYPE_NAME (typenode) = get_identifier (derived->name);
1485 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1486 derived->backend_decl = typenode;
1489 /* Go through the derived type components, building them as
1490 necessary. The reason for doing this now is that it is
1491 possible to recurse back to this derived type through a
1492 pointer component (PR24092). If this happens, the fields
1493 will be built and so we can return the type. */
1494 for (c = derived->components; c; c = c->next)
1496 if (c->ts.type != BT_DERIVED)
1499 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1500 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1503 if (TYPE_FIELDS (derived->backend_decl))
1504 return derived->backend_decl;
1506 /* Build the type member list. Install the newly created RECORD_TYPE
1507 node as DECL_CONTEXT of each FIELD_DECL. */
1508 fieldlist = NULL_TREE;
1509 for (c = derived->components; c; c = c->next)
1511 if (c->ts.type == BT_DERIVED)
1512 field_type = c->ts.derived->backend_decl;
1515 if (c->ts.type == BT_CHARACTER)
1517 /* Evaluate the string length. */
1518 gfc_conv_const_charlen (c->ts.cl);
1519 gcc_assert (c->ts.cl->backend_decl);
1522 field_type = gfc_typenode_for_spec (&c->ts);
1525 /* This returns an array descriptor type. Initialization may be
1529 if (c->pointer || c->allocatable)
1531 /* Pointers to arrays aren't actually pointer types. The
1532 descriptors are separate, but the data is common. */
1533 field_type = gfc_build_array_type (field_type, c->as);
1536 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1538 else if (c->pointer)
1539 field_type = build_pointer_type (field_type);
1541 field = gfc_add_field_to_struct (&fieldlist, typenode,
1542 get_identifier (c->name),
1545 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1548 if (!c->backend_decl)
1549 c->backend_decl = field;
1552 /* Now we have the final fieldlist. Record it, then lay out the
1553 derived type, including the fields. */
1554 TYPE_FIELDS (typenode) = fieldlist;
1556 gfc_finish_type (typenode);
1558 derived->backend_decl = typenode;
1560 /* Add this backend_decl to all the other, equal derived types. */
1561 for (dt = gfc_derived_types; dt; dt = dt->next)
1562 copy_dt_decls_ifequal (derived, dt->derived);
1564 return derived->backend_decl;
1569 gfc_return_by_reference (gfc_symbol * sym)
1571 if (!sym->attr.function)
1574 if (sym->attr.dimension)
1577 if (sym->ts.type == BT_CHARACTER)
1580 /* Possibly return complex numbers by reference for g77 compatibility.
1581 We don't do this for calls to intrinsics (as the library uses the
1582 -fno-f2c calling convention), nor for calls to functions which always
1583 require an explicit interface, as no compatibility problems can
1585 if (gfc_option.flag_f2c
1586 && sym->ts.type == BT_COMPLEX
1587 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1594 gfc_get_mixed_entry_union (gfc_namespace *ns)
1599 char name[GFC_MAX_SYMBOL_LEN + 1];
1600 gfc_entry_list *el, *el2;
1602 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1603 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1605 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1607 /* Build the type node. */
1608 type = make_node (UNION_TYPE);
1610 TYPE_NAME (type) = get_identifier (name);
1613 for (el = ns->entries; el; el = el->next)
1615 /* Search for duplicates. */
1616 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1617 if (el2->sym->result == el->sym->result)
1622 decl = build_decl (FIELD_DECL,
1623 get_identifier (el->sym->result->name),
1624 gfc_sym_type (el->sym->result));
1625 DECL_CONTEXT (decl) = type;
1626 fieldlist = chainon (fieldlist, decl);
1630 /* Finish off the type. */
1631 TYPE_FIELDS (type) = fieldlist;
1633 gfc_finish_type (type);
1638 gfc_get_function_type (gfc_symbol * sym)
1642 gfc_formal_arglist *f;
1645 int alternate_return;
1647 /* Make sure this symbol is a function or a subroutine. */
1648 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1650 if (sym->backend_decl)
1651 return TREE_TYPE (sym->backend_decl);
1654 alternate_return = 0;
1655 typelist = NULL_TREE;
1657 if (sym->attr.entry_master)
1659 /* Additional parameter for selecting an entry point. */
1660 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1663 /* Some functions we use an extra parameter for the return value. */
1664 if (gfc_return_by_reference (sym))
1671 if (arg->ts.type == BT_CHARACTER)
1672 gfc_conv_const_charlen (arg->ts.cl);
1674 type = gfc_sym_type (arg);
1675 if (arg->ts.type == BT_COMPLEX
1676 || arg->attr.dimension
1677 || arg->ts.type == BT_CHARACTER)
1678 type = build_reference_type (type);
1680 typelist = gfc_chainon_list (typelist, type);
1681 if (arg->ts.type == BT_CHARACTER)
1682 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1685 /* Build the argument types for the function. */
1686 for (f = sym->formal; f; f = f->next)
1691 /* Evaluate constant character lengths here so that they can be
1692 included in the type. */
1693 if (arg->ts.type == BT_CHARACTER)
1694 gfc_conv_const_charlen (arg->ts.cl);
1696 if (arg->attr.flavor == FL_PROCEDURE)
1698 type = gfc_get_function_type (arg);
1699 type = build_pointer_type (type);
1702 type = gfc_sym_type (arg);
1704 /* Parameter Passing Convention
1706 We currently pass all parameters by reference.
1707 Parameters with INTENT(IN) could be passed by value.
1708 The problem arises if a function is called via an implicit
1709 prototype. In this situation the INTENT is not known.
1710 For this reason all parameters to global functions must be
1711 passed by reference. Passing by value would potentially
1712 generate bad code. Worse there would be no way of telling that
1713 this code was bad, except that it would give incorrect results.
1715 Contained procedures could pass by value as these are never
1716 used without an explicit interface, and cannot be passed as
1717 actual parameters for a dummy procedure. */
1718 if (arg->ts.type == BT_CHARACTER)
1720 typelist = gfc_chainon_list (typelist, type);
1724 if (sym->attr.subroutine)
1725 alternate_return = 1;
1729 /* Add hidden string length parameters. */
1731 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1734 typelist = gfc_chainon_list (typelist, void_type_node);
1736 if (alternate_return)
1737 type = integer_type_node;
1738 else if (!sym->attr.function || gfc_return_by_reference (sym))
1739 type = void_type_node;
1740 else if (sym->attr.mixed_entry_master)
1741 type = gfc_get_mixed_entry_union (sym->ns);
1742 else if (gfc_option.flag_f2c
1743 && sym->ts.type == BT_REAL
1744 && sym->ts.kind == gfc_default_real_kind
1745 && !sym->attr.always_explicit)
1747 /* Special case: f2c calling conventions require that (scalar)
1748 default REAL functions return the C type double instead. f2c
1749 compatibility is only an issue with functions that don't
1750 require an explicit interface, as only these could be
1751 implemented in Fortran 77. */
1752 sym->ts.kind = gfc_default_double_kind;
1753 type = gfc_typenode_for_spec (&sym->ts);
1754 sym->ts.kind = gfc_default_real_kind;
1757 type = gfc_sym_type (sym);
1759 type = build_function_type (type, typelist);
1764 /* Language hooks for middle-end access to type nodes. */
1766 /* Return an integer type with BITS bits of precision,
1767 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1770 gfc_type_for_size (unsigned bits, int unsignedp)
1775 for (i = 0; i <= MAX_INT_KINDS; ++i)
1777 tree type = gfc_integer_types[i];
1778 if (type && bits == TYPE_PRECISION (type))
1784 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1785 return unsigned_intQI_type_node;
1786 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1787 return unsigned_intHI_type_node;
1788 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1789 return unsigned_intSI_type_node;
1790 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1791 return unsigned_intDI_type_node;
1792 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1793 return unsigned_intTI_type_node;
1799 /* Return a data type that has machine mode MODE. If the mode is an
1800 integer, then UNSIGNEDP selects between signed and unsigned types. */
1803 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1808 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1809 base = gfc_real_types;
1810 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1811 base = gfc_complex_types;
1812 else if (SCALAR_INT_MODE_P (mode))
1813 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1814 else if (VECTOR_MODE_P (mode))
1816 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1817 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1818 if (inner_type != NULL_TREE)
1819 return build_vector_type_for_mode (inner_type, mode);
1825 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1827 tree type = base[i];
1828 if (type && mode == TYPE_MODE (type))
1835 /* Return an unsigned type the same as TYPE in other respects. */
1838 gfc_unsigned_type (tree type)
1840 return get_signed_or_unsigned_type (1, type);
1843 /* Return a signed type the same as TYPE in other respects. */
1846 gfc_signed_type (tree type)
1848 return get_signed_or_unsigned_type (0, type);
1851 #include "gt-fortran-trans-types.h"