1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-types.c -- gfortran backend types */
28 #include "coretypes.h"
29 #include "tm.h" /* For INTMAX_TYPE, INT8_TYPE, INT16_TYPE, INT32_TYPE,
30 INT64_TYPE, INT_LEAST8_TYPE, INT_LEAST16_TYPE,
31 INT_LEAST32_TYPE, INT_LEAST64_TYPE, INT_FAST8_TYPE,
32 INT_FAST16_TYPE, INT_FAST32_TYPE, INT_FAST64_TYPE,
33 BOOL_TYPE_SIZE, BITS_PER_UNIT, POINTER_SIZE,
34 INT_TYPE_SIZE, CHAR_TYPE_SIZE, SHORT_TYPE_SIZE,
35 LONG_TYPE_SIZE, LONG_LONG_TYPE_SIZE,
36 FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE,
37 LONG_DOUBLE_TYPE_SIZE and LIBGCC2_HAS_TF_MODE. */
39 #include "langhooks.h" /* For iso-c-bindings.def. */
42 #include "diagnostic-core.h" /* For fatal_error. */
43 #include "toplev.h" /* For rest_of_decl_compilation. */
46 #include "trans-types.h"
47 #include "trans-const.h"
49 #include "dwarf2out.h" /* For struct array_descr_info. */
52 #if (GFC_MAX_DIMENSIONS < 10)
53 #define GFC_RANK_DIGITS 1
54 #define GFC_RANK_PRINTF_FORMAT "%01d"
55 #elif (GFC_MAX_DIMENSIONS < 100)
56 #define GFC_RANK_DIGITS 2
57 #define GFC_RANK_PRINTF_FORMAT "%02d"
59 #error If you really need >99 dimensions, continue the sequence above...
62 /* array of structs so we don't have to worry about xmalloc or free */
63 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
65 tree gfc_array_index_type
;
66 tree gfc_array_range_type
;
67 tree gfc_character1_type_node
;
69 tree prvoid_type_node
;
70 tree ppvoid_type_node
;
74 tree gfc_charlen_type_node
;
76 tree float128_type_node
= NULL_TREE
;
77 tree complex_float128_type_node
= NULL_TREE
;
79 bool gfc_real16_is_float128
= false;
81 static GTY(()) tree gfc_desc_dim_type
;
82 static GTY(()) tree gfc_max_array_element_size
;
83 static GTY(()) tree gfc_array_descriptor_base
[2 * GFC_MAX_DIMENSIONS
];
85 /* Arrays for all integral and real kinds. We'll fill this in at runtime
86 after the target has a chance to process command-line options. */
88 #define MAX_INT_KINDS 5
89 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
90 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
91 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
92 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
94 #define MAX_REAL_KINDS 5
95 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
96 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
97 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
99 #define MAX_CHARACTER_KINDS 2
100 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
101 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
102 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
104 static tree
gfc_add_field_to_struct_1 (tree
, tree
, tree
, tree
**);
106 /* The integer kind to use for array indices. This will be set to the
107 proper value based on target information from the backend. */
109 int gfc_index_integer_kind
;
111 /* The default kinds of the various types. */
113 int gfc_default_integer_kind
;
114 int gfc_max_integer_kind
;
115 int gfc_default_real_kind
;
116 int gfc_default_double_kind
;
117 int gfc_default_character_kind
;
118 int gfc_default_logical_kind
;
119 int gfc_default_complex_kind
;
122 /* The kind size used for record offsets. If the target system supports
123 kind=8, this will be set to 8, otherwise it is set to 4. */
126 /* The integer kind used to store character lengths. */
127 int gfc_charlen_int_kind
;
129 /* The size of the numeric storage unit and character storage unit. */
130 int gfc_numeric_storage_size
;
131 int gfc_character_storage_size
;
135 gfc_check_any_c_kind (gfc_typespec
*ts
)
139 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
141 /* Check for any C interoperable kind for the given type/kind in ts.
142 This can be used after verify_c_interop to make sure that the
143 Fortran kind being used exists in at least some form for C. */
144 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
145 c_interop_kinds_table
[i
].value
== ts
->kind
)
154 get_real_kind_from_node (tree type
)
158 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
159 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
160 return gfc_real_kinds
[i
].kind
;
166 get_int_kind_from_node (tree type
)
173 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
174 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
175 return gfc_integer_kinds
[i
].kind
;
180 /* Return a typenode for the "standard" C type with a given name. */
182 get_typenode_from_name (const char *name
)
184 if (name
== NULL
|| *name
== '\0')
187 if (strcmp (name
, "char") == 0)
188 return char_type_node
;
189 if (strcmp (name
, "unsigned char") == 0)
190 return unsigned_char_type_node
;
191 if (strcmp (name
, "signed char") == 0)
192 return signed_char_type_node
;
194 if (strcmp (name
, "short int") == 0)
195 return short_integer_type_node
;
196 if (strcmp (name
, "short unsigned int") == 0)
197 return short_unsigned_type_node
;
199 if (strcmp (name
, "int") == 0)
200 return integer_type_node
;
201 if (strcmp (name
, "unsigned int") == 0)
202 return unsigned_type_node
;
204 if (strcmp (name
, "long int") == 0)
205 return long_integer_type_node
;
206 if (strcmp (name
, "long unsigned int") == 0)
207 return long_unsigned_type_node
;
209 if (strcmp (name
, "long long int") == 0)
210 return long_long_integer_type_node
;
211 if (strcmp (name
, "long long unsigned int") == 0)
212 return long_long_unsigned_type_node
;
218 get_int_kind_from_name (const char *name
)
220 return get_int_kind_from_node (get_typenode_from_name (name
));
224 /* Get the kind number corresponding to an integer of given size,
225 following the required return values for ISO_FORTRAN_ENV INT* constants:
226 -2 is returned if we support a kind of larger size, -1 otherwise. */
228 gfc_get_int_kind_from_width_isofortranenv (int size
)
232 /* Look for a kind with matching storage size. */
233 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
234 if (gfc_integer_kinds
[i
].bit_size
== size
)
235 return gfc_integer_kinds
[i
].kind
;
237 /* Look for a kind with larger storage size. */
238 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
239 if (gfc_integer_kinds
[i
].bit_size
> size
)
245 /* Get the kind number corresponding to a real of given storage size,
246 following the required return values for ISO_FORTRAN_ENV REAL* constants:
247 -2 is returned if we support a kind of larger size, -1 otherwise. */
249 gfc_get_real_kind_from_width_isofortranenv (int size
)
255 /* Look for a kind with matching storage size. */
256 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
257 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
258 return gfc_real_kinds
[i
].kind
;
260 /* Look for a kind with larger storage size. */
261 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
262 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
271 get_int_kind_from_width (int size
)
275 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
276 if (gfc_integer_kinds
[i
].bit_size
== size
)
277 return gfc_integer_kinds
[i
].kind
;
283 get_int_kind_from_minimal_width (int size
)
287 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
288 if (gfc_integer_kinds
[i
].bit_size
>= size
)
289 return gfc_integer_kinds
[i
].kind
;
295 /* Generate the CInteropKind_t objects for the C interoperable
299 void init_c_interop_kinds (void)
303 /* init all pointers in the list to NULL */
304 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
306 /* Initialize the name and value fields. */
307 c_interop_kinds_table
[i
].name
[0] = '\0';
308 c_interop_kinds_table
[i
].value
= -100;
309 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
312 #define NAMED_INTCST(a,b,c,d) \
313 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
314 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
315 c_interop_kinds_table[a].value = c;
316 #define NAMED_REALCST(a,b,c) \
317 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
318 c_interop_kinds_table[a].f90_type = BT_REAL; \
319 c_interop_kinds_table[a].value = c;
320 #define NAMED_CMPXCST(a,b,c) \
321 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
322 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
323 c_interop_kinds_table[a].value = c;
324 #define NAMED_LOGCST(a,b,c) \
325 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
326 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
327 c_interop_kinds_table[a].value = c;
328 #define NAMED_CHARKNDCST(a,b,c) \
329 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
330 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
331 c_interop_kinds_table[a].value = c;
332 #define NAMED_CHARCST(a,b,c) \
333 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
334 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
335 c_interop_kinds_table[a].value = c;
336 #define DERIVED_TYPE(a,b,c) \
337 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
338 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
339 c_interop_kinds_table[a].value = c;
340 #define PROCEDURE(a,b) \
341 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
342 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
343 c_interop_kinds_table[a].value = 0;
344 #include "iso-c-binding.def"
345 #define NAMED_FUNCTION(a,b,c,d) \
346 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
347 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
348 c_interop_kinds_table[a].value = c;
349 #include "iso-c-binding.def"
353 /* Query the target to determine which machine modes are available for
354 computation. Choose KIND numbers for them. */
357 gfc_init_kinds (void)
360 int i_index
, r_index
, kind
;
361 bool saw_i4
= false, saw_i8
= false;
362 bool saw_r4
= false, saw_r8
= false, saw_r16
= false;
364 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
368 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
371 /* The middle end doesn't support constants larger than 2*HWI.
372 Perhaps the target hook shouldn't have accepted these either,
373 but just to be safe... */
374 bitsize
= GET_MODE_BITSIZE (mode
);
375 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
378 gcc_assert (i_index
!= MAX_INT_KINDS
);
380 /* Let the kind equal the bit size divided by 8. This insulates the
381 programmer from the underlying byte size. */
389 gfc_integer_kinds
[i_index
].kind
= kind
;
390 gfc_integer_kinds
[i_index
].radix
= 2;
391 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
392 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
394 gfc_logical_kinds
[i_index
].kind
= kind
;
395 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
400 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
401 used for large file access. */
408 /* If we do not at least have kind = 4, everything is pointless. */
411 /* Set the maximum integer kind. Used with at least BOZ constants. */
412 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
414 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
416 const struct real_format
*fmt
=
417 REAL_MODE_FORMAT ((enum machine_mode
) mode
);
422 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
425 /* Only let float, double, long double and __float128 go through.
426 Runtime support for others is not provided, so they would be
428 if (mode
!= TYPE_MODE (float_type_node
)
429 && (mode
!= TYPE_MODE (double_type_node
))
430 && (mode
!= TYPE_MODE (long_double_type_node
))
431 #if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
437 /* Let the kind equal the precision divided by 8, rounding up. Again,
438 this insulates the programmer from the underlying byte size.
440 Also, it effectively deals with IEEE extended formats. There, the
441 total size of the type may equal 16, but it's got 6 bytes of padding
442 and the increased size can get in the way of a real IEEE quad format
443 which may also be supported by the target.
445 We round up so as to handle IA-64 __floatreg (RFmode), which is an
446 82 bit type. Not to be confused with __float80 (XFmode), which is
447 an 80 bit type also supported by IA-64. So XFmode should come out
448 to be kind=10, and RFmode should come out to be kind=11. Egads. */
450 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
459 /* Careful we don't stumble a weird internal mode. */
460 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
461 /* Or have too many modes for the allocated space. */
462 gcc_assert (r_index
!= MAX_REAL_KINDS
);
464 gfc_real_kinds
[r_index
].kind
= kind
;
465 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
466 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
467 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
468 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
469 if (fmt
->pnan
< fmt
->p
)
470 /* This is an IBM extended double format (or the MIPS variant)
471 made up of two IEEE doubles. The value of the long double is
472 the sum of the values of the two parts. The most significant
473 part is required to be the value of the long double rounded
474 to the nearest double. If we use emax of 1024 then we can't
475 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
476 rounding will make the most significant part overflow. */
477 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
478 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
482 /* Choose the default integer kind. We choose 4 unless the user
483 directs us otherwise. */
484 if (gfc_option
.flag_default_integer
)
487 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
488 gfc_default_integer_kind
= 8;
490 /* Even if the user specified that the default integer kind be 8,
491 the numeric storage size isn't 64. In this case, a warning will
492 be issued when NUMERIC_STORAGE_SIZE is used. */
493 gfc_numeric_storage_size
= 4 * 8;
497 gfc_default_integer_kind
= 4;
498 gfc_numeric_storage_size
= 4 * 8;
502 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
503 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
506 /* Choose the default real kind. Again, we choose 4 when possible. */
507 if (gfc_option
.flag_default_real
)
510 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
511 gfc_default_real_kind
= 8;
514 gfc_default_real_kind
= 4;
516 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
518 /* Choose the default double kind. If -fdefault-real and -fdefault-double
519 are specified, we use kind=8, if it's available. If -fdefault-real is
520 specified without -fdefault-double, we use kind=16, if it's available.
521 Otherwise we do not change anything. */
522 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
523 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
525 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
526 gfc_default_double_kind
= 8;
527 else if (gfc_option
.flag_default_real
&& saw_r16
)
528 gfc_default_double_kind
= 16;
529 else if (saw_r4
&& saw_r8
)
530 gfc_default_double_kind
= 8;
533 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
534 real ... occupies two contiguous numeric storage units.
536 Therefore we must be supplied a kind twice as large as we chose
537 for single precision. There are loopholes, in that double
538 precision must *occupy* two storage units, though it doesn't have
539 to *use* two storage units. Which means that you can make this
540 kind artificially wide by padding it. But at present there are
541 no GCC targets for which a two-word type does not exist, so we
542 just let gfc_validate_kind abort and tell us if something breaks. */
544 gfc_default_double_kind
545 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
548 /* The default logical kind is constrained to be the same as the
549 default integer kind. Similarly with complex and real. */
550 gfc_default_logical_kind
= gfc_default_integer_kind
;
551 gfc_default_complex_kind
= gfc_default_real_kind
;
553 /* We only have two character kinds: ASCII and UCS-4.
554 ASCII corresponds to a 8-bit integer type, if one is available.
555 UCS-4 corresponds to a 32-bit integer type, if one is available. */
557 if ((kind
= get_int_kind_from_width (8)) > 0)
559 gfc_character_kinds
[i_index
].kind
= kind
;
560 gfc_character_kinds
[i_index
].bit_size
= 8;
561 gfc_character_kinds
[i_index
].name
= "ascii";
564 if ((kind
= get_int_kind_from_width (32)) > 0)
566 gfc_character_kinds
[i_index
].kind
= kind
;
567 gfc_character_kinds
[i_index
].bit_size
= 32;
568 gfc_character_kinds
[i_index
].name
= "iso_10646";
572 /* Choose the smallest integer kind for our default character. */
573 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
574 gfc_character_storage_size
= gfc_default_character_kind
* 8;
576 /* Choose the integer kind the same size as "void*" for our index kind. */
577 gfc_index_integer_kind
= POINTER_SIZE
/ 8;
578 /* Pick a kind the same size as the C "int" type. */
579 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
581 /* initialize the C interoperable kinds */
582 init_c_interop_kinds();
585 /* Make sure that a valid kind is present. Returns an index into the
586 associated kinds array, -1 if the kind is not present. */
589 validate_integer (int kind
)
593 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
594 if (gfc_integer_kinds
[i
].kind
== kind
)
601 validate_real (int kind
)
605 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
606 if (gfc_real_kinds
[i
].kind
== kind
)
613 validate_logical (int kind
)
617 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
618 if (gfc_logical_kinds
[i
].kind
== kind
)
625 validate_character (int kind
)
629 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
630 if (gfc_character_kinds
[i
].kind
== kind
)
636 /* Validate a kind given a basic type. The return value is the same
637 for the child functions, with -1 indicating nonexistence of the
638 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
641 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
647 case BT_REAL
: /* Fall through */
649 rc
= validate_real (kind
);
652 rc
= validate_integer (kind
);
655 rc
= validate_logical (kind
);
658 rc
= validate_character (kind
);
662 gfc_internal_error ("gfc_validate_kind(): Got bad type");
665 if (rc
< 0 && !may_fail
)
666 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
672 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
673 Reuse common type nodes where possible. Recognize if the kind matches up
674 with a C type. This will be used later in determining which routines may
675 be scarfed from libm. */
678 gfc_build_int_type (gfc_integer_info
*info
)
680 int mode_precision
= info
->bit_size
;
682 if (mode_precision
== CHAR_TYPE_SIZE
)
684 if (mode_precision
== SHORT_TYPE_SIZE
)
686 if (mode_precision
== INT_TYPE_SIZE
)
688 if (mode_precision
== LONG_TYPE_SIZE
)
690 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
691 info
->c_long_long
= 1;
693 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
694 return intQI_type_node
;
695 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
696 return intHI_type_node
;
697 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
698 return intSI_type_node
;
699 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
700 return intDI_type_node
;
701 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
702 return intTI_type_node
;
704 return make_signed_type (mode_precision
);
708 gfc_build_uint_type (int size
)
710 if (size
== CHAR_TYPE_SIZE
)
711 return unsigned_char_type_node
;
712 if (size
== SHORT_TYPE_SIZE
)
713 return short_unsigned_type_node
;
714 if (size
== INT_TYPE_SIZE
)
715 return unsigned_type_node
;
716 if (size
== LONG_TYPE_SIZE
)
717 return long_unsigned_type_node
;
718 if (size
== LONG_LONG_TYPE_SIZE
)
719 return long_long_unsigned_type_node
;
721 return make_unsigned_type (size
);
726 gfc_build_real_type (gfc_real_info
*info
)
728 int mode_precision
= info
->mode_precision
;
731 if (mode_precision
== FLOAT_TYPE_SIZE
)
733 if (mode_precision
== DOUBLE_TYPE_SIZE
)
735 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
736 info
->c_long_double
= 1;
737 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
739 info
->c_float128
= 1;
740 gfc_real16_is_float128
= true;
743 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
744 return float_type_node
;
745 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
746 return double_type_node
;
747 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
748 return long_double_type_node
;
750 new_type
= make_node (REAL_TYPE
);
751 TYPE_PRECISION (new_type
) = mode_precision
;
752 layout_type (new_type
);
757 gfc_build_complex_type (tree scalar_type
)
761 if (scalar_type
== NULL
)
763 if (scalar_type
== float_type_node
)
764 return complex_float_type_node
;
765 if (scalar_type
== double_type_node
)
766 return complex_double_type_node
;
767 if (scalar_type
== long_double_type_node
)
768 return complex_long_double_type_node
;
770 new_type
= make_node (COMPLEX_TYPE
);
771 TREE_TYPE (new_type
) = scalar_type
;
772 layout_type (new_type
);
777 gfc_build_logical_type (gfc_logical_info
*info
)
779 int bit_size
= info
->bit_size
;
782 if (bit_size
== BOOL_TYPE_SIZE
)
785 return boolean_type_node
;
788 new_type
= make_unsigned_type (bit_size
);
789 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
790 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
791 TYPE_PRECISION (new_type
) = 1;
797 /* Create the backend type nodes. We map them to their
798 equivalent C type, at least for now. We also give
799 names to the types here, and we push them in the
800 global binding level context.*/
803 gfc_init_types (void)
809 unsigned HOST_WIDE_INT hi
;
810 unsigned HOST_WIDE_INT lo
;
812 /* Create and name the types. */
813 #define PUSH_TYPE(name, node) \
814 pushdecl (build_decl (input_location, \
815 TYPE_DECL, get_identifier (name), node))
817 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
819 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
820 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
821 if (TYPE_STRING_FLAG (type
))
822 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
823 gfc_integer_types
[index
] = type
;
824 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
825 gfc_integer_kinds
[index
].kind
);
826 PUSH_TYPE (name_buf
, type
);
829 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
831 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
832 gfc_logical_types
[index
] = type
;
833 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
834 gfc_logical_kinds
[index
].kind
);
835 PUSH_TYPE (name_buf
, type
);
838 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
840 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
841 gfc_real_types
[index
] = type
;
842 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
843 gfc_real_kinds
[index
].kind
);
844 PUSH_TYPE (name_buf
, type
);
846 if (gfc_real_kinds
[index
].c_float128
)
847 float128_type_node
= type
;
849 type
= gfc_build_complex_type (type
);
850 gfc_complex_types
[index
] = type
;
851 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
852 gfc_real_kinds
[index
].kind
);
853 PUSH_TYPE (name_buf
, type
);
855 if (gfc_real_kinds
[index
].c_float128
)
856 complex_float128_type_node
= type
;
859 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
861 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
862 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
863 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
864 gfc_character_kinds
[index
].kind
);
865 PUSH_TYPE (name_buf
, type
);
866 gfc_character_types
[index
] = type
;
867 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
869 gfc_character1_type_node
= gfc_character_types
[0];
871 PUSH_TYPE ("byte", unsigned_char_type_node
);
872 PUSH_TYPE ("void", void_type_node
);
874 /* DBX debugging output gets upset if these aren't set. */
875 if (!TYPE_NAME (integer_type_node
))
876 PUSH_TYPE ("c_integer", integer_type_node
);
877 if (!TYPE_NAME (char_type_node
))
878 PUSH_TYPE ("c_char", char_type_node
);
882 pvoid_type_node
= build_pointer_type (void_type_node
);
883 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
884 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
885 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
887 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
889 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
890 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
891 since this function is called before gfc_init_constants. */
893 = build_range_type (gfc_array_index_type
,
894 build_int_cst (gfc_array_index_type
, 0),
897 /* The maximum array element size that can be handled is determined
898 by the number of bits available to store this field in the array
901 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
902 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
903 if (n
> HOST_BITS_PER_WIDE_INT
)
904 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
906 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
907 gfc_max_array_element_size
908 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
910 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
911 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
912 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
914 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
915 gfc_charlen_int_kind
= 4;
916 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
919 /* Get the type node for the given type and kind. */
922 gfc_get_int_type (int kind
)
924 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
925 return index
< 0 ? 0 : gfc_integer_types
[index
];
929 gfc_get_real_type (int kind
)
931 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
932 return index
< 0 ? 0 : gfc_real_types
[index
];
936 gfc_get_complex_type (int kind
)
938 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
939 return index
< 0 ? 0 : gfc_complex_types
[index
];
943 gfc_get_logical_type (int kind
)
945 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
946 return index
< 0 ? 0 : gfc_logical_types
[index
];
950 gfc_get_char_type (int kind
)
952 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
953 return index
< 0 ? 0 : gfc_character_types
[index
];
957 gfc_get_pchar_type (int kind
)
959 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
960 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
964 /* Create a character type with the given kind and length. */
967 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
971 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
972 type
= build_array_type (eltype
, bounds
);
973 TYPE_STRING_FLAG (type
) = 1;
979 gfc_get_character_type_len (int kind
, tree len
)
981 gfc_validate_kind (BT_CHARACTER
, kind
, false);
982 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
986 /* Get a type node for a character kind. */
989 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
993 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
995 return gfc_get_character_type_len (kind
, len
);
998 /* Covert a basic type. This will be an array for character types. */
1001 gfc_typenode_for_spec (gfc_typespec
* spec
)
1011 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1012 has been resolved. This is done so we can convert C_PTR and
1013 C_FUNPTR to simple variables that get translated to (void *). */
1014 if (spec
->f90_type
== BT_VOID
)
1017 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1018 basetype
= ptr_type_node
;
1020 basetype
= pfunc_type_node
;
1023 basetype
= gfc_get_int_type (spec
->kind
);
1027 basetype
= gfc_get_real_type (spec
->kind
);
1031 basetype
= gfc_get_complex_type (spec
->kind
);
1035 basetype
= gfc_get_logical_type (spec
->kind
);
1041 basetype
= gfc_get_character_type (spec
->kind
, NULL
);
1044 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1049 basetype
= gfc_get_derived_type (spec
->u
.derived
);
1051 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1052 type and kind to fit a (void *) and the basetype returned was a
1053 ptr_type_node. We need to pass up this new information to the
1054 symbol that was declared of type C_PTR or C_FUNPTR. */
1055 if (spec
->u
.derived
->attr
.is_iso_c
)
1057 spec
->type
= spec
->u
.derived
->ts
.type
;
1058 spec
->kind
= spec
->u
.derived
->ts
.kind
;
1059 spec
->f90_type
= spec
->u
.derived
->ts
.f90_type
;
1063 /* This is for the second arg to c_f_pointer and c_f_procpointer
1064 of the iso_c_binding module, to accept any ptr type. */
1065 basetype
= ptr_type_node
;
1066 if (spec
->f90_type
== BT_VOID
)
1069 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1070 basetype
= ptr_type_node
;
1072 basetype
= pfunc_type_node
;
1081 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1084 gfc_conv_array_bound (gfc_expr
* expr
)
1086 /* If expr is an integer constant, return that. */
1087 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1088 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1090 /* Otherwise return NULL. */
1095 gfc_get_element_type (tree type
)
1099 if (GFC_ARRAY_TYPE_P (type
))
1101 if (TREE_CODE (type
) == POINTER_TYPE
)
1102 type
= TREE_TYPE (type
);
1103 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1105 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1110 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1111 element
= TREE_TYPE (type
);
1116 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1117 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1119 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1120 element
= TREE_TYPE (element
);
1122 gcc_assert (TREE_CODE (element
) == ARRAY_TYPE
);
1123 element
= TREE_TYPE (element
);
1129 /* Build an array. This function is called from gfc_sym_type().
1130 Actually returns array descriptor type.
1132 Format of array descriptors is as follows:
1134 struct gfc_array_descriptor
1139 struct descriptor_dimension dimension[N_DIM];
1142 struct descriptor_dimension
1149 Translation code should use gfc_conv_descriptor_* rather than
1150 accessing the descriptor directly. Any changes to the array
1151 descriptor type will require changes in gfc_conv_descriptor_* and
1152 gfc_build_array_initializer.
1154 This is represented internally as a RECORD_TYPE. The index nodes
1155 are gfc_array_index_type and the data node is a pointer to the
1156 data. See below for the handling of character types.
1158 The dtype member is formatted as follows:
1159 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1160 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1161 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1163 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1164 this generated poor code for assumed/deferred size arrays. These
1165 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1166 of the GENERIC grammar. Also, there is no way to explicitly set
1167 the array stride, so all data must be packed(1). I've tried to
1168 mark all the functions which would require modification with a GCC
1171 The data component points to the first element in the array. The
1172 offset field is the position of the origin of the array (i.e. element
1173 (0, 0 ...)). This may be outside the bounds of the array.
1175 An element is accessed by
1176 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1177 This gives good performance as the computation does not involve the
1178 bounds of the array. For packed arrays, this is optimized further
1179 by substituting the known strides.
1181 This system has one problem: all array bounds must be within 2^31
1182 elements of the origin (2^63 on 64-bit machines). For example
1183 integer, dimension (80000:90000, 80000:90000, 2) :: array
1184 may not work properly on 32-bit machines because 80000*80000 >
1185 2^31, so the calculation for stride2 would overflow. This may
1186 still work, but I haven't checked, and it relies on the overflow
1187 doing the right thing.
1189 The way to fix this problem is to access elements as follows:
1190 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1191 Obviously this is much slower. I will make this a compile time
1192 option, something like -fsmall-array-offsets. Mixing code compiled
1193 with and without this switch will work.
1195 (1) This can be worked around by modifying the upper bound of the
1196 previous dimension. This requires extra fields in the descriptor
1197 (both real_ubound and fake_ubound). */
1200 /* Returns true if the array sym does not require a descriptor. */
1203 gfc_is_nodesc_array (gfc_symbol
* sym
)
1205 gcc_assert (sym
->attr
.dimension
|| sym
->attr
.codimension
);
1207 /* We only want local arrays. */
1208 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1211 /* We want a descriptor for associate-name arrays that do not have an
1212 explicitely known shape already. */
1213 if (sym
->assoc
&& sym
->as
->type
!= AS_EXPLICIT
)
1216 if (sym
->attr
.dummy
)
1217 return sym
->as
->type
!= AS_ASSUMED_SHAPE
;
1219 if (sym
->attr
.result
|| sym
->attr
.function
)
1222 gcc_assert (sym
->as
->type
== AS_EXPLICIT
|| sym
->as
->cp_was_assumed
);
1228 /* Create an array descriptor type. */
1231 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1232 enum gfc_array_kind akind
, bool restricted
,
1235 tree lbound
[GFC_MAX_DIMENSIONS
];
1236 tree ubound
[GFC_MAX_DIMENSIONS
];
1239 for (n
= 0; n
< as
->rank
; n
++)
1241 /* Create expressions for the known bounds of the array. */
1242 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1243 lbound
[n
] = gfc_index_one_node
;
1245 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1246 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1249 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1251 if (as
->lower
[n
] == NULL
)
1252 lbound
[n
] = gfc_index_one_node
;
1254 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1256 if (n
< as
->rank
+ as
->corank
- 1)
1257 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1260 if (as
->type
== AS_ASSUMED_SHAPE
)
1261 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1262 : GFC_ARRAY_ASSUMED_SHAPE
;
1263 return gfc_get_array_type_bounds (type
, as
->rank
, as
->corank
, lbound
,
1264 ubound
, 0, akind
, restricted
);
1267 /* Returns the struct descriptor_dimension type. */
1270 gfc_get_desc_dim_type (void)
1273 tree decl
, *chain
= NULL
;
1275 if (gfc_desc_dim_type
)
1276 return gfc_desc_dim_type
;
1278 /* Build the type node. */
1279 type
= make_node (RECORD_TYPE
);
1281 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1282 TYPE_PACKED (type
) = 1;
1284 /* Consists of the stride, lbound and ubound members. */
1285 decl
= gfc_add_field_to_struct_1 (type
,
1286 get_identifier ("stride"),
1287 gfc_array_index_type
, &chain
);
1288 TREE_NO_WARNING (decl
) = 1;
1290 decl
= gfc_add_field_to_struct_1 (type
,
1291 get_identifier ("lbound"),
1292 gfc_array_index_type
, &chain
);
1293 TREE_NO_WARNING (decl
) = 1;
1295 decl
= gfc_add_field_to_struct_1 (type
,
1296 get_identifier ("ubound"),
1297 gfc_array_index_type
, &chain
);
1298 TREE_NO_WARNING (decl
) = 1;
1300 /* Finish off the type. */
1301 gfc_finish_type (type
);
1302 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1304 gfc_desc_dim_type
= type
;
1309 /* Return the DTYPE for an array. This describes the type and type parameters
1311 /* TODO: Only call this when the value is actually used, and make all the
1312 unknown cases abort. */
1315 gfc_get_dtype (tree type
)
1325 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1327 if (GFC_TYPE_ARRAY_DTYPE (type
))
1328 return GFC_TYPE_ARRAY_DTYPE (type
);
1330 rank
= GFC_TYPE_ARRAY_RANK (type
);
1331 etype
= gfc_get_element_type (type
);
1333 switch (TREE_CODE (etype
))
1351 /* We will never have arrays of arrays. */
1361 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1362 /* We can strange array types for temporary arrays. */
1363 return gfc_index_zero_node
;
1366 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1367 size
= TYPE_SIZE_UNIT (etype
);
1369 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1370 if (size
&& INTEGER_CST_P (size
))
1372 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1373 internal_error ("Array element size too big");
1375 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1377 dtype
= build_int_cst (gfc_array_index_type
, i
);
1379 if (size
&& !INTEGER_CST_P (size
))
1381 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1382 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
,
1383 gfc_array_index_type
,
1384 fold_convert (gfc_array_index_type
, size
), tmp
);
1385 dtype
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1388 /* If we don't know the size we leave it as zero. This should never happen
1389 for anything that is actually used. */
1390 /* TODO: Check this is actually true, particularly when repacking
1391 assumed size parameters. */
1393 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1398 /* Build an array type for use without a descriptor, packed according
1399 to the value of PACKED. */
1402 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1416 mpz_init_set_ui (offset
, 0);
1417 mpz_init_set_ui (stride
, 1);
1420 /* We don't use build_array_type because this does not include include
1421 lang-specific information (i.e. the bounds of the array) when checking
1424 type
= make_node (ARRAY_TYPE
);
1427 type
= build_variant_type_copy (etype
);
1428 TREE_TYPE (type
) = etype
;
1431 GFC_ARRAY_TYPE_P (type
) = 1;
1432 TYPE_LANG_SPECIFIC (type
)
1433 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1435 known_stride
= (packed
!= PACKED_NO
);
1437 for (n
= 0; n
< as
->rank
; n
++)
1439 /* Fill in the stride and bound components of the type. */
1441 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1444 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1446 expr
= as
->lower
[n
];
1447 if (expr
->expr_type
== EXPR_CONSTANT
)
1449 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1450 gfc_index_integer_kind
);
1457 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1461 /* Calculate the offset. */
1462 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1463 mpz_sub (offset
, offset
, delta
);
1468 expr
= as
->upper
[n
];
1469 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1471 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1472 gfc_index_integer_kind
);
1479 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1483 /* Calculate the stride. */
1484 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1485 as
->lower
[n
]->value
.integer
);
1486 mpz_add_ui (delta
, delta
, 1);
1487 mpz_mul (stride
, stride
, delta
);
1490 /* Only the first stride is known for partial packed arrays. */
1491 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1494 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1496 expr
= as
->lower
[n
];
1497 if (expr
->expr_type
== EXPR_CONSTANT
)
1498 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1499 gfc_index_integer_kind
);
1502 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1504 expr
= as
->upper
[n
];
1505 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1506 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1507 gfc_index_integer_kind
);
1510 if (n
< as
->rank
+ as
->corank
- 1)
1511 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1516 GFC_TYPE_ARRAY_OFFSET (type
) =
1517 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1520 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1524 GFC_TYPE_ARRAY_SIZE (type
) =
1525 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1528 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1530 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1531 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1532 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1533 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1535 /* TODO: use main type if it is unbounded. */
1536 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1537 build_pointer_type (build_array_type (etype
, range
));
1539 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1540 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1541 TYPE_QUAL_RESTRICT
);
1545 if (packed
!= PACKED_STATIC
|| gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
1546 type
= build_pointer_type (type
);
1549 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1551 if (packed
!= PACKED_STATIC
|| gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
1553 GFC_ARRAY_TYPE_P (type
) = 1;
1554 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1562 mpz_sub_ui (stride
, stride
, 1);
1563 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1568 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1569 TYPE_DOMAIN (type
) = range
;
1571 build_pointer_type (etype
);
1572 TREE_TYPE (type
) = etype
;
1580 /* Represent packed arrays as multi-dimensional if they have rank >
1581 1 and with proper bounds, instead of flat arrays. This makes for
1582 better debug info. */
1585 tree gtype
= etype
, rtype
, type_decl
;
1587 for (n
= as
->rank
- 1; n
>= 0; n
--)
1589 rtype
= build_range_type (gfc_array_index_type
,
1590 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1591 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1592 gtype
= build_array_type (gtype
, rtype
);
1594 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1595 TYPE_DECL
, NULL
, gtype
);
1596 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1599 if (packed
!= PACKED_STATIC
|| !known_stride
1600 || (as
->corank
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
))
1602 /* For dummy arrays and automatic (heap allocated) arrays we
1603 want a pointer to the array. */
1604 type
= build_pointer_type (type
);
1606 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1607 GFC_ARRAY_TYPE_P (type
) = 1;
1608 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1613 /* Return or create the base type for an array descriptor. */
1616 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1618 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1619 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1620 int idx
= 2 * (codimen
+ dimen
- 1) + restricted
;
1622 gcc_assert (codimen
+ dimen
>= 1 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1623 if (gfc_array_descriptor_base
[idx
])
1624 return gfc_array_descriptor_base
[idx
];
1626 /* Build the type node. */
1627 fat_type
= make_node (RECORD_TYPE
);
1629 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1630 TYPE_NAME (fat_type
) = get_identifier (name
);
1631 TYPE_NAMELESS (fat_type
) = 1;
1633 /* Add the data member as the first element of the descriptor. */
1634 decl
= gfc_add_field_to_struct_1 (fat_type
,
1635 get_identifier ("data"),
1638 : ptr_type_node
), &chain
);
1640 /* Add the base component. */
1641 decl
= gfc_add_field_to_struct_1 (fat_type
,
1642 get_identifier ("offset"),
1643 gfc_array_index_type
, &chain
);
1644 TREE_NO_WARNING (decl
) = 1;
1646 /* Add the dtype component. */
1647 decl
= gfc_add_field_to_struct_1 (fat_type
,
1648 get_identifier ("dtype"),
1649 gfc_array_index_type
, &chain
);
1650 TREE_NO_WARNING (decl
) = 1;
1652 /* Build the array type for the stride and bound components. */
1654 build_array_type (gfc_get_desc_dim_type (),
1655 build_range_type (gfc_array_index_type
,
1656 gfc_index_zero_node
,
1657 gfc_rank_cst
[codimen
+ dimen
- 1]));
1659 decl
= gfc_add_field_to_struct_1 (fat_type
,
1660 get_identifier ("dim"),
1662 TREE_NO_WARNING (decl
) = 1;
1664 /* Finish off the type. */
1665 gfc_finish_type (fat_type
);
1666 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1668 gfc_array_descriptor_base
[idx
] = fat_type
;
1672 /* Build an array (descriptor) type with given bounds. */
1675 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1676 tree
* ubound
, int packed
,
1677 enum gfc_array_kind akind
, bool restricted
)
1679 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1680 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1681 const char *type_name
;
1684 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1685 fat_type
= build_distinct_type_copy (base_type
);
1686 /* Make sure that nontarget and target array type have the same canonical
1687 type (and same stub decl for debug info). */
1688 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1689 TYPE_CANONICAL (fat_type
) = base_type
;
1690 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1692 tmp
= TYPE_NAME (etype
);
1693 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1694 tmp
= DECL_NAME (tmp
);
1696 type_name
= IDENTIFIER_POINTER (tmp
);
1698 type_name
= "unknown";
1699 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1700 GFC_MAX_SYMBOL_LEN
, type_name
);
1701 TYPE_NAME (fat_type
) = get_identifier (name
);
1702 TYPE_NAMELESS (fat_type
) = 1;
1704 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1705 TYPE_LANG_SPECIFIC (fat_type
)
1706 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1708 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1709 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1710 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1711 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1713 /* Build an array descriptor record type. */
1715 stride
= gfc_index_one_node
;
1718 for (n
= 0; n
< dimen
+ codimen
; n
++)
1721 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1728 if (lower
!= NULL_TREE
)
1730 if (INTEGER_CST_P (lower
))
1731 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1736 if (codimen
&& n
== dimen
+ codimen
- 1)
1740 if (upper
!= NULL_TREE
)
1742 if (INTEGER_CST_P (upper
))
1743 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1751 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1753 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1754 gfc_array_index_type
, upper
, lower
);
1755 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1756 gfc_array_index_type
, tmp
,
1757 gfc_index_one_node
);
1758 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1759 gfc_array_index_type
, tmp
, stride
);
1760 /* Check the folding worked. */
1761 gcc_assert (INTEGER_CST_P (stride
));
1766 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1768 /* TODO: known offsets for descriptors. */
1769 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1771 /* We define data as an array with the correct size if possible.
1772 Much better than doing pointer arithmetic. */
1774 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1775 int_const_binop (MINUS_EXPR
, stride
,
1778 rtype
= gfc_array_range_type
;
1779 arraytype
= build_array_type (etype
, rtype
);
1780 arraytype
= build_pointer_type (arraytype
);
1782 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1783 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1785 /* This will generate the base declarations we need to emit debug
1786 information for this type. FIXME: there must be a better way to
1787 avoid divergence between compilations with and without debug
1790 struct array_descr_info info
;
1791 gfc_get_array_descr_info (fat_type
, &info
);
1792 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
1798 /* Build a pointer type. This function is called from gfc_sym_type(). */
1801 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1803 /* Array pointer types aren't actually pointers. */
1804 if (sym
->attr
.dimension
)
1807 return build_pointer_type (type
);
1810 static tree
gfc_nonrestricted_type (tree t
);
1811 /* Given two record or union type nodes TO and FROM, ensure
1812 that all fields in FROM have a corresponding field in TO,
1813 their type being nonrestrict variants. This accepts a TO
1814 node that already has a prefix of the fields in FROM. */
1816 mirror_fields (tree to
, tree from
)
1821 /* Forward to the end of TOs fields. */
1822 fto
= TYPE_FIELDS (to
);
1823 ffrom
= TYPE_FIELDS (from
);
1824 chain
= &TYPE_FIELDS (to
);
1827 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
1828 chain
= &DECL_CHAIN (fto
);
1829 fto
= DECL_CHAIN (fto
);
1830 ffrom
= DECL_CHAIN (ffrom
);
1833 /* Now add all fields remaining in FROM (starting with ffrom). */
1834 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
1836 tree newfield
= copy_node (ffrom
);
1837 DECL_CONTEXT (newfield
) = to
;
1838 /* The store to DECL_CHAIN might seem redundant with the
1839 stores to *chain, but not clearing it here would mean
1840 leaving a chain into the old fields. If ever
1841 our called functions would look at them confusion
1843 DECL_CHAIN (newfield
) = NULL_TREE
;
1845 chain
= &DECL_CHAIN (newfield
);
1847 if (TREE_CODE (ffrom
) == FIELD_DECL
)
1849 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
1850 TREE_TYPE (newfield
) = elemtype
;
1856 /* Given a type T, returns a different type of the same structure,
1857 except that all types it refers to (recursively) are always
1858 non-restrict qualified types. */
1860 gfc_nonrestricted_type (tree t
)
1864 /* If the type isn't layed out yet, don't copy it. If something
1865 needs it for real it should wait until the type got finished. */
1869 if (!TYPE_LANG_SPECIFIC (t
))
1870 TYPE_LANG_SPECIFIC (t
)
1871 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1872 /* If we're dealing with this very node already further up
1873 the call chain (recursion via pointers and struct members)
1874 we haven't yet determined if we really need a new type node.
1875 Assume we don't, return T itself. */
1876 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
1879 /* If we have calculated this all already, just return it. */
1880 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
1881 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
1883 /* Mark this type. */
1884 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
1886 switch (TREE_CODE (t
))
1892 case REFERENCE_TYPE
:
1894 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
1895 if (totype
== TREE_TYPE (t
))
1897 else if (TREE_CODE (t
) == POINTER_TYPE
)
1898 ret
= build_pointer_type (totype
);
1900 ret
= build_reference_type (totype
);
1901 ret
= build_qualified_type (ret
,
1902 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
1908 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
1909 if (elemtype
== TREE_TYPE (t
))
1913 ret
= build_variant_type_copy (t
);
1914 TREE_TYPE (ret
) = elemtype
;
1915 if (TYPE_LANG_SPECIFIC (t
)
1916 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
1918 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
1919 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
1920 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
1922 TYPE_LANG_SPECIFIC (ret
)
1923 = ggc_alloc_cleared_lang_type (sizeof (struct
1925 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
1926 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
1935 case QUAL_UNION_TYPE
:
1938 /* First determine if we need a new type at all.
1939 Careful, the two calls to gfc_nonrestricted_type per field
1940 might return different values. That happens exactly when
1941 one of the fields reaches back to this very record type
1942 (via pointers). The first calls will assume that we don't
1943 need to copy T (see the error_mark_node marking). If there
1944 are any reasons for copying T apart from having to copy T,
1945 we'll indeed copy it, and the second calls to
1946 gfc_nonrestricted_type will use that new node if they
1948 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
1949 if (TREE_CODE (field
) == FIELD_DECL
)
1951 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
1952 if (elemtype
!= TREE_TYPE (field
))
1957 ret
= build_variant_type_copy (t
);
1958 TYPE_FIELDS (ret
) = NULL_TREE
;
1960 /* Here we make sure that as soon as we know we have to copy
1961 T, that also fields reaching back to us will use the new
1962 copy. It's okay if that copy still contains the old fields,
1963 we won't look at them. */
1964 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
1965 mirror_fields (ret
, t
);
1970 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
1975 /* Return the type for a symbol. Special handling is required for character
1976 types to get the correct level of indirection.
1977 For functions return the return type.
1978 For subroutines return void_type_node.
1979 Calling this multiple times for the same symbol should be avoided,
1980 especially for character and array types. */
1983 gfc_sym_type (gfc_symbol
* sym
)
1989 /* Procedure Pointers inside COMMON blocks. */
1990 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
1992 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
1993 sym
->attr
.proc_pointer
= 0;
1994 type
= build_pointer_type (gfc_get_function_type (sym
));
1995 sym
->attr
.proc_pointer
= 1;
1999 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2000 return void_type_node
;
2002 /* In the case of a function the fake result variable may have a
2003 type different from the function type, so don't return early in
2005 if (sym
->backend_decl
&& !sym
->attr
.function
)
2006 return TREE_TYPE (sym
->backend_decl
);
2008 if (sym
->ts
.type
== BT_CHARACTER
2009 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2010 || (sym
->attr
.result
2011 && sym
->ns
->proc_name
2012 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
2013 type
= gfc_character1_type_node
;
2015 type
= gfc_typenode_for_spec (&sym
->ts
);
2017 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2022 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2023 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2025 type
= gfc_nonrestricted_type (type
);
2027 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2029 if (gfc_is_nodesc_array (sym
))
2031 /* If this is a character argument of unknown length, just use the
2033 if (sym
->ts
.type
!= BT_CHARACTER
2034 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2035 || sym
->ts
.u
.cl
->backend_decl
)
2037 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2044 if (sym
->attr
.cray_pointee
)
2045 GFC_POINTER_TYPE_P (type
) = 1;
2049 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2050 if (sym
->attr
.pointer
)
2051 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2052 : GFC_ARRAY_POINTER
;
2053 else if (sym
->attr
.allocatable
)
2054 akind
= GFC_ARRAY_ALLOCATABLE
;
2055 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2056 sym
->attr
.contiguous
);
2061 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2062 || gfc_is_associate_pointer (sym
))
2063 type
= gfc_build_pointer_type (sym
, type
);
2064 if (sym
->attr
.pointer
|| sym
->attr
.cray_pointee
)
2065 GFC_POINTER_TYPE_P (type
) = 1;
2068 /* We currently pass all parameters by reference.
2069 See f95_get_function_decl. For dummy function parameters return the
2073 /* We must use pointer types for potentially absent variables. The
2074 optimizers assume a reference type argument is never NULL. */
2075 if (sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
)
2076 type
= build_pointer_type (type
);
2079 type
= build_reference_type (type
);
2081 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2088 /* Layout and output debug info for a record type. */
2091 gfc_finish_type (tree type
)
2095 decl
= build_decl (input_location
,
2096 TYPE_DECL
, NULL_TREE
, type
);
2097 TYPE_STUB_DECL (type
) = decl
;
2099 rest_of_type_compilation (type
, 1);
2100 rest_of_decl_compilation (decl
, 1, 0);
2103 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2104 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2105 to the end of the field list pointed to by *CHAIN.
2107 Returns a pointer to the new field. */
2110 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2112 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2114 DECL_CONTEXT (decl
) = context
;
2115 DECL_CHAIN (decl
) = NULL_TREE
;
2116 if (TYPE_FIELDS (context
) == NULL_TREE
)
2117 TYPE_FIELDS (context
) = decl
;
2122 *chain
= &DECL_CHAIN (decl
);
2128 /* Like `gfc_add_field_to_struct_1', but adds alignment
2132 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2134 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2136 DECL_INITIAL (decl
) = 0;
2137 DECL_ALIGN (decl
) = 0;
2138 DECL_USER_ALIGN (decl
) = 0;
2144 /* Copy the backend_decl and component backend_decls if
2145 the two derived type symbols are "equal", as described
2146 in 4.4.2 and resolved by gfc_compare_derived_types. */
2149 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2152 gfc_component
*to_cm
;
2153 gfc_component
*from_cm
;
2155 if (from
->backend_decl
== NULL
2156 || !gfc_compare_derived_types (from
, to
))
2159 to
->backend_decl
= from
->backend_decl
;
2161 to_cm
= to
->components
;
2162 from_cm
= from
->components
;
2164 /* Copy the component declarations. If a component is itself
2165 a derived type, we need a copy of its component declarations.
2166 This is done by recursing into gfc_get_derived_type and
2167 ensures that the component's component declarations have
2168 been built. If it is a character, we need the character
2170 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2172 to_cm
->backend_decl
= from_cm
->backend_decl
;
2173 if (from_cm
->ts
.type
== BT_DERIVED
2174 && (!from_cm
->attr
.pointer
|| from_gsym
))
2175 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2176 else if (from_cm
->ts
.type
== BT_CLASS
2177 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2178 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2179 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2180 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2187 /* Build a tree node for a procedure pointer component. */
2190 gfc_get_ppc_type (gfc_component
* c
)
2194 /* Explicit interface. */
2195 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2196 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2198 /* Implicit interface (only return value may be known). */
2199 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2200 t
= gfc_typenode_for_spec (&c
->ts
);
2204 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2208 /* Build a tree node for a derived type. If there are equal
2209 derived types, with different local names, these are built
2210 at the same time. If an equal derived type has been built
2211 in a parent namespace, this is used. */
2214 gfc_get_derived_type (gfc_symbol
* derived
)
2216 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2217 tree canonical
= NULL_TREE
;
2219 bool got_canonical
= false;
2224 gcc_assert (derived
&& derived
->attr
.flavor
== FL_DERIVED
);
2226 /* See if it's one of the iso_c_binding derived types. */
2227 if (derived
->attr
.is_iso_c
== 1)
2229 if (derived
->backend_decl
)
2230 return derived
->backend_decl
;
2232 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2233 derived
->backend_decl
= ptr_type_node
;
2235 derived
->backend_decl
= pfunc_type_node
;
2237 derived
->ts
.kind
= gfc_index_integer_kind
;
2238 derived
->ts
.type
= BT_INTEGER
;
2239 /* Set the f90_type to BT_VOID as a way to recognize something of type
2240 BT_INTEGER that needs to fit a void * for the purpose of the
2241 iso_c_binding derived types. */
2242 derived
->ts
.f90_type
= BT_VOID
;
2244 return derived
->backend_decl
;
2247 /* If use associated, use the module type for this one. */
2248 if (gfc_option
.flag_whole_file
2249 && derived
->backend_decl
== NULL
2250 && derived
->attr
.use_assoc
2252 && gfc_get_module_backend_decl (derived
))
2253 goto copy_derived_types
;
2255 /* If a whole file compilation, the derived types from an earlier
2256 namespace can be used as the canonical type. */
2257 if (gfc_option
.flag_whole_file
2258 && derived
->backend_decl
== NULL
2259 && !derived
->attr
.use_assoc
2260 && gfc_global_ns_list
)
2262 for (ns
= gfc_global_ns_list
;
2263 ns
->translated
&& !got_canonical
;
2266 dt
= ns
->derived_types
;
2267 for (; dt
&& !canonical
; dt
= dt
->next
)
2269 gfc_copy_dt_decls_ifequal (dt
->derived
, derived
, true);
2270 if (derived
->backend_decl
)
2271 got_canonical
= true;
2276 /* Store up the canonical type to be added to this one. */
2279 if (TYPE_CANONICAL (derived
->backend_decl
))
2280 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2282 canonical
= derived
->backend_decl
;
2284 derived
->backend_decl
= NULL_TREE
;
2287 /* derived->backend_decl != 0 means we saw it before, but its
2288 components' backend_decl may have not been built. */
2289 if (derived
->backend_decl
)
2291 /* Its components' backend_decl have been built or we are
2292 seeing recursion through the formal arglist of a procedure
2293 pointer component. */
2294 if (TYPE_FIELDS (derived
->backend_decl
)
2295 || derived
->attr
.proc_pointer_comp
)
2296 return derived
->backend_decl
;
2298 typenode
= derived
->backend_decl
;
2302 /* We see this derived type first time, so build the type node. */
2303 typenode
= make_node (RECORD_TYPE
);
2304 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2305 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
2306 derived
->backend_decl
= typenode
;
2309 /* Go through the derived type components, building them as
2310 necessary. The reason for doing this now is that it is
2311 possible to recurse back to this derived type through a
2312 pointer component (PR24092). If this happens, the fields
2313 will be built and so we can return the type. */
2314 for (c
= derived
->components
; c
; c
= c
->next
)
2316 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2319 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
2320 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2321 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
);
2323 if (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.is_iso_c
)
2325 /* Need to copy the modified ts from the derived type. The
2326 typespec was modified because C_PTR/C_FUNPTR are translated
2327 into (void *) from derived types. */
2328 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2329 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2330 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2333 c
->initializer
->ts
.type
= c
->ts
.type
;
2334 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2335 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2336 c
->initializer
->expr_type
= EXPR_NULL
;
2341 if (TYPE_FIELDS (derived
->backend_decl
))
2342 return derived
->backend_decl
;
2344 /* Build the type member list. Install the newly created RECORD_TYPE
2345 node as DECL_CONTEXT of each FIELD_DECL. */
2346 for (c
= derived
->components
; c
; c
= c
->next
)
2348 if (c
->attr
.proc_pointer
)
2349 field_type
= gfc_get_ppc_type (c
);
2350 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2351 field_type
= c
->ts
.u
.derived
->backend_decl
;
2354 if (c
->ts
.type
== BT_CHARACTER
)
2356 /* Evaluate the string length. */
2357 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2358 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2361 field_type
= gfc_typenode_for_spec (&c
->ts
);
2364 /* This returns an array descriptor type. Initialization may be
2366 if (c
->attr
.dimension
&& !c
->attr
.proc_pointer
)
2368 if (c
->attr
.pointer
|| c
->attr
.allocatable
)
2370 enum gfc_array_kind akind
;
2371 if (c
->attr
.pointer
)
2372 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2373 : GFC_ARRAY_POINTER
;
2375 akind
= GFC_ARRAY_ALLOCATABLE
;
2376 /* Pointers to arrays aren't actually pointer types. The
2377 descriptors are separate, but the data is common. */
2378 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2380 && !c
->attr
.pointer
,
2381 c
->attr
.contiguous
);
2384 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2388 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
)
2389 && !c
->attr
.proc_pointer
)
2390 field_type
= build_pointer_type (field_type
);
2392 /* vtype fields can point to different types to the base type. */
2393 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.vtype
)
2394 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2397 field
= gfc_add_field_to_struct (typenode
,
2398 get_identifier (c
->name
),
2399 field_type
, &chain
);
2401 gfc_set_decl_location (field
, &c
->loc
);
2402 else if (derived
->declared_at
.lb
)
2403 gfc_set_decl_location (field
, &derived
->declared_at
);
2405 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2408 if (!c
->backend_decl
)
2409 c
->backend_decl
= field
;
2412 /* Now lay out the derived type, including the fields. */
2414 TYPE_CANONICAL (typenode
) = canonical
;
2416 gfc_finish_type (typenode
);
2417 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2418 if (derived
->module
&& derived
->ns
->proc_name
2419 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2421 if (derived
->ns
->proc_name
->backend_decl
2422 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2425 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2426 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2427 = derived
->ns
->proc_name
->backend_decl
;
2431 derived
->backend_decl
= typenode
;
2435 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2436 gfc_copy_dt_decls_ifequal (derived
, dt
->derived
, false);
2438 return derived
->backend_decl
;
2443 gfc_return_by_reference (gfc_symbol
* sym
)
2445 if (!sym
->attr
.function
)
2448 if (sym
->attr
.dimension
)
2451 if (sym
->ts
.type
== BT_CHARACTER
2452 && !sym
->attr
.is_bind_c
2453 && (!sym
->attr
.result
2454 || !sym
->ns
->proc_name
2455 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2458 /* Possibly return complex numbers by reference for g77 compatibility.
2459 We don't do this for calls to intrinsics (as the library uses the
2460 -fno-f2c calling convention), nor for calls to functions which always
2461 require an explicit interface, as no compatibility problems can
2463 if (gfc_option
.flag_f2c
2464 && sym
->ts
.type
== BT_COMPLEX
2465 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2472 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2476 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2477 gfc_entry_list
*el
, *el2
;
2479 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2480 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2482 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2484 /* Build the type node. */
2485 type
= make_node (UNION_TYPE
);
2487 TYPE_NAME (type
) = get_identifier (name
);
2489 for (el
= ns
->entries
; el
; el
= el
->next
)
2491 /* Search for duplicates. */
2492 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2493 if (el2
->sym
->result
== el
->sym
->result
)
2497 gfc_add_field_to_struct_1 (type
,
2498 get_identifier (el
->sym
->result
->name
),
2499 gfc_sym_type (el
->sym
->result
), &chain
);
2502 /* Finish off the type. */
2503 gfc_finish_type (type
);
2504 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2508 /* Create a "fn spec" based on the formal arguments;
2509 cf. create_function_arglist. */
2512 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2516 gfc_formal_arglist
*f
;
2519 memset (&spec
, 0, sizeof (spec
));
2523 if (sym
->attr
.entry_master
)
2524 spec
[spec_len
++] = 'R';
2525 if (gfc_return_by_reference (sym
))
2527 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2529 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2530 spec
[spec_len
++] = '.';
2532 spec
[spec_len
++] = 'w';
2533 if (sym
->ts
.type
== BT_CHARACTER
)
2534 spec
[spec_len
++] = 'R';
2537 for (f
= sym
->formal
; f
; f
= f
->next
)
2538 if (spec_len
< sizeof (spec
))
2540 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2541 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2542 || (f
->sym
->ts
.type
== BT_DERIVED
2543 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2544 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2545 || (f
->sym
->ts
.type
== BT_CLASS
2546 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2547 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2548 spec
[spec_len
++] = '.';
2549 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2550 spec
[spec_len
++] = 'r';
2552 spec
[spec_len
++] = 'w';
2555 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2556 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2557 return build_type_attribute_variant (fntype
, tmp
);
2562 gfc_get_function_type (gfc_symbol
* sym
)
2565 VEC(tree
,gc
) *typelist
;
2566 gfc_formal_arglist
*f
;
2568 int alternate_return
;
2569 bool is_varargs
= true;
2571 /* Make sure this symbol is a function, a subroutine or the main
2573 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2574 || sym
->attr
.flavor
== FL_PROGRAM
);
2576 if (sym
->backend_decl
)
2577 return TREE_TYPE (sym
->backend_decl
);
2579 alternate_return
= 0;
2582 if (sym
->attr
.entry_master
)
2583 /* Additional parameter for selecting an entry point. */
2584 VEC_safe_push (tree
, gc
, typelist
, gfc_array_index_type
);
2591 if (arg
->ts
.type
== BT_CHARACTER
)
2592 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2594 /* Some functions we use an extra parameter for the return value. */
2595 if (gfc_return_by_reference (sym
))
2597 type
= gfc_sym_type (arg
);
2598 if (arg
->ts
.type
== BT_COMPLEX
2599 || arg
->attr
.dimension
2600 || arg
->ts
.type
== BT_CHARACTER
)
2601 type
= build_reference_type (type
);
2603 VEC_safe_push (tree
, gc
, typelist
, type
);
2604 if (arg
->ts
.type
== BT_CHARACTER
)
2606 if (!arg
->ts
.deferred
)
2607 /* Transfer by value. */
2608 VEC_safe_push (tree
, gc
, typelist
, gfc_charlen_type_node
);
2610 /* Deferred character lengths are transferred by reference
2611 so that the value can be returned. */
2612 VEC_safe_push (tree
, gc
, typelist
,
2613 build_pointer_type (gfc_charlen_type_node
));
2617 /* Build the argument types for the function. */
2618 for (f
= sym
->formal
; f
; f
= f
->next
)
2623 /* Evaluate constant character lengths here so that they can be
2624 included in the type. */
2625 if (arg
->ts
.type
== BT_CHARACTER
)
2626 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2628 if (arg
->attr
.flavor
== FL_PROCEDURE
)
2630 type
= gfc_get_function_type (arg
);
2631 type
= build_pointer_type (type
);
2634 type
= gfc_sym_type (arg
);
2636 /* Parameter Passing Convention
2638 We currently pass all parameters by reference.
2639 Parameters with INTENT(IN) could be passed by value.
2640 The problem arises if a function is called via an implicit
2641 prototype. In this situation the INTENT is not known.
2642 For this reason all parameters to global functions must be
2643 passed by reference. Passing by value would potentially
2644 generate bad code. Worse there would be no way of telling that
2645 this code was bad, except that it would give incorrect results.
2647 Contained procedures could pass by value as these are never
2648 used without an explicit interface, and cannot be passed as
2649 actual parameters for a dummy procedure. */
2651 VEC_safe_push (tree
, gc
, typelist
, type
);
2655 if (sym
->attr
.subroutine
)
2656 alternate_return
= 1;
2660 /* Add hidden string length parameters. */
2661 for (f
= sym
->formal
; f
; f
= f
->next
)
2664 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2666 if (!arg
->ts
.deferred
)
2667 /* Transfer by value. */
2668 type
= gfc_charlen_type_node
;
2670 /* Deferred character lengths are transferred by reference
2671 so that the value can be returned. */
2672 type
= build_pointer_type (gfc_charlen_type_node
);
2674 VEC_safe_push (tree
, gc
, typelist
, type
);
2678 if (!VEC_empty (tree
, typelist
)
2679 || sym
->attr
.is_main_program
2680 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
2683 if (alternate_return
)
2684 type
= integer_type_node
;
2685 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
2686 type
= void_type_node
;
2687 else if (sym
->attr
.mixed_entry_master
)
2688 type
= gfc_get_mixed_entry_union (sym
->ns
);
2689 else if (gfc_option
.flag_f2c
2690 && sym
->ts
.type
== BT_REAL
2691 && sym
->ts
.kind
== gfc_default_real_kind
2692 && !sym
->attr
.always_explicit
)
2694 /* Special case: f2c calling conventions require that (scalar)
2695 default REAL functions return the C type double instead. f2c
2696 compatibility is only an issue with functions that don't
2697 require an explicit interface, as only these could be
2698 implemented in Fortran 77. */
2699 sym
->ts
.kind
= gfc_default_double_kind
;
2700 type
= gfc_typenode_for_spec (&sym
->ts
);
2701 sym
->ts
.kind
= gfc_default_real_kind
;
2703 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
2704 /* Procedure pointer return values. */
2706 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
2708 /* Unset proc_pointer as gfc_get_function_type
2709 is called recursively. */
2710 sym
->result
->attr
.proc_pointer
= 0;
2711 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
2712 sym
->result
->attr
.proc_pointer
= 1;
2715 type
= gfc_sym_type (sym
->result
);
2718 type
= gfc_sym_type (sym
);
2721 type
= build_varargs_function_type_vec (type
, typelist
);
2723 type
= build_function_type_vec (type
, typelist
);
2724 type
= create_fn_spec (sym
, type
);
2729 /* Language hooks for middle-end access to type nodes. */
2731 /* Return an integer type with BITS bits of precision,
2732 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2735 gfc_type_for_size (unsigned bits
, int unsignedp
)
2740 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
2742 tree type
= gfc_integer_types
[i
];
2743 if (type
&& bits
== TYPE_PRECISION (type
))
2747 /* Handle TImode as a special case because it is used by some backends
2748 (e.g. ARM) even though it is not available for normal use. */
2749 #if HOST_BITS_PER_WIDE_INT >= 64
2750 if (bits
== TYPE_PRECISION (intTI_type_node
))
2751 return intTI_type_node
;
2756 if (bits
== TYPE_PRECISION (unsigned_intQI_type_node
))
2757 return unsigned_intQI_type_node
;
2758 if (bits
== TYPE_PRECISION (unsigned_intHI_type_node
))
2759 return unsigned_intHI_type_node
;
2760 if (bits
== TYPE_PRECISION (unsigned_intSI_type_node
))
2761 return unsigned_intSI_type_node
;
2762 if (bits
== TYPE_PRECISION (unsigned_intDI_type_node
))
2763 return unsigned_intDI_type_node
;
2764 if (bits
== TYPE_PRECISION (unsigned_intTI_type_node
))
2765 return unsigned_intTI_type_node
;
2771 /* Return a data type that has machine mode MODE. If the mode is an
2772 integer, then UNSIGNEDP selects between signed and unsigned types. */
2775 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
2780 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
2781 base
= gfc_real_types
;
2782 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
2783 base
= gfc_complex_types
;
2784 else if (SCALAR_INT_MODE_P (mode
))
2785 return gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
2786 else if (VECTOR_MODE_P (mode
))
2788 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
2789 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
2790 if (inner_type
!= NULL_TREE
)
2791 return build_vector_type_for_mode (inner_type
, mode
);
2797 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
2799 tree type
= base
[i
];
2800 if (type
&& mode
== TYPE_MODE (type
))
2807 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2811 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
2814 bool indirect
= false;
2815 tree etype
, ptype
, field
, t
, base_decl
;
2816 tree data_off
, dim_off
, dim_size
, elem_size
;
2817 tree lower_suboff
, upper_suboff
, stride_suboff
;
2819 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2821 if (! POINTER_TYPE_P (type
))
2823 type
= TREE_TYPE (type
);
2824 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2829 rank
= GFC_TYPE_ARRAY_RANK (type
);
2830 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
2833 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
2834 gcc_assert (POINTER_TYPE_P (etype
));
2835 etype
= TREE_TYPE (etype
);
2836 gcc_assert (TREE_CODE (etype
) == ARRAY_TYPE
);
2837 etype
= TREE_TYPE (etype
);
2838 /* Can't handle variable sized elements yet. */
2839 if (int_size_in_bytes (etype
) <= 0)
2841 /* Nor non-constant lower bounds in assumed shape arrays. */
2842 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
2843 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
2845 for (dim
= 0; dim
< rank
; dim
++)
2846 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
2847 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
2851 memset (info
, '\0', sizeof (*info
));
2852 info
->ndimensions
= rank
;
2853 info
->element_type
= etype
;
2854 ptype
= build_pointer_type (gfc_array_index_type
);
2855 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
2858 base_decl
= build_decl (input_location
, VAR_DECL
, NULL_TREE
,
2859 indirect
? build_pointer_type (ptype
) : ptype
);
2860 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
2862 info
->base_decl
= base_decl
;
2864 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
2866 if (GFC_TYPE_ARRAY_SPAN (type
))
2867 elem_size
= GFC_TYPE_ARRAY_SPAN (type
);
2869 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
2870 field
= TYPE_FIELDS (TYPE_MAIN_VARIANT (type
));
2871 data_off
= byte_position (field
);
2872 field
= DECL_CHAIN (field
);
2873 field
= DECL_CHAIN (field
);
2874 field
= DECL_CHAIN (field
);
2875 dim_off
= byte_position (field
);
2876 dim_size
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field
)));
2877 field
= TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field
)));
2878 stride_suboff
= byte_position (field
);
2879 field
= DECL_CHAIN (field
);
2880 lower_suboff
= byte_position (field
);
2881 field
= DECL_CHAIN (field
);
2882 upper_suboff
= byte_position (field
);
2885 if (!integer_zerop (data_off
))
2886 t
= build2 (POINTER_PLUS_EXPR
, ptype
, t
, data_off
);
2887 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
2888 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
2889 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
2890 info
->allocated
= build2 (NE_EXPR
, boolean_type_node
,
2891 info
->data_location
, null_pointer_node
);
2892 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
2893 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
2894 info
->associated
= build2 (NE_EXPR
, boolean_type_node
,
2895 info
->data_location
, null_pointer_node
);
2897 for (dim
= 0; dim
< rank
; dim
++)
2899 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2900 size_binop (PLUS_EXPR
, dim_off
, lower_suboff
));
2901 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2902 info
->dimen
[dim
].lower_bound
= t
;
2903 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2904 size_binop (PLUS_EXPR
, dim_off
, upper_suboff
));
2905 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2906 info
->dimen
[dim
].upper_bound
= t
;
2907 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
2908 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
2910 /* Assumed shape arrays have known lower bounds. */
2911 info
->dimen
[dim
].upper_bound
2912 = build2 (MINUS_EXPR
, gfc_array_index_type
,
2913 info
->dimen
[dim
].upper_bound
,
2914 info
->dimen
[dim
].lower_bound
);
2915 info
->dimen
[dim
].lower_bound
2916 = fold_convert (gfc_array_index_type
,
2917 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
2918 info
->dimen
[dim
].upper_bound
2919 = build2 (PLUS_EXPR
, gfc_array_index_type
,
2920 info
->dimen
[dim
].lower_bound
,
2921 info
->dimen
[dim
].upper_bound
);
2923 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2924 size_binop (PLUS_EXPR
, dim_off
, stride_suboff
));
2925 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2926 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
2927 info
->dimen
[dim
].stride
= t
;
2928 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
2934 #include "gt-fortran-trans-types.h"