1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
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"
40 #include "dwarf2out.h"
43 #if (GFC_MAX_DIMENSIONS < 10)
44 #define GFC_RANK_DIGITS 1
45 #define GFC_RANK_PRINTF_FORMAT "%01d"
46 #elif (GFC_MAX_DIMENSIONS < 100)
47 #define GFC_RANK_DIGITS 2
48 #define GFC_RANK_PRINTF_FORMAT "%02d"
50 #error If you really need >99 dimensions, continue the sequence above...
53 /* array of structs so we don't have to worry about xmalloc or free */
54 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
56 static tree
gfc_get_derived_type (gfc_symbol
* derived
);
58 tree gfc_array_index_type
;
59 tree gfc_array_range_type
;
60 tree gfc_character1_type_node
;
62 tree ppvoid_type_node
;
66 tree gfc_charlen_type_node
;
68 static GTY(()) tree gfc_desc_dim_type
;
69 static GTY(()) tree gfc_max_array_element_size
;
70 static GTY(()) tree gfc_array_descriptor_base
[GFC_MAX_DIMENSIONS
];
72 /* Arrays for all integral and real kinds. We'll fill this in at runtime
73 after the target has a chance to process command-line options. */
75 #define MAX_INT_KINDS 5
76 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
77 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
78 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
79 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
81 #define MAX_REAL_KINDS 5
82 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
83 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
84 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
86 #define MAX_CHARACTER_KINDS 2
87 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
88 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
89 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
92 /* The integer kind to use for array indices. This will be set to the
93 proper value based on target information from the backend. */
95 int gfc_index_integer_kind
;
97 /* The default kinds of the various types. */
99 int gfc_default_integer_kind
;
100 int gfc_max_integer_kind
;
101 int gfc_default_real_kind
;
102 int gfc_default_double_kind
;
103 int gfc_default_character_kind
;
104 int gfc_default_logical_kind
;
105 int gfc_default_complex_kind
;
108 /* The kind size used for record offsets. If the target system supports
109 kind=8, this will be set to 8, otherwise it is set to 4. */
112 /* The integer kind used to store character lengths. */
113 int gfc_charlen_int_kind
;
115 /* The size of the numeric storage unit and character storage unit. */
116 int gfc_numeric_storage_size
;
117 int gfc_character_storage_size
;
121 gfc_check_any_c_kind (gfc_typespec
*ts
)
125 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
127 /* Check for any C interoperable kind for the given type/kind in ts.
128 This can be used after verify_c_interop to make sure that the
129 Fortran kind being used exists in at least some form for C. */
130 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
131 c_interop_kinds_table
[i
].value
== ts
->kind
)
140 get_real_kind_from_node (tree type
)
144 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
145 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
146 return gfc_real_kinds
[i
].kind
;
152 get_int_kind_from_node (tree type
)
159 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
160 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
161 return gfc_integer_kinds
[i
].kind
;
166 /* Return a typenode for the "standard" C type with a given name. */
168 get_typenode_from_name (const char *name
)
170 if (name
== NULL
|| *name
== '\0')
173 if (strcmp (name
, "char") == 0)
174 return char_type_node
;
175 if (strcmp (name
, "unsigned char") == 0)
176 return unsigned_char_type_node
;
177 if (strcmp (name
, "signed char") == 0)
178 return signed_char_type_node
;
180 if (strcmp (name
, "short int") == 0)
181 return short_integer_type_node
;
182 if (strcmp (name
, "short unsigned int") == 0)
183 return short_unsigned_type_node
;
185 if (strcmp (name
, "int") == 0)
186 return integer_type_node
;
187 if (strcmp (name
, "unsigned int") == 0)
188 return unsigned_type_node
;
190 if (strcmp (name
, "long int") == 0)
191 return long_integer_type_node
;
192 if (strcmp (name
, "long unsigned int") == 0)
193 return long_unsigned_type_node
;
195 if (strcmp (name
, "long long int") == 0)
196 return long_long_integer_type_node
;
197 if (strcmp (name
, "long long unsigned int") == 0)
198 return long_long_unsigned_type_node
;
204 get_int_kind_from_name (const char *name
)
206 return get_int_kind_from_node (get_typenode_from_name (name
));
210 /* Get the kind number corresponding to an integer of given size,
211 following the required return values for ISO_FORTRAN_ENV INT* constants:
212 -2 is returned if we support a kind of larger size, -1 otherwise. */
214 gfc_get_int_kind_from_width_isofortranenv (int size
)
218 /* Look for a kind with matching storage size. */
219 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
220 if (gfc_integer_kinds
[i
].bit_size
== size
)
221 return gfc_integer_kinds
[i
].kind
;
223 /* Look for a kind with larger storage size. */
224 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
225 if (gfc_integer_kinds
[i
].bit_size
> size
)
231 /* Get the kind number corresponding to a real of given storage size,
232 following the required return values for ISO_FORTRAN_ENV REAL* constants:
233 -2 is returned if we support a kind of larger size, -1 otherwise. */
235 gfc_get_real_kind_from_width_isofortranenv (int size
)
241 /* Look for a kind with matching storage size. */
242 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
243 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
244 return gfc_real_kinds
[i
].kind
;
246 /* Look for a kind with larger storage size. */
247 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
248 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
257 get_int_kind_from_width (int size
)
261 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
262 if (gfc_integer_kinds
[i
].bit_size
== size
)
263 return gfc_integer_kinds
[i
].kind
;
269 get_int_kind_from_minimal_width (int size
)
273 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
274 if (gfc_integer_kinds
[i
].bit_size
>= size
)
275 return gfc_integer_kinds
[i
].kind
;
281 /* Generate the CInteropKind_t objects for the C interoperable
285 void init_c_interop_kinds (void)
288 tree intmax_type_node
= INT_TYPE_SIZE
== LONG_LONG_TYPE_SIZE
?
290 (LONG_TYPE_SIZE
== LONG_LONG_TYPE_SIZE
?
291 long_integer_type_node
:
292 long_long_integer_type_node
);
294 /* init all pointers in the list to NULL */
295 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
297 /* Initialize the name and value fields. */
298 c_interop_kinds_table
[i
].name
[0] = '\0';
299 c_interop_kinds_table
[i
].value
= -100;
300 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
303 #define NAMED_INTCST(a,b,c,d) \
304 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
305 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
306 c_interop_kinds_table[a].value = c;
307 #define NAMED_REALCST(a,b,c) \
308 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
309 c_interop_kinds_table[a].f90_type = BT_REAL; \
310 c_interop_kinds_table[a].value = c;
311 #define NAMED_CMPXCST(a,b,c) \
312 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
313 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
314 c_interop_kinds_table[a].value = c;
315 #define NAMED_LOGCST(a,b,c) \
316 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
317 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
318 c_interop_kinds_table[a].value = c;
319 #define NAMED_CHARKNDCST(a,b,c) \
320 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
321 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
322 c_interop_kinds_table[a].value = c;
323 #define NAMED_CHARCST(a,b,c) \
324 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
325 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
326 c_interop_kinds_table[a].value = c;
327 #define DERIVED_TYPE(a,b,c) \
328 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
329 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
330 c_interop_kinds_table[a].value = c;
331 #define PROCEDURE(a,b) \
332 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
333 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
334 c_interop_kinds_table[a].value = 0;
335 #include "iso-c-binding.def"
339 /* Query the target to determine which machine modes are available for
340 computation. Choose KIND numbers for them. */
343 gfc_init_kinds (void)
346 int i_index
, r_index
, kind
;
347 bool saw_i4
= false, saw_i8
= false;
348 bool saw_r4
= false, saw_r8
= false, saw_r16
= false;
350 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
354 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
357 /* The middle end doesn't support constants larger than 2*HWI.
358 Perhaps the target hook shouldn't have accepted these either,
359 but just to be safe... */
360 bitsize
= GET_MODE_BITSIZE (mode
);
361 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
364 gcc_assert (i_index
!= MAX_INT_KINDS
);
366 /* Let the kind equal the bit size divided by 8. This insulates the
367 programmer from the underlying byte size. */
375 gfc_integer_kinds
[i_index
].kind
= kind
;
376 gfc_integer_kinds
[i_index
].radix
= 2;
377 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
378 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
380 gfc_logical_kinds
[i_index
].kind
= kind
;
381 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
386 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
387 used for large file access. */
394 /* If we do not at least have kind = 4, everything is pointless. */
397 /* Set the maximum integer kind. Used with at least BOZ constants. */
398 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
400 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
402 const struct real_format
*fmt
=
403 REAL_MODE_FORMAT ((enum machine_mode
) mode
);
408 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
411 /* Only let float/double/long double go through because the fortran
412 library assumes these are the only floating point types. */
414 if (mode
!= TYPE_MODE (float_type_node
)
415 && (mode
!= TYPE_MODE (double_type_node
))
416 && (mode
!= TYPE_MODE (long_double_type_node
)))
419 /* Let the kind equal the precision divided by 8, rounding up. Again,
420 this insulates the programmer from the underlying byte size.
422 Also, it effectively deals with IEEE extended formats. There, the
423 total size of the type may equal 16, but it's got 6 bytes of padding
424 and the increased size can get in the way of a real IEEE quad format
425 which may also be supported by the target.
427 We round up so as to handle IA-64 __floatreg (RFmode), which is an
428 82 bit type. Not to be confused with __float80 (XFmode), which is
429 an 80 bit type also supported by IA-64. So XFmode should come out
430 to be kind=10, and RFmode should come out to be kind=11. Egads. */
432 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
441 /* Careful we don't stumble a weird internal mode. */
442 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
443 /* Or have too many modes for the allocated space. */
444 gcc_assert (r_index
!= MAX_REAL_KINDS
);
446 gfc_real_kinds
[r_index
].kind
= kind
;
447 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
448 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
449 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
450 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
451 if (fmt
->pnan
< fmt
->p
)
452 /* This is an IBM extended double format (or the MIPS variant)
453 made up of two IEEE doubles. The value of the long double is
454 the sum of the values of the two parts. The most significant
455 part is required to be the value of the long double rounded
456 to the nearest double. If we use emax of 1024 then we can't
457 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
458 rounding will make the most significant part overflow. */
459 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
460 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
464 /* Choose the default integer kind. We choose 4 unless the user
465 directs us otherwise. */
466 if (gfc_option
.flag_default_integer
)
469 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
470 gfc_default_integer_kind
= 8;
472 /* Even if the user specified that the default integer kind be 8,
473 the numeric storage size isn't 64. In this case, a warning will
474 be issued when NUMERIC_STORAGE_SIZE is used. */
475 gfc_numeric_storage_size
= 4 * 8;
479 gfc_default_integer_kind
= 4;
480 gfc_numeric_storage_size
= 4 * 8;
484 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
485 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
488 /* Choose the default real kind. Again, we choose 4 when possible. */
489 if (gfc_option
.flag_default_real
)
492 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
493 gfc_default_real_kind
= 8;
496 gfc_default_real_kind
= 4;
498 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
500 /* Choose the default double kind. If -fdefault-real and -fdefault-double
501 are specified, we use kind=8, if it's available. If -fdefault-real is
502 specified without -fdefault-double, we use kind=16, if it's available.
503 Otherwise we do not change anything. */
504 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
505 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
507 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
508 gfc_default_double_kind
= 8;
509 else if (gfc_option
.flag_default_real
&& saw_r16
)
510 gfc_default_double_kind
= 16;
511 else if (saw_r4
&& saw_r8
)
512 gfc_default_double_kind
= 8;
515 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
516 real ... occupies two contiguous numeric storage units.
518 Therefore we must be supplied a kind twice as large as we chose
519 for single precision. There are loopholes, in that double
520 precision must *occupy* two storage units, though it doesn't have
521 to *use* two storage units. Which means that you can make this
522 kind artificially wide by padding it. But at present there are
523 no GCC targets for which a two-word type does not exist, so we
524 just let gfc_validate_kind abort and tell us if something breaks. */
526 gfc_default_double_kind
527 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
530 /* The default logical kind is constrained to be the same as the
531 default integer kind. Similarly with complex and real. */
532 gfc_default_logical_kind
= gfc_default_integer_kind
;
533 gfc_default_complex_kind
= gfc_default_real_kind
;
535 /* We only have two character kinds: ASCII and UCS-4.
536 ASCII corresponds to a 8-bit integer type, if one is available.
537 UCS-4 corresponds to a 32-bit integer type, if one is available. */
539 if ((kind
= get_int_kind_from_width (8)) > 0)
541 gfc_character_kinds
[i_index
].kind
= kind
;
542 gfc_character_kinds
[i_index
].bit_size
= 8;
543 gfc_character_kinds
[i_index
].name
= "ascii";
546 if ((kind
= get_int_kind_from_width (32)) > 0)
548 gfc_character_kinds
[i_index
].kind
= kind
;
549 gfc_character_kinds
[i_index
].bit_size
= 32;
550 gfc_character_kinds
[i_index
].name
= "iso_10646";
554 /* Choose the smallest integer kind for our default character. */
555 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
556 gfc_character_storage_size
= gfc_default_character_kind
* 8;
558 /* Choose the integer kind the same size as "void*" for our index kind. */
559 gfc_index_integer_kind
= POINTER_SIZE
/ 8;
560 /* Pick a kind the same size as the C "int" type. */
561 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
563 /* initialize the C interoperable kinds */
564 init_c_interop_kinds();
567 /* Make sure that a valid kind is present. Returns an index into the
568 associated kinds array, -1 if the kind is not present. */
571 validate_integer (int kind
)
575 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
576 if (gfc_integer_kinds
[i
].kind
== kind
)
583 validate_real (int kind
)
587 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
588 if (gfc_real_kinds
[i
].kind
== kind
)
595 validate_logical (int kind
)
599 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
600 if (gfc_logical_kinds
[i
].kind
== kind
)
607 validate_character (int kind
)
611 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
612 if (gfc_character_kinds
[i
].kind
== kind
)
618 /* Validate a kind given a basic type. The return value is the same
619 for the child functions, with -1 indicating nonexistence of the
620 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
623 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
629 case BT_REAL
: /* Fall through */
631 rc
= validate_real (kind
);
634 rc
= validate_integer (kind
);
637 rc
= validate_logical (kind
);
640 rc
= validate_character (kind
);
644 gfc_internal_error ("gfc_validate_kind(): Got bad type");
647 if (rc
< 0 && !may_fail
)
648 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
654 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
655 Reuse common type nodes where possible. Recognize if the kind matches up
656 with a C type. This will be used later in determining which routines may
657 be scarfed from libm. */
660 gfc_build_int_type (gfc_integer_info
*info
)
662 int mode_precision
= info
->bit_size
;
664 if (mode_precision
== CHAR_TYPE_SIZE
)
666 if (mode_precision
== SHORT_TYPE_SIZE
)
668 if (mode_precision
== INT_TYPE_SIZE
)
670 if (mode_precision
== LONG_TYPE_SIZE
)
672 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
673 info
->c_long_long
= 1;
675 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
676 return intQI_type_node
;
677 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
678 return intHI_type_node
;
679 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
680 return intSI_type_node
;
681 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
682 return intDI_type_node
;
683 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
684 return intTI_type_node
;
686 return make_signed_type (mode_precision
);
690 gfc_build_uint_type (int size
)
692 if (size
== CHAR_TYPE_SIZE
)
693 return unsigned_char_type_node
;
694 if (size
== SHORT_TYPE_SIZE
)
695 return short_unsigned_type_node
;
696 if (size
== INT_TYPE_SIZE
)
697 return unsigned_type_node
;
698 if (size
== LONG_TYPE_SIZE
)
699 return long_unsigned_type_node
;
700 if (size
== LONG_LONG_TYPE_SIZE
)
701 return long_long_unsigned_type_node
;
703 return make_unsigned_type (size
);
708 gfc_build_real_type (gfc_real_info
*info
)
710 int mode_precision
= info
->mode_precision
;
713 if (mode_precision
== FLOAT_TYPE_SIZE
)
715 if (mode_precision
== DOUBLE_TYPE_SIZE
)
717 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
718 info
->c_long_double
= 1;
720 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
721 return float_type_node
;
722 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
723 return double_type_node
;
724 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
725 return long_double_type_node
;
727 new_type
= make_node (REAL_TYPE
);
728 TYPE_PRECISION (new_type
) = mode_precision
;
729 layout_type (new_type
);
734 gfc_build_complex_type (tree scalar_type
)
738 if (scalar_type
== NULL
)
740 if (scalar_type
== float_type_node
)
741 return complex_float_type_node
;
742 if (scalar_type
== double_type_node
)
743 return complex_double_type_node
;
744 if (scalar_type
== long_double_type_node
)
745 return complex_long_double_type_node
;
747 new_type
= make_node (COMPLEX_TYPE
);
748 TREE_TYPE (new_type
) = scalar_type
;
749 layout_type (new_type
);
754 gfc_build_logical_type (gfc_logical_info
*info
)
756 int bit_size
= info
->bit_size
;
759 if (bit_size
== BOOL_TYPE_SIZE
)
762 return boolean_type_node
;
765 new_type
= make_unsigned_type (bit_size
);
766 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
767 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
768 TYPE_PRECISION (new_type
) = 1;
775 /* Return the bit size of the C "size_t". */
781 if (strcmp (SIZE_TYPE
, "unsigned int") == 0)
782 return INT_TYPE_SIZE
;
783 if (strcmp (SIZE_TYPE
, "long unsigned int") == 0)
784 return LONG_TYPE_SIZE
;
785 if (strcmp (SIZE_TYPE
, "short unsigned int") == 0)
786 return SHORT_TYPE_SIZE
;
789 return LONG_TYPE_SIZE
;
794 /* Create the backend type nodes. We map them to their
795 equivalent C type, at least for now. We also give
796 names to the types here, and we push them in the
797 global binding level context.*/
800 gfc_init_types (void)
806 unsigned HOST_WIDE_INT hi
;
807 unsigned HOST_WIDE_INT lo
;
809 /* Create and name the types. */
810 #define PUSH_TYPE(name, node) \
811 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
813 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
815 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
816 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
817 if (TYPE_STRING_FLAG (type
))
818 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
819 gfc_integer_types
[index
] = type
;
820 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
821 gfc_integer_kinds
[index
].kind
);
822 PUSH_TYPE (name_buf
, type
);
825 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
827 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
828 gfc_logical_types
[index
] = type
;
829 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
830 gfc_logical_kinds
[index
].kind
);
831 PUSH_TYPE (name_buf
, type
);
834 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
836 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
837 gfc_real_types
[index
] = type
;
838 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
839 gfc_real_kinds
[index
].kind
);
840 PUSH_TYPE (name_buf
, type
);
842 type
= gfc_build_complex_type (type
);
843 gfc_complex_types
[index
] = type
;
844 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
845 gfc_real_kinds
[index
].kind
);
846 PUSH_TYPE (name_buf
, type
);
849 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
851 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
852 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
853 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
854 gfc_character_kinds
[index
].kind
);
855 PUSH_TYPE (name_buf
, type
);
856 gfc_character_types
[index
] = type
;
857 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
859 gfc_character1_type_node
= gfc_character_types
[0];
861 PUSH_TYPE ("byte", unsigned_char_type_node
);
862 PUSH_TYPE ("void", void_type_node
);
864 /* DBX debugging output gets upset if these aren't set. */
865 if (!TYPE_NAME (integer_type_node
))
866 PUSH_TYPE ("c_integer", integer_type_node
);
867 if (!TYPE_NAME (char_type_node
))
868 PUSH_TYPE ("c_char", char_type_node
);
872 pvoid_type_node
= build_pointer_type (void_type_node
);
873 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
874 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
876 = build_pointer_type (build_function_type (void_type_node
, NULL_TREE
));
878 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
879 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
880 since this function is called before gfc_init_constants. */
882 = build_range_type (gfc_array_index_type
,
883 build_int_cst (gfc_array_index_type
, 0),
886 /* The maximum array element size that can be handled is determined
887 by the number of bits available to store this field in the array
890 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
891 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
892 if (n
> HOST_BITS_PER_WIDE_INT
)
893 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
895 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
896 gfc_max_array_element_size
897 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
899 size_type_node
= gfc_array_index_type
;
901 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
902 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
903 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
905 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
906 gfc_charlen_int_kind
= 4;
907 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
910 /* Get the type node for the given type and kind. */
913 gfc_get_int_type (int kind
)
915 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
916 return index
< 0 ? 0 : gfc_integer_types
[index
];
920 gfc_get_real_type (int kind
)
922 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
923 return index
< 0 ? 0 : gfc_real_types
[index
];
927 gfc_get_complex_type (int kind
)
929 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
930 return index
< 0 ? 0 : gfc_complex_types
[index
];
934 gfc_get_logical_type (int kind
)
936 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
937 return index
< 0 ? 0 : gfc_logical_types
[index
];
941 gfc_get_char_type (int kind
)
943 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
944 return index
< 0 ? 0 : gfc_character_types
[index
];
948 gfc_get_pchar_type (int kind
)
950 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
951 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
955 /* Create a character type with the given kind and length. */
958 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
962 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
963 type
= build_array_type (eltype
, bounds
);
964 TYPE_STRING_FLAG (type
) = 1;
970 gfc_get_character_type_len (int kind
, tree len
)
972 gfc_validate_kind (BT_CHARACTER
, kind
, false);
973 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
977 /* Get a type node for a character kind. */
980 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
984 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
986 return gfc_get_character_type_len (kind
, len
);
989 /* Covert a basic type. This will be an array for character types. */
992 gfc_typenode_for_spec (gfc_typespec
* spec
)
1002 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1003 has been resolved. This is done so we can convert C_PTR and
1004 C_FUNPTR to simple variables that get translated to (void *). */
1005 if (spec
->f90_type
== BT_VOID
)
1008 && spec
->derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1009 basetype
= ptr_type_node
;
1011 basetype
= pfunc_type_node
;
1014 basetype
= gfc_get_int_type (spec
->kind
);
1018 basetype
= gfc_get_real_type (spec
->kind
);
1022 basetype
= gfc_get_complex_type (spec
->kind
);
1026 basetype
= gfc_get_logical_type (spec
->kind
);
1030 basetype
= gfc_get_character_type (spec
->kind
, spec
->cl
);
1034 basetype
= gfc_get_derived_type (spec
->derived
);
1036 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1037 type and kind to fit a (void *) and the basetype returned was a
1038 ptr_type_node. We need to pass up this new information to the
1039 symbol that was declared of type C_PTR or C_FUNPTR. */
1040 if (spec
->derived
->attr
.is_iso_c
)
1042 spec
->type
= spec
->derived
->ts
.type
;
1043 spec
->kind
= spec
->derived
->ts
.kind
;
1044 spec
->f90_type
= spec
->derived
->ts
.f90_type
;
1048 /* This is for the second arg to c_f_pointer and c_f_procpointer
1049 of the iso_c_binding module, to accept any ptr type. */
1050 basetype
= ptr_type_node
;
1051 if (spec
->f90_type
== BT_VOID
)
1054 && spec
->derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1055 basetype
= ptr_type_node
;
1057 basetype
= pfunc_type_node
;
1066 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1069 gfc_conv_array_bound (gfc_expr
* expr
)
1071 /* If expr is an integer constant, return that. */
1072 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1073 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1075 /* Otherwise return NULL. */
1080 gfc_get_element_type (tree type
)
1084 if (GFC_ARRAY_TYPE_P (type
))
1086 if (TREE_CODE (type
) == POINTER_TYPE
)
1087 type
= TREE_TYPE (type
);
1088 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1089 element
= TREE_TYPE (type
);
1093 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1094 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1096 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1097 element
= TREE_TYPE (element
);
1099 gcc_assert (TREE_CODE (element
) == ARRAY_TYPE
);
1100 element
= TREE_TYPE (element
);
1106 /* Build an array. This function is called from gfc_sym_type().
1107 Actually returns array descriptor type.
1109 Format of array descriptors is as follows:
1111 struct gfc_array_descriptor
1116 struct descriptor_dimension dimension[N_DIM];
1119 struct descriptor_dimension
1126 Translation code should use gfc_conv_descriptor_* rather than
1127 accessing the descriptor directly. Any changes to the array
1128 descriptor type will require changes in gfc_conv_descriptor_* and
1129 gfc_build_array_initializer.
1131 This is represented internally as a RECORD_TYPE. The index nodes
1132 are gfc_array_index_type and the data node is a pointer to the
1133 data. See below for the handling of character types.
1135 The dtype member is formatted as follows:
1136 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1137 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1138 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1140 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1141 this generated poor code for assumed/deferred size arrays. These
1142 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1143 of the GENERIC grammar. Also, there is no way to explicitly set
1144 the array stride, so all data must be packed(1). I've tried to
1145 mark all the functions which would require modification with a GCC
1148 The data component points to the first element in the array. The
1149 offset field is the position of the origin of the array (i.e. element
1150 (0, 0 ...)). This may be outside the bounds of the array.
1152 An element is accessed by
1153 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1154 This gives good performance as the computation does not involve the
1155 bounds of the array. For packed arrays, this is optimized further
1156 by substituting the known strides.
1158 This system has one problem: all array bounds must be within 2^31
1159 elements of the origin (2^63 on 64-bit machines). For example
1160 integer, dimension (80000:90000, 80000:90000, 2) :: array
1161 may not work properly on 32-bit machines because 80000*80000 >
1162 2^31, so the calculation for stride2 would overflow. This may
1163 still work, but I haven't checked, and it relies on the overflow
1164 doing the right thing.
1166 The way to fix this problem is to access elements as follows:
1167 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1168 Obviously this is much slower. I will make this a compile time
1169 option, something like -fsmall-array-offsets. Mixing code compiled
1170 with and without this switch will work.
1172 (1) This can be worked around by modifying the upper bound of the
1173 previous dimension. This requires extra fields in the descriptor
1174 (both real_ubound and fake_ubound). */
1177 /* Returns true if the array sym does not require a descriptor. */
1180 gfc_is_nodesc_array (gfc_symbol
* sym
)
1182 gcc_assert (sym
->attr
.dimension
);
1184 /* We only want local arrays. */
1185 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1188 if (sym
->attr
.dummy
)
1190 if (sym
->as
->type
!= AS_ASSUMED_SHAPE
)
1196 if (sym
->attr
.result
|| sym
->attr
.function
)
1199 gcc_assert (sym
->as
->type
== AS_EXPLICIT
);
1205 /* Create an array descriptor type. */
1208 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1209 enum gfc_array_kind akind
)
1211 tree lbound
[GFC_MAX_DIMENSIONS
];
1212 tree ubound
[GFC_MAX_DIMENSIONS
];
1215 for (n
= 0; n
< as
->rank
; n
++)
1217 /* Create expressions for the known bounds of the array. */
1218 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1219 lbound
[n
] = gfc_index_one_node
;
1221 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1222 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1225 if (as
->type
== AS_ASSUMED_SHAPE
)
1226 akind
= GFC_ARRAY_ASSUMED_SHAPE
;
1227 return gfc_get_array_type_bounds (type
, as
->rank
, lbound
, ubound
, 0, akind
);
1230 /* Returns the struct descriptor_dimension type. */
1233 gfc_get_desc_dim_type (void)
1239 if (gfc_desc_dim_type
)
1240 return gfc_desc_dim_type
;
1242 /* Build the type node. */
1243 type
= make_node (RECORD_TYPE
);
1245 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1246 TYPE_PACKED (type
) = 1;
1248 /* Consists of the stride, lbound and ubound members. */
1249 decl
= build_decl (FIELD_DECL
,
1250 get_identifier ("stride"), gfc_array_index_type
);
1251 DECL_CONTEXT (decl
) = type
;
1252 TREE_NO_WARNING (decl
) = 1;
1255 decl
= build_decl (FIELD_DECL
,
1256 get_identifier ("lbound"), gfc_array_index_type
);
1257 DECL_CONTEXT (decl
) = type
;
1258 TREE_NO_WARNING (decl
) = 1;
1259 fieldlist
= chainon (fieldlist
, decl
);
1261 decl
= build_decl (FIELD_DECL
,
1262 get_identifier ("ubound"), gfc_array_index_type
);
1263 DECL_CONTEXT (decl
) = type
;
1264 TREE_NO_WARNING (decl
) = 1;
1265 fieldlist
= chainon (fieldlist
, decl
);
1267 /* Finish off the type. */
1268 TYPE_FIELDS (type
) = fieldlist
;
1270 gfc_finish_type (type
);
1271 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1273 gfc_desc_dim_type
= type
;
1278 /* Return the DTYPE for an array. This describes the type and type parameters
1280 /* TODO: Only call this when the value is actually used, and make all the
1281 unknown cases abort. */
1284 gfc_get_dtype (tree type
)
1294 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1296 if (GFC_TYPE_ARRAY_DTYPE (type
))
1297 return GFC_TYPE_ARRAY_DTYPE (type
);
1299 rank
= GFC_TYPE_ARRAY_RANK (type
);
1300 etype
= gfc_get_element_type (type
);
1302 switch (TREE_CODE (etype
))
1305 n
= GFC_DTYPE_INTEGER
;
1309 n
= GFC_DTYPE_LOGICAL
;
1317 n
= GFC_DTYPE_COMPLEX
;
1320 /* We will never have arrays of arrays. */
1322 n
= GFC_DTYPE_DERIVED
;
1326 n
= GFC_DTYPE_CHARACTER
;
1330 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1331 /* We can strange array types for temporary arrays. */
1332 return gfc_index_zero_node
;
1335 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1336 size
= TYPE_SIZE_UNIT (etype
);
1338 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1339 if (size
&& INTEGER_CST_P (size
))
1341 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1342 internal_error ("Array element size too big");
1344 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1346 dtype
= build_int_cst (gfc_array_index_type
, i
);
1348 if (size
&& !INTEGER_CST_P (size
))
1350 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1351 tmp
= fold_build2 (LSHIFT_EXPR
, gfc_array_index_type
,
1352 fold_convert (gfc_array_index_type
, size
), tmp
);
1353 dtype
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
, dtype
);
1355 /* If we don't know the size we leave it as zero. This should never happen
1356 for anything that is actually used. */
1357 /* TODO: Check this is actually true, particularly when repacking
1358 assumed size parameters. */
1360 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1365 /* Build an array type for use without a descriptor, packed according
1366 to the value of PACKED. */
1369 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
)
1382 mpz_init_set_ui (offset
, 0);
1383 mpz_init_set_ui (stride
, 1);
1386 /* We don't use build_array_type because this does not include include
1387 lang-specific information (i.e. the bounds of the array) when checking
1389 type
= make_node (ARRAY_TYPE
);
1391 GFC_ARRAY_TYPE_P (type
) = 1;
1392 TYPE_LANG_SPECIFIC (type
) = (struct lang_type
*)
1393 ggc_alloc_cleared (sizeof (struct lang_type
));
1395 known_stride
= (packed
!= PACKED_NO
);
1397 for (n
= 0; n
< as
->rank
; n
++)
1399 /* Fill in the stride and bound components of the type. */
1401 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1404 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1406 expr
= as
->lower
[n
];
1407 if (expr
->expr_type
== EXPR_CONSTANT
)
1409 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1410 gfc_index_integer_kind
);
1417 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1421 /* Calculate the offset. */
1422 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1423 mpz_sub (offset
, offset
, delta
);
1428 expr
= as
->upper
[n
];
1429 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1431 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1432 gfc_index_integer_kind
);
1439 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1443 /* Calculate the stride. */
1444 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1445 as
->lower
[n
]->value
.integer
);
1446 mpz_add_ui (delta
, delta
, 1);
1447 mpz_mul (stride
, stride
, delta
);
1450 /* Only the first stride is known for partial packed arrays. */
1451 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1457 GFC_TYPE_ARRAY_OFFSET (type
) =
1458 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1461 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1465 GFC_TYPE_ARRAY_SIZE (type
) =
1466 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1469 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1471 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1472 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1473 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1475 /* TODO: use main type if it is unbounded. */
1476 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1477 build_pointer_type (build_array_type (etype
, range
));
1481 mpz_sub_ui (stride
, stride
, 1);
1482 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1487 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1488 TYPE_DOMAIN (type
) = range
;
1490 build_pointer_type (etype
);
1491 TREE_TYPE (type
) = etype
;
1499 /* Represent packed arrays as multi-dimensional if they have rank >
1500 1 and with proper bounds, instead of flat arrays. This makes for
1501 better debug info. */
1504 tree gtype
= etype
, rtype
, type_decl
;
1506 for (n
= as
->rank
- 1; n
>= 0; n
--)
1508 rtype
= build_range_type (gfc_array_index_type
,
1509 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1510 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1511 gtype
= build_array_type (gtype
, rtype
);
1513 TYPE_NAME (type
) = type_decl
= build_decl (TYPE_DECL
, NULL
, gtype
);
1514 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1517 if (packed
!= PACKED_STATIC
|| !known_stride
)
1519 /* For dummy arrays and automatic (heap allocated) arrays we
1520 want a pointer to the array. */
1521 type
= build_pointer_type (type
);
1522 GFC_ARRAY_TYPE_P (type
) = 1;
1523 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1528 /* Return or create the base type for an array descriptor. */
1531 gfc_get_array_descriptor_base (int dimen
)
1533 tree fat_type
, fieldlist
, decl
, arraytype
;
1534 char name
[16 + GFC_RANK_DIGITS
+ 1];
1536 gcc_assert (dimen
>= 1 && dimen
<= GFC_MAX_DIMENSIONS
);
1537 if (gfc_array_descriptor_base
[dimen
- 1])
1538 return gfc_array_descriptor_base
[dimen
- 1];
1540 /* Build the type node. */
1541 fat_type
= make_node (RECORD_TYPE
);
1543 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
);
1544 TYPE_NAME (fat_type
) = get_identifier (name
);
1546 /* Add the data member as the first element of the descriptor. */
1547 decl
= build_decl (FIELD_DECL
, get_identifier ("data"), ptr_type_node
);
1549 DECL_CONTEXT (decl
) = fat_type
;
1552 /* Add the base component. */
1553 decl
= build_decl (FIELD_DECL
, get_identifier ("offset"),
1554 gfc_array_index_type
);
1555 DECL_CONTEXT (decl
) = fat_type
;
1556 TREE_NO_WARNING (decl
) = 1;
1557 fieldlist
= chainon (fieldlist
, decl
);
1559 /* Add the dtype component. */
1560 decl
= build_decl (FIELD_DECL
, get_identifier ("dtype"),
1561 gfc_array_index_type
);
1562 DECL_CONTEXT (decl
) = fat_type
;
1563 TREE_NO_WARNING (decl
) = 1;
1564 fieldlist
= chainon (fieldlist
, decl
);
1566 /* Build the array type for the stride and bound components. */
1568 build_array_type (gfc_get_desc_dim_type (),
1569 build_range_type (gfc_array_index_type
,
1570 gfc_index_zero_node
,
1571 gfc_rank_cst
[dimen
- 1]));
1573 decl
= build_decl (FIELD_DECL
, get_identifier ("dim"), arraytype
);
1574 DECL_CONTEXT (decl
) = fat_type
;
1575 TREE_NO_WARNING (decl
) = 1;
1576 fieldlist
= chainon (fieldlist
, decl
);
1578 /* Finish off the type. */
1579 TYPE_FIELDS (fat_type
) = fieldlist
;
1581 gfc_finish_type (fat_type
);
1582 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1584 gfc_array_descriptor_base
[dimen
- 1] = fat_type
;
1588 /* Build an array (descriptor) type with given bounds. */
1591 gfc_get_array_type_bounds (tree etype
, int dimen
, tree
* lbound
,
1592 tree
* ubound
, int packed
,
1593 enum gfc_array_kind akind
)
1595 char name
[8 + GFC_RANK_DIGITS
+ GFC_MAX_SYMBOL_LEN
];
1596 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1597 const char *type_name
;
1600 base_type
= gfc_get_array_descriptor_base (dimen
);
1601 fat_type
= build_variant_type_copy (base_type
);
1603 tmp
= TYPE_NAME (etype
);
1604 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1605 tmp
= DECL_NAME (tmp
);
1607 type_name
= IDENTIFIER_POINTER (tmp
);
1609 type_name
= "unknown";
1610 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
,
1611 GFC_MAX_SYMBOL_LEN
, type_name
);
1612 TYPE_NAME (fat_type
) = get_identifier (name
);
1614 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1615 TYPE_LANG_SPECIFIC (fat_type
) = (struct lang_type
*)
1616 ggc_alloc_cleared (sizeof (struct lang_type
));
1618 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1619 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1620 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1622 /* Build an array descriptor record type. */
1624 stride
= gfc_index_one_node
;
1627 for (n
= 0; n
< dimen
; n
++)
1629 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1636 if (lower
!= NULL_TREE
)
1638 if (INTEGER_CST_P (lower
))
1639 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1645 if (upper
!= NULL_TREE
)
1647 if (INTEGER_CST_P (upper
))
1648 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1653 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1655 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, upper
, lower
);
1656 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
1657 gfc_index_one_node
);
1659 fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, stride
);
1660 /* Check the folding worked. */
1661 gcc_assert (INTEGER_CST_P (stride
));
1666 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1668 /* TODO: known offsets for descriptors. */
1669 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1671 /* We define data as an array with the correct size if possible.
1672 Much better than doing pointer arithmetic. */
1674 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1675 int_const_binop (MINUS_EXPR
, stride
,
1676 integer_one_node
, 0));
1678 rtype
= gfc_array_range_type
;
1679 arraytype
= build_array_type (etype
, rtype
);
1680 arraytype
= build_pointer_type (arraytype
);
1681 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1686 /* Build a pointer type. This function is called from gfc_sym_type(). */
1689 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1691 /* Array pointer types aren't actually pointers. */
1692 if (sym
->attr
.dimension
)
1695 return build_pointer_type (type
);
1698 /* Return the type for a symbol. Special handling is required for character
1699 types to get the correct level of indirection.
1700 For functions return the return type.
1701 For subroutines return void_type_node.
1702 Calling this multiple times for the same symbol should be avoided,
1703 especially for character and array types. */
1706 gfc_sym_type (gfc_symbol
* sym
)
1711 /* Procedure Pointers inside COMMON blocks. */
1712 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
1714 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
1715 sym
->attr
.proc_pointer
= 0;
1716 type
= build_pointer_type (gfc_get_function_type (sym
));
1717 sym
->attr
.proc_pointer
= 1;
1721 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
1722 return void_type_node
;
1724 /* In the case of a function the fake result variable may have a
1725 type different from the function type, so don't return early in
1727 if (sym
->backend_decl
&& !sym
->attr
.function
)
1728 return TREE_TYPE (sym
->backend_decl
);
1730 if (sym
->ts
.type
== BT_CHARACTER
1731 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
1732 || (sym
->attr
.result
1733 && sym
->ns
->proc_name
1734 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
1735 type
= gfc_character1_type_node
;
1737 type
= gfc_typenode_for_spec (&sym
->ts
);
1739 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
1744 if (sym
->attr
.dimension
)
1746 if (gfc_is_nodesc_array (sym
))
1748 /* If this is a character argument of unknown length, just use the
1750 if (sym
->ts
.type
!= BT_CHARACTER
1751 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
1752 || sym
->ts
.cl
->backend_decl
)
1754 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
1762 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
1763 if (sym
->attr
.pointer
)
1764 akind
= GFC_ARRAY_POINTER
;
1765 else if (sym
->attr
.allocatable
)
1766 akind
= GFC_ARRAY_ALLOCATABLE
;
1767 type
= gfc_build_array_type (type
, sym
->as
, akind
);
1772 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1773 type
= gfc_build_pointer_type (sym
, type
);
1774 if (sym
->attr
.pointer
)
1775 GFC_POINTER_TYPE_P (type
) = 1;
1778 /* We currently pass all parameters by reference.
1779 See f95_get_function_decl. For dummy function parameters return the
1783 /* We must use pointer types for potentially absent variables. The
1784 optimizers assume a reference type argument is never NULL. */
1785 if (sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
)
1786 type
= build_pointer_type (type
);
1788 type
= build_reference_type (type
);
1794 /* Layout and output debug info for a record type. */
1797 gfc_finish_type (tree type
)
1801 decl
= build_decl (TYPE_DECL
, NULL_TREE
, type
);
1802 TYPE_STUB_DECL (type
) = decl
;
1804 rest_of_type_compilation (type
, 1);
1805 rest_of_decl_compilation (decl
, 1, 0);
1808 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1809 or RECORD_TYPE pointed to by STYPE. The new field is chained
1810 to the fieldlist pointed to by FIELDLIST.
1812 Returns a pointer to the new field. */
1815 gfc_add_field_to_struct (tree
*fieldlist
, tree context
,
1816 tree name
, tree type
)
1820 decl
= build_decl (FIELD_DECL
, name
, type
);
1822 DECL_CONTEXT (decl
) = context
;
1823 DECL_INITIAL (decl
) = 0;
1824 DECL_ALIGN (decl
) = 0;
1825 DECL_USER_ALIGN (decl
) = 0;
1826 TREE_CHAIN (decl
) = NULL_TREE
;
1827 *fieldlist
= chainon (*fieldlist
, decl
);
1833 /* Copy the backend_decl and component backend_decls if
1834 the two derived type symbols are "equal", as described
1835 in 4.4.2 and resolved by gfc_compare_derived_types. */
1838 copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
)
1840 gfc_component
*to_cm
;
1841 gfc_component
*from_cm
;
1843 if (from
->backend_decl
== NULL
1844 || !gfc_compare_derived_types (from
, to
))
1847 to
->backend_decl
= from
->backend_decl
;
1849 to_cm
= to
->components
;
1850 from_cm
= from
->components
;
1852 /* Copy the component declarations. If a component is itself
1853 a derived type, we need a copy of its component declarations.
1854 This is done by recursing into gfc_get_derived_type and
1855 ensures that the component's component declarations have
1856 been built. If it is a character, we need the character
1858 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
1860 to_cm
->backend_decl
= from_cm
->backend_decl
;
1861 if (!from_cm
->attr
.pointer
&& from_cm
->ts
.type
== BT_DERIVED
)
1862 gfc_get_derived_type (to_cm
->ts
.derived
);
1864 else if (from_cm
->ts
.type
== BT_CHARACTER
)
1865 to_cm
->ts
.cl
->backend_decl
= from_cm
->ts
.cl
->backend_decl
;
1872 /* Build a tree node for a procedure pointer component. */
1875 gfc_get_ppc_type (gfc_component
* c
)
1878 if (c
->attr
.function
)
1879 t
= gfc_typenode_for_spec (&c
->ts
);
1882 /* TODO: Build argument list. */
1883 return build_pointer_type (build_function_type (t
, NULL_TREE
));
1887 /* Build a tree node for a derived type. If there are equal
1888 derived types, with different local names, these are built
1889 at the same time. If an equal derived type has been built
1890 in a parent namespace, this is used. */
1893 gfc_get_derived_type (gfc_symbol
* derived
)
1895 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
, fieldlist
= NULL
;
1899 gcc_assert (derived
&& derived
->attr
.flavor
== FL_DERIVED
);
1901 /* See if it's one of the iso_c_binding derived types. */
1902 if (derived
->attr
.is_iso_c
== 1)
1904 if (derived
->backend_decl
)
1905 return derived
->backend_decl
;
1907 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1908 derived
->backend_decl
= ptr_type_node
;
1910 derived
->backend_decl
= pfunc_type_node
;
1912 /* Create a backend_decl for the __c_ptr_c_address field. */
1913 derived
->components
->backend_decl
=
1914 gfc_add_field_to_struct (&(derived
->backend_decl
->type
.values
),
1915 derived
->backend_decl
,
1916 get_identifier (derived
->components
->name
),
1917 gfc_typenode_for_spec (
1918 &(derived
->components
->ts
)));
1920 derived
->ts
.kind
= gfc_index_integer_kind
;
1921 derived
->ts
.type
= BT_INTEGER
;
1922 /* Set the f90_type to BT_VOID as a way to recognize something of type
1923 BT_INTEGER that needs to fit a void * for the purpose of the
1924 iso_c_binding derived types. */
1925 derived
->ts
.f90_type
= BT_VOID
;
1927 return derived
->backend_decl
;
1930 /* derived->backend_decl != 0 means we saw it before, but its
1931 components' backend_decl may have not been built. */
1932 if (derived
->backend_decl
)
1933 return derived
->backend_decl
;
1936 /* We see this derived type first time, so build the type node. */
1937 typenode
= make_node (RECORD_TYPE
);
1938 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
1939 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
1940 derived
->backend_decl
= typenode
;
1943 /* Go through the derived type components, building them as
1944 necessary. The reason for doing this now is that it is
1945 possible to recurse back to this derived type through a
1946 pointer component (PR24092). If this happens, the fields
1947 will be built and so we can return the type. */
1948 for (c
= derived
->components
; c
; c
= c
->next
)
1950 if (c
->ts
.type
!= BT_DERIVED
)
1953 if (!c
->attr
.pointer
|| c
->ts
.derived
->backend_decl
== NULL
)
1954 c
->ts
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.derived
);
1956 if (c
->ts
.derived
&& c
->ts
.derived
->attr
.is_iso_c
)
1958 /* Need to copy the modified ts from the derived type. The
1959 typespec was modified because C_PTR/C_FUNPTR are translated
1960 into (void *) from derived types. */
1961 c
->ts
.type
= c
->ts
.derived
->ts
.type
;
1962 c
->ts
.kind
= c
->ts
.derived
->ts
.kind
;
1963 c
->ts
.f90_type
= c
->ts
.derived
->ts
.f90_type
;
1966 c
->initializer
->ts
.type
= c
->ts
.type
;
1967 c
->initializer
->ts
.kind
= c
->ts
.kind
;
1968 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
1969 c
->initializer
->expr_type
= EXPR_NULL
;
1974 if (TYPE_FIELDS (derived
->backend_decl
))
1975 return derived
->backend_decl
;
1977 /* Build the type member list. Install the newly created RECORD_TYPE
1978 node as DECL_CONTEXT of each FIELD_DECL. */
1979 fieldlist
= NULL_TREE
;
1980 for (c
= derived
->components
; c
; c
= c
->next
)
1982 if (c
->ts
.type
== BT_DERIVED
)
1983 field_type
= c
->ts
.derived
->backend_decl
;
1984 else if (c
->attr
.proc_pointer
)
1985 field_type
= gfc_get_ppc_type (c
);
1988 if (c
->ts
.type
== BT_CHARACTER
)
1990 /* Evaluate the string length. */
1991 gfc_conv_const_charlen (c
->ts
.cl
);
1992 gcc_assert (c
->ts
.cl
->backend_decl
);
1995 field_type
= gfc_typenode_for_spec (&c
->ts
);
1998 /* This returns an array descriptor type. Initialization may be
2000 if (c
->attr
.dimension
)
2002 if (c
->attr
.pointer
|| c
->attr
.allocatable
)
2004 enum gfc_array_kind akind
;
2005 if (c
->attr
.pointer
)
2006 akind
= GFC_ARRAY_POINTER
;
2008 akind
= GFC_ARRAY_ALLOCATABLE
;
2009 /* Pointers to arrays aren't actually pointer types. The
2010 descriptors are separate, but the data is common. */
2011 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
);
2014 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2017 else if (c
->attr
.pointer
)
2018 field_type
= build_pointer_type (field_type
);
2020 field
= gfc_add_field_to_struct (&fieldlist
, typenode
,
2021 get_identifier (c
->name
),
2024 gfc_set_decl_location (field
, &c
->loc
);
2025 else if (derived
->declared_at
.lb
)
2026 gfc_set_decl_location (field
, &derived
->declared_at
);
2028 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2031 if (!c
->backend_decl
)
2032 c
->backend_decl
= field
;
2035 /* Now we have the final fieldlist. Record it, then lay out the
2036 derived type, including the fields. */
2037 TYPE_FIELDS (typenode
) = fieldlist
;
2039 gfc_finish_type (typenode
);
2040 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2041 if (derived
->module
&& derived
->ns
->proc_name
2042 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2044 if (derived
->ns
->proc_name
->backend_decl
2045 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2048 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2049 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2050 = derived
->ns
->proc_name
->backend_decl
;
2054 derived
->backend_decl
= typenode
;
2056 /* Add this backend_decl to all the other, equal derived types. */
2057 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2058 copy_dt_decls_ifequal (derived
, dt
->derived
);
2060 return derived
->backend_decl
;
2065 gfc_return_by_reference (gfc_symbol
* sym
)
2067 if (!sym
->attr
.function
)
2070 if (sym
->attr
.dimension
)
2073 if (sym
->ts
.type
== BT_CHARACTER
2074 && !sym
->attr
.is_bind_c
2075 && (!sym
->attr
.result
2076 || !sym
->ns
->proc_name
2077 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2080 /* Possibly return complex numbers by reference for g77 compatibility.
2081 We don't do this for calls to intrinsics (as the library uses the
2082 -fno-f2c calling convention), nor for calls to functions which always
2083 require an explicit interface, as no compatibility problems can
2085 if (gfc_option
.flag_f2c
2086 && sym
->ts
.type
== BT_COMPLEX
2087 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2094 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2099 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2100 gfc_entry_list
*el
, *el2
;
2102 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2103 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2105 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2107 /* Build the type node. */
2108 type
= make_node (UNION_TYPE
);
2110 TYPE_NAME (type
) = get_identifier (name
);
2113 for (el
= ns
->entries
; el
; el
= el
->next
)
2115 /* Search for duplicates. */
2116 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2117 if (el2
->sym
->result
== el
->sym
->result
)
2122 decl
= build_decl (FIELD_DECL
,
2123 get_identifier (el
->sym
->result
->name
),
2124 gfc_sym_type (el
->sym
->result
));
2125 DECL_CONTEXT (decl
) = type
;
2126 fieldlist
= chainon (fieldlist
, decl
);
2130 /* Finish off the type. */
2131 TYPE_FIELDS (type
) = fieldlist
;
2133 gfc_finish_type (type
);
2134 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2139 gfc_get_function_type (gfc_symbol
* sym
)
2143 gfc_formal_arglist
*f
;
2146 int alternate_return
;
2148 /* Make sure this symbol is a function, a subroutine or the main
2150 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2151 || sym
->attr
.flavor
== FL_PROGRAM
);
2153 if (sym
->backend_decl
)
2154 return TREE_TYPE (sym
->backend_decl
);
2157 alternate_return
= 0;
2158 typelist
= NULL_TREE
;
2160 if (sym
->attr
.entry_master
)
2162 /* Additional parameter for selecting an entry point. */
2163 typelist
= gfc_chainon_list (typelist
, gfc_array_index_type
);
2171 if (arg
->ts
.type
== BT_CHARACTER
)
2172 gfc_conv_const_charlen (arg
->ts
.cl
);
2174 /* Some functions we use an extra parameter for the return value. */
2175 if (gfc_return_by_reference (sym
))
2177 type
= gfc_sym_type (arg
);
2178 if (arg
->ts
.type
== BT_COMPLEX
2179 || arg
->attr
.dimension
2180 || arg
->ts
.type
== BT_CHARACTER
)
2181 type
= build_reference_type (type
);
2183 typelist
= gfc_chainon_list (typelist
, type
);
2184 if (arg
->ts
.type
== BT_CHARACTER
)
2185 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
2188 /* Build the argument types for the function. */
2189 for (f
= sym
->formal
; f
; f
= f
->next
)
2194 /* Evaluate constant character lengths here so that they can be
2195 included in the type. */
2196 if (arg
->ts
.type
== BT_CHARACTER
)
2197 gfc_conv_const_charlen (arg
->ts
.cl
);
2199 if (arg
->attr
.flavor
== FL_PROCEDURE
)
2201 type
= gfc_get_function_type (arg
);
2202 type
= build_pointer_type (type
);
2205 type
= gfc_sym_type (arg
);
2207 /* Parameter Passing Convention
2209 We currently pass all parameters by reference.
2210 Parameters with INTENT(IN) could be passed by value.
2211 The problem arises if a function is called via an implicit
2212 prototype. In this situation the INTENT is not known.
2213 For this reason all parameters to global functions must be
2214 passed by reference. Passing by value would potentially
2215 generate bad code. Worse there would be no way of telling that
2216 this code was bad, except that it would give incorrect results.
2218 Contained procedures could pass by value as these are never
2219 used without an explicit interface, and cannot be passed as
2220 actual parameters for a dummy procedure. */
2221 if (arg
->ts
.type
== BT_CHARACTER
)
2223 typelist
= gfc_chainon_list (typelist
, type
);
2227 if (sym
->attr
.subroutine
)
2228 alternate_return
= 1;
2232 /* Add hidden string length parameters. */
2234 typelist
= gfc_chainon_list (typelist
, gfc_charlen_type_node
);
2237 typelist
= gfc_chainon_list (typelist
, void_type_node
);
2239 if (alternate_return
)
2240 type
= integer_type_node
;
2241 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
2242 type
= void_type_node
;
2243 else if (sym
->attr
.mixed_entry_master
)
2244 type
= gfc_get_mixed_entry_union (sym
->ns
);
2245 else if (gfc_option
.flag_f2c
2246 && sym
->ts
.type
== BT_REAL
2247 && sym
->ts
.kind
== gfc_default_real_kind
2248 && !sym
->attr
.always_explicit
)
2250 /* Special case: f2c calling conventions require that (scalar)
2251 default REAL functions return the C type double instead. f2c
2252 compatibility is only an issue with functions that don't
2253 require an explicit interface, as only these could be
2254 implemented in Fortran 77. */
2255 sym
->ts
.kind
= gfc_default_double_kind
;
2256 type
= gfc_typenode_for_spec (&sym
->ts
);
2257 sym
->ts
.kind
= gfc_default_real_kind
;
2259 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
2260 /* Procedure pointer return values. */
2262 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
2264 /* Unset proc_pointer as gfc_get_function_type
2265 is called recursively. */
2266 sym
->result
->attr
.proc_pointer
= 0;
2267 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
2268 sym
->result
->attr
.proc_pointer
= 1;
2271 type
= gfc_sym_type (sym
->result
);
2274 type
= gfc_sym_type (sym
);
2276 type
= build_function_type (type
, typelist
);
2281 /* Language hooks for middle-end access to type nodes. */
2283 /* Return an integer type with BITS bits of precision,
2284 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2287 gfc_type_for_size (unsigned bits
, int unsignedp
)
2292 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
2294 tree type
= gfc_integer_types
[i
];
2295 if (type
&& bits
== TYPE_PRECISION (type
))
2299 /* Handle TImode as a special case because it is used by some backends
2300 (e.g. ARM) even though it is not available for normal use. */
2301 #if HOST_BITS_PER_WIDE_INT >= 64
2302 if (bits
== TYPE_PRECISION (intTI_type_node
))
2303 return intTI_type_node
;
2308 if (bits
== TYPE_PRECISION (unsigned_intQI_type_node
))
2309 return unsigned_intQI_type_node
;
2310 if (bits
== TYPE_PRECISION (unsigned_intHI_type_node
))
2311 return unsigned_intHI_type_node
;
2312 if (bits
== TYPE_PRECISION (unsigned_intSI_type_node
))
2313 return unsigned_intSI_type_node
;
2314 if (bits
== TYPE_PRECISION (unsigned_intDI_type_node
))
2315 return unsigned_intDI_type_node
;
2316 if (bits
== TYPE_PRECISION (unsigned_intTI_type_node
))
2317 return unsigned_intTI_type_node
;
2323 /* Return a data type that has machine mode MODE. If the mode is an
2324 integer, then UNSIGNEDP selects between signed and unsigned types. */
2327 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
2332 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
2333 base
= gfc_real_types
;
2334 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
2335 base
= gfc_complex_types
;
2336 else if (SCALAR_INT_MODE_P (mode
))
2337 return gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
2338 else if (VECTOR_MODE_P (mode
))
2340 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
2341 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
2342 if (inner_type
!= NULL_TREE
)
2343 return build_vector_type_for_mode (inner_type
, mode
);
2349 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
2351 tree type
= base
[i
];
2352 if (type
&& mode
== TYPE_MODE (type
))
2359 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2363 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
2366 bool indirect
= false;
2367 tree etype
, ptype
, field
, t
, base_decl
;
2368 tree data_off
, offset_off
, dim_off
, dim_size
, elem_size
;
2369 tree lower_suboff
, upper_suboff
, stride_suboff
;
2371 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2373 if (! POINTER_TYPE_P (type
))
2375 type
= TREE_TYPE (type
);
2376 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2381 rank
= GFC_TYPE_ARRAY_RANK (type
);
2382 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
2385 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
2386 gcc_assert (POINTER_TYPE_P (etype
));
2387 etype
= TREE_TYPE (etype
);
2388 gcc_assert (TREE_CODE (etype
) == ARRAY_TYPE
);
2389 etype
= TREE_TYPE (etype
);
2390 /* Can't handle variable sized elements yet. */
2391 if (int_size_in_bytes (etype
) <= 0)
2393 /* Nor non-constant lower bounds in assumed shape arrays. */
2394 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
)
2396 for (dim
= 0; dim
< rank
; dim
++)
2397 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
2398 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
2402 memset (info
, '\0', sizeof (*info
));
2403 info
->ndimensions
= rank
;
2404 info
->element_type
= etype
;
2405 ptype
= build_pointer_type (gfc_array_index_type
);
2408 info
->base_decl
= build_decl (VAR_DECL
, NULL_TREE
,
2409 build_pointer_type (ptype
));
2410 base_decl
= build1 (INDIRECT_REF
, ptype
, info
->base_decl
);
2413 info
->base_decl
= base_decl
= build_decl (VAR_DECL
, NULL_TREE
, ptype
);
2415 if (GFC_TYPE_ARRAY_SPAN (type
))
2416 elem_size
= GFC_TYPE_ARRAY_SPAN (type
);
2418 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
2419 field
= TYPE_FIELDS (TYPE_MAIN_VARIANT (type
));
2420 data_off
= byte_position (field
);
2421 field
= TREE_CHAIN (field
);
2422 offset_off
= byte_position (field
);
2423 field
= TREE_CHAIN (field
);
2424 field
= TREE_CHAIN (field
);
2425 dim_off
= byte_position (field
);
2426 dim_size
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field
)));
2427 field
= TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field
)));
2428 stride_suboff
= byte_position (field
);
2429 field
= TREE_CHAIN (field
);
2430 lower_suboff
= byte_position (field
);
2431 field
= TREE_CHAIN (field
);
2432 upper_suboff
= byte_position (field
);
2435 if (!integer_zerop (data_off
))
2436 t
= build2 (POINTER_PLUS_EXPR
, ptype
, t
, data_off
);
2437 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
2438 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
2439 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
2440 info
->allocated
= build2 (NE_EXPR
, boolean_type_node
,
2441 info
->data_location
, null_pointer_node
);
2442 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
)
2443 info
->associated
= build2 (NE_EXPR
, boolean_type_node
,
2444 info
->data_location
, null_pointer_node
);
2446 for (dim
= 0; dim
< rank
; dim
++)
2448 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2449 size_binop (PLUS_EXPR
, dim_off
, lower_suboff
));
2450 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2451 info
->dimen
[dim
].lower_bound
= t
;
2452 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2453 size_binop (PLUS_EXPR
, dim_off
, upper_suboff
));
2454 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2455 info
->dimen
[dim
].upper_bound
= t
;
2456 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
)
2458 /* Assumed shape arrays have known lower bounds. */
2459 info
->dimen
[dim
].upper_bound
2460 = build2 (MINUS_EXPR
, gfc_array_index_type
,
2461 info
->dimen
[dim
].upper_bound
,
2462 info
->dimen
[dim
].lower_bound
);
2463 info
->dimen
[dim
].lower_bound
2464 = fold_convert (gfc_array_index_type
,
2465 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
2466 info
->dimen
[dim
].upper_bound
2467 = build2 (PLUS_EXPR
, gfc_array_index_type
,
2468 info
->dimen
[dim
].lower_bound
,
2469 info
->dimen
[dim
].upper_bound
);
2471 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2472 size_binop (PLUS_EXPR
, dim_off
, stride_suboff
));
2473 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2474 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
2475 info
->dimen
[dim
].stride
= t
;
2476 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
2482 #include "gt-fortran-trans-types.h"