1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-types.c -- gfortran backend types */
27 #include "coretypes.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
40 #if (GFC_MAX_DIMENSIONS < 10)
41 #define GFC_RANK_DIGITS 1
42 #define GFC_RANK_PRINTF_FORMAT "%01d"
43 #elif (GFC_MAX_DIMENSIONS < 100)
44 #define GFC_RANK_DIGITS 2
45 #define GFC_RANK_PRINTF_FORMAT "%02d"
47 #error If you really need >99 dimensions, continue the sequence above...
50 static tree
gfc_get_derived_type (gfc_symbol
* derived
);
52 tree gfc_array_index_type
;
53 tree gfc_array_range_type
;
54 tree gfc_character1_type_node
;
56 tree ppvoid_type_node
;
59 tree gfc_charlen_type_node
;
61 static GTY(()) tree gfc_desc_dim_type
;
62 static GTY(()) tree gfc_max_array_element_size
;
63 static GTY(()) tree gfc_array_descriptor_base
[GFC_MAX_DIMENSIONS
];
65 /* Arrays for all integral and real kinds. We'll fill this in at runtime
66 after the target has a chance to process command-line options. */
68 #define MAX_INT_KINDS 5
69 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
70 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
71 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
72 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
74 #define MAX_REAL_KINDS 5
75 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
76 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
77 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
79 /* The integer kind to use for array indices. This will be set to the
80 proper value based on target information from the backend. */
82 int gfc_index_integer_kind
;
84 /* The default kinds of the various types. */
86 int gfc_default_integer_kind
;
87 int gfc_max_integer_kind
;
88 int gfc_default_real_kind
;
89 int gfc_default_double_kind
;
90 int gfc_default_character_kind
;
91 int gfc_default_logical_kind
;
92 int gfc_default_complex_kind
;
95 /* Query the target to determine which machine modes are available for
96 computation. Choose KIND numbers for them. */
101 enum machine_mode mode
;
102 int i_index
, r_index
;
103 bool saw_i4
= false, saw_i8
= false;
104 bool saw_r4
= false, saw_r8
= false, saw_r16
= false;
106 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
110 if (!targetm
.scalar_mode_supported_p (mode
))
113 /* The middle end doesn't support constants larger than 2*HWI.
114 Perhaps the target hook shouldn't have accepted these either,
115 but just to be safe... */
116 bitsize
= GET_MODE_BITSIZE (mode
);
117 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
120 gcc_assert (i_index
!= MAX_INT_KINDS
);
122 /* Let the kind equal the bit size divided by 8. This insulates the
123 programmer from the underlying byte size. */
131 gfc_integer_kinds
[i_index
].kind
= kind
;
132 gfc_integer_kinds
[i_index
].radix
= 2;
133 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
134 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
136 gfc_logical_kinds
[i_index
].kind
= kind
;
137 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
142 /* Set the maximum integer kind. Used with at least BOZ constants. */
143 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
145 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
147 const struct real_format
*fmt
= REAL_MODE_FORMAT (mode
);
152 if (!targetm
.scalar_mode_supported_p (mode
))
155 /* Only let float/double/long double go through because the fortran
156 library assumes these are the only floating point types. */
158 if (mode
!= TYPE_MODE (float_type_node
)
159 && (mode
!= TYPE_MODE (double_type_node
))
160 && (mode
!= TYPE_MODE (long_double_type_node
)))
163 /* Let the kind equal the precision divided by 8, rounding up. Again,
164 this insulates the programmer from the underlying byte size.
166 Also, it effectively deals with IEEE extended formats. There, the
167 total size of the type may equal 16, but it's got 6 bytes of padding
168 and the increased size can get in the way of a real IEEE quad format
169 which may also be supported by the target.
171 We round up so as to handle IA-64 __floatreg (RFmode), which is an
172 82 bit type. Not to be confused with __float80 (XFmode), which is
173 an 80 bit type also supported by IA-64. So XFmode should come out
174 to be kind=10, and RFmode should come out to be kind=11. Egads. */
176 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
185 /* Careful we don't stumble a wierd internal mode. */
186 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
187 /* Or have too many modes for the allocated space. */
188 gcc_assert (r_index
!= MAX_REAL_KINDS
);
190 gfc_real_kinds
[r_index
].kind
= kind
;
191 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
192 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
193 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
194 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
195 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
199 /* Choose the default integer kind. We choose 4 unless the user
200 directs us otherwise. */
201 if (gfc_option
.flag_default_integer
)
204 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
205 gfc_default_integer_kind
= 8;
208 gfc_default_integer_kind
= 4;
210 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
212 /* Choose the default real kind. Again, we choose 4 when possible. */
213 if (gfc_option
.flag_default_real
)
216 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
217 gfc_default_real_kind
= 8;
220 gfc_default_real_kind
= 4;
222 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
224 /* Choose the default double kind. If -fdefault-real and -fdefault-double
225 are specified, we use kind=8, if it's available. If -fdefault-real is
226 specified without -fdefault-double, we use kind=16, if it's available.
227 Otherwise we do not change anything. */
228 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
229 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
231 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
232 gfc_default_double_kind
= 8;
233 else if (gfc_option
.flag_default_real
&& saw_r16
)
234 gfc_default_double_kind
= 16;
235 else if (saw_r4
&& saw_r8
)
236 gfc_default_double_kind
= 8;
239 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
240 real ... occupies two contiguous numeric storage units.
242 Therefore we must be supplied a kind twice as large as we chose
243 for single precision. There are loopholes, in that double
244 precision must *occupy* two storage units, though it doesn't have
245 to *use* two storage units. Which means that you can make this
246 kind artificially wide by padding it. But at present there are
247 no GCC targets for which a two-word type does not exist, so we
248 just let gfc_validate_kind abort and tell us if something breaks. */
250 gfc_default_double_kind
251 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
254 /* The default logical kind is constrained to be the same as the
255 default integer kind. Similarly with complex and real. */
256 gfc_default_logical_kind
= gfc_default_integer_kind
;
257 gfc_default_complex_kind
= gfc_default_real_kind
;
259 /* Choose the smallest integer kind for our default character. */
260 gfc_default_character_kind
= gfc_integer_kinds
[0].kind
;
262 /* Choose the integer kind the same size as "void*" for our index kind. */
263 gfc_index_integer_kind
= POINTER_SIZE
/ 8;
264 /* Pick a kind the same size as the C "int" type. */
265 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
268 /* Make sure that a valid kind is present. Returns an index into the
269 associated kinds array, -1 if the kind is not present. */
272 validate_integer (int kind
)
276 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
277 if (gfc_integer_kinds
[i
].kind
== kind
)
284 validate_real (int kind
)
288 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
289 if (gfc_real_kinds
[i
].kind
== kind
)
296 validate_logical (int kind
)
300 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
301 if (gfc_logical_kinds
[i
].kind
== kind
)
308 validate_character (int kind
)
310 return kind
== gfc_default_character_kind
? 0 : -1;
313 /* Validate a kind given a basic type. The return value is the same
314 for the child functions, with -1 indicating nonexistence of the
315 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
318 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
324 case BT_REAL
: /* Fall through */
326 rc
= validate_real (kind
);
329 rc
= validate_integer (kind
);
332 rc
= validate_logical (kind
);
335 rc
= validate_character (kind
);
339 gfc_internal_error ("gfc_validate_kind(): Got bad type");
342 if (rc
< 0 && !may_fail
)
343 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
349 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
350 Reuse common type nodes where possible. Recognize if the kind matches up
351 with a C type. This will be used later in determining which routines may
352 be scarfed from libm. */
355 gfc_build_int_type (gfc_integer_info
*info
)
357 int mode_precision
= info
->bit_size
;
359 if (mode_precision
== CHAR_TYPE_SIZE
)
361 if (mode_precision
== SHORT_TYPE_SIZE
)
363 if (mode_precision
== INT_TYPE_SIZE
)
365 if (mode_precision
== LONG_TYPE_SIZE
)
367 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
368 info
->c_long_long
= 1;
370 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
371 return intQI_type_node
;
372 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
373 return intHI_type_node
;
374 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
375 return intSI_type_node
;
376 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
377 return intDI_type_node
;
378 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
379 return intTI_type_node
;
381 return make_signed_type (mode_precision
);
385 gfc_build_real_type (gfc_real_info
*info
)
387 int mode_precision
= info
->mode_precision
;
390 if (mode_precision
== FLOAT_TYPE_SIZE
)
392 if (mode_precision
== DOUBLE_TYPE_SIZE
)
394 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
395 info
->c_long_double
= 1;
397 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
398 return float_type_node
;
399 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
400 return double_type_node
;
401 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
402 return long_double_type_node
;
404 new_type
= make_node (REAL_TYPE
);
405 TYPE_PRECISION (new_type
) = mode_precision
;
406 layout_type (new_type
);
411 gfc_build_complex_type (tree scalar_type
)
415 if (scalar_type
== NULL
)
417 if (scalar_type
== float_type_node
)
418 return complex_float_type_node
;
419 if (scalar_type
== double_type_node
)
420 return complex_double_type_node
;
421 if (scalar_type
== long_double_type_node
)
422 return complex_long_double_type_node
;
424 new_type
= make_node (COMPLEX_TYPE
);
425 TREE_TYPE (new_type
) = scalar_type
;
426 layout_type (new_type
);
431 gfc_build_logical_type (gfc_logical_info
*info
)
433 int bit_size
= info
->bit_size
;
436 if (bit_size
== BOOL_TYPE_SIZE
)
439 return boolean_type_node
;
442 new_type
= make_unsigned_type (bit_size
);
443 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
444 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
445 TYPE_PRECISION (new_type
) = 1;
451 /* Return the bit size of the C "size_t". */
457 if (strcmp (SIZE_TYPE
, "unsigned int") == 0)
458 return INT_TYPE_SIZE
;
459 if (strcmp (SIZE_TYPE
, "long unsigned int") == 0)
460 return LONG_TYPE_SIZE
;
461 if (strcmp (SIZE_TYPE
, "short unsigned int") == 0)
462 return SHORT_TYPE_SIZE
;
465 return LONG_TYPE_SIZE
;
470 /* Create the backend type nodes. We map them to their
471 equivalent C type, at least for now. We also give
472 names to the types here, and we push them in the
473 global binding level context.*/
476 gfc_init_types (void)
482 unsigned HOST_WIDE_INT hi
;
483 unsigned HOST_WIDE_INT lo
;
485 /* Create and name the types. */
486 #define PUSH_TYPE(name, node) \
487 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
489 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
491 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
492 gfc_integer_types
[index
] = type
;
493 snprintf (name_buf
, sizeof(name_buf
), "int%d",
494 gfc_integer_kinds
[index
].kind
);
495 PUSH_TYPE (name_buf
, type
);
498 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
500 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
501 gfc_logical_types
[index
] = type
;
502 snprintf (name_buf
, sizeof(name_buf
), "logical%d",
503 gfc_logical_kinds
[index
].kind
);
504 PUSH_TYPE (name_buf
, type
);
507 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
509 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
510 gfc_real_types
[index
] = type
;
511 snprintf (name_buf
, sizeof(name_buf
), "real%d",
512 gfc_real_kinds
[index
].kind
);
513 PUSH_TYPE (name_buf
, type
);
515 type
= gfc_build_complex_type (type
);
516 gfc_complex_types
[index
] = type
;
517 snprintf (name_buf
, sizeof(name_buf
), "complex%d",
518 gfc_real_kinds
[index
].kind
);
519 PUSH_TYPE (name_buf
, type
);
522 gfc_character1_type_node
= build_type_variant (unsigned_char_type_node
,
524 PUSH_TYPE ("char", gfc_character1_type_node
);
526 PUSH_TYPE ("byte", unsigned_char_type_node
);
527 PUSH_TYPE ("void", void_type_node
);
529 /* DBX debugging output gets upset if these aren't set. */
530 if (!TYPE_NAME (integer_type_node
))
531 PUSH_TYPE ("c_integer", integer_type_node
);
532 if (!TYPE_NAME (char_type_node
))
533 PUSH_TYPE ("c_char", char_type_node
);
537 pvoid_type_node
= build_pointer_type (void_type_node
);
538 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
539 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
541 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
542 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
543 since this function is called before gfc_init_constants. */
545 = build_range_type (gfc_array_index_type
,
546 build_int_cst (gfc_array_index_type
, 0),
549 /* The maximum array element size that can be handled is determined
550 by the number of bits available to store this field in the array
553 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
554 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
555 if (n
> HOST_BITS_PER_WIDE_INT
)
556 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
558 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
559 gfc_max_array_element_size
560 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
562 size_type_node
= gfc_array_index_type
;
564 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
565 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
566 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
568 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
569 gfc_charlen_type_node
= gfc_get_int_type (4);
572 /* Get the type node for the given type and kind. */
575 gfc_get_int_type (int kind
)
577 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
578 return index
< 0 ? 0 : gfc_integer_types
[index
];
582 gfc_get_real_type (int kind
)
584 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
585 return index
< 0 ? 0 : gfc_real_types
[index
];
589 gfc_get_complex_type (int kind
)
591 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
592 return index
< 0 ? 0 : gfc_complex_types
[index
];
596 gfc_get_logical_type (int kind
)
598 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
599 return index
< 0 ? 0 : gfc_logical_types
[index
];
602 /* Create a character type with the given kind and length. */
605 gfc_get_character_type_len (int kind
, tree len
)
609 gfc_validate_kind (BT_CHARACTER
, kind
, false);
611 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
612 type
= build_array_type (gfc_character1_type_node
, bounds
);
613 TYPE_STRING_FLAG (type
) = 1;
619 /* Get a type node for a character kind. */
622 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
626 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
628 return gfc_get_character_type_len (kind
, len
);
631 /* Covert a basic type. This will be an array for character types. */
634 gfc_typenode_for_spec (gfc_typespec
* spec
)
644 basetype
= gfc_get_int_type (spec
->kind
);
648 basetype
= gfc_get_real_type (spec
->kind
);
652 basetype
= gfc_get_complex_type (spec
->kind
);
656 basetype
= gfc_get_logical_type (spec
->kind
);
660 basetype
= gfc_get_character_type (spec
->kind
, spec
->cl
);
664 basetype
= gfc_get_derived_type (spec
->derived
);
673 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
676 gfc_conv_array_bound (gfc_expr
* expr
)
678 /* If expr is an integer constant, return that. */
679 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
680 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
682 /* Otherwise return NULL. */
687 gfc_get_element_type (tree type
)
691 if (GFC_ARRAY_TYPE_P (type
))
693 if (TREE_CODE (type
) == POINTER_TYPE
)
694 type
= TREE_TYPE (type
);
695 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
696 element
= TREE_TYPE (type
);
700 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
701 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
703 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
704 element
= TREE_TYPE (element
);
706 gcc_assert (TREE_CODE (element
) == ARRAY_TYPE
);
707 element
= TREE_TYPE (element
);
713 /* Build an array. This function is called from gfc_sym_type().
714 Actually returns array descriptor type.
716 Format of array descriptors is as follows:
718 struct gfc_array_descriptor
723 struct descriptor_dimension dimension[N_DIM];
726 struct descriptor_dimension
733 Translation code should use gfc_conv_descriptor_* rather than accessing
734 the descriptor directly. Any changes to the array descriptor type will
735 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
737 This is represented internally as a RECORD_TYPE. The index nodes are
738 gfc_array_index_type and the data node is a pointer to the data. See below
739 for the handling of character types.
741 The dtype member is formatted as follows:
742 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
743 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
744 size = dtype >> GFC_DTYPE_SIZE_SHIFT
746 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
747 generated poor code for assumed/deferred size arrays. These require
748 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
749 grammar. Also, there is no way to explicitly set the array stride, so
750 all data must be packed(1). I've tried to mark all the functions which
751 would require modification with a GCC ARRAYS comment.
753 The data component points to the first element in the array.
754 The offset field is the position of the origin of the array
755 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
757 An element is accessed by
758 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
759 This gives good performance as the computation does not involve the
760 bounds of the array. For packed arrays, this is optimized further by
761 substituting the known strides.
763 This system has one problem: all array bounds must be withing 2^31 elements
764 of the origin (2^63 on 64-bit machines). For example
765 integer, dimension (80000:90000, 80000:90000, 2) :: array
766 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
767 the calculation for stride02 would overflow. This may still work, but
768 I haven't checked, and it relies on the overflow doing the right thing.
770 The way to fix this problem is to access elements as follows:
771 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
772 Obviously this is much slower. I will make this a compile time option,
773 something like -fsmall-array-offsets. Mixing code compiled with and without
774 this switch will work.
776 (1) This can be worked around by modifying the upper bound of the previous
777 dimension. This requires extra fields in the descriptor (both real_ubound
778 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
779 may allow us to do this. However I can't find mention of this anywhere
783 /* Returns true if the array sym does not require a descriptor. */
786 gfc_is_nodesc_array (gfc_symbol
* sym
)
788 gcc_assert (sym
->attr
.dimension
);
790 /* We only want local arrays. */
791 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
796 if (sym
->as
->type
!= AS_ASSUMED_SHAPE
)
802 if (sym
->attr
.result
|| sym
->attr
.function
)
805 gcc_assert (sym
->as
->type
== AS_EXPLICIT
);
811 /* Create an array descriptor type. */
814 gfc_build_array_type (tree type
, gfc_array_spec
* as
)
816 tree lbound
[GFC_MAX_DIMENSIONS
];
817 tree ubound
[GFC_MAX_DIMENSIONS
];
820 for (n
= 0; n
< as
->rank
; n
++)
822 /* Create expressions for the known bounds of the array. */
823 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
824 lbound
[n
] = gfc_index_one_node
;
826 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
827 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
830 return gfc_get_array_type_bounds (type
, as
->rank
, lbound
, ubound
, 0);
833 /* Returns the struct descriptor_dimension type. */
836 gfc_get_desc_dim_type (void)
842 if (gfc_desc_dim_type
)
843 return gfc_desc_dim_type
;
845 /* Build the type node. */
846 type
= make_node (RECORD_TYPE
);
848 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
849 TYPE_PACKED (type
) = 1;
851 /* Consists of the stride, lbound and ubound members. */
852 decl
= build_decl (FIELD_DECL
,
853 get_identifier ("stride"), gfc_array_index_type
);
854 DECL_CONTEXT (decl
) = type
;
857 decl
= build_decl (FIELD_DECL
,
858 get_identifier ("lbound"), gfc_array_index_type
);
859 DECL_CONTEXT (decl
) = type
;
860 fieldlist
= chainon (fieldlist
, decl
);
862 decl
= build_decl (FIELD_DECL
,
863 get_identifier ("ubound"), gfc_array_index_type
);
864 DECL_CONTEXT (decl
) = type
;
865 fieldlist
= chainon (fieldlist
, decl
);
867 /* Finish off the type. */
868 TYPE_FIELDS (type
) = fieldlist
;
870 gfc_finish_type (type
);
872 gfc_desc_dim_type
= type
;
877 /* Return the DTYPE for an array. This describes the type and type parameters
879 /* TODO: Only call this when the value is actually used, and make all the
880 unknown cases abort. */
883 gfc_get_dtype (tree type
)
893 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
895 if (GFC_TYPE_ARRAY_DTYPE (type
))
896 return GFC_TYPE_ARRAY_DTYPE (type
);
898 rank
= GFC_TYPE_ARRAY_RANK (type
);
899 etype
= gfc_get_element_type (type
);
901 switch (TREE_CODE (etype
))
904 n
= GFC_DTYPE_INTEGER
;
908 n
= GFC_DTYPE_LOGICAL
;
916 n
= GFC_DTYPE_COMPLEX
;
919 /* We will never have arrays of arrays. */
921 n
= GFC_DTYPE_DERIVED
;
925 n
= GFC_DTYPE_CHARACTER
;
929 /* TODO: Don't do dtype for temporary descriptorless arrays. */
930 /* We can strange array types for temporary arrays. */
931 return gfc_index_zero_node
;
934 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
935 size
= TYPE_SIZE_UNIT (etype
);
937 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
938 if (size
&& INTEGER_CST_P (size
))
940 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
941 internal_error ("Array element size too big");
943 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
945 dtype
= build_int_cst (gfc_array_index_type
, i
);
947 if (size
&& !INTEGER_CST_P (size
))
949 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
950 tmp
= fold_build2 (LSHIFT_EXPR
, gfc_array_index_type
, size
, tmp
);
951 dtype
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, dtype
);
953 /* If we don't know the size we leave it as zero. This should never happen
954 for anything that is actually used. */
955 /* TODO: Check this is actually true, particularly when repacking
956 assumed size parameters. */
958 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
963 /* Build an array type for use without a descriptor. Valid values of packed
964 are 0=no, 1=partial, 2=full, 3=static. */
967 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, int packed
)
980 mpz_init_set_ui (offset
, 0);
981 mpz_init_set_ui (stride
, 1);
984 /* We don't use build_array_type because this does not include include
985 lang-specific information (i.e. the bounds of the array) when checking
987 type
= make_node (ARRAY_TYPE
);
989 GFC_ARRAY_TYPE_P (type
) = 1;
990 TYPE_LANG_SPECIFIC (type
) = (struct lang_type
*)
991 ggc_alloc_cleared (sizeof (struct lang_type
));
993 known_stride
= (packed
!= 0);
995 for (n
= 0; n
< as
->rank
; n
++)
997 /* Fill in the stride and bound components of the type. */
999 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1002 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1004 expr
= as
->lower
[n
];
1005 if (expr
->expr_type
== EXPR_CONSTANT
)
1007 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1008 gfc_index_integer_kind
);
1015 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1019 /* Calculate the offset. */
1020 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1021 mpz_sub (offset
, offset
, delta
);
1026 expr
= as
->upper
[n
];
1027 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1029 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1030 gfc_index_integer_kind
);
1037 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1041 /* Calculate the stride. */
1042 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1043 as
->lower
[n
]->value
.integer
);
1044 mpz_add_ui (delta
, delta
, 1);
1045 mpz_mul (stride
, stride
, delta
);
1048 /* Only the first stride is known for partial packed arrays. */
1055 GFC_TYPE_ARRAY_OFFSET (type
) =
1056 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1059 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1063 GFC_TYPE_ARRAY_SIZE (type
) =
1064 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1067 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1069 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1070 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1071 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1073 /* TODO: use main type if it is unbounded. */
1074 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1075 build_pointer_type (build_array_type (etype
, range
));
1079 mpz_sub_ui (stride
, stride
, 1);
1080 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1085 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1086 TYPE_DOMAIN (type
) = range
;
1088 build_pointer_type (etype
);
1089 TREE_TYPE (type
) = etype
;
1097 if (packed
< 3 || !known_stride
)
1099 /* For dummy arrays and automatic (heap allocated) arrays we
1100 want a pointer to the array. */
1101 type
= build_pointer_type (type
);
1102 GFC_ARRAY_TYPE_P (type
) = 1;
1103 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1108 /* Return or create the base type for an array descriptor. */
1111 gfc_get_array_descriptor_base (int dimen
)
1113 tree fat_type
, fieldlist
, decl
, arraytype
;
1114 char name
[16 + GFC_RANK_DIGITS
+ 1];
1116 gcc_assert (dimen
>= 1 && dimen
<= GFC_MAX_DIMENSIONS
);
1117 if (gfc_array_descriptor_base
[dimen
- 1])
1118 return gfc_array_descriptor_base
[dimen
- 1];
1120 /* Build the type node. */
1121 fat_type
= make_node (RECORD_TYPE
);
1123 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
);
1124 TYPE_NAME (fat_type
) = get_identifier (name
);
1126 /* Add the data member as the first element of the descriptor. */
1127 decl
= build_decl (FIELD_DECL
, get_identifier ("data"), ptr_type_node
);
1129 DECL_CONTEXT (decl
) = fat_type
;
1132 /* Add the base component. */
1133 decl
= build_decl (FIELD_DECL
, get_identifier ("offset"),
1134 gfc_array_index_type
);
1135 DECL_CONTEXT (decl
) = fat_type
;
1136 fieldlist
= chainon (fieldlist
, decl
);
1138 /* Add the dtype component. */
1139 decl
= build_decl (FIELD_DECL
, get_identifier ("dtype"),
1140 gfc_array_index_type
);
1141 DECL_CONTEXT (decl
) = fat_type
;
1142 fieldlist
= chainon (fieldlist
, decl
);
1144 /* Build the array type for the stride and bound components. */
1146 build_array_type (gfc_get_desc_dim_type (),
1147 build_range_type (gfc_array_index_type
,
1148 gfc_index_zero_node
,
1149 gfc_rank_cst
[dimen
- 1]));
1151 decl
= build_decl (FIELD_DECL
, get_identifier ("dim"), arraytype
);
1152 DECL_CONTEXT (decl
) = fat_type
;
1153 fieldlist
= chainon (fieldlist
, decl
);
1155 /* Finish off the type. */
1156 TYPE_FIELDS (fat_type
) = fieldlist
;
1158 gfc_finish_type (fat_type
);
1160 gfc_array_descriptor_base
[dimen
- 1] = fat_type
;
1164 /* Build an array (descriptor) type with given bounds. */
1167 gfc_get_array_type_bounds (tree etype
, int dimen
, tree
* lbound
,
1168 tree
* ubound
, int packed
)
1170 char name
[8 + GFC_RANK_DIGITS
+ GFC_MAX_SYMBOL_LEN
];
1171 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
;
1172 const char *typename
;
1175 base_type
= gfc_get_array_descriptor_base (dimen
);
1176 fat_type
= build_variant_type_copy (base_type
);
1178 tmp
= TYPE_NAME (etype
);
1179 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1180 tmp
= DECL_NAME (tmp
);
1182 typename
= IDENTIFIER_POINTER (tmp
);
1184 typename
= "unknown";
1185 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
,
1186 GFC_MAX_SYMBOL_LEN
, typename
);
1187 TYPE_NAME (fat_type
) = get_identifier (name
);
1189 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1190 TYPE_LANG_SPECIFIC (fat_type
) = (struct lang_type
*)
1191 ggc_alloc_cleared (sizeof (struct lang_type
));
1193 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1194 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1196 /* Build an array descriptor record type. */
1198 stride
= gfc_index_one_node
;
1201 for (n
= 0; n
< dimen
; n
++)
1203 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1210 if (lower
!= NULL_TREE
)
1212 if (INTEGER_CST_P (lower
))
1213 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1219 if (upper
!= NULL_TREE
)
1221 if (INTEGER_CST_P (upper
))
1222 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1227 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1229 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
1230 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
1231 gfc_index_one_node
);
1233 fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, stride
);
1234 /* Check the folding worked. */
1235 gcc_assert (INTEGER_CST_P (stride
));
1240 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1242 /* TODO: known offsets for descriptors. */
1243 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1245 /* We define data as an unknown size array. Much better than doing
1246 pointer arithmetic. */
1248 build_array_type (etype
, gfc_array_range_type
);
1249 arraytype
= build_pointer_type (arraytype
);
1250 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1255 /* Build a pointer type. This function is called from gfc_sym_type(). */
1258 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1260 /* Array pointer types aren't actually pointers. */
1261 if (sym
->attr
.dimension
)
1264 return build_pointer_type (type
);
1267 /* Return the type for a symbol. Special handling is required for character
1268 types to get the correct level of indirection.
1269 For functions return the return type.
1270 For subroutines return void_type_node.
1271 Calling this multiple times for the same symbol should be avoided,
1272 especially for character and array types. */
1275 gfc_sym_type (gfc_symbol
* sym
)
1280 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
1281 return void_type_node
;
1283 if (sym
->backend_decl
)
1285 if (sym
->attr
.function
)
1286 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
1288 return TREE_TYPE (sym
->backend_decl
);
1291 type
= gfc_typenode_for_spec (&sym
->ts
);
1292 if (gfc_option
.flag_f2c
1293 && sym
->attr
.function
1294 && sym
->ts
.type
== BT_REAL
1295 && sym
->ts
.kind
== gfc_default_real_kind
1296 && !sym
->attr
.always_explicit
)
1298 /* Special case: f2c calling conventions require that (scalar)
1299 default REAL functions return the C type double instead. */
1300 sym
->ts
.kind
= gfc_default_double_kind
;
1301 type
= gfc_typenode_for_spec (&sym
->ts
);
1302 sym
->ts
.kind
= gfc_default_real_kind
;
1305 if (sym
->attr
.dummy
&& !sym
->attr
.function
)
1310 if (sym
->attr
.dimension
)
1312 if (gfc_is_nodesc_array (sym
))
1314 /* If this is a character argument of unknown length, just use the
1316 if (sym
->ts
.type
!= BT_CHARACTER
1317 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
1318 || sym
->ts
.cl
->backend_decl
)
1320 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
1326 type
= gfc_build_array_type (type
, sym
->as
);
1330 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1331 type
= gfc_build_pointer_type (sym
, type
);
1334 /* We currently pass all parameters by reference.
1335 See f95_get_function_decl. For dummy function parameters return the
1339 /* We must use pointer types for potentially absent variables. The
1340 optimizers assume a reference type argument is never NULL. */
1341 if (sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
)
1342 type
= build_pointer_type (type
);
1344 type
= build_reference_type (type
);
1350 /* Layout and output debug info for a record type. */
1353 gfc_finish_type (tree type
)
1357 decl
= build_decl (TYPE_DECL
, NULL_TREE
, type
);
1358 TYPE_STUB_DECL (type
) = decl
;
1360 rest_of_type_compilation (type
, 1);
1361 rest_of_decl_compilation (decl
, 1, 0);
1364 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1365 or RECORD_TYPE pointed to by STYPE. The new field is chained
1366 to the fieldlist pointed to by FIELDLIST.
1368 Returns a pointer to the new field. */
1371 gfc_add_field_to_struct (tree
*fieldlist
, tree context
,
1372 tree name
, tree type
)
1376 decl
= build_decl (FIELD_DECL
, name
, type
);
1378 DECL_CONTEXT (decl
) = context
;
1379 DECL_INITIAL (decl
) = 0;
1380 DECL_ALIGN (decl
) = 0;
1381 DECL_USER_ALIGN (decl
) = 0;
1382 TREE_CHAIN (decl
) = NULL_TREE
;
1383 *fieldlist
= chainon (*fieldlist
, decl
);
1389 /* Build a tree node for a derived type. */
1392 gfc_get_derived_type (gfc_symbol
* derived
)
1394 tree typenode
, field
, field_type
, fieldlist
;
1397 gcc_assert (derived
&& derived
->attr
.flavor
== FL_DERIVED
);
1399 /* derived->backend_decl != 0 means we saw it before, but its
1400 components' backend_decl may have not been built. */
1401 if (derived
->backend_decl
)
1403 /* Its components' backend_decl have been built. */
1404 if (TYPE_FIELDS (derived
->backend_decl
))
1405 return derived
->backend_decl
;
1407 typenode
= derived
->backend_decl
;
1411 /* We see this derived type first time, so build the type node. */
1412 typenode
= make_node (RECORD_TYPE
);
1413 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
1414 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
1415 derived
->backend_decl
= typenode
;
1418 /* Build the type member list. Install the newly created RECORD_TYPE
1419 node as DECL_CONTEXT of each FIELD_DECL. */
1420 fieldlist
= NULL_TREE
;
1421 for (c
= derived
->components
; c
; c
= c
->next
)
1423 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
)
1425 if (c
->ts
.derived
->backend_decl
)
1426 /* We already saw this derived type so use the exiting type.
1427 It doesn't matter if it is incomplete. */
1428 field_type
= c
->ts
.derived
->backend_decl
;
1430 /* Recurse into the type. */
1431 field_type
= gfc_get_derived_type (c
->ts
.derived
);
1435 if (c
->ts
.type
== BT_CHARACTER
)
1437 /* Evaluate the string length. */
1438 gfc_conv_const_charlen (c
->ts
.cl
);
1439 gcc_assert (c
->ts
.cl
->backend_decl
);
1442 field_type
= gfc_typenode_for_spec (&c
->ts
);
1445 /* This returns an array descriptor type. Initialization may be
1451 /* Pointers to arrays aren't actually pointer types. The
1452 descriptors are separate, but the data is common. */
1453 field_type
= gfc_build_array_type (field_type
, c
->as
);
1456 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
, 3);
1458 else if (c
->pointer
)
1459 field_type
= build_pointer_type (field_type
);
1461 field
= gfc_add_field_to_struct (&fieldlist
, typenode
,
1462 get_identifier (c
->name
),
1465 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
1467 gcc_assert (!c
->backend_decl
);
1468 c
->backend_decl
= field
;
1471 /* Now we have the final fieldlist. Record it, then lay out the
1472 derived type, including the fields. */
1473 TYPE_FIELDS (typenode
) = fieldlist
;
1475 gfc_finish_type (typenode
);
1477 derived
->backend_decl
= typenode
;
1483 gfc_return_by_reference (gfc_symbol
* sym
)
1485 if (!sym
->attr
.function
)
1488 if (sym
->attr
.dimension
)
1491 if (sym
->ts
.type
== BT_CHARACTER
)
1494 /* Possibly return complex numbers by reference for g77 compatibility.
1495 We don't do this for calls to intrinsics (as the library uses the
1496 -fno-f2c calling convention), nor for calls to functions which always
1497 require an explicit interface, as no compatibility problems can
1499 if (gfc_option
.flag_f2c
1500 && sym
->ts
.type
== BT_COMPLEX
1501 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
1508 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
1513 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1514 gfc_entry_list
*el
, *el2
;
1516 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
1517 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
1519 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
1521 /* Build the type node. */
1522 type
= make_node (UNION_TYPE
);
1524 TYPE_NAME (type
) = get_identifier (name
);
1527 for (el
= ns
->entries
; el
; el
= el
->next
)
1529 /* Search for duplicates. */
1530 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
1531 if (el2
->sym
->result
== el
->sym
->result
)
1536 decl
= build_decl (FIELD_DECL
,
1537 get_identifier (el
->sym
->result
->name
),
1538 gfc_sym_type (el
->sym
->result
));
1539 DECL_CONTEXT (decl
) = type
;
1540 fieldlist
= chainon (fieldlist
, decl
);
1544 /* Finish off the type. */
1545 TYPE_FIELDS (type
) = fieldlist
;
1547 gfc_finish_type (type
);
1552 gfc_get_function_type (gfc_symbol
* sym
)
1556 gfc_formal_arglist
*f
;
1559 int alternate_return
;
1561 /* Make sure this symbol is a function or a subroutine. */
1562 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1564 if (sym
->backend_decl
)
1565 return TREE_TYPE (sym
->backend_decl
);
1568 alternate_return
= 0;
1569 typelist
= NULL_TREE
;
1571 if (sym
->attr
.entry_master
)
1573 /* Additional parameter for selecting an entry point. */
1574 typelist
= gfc_chainon_list (typelist
, gfc_array_index_type
);
1577 /* Some functions we use an extra parameter for the return value. */
1578 if (gfc_return_by_reference (sym
))
1585 if (arg
->ts
.type
== BT_CHARACTER
)
1586 gfc_conv_const_charlen (arg
->ts
.cl
);
1588 type
= gfc_sym_type (arg
);
1589 if (arg
->ts
.type
== BT_COMPLEX
1590 || arg
->attr
.dimension
1591 || arg
->ts
.type
== BT_CHARACTER
)
1592 type
= build_reference_type (type
);
1594 typelist
= gfc_chainon_list (typelist
, type
);
1595 if (arg
->ts
.type
== BT_CHARACTER
)
1596 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
1599 /* Build the argument types for the function. */
1600 for (f
= sym
->formal
; f
; f
= f
->next
)
1605 /* Evaluate constant character lengths here so that they can be
1606 included in the type. */
1607 if (arg
->ts
.type
== BT_CHARACTER
)
1608 gfc_conv_const_charlen (arg
->ts
.cl
);
1610 if (arg
->attr
.flavor
== FL_PROCEDURE
)
1612 type
= gfc_get_function_type (arg
);
1613 type
= build_pointer_type (type
);
1616 type
= gfc_sym_type (arg
);
1618 /* Parameter Passing Convention
1620 We currently pass all parameters by reference.
1621 Parameters with INTENT(IN) could be passed by value.
1622 The problem arises if a function is called via an implicit
1623 prototype. In this situation the INTENT is not known.
1624 For this reason all parameters to global functions must be
1625 passed by reference. Passing by value would potentially
1626 generate bad code. Worse there would be no way of telling that
1627 this code was bad, except that it would give incorrect results.
1629 Contained procedures could pass by value as these are never
1630 used without an explicit interface, and connot be passed as
1631 actual parameters for a dummy procedure. */
1632 if (arg
->ts
.type
== BT_CHARACTER
)
1634 typelist
= gfc_chainon_list (typelist
, type
);
1638 if (sym
->attr
.subroutine
)
1639 alternate_return
= 1;
1643 /* Add hidden string length parameters. */
1645 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
1647 typelist
= gfc_chainon_list (typelist
, void_type_node
);
1649 if (alternate_return
)
1650 type
= integer_type_node
;
1651 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
1652 type
= void_type_node
;
1653 else if (sym
->attr
.mixed_entry_master
)
1654 type
= gfc_get_mixed_entry_union (sym
->ns
);
1656 type
= gfc_sym_type (sym
);
1658 type
= build_function_type (type
, typelist
);
1663 /* Language hooks for middle-end access to type nodes. */
1665 /* Return an integer type with BITS bits of precision,
1666 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1669 gfc_type_for_size (unsigned bits
, int unsignedp
)
1674 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
1676 tree type
= gfc_integer_types
[i
];
1677 if (type
&& bits
== TYPE_PRECISION (type
))
1683 if (bits
== TYPE_PRECISION (unsigned_intQI_type_node
))
1684 return unsigned_intQI_type_node
;
1685 if (bits
== TYPE_PRECISION (unsigned_intHI_type_node
))
1686 return unsigned_intHI_type_node
;
1687 if (bits
== TYPE_PRECISION (unsigned_intSI_type_node
))
1688 return unsigned_intSI_type_node
;
1689 if (bits
== TYPE_PRECISION (unsigned_intDI_type_node
))
1690 return unsigned_intDI_type_node
;
1691 if (bits
== TYPE_PRECISION (unsigned_intTI_type_node
))
1692 return unsigned_intTI_type_node
;
1698 /* Return a data type that has machine mode MODE. If the mode is an
1699 integer, then UNSIGNEDP selects between signed and unsigned types. */
1702 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
1707 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
1708 base
= gfc_real_types
;
1709 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
1710 base
= gfc_complex_types
;
1711 else if (SCALAR_INT_MODE_P (mode
))
1712 return gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
1713 else if (VECTOR_MODE_P (mode
))
1715 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
1716 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
1717 if (inner_type
!= NULL_TREE
)
1718 return build_vector_type_for_mode (inner_type
, mode
);
1724 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
1726 tree type
= base
[i
];
1727 if (type
&& mode
== TYPE_MODE (type
))
1734 /* Return a type the same as TYPE except unsigned or
1735 signed according to UNSIGNEDP. */
1738 gfc_signed_or_unsigned_type (int unsignedp
, tree type
)
1740 if (TREE_CODE (type
) != INTEGER_TYPE
|| TYPE_UNSIGNED (type
) == unsignedp
)
1743 return gfc_type_for_size (TYPE_PRECISION (type
), unsignedp
);
1746 /* Return an unsigned type the same as TYPE in other respects. */
1749 gfc_unsigned_type (tree type
)
1751 return gfc_signed_or_unsigned_type (1, type
);
1754 /* Return a signed type the same as TYPE in other respects. */
1757 gfc_signed_type (tree type
)
1759 return gfc_signed_or_unsigned_type (0, type
);
1762 #include "gt-fortran-trans-types.h"