1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, 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 COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-types.c -- gfortran backend types */
27 #include "coretypes.h"
29 #include "langhooks.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 /* array of structs so we don't have to worry about xmalloc or free */
52 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
54 static tree
gfc_get_derived_type (gfc_symbol
* derived
);
56 tree gfc_array_index_type
;
57 tree gfc_array_range_type
;
58 tree gfc_character1_type_node
;
60 tree ppvoid_type_node
;
64 tree gfc_charlen_type_node
;
66 static GTY(()) tree gfc_desc_dim_type
;
67 static GTY(()) tree gfc_max_array_element_size
;
68 static GTY(()) tree gfc_array_descriptor_base
[GFC_MAX_DIMENSIONS
];
70 /* Arrays for all integral and real kinds. We'll fill this in at runtime
71 after the target has a chance to process command-line options. */
73 #define MAX_INT_KINDS 5
74 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
75 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
76 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
77 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
79 #define MAX_REAL_KINDS 5
80 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
81 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
82 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
85 /* The integer kind to use for array indices. This will be set to the
86 proper value based on target information from the backend. */
88 int gfc_index_integer_kind
;
90 /* The default kinds of the various types. */
92 int gfc_default_integer_kind
;
93 int gfc_max_integer_kind
;
94 int gfc_default_real_kind
;
95 int gfc_default_double_kind
;
96 int gfc_default_character_kind
;
97 int gfc_default_logical_kind
;
98 int gfc_default_complex_kind
;
101 /* The kind size used for record offsets. If the target system supports
102 kind=8, this will be set to 8, otherwise it is set to 4. */
105 /* The integer kind used to store character lengths. */
106 int gfc_charlen_int_kind
;
108 /* The size of the numeric storage unit and character storage unit. */
109 int gfc_numeric_storage_size
;
110 int gfc_character_storage_size
;
113 /* Validate that the f90_type of the given gfc_typespec is valid for
114 the type it represents. The f90_type represents the Fortran types
115 this C kind can be used with. For example, c_int has a f90_type of
116 BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
117 if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
121 gfc_validate_c_kind (gfc_typespec
*ts
)
123 return ((ts
->type
== ts
->f90_type
) ? SUCCESS
: FAILURE
);
128 gfc_check_any_c_kind (gfc_typespec
*ts
)
132 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
134 /* Check for any C interoperable kind for the given type/kind in ts.
135 This can be used after verify_c_interop to make sure that the
136 Fortran kind being used exists in at least some form for C. */
137 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
138 c_interop_kinds_table
[i
].value
== ts
->kind
)
147 get_real_kind_from_node (tree type
)
151 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
152 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
153 return gfc_real_kinds
[i
].kind
;
159 get_int_kind_from_node (tree type
)
166 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
167 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
168 return gfc_integer_kinds
[i
].kind
;
174 get_int_kind_from_width (int size
)
178 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
179 if (gfc_integer_kinds
[i
].bit_size
== size
)
180 return gfc_integer_kinds
[i
].kind
;
186 get_int_kind_from_minimal_width (int size
)
190 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
191 if (gfc_integer_kinds
[i
].bit_size
>= size
)
192 return gfc_integer_kinds
[i
].kind
;
198 /* Generate the CInteropKind_t objects for the C interoperable
202 void init_c_interop_kinds (void)
205 tree intmax_type_node
= INT_TYPE_SIZE
== LONG_LONG_TYPE_SIZE
?
207 (LONG_TYPE_SIZE
== LONG_LONG_TYPE_SIZE
?
208 long_integer_type_node
:
209 long_long_integer_type_node
);
211 /* init all pointers in the list to NULL */
212 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
214 /* Initialize the name and value fields. */
215 c_interop_kinds_table
[i
].name
[0] = '\0';
216 c_interop_kinds_table
[i
].value
= -100;
217 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
220 #define NAMED_INTCST(a,b,c) \
221 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
222 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
223 c_interop_kinds_table[a].value = c;
224 #define NAMED_REALCST(a,b,c) \
225 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
226 c_interop_kinds_table[a].f90_type = BT_REAL; \
227 c_interop_kinds_table[a].value = c;
228 #define NAMED_CMPXCST(a,b,c) \
229 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
230 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
231 c_interop_kinds_table[a].value = c;
232 #define NAMED_LOGCST(a,b,c) \
233 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
234 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
235 c_interop_kinds_table[a].value = c;
236 #define NAMED_CHARKNDCST(a,b,c) \
237 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
238 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
239 c_interop_kinds_table[a].value = c;
240 #define NAMED_CHARCST(a,b,c) \
241 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
242 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
243 c_interop_kinds_table[a].value = c;
244 #define DERIVED_TYPE(a,b,c) \
245 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
246 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
247 c_interop_kinds_table[a].value = c;
248 #define PROCEDURE(a,b) \
249 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
250 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
251 c_interop_kinds_table[a].value = 0;
252 #include "iso-c-binding.def"
256 /* Query the target to determine which machine modes are available for
257 computation. Choose KIND numbers for them. */
260 gfc_init_kinds (void)
262 enum machine_mode mode
;
263 int i_index
, r_index
;
264 bool saw_i4
= false, saw_i8
= false;
265 bool saw_r4
= false, saw_r8
= false, saw_r16
= false;
267 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
271 if (!targetm
.scalar_mode_supported_p (mode
))
274 /* The middle end doesn't support constants larger than 2*HWI.
275 Perhaps the target hook shouldn't have accepted these either,
276 but just to be safe... */
277 bitsize
= GET_MODE_BITSIZE (mode
);
278 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
281 gcc_assert (i_index
!= MAX_INT_KINDS
);
283 /* Let the kind equal the bit size divided by 8. This insulates the
284 programmer from the underlying byte size. */
292 gfc_integer_kinds
[i_index
].kind
= kind
;
293 gfc_integer_kinds
[i_index
].radix
= 2;
294 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
295 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
297 gfc_logical_kinds
[i_index
].kind
= kind
;
298 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
303 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
304 used for large file access. */
311 /* If we do not at least have kind = 4, everything is pointless. */
314 /* Set the maximum integer kind. Used with at least BOZ constants. */
315 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
317 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
319 const struct real_format
*fmt
= REAL_MODE_FORMAT (mode
);
324 if (!targetm
.scalar_mode_supported_p (mode
))
327 /* Only let float/double/long double go through because the fortran
328 library assumes these are the only floating point types. */
330 if (mode
!= TYPE_MODE (float_type_node
)
331 && (mode
!= TYPE_MODE (double_type_node
))
332 && (mode
!= TYPE_MODE (long_double_type_node
)))
335 /* Let the kind equal the precision divided by 8, rounding up. Again,
336 this insulates the programmer from the underlying byte size.
338 Also, it effectively deals with IEEE extended formats. There, the
339 total size of the type may equal 16, but it's got 6 bytes of padding
340 and the increased size can get in the way of a real IEEE quad format
341 which may also be supported by the target.
343 We round up so as to handle IA-64 __floatreg (RFmode), which is an
344 82 bit type. Not to be confused with __float80 (XFmode), which is
345 an 80 bit type also supported by IA-64. So XFmode should come out
346 to be kind=10, and RFmode should come out to be kind=11. Egads. */
348 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
357 /* Careful we don't stumble a wierd internal mode. */
358 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
359 /* Or have too many modes for the allocated space. */
360 gcc_assert (r_index
!= MAX_REAL_KINDS
);
362 gfc_real_kinds
[r_index
].kind
= kind
;
363 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
364 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
365 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
366 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
367 if (fmt
->pnan
< fmt
->p
)
368 /* This is an IBM extended double format (or the MIPS variant)
369 made up of two IEEE doubles. The value of the long double is
370 the sum of the values of the two parts. The most significant
371 part is required to be the value of the long double rounded
372 to the nearest double. If we use emax of 1024 then we can't
373 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
374 rounding will make the most significant part overflow. */
375 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
376 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
380 /* Choose the default integer kind. We choose 4 unless the user
381 directs us otherwise. */
382 if (gfc_option
.flag_default_integer
)
385 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
386 gfc_default_integer_kind
= 8;
388 /* Even if the user specified that the default integer kind be 8,
389 the numerica storage size isn't 64. In this case, a warning will
390 be issued when NUMERIC_STORAGE_SIZE is used. */
391 gfc_numeric_storage_size
= 4 * 8;
395 gfc_default_integer_kind
= 4;
396 gfc_numeric_storage_size
= 4 * 8;
400 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
401 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
404 /* Choose the default real kind. Again, we choose 4 when possible. */
405 if (gfc_option
.flag_default_real
)
408 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
409 gfc_default_real_kind
= 8;
412 gfc_default_real_kind
= 4;
414 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
416 /* Choose the default double kind. If -fdefault-real and -fdefault-double
417 are specified, we use kind=8, if it's available. If -fdefault-real is
418 specified without -fdefault-double, we use kind=16, if it's available.
419 Otherwise we do not change anything. */
420 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
421 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
423 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
424 gfc_default_double_kind
= 8;
425 else if (gfc_option
.flag_default_real
&& saw_r16
)
426 gfc_default_double_kind
= 16;
427 else if (saw_r4
&& saw_r8
)
428 gfc_default_double_kind
= 8;
431 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
432 real ... occupies two contiguous numeric storage units.
434 Therefore we must be supplied a kind twice as large as we chose
435 for single precision. There are loopholes, in that double
436 precision must *occupy* two storage units, though it doesn't have
437 to *use* two storage units. Which means that you can make this
438 kind artificially wide by padding it. But at present there are
439 no GCC targets for which a two-word type does not exist, so we
440 just let gfc_validate_kind abort and tell us if something breaks. */
442 gfc_default_double_kind
443 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
446 /* The default logical kind is constrained to be the same as the
447 default integer kind. Similarly with complex and real. */
448 gfc_default_logical_kind
= gfc_default_integer_kind
;
449 gfc_default_complex_kind
= gfc_default_real_kind
;
451 /* Choose the smallest integer kind for our default character. */
452 gfc_default_character_kind
= gfc_integer_kinds
[0].kind
;
453 gfc_character_storage_size
= gfc_default_character_kind
* 8;
455 /* Choose the integer kind the same size as "void*" for our index kind. */
456 gfc_index_integer_kind
= POINTER_SIZE
/ 8;
457 /* Pick a kind the same size as the C "int" type. */
458 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
460 /* initialize the C interoperable kinds */
461 init_c_interop_kinds();
464 /* Make sure that a valid kind is present. Returns an index into the
465 associated kinds array, -1 if the kind is not present. */
468 validate_integer (int kind
)
472 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
473 if (gfc_integer_kinds
[i
].kind
== kind
)
480 validate_real (int kind
)
484 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
485 if (gfc_real_kinds
[i
].kind
== kind
)
492 validate_logical (int kind
)
496 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
497 if (gfc_logical_kinds
[i
].kind
== kind
)
504 validate_character (int kind
)
506 return kind
== gfc_default_character_kind
? 0 : -1;
509 /* Validate a kind given a basic type. The return value is the same
510 for the child functions, with -1 indicating nonexistence of the
511 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
514 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
520 case BT_REAL
: /* Fall through */
522 rc
= validate_real (kind
);
525 rc
= validate_integer (kind
);
528 rc
= validate_logical (kind
);
531 rc
= validate_character (kind
);
535 gfc_internal_error ("gfc_validate_kind(): Got bad type");
538 if (rc
< 0 && !may_fail
)
539 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
545 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
546 Reuse common type nodes where possible. Recognize if the kind matches up
547 with a C type. This will be used later in determining which routines may
548 be scarfed from libm. */
551 gfc_build_int_type (gfc_integer_info
*info
)
553 int mode_precision
= info
->bit_size
;
555 if (mode_precision
== CHAR_TYPE_SIZE
)
557 if (mode_precision
== SHORT_TYPE_SIZE
)
559 if (mode_precision
== INT_TYPE_SIZE
)
561 if (mode_precision
== LONG_TYPE_SIZE
)
563 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
564 info
->c_long_long
= 1;
566 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
567 return intQI_type_node
;
568 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
569 return intHI_type_node
;
570 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
571 return intSI_type_node
;
572 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
573 return intDI_type_node
;
574 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
575 return intTI_type_node
;
577 return make_signed_type (mode_precision
);
581 gfc_build_real_type (gfc_real_info
*info
)
583 int mode_precision
= info
->mode_precision
;
586 if (mode_precision
== FLOAT_TYPE_SIZE
)
588 if (mode_precision
== DOUBLE_TYPE_SIZE
)
590 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
591 info
->c_long_double
= 1;
593 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
594 return float_type_node
;
595 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
596 return double_type_node
;
597 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
598 return long_double_type_node
;
600 new_type
= make_node (REAL_TYPE
);
601 TYPE_PRECISION (new_type
) = mode_precision
;
602 layout_type (new_type
);
607 gfc_build_complex_type (tree scalar_type
)
611 if (scalar_type
== NULL
)
613 if (scalar_type
== float_type_node
)
614 return complex_float_type_node
;
615 if (scalar_type
== double_type_node
)
616 return complex_double_type_node
;
617 if (scalar_type
== long_double_type_node
)
618 return complex_long_double_type_node
;
620 new_type
= make_node (COMPLEX_TYPE
);
621 TREE_TYPE (new_type
) = scalar_type
;
622 layout_type (new_type
);
627 gfc_build_logical_type (gfc_logical_info
*info
)
629 int bit_size
= info
->bit_size
;
632 if (bit_size
== BOOL_TYPE_SIZE
)
635 return boolean_type_node
;
638 new_type
= make_unsigned_type (bit_size
);
639 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
640 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
641 TYPE_PRECISION (new_type
) = 1;
647 /* Return the bit size of the C "size_t". */
653 if (strcmp (SIZE_TYPE
, "unsigned int") == 0)
654 return INT_TYPE_SIZE
;
655 if (strcmp (SIZE_TYPE
, "long unsigned int") == 0)
656 return LONG_TYPE_SIZE
;
657 if (strcmp (SIZE_TYPE
, "short unsigned int") == 0)
658 return SHORT_TYPE_SIZE
;
661 return LONG_TYPE_SIZE
;
666 /* Create the backend type nodes. We map them to their
667 equivalent C type, at least for now. We also give
668 names to the types here, and we push them in the
669 global binding level context.*/
672 gfc_init_types (void)
678 unsigned HOST_WIDE_INT hi
;
679 unsigned HOST_WIDE_INT lo
;
681 /* Create and name the types. */
682 #define PUSH_TYPE(name, node) \
683 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
685 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
687 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
688 gfc_integer_types
[index
] = type
;
689 snprintf (name_buf
, sizeof(name_buf
), "int%d",
690 gfc_integer_kinds
[index
].kind
);
691 PUSH_TYPE (name_buf
, type
);
694 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
696 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
697 gfc_logical_types
[index
] = type
;
698 snprintf (name_buf
, sizeof(name_buf
), "logical%d",
699 gfc_logical_kinds
[index
].kind
);
700 PUSH_TYPE (name_buf
, type
);
703 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
705 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
706 gfc_real_types
[index
] = type
;
707 snprintf (name_buf
, sizeof(name_buf
), "real%d",
708 gfc_real_kinds
[index
].kind
);
709 PUSH_TYPE (name_buf
, type
);
711 type
= gfc_build_complex_type (type
);
712 gfc_complex_types
[index
] = type
;
713 snprintf (name_buf
, sizeof(name_buf
), "complex%d",
714 gfc_real_kinds
[index
].kind
);
715 PUSH_TYPE (name_buf
, type
);
718 gfc_character1_type_node
= build_type_variant (unsigned_char_type_node
,
720 PUSH_TYPE ("char", gfc_character1_type_node
);
722 PUSH_TYPE ("byte", unsigned_char_type_node
);
723 PUSH_TYPE ("void", void_type_node
);
725 /* DBX debugging output gets upset if these aren't set. */
726 if (!TYPE_NAME (integer_type_node
))
727 PUSH_TYPE ("c_integer", integer_type_node
);
728 if (!TYPE_NAME (char_type_node
))
729 PUSH_TYPE ("c_char", char_type_node
);
733 pvoid_type_node
= build_pointer_type (void_type_node
);
734 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
735 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
737 = build_pointer_type (build_function_type (void_type_node
, NULL_TREE
));
739 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
740 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
741 since this function is called before gfc_init_constants. */
743 = build_range_type (gfc_array_index_type
,
744 build_int_cst (gfc_array_index_type
, 0),
747 /* The maximum array element size that can be handled is determined
748 by the number of bits available to store this field in the array
751 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
752 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
753 if (n
> HOST_BITS_PER_WIDE_INT
)
754 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
756 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
757 gfc_max_array_element_size
758 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
760 size_type_node
= gfc_array_index_type
;
762 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
763 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
764 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
766 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
767 gfc_charlen_int_kind
= 4;
768 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
771 /* Get the type node for the given type and kind. */
774 gfc_get_int_type (int kind
)
776 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
777 return index
< 0 ? 0 : gfc_integer_types
[index
];
781 gfc_get_real_type (int kind
)
783 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
784 return index
< 0 ? 0 : gfc_real_types
[index
];
788 gfc_get_complex_type (int kind
)
790 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
791 return index
< 0 ? 0 : gfc_complex_types
[index
];
795 gfc_get_logical_type (int kind
)
797 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
798 return index
< 0 ? 0 : gfc_logical_types
[index
];
801 /* Create a character type with the given kind and length. */
804 gfc_get_character_type_len (int kind
, tree len
)
808 gfc_validate_kind (BT_CHARACTER
, kind
, false);
810 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
811 type
= build_array_type (gfc_character1_type_node
, bounds
);
812 TYPE_STRING_FLAG (type
) = 1;
818 /* Get a type node for a character kind. */
821 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
825 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
827 return gfc_get_character_type_len (kind
, len
);
830 /* Covert a basic type. This will be an array for character types. */
833 gfc_typenode_for_spec (gfc_typespec
* spec
)
843 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
844 has been resolved. This is done so we can convert C_PTR and
845 C_FUNPTR to simple variables that get translated to (void *). */
846 if (spec
->f90_type
== BT_VOID
)
849 && spec
->derived
->intmod_sym_id
== ISOCBINDING_PTR
)
850 basetype
= ptr_type_node
;
852 basetype
= pfunc_type_node
;
855 basetype
= gfc_get_int_type (spec
->kind
);
859 basetype
= gfc_get_real_type (spec
->kind
);
863 basetype
= gfc_get_complex_type (spec
->kind
);
867 basetype
= gfc_get_logical_type (spec
->kind
);
871 basetype
= gfc_get_character_type (spec
->kind
, spec
->cl
);
875 basetype
= gfc_get_derived_type (spec
->derived
);
877 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
878 type and kind to fit a (void *) and the basetype returned was a
879 ptr_type_node. We need to pass up this new information to the
880 symbol that was declared of type C_PTR or C_FUNPTR. */
881 if (spec
->derived
->attr
.is_iso_c
)
883 spec
->type
= spec
->derived
->ts
.type
;
884 spec
->kind
= spec
->derived
->ts
.kind
;
885 spec
->f90_type
= spec
->derived
->ts
.f90_type
;
889 /* This is for the second arg to c_f_pointer and c_f_procpointer
890 of the iso_c_binding module, to accept any ptr type. */
891 basetype
= ptr_type_node
;
892 if (spec
->f90_type
== BT_VOID
)
895 && spec
->derived
->intmod_sym_id
== ISOCBINDING_PTR
)
896 basetype
= ptr_type_node
;
898 basetype
= pfunc_type_node
;
907 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
910 gfc_conv_array_bound (gfc_expr
* expr
)
912 /* If expr is an integer constant, return that. */
913 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
914 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
916 /* Otherwise return NULL. */
921 gfc_get_element_type (tree type
)
925 if (GFC_ARRAY_TYPE_P (type
))
927 if (TREE_CODE (type
) == POINTER_TYPE
)
928 type
= TREE_TYPE (type
);
929 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
930 element
= TREE_TYPE (type
);
934 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
935 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
937 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
938 element
= TREE_TYPE (element
);
940 gcc_assert (TREE_CODE (element
) == ARRAY_TYPE
);
941 element
= TREE_TYPE (element
);
947 /* Build an array. This function is called from gfc_sym_type().
948 Actually returns array descriptor type.
950 Format of array descriptors is as follows:
952 struct gfc_array_descriptor
957 struct descriptor_dimension dimension[N_DIM];
960 struct descriptor_dimension
967 Translation code should use gfc_conv_descriptor_* rather than
968 accessing the descriptor directly. Any changes to the array
969 descriptor type will require changes in gfc_conv_descriptor_* and
970 gfc_build_array_initializer.
972 This is represented internally as a RECORD_TYPE. The index nodes
973 are gfc_array_index_type and the data node is a pointer to the
974 data. See below for the handling of character types.
976 The dtype member is formatted as follows:
977 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
978 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
979 size = dtype >> GFC_DTYPE_SIZE_SHIFT
981 I originally used nested ARRAY_TYPE nodes to represent arrays, but
982 this generated poor code for assumed/deferred size arrays. These
983 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
984 of the GENERIC grammar. Also, there is no way to explicitly set
985 the array stride, so all data must be packed(1). I've tried to
986 mark all the functions which would require modification with a GCC
989 The data component points to the first element in the array. The
990 offset field is the position of the origin of the array (ie element
991 (0, 0 ...)). This may be outsite the bounds of the array.
993 An element is accessed by
994 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
995 This gives good performance as the computation does not involve the
996 bounds of the array. For packed arrays, this is optimized further
997 by substituting the known strides.
999 This system has one problem: all array bounds must be within 2^31
1000 elements of the origin (2^63 on 64-bit machines). For example
1001 integer, dimension (80000:90000, 80000:90000, 2) :: array
1002 may not work properly on 32-bit machines because 80000*80000 >
1003 2^31, so the calculation for stride02 would overflow. This may
1004 still work, but I haven't checked, and it relies on the overflow
1005 doing the right thing.
1007 The way to fix this problem is to access elements as follows:
1008 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1009 Obviously this is much slower. I will make this a compile time
1010 option, something like -fsmall-array-offsets. Mixing code compiled
1011 with and without this switch will work.
1013 (1) This can be worked around by modifying the upper bound of the
1014 previous dimension. This requires extra fields in the descriptor
1015 (both real_ubound and fake_ubound). */
1018 /* Returns true if the array sym does not require a descriptor. */
1021 gfc_is_nodesc_array (gfc_symbol
* sym
)
1023 gcc_assert (sym
->attr
.dimension
);
1025 /* We only want local arrays. */
1026 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1029 if (sym
->attr
.dummy
)
1031 if (sym
->as
->type
!= AS_ASSUMED_SHAPE
)
1037 if (sym
->attr
.result
|| sym
->attr
.function
)
1040 gcc_assert (sym
->as
->type
== AS_EXPLICIT
);
1046 /* Create an array descriptor type. */
1049 gfc_build_array_type (tree type
, gfc_array_spec
* as
)
1051 tree lbound
[GFC_MAX_DIMENSIONS
];
1052 tree ubound
[GFC_MAX_DIMENSIONS
];
1055 for (n
= 0; n
< as
->rank
; n
++)
1057 /* Create expressions for the known bounds of the array. */
1058 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1059 lbound
[n
] = gfc_index_one_node
;
1061 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1062 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1065 return gfc_get_array_type_bounds (type
, as
->rank
, lbound
, ubound
, 0);
1068 /* Returns the struct descriptor_dimension type. */
1071 gfc_get_desc_dim_type (void)
1077 if (gfc_desc_dim_type
)
1078 return gfc_desc_dim_type
;
1080 /* Build the type node. */
1081 type
= make_node (RECORD_TYPE
);
1083 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1084 TYPE_PACKED (type
) = 1;
1086 /* Consists of the stride, lbound and ubound members. */
1087 decl
= build_decl (FIELD_DECL
,
1088 get_identifier ("stride"), gfc_array_index_type
);
1089 DECL_CONTEXT (decl
) = type
;
1092 decl
= build_decl (FIELD_DECL
,
1093 get_identifier ("lbound"), gfc_array_index_type
);
1094 DECL_CONTEXT (decl
) = type
;
1095 fieldlist
= chainon (fieldlist
, decl
);
1097 decl
= build_decl (FIELD_DECL
,
1098 get_identifier ("ubound"), gfc_array_index_type
);
1099 DECL_CONTEXT (decl
) = type
;
1100 fieldlist
= chainon (fieldlist
, decl
);
1102 /* Finish off the type. */
1103 TYPE_FIELDS (type
) = fieldlist
;
1105 gfc_finish_type (type
);
1107 gfc_desc_dim_type
= type
;
1112 /* Return the DTYPE for an array. This describes the type and type parameters
1114 /* TODO: Only call this when the value is actually used, and make all the
1115 unknown cases abort. */
1118 gfc_get_dtype (tree type
)
1128 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1130 if (GFC_TYPE_ARRAY_DTYPE (type
))
1131 return GFC_TYPE_ARRAY_DTYPE (type
);
1133 rank
= GFC_TYPE_ARRAY_RANK (type
);
1134 etype
= gfc_get_element_type (type
);
1136 switch (TREE_CODE (etype
))
1139 n
= GFC_DTYPE_INTEGER
;
1143 n
= GFC_DTYPE_LOGICAL
;
1151 n
= GFC_DTYPE_COMPLEX
;
1154 /* We will never have arrays of arrays. */
1156 n
= GFC_DTYPE_DERIVED
;
1160 n
= GFC_DTYPE_CHARACTER
;
1164 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1165 /* We can strange array types for temporary arrays. */
1166 return gfc_index_zero_node
;
1169 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1170 size
= TYPE_SIZE_UNIT (etype
);
1172 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1173 if (size
&& INTEGER_CST_P (size
))
1175 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1176 internal_error ("Array element size too big");
1178 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1180 dtype
= build_int_cst (gfc_array_index_type
, i
);
1182 if (size
&& !INTEGER_CST_P (size
))
1184 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1185 tmp
= fold_build2 (LSHIFT_EXPR
, gfc_array_index_type
,
1186 fold_convert (gfc_array_index_type
, size
), tmp
);
1187 dtype
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, dtype
);
1189 /* If we don't know the size we leave it as zero. This should never happen
1190 for anything that is actually used. */
1191 /* TODO: Check this is actually true, particularly when repacking
1192 assumed size parameters. */
1194 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1199 /* Build an array type for use without a descriptor, packed according
1200 to the value of PACKED. */
1203 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
)
1216 mpz_init_set_ui (offset
, 0);
1217 mpz_init_set_ui (stride
, 1);
1220 /* We don't use build_array_type because this does not include include
1221 lang-specific information (i.e. the bounds of the array) when checking
1223 type
= make_node (ARRAY_TYPE
);
1225 GFC_ARRAY_TYPE_P (type
) = 1;
1226 TYPE_LANG_SPECIFIC (type
) = (struct lang_type
*)
1227 ggc_alloc_cleared (sizeof (struct lang_type
));
1229 known_stride
= (packed
!= PACKED_NO
);
1231 for (n
= 0; n
< as
->rank
; n
++)
1233 /* Fill in the stride and bound components of the type. */
1235 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1238 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1240 expr
= as
->lower
[n
];
1241 if (expr
->expr_type
== EXPR_CONSTANT
)
1243 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1244 gfc_index_integer_kind
);
1251 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1255 /* Calculate the offset. */
1256 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1257 mpz_sub (offset
, offset
, delta
);
1262 expr
= as
->upper
[n
];
1263 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1265 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1266 gfc_index_integer_kind
);
1273 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1277 /* Calculate the stride. */
1278 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1279 as
->lower
[n
]->value
.integer
);
1280 mpz_add_ui (delta
, delta
, 1);
1281 mpz_mul (stride
, stride
, delta
);
1284 /* Only the first stride is known for partial packed arrays. */
1285 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1291 GFC_TYPE_ARRAY_OFFSET (type
) =
1292 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1295 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1299 GFC_TYPE_ARRAY_SIZE (type
) =
1300 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1303 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1305 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1306 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1307 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1309 /* TODO: use main type if it is unbounded. */
1310 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1311 build_pointer_type (build_array_type (etype
, range
));
1315 mpz_sub_ui (stride
, stride
, 1);
1316 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1321 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1322 TYPE_DOMAIN (type
) = range
;
1324 build_pointer_type (etype
);
1325 TREE_TYPE (type
) = etype
;
1333 if (packed
!= PACKED_STATIC
|| !known_stride
)
1335 /* For dummy arrays and automatic (heap allocated) arrays we
1336 want a pointer to the array. */
1337 type
= build_pointer_type (type
);
1338 GFC_ARRAY_TYPE_P (type
) = 1;
1339 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1344 /* Return or create the base type for an array descriptor. */
1347 gfc_get_array_descriptor_base (int dimen
)
1349 tree fat_type
, fieldlist
, decl
, arraytype
;
1350 char name
[16 + GFC_RANK_DIGITS
+ 1];
1352 gcc_assert (dimen
>= 1 && dimen
<= GFC_MAX_DIMENSIONS
);
1353 if (gfc_array_descriptor_base
[dimen
- 1])
1354 return gfc_array_descriptor_base
[dimen
- 1];
1356 /* Build the type node. */
1357 fat_type
= make_node (RECORD_TYPE
);
1359 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
);
1360 TYPE_NAME (fat_type
) = get_identifier (name
);
1362 /* Add the data member as the first element of the descriptor. */
1363 decl
= build_decl (FIELD_DECL
, get_identifier ("data"), ptr_type_node
);
1365 DECL_CONTEXT (decl
) = fat_type
;
1368 /* Add the base component. */
1369 decl
= build_decl (FIELD_DECL
, get_identifier ("offset"),
1370 gfc_array_index_type
);
1371 DECL_CONTEXT (decl
) = fat_type
;
1372 fieldlist
= chainon (fieldlist
, decl
);
1374 /* Add the dtype component. */
1375 decl
= build_decl (FIELD_DECL
, get_identifier ("dtype"),
1376 gfc_array_index_type
);
1377 DECL_CONTEXT (decl
) = fat_type
;
1378 fieldlist
= chainon (fieldlist
, decl
);
1380 /* Build the array type for the stride and bound components. */
1382 build_array_type (gfc_get_desc_dim_type (),
1383 build_range_type (gfc_array_index_type
,
1384 gfc_index_zero_node
,
1385 gfc_rank_cst
[dimen
- 1]));
1387 decl
= build_decl (FIELD_DECL
, get_identifier ("dim"), arraytype
);
1388 DECL_CONTEXT (decl
) = fat_type
;
1389 fieldlist
= chainon (fieldlist
, decl
);
1391 /* Finish off the type. */
1392 TYPE_FIELDS (fat_type
) = fieldlist
;
1394 gfc_finish_type (fat_type
);
1396 gfc_array_descriptor_base
[dimen
- 1] = fat_type
;
1400 /* Build an array (descriptor) type with given bounds. */
1403 gfc_get_array_type_bounds (tree etype
, int dimen
, tree
* lbound
,
1404 tree
* ubound
, int packed
)
1406 char name
[8 + GFC_RANK_DIGITS
+ GFC_MAX_SYMBOL_LEN
];
1407 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
;
1408 const char *typename
;
1411 base_type
= gfc_get_array_descriptor_base (dimen
);
1412 fat_type
= build_variant_type_copy (base_type
);
1414 tmp
= TYPE_NAME (etype
);
1415 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1416 tmp
= DECL_NAME (tmp
);
1418 typename
= IDENTIFIER_POINTER (tmp
);
1420 typename
= "unknown";
1421 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
,
1422 GFC_MAX_SYMBOL_LEN
, typename
);
1423 TYPE_NAME (fat_type
) = get_identifier (name
);
1425 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1426 TYPE_LANG_SPECIFIC (fat_type
) = (struct lang_type
*)
1427 ggc_alloc_cleared (sizeof (struct lang_type
));
1429 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1430 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1432 /* Build an array descriptor record type. */
1434 stride
= gfc_index_one_node
;
1437 for (n
= 0; n
< dimen
; n
++)
1439 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1446 if (lower
!= NULL_TREE
)
1448 if (INTEGER_CST_P (lower
))
1449 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1455 if (upper
!= NULL_TREE
)
1457 if (INTEGER_CST_P (upper
))
1458 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1463 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1465 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
1466 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
1467 gfc_index_one_node
);
1469 fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, stride
);
1470 /* Check the folding worked. */
1471 gcc_assert (INTEGER_CST_P (stride
));
1476 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1478 /* TODO: known offsets for descriptors. */
1479 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1481 /* We define data as an unknown size array. Much better than doing
1482 pointer arithmetic. */
1484 build_array_type (etype
, gfc_array_range_type
);
1485 arraytype
= build_pointer_type (arraytype
);
1486 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1491 /* Build a pointer type. This function is called from gfc_sym_type(). */
1494 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1496 /* Array pointer types aren't actually pointers. */
1497 if (sym
->attr
.dimension
)
1500 return build_pointer_type (type
);
1503 /* Return the type for a symbol. Special handling is required for character
1504 types to get the correct level of indirection.
1505 For functions return the return type.
1506 For subroutines return void_type_node.
1507 Calling this multiple times for the same symbol should be avoided,
1508 especially for character and array types. */
1511 gfc_sym_type (gfc_symbol
* sym
)
1516 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
1517 return void_type_node
;
1519 /* In the case of a function the fake result variable may have a
1520 type different from the function type, so don't return early in
1522 if (sym
->backend_decl
&& !sym
->attr
.function
)
1523 return TREE_TYPE (sym
->backend_decl
);
1525 type
= gfc_typenode_for_spec (&sym
->ts
);
1527 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
1532 if (sym
->attr
.dimension
)
1534 if (gfc_is_nodesc_array (sym
))
1536 /* If this is a character argument of unknown length, just use the
1538 if (sym
->ts
.type
!= BT_CHARACTER
1539 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
1540 || sym
->ts
.cl
->backend_decl
)
1542 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
1550 type
= gfc_build_array_type (type
, sym
->as
);
1555 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1556 type
= gfc_build_pointer_type (sym
, type
);
1557 if (sym
->attr
.pointer
)
1558 GFC_POINTER_TYPE_P (type
) = 1;
1561 /* We currently pass all parameters by reference.
1562 See f95_get_function_decl. For dummy function parameters return the
1566 /* We must use pointer types for potentially absent variables. The
1567 optimizers assume a reference type argument is never NULL. */
1568 if (sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
)
1569 type
= build_pointer_type (type
);
1571 type
= build_reference_type (type
);
1577 /* Layout and output debug info for a record type. */
1580 gfc_finish_type (tree type
)
1584 decl
= build_decl (TYPE_DECL
, NULL_TREE
, type
);
1585 TYPE_STUB_DECL (type
) = decl
;
1587 rest_of_type_compilation (type
, 1);
1588 rest_of_decl_compilation (decl
, 1, 0);
1591 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1592 or RECORD_TYPE pointed to by STYPE. The new field is chained
1593 to the fieldlist pointed to by FIELDLIST.
1595 Returns a pointer to the new field. */
1598 gfc_add_field_to_struct (tree
*fieldlist
, tree context
,
1599 tree name
, tree type
)
1603 decl
= build_decl (FIELD_DECL
, name
, type
);
1605 DECL_CONTEXT (decl
) = context
;
1606 DECL_INITIAL (decl
) = 0;
1607 DECL_ALIGN (decl
) = 0;
1608 DECL_USER_ALIGN (decl
) = 0;
1609 TREE_CHAIN (decl
) = NULL_TREE
;
1610 *fieldlist
= chainon (*fieldlist
, decl
);
1616 /* Copy the backend_decl and component backend_decls if
1617 the two derived type symbols are "equal", as described
1618 in 4.4.2 and resolved by gfc_compare_derived_types. */
1621 copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
)
1623 gfc_component
*to_cm
;
1624 gfc_component
*from_cm
;
1626 if (from
->backend_decl
== NULL
1627 || !gfc_compare_derived_types (from
, to
))
1630 to
->backend_decl
= from
->backend_decl
;
1632 to_cm
= to
->components
;
1633 from_cm
= from
->components
;
1635 /* Copy the component declarations. If a component is itself
1636 a derived type, we need a copy of its component declarations.
1637 This is done by recursing into gfc_get_derived_type and
1638 ensures that the component's component declarations have
1639 been built. If it is a character, we need the character
1641 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
1643 to_cm
->backend_decl
= from_cm
->backend_decl
;
1644 if (!from_cm
->pointer
&& from_cm
->ts
.type
== BT_DERIVED
)
1645 gfc_get_derived_type (to_cm
->ts
.derived
);
1647 else if (from_cm
->ts
.type
== BT_CHARACTER
)
1648 to_cm
->ts
.cl
->backend_decl
= from_cm
->ts
.cl
->backend_decl
;
1655 /* Build a tree node for a derived type. If there are equal
1656 derived types, with different local names, these are built
1657 at the same time. If an equal derived type has been built
1658 in a parent namespace, this is used. */
1661 gfc_get_derived_type (gfc_symbol
* derived
)
1663 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
, fieldlist
= NULL
;
1667 gcc_assert (derived
&& derived
->attr
.flavor
== FL_DERIVED
);
1669 /* See if it's one of the iso_c_binding derived types. */
1670 if (derived
->attr
.is_iso_c
== 1)
1672 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1673 derived
->backend_decl
= ptr_type_node
;
1675 derived
->backend_decl
= pfunc_type_node
;
1676 derived
->ts
.kind
= gfc_index_integer_kind
;
1677 derived
->ts
.type
= BT_INTEGER
;
1678 /* Set the f90_type to BT_VOID as a way to recognize something of type
1679 BT_INTEGER that needs to fit a void * for the purpose of the
1680 iso_c_binding derived types. */
1681 derived
->ts
.f90_type
= BT_VOID
;
1682 return derived
->backend_decl
;
1685 /* derived->backend_decl != 0 means we saw it before, but its
1686 components' backend_decl may have not been built. */
1687 if (derived
->backend_decl
)
1689 /* Its components' backend_decl have been built. */
1690 if (TYPE_FIELDS (derived
->backend_decl
))
1691 return derived
->backend_decl
;
1693 typenode
= derived
->backend_decl
;
1698 /* We see this derived type first time, so build the type node. */
1699 typenode
= make_node (RECORD_TYPE
);
1700 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
1701 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
1702 derived
->backend_decl
= typenode
;
1705 /* Go through the derived type components, building them as
1706 necessary. The reason for doing this now is that it is
1707 possible to recurse back to this derived type through a
1708 pointer component (PR24092). If this happens, the fields
1709 will be built and so we can return the type. */
1710 for (c
= derived
->components
; c
; c
= c
->next
)
1712 if (c
->ts
.type
!= BT_DERIVED
)
1715 if (!c
->pointer
|| c
->ts
.derived
->backend_decl
== NULL
)
1716 c
->ts
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.derived
);
1718 if (c
->ts
.derived
&& c
->ts
.derived
->attr
.is_iso_c
)
1720 /* Need to copy the modified ts from the derived type. The
1721 typespec was modified because C_PTR/C_FUNPTR are translated
1722 into (void *) from derived types. */
1723 c
->ts
.type
= c
->ts
.derived
->ts
.type
;
1724 c
->ts
.kind
= c
->ts
.derived
->ts
.kind
;
1725 c
->ts
.f90_type
= c
->ts
.derived
->ts
.f90_type
;
1729 if (TYPE_FIELDS (derived
->backend_decl
))
1730 return derived
->backend_decl
;
1732 /* Build the type member list. Install the newly created RECORD_TYPE
1733 node as DECL_CONTEXT of each FIELD_DECL. */
1734 fieldlist
= NULL_TREE
;
1735 for (c
= derived
->components
; c
; c
= c
->next
)
1737 if (c
->ts
.type
== BT_DERIVED
)
1738 field_type
= c
->ts
.derived
->backend_decl
;
1741 if (c
->ts
.type
== BT_CHARACTER
)
1743 /* Evaluate the string length. */
1744 gfc_conv_const_charlen (c
->ts
.cl
);
1745 gcc_assert (c
->ts
.cl
->backend_decl
);
1748 field_type
= gfc_typenode_for_spec (&c
->ts
);
1751 /* This returns an array descriptor type. Initialization may be
1755 if (c
->pointer
|| c
->allocatable
)
1757 /* Pointers to arrays aren't actually pointer types. The
1758 descriptors are separate, but the data is common. */
1759 field_type
= gfc_build_array_type (field_type
, c
->as
);
1762 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
1765 else if (c
->pointer
)
1766 field_type
= build_pointer_type (field_type
);
1768 field
= gfc_add_field_to_struct (&fieldlist
, typenode
,
1769 get_identifier (c
->name
),
1772 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
1775 if (!c
->backend_decl
)
1776 c
->backend_decl
= field
;
1779 /* Now we have the final fieldlist. Record it, then lay out the
1780 derived type, including the fields. */
1781 TYPE_FIELDS (typenode
) = fieldlist
;
1783 gfc_finish_type (typenode
);
1785 derived
->backend_decl
= typenode
;
1787 /* Add this backend_decl to all the other, equal derived types. */
1788 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
1789 copy_dt_decls_ifequal (derived
, dt
->derived
);
1791 return derived
->backend_decl
;
1796 gfc_return_by_reference (gfc_symbol
* sym
)
1798 if (!sym
->attr
.function
)
1801 if (sym
->attr
.dimension
)
1804 if (sym
->ts
.type
== BT_CHARACTER
)
1807 /* Possibly return complex numbers by reference for g77 compatibility.
1808 We don't do this for calls to intrinsics (as the library uses the
1809 -fno-f2c calling convention), nor for calls to functions which always
1810 require an explicit interface, as no compatibility problems can
1812 if (gfc_option
.flag_f2c
1813 && sym
->ts
.type
== BT_COMPLEX
1814 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
1821 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
1826 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1827 gfc_entry_list
*el
, *el2
;
1829 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
1830 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
1832 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
1834 /* Build the type node. */
1835 type
= make_node (UNION_TYPE
);
1837 TYPE_NAME (type
) = get_identifier (name
);
1840 for (el
= ns
->entries
; el
; el
= el
->next
)
1842 /* Search for duplicates. */
1843 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
1844 if (el2
->sym
->result
== el
->sym
->result
)
1849 decl
= build_decl (FIELD_DECL
,
1850 get_identifier (el
->sym
->result
->name
),
1851 gfc_sym_type (el
->sym
->result
));
1852 DECL_CONTEXT (decl
) = type
;
1853 fieldlist
= chainon (fieldlist
, decl
);
1857 /* Finish off the type. */
1858 TYPE_FIELDS (type
) = fieldlist
;
1860 gfc_finish_type (type
);
1865 gfc_get_function_type (gfc_symbol
* sym
)
1869 gfc_formal_arglist
*f
;
1872 int alternate_return
;
1874 /* Make sure this symbol is a function or a subroutine. */
1875 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1877 if (sym
->backend_decl
)
1878 return TREE_TYPE (sym
->backend_decl
);
1881 alternate_return
= 0;
1882 typelist
= NULL_TREE
;
1884 if (sym
->attr
.entry_master
)
1886 /* Additional parameter for selecting an entry point. */
1887 typelist
= gfc_chainon_list (typelist
, gfc_array_index_type
);
1890 /* Some functions we use an extra parameter for the return value. */
1891 if (gfc_return_by_reference (sym
))
1898 if (arg
->ts
.type
== BT_CHARACTER
)
1899 gfc_conv_const_charlen (arg
->ts
.cl
);
1901 type
= gfc_sym_type (arg
);
1902 if (arg
->ts
.type
== BT_COMPLEX
1903 || arg
->attr
.dimension
1904 || arg
->ts
.type
== BT_CHARACTER
)
1905 type
= build_reference_type (type
);
1907 typelist
= gfc_chainon_list (typelist
, type
);
1908 if (arg
->ts
.type
== BT_CHARACTER
)
1909 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
1912 /* Build the argument types for the function. */
1913 for (f
= sym
->formal
; f
; f
= f
->next
)
1918 /* Evaluate constant character lengths here so that they can be
1919 included in the type. */
1920 if (arg
->ts
.type
== BT_CHARACTER
)
1921 gfc_conv_const_charlen (arg
->ts
.cl
);
1923 if (arg
->attr
.flavor
== FL_PROCEDURE
)
1925 type
= gfc_get_function_type (arg
);
1926 type
= build_pointer_type (type
);
1929 type
= gfc_sym_type (arg
);
1931 /* Parameter Passing Convention
1933 We currently pass all parameters by reference.
1934 Parameters with INTENT(IN) could be passed by value.
1935 The problem arises if a function is called via an implicit
1936 prototype. In this situation the INTENT is not known.
1937 For this reason all parameters to global functions must be
1938 passed by reference. Passing by value would potentially
1939 generate bad code. Worse there would be no way of telling that
1940 this code was bad, except that it would give incorrect results.
1942 Contained procedures could pass by value as these are never
1943 used without an explicit interface, and cannot be passed as
1944 actual parameters for a dummy procedure. */
1945 if (arg
->ts
.type
== BT_CHARACTER
)
1947 typelist
= gfc_chainon_list (typelist
, type
);
1951 if (sym
->attr
.subroutine
)
1952 alternate_return
= 1;
1956 /* Add hidden string length parameters. */
1958 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
1961 typelist
= gfc_chainon_list (typelist
, void_type_node
);
1963 if (alternate_return
)
1964 type
= integer_type_node
;
1965 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
1966 type
= void_type_node
;
1967 else if (sym
->attr
.mixed_entry_master
)
1968 type
= gfc_get_mixed_entry_union (sym
->ns
);
1969 else if (gfc_option
.flag_f2c
1970 && sym
->ts
.type
== BT_REAL
1971 && sym
->ts
.kind
== gfc_default_real_kind
1972 && !sym
->attr
.always_explicit
)
1974 /* Special case: f2c calling conventions require that (scalar)
1975 default REAL functions return the C type double instead. f2c
1976 compatibility is only an issue with functions that don't
1977 require an explicit interface, as only these could be
1978 implemented in Fortran 77. */
1979 sym
->ts
.kind
= gfc_default_double_kind
;
1980 type
= gfc_typenode_for_spec (&sym
->ts
);
1981 sym
->ts
.kind
= gfc_default_real_kind
;
1984 type
= gfc_sym_type (sym
);
1986 type
= build_function_type (type
, typelist
);
1991 /* Language hooks for middle-end access to type nodes. */
1993 /* Return an integer type with BITS bits of precision,
1994 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1997 gfc_type_for_size (unsigned bits
, int unsignedp
)
2002 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
2004 tree type
= gfc_integer_types
[i
];
2005 if (type
&& bits
== TYPE_PRECISION (type
))
2009 /* Handle TImode as a special case because it is used by some backends
2010 (eg. ARM) even though it is not available for normal use. */
2011 #if HOST_BITS_PER_WIDE_INT >= 64
2012 if (bits
== TYPE_PRECISION (intTI_type_node
))
2013 return intTI_type_node
;
2018 if (bits
== TYPE_PRECISION (unsigned_intQI_type_node
))
2019 return unsigned_intQI_type_node
;
2020 if (bits
== TYPE_PRECISION (unsigned_intHI_type_node
))
2021 return unsigned_intHI_type_node
;
2022 if (bits
== TYPE_PRECISION (unsigned_intSI_type_node
))
2023 return unsigned_intSI_type_node
;
2024 if (bits
== TYPE_PRECISION (unsigned_intDI_type_node
))
2025 return unsigned_intDI_type_node
;
2026 if (bits
== TYPE_PRECISION (unsigned_intTI_type_node
))
2027 return unsigned_intTI_type_node
;
2033 /* Return a data type that has machine mode MODE. If the mode is an
2034 integer, then UNSIGNEDP selects between signed and unsigned types. */
2037 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
2042 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
2043 base
= gfc_real_types
;
2044 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
2045 base
= gfc_complex_types
;
2046 else if (SCALAR_INT_MODE_P (mode
))
2047 return gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
2048 else if (VECTOR_MODE_P (mode
))
2050 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
2051 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
2052 if (inner_type
!= NULL_TREE
)
2053 return build_vector_type_for_mode (inner_type
, mode
);
2059 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
2061 tree type
= base
[i
];
2062 if (type
&& mode
== TYPE_MODE (type
))
2069 #include "gt-fortran-trans-types.h"