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 /* Let the kind equal the precision divided by 8, rounding up. Again,
156 this insulates the programmer from the underlying byte size.
158 Also, it effectively deals with IEEE extended formats. There, the
159 total size of the type may equal 16, but it's got 6 bytes of padding
160 and the increased size can get in the way of a real IEEE quad format
161 which may also be supported by the target.
163 We round up so as to handle IA-64 __floatreg (RFmode), which is an
164 82 bit type. Not to be confused with __float80 (XFmode), which is
165 an 80 bit type also supported by IA-64. So XFmode should come out
166 to be kind=10, and RFmode should come out to be kind=11. Egads. */
168 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
177 /* Careful we don't stumble a wierd internal mode. */
178 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
179 /* Or have too many modes for the allocated space. */
180 gcc_assert (r_index
!= MAX_REAL_KINDS
);
182 gfc_real_kinds
[r_index
].kind
= kind
;
183 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
184 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
185 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
186 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
187 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
191 /* Choose the default integer kind. We choose 4 unless the user
192 directs us otherwise. */
193 if (gfc_option
.flag_default_integer
)
196 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
197 gfc_default_integer_kind
= 8;
200 gfc_default_integer_kind
= 4;
202 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
204 /* Choose the default real kind. Again, we choose 4 when possible. */
205 if (gfc_option
.flag_default_real
)
208 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
209 gfc_default_real_kind
= 8;
212 gfc_default_real_kind
= 4;
214 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
216 /* Choose the default double kind. If -fdefault-real and -fdefault-double
217 are specified, we use kind=8, if it's available. If -fdefault-real is
218 specified without -fdefault-double, we use kind=16, if it's available.
219 Otherwise we do not change anything. */
220 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
221 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
223 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
224 gfc_default_double_kind
= 8;
225 else if (gfc_option
.flag_default_real
&& saw_r16
)
226 gfc_default_double_kind
= 16;
227 else if (saw_r4
&& saw_r8
)
228 gfc_default_double_kind
= 8;
231 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
232 real ... occupies two contiguous numeric storage units.
234 Therefore we must be supplied a kind twice as large as we chose
235 for single precision. There are loopholes, in that double
236 precision must *occupy* two storage units, though it doesn't have
237 to *use* two storage units. Which means that you can make this
238 kind artificially wide by padding it. But at present there are
239 no GCC targets for which a two-word type does not exist, so we
240 just let gfc_validate_kind abort and tell us if something breaks. */
242 gfc_default_double_kind
243 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
246 /* The default logical kind is constrained to be the same as the
247 default integer kind. Similarly with complex and real. */
248 gfc_default_logical_kind
= gfc_default_integer_kind
;
249 gfc_default_complex_kind
= gfc_default_real_kind
;
251 /* Choose the smallest integer kind for our default character. */
252 gfc_default_character_kind
= gfc_integer_kinds
[0].kind
;
254 /* Choose the integer kind the same size as "void*" for our index kind. */
255 gfc_index_integer_kind
= POINTER_SIZE
/ 8;
256 /* Pick a kind the same size as the C "int" type. */
257 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
260 /* Make sure that a valid kind is present. Returns an index into the
261 associated kinds array, -1 if the kind is not present. */
264 validate_integer (int kind
)
268 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
269 if (gfc_integer_kinds
[i
].kind
== kind
)
276 validate_real (int kind
)
280 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
281 if (gfc_real_kinds
[i
].kind
== kind
)
288 validate_logical (int kind
)
292 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
293 if (gfc_logical_kinds
[i
].kind
== kind
)
300 validate_character (int kind
)
302 return kind
== gfc_default_character_kind
? 0 : -1;
305 /* Validate a kind given a basic type. The return value is the same
306 for the child functions, with -1 indicating nonexistence of the
307 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
310 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
316 case BT_REAL
: /* Fall through */
318 rc
= validate_real (kind
);
321 rc
= validate_integer (kind
);
324 rc
= validate_logical (kind
);
327 rc
= validate_character (kind
);
331 gfc_internal_error ("gfc_validate_kind(): Got bad type");
334 if (rc
< 0 && !may_fail
)
335 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
341 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
342 Reuse common type nodes where possible. Recognize if the kind matches up
343 with a C type. This will be used later in determining which routines may
344 be scarfed from libm. */
347 gfc_build_int_type (gfc_integer_info
*info
)
349 int mode_precision
= info
->bit_size
;
351 if (mode_precision
== CHAR_TYPE_SIZE
)
353 if (mode_precision
== SHORT_TYPE_SIZE
)
355 if (mode_precision
== INT_TYPE_SIZE
)
357 if (mode_precision
== LONG_TYPE_SIZE
)
359 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
360 info
->c_long_long
= 1;
362 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
363 return intQI_type_node
;
364 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
365 return intHI_type_node
;
366 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
367 return intSI_type_node
;
368 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
369 return intDI_type_node
;
370 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
371 return intTI_type_node
;
373 return make_signed_type (mode_precision
);
377 gfc_build_real_type (gfc_real_info
*info
)
379 int mode_precision
= info
->mode_precision
;
382 if (mode_precision
== FLOAT_TYPE_SIZE
)
384 if (mode_precision
== DOUBLE_TYPE_SIZE
)
386 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
387 info
->c_long_double
= 1;
389 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
390 return float_type_node
;
391 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
392 return double_type_node
;
393 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
394 return long_double_type_node
;
396 new_type
= make_node (REAL_TYPE
);
397 TYPE_PRECISION (new_type
) = mode_precision
;
398 layout_type (new_type
);
403 gfc_build_complex_type (tree scalar_type
)
407 if (scalar_type
== NULL
)
409 if (scalar_type
== float_type_node
)
410 return complex_float_type_node
;
411 if (scalar_type
== double_type_node
)
412 return complex_double_type_node
;
413 if (scalar_type
== long_double_type_node
)
414 return complex_long_double_type_node
;
416 new_type
= make_node (COMPLEX_TYPE
);
417 TREE_TYPE (new_type
) = scalar_type
;
418 layout_type (new_type
);
423 gfc_build_logical_type (gfc_logical_info
*info
)
425 int bit_size
= info
->bit_size
;
428 if (bit_size
== BOOL_TYPE_SIZE
)
431 return boolean_type_node
;
434 new_type
= make_unsigned_type (bit_size
);
435 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
436 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
437 TYPE_PRECISION (new_type
) = 1;
443 /* Return the bit size of the C "size_t". */
449 if (strcmp (SIZE_TYPE
, "unsigned int") == 0)
450 return INT_TYPE_SIZE
;
451 if (strcmp (SIZE_TYPE
, "long unsigned int") == 0)
452 return LONG_TYPE_SIZE
;
453 if (strcmp (SIZE_TYPE
, "short unsigned int") == 0)
454 return SHORT_TYPE_SIZE
;
457 return LONG_TYPE_SIZE
;
462 /* Create the backend type nodes. We map them to their
463 equivalent C type, at least for now. We also give
464 names to the types here, and we push them in the
465 global binding level context.*/
468 gfc_init_types (void)
474 unsigned HOST_WIDE_INT hi
;
475 unsigned HOST_WIDE_INT lo
;
477 /* Create and name the types. */
478 #define PUSH_TYPE(name, node) \
479 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
481 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
483 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
484 gfc_integer_types
[index
] = type
;
485 snprintf (name_buf
, sizeof(name_buf
), "int%d",
486 gfc_integer_kinds
[index
].kind
);
487 PUSH_TYPE (name_buf
, type
);
490 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
492 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
493 gfc_logical_types
[index
] = type
;
494 snprintf (name_buf
, sizeof(name_buf
), "logical%d",
495 gfc_logical_kinds
[index
].kind
);
496 PUSH_TYPE (name_buf
, type
);
499 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
501 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
502 gfc_real_types
[index
] = type
;
503 snprintf (name_buf
, sizeof(name_buf
), "real%d",
504 gfc_real_kinds
[index
].kind
);
505 PUSH_TYPE (name_buf
, type
);
507 type
= gfc_build_complex_type (type
);
508 gfc_complex_types
[index
] = type
;
509 snprintf (name_buf
, sizeof(name_buf
), "complex%d",
510 gfc_real_kinds
[index
].kind
);
511 PUSH_TYPE (name_buf
, type
);
514 gfc_character1_type_node
= build_type_variant (unsigned_char_type_node
,
516 PUSH_TYPE ("char", gfc_character1_type_node
);
518 PUSH_TYPE ("byte", unsigned_char_type_node
);
519 PUSH_TYPE ("void", void_type_node
);
521 /* DBX debugging output gets upset if these aren't set. */
522 if (!TYPE_NAME (integer_type_node
))
523 PUSH_TYPE ("c_integer", integer_type_node
);
524 if (!TYPE_NAME (char_type_node
))
525 PUSH_TYPE ("c_char", char_type_node
);
529 pvoid_type_node
= build_pointer_type (void_type_node
);
530 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
531 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
533 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
534 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
535 since this function is called before gfc_init_constants. */
537 = build_range_type (gfc_array_index_type
,
538 build_int_cst (gfc_array_index_type
, 0),
541 /* The maximum array element size that can be handled is determined
542 by the number of bits available to store this field in the array
545 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
546 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
547 if (n
> HOST_BITS_PER_WIDE_INT
)
548 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
550 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
551 gfc_max_array_element_size
552 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
554 size_type_node
= gfc_array_index_type
;
556 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
557 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
558 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
560 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
561 gfc_charlen_type_node
= gfc_get_int_type (4);
564 /* Get the type node for the given type and kind. */
567 gfc_get_int_type (int kind
)
569 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
570 return index
< 0 ? 0 : gfc_integer_types
[index
];
574 gfc_get_real_type (int kind
)
576 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
577 return index
< 0 ? 0 : gfc_real_types
[index
];
581 gfc_get_complex_type (int kind
)
583 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
584 return index
< 0 ? 0 : gfc_complex_types
[index
];
588 gfc_get_logical_type (int kind
)
590 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
591 return index
< 0 ? 0 : gfc_logical_types
[index
];
594 /* Create a character type with the given kind and length. */
597 gfc_get_character_type_len (int kind
, tree len
)
601 gfc_validate_kind (BT_CHARACTER
, kind
, false);
603 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
604 type
= build_array_type (gfc_character1_type_node
, bounds
);
605 TYPE_STRING_FLAG (type
) = 1;
611 /* Get a type node for a character kind. */
614 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
618 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
620 return gfc_get_character_type_len (kind
, len
);
623 /* Covert a basic type. This will be an array for character types. */
626 gfc_typenode_for_spec (gfc_typespec
* spec
)
636 basetype
= gfc_get_int_type (spec
->kind
);
640 basetype
= gfc_get_real_type (spec
->kind
);
644 basetype
= gfc_get_complex_type (spec
->kind
);
648 basetype
= gfc_get_logical_type (spec
->kind
);
652 basetype
= gfc_get_character_type (spec
->kind
, spec
->cl
);
656 basetype
= gfc_get_derived_type (spec
->derived
);
665 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
668 gfc_conv_array_bound (gfc_expr
* expr
)
670 /* If expr is an integer constant, return that. */
671 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
672 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
674 /* Otherwise return NULL. */
679 gfc_get_element_type (tree type
)
683 if (GFC_ARRAY_TYPE_P (type
))
685 if (TREE_CODE (type
) == POINTER_TYPE
)
686 type
= TREE_TYPE (type
);
687 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
688 element
= TREE_TYPE (type
);
692 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
693 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
695 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
696 element
= TREE_TYPE (element
);
698 gcc_assert (TREE_CODE (element
) == ARRAY_TYPE
);
699 element
= TREE_TYPE (element
);
705 /* Build an array. This function is called from gfc_sym_type().
706 Actually returns array descriptor type.
708 Format of array descriptors is as follows:
710 struct gfc_array_descriptor
715 struct descriptor_dimension dimension[N_DIM];
718 struct descriptor_dimension
725 Translation code should use gfc_conv_descriptor_* rather than accessing
726 the descriptor directly. Any changes to the array descriptor type will
727 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
729 This is represented internally as a RECORD_TYPE. The index nodes are
730 gfc_array_index_type and the data node is a pointer to the data. See below
731 for the handling of character types.
733 The dtype member is formatted as follows:
734 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
735 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
736 size = dtype >> GFC_DTYPE_SIZE_SHIFT
738 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
739 generated poor code for assumed/deferred size arrays. These require
740 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
741 grammar. Also, there is no way to explicitly set the array stride, so
742 all data must be packed(1). I've tried to mark all the functions which
743 would require modification with a GCC ARRAYS comment.
745 The data component points to the first element in the array.
746 The offset field is the position of the origin of the array
747 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
749 An element is accessed by
750 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
751 This gives good performance as the computation does not involve the
752 bounds of the array. For packed arrays, this is optimized further by
753 substituting the known strides.
755 This system has one problem: all array bounds must be withing 2^31 elements
756 of the origin (2^63 on 64-bit machines). For example
757 integer, dimension (80000:90000, 80000:90000, 2) :: array
758 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
759 the calculation for stride02 would overflow. This may still work, but
760 I haven't checked, and it relies on the overflow doing the right thing.
762 The way to fix this problem is to access elements as follows:
763 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
764 Obviously this is much slower. I will make this a compile time option,
765 something like -fsmall-array-offsets. Mixing code compiled with and without
766 this switch will work.
768 (1) This can be worked around by modifying the upper bound of the previous
769 dimension. This requires extra fields in the descriptor (both real_ubound
770 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
771 may allow us to do this. However I can't find mention of this anywhere
775 /* Returns true if the array sym does not require a descriptor. */
778 gfc_is_nodesc_array (gfc_symbol
* sym
)
780 gcc_assert (sym
->attr
.dimension
);
782 /* We only want local arrays. */
783 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
788 if (sym
->as
->type
!= AS_ASSUMED_SHAPE
)
794 if (sym
->attr
.result
|| sym
->attr
.function
)
797 gcc_assert (sym
->as
->type
== AS_EXPLICIT
);
803 /* Create an array descriptor type. */
806 gfc_build_array_type (tree type
, gfc_array_spec
* as
)
808 tree lbound
[GFC_MAX_DIMENSIONS
];
809 tree ubound
[GFC_MAX_DIMENSIONS
];
812 for (n
= 0; n
< as
->rank
; n
++)
814 /* Create expressions for the known bounds of the array. */
815 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
816 lbound
[n
] = gfc_index_one_node
;
818 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
819 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
822 return gfc_get_array_type_bounds (type
, as
->rank
, lbound
, ubound
, 0);
825 /* Returns the struct descriptor_dimension type. */
828 gfc_get_desc_dim_type (void)
834 if (gfc_desc_dim_type
)
835 return gfc_desc_dim_type
;
837 /* Build the type node. */
838 type
= make_node (RECORD_TYPE
);
840 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
841 TYPE_PACKED (type
) = 1;
843 /* Consists of the stride, lbound and ubound members. */
844 decl
= build_decl (FIELD_DECL
,
845 get_identifier ("stride"), gfc_array_index_type
);
846 DECL_CONTEXT (decl
) = type
;
849 decl
= build_decl (FIELD_DECL
,
850 get_identifier ("lbound"), gfc_array_index_type
);
851 DECL_CONTEXT (decl
) = type
;
852 fieldlist
= chainon (fieldlist
, decl
);
854 decl
= build_decl (FIELD_DECL
,
855 get_identifier ("ubound"), gfc_array_index_type
);
856 DECL_CONTEXT (decl
) = type
;
857 fieldlist
= chainon (fieldlist
, decl
);
859 /* Finish off the type. */
860 TYPE_FIELDS (type
) = fieldlist
;
862 gfc_finish_type (type
);
864 gfc_desc_dim_type
= type
;
869 /* Return the DTYPE for an array. This describes the type and type parameters
871 /* TODO: Only call this when the value is actually used, and make all the
872 unknown cases abort. */
875 gfc_get_dtype (tree type
)
885 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
887 if (GFC_TYPE_ARRAY_DTYPE (type
))
888 return GFC_TYPE_ARRAY_DTYPE (type
);
890 rank
= GFC_TYPE_ARRAY_RANK (type
);
891 etype
= gfc_get_element_type (type
);
893 switch (TREE_CODE (etype
))
896 n
= GFC_DTYPE_INTEGER
;
900 n
= GFC_DTYPE_LOGICAL
;
908 n
= GFC_DTYPE_COMPLEX
;
911 /* We will never have arrays of arrays. */
913 n
= GFC_DTYPE_DERIVED
;
917 n
= GFC_DTYPE_CHARACTER
;
921 /* TODO: Don't do dtype for temporary descriptorless arrays. */
922 /* We can strange array types for temporary arrays. */
923 return gfc_index_zero_node
;
926 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
927 size
= TYPE_SIZE_UNIT (etype
);
929 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
930 if (size
&& INTEGER_CST_P (size
))
932 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
933 internal_error ("Array element size too big");
935 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
937 dtype
= build_int_cst (gfc_array_index_type
, i
);
939 if (size
&& !INTEGER_CST_P (size
))
941 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
942 tmp
= fold_build2 (LSHIFT_EXPR
, gfc_array_index_type
, size
, tmp
);
943 dtype
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, dtype
);
945 /* If we don't know the size we leave it as zero. This should never happen
946 for anything that is actually used. */
947 /* TODO: Check this is actually true, particularly when repacking
948 assumed size parameters. */
950 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
955 /* Build an array type for use without a descriptor. Valid values of packed
956 are 0=no, 1=partial, 2=full, 3=static. */
959 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, int packed
)
972 mpz_init_set_ui (offset
, 0);
973 mpz_init_set_ui (stride
, 1);
976 /* We don't use build_array_type because this does not include include
977 lang-specific information (i.e. the bounds of the array) when checking
979 type
= make_node (ARRAY_TYPE
);
981 GFC_ARRAY_TYPE_P (type
) = 1;
982 TYPE_LANG_SPECIFIC (type
) = (struct lang_type
*)
983 ggc_alloc_cleared (sizeof (struct lang_type
));
985 known_stride
= (packed
!= 0);
987 for (n
= 0; n
< as
->rank
; n
++)
989 /* Fill in the stride and bound components of the type. */
991 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
994 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
997 if (expr
->expr_type
== EXPR_CONSTANT
)
999 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1000 gfc_index_integer_kind
);
1007 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1011 /* Calculate the offset. */
1012 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1013 mpz_sub (offset
, offset
, delta
);
1018 expr
= as
->upper
[n
];
1019 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1021 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1022 gfc_index_integer_kind
);
1029 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1033 /* Calculate the stride. */
1034 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1035 as
->lower
[n
]->value
.integer
);
1036 mpz_add_ui (delta
, delta
, 1);
1037 mpz_mul (stride
, stride
, delta
);
1040 /* Only the first stride is known for partial packed arrays. */
1047 GFC_TYPE_ARRAY_OFFSET (type
) =
1048 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1051 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1055 GFC_TYPE_ARRAY_SIZE (type
) =
1056 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1059 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1061 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1062 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1063 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1065 /* TODO: use main type if it is unbounded. */
1066 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1067 build_pointer_type (build_array_type (etype
, range
));
1071 mpz_sub_ui (stride
, stride
, 1);
1072 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1077 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1078 TYPE_DOMAIN (type
) = range
;
1080 build_pointer_type (etype
);
1081 TREE_TYPE (type
) = etype
;
1089 if (packed
< 3 || !known_stride
)
1091 /* For dummy arrays and automatic (heap allocated) arrays we
1092 want a pointer to the array. */
1093 type
= build_pointer_type (type
);
1094 GFC_ARRAY_TYPE_P (type
) = 1;
1095 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1100 /* Return or create the base type for an array descriptor. */
1103 gfc_get_array_descriptor_base (int dimen
)
1105 tree fat_type
, fieldlist
, decl
, arraytype
;
1106 char name
[16 + GFC_RANK_DIGITS
+ 1];
1108 gcc_assert (dimen
>= 1 && dimen
<= GFC_MAX_DIMENSIONS
);
1109 if (gfc_array_descriptor_base
[dimen
- 1])
1110 return gfc_array_descriptor_base
[dimen
- 1];
1112 /* Build the type node. */
1113 fat_type
= make_node (RECORD_TYPE
);
1115 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
);
1116 TYPE_NAME (fat_type
) = get_identifier (name
);
1118 /* Add the data member as the first element of the descriptor. */
1119 decl
= build_decl (FIELD_DECL
, get_identifier ("data"), ptr_type_node
);
1121 DECL_CONTEXT (decl
) = fat_type
;
1124 /* Add the base component. */
1125 decl
= build_decl (FIELD_DECL
, get_identifier ("offset"),
1126 gfc_array_index_type
);
1127 DECL_CONTEXT (decl
) = fat_type
;
1128 fieldlist
= chainon (fieldlist
, decl
);
1130 /* Add the dtype component. */
1131 decl
= build_decl (FIELD_DECL
, get_identifier ("dtype"),
1132 gfc_array_index_type
);
1133 DECL_CONTEXT (decl
) = fat_type
;
1134 fieldlist
= chainon (fieldlist
, decl
);
1136 /* Build the array type for the stride and bound components. */
1138 build_array_type (gfc_get_desc_dim_type (),
1139 build_range_type (gfc_array_index_type
,
1140 gfc_index_zero_node
,
1141 gfc_rank_cst
[dimen
- 1]));
1143 decl
= build_decl (FIELD_DECL
, get_identifier ("dim"), arraytype
);
1144 DECL_CONTEXT (decl
) = fat_type
;
1145 fieldlist
= chainon (fieldlist
, decl
);
1147 /* Finish off the type. */
1148 TYPE_FIELDS (fat_type
) = fieldlist
;
1150 gfc_finish_type (fat_type
);
1152 gfc_array_descriptor_base
[dimen
- 1] = fat_type
;
1156 /* Build an array (descriptor) type with given bounds. */
1159 gfc_get_array_type_bounds (tree etype
, int dimen
, tree
* lbound
,
1160 tree
* ubound
, int packed
)
1162 char name
[8 + GFC_RANK_DIGITS
+ GFC_MAX_SYMBOL_LEN
];
1163 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
;
1164 const char *typename
;
1167 base_type
= gfc_get_array_descriptor_base (dimen
);
1168 fat_type
= build_variant_type_copy (base_type
);
1170 tmp
= TYPE_NAME (etype
);
1171 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1172 tmp
= DECL_NAME (tmp
);
1174 typename
= IDENTIFIER_POINTER (tmp
);
1176 typename
= "unknown";
1177 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
,
1178 GFC_MAX_SYMBOL_LEN
, typename
);
1179 TYPE_NAME (fat_type
) = get_identifier (name
);
1181 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1182 TYPE_LANG_SPECIFIC (fat_type
) = (struct lang_type
*)
1183 ggc_alloc_cleared (sizeof (struct lang_type
));
1185 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1186 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1188 /* Build an array descriptor record type. */
1190 stride
= gfc_index_one_node
;
1193 for (n
= 0; n
< dimen
; n
++)
1195 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1202 if (lower
!= NULL_TREE
)
1204 if (INTEGER_CST_P (lower
))
1205 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1211 if (upper
!= NULL_TREE
)
1213 if (INTEGER_CST_P (upper
))
1214 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1219 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1221 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
1222 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
1223 gfc_index_one_node
);
1225 fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, stride
);
1226 /* Check the folding worked. */
1227 gcc_assert (INTEGER_CST_P (stride
));
1232 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1234 /* TODO: known offsets for descriptors. */
1235 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1237 /* We define data as an unknown size array. Much better than doing
1238 pointer arithmetic. */
1240 build_array_type (etype
, gfc_array_range_type
);
1241 arraytype
= build_pointer_type (arraytype
);
1242 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1247 /* Build a pointer type. This function is called from gfc_sym_type(). */
1250 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1252 /* Array pointer types aren't actually pointers. */
1253 if (sym
->attr
.dimension
)
1256 return build_pointer_type (type
);
1259 /* Return the type for a symbol. Special handling is required for character
1260 types to get the correct level of indirection.
1261 For functions return the return type.
1262 For subroutines return void_type_node.
1263 Calling this multiple times for the same symbol should be avoided,
1264 especially for character and array types. */
1267 gfc_sym_type (gfc_symbol
* sym
)
1272 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
1273 return void_type_node
;
1275 if (sym
->backend_decl
)
1277 if (sym
->attr
.function
)
1278 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
1280 return TREE_TYPE (sym
->backend_decl
);
1283 type
= gfc_typenode_for_spec (&sym
->ts
);
1284 if (gfc_option
.flag_f2c
1285 && sym
->attr
.function
1286 && sym
->ts
.type
== BT_REAL
1287 && sym
->ts
.kind
== gfc_default_real_kind
1288 && !sym
->attr
.always_explicit
)
1290 /* Special case: f2c calling conventions require that (scalar)
1291 default REAL functions return the C type double instead. */
1292 sym
->ts
.kind
= gfc_default_double_kind
;
1293 type
= gfc_typenode_for_spec (&sym
->ts
);
1294 sym
->ts
.kind
= gfc_default_real_kind
;
1297 if (sym
->attr
.dummy
&& !sym
->attr
.function
)
1302 if (sym
->attr
.dimension
)
1304 if (gfc_is_nodesc_array (sym
))
1306 /* If this is a character argument of unknown length, just use the
1308 if (sym
->ts
.type
!= BT_CHARACTER
1309 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
1310 || sym
->ts
.cl
->backend_decl
)
1312 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
1318 type
= gfc_build_array_type (type
, sym
->as
);
1322 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1323 type
= gfc_build_pointer_type (sym
, type
);
1326 /* We currently pass all parameters by reference.
1327 See f95_get_function_decl. For dummy function parameters return the
1331 /* We must use pointer types for potentially absent variables. The
1332 optimizers assume a reference type argument is never NULL. */
1333 if (sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
)
1334 type
= build_pointer_type (type
);
1336 type
= build_reference_type (type
);
1342 /* Layout and output debug info for a record type. */
1345 gfc_finish_type (tree type
)
1349 decl
= build_decl (TYPE_DECL
, NULL_TREE
, type
);
1350 TYPE_STUB_DECL (type
) = decl
;
1352 rest_of_type_compilation (type
, 1);
1353 rest_of_decl_compilation (decl
, 1, 0);
1356 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1357 or RECORD_TYPE pointed to by STYPE. The new field is chained
1358 to the fieldlist pointed to by FIELDLIST.
1360 Returns a pointer to the new field. */
1363 gfc_add_field_to_struct (tree
*fieldlist
, tree context
,
1364 tree name
, tree type
)
1368 decl
= build_decl (FIELD_DECL
, name
, type
);
1370 DECL_CONTEXT (decl
) = context
;
1371 DECL_INITIAL (decl
) = 0;
1372 DECL_ALIGN (decl
) = 0;
1373 DECL_USER_ALIGN (decl
) = 0;
1374 TREE_CHAIN (decl
) = NULL_TREE
;
1375 *fieldlist
= chainon (*fieldlist
, decl
);
1381 /* Build a tree node for a derived type. */
1384 gfc_get_derived_type (gfc_symbol
* derived
)
1386 tree typenode
, field
, field_type
, fieldlist
;
1389 gcc_assert (derived
&& derived
->attr
.flavor
== FL_DERIVED
);
1391 /* derived->backend_decl != 0 means we saw it before, but its
1392 components' backend_decl may have not been built. */
1393 if (derived
->backend_decl
)
1395 /* Its components' backend_decl have been built. */
1396 if (TYPE_FIELDS (derived
->backend_decl
))
1397 return derived
->backend_decl
;
1399 typenode
= derived
->backend_decl
;
1403 /* We see this derived type first time, so build the type node. */
1404 typenode
= make_node (RECORD_TYPE
);
1405 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
1406 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
1407 derived
->backend_decl
= typenode
;
1410 /* Build the type member list. Install the newly created RECORD_TYPE
1411 node as DECL_CONTEXT of each FIELD_DECL. */
1412 fieldlist
= NULL_TREE
;
1413 for (c
= derived
->components
; c
; c
= c
->next
)
1415 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
)
1417 if (c
->ts
.derived
->backend_decl
)
1418 /* We already saw this derived type so use the exiting type.
1419 It doesn't matter if it is incomplete. */
1420 field_type
= c
->ts
.derived
->backend_decl
;
1422 /* Recurse into the type. */
1423 field_type
= gfc_get_derived_type (c
->ts
.derived
);
1427 if (c
->ts
.type
== BT_CHARACTER
)
1429 /* Evaluate the string length. */
1430 gfc_conv_const_charlen (c
->ts
.cl
);
1431 gcc_assert (c
->ts
.cl
->backend_decl
);
1434 field_type
= gfc_typenode_for_spec (&c
->ts
);
1437 /* This returns an array descriptor type. Initialization may be
1443 /* Pointers to arrays aren't actually pointer types. The
1444 descriptors are separate, but the data is common. */
1445 field_type
= gfc_build_array_type (field_type
, c
->as
);
1448 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
, 3);
1450 else if (c
->pointer
)
1451 field_type
= build_pointer_type (field_type
);
1453 field
= gfc_add_field_to_struct (&fieldlist
, typenode
,
1454 get_identifier (c
->name
),
1457 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
1459 gcc_assert (!c
->backend_decl
);
1460 c
->backend_decl
= field
;
1463 /* Now we have the final fieldlist. Record it, then lay out the
1464 derived type, including the fields. */
1465 TYPE_FIELDS (typenode
) = fieldlist
;
1467 gfc_finish_type (typenode
);
1469 derived
->backend_decl
= typenode
;
1475 gfc_return_by_reference (gfc_symbol
* sym
)
1477 if (!sym
->attr
.function
)
1480 if (sym
->attr
.dimension
)
1483 if (sym
->ts
.type
== BT_CHARACTER
)
1486 /* Possibly return complex numbers by reference for g77 compatibility.
1487 We don't do this for calls to intrinsics (as the library uses the
1488 -fno-f2c calling convention), nor for calls to functions which always
1489 require an explicit interface, as no compatibility problems can
1491 if (gfc_option
.flag_f2c
1492 && sym
->ts
.type
== BT_COMPLEX
1493 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
1500 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
1505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1506 gfc_entry_list
*el
, *el2
;
1508 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
1509 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
1511 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
1513 /* Build the type node. */
1514 type
= make_node (UNION_TYPE
);
1516 TYPE_NAME (type
) = get_identifier (name
);
1519 for (el
= ns
->entries
; el
; el
= el
->next
)
1521 /* Search for duplicates. */
1522 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
1523 if (el2
->sym
->result
== el
->sym
->result
)
1528 decl
= build_decl (FIELD_DECL
,
1529 get_identifier (el
->sym
->result
->name
),
1530 gfc_sym_type (el
->sym
->result
));
1531 DECL_CONTEXT (decl
) = type
;
1532 fieldlist
= chainon (fieldlist
, decl
);
1536 /* Finish off the type. */
1537 TYPE_FIELDS (type
) = fieldlist
;
1539 gfc_finish_type (type
);
1544 gfc_get_function_type (gfc_symbol
* sym
)
1548 gfc_formal_arglist
*f
;
1551 int alternate_return
;
1553 /* Make sure this symbol is a function or a subroutine. */
1554 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1556 if (sym
->backend_decl
)
1557 return TREE_TYPE (sym
->backend_decl
);
1560 alternate_return
= 0;
1561 typelist
= NULL_TREE
;
1563 if (sym
->attr
.entry_master
)
1565 /* Additional parameter for selecting an entry point. */
1566 typelist
= gfc_chainon_list (typelist
, gfc_array_index_type
);
1569 /* Some functions we use an extra parameter for the return value. */
1570 if (gfc_return_by_reference (sym
))
1577 if (arg
->ts
.type
== BT_CHARACTER
)
1578 gfc_conv_const_charlen (arg
->ts
.cl
);
1580 type
= gfc_sym_type (arg
);
1581 if (arg
->ts
.type
== BT_COMPLEX
1582 || arg
->attr
.dimension
1583 || arg
->ts
.type
== BT_CHARACTER
)
1584 type
= build_reference_type (type
);
1586 typelist
= gfc_chainon_list (typelist
, type
);
1587 if (arg
->ts
.type
== BT_CHARACTER
)
1588 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
1591 /* Build the argument types for the function. */
1592 for (f
= sym
->formal
; f
; f
= f
->next
)
1597 /* Evaluate constant character lengths here so that they can be
1598 included in the type. */
1599 if (arg
->ts
.type
== BT_CHARACTER
)
1600 gfc_conv_const_charlen (arg
->ts
.cl
);
1602 if (arg
->attr
.flavor
== FL_PROCEDURE
)
1604 type
= gfc_get_function_type (arg
);
1605 type
= build_pointer_type (type
);
1608 type
= gfc_sym_type (arg
);
1610 /* Parameter Passing Convention
1612 We currently pass all parameters by reference.
1613 Parameters with INTENT(IN) could be passed by value.
1614 The problem arises if a function is called via an implicit
1615 prototype. In this situation the INTENT is not known.
1616 For this reason all parameters to global functions must be
1617 passed by reference. Passing by value would potentially
1618 generate bad code. Worse there would be no way of telling that
1619 this code was bad, except that it would give incorrect results.
1621 Contained procedures could pass by value as these are never
1622 used without an explicit interface, and connot be passed as
1623 actual parameters for a dummy procedure. */
1624 if (arg
->ts
.type
== BT_CHARACTER
)
1626 typelist
= gfc_chainon_list (typelist
, type
);
1630 if (sym
->attr
.subroutine
)
1631 alternate_return
= 1;
1635 /* Add hidden string length parameters. */
1637 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
1639 typelist
= gfc_chainon_list (typelist
, void_type_node
);
1641 if (alternate_return
)
1642 type
= integer_type_node
;
1643 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
1644 type
= void_type_node
;
1645 else if (sym
->attr
.mixed_entry_master
)
1646 type
= gfc_get_mixed_entry_union (sym
->ns
);
1648 type
= gfc_sym_type (sym
);
1650 type
= build_function_type (type
, typelist
);
1655 /* Language hooks for middle-end access to type nodes. */
1657 /* Return an integer type with BITS bits of precision,
1658 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1661 gfc_type_for_size (unsigned bits
, int unsignedp
)
1666 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
1668 tree type
= gfc_integer_types
[i
];
1669 if (type
&& bits
== TYPE_PRECISION (type
))
1675 if (bits
== TYPE_PRECISION (unsigned_intQI_type_node
))
1676 return unsigned_intQI_type_node
;
1677 if (bits
== TYPE_PRECISION (unsigned_intHI_type_node
))
1678 return unsigned_intHI_type_node
;
1679 if (bits
== TYPE_PRECISION (unsigned_intSI_type_node
))
1680 return unsigned_intSI_type_node
;
1681 if (bits
== TYPE_PRECISION (unsigned_intDI_type_node
))
1682 return unsigned_intDI_type_node
;
1683 if (bits
== TYPE_PRECISION (unsigned_intTI_type_node
))
1684 return unsigned_intTI_type_node
;
1690 /* Return a data type that has machine mode MODE. If the mode is an
1691 integer, then UNSIGNEDP selects between signed and unsigned types. */
1694 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
1699 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
1700 base
= gfc_real_types
;
1701 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
1702 base
= gfc_complex_types
;
1703 else if (SCALAR_INT_MODE_P (mode
))
1704 return gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
1705 else if (VECTOR_MODE_P (mode
))
1707 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
1708 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
1709 if (inner_type
!= NULL_TREE
)
1710 return build_vector_type_for_mode (inner_type
, mode
);
1716 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
1718 tree type
= base
[i
];
1719 if (type
&& mode
== TYPE_MODE (type
))
1726 /* Return a type the same as TYPE except unsigned or
1727 signed according to UNSIGNEDP. */
1730 gfc_signed_or_unsigned_type (int unsignedp
, tree type
)
1732 if (TREE_CODE (type
) != INTEGER_TYPE
|| TYPE_UNSIGNED (type
) == unsignedp
)
1735 return gfc_type_for_size (TYPE_PRECISION (type
), unsignedp
);
1738 /* Return an unsigned type the same as TYPE in other respects. */
1741 gfc_unsigned_type (tree type
)
1743 return gfc_signed_or_unsigned_type (1, type
);
1746 /* Return a signed type the same as TYPE in other respects. */
1749 gfc_signed_type (tree type
)
1751 return gfc_signed_or_unsigned_type (0, type
);
1754 #include "gt-fortran-trans-types.h"