1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
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 integer kind used to store character lengths. */
101 int gfc_charlen_int_kind;
103 /* The size of the numeric storage unit and character storage unit. */
104 int gfc_numeric_storage_size;
105 int gfc_character_storage_size;
107 /* Query the target to determine which machine modes are available for
108 computation. Choose KIND numbers for them. */
111 gfc_init_kinds (void)
113 enum machine_mode mode;
114 int i_index, r_index;
115 bool saw_i4 = false, saw_i8 = false;
116 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
118 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
122 if (!targetm.scalar_mode_supported_p (mode))
125 /* The middle end doesn't support constants larger than 2*HWI.
126 Perhaps the target hook shouldn't have accepted these either,
127 but just to be safe... */
128 bitsize = GET_MODE_BITSIZE (mode);
129 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
132 gcc_assert (i_index != MAX_INT_KINDS);
134 /* Let the kind equal the bit size divided by 8. This insulates the
135 programmer from the underlying byte size. */
143 gfc_integer_kinds[i_index].kind = kind;
144 gfc_integer_kinds[i_index].radix = 2;
145 gfc_integer_kinds[i_index].digits = bitsize - 1;
146 gfc_integer_kinds[i_index].bit_size = bitsize;
148 gfc_logical_kinds[i_index].kind = kind;
149 gfc_logical_kinds[i_index].bit_size = bitsize;
154 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
155 used for large file access. */
162 /* If we do not at least have kind = 4, everything is pointless. */
165 /* Set the maximum integer kind. Used with at least BOZ constants. */
166 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
168 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
170 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
175 if (!targetm.scalar_mode_supported_p (mode))
178 /* Only let float/double/long double go through because the fortran
179 library assumes these are the only floating point types. */
181 if (mode != TYPE_MODE (float_type_node)
182 && (mode != TYPE_MODE (double_type_node))
183 && (mode != TYPE_MODE (long_double_type_node)))
186 /* Let the kind equal the precision divided by 8, rounding up. Again,
187 this insulates the programmer from the underlying byte size.
189 Also, it effectively deals with IEEE extended formats. There, the
190 total size of the type may equal 16, but it's got 6 bytes of padding
191 and the increased size can get in the way of a real IEEE quad format
192 which may also be supported by the target.
194 We round up so as to handle IA-64 __floatreg (RFmode), which is an
195 82 bit type. Not to be confused with __float80 (XFmode), which is
196 an 80 bit type also supported by IA-64. So XFmode should come out
197 to be kind=10, and RFmode should come out to be kind=11. Egads. */
199 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
208 /* Careful we don't stumble a wierd internal mode. */
209 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
210 /* Or have too many modes for the allocated space. */
211 gcc_assert (r_index != MAX_REAL_KINDS);
213 gfc_real_kinds[r_index].kind = kind;
214 gfc_real_kinds[r_index].radix = fmt->b;
215 gfc_real_kinds[r_index].digits = fmt->p;
216 gfc_real_kinds[r_index].min_exponent = fmt->emin;
217 gfc_real_kinds[r_index].max_exponent = fmt->emax;
218 if (fmt->pnan < fmt->p)
219 /* This is an IBM extended double format (or the MIPS variant)
220 made up of two IEEE doubles. The value of the long double is
221 the sum of the values of the two parts. The most significant
222 part is required to be the value of the long double rounded
223 to the nearest double. If we use emax of 1024 then we can't
224 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
225 rounding will make the most significant part overflow. */
226 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
227 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
231 /* Choose the default integer kind. We choose 4 unless the user
232 directs us otherwise. */
233 if (gfc_option.flag_default_integer)
236 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
237 gfc_default_integer_kind = 8;
239 /* Even if the user specified that the default integer kind be 8,
240 the numerica storage size isn't 64. In this case, a warning will
241 be issued when NUMERIC_STORAGE_SIZE is used. */
242 gfc_numeric_storage_size = 4 * 8;
246 gfc_default_integer_kind = 4;
247 gfc_numeric_storage_size = 4 * 8;
251 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
252 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
255 /* Choose the default real kind. Again, we choose 4 when possible. */
256 if (gfc_option.flag_default_real)
259 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
260 gfc_default_real_kind = 8;
263 gfc_default_real_kind = 4;
265 gfc_default_real_kind = gfc_real_kinds[0].kind;
267 /* Choose the default double kind. If -fdefault-real and -fdefault-double
268 are specified, we use kind=8, if it's available. If -fdefault-real is
269 specified without -fdefault-double, we use kind=16, if it's available.
270 Otherwise we do not change anything. */
271 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
272 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
274 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
275 gfc_default_double_kind = 8;
276 else if (gfc_option.flag_default_real && saw_r16)
277 gfc_default_double_kind = 16;
278 else if (saw_r4 && saw_r8)
279 gfc_default_double_kind = 8;
282 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
283 real ... occupies two contiguous numeric storage units.
285 Therefore we must be supplied a kind twice as large as we chose
286 for single precision. There are loopholes, in that double
287 precision must *occupy* two storage units, though it doesn't have
288 to *use* two storage units. Which means that you can make this
289 kind artificially wide by padding it. But at present there are
290 no GCC targets for which a two-word type does not exist, so we
291 just let gfc_validate_kind abort and tell us if something breaks. */
293 gfc_default_double_kind
294 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
297 /* The default logical kind is constrained to be the same as the
298 default integer kind. Similarly with complex and real. */
299 gfc_default_logical_kind = gfc_default_integer_kind;
300 gfc_default_complex_kind = gfc_default_real_kind;
302 /* Choose the smallest integer kind for our default character. */
303 gfc_default_character_kind = gfc_integer_kinds[0].kind;
304 gfc_character_storage_size = gfc_default_character_kind * 8;
306 /* Choose the integer kind the same size as "void*" for our index kind. */
307 gfc_index_integer_kind = POINTER_SIZE / 8;
308 /* Pick a kind the same size as the C "int" type. */
309 gfc_c_int_kind = INT_TYPE_SIZE / 8;
312 /* Make sure that a valid kind is present. Returns an index into the
313 associated kinds array, -1 if the kind is not present. */
316 validate_integer (int kind)
320 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
321 if (gfc_integer_kinds[i].kind == kind)
328 validate_real (int kind)
332 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
333 if (gfc_real_kinds[i].kind == kind)
340 validate_logical (int kind)
344 for (i = 0; gfc_logical_kinds[i].kind; i++)
345 if (gfc_logical_kinds[i].kind == kind)
352 validate_character (int kind)
354 return kind == gfc_default_character_kind ? 0 : -1;
357 /* Validate a kind given a basic type. The return value is the same
358 for the child functions, with -1 indicating nonexistence of the
359 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
362 gfc_validate_kind (bt type, int kind, bool may_fail)
368 case BT_REAL: /* Fall through */
370 rc = validate_real (kind);
373 rc = validate_integer (kind);
376 rc = validate_logical (kind);
379 rc = validate_character (kind);
383 gfc_internal_error ("gfc_validate_kind(): Got bad type");
386 if (rc < 0 && !may_fail)
387 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
393 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
394 Reuse common type nodes where possible. Recognize if the kind matches up
395 with a C type. This will be used later in determining which routines may
396 be scarfed from libm. */
399 gfc_build_int_type (gfc_integer_info *info)
401 int mode_precision = info->bit_size;
403 if (mode_precision == CHAR_TYPE_SIZE)
405 if (mode_precision == SHORT_TYPE_SIZE)
407 if (mode_precision == INT_TYPE_SIZE)
409 if (mode_precision == LONG_TYPE_SIZE)
411 if (mode_precision == LONG_LONG_TYPE_SIZE)
412 info->c_long_long = 1;
414 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
415 return intQI_type_node;
416 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
417 return intHI_type_node;
418 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
419 return intSI_type_node;
420 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
421 return intDI_type_node;
422 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
423 return intTI_type_node;
425 return make_signed_type (mode_precision);
429 gfc_build_real_type (gfc_real_info *info)
431 int mode_precision = info->mode_precision;
434 if (mode_precision == FLOAT_TYPE_SIZE)
436 if (mode_precision == DOUBLE_TYPE_SIZE)
438 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
439 info->c_long_double = 1;
441 if (TYPE_PRECISION (float_type_node) == mode_precision)
442 return float_type_node;
443 if (TYPE_PRECISION (double_type_node) == mode_precision)
444 return double_type_node;
445 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
446 return long_double_type_node;
448 new_type = make_node (REAL_TYPE);
449 TYPE_PRECISION (new_type) = mode_precision;
450 layout_type (new_type);
455 gfc_build_complex_type (tree scalar_type)
459 if (scalar_type == NULL)
461 if (scalar_type == float_type_node)
462 return complex_float_type_node;
463 if (scalar_type == double_type_node)
464 return complex_double_type_node;
465 if (scalar_type == long_double_type_node)
466 return complex_long_double_type_node;
468 new_type = make_node (COMPLEX_TYPE);
469 TREE_TYPE (new_type) = scalar_type;
470 layout_type (new_type);
475 gfc_build_logical_type (gfc_logical_info *info)
477 int bit_size = info->bit_size;
480 if (bit_size == BOOL_TYPE_SIZE)
483 return boolean_type_node;
486 new_type = make_unsigned_type (bit_size);
487 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
488 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
489 TYPE_PRECISION (new_type) = 1;
495 /* Return the bit size of the C "size_t". */
501 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
502 return INT_TYPE_SIZE;
503 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
504 return LONG_TYPE_SIZE;
505 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
506 return SHORT_TYPE_SIZE;
509 return LONG_TYPE_SIZE;
514 /* Create the backend type nodes. We map them to their
515 equivalent C type, at least for now. We also give
516 names to the types here, and we push them in the
517 global binding level context.*/
520 gfc_init_types (void)
526 unsigned HOST_WIDE_INT hi;
527 unsigned HOST_WIDE_INT lo;
529 /* Create and name the types. */
530 #define PUSH_TYPE(name, node) \
531 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
533 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
535 type = gfc_build_int_type (&gfc_integer_kinds[index]);
536 gfc_integer_types[index] = type;
537 snprintf (name_buf, sizeof(name_buf), "int%d",
538 gfc_integer_kinds[index].kind);
539 PUSH_TYPE (name_buf, type);
542 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
544 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
545 gfc_logical_types[index] = type;
546 snprintf (name_buf, sizeof(name_buf), "logical%d",
547 gfc_logical_kinds[index].kind);
548 PUSH_TYPE (name_buf, type);
551 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
553 type = gfc_build_real_type (&gfc_real_kinds[index]);
554 gfc_real_types[index] = type;
555 snprintf (name_buf, sizeof(name_buf), "real%d",
556 gfc_real_kinds[index].kind);
557 PUSH_TYPE (name_buf, type);
559 type = gfc_build_complex_type (type);
560 gfc_complex_types[index] = type;
561 snprintf (name_buf, sizeof(name_buf), "complex%d",
562 gfc_real_kinds[index].kind);
563 PUSH_TYPE (name_buf, type);
566 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
568 PUSH_TYPE ("char", gfc_character1_type_node);
570 PUSH_TYPE ("byte", unsigned_char_type_node);
571 PUSH_TYPE ("void", void_type_node);
573 /* DBX debugging output gets upset if these aren't set. */
574 if (!TYPE_NAME (integer_type_node))
575 PUSH_TYPE ("c_integer", integer_type_node);
576 if (!TYPE_NAME (char_type_node))
577 PUSH_TYPE ("c_char", char_type_node);
581 pvoid_type_node = build_pointer_type (void_type_node);
582 ppvoid_type_node = build_pointer_type (pvoid_type_node);
583 pchar_type_node = build_pointer_type (gfc_character1_type_node);
585 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
586 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
587 since this function is called before gfc_init_constants. */
589 = build_range_type (gfc_array_index_type,
590 build_int_cst (gfc_array_index_type, 0),
593 /* The maximum array element size that can be handled is determined
594 by the number of bits available to store this field in the array
597 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
598 lo = ~ (unsigned HOST_WIDE_INT) 0;
599 if (n > HOST_BITS_PER_WIDE_INT)
600 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
602 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
603 gfc_max_array_element_size
604 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
606 size_type_node = gfc_array_index_type;
608 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
609 boolean_true_node = build_int_cst (boolean_type_node, 1);
610 boolean_false_node = build_int_cst (boolean_type_node, 0);
612 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
613 gfc_charlen_int_kind = 4;
614 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
617 /* Get the type node for the given type and kind. */
620 gfc_get_int_type (int kind)
622 int index = gfc_validate_kind (BT_INTEGER, kind, true);
623 return index < 0 ? 0 : gfc_integer_types[index];
627 gfc_get_real_type (int kind)
629 int index = gfc_validate_kind (BT_REAL, kind, true);
630 return index < 0 ? 0 : gfc_real_types[index];
634 gfc_get_complex_type (int kind)
636 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
637 return index < 0 ? 0 : gfc_complex_types[index];
641 gfc_get_logical_type (int kind)
643 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
644 return index < 0 ? 0 : gfc_logical_types[index];
647 /* Create a character type with the given kind and length. */
650 gfc_get_character_type_len (int kind, tree len)
654 gfc_validate_kind (BT_CHARACTER, kind, false);
656 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
657 type = build_array_type (gfc_character1_type_node, bounds);
658 TYPE_STRING_FLAG (type) = 1;
664 /* Get a type node for a character kind. */
667 gfc_get_character_type (int kind, gfc_charlen * cl)
671 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
673 return gfc_get_character_type_len (kind, len);
676 /* Covert a basic type. This will be an array for character types. */
679 gfc_typenode_for_spec (gfc_typespec * spec)
689 basetype = gfc_get_int_type (spec->kind);
693 basetype = gfc_get_real_type (spec->kind);
697 basetype = gfc_get_complex_type (spec->kind);
701 basetype = gfc_get_logical_type (spec->kind);
705 basetype = gfc_get_character_type (spec->kind, spec->cl);
709 basetype = gfc_get_derived_type (spec->derived);
718 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
721 gfc_conv_array_bound (gfc_expr * expr)
723 /* If expr is an integer constant, return that. */
724 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
725 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
727 /* Otherwise return NULL. */
732 gfc_get_element_type (tree type)
736 if (GFC_ARRAY_TYPE_P (type))
738 if (TREE_CODE (type) == POINTER_TYPE)
739 type = TREE_TYPE (type);
740 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
741 element = TREE_TYPE (type);
745 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
746 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
748 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
749 element = TREE_TYPE (element);
751 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
752 element = TREE_TYPE (element);
758 /* Build an array. This function is called from gfc_sym_type().
759 Actually returns array descriptor type.
761 Format of array descriptors is as follows:
763 struct gfc_array_descriptor
768 struct descriptor_dimension dimension[N_DIM];
771 struct descriptor_dimension
778 Translation code should use gfc_conv_descriptor_* rather than
779 accessing the descriptor directly. Any changes to the array
780 descriptor type will require changes in gfc_conv_descriptor_* and
781 gfc_build_array_initializer.
783 This is represented internally as a RECORD_TYPE. The index nodes
784 are gfc_array_index_type and the data node is a pointer to the
785 data. See below for the handling of character types.
787 The dtype member is formatted as follows:
788 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
789 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
790 size = dtype >> GFC_DTYPE_SIZE_SHIFT
792 I originally used nested ARRAY_TYPE nodes to represent arrays, but
793 this generated poor code for assumed/deferred size arrays. These
794 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
795 of the GENERIC grammar. Also, there is no way to explicitly set
796 the array stride, so all data must be packed(1). I've tried to
797 mark all the functions which would require modification with a GCC
800 The data component points to the first element in the array. The
801 offset field is the position of the origin of the array (ie element
802 (0, 0 ...)). This may be outsite the bounds of the array.
804 An element is accessed by
805 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
806 This gives good performance as the computation does not involve the
807 bounds of the array. For packed arrays, this is optimized further
808 by substituting the known strides.
810 This system has one problem: all array bounds must be within 2^31
811 elements of the origin (2^63 on 64-bit machines). For example
812 integer, dimension (80000:90000, 80000:90000, 2) :: array
813 may not work properly on 32-bit machines because 80000*80000 >
814 2^31, so the calculation for stride02 would overflow. This may
815 still work, but I haven't checked, and it relies on the overflow
816 doing the right thing.
818 The way to fix this problem is to access elements as follows:
819 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
820 Obviously this is much slower. I will make this a compile time
821 option, something like -fsmall-array-offsets. Mixing code compiled
822 with and without this switch will work.
824 (1) This can be worked around by modifying the upper bound of the
825 previous dimension. This requires extra fields in the descriptor
826 (both real_ubound and fake_ubound). */
829 /* Returns true if the array sym does not require a descriptor. */
832 gfc_is_nodesc_array (gfc_symbol * sym)
834 gcc_assert (sym->attr.dimension);
836 /* We only want local arrays. */
837 if (sym->attr.pointer || sym->attr.allocatable)
842 if (sym->as->type != AS_ASSUMED_SHAPE)
848 if (sym->attr.result || sym->attr.function)
851 gcc_assert (sym->as->type == AS_EXPLICIT);
857 /* Create an array descriptor type. */
860 gfc_build_array_type (tree type, gfc_array_spec * as)
862 tree lbound[GFC_MAX_DIMENSIONS];
863 tree ubound[GFC_MAX_DIMENSIONS];
866 for (n = 0; n < as->rank; n++)
868 /* Create expressions for the known bounds of the array. */
869 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
870 lbound[n] = gfc_index_one_node;
872 lbound[n] = gfc_conv_array_bound (as->lower[n]);
873 ubound[n] = gfc_conv_array_bound (as->upper[n]);
876 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
879 /* Returns the struct descriptor_dimension type. */
882 gfc_get_desc_dim_type (void)
888 if (gfc_desc_dim_type)
889 return gfc_desc_dim_type;
891 /* Build the type node. */
892 type = make_node (RECORD_TYPE);
894 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
895 TYPE_PACKED (type) = 1;
897 /* Consists of the stride, lbound and ubound members. */
898 decl = build_decl (FIELD_DECL,
899 get_identifier ("stride"), gfc_array_index_type);
900 DECL_CONTEXT (decl) = type;
903 decl = build_decl (FIELD_DECL,
904 get_identifier ("lbound"), gfc_array_index_type);
905 DECL_CONTEXT (decl) = type;
906 fieldlist = chainon (fieldlist, decl);
908 decl = build_decl (FIELD_DECL,
909 get_identifier ("ubound"), gfc_array_index_type);
910 DECL_CONTEXT (decl) = type;
911 fieldlist = chainon (fieldlist, decl);
913 /* Finish off the type. */
914 TYPE_FIELDS (type) = fieldlist;
916 gfc_finish_type (type);
918 gfc_desc_dim_type = type;
923 /* Return the DTYPE for an array. This describes the type and type parameters
925 /* TODO: Only call this when the value is actually used, and make all the
926 unknown cases abort. */
929 gfc_get_dtype (tree type)
939 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
941 if (GFC_TYPE_ARRAY_DTYPE (type))
942 return GFC_TYPE_ARRAY_DTYPE (type);
944 rank = GFC_TYPE_ARRAY_RANK (type);
945 etype = gfc_get_element_type (type);
947 switch (TREE_CODE (etype))
950 n = GFC_DTYPE_INTEGER;
954 n = GFC_DTYPE_LOGICAL;
962 n = GFC_DTYPE_COMPLEX;
965 /* We will never have arrays of arrays. */
967 n = GFC_DTYPE_DERIVED;
971 n = GFC_DTYPE_CHARACTER;
975 /* TODO: Don't do dtype for temporary descriptorless arrays. */
976 /* We can strange array types for temporary arrays. */
977 return gfc_index_zero_node;
980 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
981 size = TYPE_SIZE_UNIT (etype);
983 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
984 if (size && INTEGER_CST_P (size))
986 if (tree_int_cst_lt (gfc_max_array_element_size, size))
987 internal_error ("Array element size too big");
989 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
991 dtype = build_int_cst (gfc_array_index_type, i);
993 if (size && !INTEGER_CST_P (size))
995 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
996 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
997 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
999 /* If we don't know the size we leave it as zero. This should never happen
1000 for anything that is actually used. */
1001 /* TODO: Check this is actually true, particularly when repacking
1002 assumed size parameters. */
1004 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1009 /* Build an array type for use without a descriptor, packed according
1010 to the value of PACKED. */
1013 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
1026 mpz_init_set_ui (offset, 0);
1027 mpz_init_set_ui (stride, 1);
1030 /* We don't use build_array_type because this does not include include
1031 lang-specific information (i.e. the bounds of the array) when checking
1033 type = make_node (ARRAY_TYPE);
1035 GFC_ARRAY_TYPE_P (type) = 1;
1036 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1037 ggc_alloc_cleared (sizeof (struct lang_type));
1039 known_stride = (packed != PACKED_NO);
1041 for (n = 0; n < as->rank; n++)
1043 /* Fill in the stride and bound components of the type. */
1045 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1048 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1050 expr = as->lower[n];
1051 if (expr->expr_type == EXPR_CONSTANT)
1053 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1054 gfc_index_integer_kind);
1061 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1065 /* Calculate the offset. */
1066 mpz_mul (delta, stride, as->lower[n]->value.integer);
1067 mpz_sub (offset, offset, delta);
1072 expr = as->upper[n];
1073 if (expr && expr->expr_type == EXPR_CONSTANT)
1075 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1076 gfc_index_integer_kind);
1083 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1087 /* Calculate the stride. */
1088 mpz_sub (delta, as->upper[n]->value.integer,
1089 as->lower[n]->value.integer);
1090 mpz_add_ui (delta, delta, 1);
1091 mpz_mul (stride, stride, delta);
1094 /* Only the first stride is known for partial packed arrays. */
1095 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1101 GFC_TYPE_ARRAY_OFFSET (type) =
1102 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1105 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1109 GFC_TYPE_ARRAY_SIZE (type) =
1110 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1113 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1115 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1116 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1117 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1119 /* TODO: use main type if it is unbounded. */
1120 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1121 build_pointer_type (build_array_type (etype, range));
1125 mpz_sub_ui (stride, stride, 1);
1126 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1131 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1132 TYPE_DOMAIN (type) = range;
1134 build_pointer_type (etype);
1135 TREE_TYPE (type) = etype;
1143 if (packed != PACKED_STATIC || !known_stride)
1145 /* For dummy arrays and automatic (heap allocated) arrays we
1146 want a pointer to the array. */
1147 type = build_pointer_type (type);
1148 GFC_ARRAY_TYPE_P (type) = 1;
1149 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1154 /* Return or create the base type for an array descriptor. */
1157 gfc_get_array_descriptor_base (int dimen)
1159 tree fat_type, fieldlist, decl, arraytype;
1160 char name[16 + GFC_RANK_DIGITS + 1];
1162 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1163 if (gfc_array_descriptor_base[dimen - 1])
1164 return gfc_array_descriptor_base[dimen - 1];
1166 /* Build the type node. */
1167 fat_type = make_node (RECORD_TYPE);
1169 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1170 TYPE_NAME (fat_type) = get_identifier (name);
1172 /* Add the data member as the first element of the descriptor. */
1173 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1175 DECL_CONTEXT (decl) = fat_type;
1178 /* Add the base component. */
1179 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1180 gfc_array_index_type);
1181 DECL_CONTEXT (decl) = fat_type;
1182 fieldlist = chainon (fieldlist, decl);
1184 /* Add the dtype component. */
1185 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1186 gfc_array_index_type);
1187 DECL_CONTEXT (decl) = fat_type;
1188 fieldlist = chainon (fieldlist, decl);
1190 /* Build the array type for the stride and bound components. */
1192 build_array_type (gfc_get_desc_dim_type (),
1193 build_range_type (gfc_array_index_type,
1194 gfc_index_zero_node,
1195 gfc_rank_cst[dimen - 1]));
1197 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1198 DECL_CONTEXT (decl) = fat_type;
1199 fieldlist = chainon (fieldlist, decl);
1201 /* Finish off the type. */
1202 TYPE_FIELDS (fat_type) = fieldlist;
1204 gfc_finish_type (fat_type);
1206 gfc_array_descriptor_base[dimen - 1] = fat_type;
1210 /* Build an array (descriptor) type with given bounds. */
1213 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1214 tree * ubound, int packed)
1216 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1217 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1218 const char *typename;
1221 base_type = gfc_get_array_descriptor_base (dimen);
1222 fat_type = build_variant_type_copy (base_type);
1224 tmp = TYPE_NAME (etype);
1225 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1226 tmp = DECL_NAME (tmp);
1228 typename = IDENTIFIER_POINTER (tmp);
1230 typename = "unknown";
1231 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1232 GFC_MAX_SYMBOL_LEN, typename);
1233 TYPE_NAME (fat_type) = get_identifier (name);
1235 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1236 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1237 ggc_alloc_cleared (sizeof (struct lang_type));
1239 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1240 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1242 /* Build an array descriptor record type. */
1244 stride = gfc_index_one_node;
1247 for (n = 0; n < dimen; n++)
1249 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1256 if (lower != NULL_TREE)
1258 if (INTEGER_CST_P (lower))
1259 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1265 if (upper != NULL_TREE)
1267 if (INTEGER_CST_P (upper))
1268 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1273 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1275 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1276 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1277 gfc_index_one_node);
1279 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1280 /* Check the folding worked. */
1281 gcc_assert (INTEGER_CST_P (stride));
1286 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1288 /* TODO: known offsets for descriptors. */
1289 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1291 /* We define data as an unknown size array. Much better than doing
1292 pointer arithmetic. */
1294 build_array_type (etype, gfc_array_range_type);
1295 arraytype = build_pointer_type (arraytype);
1296 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1301 /* Build a pointer type. This function is called from gfc_sym_type(). */
1304 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1306 /* Array pointer types aren't actually pointers. */
1307 if (sym->attr.dimension)
1310 return build_pointer_type (type);
1313 /* Return the type for a symbol. Special handling is required for character
1314 types to get the correct level of indirection.
1315 For functions return the return type.
1316 For subroutines return void_type_node.
1317 Calling this multiple times for the same symbol should be avoided,
1318 especially for character and array types. */
1321 gfc_sym_type (gfc_symbol * sym)
1326 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1327 return void_type_node;
1329 /* In the case of a function the fake result variable may have a
1330 type different from the function type, so don't return early in
1332 if (sym->backend_decl && !sym->attr.function)
1333 return TREE_TYPE (sym->backend_decl);
1335 type = gfc_typenode_for_spec (&sym->ts);
1337 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1342 if (sym->attr.dimension)
1344 if (gfc_is_nodesc_array (sym))
1346 /* If this is a character argument of unknown length, just use the
1348 if (sym->ts.type != BT_CHARACTER
1349 || !(sym->attr.dummy || sym->attr.function)
1350 || sym->ts.cl->backend_decl)
1352 type = gfc_get_nodesc_array_type (type, sym->as,
1359 type = gfc_build_array_type (type, sym->as);
1363 if (sym->attr.allocatable || sym->attr.pointer)
1364 type = gfc_build_pointer_type (sym, type);
1367 /* We currently pass all parameters by reference.
1368 See f95_get_function_decl. For dummy function parameters return the
1372 /* We must use pointer types for potentially absent variables. The
1373 optimizers assume a reference type argument is never NULL. */
1374 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1375 type = build_pointer_type (type);
1377 type = build_reference_type (type);
1383 /* Layout and output debug info for a record type. */
1386 gfc_finish_type (tree type)
1390 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1391 TYPE_STUB_DECL (type) = decl;
1393 rest_of_type_compilation (type, 1);
1394 rest_of_decl_compilation (decl, 1, 0);
1397 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1398 or RECORD_TYPE pointed to by STYPE. The new field is chained
1399 to the fieldlist pointed to by FIELDLIST.
1401 Returns a pointer to the new field. */
1404 gfc_add_field_to_struct (tree *fieldlist, tree context,
1405 tree name, tree type)
1409 decl = build_decl (FIELD_DECL, name, type);
1411 DECL_CONTEXT (decl) = context;
1412 DECL_INITIAL (decl) = 0;
1413 DECL_ALIGN (decl) = 0;
1414 DECL_USER_ALIGN (decl) = 0;
1415 TREE_CHAIN (decl) = NULL_TREE;
1416 *fieldlist = chainon (*fieldlist, decl);
1422 /* Copy the backend_decl and component backend_decls if
1423 the two derived type symbols are "equal", as described
1424 in 4.4.2 and resolved by gfc_compare_derived_types. */
1427 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1429 gfc_component *to_cm;
1430 gfc_component *from_cm;
1432 if (from->backend_decl == NULL
1433 || !gfc_compare_derived_types (from, to))
1436 to->backend_decl = from->backend_decl;
1438 to_cm = to->components;
1439 from_cm = from->components;
1441 /* Copy the component declarations. If a component is itself
1442 a derived type, we need a copy of its component declarations.
1443 This is done by recursing into gfc_get_derived_type and
1444 ensures that the component's component declarations have
1445 been built. If it is a character, we need the character
1447 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1449 to_cm->backend_decl = from_cm->backend_decl;
1450 if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
1451 gfc_get_derived_type (to_cm->ts.derived);
1453 else if (from_cm->ts.type == BT_CHARACTER)
1454 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1461 /* Build a tree node for a derived type. If there are equal
1462 derived types, with different local names, these are built
1463 at the same time. If an equal derived type has been built
1464 in a parent namespace, this is used. */
1467 gfc_get_derived_type (gfc_symbol * derived)
1469 tree typenode, field, field_type, fieldlist;
1473 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1475 /* derived->backend_decl != 0 means we saw it before, but its
1476 components' backend_decl may have not been built. */
1477 if (derived->backend_decl)
1479 /* Its components' backend_decl have been built. */
1480 if (TYPE_FIELDS (derived->backend_decl))
1481 return derived->backend_decl;
1483 typenode = derived->backend_decl;
1488 /* We see this derived type first time, so build the type node. */
1489 typenode = make_node (RECORD_TYPE);
1490 TYPE_NAME (typenode) = get_identifier (derived->name);
1491 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1492 derived->backend_decl = typenode;
1495 /* Go through the derived type components, building them as
1496 necessary. The reason for doing this now is that it is
1497 possible to recurse back to this derived type through a
1498 pointer component (PR24092). If this happens, the fields
1499 will be built and so we can return the type. */
1500 for (c = derived->components; c; c = c->next)
1502 if (c->ts.type != BT_DERIVED)
1505 if (!c->pointer || c->ts.derived->backend_decl == NULL)
1506 c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
1509 if (TYPE_FIELDS (derived->backend_decl))
1510 return derived->backend_decl;
1512 /* Build the type member list. Install the newly created RECORD_TYPE
1513 node as DECL_CONTEXT of each FIELD_DECL. */
1514 fieldlist = NULL_TREE;
1515 for (c = derived->components; c; c = c->next)
1517 if (c->ts.type == BT_DERIVED)
1518 field_type = c->ts.derived->backend_decl;
1521 if (c->ts.type == BT_CHARACTER)
1523 /* Evaluate the string length. */
1524 gfc_conv_const_charlen (c->ts.cl);
1525 gcc_assert (c->ts.cl->backend_decl);
1528 field_type = gfc_typenode_for_spec (&c->ts);
1531 /* This returns an array descriptor type. Initialization may be
1535 if (c->pointer || c->allocatable)
1537 /* Pointers to arrays aren't actually pointer types. The
1538 descriptors are separate, but the data is common. */
1539 field_type = gfc_build_array_type (field_type, c->as);
1542 field_type = gfc_get_nodesc_array_type (field_type, c->as,
1545 else if (c->pointer)
1546 field_type = build_pointer_type (field_type);
1548 field = gfc_add_field_to_struct (&fieldlist, typenode,
1549 get_identifier (c->name),
1552 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1555 if (!c->backend_decl)
1556 c->backend_decl = field;
1559 /* Now we have the final fieldlist. Record it, then lay out the
1560 derived type, including the fields. */
1561 TYPE_FIELDS (typenode) = fieldlist;
1563 gfc_finish_type (typenode);
1565 derived->backend_decl = typenode;
1567 /* Add this backend_decl to all the other, equal derived types. */
1568 for (dt = gfc_derived_types; dt; dt = dt->next)
1569 copy_dt_decls_ifequal (derived, dt->derived);
1571 return derived->backend_decl;
1576 gfc_return_by_reference (gfc_symbol * sym)
1578 if (!sym->attr.function)
1581 if (sym->attr.dimension)
1584 if (sym->ts.type == BT_CHARACTER)
1587 /* Possibly return complex numbers by reference for g77 compatibility.
1588 We don't do this for calls to intrinsics (as the library uses the
1589 -fno-f2c calling convention), nor for calls to functions which always
1590 require an explicit interface, as no compatibility problems can
1592 if (gfc_option.flag_f2c
1593 && sym->ts.type == BT_COMPLEX
1594 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1601 gfc_get_mixed_entry_union (gfc_namespace *ns)
1606 char name[GFC_MAX_SYMBOL_LEN + 1];
1607 gfc_entry_list *el, *el2;
1609 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1610 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1612 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1614 /* Build the type node. */
1615 type = make_node (UNION_TYPE);
1617 TYPE_NAME (type) = get_identifier (name);
1620 for (el = ns->entries; el; el = el->next)
1622 /* Search for duplicates. */
1623 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1624 if (el2->sym->result == el->sym->result)
1629 decl = build_decl (FIELD_DECL,
1630 get_identifier (el->sym->result->name),
1631 gfc_sym_type (el->sym->result));
1632 DECL_CONTEXT (decl) = type;
1633 fieldlist = chainon (fieldlist, decl);
1637 /* Finish off the type. */
1638 TYPE_FIELDS (type) = fieldlist;
1640 gfc_finish_type (type);
1645 gfc_get_function_type (gfc_symbol * sym)
1649 gfc_formal_arglist *f;
1652 int alternate_return;
1654 /* Make sure this symbol is a function or a subroutine. */
1655 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1657 if (sym->backend_decl)
1658 return TREE_TYPE (sym->backend_decl);
1661 alternate_return = 0;
1662 typelist = NULL_TREE;
1664 if (sym->attr.entry_master)
1666 /* Additional parameter for selecting an entry point. */
1667 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1670 /* Some functions we use an extra parameter for the return value. */
1671 if (gfc_return_by_reference (sym))
1678 if (arg->ts.type == BT_CHARACTER)
1679 gfc_conv_const_charlen (arg->ts.cl);
1681 type = gfc_sym_type (arg);
1682 if (arg->ts.type == BT_COMPLEX
1683 || arg->attr.dimension
1684 || arg->ts.type == BT_CHARACTER)
1685 type = build_reference_type (type);
1687 typelist = gfc_chainon_list (typelist, type);
1688 if (arg->ts.type == BT_CHARACTER)
1689 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1692 /* Build the argument types for the function. */
1693 for (f = sym->formal; f; f = f->next)
1698 /* Evaluate constant character lengths here so that they can be
1699 included in the type. */
1700 if (arg->ts.type == BT_CHARACTER)
1701 gfc_conv_const_charlen (arg->ts.cl);
1703 if (arg->attr.flavor == FL_PROCEDURE)
1705 type = gfc_get_function_type (arg);
1706 type = build_pointer_type (type);
1709 type = gfc_sym_type (arg);
1711 /* Parameter Passing Convention
1713 We currently pass all parameters by reference.
1714 Parameters with INTENT(IN) could be passed by value.
1715 The problem arises if a function is called via an implicit
1716 prototype. In this situation the INTENT is not known.
1717 For this reason all parameters to global functions must be
1718 passed by reference. Passing by value would potentially
1719 generate bad code. Worse there would be no way of telling that
1720 this code was bad, except that it would give incorrect results.
1722 Contained procedures could pass by value as these are never
1723 used without an explicit interface, and cannot be passed as
1724 actual parameters for a dummy procedure. */
1725 if (arg->ts.type == BT_CHARACTER)
1727 typelist = gfc_chainon_list (typelist, type);
1731 if (sym->attr.subroutine)
1732 alternate_return = 1;
1736 /* Add hidden string length parameters. */
1738 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1741 typelist = gfc_chainon_list (typelist, void_type_node);
1743 if (alternate_return)
1744 type = integer_type_node;
1745 else if (!sym->attr.function || gfc_return_by_reference (sym))
1746 type = void_type_node;
1747 else if (sym->attr.mixed_entry_master)
1748 type = gfc_get_mixed_entry_union (sym->ns);
1749 else if (gfc_option.flag_f2c
1750 && sym->ts.type == BT_REAL
1751 && sym->ts.kind == gfc_default_real_kind
1752 && !sym->attr.always_explicit)
1754 /* Special case: f2c calling conventions require that (scalar)
1755 default REAL functions return the C type double instead. f2c
1756 compatibility is only an issue with functions that don't
1757 require an explicit interface, as only these could be
1758 implemented in Fortran 77. */
1759 sym->ts.kind = gfc_default_double_kind;
1760 type = gfc_typenode_for_spec (&sym->ts);
1761 sym->ts.kind = gfc_default_real_kind;
1764 type = gfc_sym_type (sym);
1766 type = build_function_type (type, typelist);
1771 /* Language hooks for middle-end access to type nodes. */
1773 /* Return an integer type with BITS bits of precision,
1774 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1777 gfc_type_for_size (unsigned bits, int unsignedp)
1782 for (i = 0; i <= MAX_INT_KINDS; ++i)
1784 tree type = gfc_integer_types[i];
1785 if (type && bits == TYPE_PRECISION (type))
1791 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1792 return unsigned_intQI_type_node;
1793 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1794 return unsigned_intHI_type_node;
1795 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1796 return unsigned_intSI_type_node;
1797 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1798 return unsigned_intDI_type_node;
1799 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1800 return unsigned_intTI_type_node;
1806 /* Return a data type that has machine mode MODE. If the mode is an
1807 integer, then UNSIGNEDP selects between signed and unsigned types. */
1810 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1815 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1816 base = gfc_real_types;
1817 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1818 base = gfc_complex_types;
1819 else if (SCALAR_INT_MODE_P (mode))
1820 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1821 else if (VECTOR_MODE_P (mode))
1823 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1824 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1825 if (inner_type != NULL_TREE)
1826 return build_vector_type_for_mode (inner_type, mode);
1832 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1834 tree type = base[i];
1835 if (type && mode == TYPE_MODE (type))
1842 /* Return a signed type the same as TYPE in other respects. */
1845 gfc_signed_type (tree type)
1847 return get_signed_or_unsigned_type (0, type);
1850 #include "gt-fortran-trans-types.h"