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
;
121 int gfc_atomic_int_kind
;
122 int gfc_atomic_logical_kind
;
124 /* The kind size used for record offsets. If the target system supports
125 kind=8, this will be set to 8, otherwise it is set to 4. */
128 /* The integer kind used to store character lengths. */
129 int gfc_charlen_int_kind
;
131 /* The size of the numeric storage unit and character storage unit. */
132 int gfc_numeric_storage_size
;
133 int gfc_character_storage_size
;
137 gfc_check_any_c_kind (gfc_typespec
*ts
)
141 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
143 /* Check for any C interoperable kind for the given type/kind in ts.
144 This can be used after verify_c_interop to make sure that the
145 Fortran kind being used exists in at least some form for C. */
146 if (c_interop_kinds_table
[i
].f90_type
== ts
->type
&&
147 c_interop_kinds_table
[i
].value
== ts
->kind
)
156 get_real_kind_from_node (tree type
)
160 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
161 if (gfc_real_kinds
[i
].mode_precision
== TYPE_PRECISION (type
))
162 return gfc_real_kinds
[i
].kind
;
168 get_int_kind_from_node (tree type
)
175 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
176 if (gfc_integer_kinds
[i
].bit_size
== TYPE_PRECISION (type
))
177 return gfc_integer_kinds
[i
].kind
;
182 /* Return a typenode for the "standard" C type with a given name. */
184 get_typenode_from_name (const char *name
)
186 if (name
== NULL
|| *name
== '\0')
189 if (strcmp (name
, "char") == 0)
190 return char_type_node
;
191 if (strcmp (name
, "unsigned char") == 0)
192 return unsigned_char_type_node
;
193 if (strcmp (name
, "signed char") == 0)
194 return signed_char_type_node
;
196 if (strcmp (name
, "short int") == 0)
197 return short_integer_type_node
;
198 if (strcmp (name
, "short unsigned int") == 0)
199 return short_unsigned_type_node
;
201 if (strcmp (name
, "int") == 0)
202 return integer_type_node
;
203 if (strcmp (name
, "unsigned int") == 0)
204 return unsigned_type_node
;
206 if (strcmp (name
, "long int") == 0)
207 return long_integer_type_node
;
208 if (strcmp (name
, "long unsigned int") == 0)
209 return long_unsigned_type_node
;
211 if (strcmp (name
, "long long int") == 0)
212 return long_long_integer_type_node
;
213 if (strcmp (name
, "long long unsigned int") == 0)
214 return long_long_unsigned_type_node
;
220 get_int_kind_from_name (const char *name
)
222 return get_int_kind_from_node (get_typenode_from_name (name
));
226 /* Get the kind number corresponding to an integer of given size,
227 following the required return values for ISO_FORTRAN_ENV INT* constants:
228 -2 is returned if we support a kind of larger size, -1 otherwise. */
230 gfc_get_int_kind_from_width_isofortranenv (int size
)
234 /* Look for a kind with matching storage size. */
235 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
236 if (gfc_integer_kinds
[i
].bit_size
== size
)
237 return gfc_integer_kinds
[i
].kind
;
239 /* Look for a kind with larger storage size. */
240 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
241 if (gfc_integer_kinds
[i
].bit_size
> size
)
247 /* Get the kind number corresponding to a real of given storage size,
248 following the required return values for ISO_FORTRAN_ENV REAL* constants:
249 -2 is returned if we support a kind of larger size, -1 otherwise. */
251 gfc_get_real_kind_from_width_isofortranenv (int size
)
257 /* Look for a kind with matching storage size. */
258 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
259 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
260 return gfc_real_kinds
[i
].kind
;
262 /* Look for a kind with larger storage size. */
263 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
264 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
273 get_int_kind_from_width (int size
)
277 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
278 if (gfc_integer_kinds
[i
].bit_size
== size
)
279 return gfc_integer_kinds
[i
].kind
;
285 get_int_kind_from_minimal_width (int size
)
289 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
290 if (gfc_integer_kinds
[i
].bit_size
>= size
)
291 return gfc_integer_kinds
[i
].kind
;
297 /* Generate the CInteropKind_t objects for the C interoperable
301 void init_c_interop_kinds (void)
305 /* init all pointers in the list to NULL */
306 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
308 /* Initialize the name and value fields. */
309 c_interop_kinds_table
[i
].name
[0] = '\0';
310 c_interop_kinds_table
[i
].value
= -100;
311 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
314 #define NAMED_INTCST(a,b,c,d) \
315 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
316 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
317 c_interop_kinds_table[a].value = c;
318 #define NAMED_REALCST(a,b,c) \
319 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
320 c_interop_kinds_table[a].f90_type = BT_REAL; \
321 c_interop_kinds_table[a].value = c;
322 #define NAMED_CMPXCST(a,b,c) \
323 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
324 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
325 c_interop_kinds_table[a].value = c;
326 #define NAMED_LOGCST(a,b,c) \
327 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
328 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
329 c_interop_kinds_table[a].value = c;
330 #define NAMED_CHARKNDCST(a,b,c) \
331 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
332 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
333 c_interop_kinds_table[a].value = c;
334 #define NAMED_CHARCST(a,b,c) \
335 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
336 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
337 c_interop_kinds_table[a].value = c;
338 #define DERIVED_TYPE(a,b,c) \
339 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
340 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
341 c_interop_kinds_table[a].value = c;
342 #define PROCEDURE(a,b) \
343 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
344 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
345 c_interop_kinds_table[a].value = 0;
346 #include "iso-c-binding.def"
347 #define NAMED_FUNCTION(a,b,c,d) \
348 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
349 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
350 c_interop_kinds_table[a].value = c;
351 #include "iso-c-binding.def"
355 /* Query the target to determine which machine modes are available for
356 computation. Choose KIND numbers for them. */
359 gfc_init_kinds (void)
362 int i_index
, r_index
, kind
;
363 bool saw_i4
= false, saw_i8
= false;
364 bool saw_r4
= false, saw_r8
= false, saw_r16
= false;
366 for (i_index
= 0, mode
= MIN_MODE_INT
; mode
<= MAX_MODE_INT
; mode
++)
370 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
373 /* The middle end doesn't support constants larger than 2*HWI.
374 Perhaps the target hook shouldn't have accepted these either,
375 but just to be safe... */
376 bitsize
= GET_MODE_BITSIZE (mode
);
377 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
380 gcc_assert (i_index
!= MAX_INT_KINDS
);
382 /* Let the kind equal the bit size divided by 8. This insulates the
383 programmer from the underlying byte size. */
391 gfc_integer_kinds
[i_index
].kind
= kind
;
392 gfc_integer_kinds
[i_index
].radix
= 2;
393 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
394 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
396 gfc_logical_kinds
[i_index
].kind
= kind
;
397 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
402 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
403 used for large file access. */
410 /* If we do not at least have kind = 4, everything is pointless. */
413 /* Set the maximum integer kind. Used with at least BOZ constants. */
414 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
416 for (r_index
= 0, mode
= MIN_MODE_FLOAT
; mode
<= MAX_MODE_FLOAT
; mode
++)
418 const struct real_format
*fmt
=
419 REAL_MODE_FORMAT ((enum machine_mode
) mode
);
424 if (!targetm
.scalar_mode_supported_p ((enum machine_mode
) mode
))
427 /* Only let float, double, long double and __float128 go through.
428 Runtime support for others is not provided, so they would be
430 if (mode
!= TYPE_MODE (float_type_node
)
431 && (mode
!= TYPE_MODE (double_type_node
))
432 && (mode
!= TYPE_MODE (long_double_type_node
))
433 #if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
439 /* Let the kind equal the precision divided by 8, rounding up. Again,
440 this insulates the programmer from the underlying byte size.
442 Also, it effectively deals with IEEE extended formats. There, the
443 total size of the type may equal 16, but it's got 6 bytes of padding
444 and the increased size can get in the way of a real IEEE quad format
445 which may also be supported by the target.
447 We round up so as to handle IA-64 __floatreg (RFmode), which is an
448 82 bit type. Not to be confused with __float80 (XFmode), which is
449 an 80 bit type also supported by IA-64. So XFmode should come out
450 to be kind=10, and RFmode should come out to be kind=11. Egads. */
452 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
461 /* Careful we don't stumble a weird internal mode. */
462 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
463 /* Or have too many modes for the allocated space. */
464 gcc_assert (r_index
!= MAX_REAL_KINDS
);
466 gfc_real_kinds
[r_index
].kind
= kind
;
467 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
468 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
469 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
470 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
471 if (fmt
->pnan
< fmt
->p
)
472 /* This is an IBM extended double format (or the MIPS variant)
473 made up of two IEEE doubles. The value of the long double is
474 the sum of the values of the two parts. The most significant
475 part is required to be the value of the long double rounded
476 to the nearest double. If we use emax of 1024 then we can't
477 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
478 rounding will make the most significant part overflow. */
479 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
480 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
484 /* Choose the default integer kind. We choose 4 unless the user
485 directs us otherwise. */
486 if (gfc_option
.flag_default_integer
)
489 fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
490 gfc_default_integer_kind
= 8;
492 /* Even if the user specified that the default integer kind be 8,
493 the numeric storage size isn't 64. In this case, a warning will
494 be issued when NUMERIC_STORAGE_SIZE is used. */
495 gfc_numeric_storage_size
= 4 * 8;
499 gfc_default_integer_kind
= 4;
500 gfc_numeric_storage_size
= 4 * 8;
504 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
505 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
508 /* Choose the default real kind. Again, we choose 4 when possible. */
509 if (gfc_option
.flag_default_real
)
512 fatal_error ("real kind=8 not available for -fdefault-real-8 option");
513 gfc_default_real_kind
= 8;
516 gfc_default_real_kind
= 4;
518 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
520 /* Choose the default double kind. If -fdefault-real and -fdefault-double
521 are specified, we use kind=8, if it's available. If -fdefault-real is
522 specified without -fdefault-double, we use kind=16, if it's available.
523 Otherwise we do not change anything. */
524 if (gfc_option
.flag_default_double
&& !gfc_option
.flag_default_real
)
525 fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
527 if (gfc_option
.flag_default_real
&& gfc_option
.flag_default_double
&& saw_r8
)
528 gfc_default_double_kind
= 8;
529 else if (gfc_option
.flag_default_real
&& saw_r16
)
530 gfc_default_double_kind
= 16;
531 else if (saw_r4
&& saw_r8
)
532 gfc_default_double_kind
= 8;
535 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
536 real ... occupies two contiguous numeric storage units.
538 Therefore we must be supplied a kind twice as large as we chose
539 for single precision. There are loopholes, in that double
540 precision must *occupy* two storage units, though it doesn't have
541 to *use* two storage units. Which means that you can make this
542 kind artificially wide by padding it. But at present there are
543 no GCC targets for which a two-word type does not exist, so we
544 just let gfc_validate_kind abort and tell us if something breaks. */
546 gfc_default_double_kind
547 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
550 /* The default logical kind is constrained to be the same as the
551 default integer kind. Similarly with complex and real. */
552 gfc_default_logical_kind
= gfc_default_integer_kind
;
553 gfc_default_complex_kind
= gfc_default_real_kind
;
555 /* We only have two character kinds: ASCII and UCS-4.
556 ASCII corresponds to a 8-bit integer type, if one is available.
557 UCS-4 corresponds to a 32-bit integer type, if one is available. */
559 if ((kind
= get_int_kind_from_width (8)) > 0)
561 gfc_character_kinds
[i_index
].kind
= kind
;
562 gfc_character_kinds
[i_index
].bit_size
= 8;
563 gfc_character_kinds
[i_index
].name
= "ascii";
566 if ((kind
= get_int_kind_from_width (32)) > 0)
568 gfc_character_kinds
[i_index
].kind
= kind
;
569 gfc_character_kinds
[i_index
].bit_size
= 32;
570 gfc_character_kinds
[i_index
].name
= "iso_10646";
574 /* Choose the smallest integer kind for our default character. */
575 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
576 gfc_character_storage_size
= gfc_default_character_kind
* 8;
578 /* Choose the integer kind the same size as "void*" for our index kind. */
579 gfc_index_integer_kind
= POINTER_SIZE
/ 8;
580 /* Pick a kind the same size as the C "int" type. */
581 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
583 /* Choose atomic kinds to match C's int. */
584 gfc_atomic_int_kind
= gfc_c_int_kind
;
585 gfc_atomic_logical_kind
= gfc_c_int_kind
;
587 /* initialize the C interoperable kinds */
588 init_c_interop_kinds();
591 /* Make sure that a valid kind is present. Returns an index into the
592 associated kinds array, -1 if the kind is not present. */
595 validate_integer (int kind
)
599 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
600 if (gfc_integer_kinds
[i
].kind
== kind
)
607 validate_real (int kind
)
611 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
612 if (gfc_real_kinds
[i
].kind
== kind
)
619 validate_logical (int kind
)
623 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
624 if (gfc_logical_kinds
[i
].kind
== kind
)
631 validate_character (int kind
)
635 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
636 if (gfc_character_kinds
[i
].kind
== kind
)
642 /* Validate a kind given a basic type. The return value is the same
643 for the child functions, with -1 indicating nonexistence of the
644 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
647 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
653 case BT_REAL
: /* Fall through */
655 rc
= validate_real (kind
);
658 rc
= validate_integer (kind
);
661 rc
= validate_logical (kind
);
664 rc
= validate_character (kind
);
668 gfc_internal_error ("gfc_validate_kind(): Got bad type");
671 if (rc
< 0 && !may_fail
)
672 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
678 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
679 Reuse common type nodes where possible. Recognize if the kind matches up
680 with a C type. This will be used later in determining which routines may
681 be scarfed from libm. */
684 gfc_build_int_type (gfc_integer_info
*info
)
686 int mode_precision
= info
->bit_size
;
688 if (mode_precision
== CHAR_TYPE_SIZE
)
690 if (mode_precision
== SHORT_TYPE_SIZE
)
692 if (mode_precision
== INT_TYPE_SIZE
)
694 if (mode_precision
== LONG_TYPE_SIZE
)
696 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
697 info
->c_long_long
= 1;
699 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
700 return intQI_type_node
;
701 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
702 return intHI_type_node
;
703 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
704 return intSI_type_node
;
705 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
706 return intDI_type_node
;
707 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
708 return intTI_type_node
;
710 return make_signed_type (mode_precision
);
714 gfc_build_uint_type (int size
)
716 if (size
== CHAR_TYPE_SIZE
)
717 return unsigned_char_type_node
;
718 if (size
== SHORT_TYPE_SIZE
)
719 return short_unsigned_type_node
;
720 if (size
== INT_TYPE_SIZE
)
721 return unsigned_type_node
;
722 if (size
== LONG_TYPE_SIZE
)
723 return long_unsigned_type_node
;
724 if (size
== LONG_LONG_TYPE_SIZE
)
725 return long_long_unsigned_type_node
;
727 return make_unsigned_type (size
);
732 gfc_build_real_type (gfc_real_info
*info
)
734 int mode_precision
= info
->mode_precision
;
737 if (mode_precision
== FLOAT_TYPE_SIZE
)
739 if (mode_precision
== DOUBLE_TYPE_SIZE
)
741 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
742 info
->c_long_double
= 1;
743 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
745 info
->c_float128
= 1;
746 gfc_real16_is_float128
= true;
749 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
750 return float_type_node
;
751 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
752 return double_type_node
;
753 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
754 return long_double_type_node
;
756 new_type
= make_node (REAL_TYPE
);
757 TYPE_PRECISION (new_type
) = mode_precision
;
758 layout_type (new_type
);
763 gfc_build_complex_type (tree scalar_type
)
767 if (scalar_type
== NULL
)
769 if (scalar_type
== float_type_node
)
770 return complex_float_type_node
;
771 if (scalar_type
== double_type_node
)
772 return complex_double_type_node
;
773 if (scalar_type
== long_double_type_node
)
774 return complex_long_double_type_node
;
776 new_type
= make_node (COMPLEX_TYPE
);
777 TREE_TYPE (new_type
) = scalar_type
;
778 layout_type (new_type
);
783 gfc_build_logical_type (gfc_logical_info
*info
)
785 int bit_size
= info
->bit_size
;
788 if (bit_size
== BOOL_TYPE_SIZE
)
791 return boolean_type_node
;
794 new_type
= make_unsigned_type (bit_size
);
795 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
796 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
797 TYPE_PRECISION (new_type
) = 1;
803 /* Create the backend type nodes. We map them to their
804 equivalent C type, at least for now. We also give
805 names to the types here, and we push them in the
806 global binding level context.*/
809 gfc_init_types (void)
815 unsigned HOST_WIDE_INT hi
;
816 unsigned HOST_WIDE_INT lo
;
818 /* Create and name the types. */
819 #define PUSH_TYPE(name, node) \
820 pushdecl (build_decl (input_location, \
821 TYPE_DECL, get_identifier (name), node))
823 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
825 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
826 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
827 if (TYPE_STRING_FLAG (type
))
828 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
829 gfc_integer_types
[index
] = type
;
830 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
831 gfc_integer_kinds
[index
].kind
);
832 PUSH_TYPE (name_buf
, type
);
835 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
837 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
838 gfc_logical_types
[index
] = type
;
839 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
840 gfc_logical_kinds
[index
].kind
);
841 PUSH_TYPE (name_buf
, type
);
844 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
846 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
847 gfc_real_types
[index
] = type
;
848 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
849 gfc_real_kinds
[index
].kind
);
850 PUSH_TYPE (name_buf
, type
);
852 if (gfc_real_kinds
[index
].c_float128
)
853 float128_type_node
= type
;
855 type
= gfc_build_complex_type (type
);
856 gfc_complex_types
[index
] = type
;
857 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
858 gfc_real_kinds
[index
].kind
);
859 PUSH_TYPE (name_buf
, type
);
861 if (gfc_real_kinds
[index
].c_float128
)
862 complex_float128_type_node
= type
;
865 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
867 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
868 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
869 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
870 gfc_character_kinds
[index
].kind
);
871 PUSH_TYPE (name_buf
, type
);
872 gfc_character_types
[index
] = type
;
873 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
875 gfc_character1_type_node
= gfc_character_types
[0];
877 PUSH_TYPE ("byte", unsigned_char_type_node
);
878 PUSH_TYPE ("void", void_type_node
);
880 /* DBX debugging output gets upset if these aren't set. */
881 if (!TYPE_NAME (integer_type_node
))
882 PUSH_TYPE ("c_integer", integer_type_node
);
883 if (!TYPE_NAME (char_type_node
))
884 PUSH_TYPE ("c_char", char_type_node
);
888 pvoid_type_node
= build_pointer_type (void_type_node
);
889 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
890 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
891 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
893 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
895 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
896 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
897 since this function is called before gfc_init_constants. */
899 = build_range_type (gfc_array_index_type
,
900 build_int_cst (gfc_array_index_type
, 0),
903 /* The maximum array element size that can be handled is determined
904 by the number of bits available to store this field in the array
907 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
908 lo
= ~ (unsigned HOST_WIDE_INT
) 0;
909 if (n
> HOST_BITS_PER_WIDE_INT
)
910 hi
= lo
>> (2*HOST_BITS_PER_WIDE_INT
- n
);
912 hi
= 0, lo
>>= HOST_BITS_PER_WIDE_INT
- n
;
913 gfc_max_array_element_size
914 = build_int_cst_wide (long_unsigned_type_node
, lo
, hi
);
916 boolean_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
917 boolean_true_node
= build_int_cst (boolean_type_node
, 1);
918 boolean_false_node
= build_int_cst (boolean_type_node
, 0);
920 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
921 gfc_charlen_int_kind
= 4;
922 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
925 /* Get the type node for the given type and kind. */
928 gfc_get_int_type (int kind
)
930 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
931 return index
< 0 ? 0 : gfc_integer_types
[index
];
935 gfc_get_real_type (int kind
)
937 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
938 return index
< 0 ? 0 : gfc_real_types
[index
];
942 gfc_get_complex_type (int kind
)
944 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
945 return index
< 0 ? 0 : gfc_complex_types
[index
];
949 gfc_get_logical_type (int kind
)
951 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
952 return index
< 0 ? 0 : gfc_logical_types
[index
];
956 gfc_get_char_type (int kind
)
958 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
959 return index
< 0 ? 0 : gfc_character_types
[index
];
963 gfc_get_pchar_type (int kind
)
965 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
966 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
970 /* Create a character type with the given kind and length. */
973 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
977 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
978 type
= build_array_type (eltype
, bounds
);
979 TYPE_STRING_FLAG (type
) = 1;
985 gfc_get_character_type_len (int kind
, tree len
)
987 gfc_validate_kind (BT_CHARACTER
, kind
, false);
988 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
992 /* Get a type node for a character kind. */
995 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
999 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1001 return gfc_get_character_type_len (kind
, len
);
1004 /* Covert a basic type. This will be an array for character types. */
1007 gfc_typenode_for_spec (gfc_typespec
* spec
)
1017 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1018 has been resolved. This is done so we can convert C_PTR and
1019 C_FUNPTR to simple variables that get translated to (void *). */
1020 if (spec
->f90_type
== BT_VOID
)
1023 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1024 basetype
= ptr_type_node
;
1026 basetype
= pfunc_type_node
;
1029 basetype
= gfc_get_int_type (spec
->kind
);
1033 basetype
= gfc_get_real_type (spec
->kind
);
1037 basetype
= gfc_get_complex_type (spec
->kind
);
1041 basetype
= gfc_get_logical_type (spec
->kind
);
1047 basetype
= gfc_get_character_type (spec
->kind
, NULL
);
1050 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1055 basetype
= gfc_get_derived_type (spec
->u
.derived
);
1057 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1058 type and kind to fit a (void *) and the basetype returned was a
1059 ptr_type_node. We need to pass up this new information to the
1060 symbol that was declared of type C_PTR or C_FUNPTR. */
1061 if (spec
->u
.derived
->attr
.is_iso_c
)
1063 spec
->type
= spec
->u
.derived
->ts
.type
;
1064 spec
->kind
= spec
->u
.derived
->ts
.kind
;
1065 spec
->f90_type
= spec
->u
.derived
->ts
.f90_type
;
1069 /* This is for the second arg to c_f_pointer and c_f_procpointer
1070 of the iso_c_binding module, to accept any ptr type. */
1071 basetype
= ptr_type_node
;
1072 if (spec
->f90_type
== BT_VOID
)
1075 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1076 basetype
= ptr_type_node
;
1078 basetype
= pfunc_type_node
;
1087 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1090 gfc_conv_array_bound (gfc_expr
* expr
)
1092 /* If expr is an integer constant, return that. */
1093 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1094 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1096 /* Otherwise return NULL. */
1101 gfc_get_element_type (tree type
)
1105 if (GFC_ARRAY_TYPE_P (type
))
1107 if (TREE_CODE (type
) == POINTER_TYPE
)
1108 type
= TREE_TYPE (type
);
1109 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1111 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1116 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1117 element
= TREE_TYPE (type
);
1122 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1123 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1125 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1126 element
= TREE_TYPE (element
);
1128 gcc_assert (TREE_CODE (element
) == ARRAY_TYPE
);
1129 element
= TREE_TYPE (element
);
1135 /* Build an array. This function is called from gfc_sym_type().
1136 Actually returns array descriptor type.
1138 Format of array descriptors is as follows:
1140 struct gfc_array_descriptor
1145 struct descriptor_dimension dimension[N_DIM];
1148 struct descriptor_dimension
1155 Translation code should use gfc_conv_descriptor_* rather than
1156 accessing the descriptor directly. Any changes to the array
1157 descriptor type will require changes in gfc_conv_descriptor_* and
1158 gfc_build_array_initializer.
1160 This is represented internally as a RECORD_TYPE. The index nodes
1161 are gfc_array_index_type and the data node is a pointer to the
1162 data. See below for the handling of character types.
1164 The dtype member is formatted as follows:
1165 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1166 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1167 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1169 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1170 this generated poor code for assumed/deferred size arrays. These
1171 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1172 of the GENERIC grammar. Also, there is no way to explicitly set
1173 the array stride, so all data must be packed(1). I've tried to
1174 mark all the functions which would require modification with a GCC
1177 The data component points to the first element in the array. The
1178 offset field is the position of the origin of the array (i.e. element
1179 (0, 0 ...)). This may be outside the bounds of the array.
1181 An element is accessed by
1182 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1183 This gives good performance as the computation does not involve the
1184 bounds of the array. For packed arrays, this is optimized further
1185 by substituting the known strides.
1187 This system has one problem: all array bounds must be within 2^31
1188 elements of the origin (2^63 on 64-bit machines). For example
1189 integer, dimension (80000:90000, 80000:90000, 2) :: array
1190 may not work properly on 32-bit machines because 80000*80000 >
1191 2^31, so the calculation for stride2 would overflow. This may
1192 still work, but I haven't checked, and it relies on the overflow
1193 doing the right thing.
1195 The way to fix this problem is to access elements as follows:
1196 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1197 Obviously this is much slower. I will make this a compile time
1198 option, something like -fsmall-array-offsets. Mixing code compiled
1199 with and without this switch will work.
1201 (1) This can be worked around by modifying the upper bound of the
1202 previous dimension. This requires extra fields in the descriptor
1203 (both real_ubound and fake_ubound). */
1206 /* Returns true if the array sym does not require a descriptor. */
1209 gfc_is_nodesc_array (gfc_symbol
* sym
)
1211 gcc_assert (sym
->attr
.dimension
|| sym
->attr
.codimension
);
1213 /* We only want local arrays. */
1214 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1217 /* We want a descriptor for associate-name arrays that do not have an
1218 explicitely known shape already. */
1219 if (sym
->assoc
&& sym
->as
->type
!= AS_EXPLICIT
)
1222 if (sym
->attr
.dummy
)
1223 return sym
->as
->type
!= AS_ASSUMED_SHAPE
;
1225 if (sym
->attr
.result
|| sym
->attr
.function
)
1228 gcc_assert (sym
->as
->type
== AS_EXPLICIT
|| sym
->as
->cp_was_assumed
);
1234 /* Create an array descriptor type. */
1237 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1238 enum gfc_array_kind akind
, bool restricted
,
1241 tree lbound
[GFC_MAX_DIMENSIONS
];
1242 tree ubound
[GFC_MAX_DIMENSIONS
];
1245 for (n
= 0; n
< as
->rank
; n
++)
1247 /* Create expressions for the known bounds of the array. */
1248 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1249 lbound
[n
] = gfc_index_one_node
;
1251 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1252 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1255 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1257 if (as
->lower
[n
] == NULL
)
1258 lbound
[n
] = gfc_index_one_node
;
1260 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1262 if (n
< as
->rank
+ as
->corank
- 1)
1263 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1266 if (as
->type
== AS_ASSUMED_SHAPE
)
1267 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1268 : GFC_ARRAY_ASSUMED_SHAPE
;
1269 return gfc_get_array_type_bounds (type
, as
->rank
, as
->corank
, lbound
,
1270 ubound
, 0, akind
, restricted
);
1273 /* Returns the struct descriptor_dimension type. */
1276 gfc_get_desc_dim_type (void)
1279 tree decl
, *chain
= NULL
;
1281 if (gfc_desc_dim_type
)
1282 return gfc_desc_dim_type
;
1284 /* Build the type node. */
1285 type
= make_node (RECORD_TYPE
);
1287 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1288 TYPE_PACKED (type
) = 1;
1290 /* Consists of the stride, lbound and ubound members. */
1291 decl
= gfc_add_field_to_struct_1 (type
,
1292 get_identifier ("stride"),
1293 gfc_array_index_type
, &chain
);
1294 TREE_NO_WARNING (decl
) = 1;
1296 decl
= gfc_add_field_to_struct_1 (type
,
1297 get_identifier ("lbound"),
1298 gfc_array_index_type
, &chain
);
1299 TREE_NO_WARNING (decl
) = 1;
1301 decl
= gfc_add_field_to_struct_1 (type
,
1302 get_identifier ("ubound"),
1303 gfc_array_index_type
, &chain
);
1304 TREE_NO_WARNING (decl
) = 1;
1306 /* Finish off the type. */
1307 gfc_finish_type (type
);
1308 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1310 gfc_desc_dim_type
= type
;
1315 /* Return the DTYPE for an array. This describes the type and type parameters
1317 /* TODO: Only call this when the value is actually used, and make all the
1318 unknown cases abort. */
1321 gfc_get_dtype (tree type
)
1331 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1333 if (GFC_TYPE_ARRAY_DTYPE (type
))
1334 return GFC_TYPE_ARRAY_DTYPE (type
);
1336 rank
= GFC_TYPE_ARRAY_RANK (type
);
1337 etype
= gfc_get_element_type (type
);
1339 switch (TREE_CODE (etype
))
1357 /* We will never have arrays of arrays. */
1367 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1368 /* We can strange array types for temporary arrays. */
1369 return gfc_index_zero_node
;
1372 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1373 size
= TYPE_SIZE_UNIT (etype
);
1375 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1376 if (size
&& INTEGER_CST_P (size
))
1378 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1379 internal_error ("Array element size too big");
1381 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1383 dtype
= build_int_cst (gfc_array_index_type
, i
);
1385 if (size
&& !INTEGER_CST_P (size
))
1387 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1388 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
,
1389 gfc_array_index_type
,
1390 fold_convert (gfc_array_index_type
, size
), tmp
);
1391 dtype
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1394 /* If we don't know the size we leave it as zero. This should never happen
1395 for anything that is actually used. */
1396 /* TODO: Check this is actually true, particularly when repacking
1397 assumed size parameters. */
1399 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1404 /* Build an array type for use without a descriptor, packed according
1405 to the value of PACKED. */
1408 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1422 mpz_init_set_ui (offset
, 0);
1423 mpz_init_set_ui (stride
, 1);
1426 /* We don't use build_array_type because this does not include include
1427 lang-specific information (i.e. the bounds of the array) when checking
1430 type
= make_node (ARRAY_TYPE
);
1432 type
= build_variant_type_copy (etype
);
1434 GFC_ARRAY_TYPE_P (type
) = 1;
1435 TYPE_LANG_SPECIFIC (type
)
1436 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1438 known_stride
= (packed
!= PACKED_NO
);
1440 for (n
= 0; n
< as
->rank
; n
++)
1442 /* Fill in the stride and bound components of the type. */
1444 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1447 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1449 expr
= as
->lower
[n
];
1450 if (expr
->expr_type
== EXPR_CONSTANT
)
1452 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1453 gfc_index_integer_kind
);
1460 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1464 /* Calculate the offset. */
1465 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1466 mpz_sub (offset
, offset
, delta
);
1471 expr
= as
->upper
[n
];
1472 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1474 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1475 gfc_index_integer_kind
);
1482 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1486 /* Calculate the stride. */
1487 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1488 as
->lower
[n
]->value
.integer
);
1489 mpz_add_ui (delta
, delta
, 1);
1490 mpz_mul (stride
, stride
, delta
);
1493 /* Only the first stride is known for partial packed arrays. */
1494 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1497 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1499 expr
= as
->lower
[n
];
1500 if (expr
->expr_type
== EXPR_CONSTANT
)
1501 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1502 gfc_index_integer_kind
);
1505 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1507 expr
= as
->upper
[n
];
1508 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1509 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1510 gfc_index_integer_kind
);
1513 if (n
< as
->rank
+ as
->corank
- 1)
1514 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1519 GFC_TYPE_ARRAY_OFFSET (type
) =
1520 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1523 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1527 GFC_TYPE_ARRAY_SIZE (type
) =
1528 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1531 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1533 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1534 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1535 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1536 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1538 /* TODO: use main type if it is unbounded. */
1539 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1540 build_pointer_type (build_array_type (etype
, range
));
1542 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1543 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1544 TYPE_QUAL_RESTRICT
);
1548 if (packed
!= PACKED_STATIC
|| gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
1550 type
= build_pointer_type (type
);
1553 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1555 GFC_ARRAY_TYPE_P (type
) = 1;
1556 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1564 mpz_sub_ui (stride
, stride
, 1);
1565 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1570 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1571 TYPE_DOMAIN (type
) = range
;
1573 build_pointer_type (etype
);
1574 TREE_TYPE (type
) = etype
;
1582 /* Represent packed arrays as multi-dimensional if they have rank >
1583 1 and with proper bounds, instead of flat arrays. This makes for
1584 better debug info. */
1587 tree gtype
= etype
, rtype
, type_decl
;
1589 for (n
= as
->rank
- 1; n
>= 0; n
--)
1591 rtype
= build_range_type (gfc_array_index_type
,
1592 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1593 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1594 gtype
= build_array_type (gtype
, rtype
);
1596 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1597 TYPE_DECL
, NULL
, gtype
);
1598 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1601 if (packed
!= PACKED_STATIC
|| !known_stride
1602 || (as
->corank
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
))
1604 /* For dummy arrays and automatic (heap allocated) arrays we
1605 want a pointer to the array. */
1606 type
= build_pointer_type (type
);
1608 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1609 GFC_ARRAY_TYPE_P (type
) = 1;
1610 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1615 /* Return or create the base type for an array descriptor. */
1618 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1620 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1621 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1622 int idx
= 2 * (codimen
+ dimen
- 1) + restricted
;
1624 gcc_assert (codimen
+ dimen
>= 1 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1625 if (gfc_array_descriptor_base
[idx
])
1626 return gfc_array_descriptor_base
[idx
];
1628 /* Build the type node. */
1629 fat_type
= make_node (RECORD_TYPE
);
1631 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1632 TYPE_NAME (fat_type
) = get_identifier (name
);
1633 TYPE_NAMELESS (fat_type
) = 1;
1635 /* Add the data member as the first element of the descriptor. */
1636 decl
= gfc_add_field_to_struct_1 (fat_type
,
1637 get_identifier ("data"),
1640 : ptr_type_node
), &chain
);
1642 /* Add the base component. */
1643 decl
= gfc_add_field_to_struct_1 (fat_type
,
1644 get_identifier ("offset"),
1645 gfc_array_index_type
, &chain
);
1646 TREE_NO_WARNING (decl
) = 1;
1648 /* Add the dtype component. */
1649 decl
= gfc_add_field_to_struct_1 (fat_type
,
1650 get_identifier ("dtype"),
1651 gfc_array_index_type
, &chain
);
1652 TREE_NO_WARNING (decl
) = 1;
1654 /* Build the array type for the stride and bound components. */
1656 build_array_type (gfc_get_desc_dim_type (),
1657 build_range_type (gfc_array_index_type
,
1658 gfc_index_zero_node
,
1659 gfc_rank_cst
[codimen
+ dimen
- 1]));
1661 decl
= gfc_add_field_to_struct_1 (fat_type
,
1662 get_identifier ("dim"),
1664 TREE_NO_WARNING (decl
) = 1;
1666 /* Finish off the type. */
1667 gfc_finish_type (fat_type
);
1668 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1670 gfc_array_descriptor_base
[idx
] = fat_type
;
1674 /* Build an array (descriptor) type with given bounds. */
1677 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1678 tree
* ubound
, int packed
,
1679 enum gfc_array_kind akind
, bool restricted
)
1681 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1682 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1683 const char *type_name
;
1686 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1687 fat_type
= build_distinct_type_copy (base_type
);
1688 /* Make sure that nontarget and target array type have the same canonical
1689 type (and same stub decl for debug info). */
1690 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1691 TYPE_CANONICAL (fat_type
) = base_type
;
1692 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1694 tmp
= TYPE_NAME (etype
);
1695 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1696 tmp
= DECL_NAME (tmp
);
1698 type_name
= IDENTIFIER_POINTER (tmp
);
1700 type_name
= "unknown";
1701 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1702 GFC_MAX_SYMBOL_LEN
, type_name
);
1703 TYPE_NAME (fat_type
) = get_identifier (name
);
1704 TYPE_NAMELESS (fat_type
) = 1;
1706 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1707 TYPE_LANG_SPECIFIC (fat_type
)
1708 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1710 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1711 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1712 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1713 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1715 /* Build an array descriptor record type. */
1717 stride
= gfc_index_one_node
;
1720 for (n
= 0; n
< dimen
+ codimen
; n
++)
1723 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1730 if (lower
!= NULL_TREE
)
1732 if (INTEGER_CST_P (lower
))
1733 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1738 if (codimen
&& n
== dimen
+ codimen
- 1)
1742 if (upper
!= NULL_TREE
)
1744 if (INTEGER_CST_P (upper
))
1745 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1753 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1755 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1756 gfc_array_index_type
, upper
, lower
);
1757 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1758 gfc_array_index_type
, tmp
,
1759 gfc_index_one_node
);
1760 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1761 gfc_array_index_type
, tmp
, stride
);
1762 /* Check the folding worked. */
1763 gcc_assert (INTEGER_CST_P (stride
));
1768 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1770 /* TODO: known offsets for descriptors. */
1771 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1773 /* We define data as an array with the correct size if possible.
1774 Much better than doing pointer arithmetic. */
1776 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1777 int_const_binop (MINUS_EXPR
, stride
,
1780 rtype
= gfc_array_range_type
;
1781 arraytype
= build_array_type (etype
, rtype
);
1782 arraytype
= build_pointer_type (arraytype
);
1784 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1785 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1787 /* This will generate the base declarations we need to emit debug
1788 information for this type. FIXME: there must be a better way to
1789 avoid divergence between compilations with and without debug
1792 struct array_descr_info info
;
1793 gfc_get_array_descr_info (fat_type
, &info
);
1794 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
1800 /* Build a pointer type. This function is called from gfc_sym_type(). */
1803 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
1805 /* Array pointer types aren't actually pointers. */
1806 if (sym
->attr
.dimension
)
1809 return build_pointer_type (type
);
1812 static tree
gfc_nonrestricted_type (tree t
);
1813 /* Given two record or union type nodes TO and FROM, ensure
1814 that all fields in FROM have a corresponding field in TO,
1815 their type being nonrestrict variants. This accepts a TO
1816 node that already has a prefix of the fields in FROM. */
1818 mirror_fields (tree to
, tree from
)
1823 /* Forward to the end of TOs fields. */
1824 fto
= TYPE_FIELDS (to
);
1825 ffrom
= TYPE_FIELDS (from
);
1826 chain
= &TYPE_FIELDS (to
);
1829 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
1830 chain
= &DECL_CHAIN (fto
);
1831 fto
= DECL_CHAIN (fto
);
1832 ffrom
= DECL_CHAIN (ffrom
);
1835 /* Now add all fields remaining in FROM (starting with ffrom). */
1836 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
1838 tree newfield
= copy_node (ffrom
);
1839 DECL_CONTEXT (newfield
) = to
;
1840 /* The store to DECL_CHAIN might seem redundant with the
1841 stores to *chain, but not clearing it here would mean
1842 leaving a chain into the old fields. If ever
1843 our called functions would look at them confusion
1845 DECL_CHAIN (newfield
) = NULL_TREE
;
1847 chain
= &DECL_CHAIN (newfield
);
1849 if (TREE_CODE (ffrom
) == FIELD_DECL
)
1851 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
1852 TREE_TYPE (newfield
) = elemtype
;
1858 /* Given a type T, returns a different type of the same structure,
1859 except that all types it refers to (recursively) are always
1860 non-restrict qualified types. */
1862 gfc_nonrestricted_type (tree t
)
1866 /* If the type isn't layed out yet, don't copy it. If something
1867 needs it for real it should wait until the type got finished. */
1871 if (!TYPE_LANG_SPECIFIC (t
))
1872 TYPE_LANG_SPECIFIC (t
)
1873 = ggc_alloc_cleared_lang_type (sizeof (struct lang_type
));
1874 /* If we're dealing with this very node already further up
1875 the call chain (recursion via pointers and struct members)
1876 we haven't yet determined if we really need a new type node.
1877 Assume we don't, return T itself. */
1878 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
1881 /* If we have calculated this all already, just return it. */
1882 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
1883 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
1885 /* Mark this type. */
1886 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
1888 switch (TREE_CODE (t
))
1894 case REFERENCE_TYPE
:
1896 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
1897 if (totype
== TREE_TYPE (t
))
1899 else if (TREE_CODE (t
) == POINTER_TYPE
)
1900 ret
= build_pointer_type (totype
);
1902 ret
= build_reference_type (totype
);
1903 ret
= build_qualified_type (ret
,
1904 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
1910 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
1911 if (elemtype
== TREE_TYPE (t
))
1915 ret
= build_variant_type_copy (t
);
1916 TREE_TYPE (ret
) = elemtype
;
1917 if (TYPE_LANG_SPECIFIC (t
)
1918 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
1920 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
1921 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
1922 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
1924 TYPE_LANG_SPECIFIC (ret
)
1925 = ggc_alloc_cleared_lang_type (sizeof (struct
1927 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
1928 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
1937 case QUAL_UNION_TYPE
:
1940 /* First determine if we need a new type at all.
1941 Careful, the two calls to gfc_nonrestricted_type per field
1942 might return different values. That happens exactly when
1943 one of the fields reaches back to this very record type
1944 (via pointers). The first calls will assume that we don't
1945 need to copy T (see the error_mark_node marking). If there
1946 are any reasons for copying T apart from having to copy T,
1947 we'll indeed copy it, and the second calls to
1948 gfc_nonrestricted_type will use that new node if they
1950 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
1951 if (TREE_CODE (field
) == FIELD_DECL
)
1953 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
1954 if (elemtype
!= TREE_TYPE (field
))
1959 ret
= build_variant_type_copy (t
);
1960 TYPE_FIELDS (ret
) = NULL_TREE
;
1962 /* Here we make sure that as soon as we know we have to copy
1963 T, that also fields reaching back to us will use the new
1964 copy. It's okay if that copy still contains the old fields,
1965 we won't look at them. */
1966 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
1967 mirror_fields (ret
, t
);
1972 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
1977 /* Return the type for a symbol. Special handling is required for character
1978 types to get the correct level of indirection.
1979 For functions return the return type.
1980 For subroutines return void_type_node.
1981 Calling this multiple times for the same symbol should be avoided,
1982 especially for character and array types. */
1985 gfc_sym_type (gfc_symbol
* sym
)
1991 /* Procedure Pointers inside COMMON blocks. */
1992 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
1994 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
1995 sym
->attr
.proc_pointer
= 0;
1996 type
= build_pointer_type (gfc_get_function_type (sym
));
1997 sym
->attr
.proc_pointer
= 1;
2001 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2002 return void_type_node
;
2004 /* In the case of a function the fake result variable may have a
2005 type different from the function type, so don't return early in
2007 if (sym
->backend_decl
&& !sym
->attr
.function
)
2008 return TREE_TYPE (sym
->backend_decl
);
2010 if (sym
->ts
.type
== BT_CHARACTER
2011 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2012 || (sym
->attr
.result
2013 && sym
->ns
->proc_name
2014 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
2015 type
= gfc_character1_type_node
;
2017 type
= gfc_typenode_for_spec (&sym
->ts
);
2019 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2024 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2025 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2027 type
= gfc_nonrestricted_type (type
);
2029 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2031 if (gfc_is_nodesc_array (sym
))
2033 /* If this is a character argument of unknown length, just use the
2035 if (sym
->ts
.type
!= BT_CHARACTER
2036 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2037 || sym
->ts
.u
.cl
->backend_decl
)
2039 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2046 if (sym
->attr
.cray_pointee
)
2047 GFC_POINTER_TYPE_P (type
) = 1;
2051 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2052 if (sym
->attr
.pointer
)
2053 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2054 : GFC_ARRAY_POINTER
;
2055 else if (sym
->attr
.allocatable
)
2056 akind
= GFC_ARRAY_ALLOCATABLE
;
2057 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2058 sym
->attr
.contiguous
);
2063 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2064 || gfc_is_associate_pointer (sym
))
2065 type
= gfc_build_pointer_type (sym
, type
);
2066 if (sym
->attr
.pointer
|| sym
->attr
.cray_pointee
)
2067 GFC_POINTER_TYPE_P (type
) = 1;
2070 /* We currently pass all parameters by reference.
2071 See f95_get_function_decl. For dummy function parameters return the
2075 /* We must use pointer types for potentially absent variables. The
2076 optimizers assume a reference type argument is never NULL. */
2077 if (sym
->attr
.optional
|| sym
->ns
->proc_name
->attr
.entry_master
)
2078 type
= build_pointer_type (type
);
2081 type
= build_reference_type (type
);
2083 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2090 /* Layout and output debug info for a record type. */
2093 gfc_finish_type (tree type
)
2097 decl
= build_decl (input_location
,
2098 TYPE_DECL
, NULL_TREE
, type
);
2099 TYPE_STUB_DECL (type
) = decl
;
2101 rest_of_type_compilation (type
, 1);
2102 rest_of_decl_compilation (decl
, 1, 0);
2105 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2106 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2107 to the end of the field list pointed to by *CHAIN.
2109 Returns a pointer to the new field. */
2112 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2114 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2116 DECL_CONTEXT (decl
) = context
;
2117 DECL_CHAIN (decl
) = NULL_TREE
;
2118 if (TYPE_FIELDS (context
) == NULL_TREE
)
2119 TYPE_FIELDS (context
) = decl
;
2124 *chain
= &DECL_CHAIN (decl
);
2130 /* Like `gfc_add_field_to_struct_1', but adds alignment
2134 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2136 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2138 DECL_INITIAL (decl
) = 0;
2139 DECL_ALIGN (decl
) = 0;
2140 DECL_USER_ALIGN (decl
) = 0;
2146 /* Copy the backend_decl and component backend_decls if
2147 the two derived type symbols are "equal", as described
2148 in 4.4.2 and resolved by gfc_compare_derived_types. */
2151 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2154 gfc_component
*to_cm
;
2155 gfc_component
*from_cm
;
2157 if (from
->backend_decl
== NULL
2158 || !gfc_compare_derived_types (from
, to
))
2161 to
->backend_decl
= from
->backend_decl
;
2163 to_cm
= to
->components
;
2164 from_cm
= from
->components
;
2166 /* Copy the component declarations. If a component is itself
2167 a derived type, we need a copy of its component declarations.
2168 This is done by recursing into gfc_get_derived_type and
2169 ensures that the component's component declarations have
2170 been built. If it is a character, we need the character
2172 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2174 to_cm
->backend_decl
= from_cm
->backend_decl
;
2175 if (from_cm
->ts
.type
== BT_DERIVED
2176 && (!from_cm
->attr
.pointer
|| from_gsym
))
2177 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2178 else if (from_cm
->ts
.type
== BT_CLASS
2179 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2180 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2181 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2182 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2189 /* Build a tree node for a procedure pointer component. */
2192 gfc_get_ppc_type (gfc_component
* c
)
2196 /* Explicit interface. */
2197 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2198 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2200 /* Implicit interface (only return value may be known). */
2201 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2202 t
= gfc_typenode_for_spec (&c
->ts
);
2206 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2210 /* Build a tree node for a derived type. If there are equal
2211 derived types, with different local names, these are built
2212 at the same time. If an equal derived type has been built
2213 in a parent namespace, this is used. */
2216 gfc_get_derived_type (gfc_symbol
* derived
)
2218 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2219 tree canonical
= NULL_TREE
;
2221 bool got_canonical
= false;
2226 gcc_assert (derived
&& derived
->attr
.flavor
== FL_DERIVED
);
2228 /* See if it's one of the iso_c_binding derived types. */
2229 if (derived
->attr
.is_iso_c
== 1)
2231 if (derived
->backend_decl
)
2232 return derived
->backend_decl
;
2234 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2235 derived
->backend_decl
= ptr_type_node
;
2237 derived
->backend_decl
= pfunc_type_node
;
2239 derived
->ts
.kind
= gfc_index_integer_kind
;
2240 derived
->ts
.type
= BT_INTEGER
;
2241 /* Set the f90_type to BT_VOID as a way to recognize something of type
2242 BT_INTEGER that needs to fit a void * for the purpose of the
2243 iso_c_binding derived types. */
2244 derived
->ts
.f90_type
= BT_VOID
;
2246 return derived
->backend_decl
;
2249 /* If use associated, use the module type for this one. */
2250 if (gfc_option
.flag_whole_file
2251 && derived
->backend_decl
== NULL
2252 && derived
->attr
.use_assoc
2254 && gfc_get_module_backend_decl (derived
))
2255 goto copy_derived_types
;
2257 /* If a whole file compilation, the derived types from an earlier
2258 namespace can be used as the canonical type. */
2259 if (gfc_option
.flag_whole_file
2260 && derived
->backend_decl
== NULL
2261 && !derived
->attr
.use_assoc
2262 && gfc_global_ns_list
)
2264 for (ns
= gfc_global_ns_list
;
2265 ns
->translated
&& !got_canonical
;
2268 dt
= ns
->derived_types
;
2269 for (; dt
&& !canonical
; dt
= dt
->next
)
2271 gfc_copy_dt_decls_ifequal (dt
->derived
, derived
, true);
2272 if (derived
->backend_decl
)
2273 got_canonical
= true;
2278 /* Store up the canonical type to be added to this one. */
2281 if (TYPE_CANONICAL (derived
->backend_decl
))
2282 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2284 canonical
= derived
->backend_decl
;
2286 derived
->backend_decl
= NULL_TREE
;
2289 /* derived->backend_decl != 0 means we saw it before, but its
2290 components' backend_decl may have not been built. */
2291 if (derived
->backend_decl
)
2293 /* Its components' backend_decl have been built or we are
2294 seeing recursion through the formal arglist of a procedure
2295 pointer component. */
2296 if (TYPE_FIELDS (derived
->backend_decl
)
2297 || derived
->attr
.proc_pointer_comp
)
2298 return derived
->backend_decl
;
2300 typenode
= derived
->backend_decl
;
2304 /* We see this derived type first time, so build the type node. */
2305 typenode
= make_node (RECORD_TYPE
);
2306 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2307 TYPE_PACKED (typenode
) = gfc_option
.flag_pack_derived
;
2308 derived
->backend_decl
= typenode
;
2311 /* Go through the derived type components, building them as
2312 necessary. The reason for doing this now is that it is
2313 possible to recurse back to this derived type through a
2314 pointer component (PR24092). If this happens, the fields
2315 will be built and so we can return the type. */
2316 for (c
= derived
->components
; c
; c
= c
->next
)
2318 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2321 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
)
2322 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2323 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
);
2325 if (c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.is_iso_c
)
2327 /* Need to copy the modified ts from the derived type. The
2328 typespec was modified because C_PTR/C_FUNPTR are translated
2329 into (void *) from derived types. */
2330 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2331 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2332 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2335 c
->initializer
->ts
.type
= c
->ts
.type
;
2336 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2337 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2338 c
->initializer
->expr_type
= EXPR_NULL
;
2343 if (TYPE_FIELDS (derived
->backend_decl
))
2344 return derived
->backend_decl
;
2346 /* Build the type member list. Install the newly created RECORD_TYPE
2347 node as DECL_CONTEXT of each FIELD_DECL. */
2348 for (c
= derived
->components
; c
; c
= c
->next
)
2350 if (c
->attr
.proc_pointer
)
2351 field_type
= gfc_get_ppc_type (c
);
2352 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2353 field_type
= c
->ts
.u
.derived
->backend_decl
;
2356 if (c
->ts
.type
== BT_CHARACTER
)
2358 /* Evaluate the string length. */
2359 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2360 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2363 field_type
= gfc_typenode_for_spec (&c
->ts
);
2366 /* This returns an array descriptor type. Initialization may be
2368 if (c
->attr
.dimension
&& !c
->attr
.proc_pointer
)
2370 if (c
->attr
.pointer
|| c
->attr
.allocatable
)
2372 enum gfc_array_kind akind
;
2373 if (c
->attr
.pointer
)
2374 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2375 : GFC_ARRAY_POINTER
;
2377 akind
= GFC_ARRAY_ALLOCATABLE
;
2378 /* Pointers to arrays aren't actually pointer types. The
2379 descriptors are separate, but the data is common. */
2380 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2382 && !c
->attr
.pointer
,
2383 c
->attr
.contiguous
);
2386 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2390 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
)
2391 && !c
->attr
.proc_pointer
)
2392 field_type
= build_pointer_type (field_type
);
2394 /* vtype fields can point to different types to the base type. */
2395 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.vtype
)
2396 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2399 field
= gfc_add_field_to_struct (typenode
,
2400 get_identifier (c
->name
),
2401 field_type
, &chain
);
2403 gfc_set_decl_location (field
, &c
->loc
);
2404 else if (derived
->declared_at
.lb
)
2405 gfc_set_decl_location (field
, &derived
->declared_at
);
2407 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2410 if (!c
->backend_decl
)
2411 c
->backend_decl
= field
;
2414 /* Now lay out the derived type, including the fields. */
2416 TYPE_CANONICAL (typenode
) = canonical
;
2418 gfc_finish_type (typenode
);
2419 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2420 if (derived
->module
&& derived
->ns
->proc_name
2421 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2423 if (derived
->ns
->proc_name
->backend_decl
2424 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2427 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2428 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2429 = derived
->ns
->proc_name
->backend_decl
;
2433 derived
->backend_decl
= typenode
;
2437 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2438 gfc_copy_dt_decls_ifequal (derived
, dt
->derived
, false);
2440 return derived
->backend_decl
;
2445 gfc_return_by_reference (gfc_symbol
* sym
)
2447 if (!sym
->attr
.function
)
2450 if (sym
->attr
.dimension
)
2453 if (sym
->ts
.type
== BT_CHARACTER
2454 && !sym
->attr
.is_bind_c
2455 && (!sym
->attr
.result
2456 || !sym
->ns
->proc_name
2457 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2460 /* Possibly return complex numbers by reference for g77 compatibility.
2461 We don't do this for calls to intrinsics (as the library uses the
2462 -fno-f2c calling convention), nor for calls to functions which always
2463 require an explicit interface, as no compatibility problems can
2465 if (gfc_option
.flag_f2c
2466 && sym
->ts
.type
== BT_COMPLEX
2467 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2474 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2478 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2479 gfc_entry_list
*el
, *el2
;
2481 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2482 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2484 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2486 /* Build the type node. */
2487 type
= make_node (UNION_TYPE
);
2489 TYPE_NAME (type
) = get_identifier (name
);
2491 for (el
= ns
->entries
; el
; el
= el
->next
)
2493 /* Search for duplicates. */
2494 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2495 if (el2
->sym
->result
== el
->sym
->result
)
2499 gfc_add_field_to_struct_1 (type
,
2500 get_identifier (el
->sym
->result
->name
),
2501 gfc_sym_type (el
->sym
->result
), &chain
);
2504 /* Finish off the type. */
2505 gfc_finish_type (type
);
2506 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2510 /* Create a "fn spec" based on the formal arguments;
2511 cf. create_function_arglist. */
2514 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2518 gfc_formal_arglist
*f
;
2521 memset (&spec
, 0, sizeof (spec
));
2525 if (sym
->attr
.entry_master
)
2526 spec
[spec_len
++] = 'R';
2527 if (gfc_return_by_reference (sym
))
2529 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2531 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2532 spec
[spec_len
++] = '.';
2534 spec
[spec_len
++] = 'w';
2535 if (sym
->ts
.type
== BT_CHARACTER
)
2536 spec
[spec_len
++] = 'R';
2539 for (f
= sym
->formal
; f
; f
= f
->next
)
2540 if (spec_len
< sizeof (spec
))
2542 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2543 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2544 || (f
->sym
->ts
.type
== BT_DERIVED
2545 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2546 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2547 || (f
->sym
->ts
.type
== BT_CLASS
2548 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2549 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2550 spec
[spec_len
++] = '.';
2551 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2552 spec
[spec_len
++] = 'r';
2554 spec
[spec_len
++] = 'w';
2557 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2558 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2559 return build_type_attribute_variant (fntype
, tmp
);
2564 gfc_get_function_type (gfc_symbol
* sym
)
2567 VEC(tree
,gc
) *typelist
;
2568 gfc_formal_arglist
*f
;
2570 int alternate_return
;
2571 bool is_varargs
= true;
2573 /* Make sure this symbol is a function, a subroutine or the main
2575 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2576 || sym
->attr
.flavor
== FL_PROGRAM
);
2578 if (sym
->backend_decl
)
2579 return TREE_TYPE (sym
->backend_decl
);
2581 alternate_return
= 0;
2584 if (sym
->attr
.entry_master
)
2585 /* Additional parameter for selecting an entry point. */
2586 VEC_safe_push (tree
, gc
, typelist
, gfc_array_index_type
);
2593 if (arg
->ts
.type
== BT_CHARACTER
)
2594 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2596 /* Some functions we use an extra parameter for the return value. */
2597 if (gfc_return_by_reference (sym
))
2599 type
= gfc_sym_type (arg
);
2600 if (arg
->ts
.type
== BT_COMPLEX
2601 || arg
->attr
.dimension
2602 || arg
->ts
.type
== BT_CHARACTER
)
2603 type
= build_reference_type (type
);
2605 VEC_safe_push (tree
, gc
, typelist
, type
);
2606 if (arg
->ts
.type
== BT_CHARACTER
)
2608 if (!arg
->ts
.deferred
)
2609 /* Transfer by value. */
2610 VEC_safe_push (tree
, gc
, typelist
, gfc_charlen_type_node
);
2612 /* Deferred character lengths are transferred by reference
2613 so that the value can be returned. */
2614 VEC_safe_push (tree
, gc
, typelist
,
2615 build_pointer_type (gfc_charlen_type_node
));
2619 /* Build the argument types for the function. */
2620 for (f
= sym
->formal
; f
; f
= f
->next
)
2625 /* Evaluate constant character lengths here so that they can be
2626 included in the type. */
2627 if (arg
->ts
.type
== BT_CHARACTER
)
2628 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2630 if (arg
->attr
.flavor
== FL_PROCEDURE
)
2632 type
= gfc_get_function_type (arg
);
2633 type
= build_pointer_type (type
);
2636 type
= gfc_sym_type (arg
);
2638 /* Parameter Passing Convention
2640 We currently pass all parameters by reference.
2641 Parameters with INTENT(IN) could be passed by value.
2642 The problem arises if a function is called via an implicit
2643 prototype. In this situation the INTENT is not known.
2644 For this reason all parameters to global functions must be
2645 passed by reference. Passing by value would potentially
2646 generate bad code. Worse there would be no way of telling that
2647 this code was bad, except that it would give incorrect results.
2649 Contained procedures could pass by value as these are never
2650 used without an explicit interface, and cannot be passed as
2651 actual parameters for a dummy procedure. */
2653 VEC_safe_push (tree
, gc
, typelist
, type
);
2657 if (sym
->attr
.subroutine
)
2658 alternate_return
= 1;
2662 /* Add hidden string length parameters. */
2663 for (f
= sym
->formal
; f
; f
= f
->next
)
2666 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2668 if (!arg
->ts
.deferred
)
2669 /* Transfer by value. */
2670 type
= gfc_charlen_type_node
;
2672 /* Deferred character lengths are transferred by reference
2673 so that the value can be returned. */
2674 type
= build_pointer_type (gfc_charlen_type_node
);
2676 VEC_safe_push (tree
, gc
, typelist
, type
);
2680 if (!VEC_empty (tree
, typelist
)
2681 || sym
->attr
.is_main_program
2682 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
2685 if (alternate_return
)
2686 type
= integer_type_node
;
2687 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
2688 type
= void_type_node
;
2689 else if (sym
->attr
.mixed_entry_master
)
2690 type
= gfc_get_mixed_entry_union (sym
->ns
);
2691 else if (gfc_option
.flag_f2c
2692 && sym
->ts
.type
== BT_REAL
2693 && sym
->ts
.kind
== gfc_default_real_kind
2694 && !sym
->attr
.always_explicit
)
2696 /* Special case: f2c calling conventions require that (scalar)
2697 default REAL functions return the C type double instead. f2c
2698 compatibility is only an issue with functions that don't
2699 require an explicit interface, as only these could be
2700 implemented in Fortran 77. */
2701 sym
->ts
.kind
= gfc_default_double_kind
;
2702 type
= gfc_typenode_for_spec (&sym
->ts
);
2703 sym
->ts
.kind
= gfc_default_real_kind
;
2705 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
2706 /* Procedure pointer return values. */
2708 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
2710 /* Unset proc_pointer as gfc_get_function_type
2711 is called recursively. */
2712 sym
->result
->attr
.proc_pointer
= 0;
2713 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
2714 sym
->result
->attr
.proc_pointer
= 1;
2717 type
= gfc_sym_type (sym
->result
);
2720 type
= gfc_sym_type (sym
);
2723 type
= build_varargs_function_type_vec (type
, typelist
);
2725 type
= build_function_type_vec (type
, typelist
);
2726 type
= create_fn_spec (sym
, type
);
2731 /* Language hooks for middle-end access to type nodes. */
2733 /* Return an integer type with BITS bits of precision,
2734 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
2737 gfc_type_for_size (unsigned bits
, int unsignedp
)
2742 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
2744 tree type
= gfc_integer_types
[i
];
2745 if (type
&& bits
== TYPE_PRECISION (type
))
2749 /* Handle TImode as a special case because it is used by some backends
2750 (e.g. ARM) even though it is not available for normal use. */
2751 #if HOST_BITS_PER_WIDE_INT >= 64
2752 if (bits
== TYPE_PRECISION (intTI_type_node
))
2753 return intTI_type_node
;
2758 if (bits
== TYPE_PRECISION (unsigned_intQI_type_node
))
2759 return unsigned_intQI_type_node
;
2760 if (bits
== TYPE_PRECISION (unsigned_intHI_type_node
))
2761 return unsigned_intHI_type_node
;
2762 if (bits
== TYPE_PRECISION (unsigned_intSI_type_node
))
2763 return unsigned_intSI_type_node
;
2764 if (bits
== TYPE_PRECISION (unsigned_intDI_type_node
))
2765 return unsigned_intDI_type_node
;
2766 if (bits
== TYPE_PRECISION (unsigned_intTI_type_node
))
2767 return unsigned_intTI_type_node
;
2773 /* Return a data type that has machine mode MODE. If the mode is an
2774 integer, then UNSIGNEDP selects between signed and unsigned types. */
2777 gfc_type_for_mode (enum machine_mode mode
, int unsignedp
)
2782 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
2783 base
= gfc_real_types
;
2784 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
2785 base
= gfc_complex_types
;
2786 else if (SCALAR_INT_MODE_P (mode
))
2787 return gfc_type_for_size (GET_MODE_PRECISION (mode
), unsignedp
);
2788 else if (VECTOR_MODE_P (mode
))
2790 enum machine_mode inner_mode
= GET_MODE_INNER (mode
);
2791 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
2792 if (inner_type
!= NULL_TREE
)
2793 return build_vector_type_for_mode (inner_type
, mode
);
2799 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
2801 tree type
= base
[i
];
2802 if (type
&& mode
== TYPE_MODE (type
))
2809 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2813 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
2816 bool indirect
= false;
2817 tree etype
, ptype
, field
, t
, base_decl
;
2818 tree data_off
, dim_off
, dim_size
, elem_size
;
2819 tree lower_suboff
, upper_suboff
, stride_suboff
;
2821 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2823 if (! POINTER_TYPE_P (type
))
2825 type
= TREE_TYPE (type
);
2826 if (! GFC_DESCRIPTOR_TYPE_P (type
))
2831 rank
= GFC_TYPE_ARRAY_RANK (type
);
2832 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
2835 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
2836 gcc_assert (POINTER_TYPE_P (etype
));
2837 etype
= TREE_TYPE (etype
);
2838 gcc_assert (TREE_CODE (etype
) == ARRAY_TYPE
);
2839 etype
= TREE_TYPE (etype
);
2840 /* Can't handle variable sized elements yet. */
2841 if (int_size_in_bytes (etype
) <= 0)
2843 /* Nor non-constant lower bounds in assumed shape arrays. */
2844 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
2845 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
2847 for (dim
= 0; dim
< rank
; dim
++)
2848 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
2849 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
2853 memset (info
, '\0', sizeof (*info
));
2854 info
->ndimensions
= rank
;
2855 info
->element_type
= etype
;
2856 ptype
= build_pointer_type (gfc_array_index_type
);
2857 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
2860 base_decl
= build_decl (input_location
, VAR_DECL
, NULL_TREE
,
2861 indirect
? build_pointer_type (ptype
) : ptype
);
2862 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
2864 info
->base_decl
= base_decl
;
2866 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
2868 if (GFC_TYPE_ARRAY_SPAN (type
))
2869 elem_size
= GFC_TYPE_ARRAY_SPAN (type
);
2871 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
2872 field
= TYPE_FIELDS (TYPE_MAIN_VARIANT (type
));
2873 data_off
= byte_position (field
);
2874 field
= DECL_CHAIN (field
);
2875 field
= DECL_CHAIN (field
);
2876 field
= DECL_CHAIN (field
);
2877 dim_off
= byte_position (field
);
2878 dim_size
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field
)));
2879 field
= TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field
)));
2880 stride_suboff
= byte_position (field
);
2881 field
= DECL_CHAIN (field
);
2882 lower_suboff
= byte_position (field
);
2883 field
= DECL_CHAIN (field
);
2884 upper_suboff
= byte_position (field
);
2887 if (!integer_zerop (data_off
))
2888 t
= build2 (POINTER_PLUS_EXPR
, ptype
, t
, data_off
);
2889 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
2890 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
2891 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
2892 info
->allocated
= build2 (NE_EXPR
, boolean_type_node
,
2893 info
->data_location
, null_pointer_node
);
2894 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
2895 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
2896 info
->associated
= build2 (NE_EXPR
, boolean_type_node
,
2897 info
->data_location
, null_pointer_node
);
2899 for (dim
= 0; dim
< rank
; dim
++)
2901 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2902 size_binop (PLUS_EXPR
, dim_off
, lower_suboff
));
2903 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2904 info
->dimen
[dim
].lower_bound
= t
;
2905 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2906 size_binop (PLUS_EXPR
, dim_off
, upper_suboff
));
2907 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2908 info
->dimen
[dim
].upper_bound
= t
;
2909 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
2910 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
2912 /* Assumed shape arrays have known lower bounds. */
2913 info
->dimen
[dim
].upper_bound
2914 = build2 (MINUS_EXPR
, gfc_array_index_type
,
2915 info
->dimen
[dim
].upper_bound
,
2916 info
->dimen
[dim
].lower_bound
);
2917 info
->dimen
[dim
].lower_bound
2918 = fold_convert (gfc_array_index_type
,
2919 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
2920 info
->dimen
[dim
].upper_bound
2921 = build2 (PLUS_EXPR
, gfc_array_index_type
,
2922 info
->dimen
[dim
].lower_bound
,
2923 info
->dimen
[dim
].upper_bound
);
2925 t
= build2 (POINTER_PLUS_EXPR
, ptype
, base_decl
,
2926 size_binop (PLUS_EXPR
, dim_off
, stride_suboff
));
2927 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
2928 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
2929 info
->dimen
[dim
].stride
= t
;
2930 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
2936 #include "gt-fortran-trans-types.h"