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 /* Query the target to determine which machine modes are available for
97 computation. Choose KIND numbers for them. */
100 gfc_init_kinds (void)
102 enum machine_mode mode;
103 int i_index, r_index;
104 bool saw_i4 = false, saw_i8 = false;
105 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
107 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
111 if (!targetm.scalar_mode_supported_p (mode))
114 /* The middle end doesn't support constants larger than 2*HWI.
115 Perhaps the target hook shouldn't have accepted these either,
116 but just to be safe... */
117 bitsize = GET_MODE_BITSIZE (mode);
118 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
121 gcc_assert (i_index != MAX_INT_KINDS);
123 /* Let the kind equal the bit size divided by 8. This insulates the
124 programmer from the underlying byte size. */
132 gfc_integer_kinds[i_index].kind = kind;
133 gfc_integer_kinds[i_index].radix = 2;
134 gfc_integer_kinds[i_index].digits = bitsize - 1;
135 gfc_integer_kinds[i_index].bit_size = bitsize;
137 gfc_logical_kinds[i_index].kind = kind;
138 gfc_logical_kinds[i_index].bit_size = bitsize;
143 /* Set the maximum integer kind. Used with at least BOZ constants. */
144 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
146 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
148 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
153 if (!targetm.scalar_mode_supported_p (mode))
156 /* Only let float/double/long double go through because the fortran
157 library assumes these are the only floating point types. */
159 if (mode != TYPE_MODE (float_type_node)
160 && (mode != TYPE_MODE (double_type_node))
161 && (mode != TYPE_MODE (long_double_type_node)))
164 /* Let the kind equal the precision divided by 8, rounding up. Again,
165 this insulates the programmer from the underlying byte size.
167 Also, it effectively deals with IEEE extended formats. There, the
168 total size of the type may equal 16, but it's got 6 bytes of padding
169 and the increased size can get in the way of a real IEEE quad format
170 which may also be supported by the target.
172 We round up so as to handle IA-64 __floatreg (RFmode), which is an
173 82 bit type. Not to be confused with __float80 (XFmode), which is
174 an 80 bit type also supported by IA-64. So XFmode should come out
175 to be kind=10, and RFmode should come out to be kind=11. Egads. */
177 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
186 /* Careful we don't stumble a wierd internal mode. */
187 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
188 /* Or have too many modes for the allocated space. */
189 gcc_assert (r_index != MAX_REAL_KINDS);
191 gfc_real_kinds[r_index].kind = kind;
192 gfc_real_kinds[r_index].radix = fmt->b;
193 gfc_real_kinds[r_index].digits = fmt->p;
194 gfc_real_kinds[r_index].min_exponent = fmt->emin;
195 gfc_real_kinds[r_index].max_exponent = fmt->emax;
196 if (fmt->pnan < fmt->p)
197 /* This is an IBM extended double format (or the MIPS variant)
198 made up of two IEEE doubles. The value of the long double is
199 the sum of the values of the two parts. The most significant
200 part is required to be the value of the long double rounded
201 to the nearest double. If we use emax of 1024 then we can't
202 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
203 rounding will make the most significant part overflow. */
204 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
205 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
209 /* Choose the default integer kind. We choose 4 unless the user
210 directs us otherwise. */
211 if (gfc_option.flag_default_integer)
214 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
215 gfc_default_integer_kind = 8;
218 gfc_default_integer_kind = 4;
220 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
222 /* Choose the default real kind. Again, we choose 4 when possible. */
223 if (gfc_option.flag_default_real)
226 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
227 gfc_default_real_kind = 8;
230 gfc_default_real_kind = 4;
232 gfc_default_real_kind = gfc_real_kinds[0].kind;
234 /* Choose the default double kind. If -fdefault-real and -fdefault-double
235 are specified, we use kind=8, if it's available. If -fdefault-real is
236 specified without -fdefault-double, we use kind=16, if it's available.
237 Otherwise we do not change anything. */
238 if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
239 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
241 if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
242 gfc_default_double_kind = 8;
243 else if (gfc_option.flag_default_real && saw_r16)
244 gfc_default_double_kind = 16;
245 else if (saw_r4 && saw_r8)
246 gfc_default_double_kind = 8;
249 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
250 real ... occupies two contiguous numeric storage units.
252 Therefore we must be supplied a kind twice as large as we chose
253 for single precision. There are loopholes, in that double
254 precision must *occupy* two storage units, though it doesn't have
255 to *use* two storage units. Which means that you can make this
256 kind artificially wide by padding it. But at present there are
257 no GCC targets for which a two-word type does not exist, so we
258 just let gfc_validate_kind abort and tell us if something breaks. */
260 gfc_default_double_kind
261 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
264 /* The default logical kind is constrained to be the same as the
265 default integer kind. Similarly with complex and real. */
266 gfc_default_logical_kind = gfc_default_integer_kind;
267 gfc_default_complex_kind = gfc_default_real_kind;
269 /* Choose the smallest integer kind for our default character. */
270 gfc_default_character_kind = gfc_integer_kinds[0].kind;
272 /* Choose the integer kind the same size as "void*" for our index kind. */
273 gfc_index_integer_kind = POINTER_SIZE / 8;
274 /* Pick a kind the same size as the C "int" type. */
275 gfc_c_int_kind = INT_TYPE_SIZE / 8;
278 /* Make sure that a valid kind is present. Returns an index into the
279 associated kinds array, -1 if the kind is not present. */
282 validate_integer (int kind)
286 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
287 if (gfc_integer_kinds[i].kind == kind)
294 validate_real (int kind)
298 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
299 if (gfc_real_kinds[i].kind == kind)
306 validate_logical (int kind)
310 for (i = 0; gfc_logical_kinds[i].kind; i++)
311 if (gfc_logical_kinds[i].kind == kind)
318 validate_character (int kind)
320 return kind == gfc_default_character_kind ? 0 : -1;
323 /* Validate a kind given a basic type. The return value is the same
324 for the child functions, with -1 indicating nonexistence of the
325 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
328 gfc_validate_kind (bt type, int kind, bool may_fail)
334 case BT_REAL: /* Fall through */
336 rc = validate_real (kind);
339 rc = validate_integer (kind);
342 rc = validate_logical (kind);
345 rc = validate_character (kind);
349 gfc_internal_error ("gfc_validate_kind(): Got bad type");
352 if (rc < 0 && !may_fail)
353 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
359 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
360 Reuse common type nodes where possible. Recognize if the kind matches up
361 with a C type. This will be used later in determining which routines may
362 be scarfed from libm. */
365 gfc_build_int_type (gfc_integer_info *info)
367 int mode_precision = info->bit_size;
369 if (mode_precision == CHAR_TYPE_SIZE)
371 if (mode_precision == SHORT_TYPE_SIZE)
373 if (mode_precision == INT_TYPE_SIZE)
375 if (mode_precision == LONG_TYPE_SIZE)
377 if (mode_precision == LONG_LONG_TYPE_SIZE)
378 info->c_long_long = 1;
380 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
381 return intQI_type_node;
382 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
383 return intHI_type_node;
384 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
385 return intSI_type_node;
386 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
387 return intDI_type_node;
388 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
389 return intTI_type_node;
391 return make_signed_type (mode_precision);
395 gfc_build_real_type (gfc_real_info *info)
397 int mode_precision = info->mode_precision;
400 if (mode_precision == FLOAT_TYPE_SIZE)
402 if (mode_precision == DOUBLE_TYPE_SIZE)
404 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
405 info->c_long_double = 1;
407 if (TYPE_PRECISION (float_type_node) == mode_precision)
408 return float_type_node;
409 if (TYPE_PRECISION (double_type_node) == mode_precision)
410 return double_type_node;
411 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
412 return long_double_type_node;
414 new_type = make_node (REAL_TYPE);
415 TYPE_PRECISION (new_type) = mode_precision;
416 layout_type (new_type);
421 gfc_build_complex_type (tree scalar_type)
425 if (scalar_type == NULL)
427 if (scalar_type == float_type_node)
428 return complex_float_type_node;
429 if (scalar_type == double_type_node)
430 return complex_double_type_node;
431 if (scalar_type == long_double_type_node)
432 return complex_long_double_type_node;
434 new_type = make_node (COMPLEX_TYPE);
435 TREE_TYPE (new_type) = scalar_type;
436 layout_type (new_type);
441 gfc_build_logical_type (gfc_logical_info *info)
443 int bit_size = info->bit_size;
446 if (bit_size == BOOL_TYPE_SIZE)
449 return boolean_type_node;
452 new_type = make_unsigned_type (bit_size);
453 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
454 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
455 TYPE_PRECISION (new_type) = 1;
461 /* Return the bit size of the C "size_t". */
467 if (strcmp (SIZE_TYPE, "unsigned int") == 0)
468 return INT_TYPE_SIZE;
469 if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
470 return LONG_TYPE_SIZE;
471 if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
472 return SHORT_TYPE_SIZE;
475 return LONG_TYPE_SIZE;
480 /* Create the backend type nodes. We map them to their
481 equivalent C type, at least for now. We also give
482 names to the types here, and we push them in the
483 global binding level context.*/
486 gfc_init_types (void)
492 unsigned HOST_WIDE_INT hi;
493 unsigned HOST_WIDE_INT lo;
495 /* Create and name the types. */
496 #define PUSH_TYPE(name, node) \
497 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
499 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
501 type = gfc_build_int_type (&gfc_integer_kinds[index]);
502 gfc_integer_types[index] = type;
503 snprintf (name_buf, sizeof(name_buf), "int%d",
504 gfc_integer_kinds[index].kind);
505 PUSH_TYPE (name_buf, type);
508 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
510 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
511 gfc_logical_types[index] = type;
512 snprintf (name_buf, sizeof(name_buf), "logical%d",
513 gfc_logical_kinds[index].kind);
514 PUSH_TYPE (name_buf, type);
517 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
519 type = gfc_build_real_type (&gfc_real_kinds[index]);
520 gfc_real_types[index] = type;
521 snprintf (name_buf, sizeof(name_buf), "real%d",
522 gfc_real_kinds[index].kind);
523 PUSH_TYPE (name_buf, type);
525 type = gfc_build_complex_type (type);
526 gfc_complex_types[index] = type;
527 snprintf (name_buf, sizeof(name_buf), "complex%d",
528 gfc_real_kinds[index].kind);
529 PUSH_TYPE (name_buf, type);
532 gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
534 PUSH_TYPE ("char", gfc_character1_type_node);
536 PUSH_TYPE ("byte", unsigned_char_type_node);
537 PUSH_TYPE ("void", void_type_node);
539 /* DBX debugging output gets upset if these aren't set. */
540 if (!TYPE_NAME (integer_type_node))
541 PUSH_TYPE ("c_integer", integer_type_node);
542 if (!TYPE_NAME (char_type_node))
543 PUSH_TYPE ("c_char", char_type_node);
547 pvoid_type_node = build_pointer_type (void_type_node);
548 ppvoid_type_node = build_pointer_type (pvoid_type_node);
549 pchar_type_node = build_pointer_type (gfc_character1_type_node);
551 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
552 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
553 since this function is called before gfc_init_constants. */
555 = build_range_type (gfc_array_index_type,
556 build_int_cst (gfc_array_index_type, 0),
559 /* The maximum array element size that can be handled is determined
560 by the number of bits available to store this field in the array
563 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
564 lo = ~ (unsigned HOST_WIDE_INT) 0;
565 if (n > HOST_BITS_PER_WIDE_INT)
566 hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
568 hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
569 gfc_max_array_element_size
570 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
572 size_type_node = gfc_array_index_type;
574 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
575 boolean_true_node = build_int_cst (boolean_type_node, 1);
576 boolean_false_node = build_int_cst (boolean_type_node, 0);
578 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
579 gfc_charlen_type_node = gfc_get_int_type (4);
582 /* Get the type node for the given type and kind. */
585 gfc_get_int_type (int kind)
587 int index = gfc_validate_kind (BT_INTEGER, kind, true);
588 return index < 0 ? 0 : gfc_integer_types[index];
592 gfc_get_real_type (int kind)
594 int index = gfc_validate_kind (BT_REAL, kind, true);
595 return index < 0 ? 0 : gfc_real_types[index];
599 gfc_get_complex_type (int kind)
601 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
602 return index < 0 ? 0 : gfc_complex_types[index];
606 gfc_get_logical_type (int kind)
608 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
609 return index < 0 ? 0 : gfc_logical_types[index];
612 /* Create a character type with the given kind and length. */
615 gfc_get_character_type_len (int kind, tree len)
619 gfc_validate_kind (BT_CHARACTER, kind, false);
621 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
622 type = build_array_type (gfc_character1_type_node, bounds);
623 TYPE_STRING_FLAG (type) = 1;
629 /* Get a type node for a character kind. */
632 gfc_get_character_type (int kind, gfc_charlen * cl)
636 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
638 return gfc_get_character_type_len (kind, len);
641 /* Covert a basic type. This will be an array for character types. */
644 gfc_typenode_for_spec (gfc_typespec * spec)
654 basetype = gfc_get_int_type (spec->kind);
658 basetype = gfc_get_real_type (spec->kind);
662 basetype = gfc_get_complex_type (spec->kind);
666 basetype = gfc_get_logical_type (spec->kind);
670 basetype = gfc_get_character_type (spec->kind, spec->cl);
674 basetype = gfc_get_derived_type (spec->derived);
683 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
686 gfc_conv_array_bound (gfc_expr * expr)
688 /* If expr is an integer constant, return that. */
689 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
690 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
692 /* Otherwise return NULL. */
697 gfc_get_element_type (tree type)
701 if (GFC_ARRAY_TYPE_P (type))
703 if (TREE_CODE (type) == POINTER_TYPE)
704 type = TREE_TYPE (type);
705 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
706 element = TREE_TYPE (type);
710 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
711 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
713 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
714 element = TREE_TYPE (element);
716 gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
717 element = TREE_TYPE (element);
723 /* Build an array. This function is called from gfc_sym_type().
724 Actually returns array descriptor type.
726 Format of array descriptors is as follows:
728 struct gfc_array_descriptor
733 struct descriptor_dimension dimension[N_DIM];
736 struct descriptor_dimension
743 Translation code should use gfc_conv_descriptor_* rather than accessing
744 the descriptor directly. Any changes to the array descriptor type will
745 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
747 This is represented internally as a RECORD_TYPE. The index nodes are
748 gfc_array_index_type and the data node is a pointer to the data. See below
749 for the handling of character types.
751 The dtype member is formatted as follows:
752 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
753 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
754 size = dtype >> GFC_DTYPE_SIZE_SHIFT
756 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
757 generated poor code for assumed/deferred size arrays. These require
758 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
759 grammar. Also, there is no way to explicitly set the array stride, so
760 all data must be packed(1). I've tried to mark all the functions which
761 would require modification with a GCC ARRAYS comment.
763 The data component points to the first element in the array.
764 The offset field is the position of the origin of the array
765 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
767 An element is accessed by
768 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
769 This gives good performance as the computation does not involve the
770 bounds of the array. For packed arrays, this is optimized further by
771 substituting the known strides.
773 This system has one problem: all array bounds must be withing 2^31 elements
774 of the origin (2^63 on 64-bit machines). For example
775 integer, dimension (80000:90000, 80000:90000, 2) :: array
776 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
777 the calculation for stride02 would overflow. This may still work, but
778 I haven't checked, and it relies on the overflow doing the right thing.
780 The way to fix this problem is to access elements as follows:
781 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
782 Obviously this is much slower. I will make this a compile time option,
783 something like -fsmall-array-offsets. Mixing code compiled with and without
784 this switch will work.
786 (1) This can be worked around by modifying the upper bound of the previous
787 dimension. This requires extra fields in the descriptor (both real_ubound
788 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
789 may allow us to do this. However I can't find mention of this anywhere
793 /* Returns true if the array sym does not require a descriptor. */
796 gfc_is_nodesc_array (gfc_symbol * sym)
798 gcc_assert (sym->attr.dimension);
800 /* We only want local arrays. */
801 if (sym->attr.pointer || sym->attr.allocatable)
806 if (sym->as->type != AS_ASSUMED_SHAPE)
812 if (sym->attr.result || sym->attr.function)
815 gcc_assert (sym->as->type == AS_EXPLICIT);
821 /* Create an array descriptor type. */
824 gfc_build_array_type (tree type, gfc_array_spec * as)
826 tree lbound[GFC_MAX_DIMENSIONS];
827 tree ubound[GFC_MAX_DIMENSIONS];
830 for (n = 0; n < as->rank; n++)
832 /* Create expressions for the known bounds of the array. */
833 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
834 lbound[n] = gfc_index_one_node;
836 lbound[n] = gfc_conv_array_bound (as->lower[n]);
837 ubound[n] = gfc_conv_array_bound (as->upper[n]);
840 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
843 /* Returns the struct descriptor_dimension type. */
846 gfc_get_desc_dim_type (void)
852 if (gfc_desc_dim_type)
853 return gfc_desc_dim_type;
855 /* Build the type node. */
856 type = make_node (RECORD_TYPE);
858 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
859 TYPE_PACKED (type) = 1;
861 /* Consists of the stride, lbound and ubound members. */
862 decl = build_decl (FIELD_DECL,
863 get_identifier ("stride"), gfc_array_index_type);
864 DECL_CONTEXT (decl) = type;
867 decl = build_decl (FIELD_DECL,
868 get_identifier ("lbound"), gfc_array_index_type);
869 DECL_CONTEXT (decl) = type;
870 fieldlist = chainon (fieldlist, decl);
872 decl = build_decl (FIELD_DECL,
873 get_identifier ("ubound"), gfc_array_index_type);
874 DECL_CONTEXT (decl) = type;
875 fieldlist = chainon (fieldlist, decl);
877 /* Finish off the type. */
878 TYPE_FIELDS (type) = fieldlist;
880 gfc_finish_type (type);
882 gfc_desc_dim_type = type;
887 /* Return the DTYPE for an array. This describes the type and type parameters
889 /* TODO: Only call this when the value is actually used, and make all the
890 unknown cases abort. */
893 gfc_get_dtype (tree type)
903 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
905 if (GFC_TYPE_ARRAY_DTYPE (type))
906 return GFC_TYPE_ARRAY_DTYPE (type);
908 rank = GFC_TYPE_ARRAY_RANK (type);
909 etype = gfc_get_element_type (type);
911 switch (TREE_CODE (etype))
914 n = GFC_DTYPE_INTEGER;
918 n = GFC_DTYPE_LOGICAL;
926 n = GFC_DTYPE_COMPLEX;
929 /* We will never have arrays of arrays. */
931 n = GFC_DTYPE_DERIVED;
935 n = GFC_DTYPE_CHARACTER;
939 /* TODO: Don't do dtype for temporary descriptorless arrays. */
940 /* We can strange array types for temporary arrays. */
941 return gfc_index_zero_node;
944 gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
945 size = TYPE_SIZE_UNIT (etype);
947 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
948 if (size && INTEGER_CST_P (size))
950 if (tree_int_cst_lt (gfc_max_array_element_size, size))
951 internal_error ("Array element size too big");
953 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
955 dtype = build_int_cst (gfc_array_index_type, i);
957 if (size && !INTEGER_CST_P (size))
959 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
960 tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
961 dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
963 /* If we don't know the size we leave it as zero. This should never happen
964 for anything that is actually used. */
965 /* TODO: Check this is actually true, particularly when repacking
966 assumed size parameters. */
968 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
973 /* Build an array type for use without a descriptor. Valid values of packed
974 are 0=no, 1=partial, 2=full, 3=static. */
977 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
990 mpz_init_set_ui (offset, 0);
991 mpz_init_set_ui (stride, 1);
994 /* We don't use build_array_type because this does not include include
995 lang-specific information (i.e. the bounds of the array) when checking
997 type = make_node (ARRAY_TYPE);
999 GFC_ARRAY_TYPE_P (type) = 1;
1000 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1001 ggc_alloc_cleared (sizeof (struct lang_type));
1003 known_stride = (packed != 0);
1005 for (n = 0; n < as->rank; n++)
1007 /* Fill in the stride and bound components of the type. */
1009 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1012 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1014 expr = as->lower[n];
1015 if (expr->expr_type == EXPR_CONSTANT)
1017 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1018 gfc_index_integer_kind);
1025 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1029 /* Calculate the offset. */
1030 mpz_mul (delta, stride, as->lower[n]->value.integer);
1031 mpz_sub (offset, offset, delta);
1036 expr = as->upper[n];
1037 if (expr && expr->expr_type == EXPR_CONSTANT)
1039 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1040 gfc_index_integer_kind);
1047 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1051 /* Calculate the stride. */
1052 mpz_sub (delta, as->upper[n]->value.integer,
1053 as->lower[n]->value.integer);
1054 mpz_add_ui (delta, delta, 1);
1055 mpz_mul (stride, stride, delta);
1058 /* Only the first stride is known for partial packed arrays. */
1065 GFC_TYPE_ARRAY_OFFSET (type) =
1066 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1069 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1073 GFC_TYPE_ARRAY_SIZE (type) =
1074 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1077 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1079 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1080 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1081 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1083 /* TODO: use main type if it is unbounded. */
1084 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1085 build_pointer_type (build_array_type (etype, range));
1089 mpz_sub_ui (stride, stride, 1);
1090 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1095 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1096 TYPE_DOMAIN (type) = range;
1098 build_pointer_type (etype);
1099 TREE_TYPE (type) = etype;
1107 if (packed < 3 || !known_stride)
1109 /* For dummy arrays and automatic (heap allocated) arrays we
1110 want a pointer to the array. */
1111 type = build_pointer_type (type);
1112 GFC_ARRAY_TYPE_P (type) = 1;
1113 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1118 /* Return or create the base type for an array descriptor. */
1121 gfc_get_array_descriptor_base (int dimen)
1123 tree fat_type, fieldlist, decl, arraytype;
1124 char name[16 + GFC_RANK_DIGITS + 1];
1126 gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1127 if (gfc_array_descriptor_base[dimen - 1])
1128 return gfc_array_descriptor_base[dimen - 1];
1130 /* Build the type node. */
1131 fat_type = make_node (RECORD_TYPE);
1133 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1134 TYPE_NAME (fat_type) = get_identifier (name);
1136 /* Add the data member as the first element of the descriptor. */
1137 decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
1139 DECL_CONTEXT (decl) = fat_type;
1142 /* Add the base component. */
1143 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1144 gfc_array_index_type);
1145 DECL_CONTEXT (decl) = fat_type;
1146 fieldlist = chainon (fieldlist, decl);
1148 /* Add the dtype component. */
1149 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1150 gfc_array_index_type);
1151 DECL_CONTEXT (decl) = fat_type;
1152 fieldlist = chainon (fieldlist, decl);
1154 /* Build the array type for the stride and bound components. */
1156 build_array_type (gfc_get_desc_dim_type (),
1157 build_range_type (gfc_array_index_type,
1158 gfc_index_zero_node,
1159 gfc_rank_cst[dimen - 1]));
1161 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1162 DECL_CONTEXT (decl) = fat_type;
1163 fieldlist = chainon (fieldlist, decl);
1165 /* Finish off the type. */
1166 TYPE_FIELDS (fat_type) = fieldlist;
1168 gfc_finish_type (fat_type);
1170 gfc_array_descriptor_base[dimen - 1] = fat_type;
1174 /* Build an array (descriptor) type with given bounds. */
1177 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1178 tree * ubound, int packed)
1180 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1181 tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
1182 const char *typename;
1185 base_type = gfc_get_array_descriptor_base (dimen);
1186 fat_type = build_variant_type_copy (base_type);
1188 tmp = TYPE_NAME (etype);
1189 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1190 tmp = DECL_NAME (tmp);
1192 typename = IDENTIFIER_POINTER (tmp);
1194 typename = "unknown";
1195 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1196 GFC_MAX_SYMBOL_LEN, typename);
1197 TYPE_NAME (fat_type) = get_identifier (name);
1199 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1200 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1201 ggc_alloc_cleared (sizeof (struct lang_type));
1203 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1204 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1206 /* Build an array descriptor record type. */
1208 stride = gfc_index_one_node;
1211 for (n = 0; n < dimen; n++)
1213 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1220 if (lower != NULL_TREE)
1222 if (INTEGER_CST_P (lower))
1223 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1229 if (upper != NULL_TREE)
1231 if (INTEGER_CST_P (upper))
1232 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1237 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1239 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1240 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1241 gfc_index_one_node);
1243 fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1244 /* Check the folding worked. */
1245 gcc_assert (INTEGER_CST_P (stride));
1250 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1252 /* TODO: known offsets for descriptors. */
1253 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1255 /* We define data as an unknown size array. Much better than doing
1256 pointer arithmetic. */
1258 build_array_type (etype, gfc_array_range_type);
1259 arraytype = build_pointer_type (arraytype);
1260 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1265 /* Build a pointer type. This function is called from gfc_sym_type(). */
1268 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1270 /* Array pointer types aren't actually pointers. */
1271 if (sym->attr.dimension)
1274 return build_pointer_type (type);
1277 /* Return the type for a symbol. Special handling is required for character
1278 types to get the correct level of indirection.
1279 For functions return the return type.
1280 For subroutines return void_type_node.
1281 Calling this multiple times for the same symbol should be avoided,
1282 especially for character and array types. */
1285 gfc_sym_type (gfc_symbol * sym)
1290 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1291 return void_type_node;
1293 if (sym->backend_decl)
1295 if (sym->attr.function)
1296 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
1298 return TREE_TYPE (sym->backend_decl);
1301 type = gfc_typenode_for_spec (&sym->ts);
1302 if (gfc_option.flag_f2c
1303 && sym->attr.function
1304 && sym->ts.type == BT_REAL
1305 && sym->ts.kind == gfc_default_real_kind
1306 && !sym->attr.always_explicit)
1308 /* Special case: f2c calling conventions require that (scalar)
1309 default REAL functions return the C type double instead. */
1310 sym->ts.kind = gfc_default_double_kind;
1311 type = gfc_typenode_for_spec (&sym->ts);
1312 sym->ts.kind = gfc_default_real_kind;
1315 if (sym->attr.dummy && !sym->attr.function)
1320 if (sym->attr.dimension)
1322 if (gfc_is_nodesc_array (sym))
1324 /* If this is a character argument of unknown length, just use the
1326 if (sym->ts.type != BT_CHARACTER
1327 || !(sym->attr.dummy || sym->attr.function)
1328 || sym->ts.cl->backend_decl)
1330 type = gfc_get_nodesc_array_type (type, sym->as,
1336 type = gfc_build_array_type (type, sym->as);
1340 if (sym->attr.allocatable || sym->attr.pointer)
1341 type = gfc_build_pointer_type (sym, type);
1344 /* We currently pass all parameters by reference.
1345 See f95_get_function_decl. For dummy function parameters return the
1349 /* We must use pointer types for potentially absent variables. The
1350 optimizers assume a reference type argument is never NULL. */
1351 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1352 type = build_pointer_type (type);
1354 type = build_reference_type (type);
1360 /* Layout and output debug info for a record type. */
1363 gfc_finish_type (tree type)
1367 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1368 TYPE_STUB_DECL (type) = decl;
1370 rest_of_type_compilation (type, 1);
1371 rest_of_decl_compilation (decl, 1, 0);
1374 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1375 or RECORD_TYPE pointed to by STYPE. The new field is chained
1376 to the fieldlist pointed to by FIELDLIST.
1378 Returns a pointer to the new field. */
1381 gfc_add_field_to_struct (tree *fieldlist, tree context,
1382 tree name, tree type)
1386 decl = build_decl (FIELD_DECL, name, type);
1388 DECL_CONTEXT (decl) = context;
1389 DECL_INITIAL (decl) = 0;
1390 DECL_ALIGN (decl) = 0;
1391 DECL_USER_ALIGN (decl) = 0;
1392 TREE_CHAIN (decl) = NULL_TREE;
1393 *fieldlist = chainon (*fieldlist, decl);
1399 /* Copy the backend_decl and component backend_decls if
1400 the two derived type symbols are "equal", as described
1401 in 4.4.2 and resolved by gfc_compare_derived_types. */
1404 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
1406 gfc_component *to_cm;
1407 gfc_component *from_cm;
1409 if (from->backend_decl == NULL
1410 || !gfc_compare_derived_types (from, to))
1413 to->backend_decl = from->backend_decl;
1415 to_cm = to->components;
1416 from_cm = from->components;
1418 /* Copy the component declarations. If a component is itself
1419 a derived type, we need a copy of its component declarations.
1420 This is done by recursing into gfc_get_derived_type and
1421 ensures that the component's component declarations have
1422 been built. If it is a character, we need the character
1424 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1426 to_cm->backend_decl = from_cm->backend_decl;
1427 if (from_cm->ts.type == BT_DERIVED)
1428 gfc_get_derived_type (to_cm->ts.derived);
1430 else if (from_cm->ts.type == BT_CHARACTER)
1431 to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
1438 /* Build a tree node for a derived type. If there are equal
1439 derived types, with different local names, these are built
1440 at the same time. If an equal derived type has been built
1441 in a parent namespace, this is used. */
1444 gfc_get_derived_type (gfc_symbol * derived)
1446 tree typenode, field, field_type, fieldlist;
1451 gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1453 /* derived->backend_decl != 0 means we saw it before, but its
1454 components' backend_decl may have not been built. */
1455 if (derived->backend_decl)
1457 /* Its components' backend_decl have been built. */
1458 if (TYPE_FIELDS (derived->backend_decl))
1459 return derived->backend_decl;
1461 typenode = derived->backend_decl;
1465 /* In a module, if an equal derived type is already available in the
1466 specification block, use its backend declaration and those of its
1467 components, rather than building anew so that potential dummy and
1468 actual arguments use the same TREE_TYPE. Non-module structures,
1469 need to be built, if found, because the order of visits to the
1470 namespaces is different. */
1472 for (ns = derived->ns->parent; ns; ns = ns->parent)
1474 for (dt = ns->derived_types; dt; dt = dt->next)
1476 if (derived->module == NULL
1477 && dt->derived->backend_decl == NULL
1478 && gfc_compare_derived_types (dt->derived, derived))
1479 gfc_get_derived_type (dt->derived);
1481 if (copy_dt_decls_ifequal (dt->derived, derived))
1484 if (derived->backend_decl)
1485 goto other_equal_dts;
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
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, 3);
1544 else if (c->pointer)
1545 field_type = build_pointer_type (field_type);
1547 field = gfc_add_field_to_struct (&fieldlist, typenode,
1548 get_identifier (c->name),
1551 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1554 if (!c->backend_decl)
1555 c->backend_decl = field;
1558 /* Now we have the final fieldlist. Record it, then lay out the
1559 derived type, including the fields. */
1560 TYPE_FIELDS (typenode) = fieldlist;
1562 gfc_finish_type (typenode);
1564 derived->backend_decl = typenode;
1567 /* Add this backend_decl to all the other, equal derived types and
1568 their components in this namespace. */
1569 for (dt = derived->ns->derived_types; dt; dt = dt->next)
1570 copy_dt_decls_ifequal (derived, dt->derived);
1572 return derived->backend_decl;
1577 gfc_return_by_reference (gfc_symbol * sym)
1579 if (!sym->attr.function)
1582 if (sym->attr.dimension)
1585 if (sym->ts.type == BT_CHARACTER)
1588 /* Possibly return complex numbers by reference for g77 compatibility.
1589 We don't do this for calls to intrinsics (as the library uses the
1590 -fno-f2c calling convention), nor for calls to functions which always
1591 require an explicit interface, as no compatibility problems can
1593 if (gfc_option.flag_f2c
1594 && sym->ts.type == BT_COMPLEX
1595 && !sym->attr.intrinsic && !sym->attr.always_explicit)
1602 gfc_get_mixed_entry_union (gfc_namespace *ns)
1607 char name[GFC_MAX_SYMBOL_LEN + 1];
1608 gfc_entry_list *el, *el2;
1610 gcc_assert (ns->proc_name->attr.mixed_entry_master);
1611 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
1613 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
1615 /* Build the type node. */
1616 type = make_node (UNION_TYPE);
1618 TYPE_NAME (type) = get_identifier (name);
1621 for (el = ns->entries; el; el = el->next)
1623 /* Search for duplicates. */
1624 for (el2 = ns->entries; el2 != el; el2 = el2->next)
1625 if (el2->sym->result == el->sym->result)
1630 decl = build_decl (FIELD_DECL,
1631 get_identifier (el->sym->result->name),
1632 gfc_sym_type (el->sym->result));
1633 DECL_CONTEXT (decl) = type;
1634 fieldlist = chainon (fieldlist, decl);
1638 /* Finish off the type. */
1639 TYPE_FIELDS (type) = fieldlist;
1641 gfc_finish_type (type);
1646 gfc_get_function_type (gfc_symbol * sym)
1650 gfc_formal_arglist *f;
1653 int alternate_return;
1655 /* Make sure this symbol is a function or a subroutine. */
1656 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1658 if (sym->backend_decl)
1659 return TREE_TYPE (sym->backend_decl);
1662 alternate_return = 0;
1663 typelist = NULL_TREE;
1665 if (sym->attr.entry_master)
1667 /* Additional parameter for selecting an entry point. */
1668 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1671 /* Some functions we use an extra parameter for the return value. */
1672 if (gfc_return_by_reference (sym))
1679 if (arg->ts.type == BT_CHARACTER)
1680 gfc_conv_const_charlen (arg->ts.cl);
1682 type = gfc_sym_type (arg);
1683 if (arg->ts.type == BT_COMPLEX
1684 || arg->attr.dimension
1685 || arg->ts.type == BT_CHARACTER)
1686 type = build_reference_type (type);
1688 typelist = gfc_chainon_list (typelist, type);
1689 if (arg->ts.type == BT_CHARACTER)
1690 typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
1693 /* Build the argument types for the function. */
1694 for (f = sym->formal; f; f = f->next)
1699 /* Evaluate constant character lengths here so that they can be
1700 included in the type. */
1701 if (arg->ts.type == BT_CHARACTER)
1702 gfc_conv_const_charlen (arg->ts.cl);
1704 if (arg->attr.flavor == FL_PROCEDURE)
1706 type = gfc_get_function_type (arg);
1707 type = build_pointer_type (type);
1710 type = gfc_sym_type (arg);
1712 /* Parameter Passing Convention
1714 We currently pass all parameters by reference.
1715 Parameters with INTENT(IN) could be passed by value.
1716 The problem arises if a function is called via an implicit
1717 prototype. In this situation the INTENT is not known.
1718 For this reason all parameters to global functions must be
1719 passed by reference. Passing by value would potentially
1720 generate bad code. Worse there would be no way of telling that
1721 this code was bad, except that it would give incorrect results.
1723 Contained procedures could pass by value as these are never
1724 used without an explicit interface, and connot be passed as
1725 actual parameters for a dummy procedure. */
1726 if (arg->ts.type == BT_CHARACTER)
1728 typelist = gfc_chainon_list (typelist, type);
1732 if (sym->attr.subroutine)
1733 alternate_return = 1;
1737 /* Add hidden string length parameters. */
1739 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);
1750 type = gfc_sym_type (sym);
1752 type = build_function_type (type, typelist);
1757 /* Language hooks for middle-end access to type nodes. */
1759 /* Return an integer type with BITS bits of precision,
1760 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1763 gfc_type_for_size (unsigned bits, int unsignedp)
1768 for (i = 0; i <= MAX_INT_KINDS; ++i)
1770 tree type = gfc_integer_types[i];
1771 if (type && bits == TYPE_PRECISION (type))
1777 if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
1778 return unsigned_intQI_type_node;
1779 if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
1780 return unsigned_intHI_type_node;
1781 if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
1782 return unsigned_intSI_type_node;
1783 if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
1784 return unsigned_intDI_type_node;
1785 if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
1786 return unsigned_intTI_type_node;
1792 /* Return a data type that has machine mode MODE. If the mode is an
1793 integer, then UNSIGNEDP selects between signed and unsigned types. */
1796 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1801 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
1802 base = gfc_real_types;
1803 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
1804 base = gfc_complex_types;
1805 else if (SCALAR_INT_MODE_P (mode))
1806 return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
1807 else if (VECTOR_MODE_P (mode))
1809 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1810 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1811 if (inner_type != NULL_TREE)
1812 return build_vector_type_for_mode (inner_type, mode);
1818 for (i = 0; i <= MAX_REAL_KINDS; ++i)
1820 tree type = base[i];
1821 if (type && mode == TYPE_MODE (type))
1828 /* Return a type the same as TYPE except unsigned or
1829 signed according to UNSIGNEDP. */
1832 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1834 if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
1837 return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
1840 /* Return an unsigned type the same as TYPE in other respects. */
1843 gfc_unsigned_type (tree type)
1845 return gfc_signed_or_unsigned_type (1, type);
1848 /* Return a signed type the same as TYPE in other respects. */
1851 gfc_signed_type (tree type)
1853 return gfc_signed_or_unsigned_type (0, type);
1856 #include "gt-fortran-trans-types.h"