1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-types.c -- gfortran backend types */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "fold-const.h"
33 #include "stor-layout.h"
34 #include "langhooks.h" /* For iso-c-bindings.def. */
35 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "trans-types.h"
37 #include "trans-const.h"
38 #include "trans-array.h"
39 #include "dwarf2out.h" /* For struct array_descr_info. */
43 #if (GFC_MAX_DIMENSIONS < 10)
44 #define GFC_RANK_DIGITS 1
45 #define GFC_RANK_PRINTF_FORMAT "%01d"
46 #elif (GFC_MAX_DIMENSIONS < 100)
47 #define GFC_RANK_DIGITS 2
48 #define GFC_RANK_PRINTF_FORMAT "%02d"
50 #error If you really need >99 dimensions, continue the sequence above...
53 /* array of structs so we don't have to worry about xmalloc or free */
54 CInteropKind_t c_interop_kinds_table
[ISOCBINDING_NUMBER
];
56 tree gfc_array_index_type
;
57 tree gfc_array_range_type
;
58 tree gfc_character1_type_node
;
60 tree prvoid_type_node
;
61 tree ppvoid_type_node
;
65 tree logical_type_node
;
66 tree logical_true_node
;
67 tree logical_false_node
;
68 tree gfc_charlen_type_node
;
70 tree gfc_float128_type_node
= NULL_TREE
;
71 tree gfc_complex_float128_type_node
= NULL_TREE
;
73 bool gfc_real16_is_float128
= false;
75 static GTY(()) tree gfc_desc_dim_type
;
76 static GTY(()) tree gfc_max_array_element_size
;
77 static GTY(()) tree gfc_array_descriptor_base
[2 * (GFC_MAX_DIMENSIONS
+1)];
78 static GTY(()) tree gfc_array_descriptor_base_caf
[2 * (GFC_MAX_DIMENSIONS
+1)];
80 /* Arrays for all integral and real kinds. We'll fill this in at runtime
81 after the target has a chance to process command-line options. */
83 #define MAX_INT_KINDS 5
84 gfc_integer_info gfc_integer_kinds
[MAX_INT_KINDS
+ 1];
85 gfc_logical_info gfc_logical_kinds
[MAX_INT_KINDS
+ 1];
86 static GTY(()) tree gfc_integer_types
[MAX_INT_KINDS
+ 1];
87 static GTY(()) tree gfc_logical_types
[MAX_INT_KINDS
+ 1];
89 #define MAX_REAL_KINDS 5
90 gfc_real_info gfc_real_kinds
[MAX_REAL_KINDS
+ 1];
91 static GTY(()) tree gfc_real_types
[MAX_REAL_KINDS
+ 1];
92 static GTY(()) tree gfc_complex_types
[MAX_REAL_KINDS
+ 1];
94 #define MAX_CHARACTER_KINDS 2
95 gfc_character_info gfc_character_kinds
[MAX_CHARACTER_KINDS
+ 1];
96 static GTY(()) tree gfc_character_types
[MAX_CHARACTER_KINDS
+ 1];
97 static GTY(()) tree gfc_pcharacter_types
[MAX_CHARACTER_KINDS
+ 1];
99 static tree
gfc_add_field_to_struct_1 (tree
, tree
, tree
, tree
**);
101 /* The integer kind to use for array indices. This will be set to the
102 proper value based on target information from the backend. */
104 int gfc_index_integer_kind
;
106 /* The default kinds of the various types. */
108 int gfc_default_integer_kind
;
109 int gfc_max_integer_kind
;
110 int gfc_default_real_kind
;
111 int gfc_default_double_kind
;
112 int gfc_default_character_kind
;
113 int gfc_default_logical_kind
;
114 int gfc_default_complex_kind
;
116 int gfc_atomic_int_kind
;
117 int gfc_atomic_logical_kind
;
119 /* The kind size used for record offsets. If the target system supports
120 kind=8, this will be set to 8, otherwise it is set to 4. */
123 /* The integer kind used to store character lengths. */
124 int gfc_charlen_int_kind
;
126 /* Kind of internal integer for storing object sizes. */
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
)
246 /* Get the kind number corresponding to a real of a given storage size.
247 If two real's have the same storage size, then choose the real with
248 the largest precision. If a kind type is unavailable and a real
249 exists with wider storage, then return -2; otherwise, return -1. */
252 gfc_get_real_kind_from_width_isofortranenv (int size
)
261 /* Look for a kind with matching storage size. */
262 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
263 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) == size
)
265 if (gfc_real_kinds
[i
].digits
> digits
)
267 digits
= gfc_real_kinds
[i
].digits
;
268 kind
= gfc_real_kinds
[i
].kind
;
275 /* Look for a kind with larger storage size. */
276 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
277 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds
[i
].kind
)) > size
)
286 get_int_kind_from_width (int size
)
290 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
291 if (gfc_integer_kinds
[i
].bit_size
== size
)
292 return gfc_integer_kinds
[i
].kind
;
298 get_int_kind_from_minimal_width (int size
)
302 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
303 if (gfc_integer_kinds
[i
].bit_size
>= size
)
304 return gfc_integer_kinds
[i
].kind
;
310 /* Generate the CInteropKind_t objects for the C interoperable
314 gfc_init_c_interop_kinds (void)
318 /* init all pointers in the list to NULL */
319 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
321 /* Initialize the name and value fields. */
322 c_interop_kinds_table
[i
].name
[0] = '\0';
323 c_interop_kinds_table
[i
].value
= -100;
324 c_interop_kinds_table
[i
].f90_type
= BT_UNKNOWN
;
327 #define NAMED_INTCST(a,b,c,d) \
328 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
329 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
330 c_interop_kinds_table[a].value = c;
331 #define NAMED_REALCST(a,b,c,d) \
332 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
333 c_interop_kinds_table[a].f90_type = BT_REAL; \
334 c_interop_kinds_table[a].value = c;
335 #define NAMED_CMPXCST(a,b,c,d) \
336 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
337 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
338 c_interop_kinds_table[a].value = c;
339 #define NAMED_LOGCST(a,b,c) \
340 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
341 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
342 c_interop_kinds_table[a].value = c;
343 #define NAMED_CHARKNDCST(a,b,c) \
344 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
345 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
346 c_interop_kinds_table[a].value = c;
347 #define NAMED_CHARCST(a,b,c) \
348 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
349 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
350 c_interop_kinds_table[a].value = c;
351 #define DERIVED_TYPE(a,b,c) \
352 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
353 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
354 c_interop_kinds_table[a].value = c;
355 #define NAMED_FUNCTION(a,b,c,d) \
356 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
357 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
358 c_interop_kinds_table[a].value = c;
359 #define NAMED_SUBROUTINE(a,b,c,d) \
360 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
361 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
362 c_interop_kinds_table[a].value = c;
363 #include "iso-c-binding.def"
367 /* Query the target to determine which machine modes are available for
368 computation. Choose KIND numbers for them. */
371 gfc_init_kinds (void)
373 opt_scalar_int_mode int_mode_iter
;
374 opt_scalar_float_mode float_mode_iter
;
375 int i_index
, r_index
, kind
;
376 bool saw_i4
= false, saw_i8
= false;
377 bool saw_r4
= false, saw_r8
= false, saw_r10
= false, saw_r16
= false;
380 FOR_EACH_MODE_IN_CLASS (int_mode_iter
, MODE_INT
)
382 scalar_int_mode mode
= int_mode_iter
.require ();
385 if (!targetm
.scalar_mode_supported_p (mode
))
388 /* The middle end doesn't support constants larger than 2*HWI.
389 Perhaps the target hook shouldn't have accepted these either,
390 but just to be safe... */
391 bitsize
= GET_MODE_BITSIZE (mode
);
392 if (bitsize
> 2*HOST_BITS_PER_WIDE_INT
)
395 gcc_assert (i_index
!= MAX_INT_KINDS
);
397 /* Let the kind equal the bit size divided by 8. This insulates the
398 programmer from the underlying byte size. */
406 gfc_integer_kinds
[i_index
].kind
= kind
;
407 gfc_integer_kinds
[i_index
].radix
= 2;
408 gfc_integer_kinds
[i_index
].digits
= bitsize
- 1;
409 gfc_integer_kinds
[i_index
].bit_size
= bitsize
;
411 gfc_logical_kinds
[i_index
].kind
= kind
;
412 gfc_logical_kinds
[i_index
].bit_size
= bitsize
;
417 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
418 used for large file access. */
425 /* If we do not at least have kind = 4, everything is pointless. */
428 /* Set the maximum integer kind. Used with at least BOZ constants. */
429 gfc_max_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
432 FOR_EACH_MODE_IN_CLASS (float_mode_iter
, MODE_FLOAT
)
434 scalar_float_mode mode
= float_mode_iter
.require ();
435 const struct real_format
*fmt
= REAL_MODE_FORMAT (mode
);
440 if (!targetm
.scalar_mode_supported_p (mode
))
443 /* Only let float, double, long double and __float128 go through.
444 Runtime support for others is not provided, so they would be
446 if (!targetm
.libgcc_floating_mode_supported_p (mode
))
448 if (mode
!= TYPE_MODE (float_type_node
)
449 && (mode
!= TYPE_MODE (double_type_node
))
450 && (mode
!= TYPE_MODE (long_double_type_node
))
451 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
457 /* Let the kind equal the precision divided by 8, rounding up. Again,
458 this insulates the programmer from the underlying byte size.
460 Also, it effectively deals with IEEE extended formats. There, the
461 total size of the type may equal 16, but it's got 6 bytes of padding
462 and the increased size can get in the way of a real IEEE quad format
463 which may also be supported by the target.
465 We round up so as to handle IA-64 __floatreg (RFmode), which is an
466 82 bit type. Not to be confused with __float80 (XFmode), which is
467 an 80 bit type also supported by IA-64. So XFmode should come out
468 to be kind=10, and RFmode should come out to be kind=11. Egads. */
470 kind
= (GET_MODE_PRECISION (mode
) + 7) / 8;
481 /* Careful we don't stumble a weird internal mode. */
482 gcc_assert (r_index
<= 0 || gfc_real_kinds
[r_index
-1].kind
!= kind
);
483 /* Or have too many modes for the allocated space. */
484 gcc_assert (r_index
!= MAX_REAL_KINDS
);
486 gfc_real_kinds
[r_index
].kind
= kind
;
487 gfc_real_kinds
[r_index
].radix
= fmt
->b
;
488 gfc_real_kinds
[r_index
].digits
= fmt
->p
;
489 gfc_real_kinds
[r_index
].min_exponent
= fmt
->emin
;
490 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
;
491 if (fmt
->pnan
< fmt
->p
)
492 /* This is an IBM extended double format (or the MIPS variant)
493 made up of two IEEE doubles. The value of the long double is
494 the sum of the values of the two parts. The most significant
495 part is required to be the value of the long double rounded
496 to the nearest double. If we use emax of 1024 then we can't
497 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
498 rounding will make the most significant part overflow. */
499 gfc_real_kinds
[r_index
].max_exponent
= fmt
->emax
- 1;
500 gfc_real_kinds
[r_index
].mode_precision
= GET_MODE_PRECISION (mode
);
504 /* Choose the default integer kind. We choose 4 unless the user directs us
505 otherwise. Even if the user specified that the default integer kind is 8,
506 the numeric storage size is not 64 bits. In this case, a warning will be
507 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
509 gfc_numeric_storage_size
= 4 * 8;
511 if (flag_default_integer
)
514 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
515 "%<-fdefault-integer-8%> option");
517 gfc_default_integer_kind
= 8;
520 else if (flag_integer4_kind
== 8)
523 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
524 "%<-finteger-4-integer-8%> option");
526 gfc_default_integer_kind
= 8;
530 gfc_default_integer_kind
= 4;
534 gfc_default_integer_kind
= gfc_integer_kinds
[i_index
- 1].kind
;
535 gfc_numeric_storage_size
= gfc_integer_kinds
[i_index
- 1].bit_size
;
538 /* Choose the default real kind. Again, we choose 4 when possible. */
539 if (flag_default_real_8
)
542 gfc_fatal_error ("REAL(KIND=8) is not available for "
543 "%<-fdefault-real-8%> option");
545 gfc_default_real_kind
= 8;
547 else if (flag_default_real_10
)
550 gfc_fatal_error ("REAL(KIND=10) is not available for "
551 "%<-fdefault-real-10%> option");
553 gfc_default_real_kind
= 10;
555 else if (flag_default_real_16
)
558 gfc_fatal_error ("REAL(KIND=16) is not available for "
559 "%<-fdefault-real-16%> option");
561 gfc_default_real_kind
= 16;
563 else if (flag_real4_kind
== 8)
566 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
569 gfc_default_real_kind
= 8;
571 else if (flag_real4_kind
== 10)
574 gfc_fatal_error ("REAL(KIND=10) is not available for "
575 "%<-freal-4-real-10%> option");
577 gfc_default_real_kind
= 10;
579 else if (flag_real4_kind
== 16)
582 gfc_fatal_error ("REAL(KIND=16) is not available for "
583 "%<-freal-4-real-16%> option");
585 gfc_default_real_kind
= 16;
588 gfc_default_real_kind
= 4;
590 gfc_default_real_kind
= gfc_real_kinds
[0].kind
;
592 /* Choose the default double kind. If -fdefault-real and -fdefault-double
593 are specified, we use kind=8, if it's available. If -fdefault-real is
594 specified without -fdefault-double, we use kind=16, if it's available.
595 Otherwise we do not change anything. */
596 if (flag_default_double
&& saw_r8
)
597 gfc_default_double_kind
= 8;
598 else if (flag_default_real_8
|| flag_default_real_10
|| flag_default_real_16
)
600 /* Use largest available kind. */
602 gfc_default_double_kind
= 16;
604 gfc_default_double_kind
= 10;
606 gfc_default_double_kind
= 8;
608 gfc_default_double_kind
= gfc_default_real_kind
;
610 else if (flag_real8_kind
== 4)
613 gfc_fatal_error ("REAL(KIND=4) is not available for "
614 "%<-freal-8-real-4%> option");
616 gfc_default_double_kind
= 4;
618 else if (flag_real8_kind
== 10 )
621 gfc_fatal_error ("REAL(KIND=10) is not available for "
622 "%<-freal-8-real-10%> option");
624 gfc_default_double_kind
= 10;
626 else if (flag_real8_kind
== 16 )
629 gfc_fatal_error ("REAL(KIND=10) is not available for "
630 "%<-freal-8-real-16%> option");
632 gfc_default_double_kind
= 16;
634 else if (saw_r4
&& saw_r8
)
635 gfc_default_double_kind
= 8;
638 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
639 real ... occupies two contiguous numeric storage units.
641 Therefore we must be supplied a kind twice as large as we chose
642 for single precision. There are loopholes, in that double
643 precision must *occupy* two storage units, though it doesn't have
644 to *use* two storage units. Which means that you can make this
645 kind artificially wide by padding it. But at present there are
646 no GCC targets for which a two-word type does not exist, so we
647 just let gfc_validate_kind abort and tell us if something breaks. */
649 gfc_default_double_kind
650 = gfc_validate_kind (BT_REAL
, gfc_default_real_kind
* 2, false);
653 /* The default logical kind is constrained to be the same as the
654 default integer kind. Similarly with complex and real. */
655 gfc_default_logical_kind
= gfc_default_integer_kind
;
656 gfc_default_complex_kind
= gfc_default_real_kind
;
658 /* We only have two character kinds: ASCII and UCS-4.
659 ASCII corresponds to a 8-bit integer type, if one is available.
660 UCS-4 corresponds to a 32-bit integer type, if one is available. */
662 if ((kind
= get_int_kind_from_width (8)) > 0)
664 gfc_character_kinds
[i_index
].kind
= kind
;
665 gfc_character_kinds
[i_index
].bit_size
= 8;
666 gfc_character_kinds
[i_index
].name
= "ascii";
669 if ((kind
= get_int_kind_from_width (32)) > 0)
671 gfc_character_kinds
[i_index
].kind
= kind
;
672 gfc_character_kinds
[i_index
].bit_size
= 32;
673 gfc_character_kinds
[i_index
].name
= "iso_10646";
677 /* Choose the smallest integer kind for our default character. */
678 gfc_default_character_kind
= gfc_character_kinds
[0].kind
;
679 gfc_character_storage_size
= gfc_default_character_kind
* 8;
681 gfc_index_integer_kind
= get_int_kind_from_name (PTRDIFF_TYPE
);
683 /* Pick a kind the same size as the C "int" type. */
684 gfc_c_int_kind
= INT_TYPE_SIZE
/ 8;
686 /* Choose atomic kinds to match C's int. */
687 gfc_atomic_int_kind
= gfc_c_int_kind
;
688 gfc_atomic_logical_kind
= gfc_c_int_kind
;
692 /* Make sure that a valid kind is present. Returns an index into the
693 associated kinds array, -1 if the kind is not present. */
696 validate_integer (int kind
)
700 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
701 if (gfc_integer_kinds
[i
].kind
== kind
)
708 validate_real (int kind
)
712 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
713 if (gfc_real_kinds
[i
].kind
== kind
)
720 validate_logical (int kind
)
724 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
725 if (gfc_logical_kinds
[i
].kind
== kind
)
732 validate_character (int kind
)
736 for (i
= 0; gfc_character_kinds
[i
].kind
; i
++)
737 if (gfc_character_kinds
[i
].kind
== kind
)
743 /* Validate a kind given a basic type. The return value is the same
744 for the child functions, with -1 indicating nonexistence of the
745 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
748 gfc_validate_kind (bt type
, int kind
, bool may_fail
)
754 case BT_REAL
: /* Fall through */
756 rc
= validate_real (kind
);
759 rc
= validate_integer (kind
);
762 rc
= validate_logical (kind
);
765 rc
= validate_character (kind
);
769 gfc_internal_error ("gfc_validate_kind(): Got bad type");
772 if (rc
< 0 && !may_fail
)
773 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
779 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
780 Reuse common type nodes where possible. Recognize if the kind matches up
781 with a C type. This will be used later in determining which routines may
782 be scarfed from libm. */
785 gfc_build_int_type (gfc_integer_info
*info
)
787 int mode_precision
= info
->bit_size
;
789 if (mode_precision
== CHAR_TYPE_SIZE
)
791 if (mode_precision
== SHORT_TYPE_SIZE
)
793 if (mode_precision
== INT_TYPE_SIZE
)
795 if (mode_precision
== LONG_TYPE_SIZE
)
797 if (mode_precision
== LONG_LONG_TYPE_SIZE
)
798 info
->c_long_long
= 1;
800 if (TYPE_PRECISION (intQI_type_node
) == mode_precision
)
801 return intQI_type_node
;
802 if (TYPE_PRECISION (intHI_type_node
) == mode_precision
)
803 return intHI_type_node
;
804 if (TYPE_PRECISION (intSI_type_node
) == mode_precision
)
805 return intSI_type_node
;
806 if (TYPE_PRECISION (intDI_type_node
) == mode_precision
)
807 return intDI_type_node
;
808 if (TYPE_PRECISION (intTI_type_node
) == mode_precision
)
809 return intTI_type_node
;
811 return make_signed_type (mode_precision
);
815 gfc_build_uint_type (int size
)
817 if (size
== CHAR_TYPE_SIZE
)
818 return unsigned_char_type_node
;
819 if (size
== SHORT_TYPE_SIZE
)
820 return short_unsigned_type_node
;
821 if (size
== INT_TYPE_SIZE
)
822 return unsigned_type_node
;
823 if (size
== LONG_TYPE_SIZE
)
824 return long_unsigned_type_node
;
825 if (size
== LONG_LONG_TYPE_SIZE
)
826 return long_long_unsigned_type_node
;
828 return make_unsigned_type (size
);
833 gfc_build_real_type (gfc_real_info
*info
)
835 int mode_precision
= info
->mode_precision
;
838 if (mode_precision
== FLOAT_TYPE_SIZE
)
840 if (mode_precision
== DOUBLE_TYPE_SIZE
)
842 if (mode_precision
== LONG_DOUBLE_TYPE_SIZE
)
843 info
->c_long_double
= 1;
844 if (mode_precision
!= LONG_DOUBLE_TYPE_SIZE
&& mode_precision
== 128)
846 info
->c_float128
= 1;
847 gfc_real16_is_float128
= true;
850 if (TYPE_PRECISION (float_type_node
) == mode_precision
)
851 return float_type_node
;
852 if (TYPE_PRECISION (double_type_node
) == mode_precision
)
853 return double_type_node
;
854 if (TYPE_PRECISION (long_double_type_node
) == mode_precision
)
855 return long_double_type_node
;
857 new_type
= make_node (REAL_TYPE
);
858 TYPE_PRECISION (new_type
) = mode_precision
;
859 layout_type (new_type
);
864 gfc_build_complex_type (tree scalar_type
)
868 if (scalar_type
== NULL
)
870 if (scalar_type
== float_type_node
)
871 return complex_float_type_node
;
872 if (scalar_type
== double_type_node
)
873 return complex_double_type_node
;
874 if (scalar_type
== long_double_type_node
)
875 return complex_long_double_type_node
;
877 new_type
= make_node (COMPLEX_TYPE
);
878 TREE_TYPE (new_type
) = scalar_type
;
879 layout_type (new_type
);
884 gfc_build_logical_type (gfc_logical_info
*info
)
886 int bit_size
= info
->bit_size
;
889 if (bit_size
== BOOL_TYPE_SIZE
)
892 return boolean_type_node
;
895 new_type
= make_unsigned_type (bit_size
);
896 TREE_SET_CODE (new_type
, BOOLEAN_TYPE
);
897 TYPE_MAX_VALUE (new_type
) = build_int_cst (new_type
, 1);
898 TYPE_PRECISION (new_type
) = 1;
904 /* Create the backend type nodes. We map them to their
905 equivalent C type, at least for now. We also give
906 names to the types here, and we push them in the
907 global binding level context.*/
910 gfc_init_types (void)
917 /* Create and name the types. */
918 #define PUSH_TYPE(name, node) \
919 pushdecl (build_decl (input_location, \
920 TYPE_DECL, get_identifier (name), node))
922 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
924 type
= gfc_build_int_type (&gfc_integer_kinds
[index
]);
925 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
926 if (TYPE_STRING_FLAG (type
))
927 type
= make_signed_type (gfc_integer_kinds
[index
].bit_size
);
928 gfc_integer_types
[index
] = type
;
929 snprintf (name_buf
, sizeof(name_buf
), "integer(kind=%d)",
930 gfc_integer_kinds
[index
].kind
);
931 PUSH_TYPE (name_buf
, type
);
934 for (index
= 0; gfc_logical_kinds
[index
].kind
!= 0; ++index
)
936 type
= gfc_build_logical_type (&gfc_logical_kinds
[index
]);
937 gfc_logical_types
[index
] = type
;
938 snprintf (name_buf
, sizeof(name_buf
), "logical(kind=%d)",
939 gfc_logical_kinds
[index
].kind
);
940 PUSH_TYPE (name_buf
, type
);
943 for (index
= 0; gfc_real_kinds
[index
].kind
!= 0; index
++)
945 type
= gfc_build_real_type (&gfc_real_kinds
[index
]);
946 gfc_real_types
[index
] = type
;
947 snprintf (name_buf
, sizeof(name_buf
), "real(kind=%d)",
948 gfc_real_kinds
[index
].kind
);
949 PUSH_TYPE (name_buf
, type
);
951 if (gfc_real_kinds
[index
].c_float128
)
952 gfc_float128_type_node
= type
;
954 type
= gfc_build_complex_type (type
);
955 gfc_complex_types
[index
] = type
;
956 snprintf (name_buf
, sizeof(name_buf
), "complex(kind=%d)",
957 gfc_real_kinds
[index
].kind
);
958 PUSH_TYPE (name_buf
, type
);
960 if (gfc_real_kinds
[index
].c_float128
)
961 gfc_complex_float128_type_node
= type
;
964 for (index
= 0; gfc_character_kinds
[index
].kind
!= 0; ++index
)
966 type
= gfc_build_uint_type (gfc_character_kinds
[index
].bit_size
);
967 type
= build_qualified_type (type
, TYPE_UNQUALIFIED
);
968 snprintf (name_buf
, sizeof(name_buf
), "character(kind=%d)",
969 gfc_character_kinds
[index
].kind
);
970 PUSH_TYPE (name_buf
, type
);
971 gfc_character_types
[index
] = type
;
972 gfc_pcharacter_types
[index
] = build_pointer_type (type
);
974 gfc_character1_type_node
= gfc_character_types
[0];
976 PUSH_TYPE ("byte", unsigned_char_type_node
);
977 PUSH_TYPE ("void", void_type_node
);
979 /* DBX debugging output gets upset if these aren't set. */
980 if (!TYPE_NAME (integer_type_node
))
981 PUSH_TYPE ("c_integer", integer_type_node
);
982 if (!TYPE_NAME (char_type_node
))
983 PUSH_TYPE ("c_char", char_type_node
);
987 pvoid_type_node
= build_pointer_type (void_type_node
);
988 prvoid_type_node
= build_qualified_type (pvoid_type_node
, TYPE_QUAL_RESTRICT
);
989 ppvoid_type_node
= build_pointer_type (pvoid_type_node
);
990 pchar_type_node
= build_pointer_type (gfc_character1_type_node
);
992 = build_pointer_type (build_function_type_list (void_type_node
, NULL_TREE
));
994 gfc_array_index_type
= gfc_get_int_type (gfc_index_integer_kind
);
995 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
996 since this function is called before gfc_init_constants. */
998 = build_range_type (gfc_array_index_type
,
999 build_int_cst (gfc_array_index_type
, 0),
1002 /* The maximum array element size that can be handled is determined
1003 by the number of bits available to store this field in the array
1006 n
= TYPE_PRECISION (gfc_array_index_type
) - GFC_DTYPE_SIZE_SHIFT
;
1007 gfc_max_array_element_size
1008 = wide_int_to_tree (size_type_node
,
1009 wi::mask (n
, UNSIGNED
,
1010 TYPE_PRECISION (size_type_node
)));
1012 logical_type_node
= gfc_get_logical_type (gfc_default_logical_kind
);
1013 logical_true_node
= build_int_cst (logical_type_node
, 1);
1014 logical_false_node
= build_int_cst (logical_type_node
, 0);
1016 /* Character lengths are of type size_t, except signed. */
1017 gfc_charlen_int_kind
= get_int_kind_from_node (size_type_node
);
1018 gfc_charlen_type_node
= gfc_get_int_type (gfc_charlen_int_kind
);
1020 /* Fortran kind number of size_type_node (size_t). This is used for
1021 the _size member in vtables. */
1022 gfc_size_kind
= get_int_kind_from_node (size_type_node
);
1025 /* Get the type node for the given type and kind. */
1028 gfc_get_int_type (int kind
)
1030 int index
= gfc_validate_kind (BT_INTEGER
, kind
, true);
1031 return index
< 0 ? 0 : gfc_integer_types
[index
];
1035 gfc_get_real_type (int kind
)
1037 int index
= gfc_validate_kind (BT_REAL
, kind
, true);
1038 return index
< 0 ? 0 : gfc_real_types
[index
];
1042 gfc_get_complex_type (int kind
)
1044 int index
= gfc_validate_kind (BT_COMPLEX
, kind
, true);
1045 return index
< 0 ? 0 : gfc_complex_types
[index
];
1049 gfc_get_logical_type (int kind
)
1051 int index
= gfc_validate_kind (BT_LOGICAL
, kind
, true);
1052 return index
< 0 ? 0 : gfc_logical_types
[index
];
1056 gfc_get_char_type (int kind
)
1058 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1059 return index
< 0 ? 0 : gfc_character_types
[index
];
1063 gfc_get_pchar_type (int kind
)
1065 int index
= gfc_validate_kind (BT_CHARACTER
, kind
, true);
1066 return index
< 0 ? 0 : gfc_pcharacter_types
[index
];
1070 /* Create a character type with the given kind and length. */
1073 gfc_get_character_type_len_for_eltype (tree eltype
, tree len
)
1077 bounds
= build_range_type (gfc_charlen_type_node
, gfc_index_one_node
, len
);
1078 type
= build_array_type (eltype
, bounds
);
1079 TYPE_STRING_FLAG (type
) = 1;
1085 gfc_get_character_type_len (int kind
, tree len
)
1087 gfc_validate_kind (BT_CHARACTER
, kind
, false);
1088 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind
), len
);
1092 /* Get a type node for a character kind. */
1095 gfc_get_character_type (int kind
, gfc_charlen
* cl
)
1099 len
= (cl
== NULL
) ? NULL_TREE
: cl
->backend_decl
;
1100 if (len
&& POINTER_TYPE_P (TREE_TYPE (len
)))
1101 len
= build_fold_indirect_ref (len
);
1103 return gfc_get_character_type_len (kind
, len
);
1106 /* Convert a basic type. This will be an array for character types. */
1109 gfc_typenode_for_spec (gfc_typespec
* spec
, int codim
)
1119 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1120 has been resolved. This is done so we can convert C_PTR and
1121 C_FUNPTR to simple variables that get translated to (void *). */
1122 if (spec
->f90_type
== BT_VOID
)
1125 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1126 basetype
= ptr_type_node
;
1128 basetype
= pfunc_type_node
;
1131 basetype
= gfc_get_int_type (spec
->kind
);
1135 basetype
= gfc_get_real_type (spec
->kind
);
1139 basetype
= gfc_get_complex_type (spec
->kind
);
1143 basetype
= gfc_get_logical_type (spec
->kind
);
1147 basetype
= gfc_get_character_type (spec
->kind
, spec
->u
.cl
);
1151 /* Since this cannot be used, return a length one character. */
1152 basetype
= gfc_get_character_type_len (gfc_default_character_kind
,
1153 gfc_index_one_node
);
1157 basetype
= gfc_get_union_type (spec
->u
.derived
);
1162 basetype
= gfc_get_derived_type (spec
->u
.derived
, codim
);
1164 if (spec
->type
== BT_CLASS
)
1165 GFC_CLASS_TYPE_P (basetype
) = 1;
1167 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1168 type and kind to fit a (void *) and the basetype returned was a
1169 ptr_type_node. We need to pass up this new information to the
1170 symbol that was declared of type C_PTR or C_FUNPTR. */
1171 if (spec
->u
.derived
->ts
.f90_type
== BT_VOID
)
1173 spec
->type
= BT_INTEGER
;
1174 spec
->kind
= gfc_index_integer_kind
;
1175 spec
->f90_type
= BT_VOID
;
1180 /* This is for the second arg to c_f_pointer and c_f_procpointer
1181 of the iso_c_binding module, to accept any ptr type. */
1182 basetype
= ptr_type_node
;
1183 if (spec
->f90_type
== BT_VOID
)
1186 && spec
->u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
)
1187 basetype
= ptr_type_node
;
1189 basetype
= pfunc_type_node
;
1198 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1201 gfc_conv_array_bound (gfc_expr
* expr
)
1203 /* If expr is an integer constant, return that. */
1204 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
1205 return gfc_conv_mpz_to_tree (expr
->value
.integer
, gfc_index_integer_kind
);
1207 /* Otherwise return NULL. */
1211 /* Return the type of an element of the array. Note that scalar coarrays
1212 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1213 (with POINTER_TYPE stripped) is returned. */
1216 gfc_get_element_type (tree type
)
1220 if (GFC_ARRAY_TYPE_P (type
))
1222 if (TREE_CODE (type
) == POINTER_TYPE
)
1223 type
= TREE_TYPE (type
);
1224 if (GFC_TYPE_ARRAY_RANK (type
) == 0)
1226 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
1231 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1232 element
= TREE_TYPE (type
);
1237 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
1238 element
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
1240 gcc_assert (TREE_CODE (element
) == POINTER_TYPE
);
1241 element
= TREE_TYPE (element
);
1243 /* For arrays, which are not scalar coarrays. */
1244 if (TREE_CODE (element
) == ARRAY_TYPE
&& !TYPE_STRING_FLAG (element
))
1245 element
= TREE_TYPE (element
);
1251 /* Build an array. This function is called from gfc_sym_type().
1252 Actually returns array descriptor type.
1254 Format of array descriptors is as follows:
1256 struct gfc_array_descriptor
1261 struct descriptor_dimension dimension[N_DIM];
1264 struct descriptor_dimension
1271 Translation code should use gfc_conv_descriptor_* rather than
1272 accessing the descriptor directly. Any changes to the array
1273 descriptor type will require changes in gfc_conv_descriptor_* and
1274 gfc_build_array_initializer.
1276 This is represented internally as a RECORD_TYPE. The index nodes
1277 are gfc_array_index_type and the data node is a pointer to the
1278 data. See below for the handling of character types.
1280 The dtype member is formatted as follows:
1281 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1282 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1283 size = dtype >> GFC_DTYPE_SIZE_SHIFT
1285 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1286 this generated poor code for assumed/deferred size arrays. These
1287 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1288 of the GENERIC grammar. Also, there is no way to explicitly set
1289 the array stride, so all data must be packed(1). I've tried to
1290 mark all the functions which would require modification with a GCC
1293 The data component points to the first element in the array. The
1294 offset field is the position of the origin of the array (i.e. element
1295 (0, 0 ...)). This may be outside the bounds of the array.
1297 An element is accessed by
1298 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1299 This gives good performance as the computation does not involve the
1300 bounds of the array. For packed arrays, this is optimized further
1301 by substituting the known strides.
1303 This system has one problem: all array bounds must be within 2^31
1304 elements of the origin (2^63 on 64-bit machines). For example
1305 integer, dimension (80000:90000, 80000:90000, 2) :: array
1306 may not work properly on 32-bit machines because 80000*80000 >
1307 2^31, so the calculation for stride2 would overflow. This may
1308 still work, but I haven't checked, and it relies on the overflow
1309 doing the right thing.
1311 The way to fix this problem is to access elements as follows:
1312 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1313 Obviously this is much slower. I will make this a compile time
1314 option, something like -fsmall-array-offsets. Mixing code compiled
1315 with and without this switch will work.
1317 (1) This can be worked around by modifying the upper bound of the
1318 previous dimension. This requires extra fields in the descriptor
1319 (both real_ubound and fake_ubound). */
1322 /* Returns true if the array sym does not require a descriptor. */
1325 gfc_is_nodesc_array (gfc_symbol
* sym
)
1327 symbol_attribute
*array_attr
;
1329 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1331 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1332 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1334 gcc_assert (array_attr
->dimension
|| array_attr
->codimension
);
1336 /* We only want local arrays. */
1337 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1338 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1339 || array_attr
->allocatable
)
1342 /* We want a descriptor for associate-name arrays that do not have an
1343 explicitly known shape already. */
1344 if (sym
->assoc
&& as
->type
!= AS_EXPLICIT
)
1347 /* The dummy is stored in sym and not in the component. */
1348 if (sym
->attr
.dummy
)
1349 return as
->type
!= AS_ASSUMED_SHAPE
1350 && as
->type
!= AS_ASSUMED_RANK
;
1352 if (sym
->attr
.result
|| sym
->attr
.function
)
1355 gcc_assert (as
->type
== AS_EXPLICIT
|| as
->cp_was_assumed
);
1361 /* Create an array descriptor type. */
1364 gfc_build_array_type (tree type
, gfc_array_spec
* as
,
1365 enum gfc_array_kind akind
, bool restricted
,
1366 bool contiguous
, int codim
)
1368 tree lbound
[GFC_MAX_DIMENSIONS
];
1369 tree ubound
[GFC_MAX_DIMENSIONS
];
1372 /* Assumed-shape arrays do not have codimension information stored in the
1374 corank
= MAX (as
->corank
, codim
);
1375 if (as
->type
== AS_ASSUMED_SHAPE
||
1376 (as
->type
== AS_ASSUMED_RANK
&& akind
== GFC_ARRAY_ALLOCATABLE
))
1379 if (as
->type
== AS_ASSUMED_RANK
)
1380 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
1382 lbound
[n
] = NULL_TREE
;
1383 ubound
[n
] = NULL_TREE
;
1386 for (n
= 0; n
< as
->rank
; n
++)
1388 /* Create expressions for the known bounds of the array. */
1389 if (as
->type
== AS_ASSUMED_SHAPE
&& as
->lower
[n
] == NULL
)
1390 lbound
[n
] = gfc_index_one_node
;
1392 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1393 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1396 for (n
= as
->rank
; n
< as
->rank
+ corank
; n
++)
1398 if (as
->type
!= AS_DEFERRED
&& as
->lower
[n
] == NULL
)
1399 lbound
[n
] = gfc_index_one_node
;
1401 lbound
[n
] = gfc_conv_array_bound (as
->lower
[n
]);
1403 if (n
< as
->rank
+ corank
- 1)
1404 ubound
[n
] = gfc_conv_array_bound (as
->upper
[n
]);
1407 if (as
->type
== AS_ASSUMED_SHAPE
)
1408 akind
= contiguous
? GFC_ARRAY_ASSUMED_SHAPE_CONT
1409 : GFC_ARRAY_ASSUMED_SHAPE
;
1410 else if (as
->type
== AS_ASSUMED_RANK
)
1411 akind
= contiguous
? GFC_ARRAY_ASSUMED_RANK_CONT
1412 : GFC_ARRAY_ASSUMED_RANK
;
1413 return gfc_get_array_type_bounds (type
, as
->rank
== -1
1414 ? GFC_MAX_DIMENSIONS
: as
->rank
,
1415 corank
, lbound
, ubound
, 0, akind
,
1419 /* Returns the struct descriptor_dimension type. */
1422 gfc_get_desc_dim_type (void)
1425 tree decl
, *chain
= NULL
;
1427 if (gfc_desc_dim_type
)
1428 return gfc_desc_dim_type
;
1430 /* Build the type node. */
1431 type
= make_node (RECORD_TYPE
);
1433 TYPE_NAME (type
) = get_identifier ("descriptor_dimension");
1434 TYPE_PACKED (type
) = 1;
1436 /* Consists of the stride, lbound and ubound members. */
1437 decl
= gfc_add_field_to_struct_1 (type
,
1438 get_identifier ("stride"),
1439 gfc_array_index_type
, &chain
);
1440 TREE_NO_WARNING (decl
) = 1;
1442 decl
= gfc_add_field_to_struct_1 (type
,
1443 get_identifier ("lbound"),
1444 gfc_array_index_type
, &chain
);
1445 TREE_NO_WARNING (decl
) = 1;
1447 decl
= gfc_add_field_to_struct_1 (type
,
1448 get_identifier ("ubound"),
1449 gfc_array_index_type
, &chain
);
1450 TREE_NO_WARNING (decl
) = 1;
1452 /* Finish off the type. */
1453 gfc_finish_type (type
);
1454 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
1456 gfc_desc_dim_type
= type
;
1461 /* Return the DTYPE for an array. This describes the type and type parameters
1463 /* TODO: Only call this when the value is actually used, and make all the
1464 unknown cases abort. */
1467 gfc_get_dtype_rank_type (int rank
, tree etype
)
1475 switch (TREE_CODE (etype
))
1493 /* We will never have arrays of arrays. */
1507 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1508 /* We can strange array types for temporary arrays. */
1509 return gfc_index_zero_node
;
1512 gcc_assert (rank
<= GFC_DTYPE_RANK_MASK
);
1513 size
= TYPE_SIZE_UNIT (etype
);
1515 i
= rank
| (n
<< GFC_DTYPE_TYPE_SHIFT
);
1516 if (size
&& INTEGER_CST_P (size
))
1518 if (tree_int_cst_lt (gfc_max_array_element_size
, size
))
1519 gfc_fatal_error ("Array element size too big at %C");
1521 i
+= TREE_INT_CST_LOW (size
) << GFC_DTYPE_SIZE_SHIFT
;
1523 dtype
= build_int_cst (gfc_array_index_type
, i
);
1525 if (size
&& !INTEGER_CST_P (size
))
1527 tmp
= build_int_cst (gfc_array_index_type
, GFC_DTYPE_SIZE_SHIFT
);
1528 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
,
1529 gfc_array_index_type
,
1530 fold_convert (gfc_array_index_type
, size
), tmp
);
1531 dtype
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1534 /* If we don't know the size we leave it as zero. This should never happen
1535 for anything that is actually used. */
1536 /* TODO: Check this is actually true, particularly when repacking
1537 assumed size parameters. */
1544 gfc_get_dtype (tree type
)
1550 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
));
1552 if (GFC_TYPE_ARRAY_DTYPE (type
))
1553 return GFC_TYPE_ARRAY_DTYPE (type
);
1555 rank
= GFC_TYPE_ARRAY_RANK (type
);
1556 etype
= gfc_get_element_type (type
);
1557 dtype
= gfc_get_dtype_rank_type (rank
, etype
);
1559 GFC_TYPE_ARRAY_DTYPE (type
) = dtype
;
1564 /* Build an array type for use without a descriptor, packed according
1565 to the value of PACKED. */
1568 gfc_get_nodesc_array_type (tree etype
, gfc_array_spec
* as
, gfc_packed packed
,
1582 mpz_init_set_ui (offset
, 0);
1583 mpz_init_set_ui (stride
, 1);
1586 /* We don't use build_array_type because this does not include include
1587 lang-specific information (i.e. the bounds of the array) when checking
1590 type
= make_node (ARRAY_TYPE
);
1592 type
= build_variant_type_copy (etype
);
1594 GFC_ARRAY_TYPE_P (type
) = 1;
1595 TYPE_LANG_SPECIFIC (type
) = ggc_cleared_alloc
<struct lang_type
> ();
1597 known_stride
= (packed
!= PACKED_NO
);
1599 for (n
= 0; n
< as
->rank
; n
++)
1601 /* Fill in the stride and bound components of the type. */
1603 tmp
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1606 GFC_TYPE_ARRAY_STRIDE (type
, n
) = tmp
;
1608 expr
= as
->lower
[n
];
1609 if (expr
->expr_type
== EXPR_CONSTANT
)
1611 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1612 gfc_index_integer_kind
);
1619 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1623 /* Calculate the offset. */
1624 mpz_mul (delta
, stride
, as
->lower
[n
]->value
.integer
);
1625 mpz_sub (offset
, offset
, delta
);
1630 expr
= as
->upper
[n
];
1631 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1633 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1634 gfc_index_integer_kind
);
1641 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1645 /* Calculate the stride. */
1646 mpz_sub (delta
, as
->upper
[n
]->value
.integer
,
1647 as
->lower
[n
]->value
.integer
);
1648 mpz_add_ui (delta
, delta
, 1);
1649 mpz_mul (stride
, stride
, delta
);
1652 /* Only the first stride is known for partial packed arrays. */
1653 if (packed
== PACKED_NO
|| packed
== PACKED_PARTIAL
)
1656 for (n
= as
->rank
; n
< as
->rank
+ as
->corank
; n
++)
1658 expr
= as
->lower
[n
];
1659 if (expr
->expr_type
== EXPR_CONSTANT
)
1660 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1661 gfc_index_integer_kind
);
1664 GFC_TYPE_ARRAY_LBOUND (type
, n
) = tmp
;
1666 expr
= as
->upper
[n
];
1667 if (expr
&& expr
->expr_type
== EXPR_CONSTANT
)
1668 tmp
= gfc_conv_mpz_to_tree (expr
->value
.integer
,
1669 gfc_index_integer_kind
);
1672 if (n
< as
->rank
+ as
->corank
- 1)
1673 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1678 GFC_TYPE_ARRAY_OFFSET (type
) =
1679 gfc_conv_mpz_to_tree (offset
, gfc_index_integer_kind
);
1682 GFC_TYPE_ARRAY_OFFSET (type
) = NULL_TREE
;
1686 GFC_TYPE_ARRAY_SIZE (type
) =
1687 gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1690 GFC_TYPE_ARRAY_SIZE (type
) = NULL_TREE
;
1692 GFC_TYPE_ARRAY_RANK (type
) = as
->rank
;
1693 GFC_TYPE_ARRAY_CORANK (type
) = as
->corank
;
1694 GFC_TYPE_ARRAY_DTYPE (type
) = NULL_TREE
;
1695 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1697 /* TODO: use main type if it is unbounded. */
1698 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1699 build_pointer_type (build_array_type (etype
, range
));
1701 GFC_TYPE_ARRAY_DATAPTR_TYPE (type
) =
1702 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type
),
1703 TYPE_QUAL_RESTRICT
);
1707 if (packed
!= PACKED_STATIC
|| flag_coarray
== GFC_FCOARRAY_LIB
)
1709 type
= build_pointer_type (type
);
1712 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1714 GFC_ARRAY_TYPE_P (type
) = 1;
1715 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1723 mpz_sub_ui (stride
, stride
, 1);
1724 range
= gfc_conv_mpz_to_tree (stride
, gfc_index_integer_kind
);
1729 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, range
);
1730 TYPE_DOMAIN (type
) = range
;
1732 build_pointer_type (etype
);
1733 TREE_TYPE (type
) = etype
;
1741 /* Represent packed arrays as multi-dimensional if they have rank >
1742 1 and with proper bounds, instead of flat arrays. This makes for
1743 better debug info. */
1746 tree gtype
= etype
, rtype
, type_decl
;
1748 for (n
= as
->rank
- 1; n
>= 0; n
--)
1750 rtype
= build_range_type (gfc_array_index_type
,
1751 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1752 GFC_TYPE_ARRAY_UBOUND (type
, n
));
1753 gtype
= build_array_type (gtype
, rtype
);
1755 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1756 TYPE_DECL
, NULL
, gtype
);
1757 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1760 if (packed
!= PACKED_STATIC
|| !known_stride
1761 || (as
->corank
&& flag_coarray
== GFC_FCOARRAY_LIB
))
1763 /* For dummy arrays and automatic (heap allocated) arrays we
1764 want a pointer to the array. */
1765 type
= build_pointer_type (type
);
1767 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
1768 GFC_ARRAY_TYPE_P (type
) = 1;
1769 TYPE_LANG_SPECIFIC (type
) = TYPE_LANG_SPECIFIC (TREE_TYPE (type
));
1775 /* Return or create the base type for an array descriptor. */
1778 gfc_get_array_descriptor_base (int dimen
, int codimen
, bool restricted
)
1780 tree fat_type
, decl
, arraytype
, *chain
= NULL
;
1781 char name
[16 + 2*GFC_RANK_DIGITS
+ 1 + 1];
1784 /* Assumed-rank array. */
1786 dimen
= GFC_MAX_DIMENSIONS
;
1788 idx
= 2 * (codimen
+ dimen
) + restricted
;
1790 gcc_assert (codimen
+ dimen
>= 0 && codimen
+ dimen
<= GFC_MAX_DIMENSIONS
);
1792 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1794 if (gfc_array_descriptor_base_caf
[idx
])
1795 return gfc_array_descriptor_base_caf
[idx
];
1797 else if (gfc_array_descriptor_base
[idx
])
1798 return gfc_array_descriptor_base
[idx
];
1800 /* Build the type node. */
1801 fat_type
= make_node (RECORD_TYPE
);
1803 sprintf (name
, "array_descriptor" GFC_RANK_PRINTF_FORMAT
, dimen
+ codimen
);
1804 TYPE_NAME (fat_type
) = get_identifier (name
);
1805 TYPE_NAMELESS (fat_type
) = 1;
1807 /* Add the data member as the first element of the descriptor. */
1808 decl
= gfc_add_field_to_struct_1 (fat_type
,
1809 get_identifier ("data"),
1812 : ptr_type_node
), &chain
);
1814 /* Add the base component. */
1815 decl
= gfc_add_field_to_struct_1 (fat_type
,
1816 get_identifier ("offset"),
1817 gfc_array_index_type
, &chain
);
1818 TREE_NO_WARNING (decl
) = 1;
1820 /* Add the dtype component. */
1821 decl
= gfc_add_field_to_struct_1 (fat_type
,
1822 get_identifier ("dtype"),
1823 gfc_array_index_type
, &chain
);
1824 TREE_NO_WARNING (decl
) = 1;
1826 /* Add the span component. */
1827 decl
= gfc_add_field_to_struct_1 (fat_type
,
1828 get_identifier ("span"),
1829 gfc_array_index_type
, &chain
);
1830 TREE_NO_WARNING (decl
) = 1;
1832 /* Build the array type for the stride and bound components. */
1833 if (dimen
+ codimen
> 0)
1836 build_array_type (gfc_get_desc_dim_type (),
1837 build_range_type (gfc_array_index_type
,
1838 gfc_index_zero_node
,
1839 gfc_rank_cst
[codimen
+ dimen
- 1]));
1841 decl
= gfc_add_field_to_struct_1 (fat_type
, get_identifier ("dim"),
1843 TREE_NO_WARNING (decl
) = 1;
1846 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1848 decl
= gfc_add_field_to_struct_1 (fat_type
,
1849 get_identifier ("token"),
1850 prvoid_type_node
, &chain
);
1851 TREE_NO_WARNING (decl
) = 1;
1854 /* Finish off the type. */
1855 gfc_finish_type (fat_type
);
1856 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type
)) = 1;
1858 if (flag_coarray
== GFC_FCOARRAY_LIB
&& codimen
)
1859 gfc_array_descriptor_base_caf
[idx
] = fat_type
;
1861 gfc_array_descriptor_base
[idx
] = fat_type
;
1867 /* Build an array (descriptor) type with given bounds. */
1870 gfc_get_array_type_bounds (tree etype
, int dimen
, int codimen
, tree
* lbound
,
1871 tree
* ubound
, int packed
,
1872 enum gfc_array_kind akind
, bool restricted
)
1874 char name
[8 + 2*GFC_RANK_DIGITS
+ 1 + GFC_MAX_SYMBOL_LEN
];
1875 tree fat_type
, base_type
, arraytype
, lower
, upper
, stride
, tmp
, rtype
;
1876 const char *type_name
;
1879 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, restricted
);
1880 fat_type
= build_distinct_type_copy (base_type
);
1881 /* Make sure that nontarget and target array type have the same canonical
1882 type (and same stub decl for debug info). */
1883 base_type
= gfc_get_array_descriptor_base (dimen
, codimen
, false);
1884 TYPE_CANONICAL (fat_type
) = base_type
;
1885 TYPE_STUB_DECL (fat_type
) = TYPE_STUB_DECL (base_type
);
1887 tmp
= TYPE_NAME (etype
);
1888 if (tmp
&& TREE_CODE (tmp
) == TYPE_DECL
)
1889 tmp
= DECL_NAME (tmp
);
1891 type_name
= IDENTIFIER_POINTER (tmp
);
1893 type_name
= "unknown";
1894 sprintf (name
, "array" GFC_RANK_PRINTF_FORMAT
"_%.*s", dimen
+ codimen
,
1895 GFC_MAX_SYMBOL_LEN
, type_name
);
1896 TYPE_NAME (fat_type
) = get_identifier (name
);
1897 TYPE_NAMELESS (fat_type
) = 1;
1899 GFC_DESCRIPTOR_TYPE_P (fat_type
) = 1;
1900 TYPE_LANG_SPECIFIC (fat_type
) = ggc_cleared_alloc
<struct lang_type
> ();
1902 GFC_TYPE_ARRAY_RANK (fat_type
) = dimen
;
1903 GFC_TYPE_ARRAY_CORANK (fat_type
) = codimen
;
1904 GFC_TYPE_ARRAY_DTYPE (fat_type
) = NULL_TREE
;
1905 GFC_TYPE_ARRAY_AKIND (fat_type
) = akind
;
1907 /* Build an array descriptor record type. */
1909 stride
= gfc_index_one_node
;
1912 for (n
= 0; n
< dimen
+ codimen
; n
++)
1915 GFC_TYPE_ARRAY_STRIDE (fat_type
, n
) = stride
;
1922 if (lower
!= NULL_TREE
)
1924 if (INTEGER_CST_P (lower
))
1925 GFC_TYPE_ARRAY_LBOUND (fat_type
, n
) = lower
;
1930 if (codimen
&& n
== dimen
+ codimen
- 1)
1934 if (upper
!= NULL_TREE
)
1936 if (INTEGER_CST_P (upper
))
1937 GFC_TYPE_ARRAY_UBOUND (fat_type
, n
) = upper
;
1945 if (upper
!= NULL_TREE
&& lower
!= NULL_TREE
&& stride
!= NULL_TREE
)
1947 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1948 gfc_array_index_type
, upper
, lower
);
1949 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1950 gfc_array_index_type
, tmp
,
1951 gfc_index_one_node
);
1952 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
1953 gfc_array_index_type
, tmp
, stride
);
1954 /* Check the folding worked. */
1955 gcc_assert (INTEGER_CST_P (stride
));
1960 GFC_TYPE_ARRAY_SIZE (fat_type
) = stride
;
1962 /* TODO: known offsets for descriptors. */
1963 GFC_TYPE_ARRAY_OFFSET (fat_type
) = NULL_TREE
;
1967 arraytype
= build_pointer_type (etype
);
1969 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1971 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1975 /* We define data as an array with the correct size if possible.
1976 Much better than doing pointer arithmetic. */
1978 rtype
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1979 int_const_binop (MINUS_EXPR
, stride
,
1980 build_int_cst (TREE_TYPE (stride
), 1)));
1982 rtype
= gfc_array_range_type
;
1983 arraytype
= build_array_type (etype
, rtype
);
1984 arraytype
= build_pointer_type (arraytype
);
1986 arraytype
= build_qualified_type (arraytype
, TYPE_QUAL_RESTRICT
);
1987 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type
) = arraytype
;
1989 /* This will generate the base declarations we need to emit debug
1990 information for this type. FIXME: there must be a better way to
1991 avoid divergence between compilations with and without debug
1994 struct array_descr_info info
;
1995 gfc_get_array_descr_info (fat_type
, &info
);
1996 gfc_get_array_descr_info (build_pointer_type (fat_type
), &info
);
2002 /* Build a pointer type. This function is called from gfc_sym_type(). */
2005 gfc_build_pointer_type (gfc_symbol
* sym
, tree type
)
2007 /* Array pointer types aren't actually pointers. */
2008 if (sym
->attr
.dimension
)
2011 return build_pointer_type (type
);
2014 static tree
gfc_nonrestricted_type (tree t
);
2015 /* Given two record or union type nodes TO and FROM, ensure
2016 that all fields in FROM have a corresponding field in TO,
2017 their type being nonrestrict variants. This accepts a TO
2018 node that already has a prefix of the fields in FROM. */
2020 mirror_fields (tree to
, tree from
)
2025 /* Forward to the end of TOs fields. */
2026 fto
= TYPE_FIELDS (to
);
2027 ffrom
= TYPE_FIELDS (from
);
2028 chain
= &TYPE_FIELDS (to
);
2031 gcc_assert (ffrom
&& DECL_NAME (fto
) == DECL_NAME (ffrom
));
2032 chain
= &DECL_CHAIN (fto
);
2033 fto
= DECL_CHAIN (fto
);
2034 ffrom
= DECL_CHAIN (ffrom
);
2037 /* Now add all fields remaining in FROM (starting with ffrom). */
2038 for (; ffrom
; ffrom
= DECL_CHAIN (ffrom
))
2040 tree newfield
= copy_node (ffrom
);
2041 DECL_CONTEXT (newfield
) = to
;
2042 /* The store to DECL_CHAIN might seem redundant with the
2043 stores to *chain, but not clearing it here would mean
2044 leaving a chain into the old fields. If ever
2045 our called functions would look at them confusion
2047 DECL_CHAIN (newfield
) = NULL_TREE
;
2049 chain
= &DECL_CHAIN (newfield
);
2051 if (TREE_CODE (ffrom
) == FIELD_DECL
)
2053 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (ffrom
));
2054 TREE_TYPE (newfield
) = elemtype
;
2060 /* Given a type T, returns a different type of the same structure,
2061 except that all types it refers to (recursively) are always
2062 non-restrict qualified types. */
2064 gfc_nonrestricted_type (tree t
)
2068 /* If the type isn't laid out yet, don't copy it. If something
2069 needs it for real it should wait until the type got finished. */
2073 if (!TYPE_LANG_SPECIFIC (t
))
2074 TYPE_LANG_SPECIFIC (t
) = ggc_cleared_alloc
<struct lang_type
> ();
2075 /* If we're dealing with this very node already further up
2076 the call chain (recursion via pointers and struct members)
2077 we haven't yet determined if we really need a new type node.
2078 Assume we don't, return T itself. */
2079 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
== error_mark_node
)
2082 /* If we have calculated this all already, just return it. */
2083 if (TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
)
2084 return TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
;
2086 /* Mark this type. */
2087 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= error_mark_node
;
2089 switch (TREE_CODE (t
))
2095 case REFERENCE_TYPE
:
2097 tree totype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2098 if (totype
== TREE_TYPE (t
))
2100 else if (TREE_CODE (t
) == POINTER_TYPE
)
2101 ret
= build_pointer_type (totype
);
2103 ret
= build_reference_type (totype
);
2104 ret
= build_qualified_type (ret
,
2105 TYPE_QUALS (t
) & ~TYPE_QUAL_RESTRICT
);
2111 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (t
));
2112 if (elemtype
== TREE_TYPE (t
))
2116 ret
= build_variant_type_copy (t
);
2117 TREE_TYPE (ret
) = elemtype
;
2118 if (TYPE_LANG_SPECIFIC (t
)
2119 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2121 tree dataptr_type
= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
);
2122 dataptr_type
= gfc_nonrestricted_type (dataptr_type
);
2123 if (dataptr_type
!= GFC_TYPE_ARRAY_DATAPTR_TYPE (t
))
2125 TYPE_LANG_SPECIFIC (ret
)
2126 = ggc_cleared_alloc
<struct lang_type
> ();
2127 *TYPE_LANG_SPECIFIC (ret
) = *TYPE_LANG_SPECIFIC (t
);
2128 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret
) = dataptr_type
;
2137 case QUAL_UNION_TYPE
:
2140 /* First determine if we need a new type at all.
2141 Careful, the two calls to gfc_nonrestricted_type per field
2142 might return different values. That happens exactly when
2143 one of the fields reaches back to this very record type
2144 (via pointers). The first calls will assume that we don't
2145 need to copy T (see the error_mark_node marking). If there
2146 are any reasons for copying T apart from having to copy T,
2147 we'll indeed copy it, and the second calls to
2148 gfc_nonrestricted_type will use that new node if they
2150 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
2151 if (TREE_CODE (field
) == FIELD_DECL
)
2153 tree elemtype
= gfc_nonrestricted_type (TREE_TYPE (field
));
2154 if (elemtype
!= TREE_TYPE (field
))
2159 ret
= build_variant_type_copy (t
);
2160 TYPE_FIELDS (ret
) = NULL_TREE
;
2162 /* Here we make sure that as soon as we know we have to copy
2163 T, that also fields reaching back to us will use the new
2164 copy. It's okay if that copy still contains the old fields,
2165 we won't look at them. */
2166 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2167 mirror_fields (ret
, t
);
2172 TYPE_LANG_SPECIFIC (t
)->nonrestricted_type
= ret
;
2177 /* Return the type for a symbol. Special handling is required for character
2178 types to get the correct level of indirection.
2179 For functions return the return type.
2180 For subroutines return void_type_node.
2181 Calling this multiple times for the same symbol should be avoided,
2182 especially for character and array types. */
2185 gfc_sym_type (gfc_symbol
* sym
)
2191 /* Procedure Pointers inside COMMON blocks. */
2192 if (sym
->attr
.proc_pointer
&& sym
->attr
.in_common
)
2194 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2195 sym
->attr
.proc_pointer
= 0;
2196 type
= build_pointer_type (gfc_get_function_type (sym
));
2197 sym
->attr
.proc_pointer
= 1;
2201 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2202 return void_type_node
;
2204 /* In the case of a function the fake result variable may have a
2205 type different from the function type, so don't return early in
2207 if (sym
->backend_decl
&& !sym
->attr
.function
)
2208 return TREE_TYPE (sym
->backend_decl
);
2210 if (sym
->attr
.result
2211 && sym
->ts
.type
== BT_CHARACTER
2212 && sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
2213 && sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
!= NULL_TREE
)
2214 sym
->ts
.u
.cl
->backend_decl
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2216 if (sym
->ts
.type
== BT_CHARACTER
2217 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
)
2218 || (sym
->attr
.result
2219 && sym
->ns
->proc_name
2220 && sym
->ns
->proc_name
->attr
.is_bind_c
)
2221 || (sym
->ts
.deferred
&& (!sym
->ts
.u
.cl
2222 || !sym
->ts
.u
.cl
->backend_decl
))))
2223 type
= gfc_character1_type_node
;
2225 type
= gfc_typenode_for_spec (&sym
->ts
, sym
->attr
.codimension
);
2227 if (sym
->attr
.dummy
&& !sym
->attr
.function
&& !sym
->attr
.value
)
2232 restricted
= !sym
->attr
.target
&& !sym
->attr
.pointer
2233 && !sym
->attr
.proc_pointer
&& !sym
->attr
.cray_pointee
;
2235 type
= gfc_nonrestricted_type (type
);
2237 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2239 if (gfc_is_nodesc_array (sym
))
2241 /* If this is a character argument of unknown length, just use the
2243 if (sym
->ts
.type
!= BT_CHARACTER
2244 || !(sym
->attr
.dummy
|| sym
->attr
.function
)
2245 || sym
->ts
.u
.cl
->backend_decl
)
2247 type
= gfc_get_nodesc_array_type (type
, sym
->as
,
2256 enum gfc_array_kind akind
= GFC_ARRAY_UNKNOWN
;
2257 if (sym
->attr
.pointer
)
2258 akind
= sym
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2259 : GFC_ARRAY_POINTER
;
2260 else if (sym
->attr
.allocatable
)
2261 akind
= GFC_ARRAY_ALLOCATABLE
;
2262 type
= gfc_build_array_type (type
, sym
->as
, akind
, restricted
,
2263 sym
->attr
.contiguous
, false);
2268 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
2269 || gfc_is_associate_pointer (sym
))
2270 type
= gfc_build_pointer_type (sym
, type
);
2273 /* We currently pass all parameters by reference.
2274 See f95_get_function_decl. For dummy function parameters return the
2278 /* We must use pointer types for potentially absent variables. The
2279 optimizers assume a reference type argument is never NULL. */
2280 if (sym
->attr
.optional
2281 || (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.entry_master
))
2282 type
= build_pointer_type (type
);
2285 type
= build_reference_type (type
);
2287 type
= build_qualified_type (type
, TYPE_QUAL_RESTRICT
);
2294 /* Layout and output debug info for a record type. */
2297 gfc_finish_type (tree type
)
2301 decl
= build_decl (input_location
,
2302 TYPE_DECL
, NULL_TREE
, type
);
2303 TYPE_STUB_DECL (type
) = decl
;
2305 rest_of_type_compilation (type
, 1);
2306 rest_of_decl_compilation (decl
, 1, 0);
2309 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2310 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2311 to the end of the field list pointed to by *CHAIN.
2313 Returns a pointer to the new field. */
2316 gfc_add_field_to_struct_1 (tree context
, tree name
, tree type
, tree
**chain
)
2318 tree decl
= build_decl (input_location
, FIELD_DECL
, name
, type
);
2320 DECL_CONTEXT (decl
) = context
;
2321 DECL_CHAIN (decl
) = NULL_TREE
;
2322 if (TYPE_FIELDS (context
) == NULL_TREE
)
2323 TYPE_FIELDS (context
) = decl
;
2328 *chain
= &DECL_CHAIN (decl
);
2334 /* Like `gfc_add_field_to_struct_1', but adds alignment
2338 gfc_add_field_to_struct (tree context
, tree name
, tree type
, tree
**chain
)
2340 tree decl
= gfc_add_field_to_struct_1 (context
, name
, type
, chain
);
2342 DECL_INITIAL (decl
) = 0;
2343 SET_DECL_ALIGN (decl
, 0);
2344 DECL_USER_ALIGN (decl
) = 0;
2350 /* Copy the backend_decl and component backend_decls if
2351 the two derived type symbols are "equal", as described
2352 in 4.4.2 and resolved by gfc_compare_derived_types. */
2355 gfc_copy_dt_decls_ifequal (gfc_symbol
*from
, gfc_symbol
*to
,
2358 gfc_component
*to_cm
;
2359 gfc_component
*from_cm
;
2364 if (from
->backend_decl
== NULL
2365 || !gfc_compare_derived_types (from
, to
))
2368 to
->backend_decl
= from
->backend_decl
;
2370 to_cm
= to
->components
;
2371 from_cm
= from
->components
;
2373 /* Copy the component declarations. If a component is itself
2374 a derived type, we need a copy of its component declarations.
2375 This is done by recursing into gfc_get_derived_type and
2376 ensures that the component's component declarations have
2377 been built. If it is a character, we need the character
2379 for (; to_cm
; to_cm
= to_cm
->next
, from_cm
= from_cm
->next
)
2381 to_cm
->backend_decl
= from_cm
->backend_decl
;
2382 to_cm
->caf_token
= from_cm
->caf_token
;
2383 if (from_cm
->ts
.type
== BT_UNION
)
2384 gfc_get_union_type (to_cm
->ts
.u
.derived
);
2385 else if (from_cm
->ts
.type
== BT_DERIVED
2386 && (!from_cm
->attr
.pointer
|| from_gsym
))
2387 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2388 else if (from_cm
->ts
.type
== BT_CLASS
2389 && (!CLASS_DATA (from_cm
)->attr
.class_pointer
|| from_gsym
))
2390 gfc_get_derived_type (to_cm
->ts
.u
.derived
);
2391 else if (from_cm
->ts
.type
== BT_CHARACTER
)
2392 to_cm
->ts
.u
.cl
->backend_decl
= from_cm
->ts
.u
.cl
->backend_decl
;
2399 /* Build a tree node for a procedure pointer component. */
2402 gfc_get_ppc_type (gfc_component
* c
)
2406 /* Explicit interface. */
2407 if (c
->attr
.if_source
!= IFSRC_UNKNOWN
&& c
->ts
.interface
)
2408 return build_pointer_type (gfc_get_function_type (c
->ts
.interface
));
2410 /* Implicit interface (only return value may be known). */
2411 if (c
->attr
.function
&& !c
->attr
.dimension
&& c
->ts
.type
!= BT_CHARACTER
)
2412 t
= gfc_typenode_for_spec (&c
->ts
);
2416 return build_pointer_type (build_function_type_list (t
, NULL_TREE
));
2420 /* Build a tree node for a union type. Requires building each map
2421 structure which is an element of the union. */
2424 gfc_get_union_type (gfc_symbol
*un
)
2426 gfc_component
*map
= NULL
;
2427 tree typenode
= NULL
, map_type
= NULL
, map_field
= NULL
;
2430 if (un
->backend_decl
)
2432 if (TYPE_FIELDS (un
->backend_decl
) || un
->attr
.proc_pointer_comp
)
2433 return un
->backend_decl
;
2435 typenode
= un
->backend_decl
;
2439 typenode
= make_node (UNION_TYPE
);
2440 TYPE_NAME (typenode
) = get_identifier (un
->name
);
2443 /* Add each contained MAP as a field. */
2444 for (map
= un
->components
; map
; map
= map
->next
)
2446 gcc_assert (map
->ts
.type
== BT_DERIVED
);
2448 /* The map's type node, which is defined within this union's context. */
2449 map_type
= gfc_get_derived_type (map
->ts
.u
.derived
);
2450 TYPE_CONTEXT (map_type
) = typenode
;
2452 /* The map field's declaration. */
2453 map_field
= gfc_add_field_to_struct(typenode
, get_identifier(map
->name
),
2456 gfc_set_decl_location (map_field
, &map
->loc
);
2457 else if (un
->declared_at
.lb
)
2458 gfc_set_decl_location (map_field
, &un
->declared_at
);
2460 DECL_PACKED (map_field
) |= TYPE_PACKED (typenode
);
2461 DECL_NAMELESS(map_field
) = true;
2463 /* We should never clobber another backend declaration for this map,
2464 because each map component is unique. */
2465 if (!map
->backend_decl
)
2466 map
->backend_decl
= map_field
;
2469 un
->backend_decl
= typenode
;
2470 gfc_finish_type (typenode
);
2476 /* Build a tree node for a derived type. If there are equal
2477 derived types, with different local names, these are built
2478 at the same time. If an equal derived type has been built
2479 in a parent namespace, this is used. */
2482 gfc_get_derived_type (gfc_symbol
* derived
, int codimen
)
2484 tree typenode
= NULL
, field
= NULL
, field_type
= NULL
;
2485 tree canonical
= NULL_TREE
;
2487 bool got_canonical
= false;
2488 bool unlimited_entity
= false;
2495 coarray_flag
= flag_coarray
== GFC_FCOARRAY_LIB
2496 && derived
->module
&& !derived
->attr
.vtype
;
2498 gcc_assert (!derived
->attr
.pdt_template
);
2500 if (derived
->attr
.unlimited_polymorphic
2501 || (flag_coarray
== GFC_FCOARRAY_LIB
2502 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2503 && (derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
2504 || derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
2505 return ptr_type_node
;
2507 if (flag_coarray
!= GFC_FCOARRAY_LIB
2508 && derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2509 && derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2510 return gfc_get_int_type (gfc_default_integer_kind
);
2512 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
2513 && derived
->attr
.generic
)
2514 derived
= gfc_find_dt_in_generic (derived
);
2516 /* See if it's one of the iso_c_binding derived types. */
2517 if (derived
->attr
.is_iso_c
== 1 || derived
->ts
.f90_type
== BT_VOID
)
2519 if (derived
->backend_decl
)
2520 return derived
->backend_decl
;
2522 if (derived
->intmod_sym_id
== ISOCBINDING_PTR
)
2523 derived
->backend_decl
= ptr_type_node
;
2525 derived
->backend_decl
= pfunc_type_node
;
2527 derived
->ts
.kind
= gfc_index_integer_kind
;
2528 derived
->ts
.type
= BT_INTEGER
;
2529 /* Set the f90_type to BT_VOID as a way to recognize something of type
2530 BT_INTEGER that needs to fit a void * for the purpose of the
2531 iso_c_binding derived types. */
2532 derived
->ts
.f90_type
= BT_VOID
;
2534 return derived
->backend_decl
;
2537 /* If use associated, use the module type for this one. */
2538 if (derived
->backend_decl
== NULL
2539 && derived
->attr
.use_assoc
2541 && gfc_get_module_backend_decl (derived
))
2542 goto copy_derived_types
;
2544 /* The derived types from an earlier namespace can be used as the
2546 if (derived
->backend_decl
== NULL
&& !derived
->attr
.use_assoc
2547 && gfc_global_ns_list
)
2549 for (ns
= gfc_global_ns_list
;
2550 ns
->translated
&& !got_canonical
;
2553 dt
= ns
->derived_types
;
2554 for (; dt
&& !canonical
; dt
= dt
->next
)
2556 gfc_copy_dt_decls_ifequal (dt
->derived
, derived
, true);
2557 if (derived
->backend_decl
)
2558 got_canonical
= true;
2563 /* Store up the canonical type to be added to this one. */
2566 if (TYPE_CANONICAL (derived
->backend_decl
))
2567 canonical
= TYPE_CANONICAL (derived
->backend_decl
);
2569 canonical
= derived
->backend_decl
;
2571 derived
->backend_decl
= NULL_TREE
;
2574 /* derived->backend_decl != 0 means we saw it before, but its
2575 components' backend_decl may have not been built. */
2576 if (derived
->backend_decl
)
2578 /* Its components' backend_decl have been built or we are
2579 seeing recursion through the formal arglist of a procedure
2580 pointer component. */
2581 if (TYPE_FIELDS (derived
->backend_decl
))
2582 return derived
->backend_decl
;
2583 else if (derived
->attr
.abstract
2584 && derived
->attr
.proc_pointer_comp
)
2586 /* If an abstract derived type with procedure pointer
2587 components has no other type of component, return the
2588 backend_decl. Otherwise build the components if any of the
2589 non-procedure pointer components have no backend_decl. */
2590 for (c
= derived
->components
; c
; c
= c
->next
)
2592 bool same_alloc_type
= c
->attr
.allocatable
2593 && derived
== c
->ts
.u
.derived
;
2594 if (!c
->attr
.proc_pointer
2596 && c
->backend_decl
== NULL
)
2598 else if (c
->next
== NULL
)
2599 return derived
->backend_decl
;
2601 typenode
= derived
->backend_decl
;
2604 typenode
= derived
->backend_decl
;
2608 /* We see this derived type first time, so build the type node. */
2609 typenode
= make_node (RECORD_TYPE
);
2610 TYPE_NAME (typenode
) = get_identifier (derived
->name
);
2611 TYPE_PACKED (typenode
) = flag_pack_derived
;
2612 derived
->backend_decl
= typenode
;
2615 if (derived
->components
2616 && derived
->components
->ts
.type
== BT_DERIVED
2617 && strcmp (derived
->components
->name
, "_data") == 0
2618 && derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
2619 unlimited_entity
= true;
2621 /* Go through the derived type components, building them as
2622 necessary. The reason for doing this now is that it is
2623 possible to recurse back to this derived type through a
2624 pointer component (PR24092). If this happens, the fields
2625 will be built and so we can return the type. */
2626 for (c
= derived
->components
; c
; c
= c
->next
)
2628 bool same_alloc_type
= c
->attr
.allocatable
2629 && derived
== c
->ts
.u
.derived
;
2631 if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->backend_decl
== NULL
)
2632 c
->ts
.u
.derived
->backend_decl
= gfc_get_union_type (c
->ts
.u
.derived
);
2634 if (c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
2637 if ((!c
->attr
.pointer
&& !c
->attr
.proc_pointer
2638 && !same_alloc_type
)
2639 || c
->ts
.u
.derived
->backend_decl
== NULL
)
2641 int local_codim
= c
->attr
.codimension
? c
->as
->corank
: codimen
;
2642 c
->ts
.u
.derived
->backend_decl
= gfc_get_derived_type (c
->ts
.u
.derived
,
2646 if (c
->ts
.u
.derived
->attr
.is_iso_c
)
2648 /* Need to copy the modified ts from the derived type. The
2649 typespec was modified because C_PTR/C_FUNPTR are translated
2650 into (void *) from derived types. */
2651 c
->ts
.type
= c
->ts
.u
.derived
->ts
.type
;
2652 c
->ts
.kind
= c
->ts
.u
.derived
->ts
.kind
;
2653 c
->ts
.f90_type
= c
->ts
.u
.derived
->ts
.f90_type
;
2656 c
->initializer
->ts
.type
= c
->ts
.type
;
2657 c
->initializer
->ts
.kind
= c
->ts
.kind
;
2658 c
->initializer
->ts
.f90_type
= c
->ts
.f90_type
;
2659 c
->initializer
->expr_type
= EXPR_NULL
;
2664 if (TYPE_FIELDS (derived
->backend_decl
))
2665 return derived
->backend_decl
;
2667 /* Build the type member list. Install the newly created RECORD_TYPE
2668 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2669 through only the top-level linked list of components so we correctly
2670 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2671 types are built as part of gfc_get_union_type. */
2672 for (c
= derived
->components
; c
; c
= c
->next
)
2674 bool same_alloc_type
= c
->attr
.allocatable
2675 && derived
== c
->ts
.u
.derived
;
2676 /* Prevent infinite recursion, when the procedure pointer type is
2677 the same as derived, by forcing the procedure pointer component to
2678 be built as if the explicit interface does not exist. */
2679 if (c
->attr
.proc_pointer
2680 && (c
->ts
.type
!= BT_DERIVED
|| (c
->ts
.u
.derived
2681 && !gfc_compare_derived_types (derived
, c
->ts
.u
.derived
)))
2682 && (c
->ts
.type
!= BT_CLASS
|| (CLASS_DATA (c
)->ts
.u
.derived
2683 && !gfc_compare_derived_types (derived
, CLASS_DATA (c
)->ts
.u
.derived
))))
2684 field_type
= gfc_get_ppc_type (c
);
2685 else if (c
->attr
.proc_pointer
&& derived
->backend_decl
)
2687 tmp
= build_function_type_list (derived
->backend_decl
, NULL_TREE
);
2688 field_type
= build_pointer_type (tmp
);
2690 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2691 field_type
= c
->ts
.u
.derived
->backend_decl
;
2692 else if (c
->attr
.caf_token
)
2693 field_type
= pvoid_type_node
;
2696 if (c
->ts
.type
== BT_CHARACTER
2697 && !c
->ts
.deferred
&& !c
->attr
.pdt_string
)
2699 /* Evaluate the string length. */
2700 gfc_conv_const_charlen (c
->ts
.u
.cl
);
2701 gcc_assert (c
->ts
.u
.cl
->backend_decl
);
2703 else if (c
->ts
.type
== BT_CHARACTER
)
2704 c
->ts
.u
.cl
->backend_decl
2705 = build_int_cst (gfc_charlen_type_node
, 0);
2707 field_type
= gfc_typenode_for_spec (&c
->ts
, codimen
);
2710 /* This returns an array descriptor type. Initialization may be
2712 if ((c
->attr
.dimension
|| c
->attr
.codimension
) && !c
->attr
.proc_pointer
)
2714 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_array
)
2716 enum gfc_array_kind akind
;
2717 if (c
->attr
.pointer
)
2718 akind
= c
->attr
.contiguous
? GFC_ARRAY_POINTER_CONT
2719 : GFC_ARRAY_POINTER
;
2721 akind
= GFC_ARRAY_ALLOCATABLE
;
2722 /* Pointers to arrays aren't actually pointer types. The
2723 descriptors are separate, but the data is common. */
2724 field_type
= gfc_build_array_type (field_type
, c
->as
, akind
,
2726 && !c
->attr
.pointer
,
2731 field_type
= gfc_get_nodesc_array_type (field_type
, c
->as
,
2735 else if ((c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->attr
.pdt_string
)
2736 && !c
->attr
.proc_pointer
2737 && !(unlimited_entity
&& c
== derived
->components
))
2738 field_type
= build_pointer_type (field_type
);
2740 if (c
->attr
.pointer
|| same_alloc_type
)
2741 field_type
= gfc_nonrestricted_type (field_type
);
2743 /* vtype fields can point to different types to the base type. */
2744 if (c
->ts
.type
== BT_DERIVED
2745 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.vtype
)
2746 field_type
= build_pointer_type_for_mode (TREE_TYPE (field_type
),
2749 /* Ensure that the CLASS language specific flag is set. */
2750 if (c
->ts
.type
== BT_CLASS
)
2752 if (POINTER_TYPE_P (field_type
))
2753 GFC_CLASS_TYPE_P (TREE_TYPE (field_type
)) = 1;
2755 GFC_CLASS_TYPE_P (field_type
) = 1;
2758 field
= gfc_add_field_to_struct (typenode
,
2759 get_identifier (c
->name
),
2760 field_type
, &chain
);
2762 gfc_set_decl_location (field
, &c
->loc
);
2763 else if (derived
->declared_at
.lb
)
2764 gfc_set_decl_location (field
, &derived
->declared_at
);
2766 gfc_finish_decl_attrs (field
, &c
->attr
);
2768 DECL_PACKED (field
) |= TYPE_PACKED (typenode
);
2771 if (!c
->backend_decl
)
2772 c
->backend_decl
= field
;
2774 if (c
->attr
.pointer
&& c
->attr
.dimension
2775 && !(c
->ts
.type
== BT_DERIVED
2776 && strcmp (c
->name
, "_data") == 0))
2777 GFC_DECL_PTR_ARRAY_P (c
->backend_decl
) = 1;
2780 /* Now lay out the derived type, including the fields. */
2782 TYPE_CANONICAL (typenode
) = canonical
;
2784 gfc_finish_type (typenode
);
2785 gfc_set_decl_location (TYPE_STUB_DECL (typenode
), &derived
->declared_at
);
2786 if (derived
->module
&& derived
->ns
->proc_name
2787 && derived
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2789 if (derived
->ns
->proc_name
->backend_decl
2790 && TREE_CODE (derived
->ns
->proc_name
->backend_decl
)
2793 TYPE_CONTEXT (typenode
) = derived
->ns
->proc_name
->backend_decl
;
2794 DECL_CONTEXT (TYPE_STUB_DECL (typenode
))
2795 = derived
->ns
->proc_name
->backend_decl
;
2799 derived
->backend_decl
= typenode
;
2803 for (c
= derived
->components
; c
; c
= c
->next
)
2805 /* Do not add a caf_token field for class container components. */
2806 if ((codimen
|| coarray_flag
)
2807 && !c
->attr
.dimension
&& !c
->attr
.codimension
2808 && (c
->attr
.allocatable
|| c
->attr
.pointer
)
2809 && !derived
->attr
.is_class
)
2811 char caf_name
[GFC_MAX_SYMBOL_LEN
];
2812 gfc_component
*token
;
2813 snprintf (caf_name
, GFC_MAX_SYMBOL_LEN
, "_caf_%s", c
->name
);
2814 token
= gfc_find_component (derived
, caf_name
, true, true, NULL
);
2816 c
->caf_token
= token
->backend_decl
;
2817 TREE_NO_WARNING (c
->caf_token
) = 1;
2821 for (dt
= gfc_derived_types
; dt
; dt
= dt
->next
)
2822 gfc_copy_dt_decls_ifequal (derived
, dt
->derived
, false);
2824 return derived
->backend_decl
;
2829 gfc_return_by_reference (gfc_symbol
* sym
)
2831 if (!sym
->attr
.function
)
2834 if (sym
->attr
.dimension
)
2837 if (sym
->ts
.type
== BT_CHARACTER
2838 && !sym
->attr
.is_bind_c
2839 && (!sym
->attr
.result
2840 || !sym
->ns
->proc_name
2841 || !sym
->ns
->proc_name
->attr
.is_bind_c
))
2844 /* Possibly return complex numbers by reference for g77 compatibility.
2845 We don't do this for calls to intrinsics (as the library uses the
2846 -fno-f2c calling convention), nor for calls to functions which always
2847 require an explicit interface, as no compatibility problems can
2849 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2850 && !sym
->attr
.intrinsic
&& !sym
->attr
.always_explicit
)
2857 gfc_get_mixed_entry_union (gfc_namespace
*ns
)
2861 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2862 gfc_entry_list
*el
, *el2
;
2864 gcc_assert (ns
->proc_name
->attr
.mixed_entry_master
);
2865 gcc_assert (memcmp (ns
->proc_name
->name
, "master.", 7) == 0);
2867 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "munion.%s", ns
->proc_name
->name
+ 7);
2869 /* Build the type node. */
2870 type
= make_node (UNION_TYPE
);
2872 TYPE_NAME (type
) = get_identifier (name
);
2874 for (el
= ns
->entries
; el
; el
= el
->next
)
2876 /* Search for duplicates. */
2877 for (el2
= ns
->entries
; el2
!= el
; el2
= el2
->next
)
2878 if (el2
->sym
->result
== el
->sym
->result
)
2882 gfc_add_field_to_struct_1 (type
,
2883 get_identifier (el
->sym
->result
->name
),
2884 gfc_sym_type (el
->sym
->result
), &chain
);
2887 /* Finish off the type. */
2888 gfc_finish_type (type
);
2889 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type
)) = 1;
2893 /* Create a "fn spec" based on the formal arguments;
2894 cf. create_function_arglist. */
2897 create_fn_spec (gfc_symbol
*sym
, tree fntype
)
2901 gfc_formal_arglist
*f
;
2904 memset (&spec
, 0, sizeof (spec
));
2908 if (sym
->attr
.entry_master
)
2909 spec
[spec_len
++] = 'R';
2910 if (gfc_return_by_reference (sym
))
2912 gfc_symbol
*result
= sym
->result
? sym
->result
: sym
;
2914 if (result
->attr
.pointer
|| sym
->attr
.proc_pointer
)
2915 spec
[spec_len
++] = '.';
2917 spec
[spec_len
++] = 'w';
2918 if (sym
->ts
.type
== BT_CHARACTER
)
2919 spec
[spec_len
++] = 'R';
2922 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2923 if (spec_len
< sizeof (spec
))
2925 if (!f
->sym
|| f
->sym
->attr
.pointer
|| f
->sym
->attr
.target
2926 || f
->sym
->attr
.external
|| f
->sym
->attr
.cray_pointer
2927 || (f
->sym
->ts
.type
== BT_DERIVED
2928 && (f
->sym
->ts
.u
.derived
->attr
.proc_pointer_comp
2929 || f
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
2930 || (f
->sym
->ts
.type
== BT_CLASS
2931 && (CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.proc_pointer_comp
2932 || CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.pointer_comp
)))
2933 spec
[spec_len
++] = '.';
2934 else if (f
->sym
->attr
.intent
== INTENT_IN
)
2935 spec
[spec_len
++] = 'r';
2937 spec
[spec_len
++] = 'w';
2940 tmp
= build_tree_list (NULL_TREE
, build_string (spec_len
, spec
));
2941 tmp
= tree_cons (get_identifier ("fn spec"), tmp
, TYPE_ATTRIBUTES (fntype
));
2942 return build_type_attribute_variant (fntype
, tmp
);
2947 gfc_get_function_type (gfc_symbol
* sym
)
2950 vec
<tree
, va_gc
> *typelist
= NULL
;
2951 gfc_formal_arglist
*f
;
2953 int alternate_return
= 0;
2954 bool is_varargs
= true;
2956 /* Make sure this symbol is a function, a subroutine or the main
2958 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
2959 || sym
->attr
.flavor
== FL_PROGRAM
);
2961 /* To avoid recursing infinitely on recursive types, we use error_mark_node
2962 so that they can be detected here and handled further down. */
2963 if (sym
->backend_decl
== NULL
)
2964 sym
->backend_decl
= error_mark_node
;
2965 else if (sym
->backend_decl
== error_mark_node
)
2966 goto arg_type_list_done
;
2967 else if (sym
->attr
.proc_pointer
)
2968 return TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
2970 return TREE_TYPE (sym
->backend_decl
);
2972 if (sym
->attr
.entry_master
)
2973 /* Additional parameter for selecting an entry point. */
2974 vec_safe_push (typelist
, gfc_array_index_type
);
2981 if (arg
->ts
.type
== BT_CHARACTER
)
2982 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
2984 /* Some functions we use an extra parameter for the return value. */
2985 if (gfc_return_by_reference (sym
))
2987 type
= gfc_sym_type (arg
);
2988 if (arg
->ts
.type
== BT_COMPLEX
2989 || arg
->attr
.dimension
2990 || arg
->ts
.type
== BT_CHARACTER
)
2991 type
= build_reference_type (type
);
2993 vec_safe_push (typelist
, type
);
2994 if (arg
->ts
.type
== BT_CHARACTER
)
2996 if (!arg
->ts
.deferred
)
2997 /* Transfer by value. */
2998 vec_safe_push (typelist
, gfc_charlen_type_node
);
3000 /* Deferred character lengths are transferred by reference
3001 so that the value can be returned. */
3002 vec_safe_push (typelist
, build_pointer_type(gfc_charlen_type_node
));
3006 /* Build the argument types for the function. */
3007 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3012 /* Evaluate constant character lengths here so that they can be
3013 included in the type. */
3014 if (arg
->ts
.type
== BT_CHARACTER
)
3015 gfc_conv_const_charlen (arg
->ts
.u
.cl
);
3017 if (arg
->attr
.flavor
== FL_PROCEDURE
)
3019 type
= gfc_get_function_type (arg
);
3020 type
= build_pointer_type (type
);
3023 type
= gfc_sym_type (arg
);
3025 /* Parameter Passing Convention
3027 We currently pass all parameters by reference.
3028 Parameters with INTENT(IN) could be passed by value.
3029 The problem arises if a function is called via an implicit
3030 prototype. In this situation the INTENT is not known.
3031 For this reason all parameters to global functions must be
3032 passed by reference. Passing by value would potentially
3033 generate bad code. Worse there would be no way of telling that
3034 this code was bad, except that it would give incorrect results.
3036 Contained procedures could pass by value as these are never
3037 used without an explicit interface, and cannot be passed as
3038 actual parameters for a dummy procedure. */
3040 vec_safe_push (typelist
, type
);
3044 if (sym
->attr
.subroutine
)
3045 alternate_return
= 1;
3049 /* Add hidden string length parameters. */
3050 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
3053 if (arg
&& arg
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
3055 if (!arg
->ts
.deferred
)
3056 /* Transfer by value. */
3057 type
= gfc_charlen_type_node
;
3059 /* Deferred character lengths are transferred by reference
3060 so that the value can be returned. */
3061 type
= build_pointer_type (gfc_charlen_type_node
);
3063 vec_safe_push (typelist
, type
);
3067 if (!vec_safe_is_empty (typelist
)
3068 || sym
->attr
.is_main_program
3069 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
3072 if (sym
->backend_decl
== error_mark_node
)
3073 sym
->backend_decl
= NULL_TREE
;
3077 if (alternate_return
)
3078 type
= integer_type_node
;
3079 else if (!sym
->attr
.function
|| gfc_return_by_reference (sym
))
3080 type
= void_type_node
;
3081 else if (sym
->attr
.mixed_entry_master
)
3082 type
= gfc_get_mixed_entry_union (sym
->ns
);
3083 else if (flag_f2c
&& sym
->ts
.type
== BT_REAL
3084 && sym
->ts
.kind
== gfc_default_real_kind
3085 && !sym
->attr
.always_explicit
)
3087 /* Special case: f2c calling conventions require that (scalar)
3088 default REAL functions return the C type double instead. f2c
3089 compatibility is only an issue with functions that don't
3090 require an explicit interface, as only these could be
3091 implemented in Fortran 77. */
3092 sym
->ts
.kind
= gfc_default_double_kind
;
3093 type
= gfc_typenode_for_spec (&sym
->ts
);
3094 sym
->ts
.kind
= gfc_default_real_kind
;
3096 else if (sym
->result
&& sym
->result
->attr
.proc_pointer
)
3097 /* Procedure pointer return values. */
3099 if (sym
->result
->attr
.result
&& strcmp (sym
->name
,"ppr@") != 0)
3101 /* Unset proc_pointer as gfc_get_function_type
3102 is called recursively. */
3103 sym
->result
->attr
.proc_pointer
= 0;
3104 type
= build_pointer_type (gfc_get_function_type (sym
->result
));
3105 sym
->result
->attr
.proc_pointer
= 1;
3108 type
= gfc_sym_type (sym
->result
);
3111 type
= gfc_sym_type (sym
);
3114 type
= build_varargs_function_type_vec (type
, typelist
);
3116 type
= build_function_type_vec (type
, typelist
);
3117 type
= create_fn_spec (sym
, type
);
3122 /* Language hooks for middle-end access to type nodes. */
3124 /* Return an integer type with BITS bits of precision,
3125 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3128 gfc_type_for_size (unsigned bits
, int unsignedp
)
3133 for (i
= 0; i
<= MAX_INT_KINDS
; ++i
)
3135 tree type
= gfc_integer_types
[i
];
3136 if (type
&& bits
== TYPE_PRECISION (type
))
3140 /* Handle TImode as a special case because it is used by some backends
3141 (e.g. ARM) even though it is not available for normal use. */
3142 #if HOST_BITS_PER_WIDE_INT >= 64
3143 if (bits
== TYPE_PRECISION (intTI_type_node
))
3144 return intTI_type_node
;
3147 if (bits
<= TYPE_PRECISION (intQI_type_node
))
3148 return intQI_type_node
;
3149 if (bits
<= TYPE_PRECISION (intHI_type_node
))
3150 return intHI_type_node
;
3151 if (bits
<= TYPE_PRECISION (intSI_type_node
))
3152 return intSI_type_node
;
3153 if (bits
<= TYPE_PRECISION (intDI_type_node
))
3154 return intDI_type_node
;
3155 if (bits
<= TYPE_PRECISION (intTI_type_node
))
3156 return intTI_type_node
;
3160 if (bits
<= TYPE_PRECISION (unsigned_intQI_type_node
))
3161 return unsigned_intQI_type_node
;
3162 if (bits
<= TYPE_PRECISION (unsigned_intHI_type_node
))
3163 return unsigned_intHI_type_node
;
3164 if (bits
<= TYPE_PRECISION (unsigned_intSI_type_node
))
3165 return unsigned_intSI_type_node
;
3166 if (bits
<= TYPE_PRECISION (unsigned_intDI_type_node
))
3167 return unsigned_intDI_type_node
;
3168 if (bits
<= TYPE_PRECISION (unsigned_intTI_type_node
))
3169 return unsigned_intTI_type_node
;
3175 /* Return a data type that has machine mode MODE. If the mode is an
3176 integer, then UNSIGNEDP selects between signed and unsigned types. */
3179 gfc_type_for_mode (machine_mode mode
, int unsignedp
)
3183 scalar_int_mode int_mode
;
3185 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
3186 base
= gfc_real_types
;
3187 else if (GET_MODE_CLASS (mode
) == MODE_COMPLEX_FLOAT
)
3188 base
= gfc_complex_types
;
3189 else if (is_a
<scalar_int_mode
> (mode
, &int_mode
))
3191 tree type
= gfc_type_for_size (GET_MODE_PRECISION (int_mode
), unsignedp
);
3192 return type
!= NULL_TREE
&& mode
== TYPE_MODE (type
) ? type
: NULL_TREE
;
3194 else if (GET_MODE_CLASS (mode
) == MODE_VECTOR_BOOL
3195 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3197 unsigned int elem_bits
= vector_element_size (GET_MODE_BITSIZE (mode
),
3198 GET_MODE_NUNITS (mode
));
3199 tree bool_type
= build_nonstandard_boolean_type (elem_bits
);
3200 return build_vector_type_for_mode (bool_type
, mode
);
3202 else if (VECTOR_MODE_P (mode
)
3203 && valid_vector_subparts_p (GET_MODE_NUNITS (mode
)))
3205 machine_mode inner_mode
= GET_MODE_INNER (mode
);
3206 tree inner_type
= gfc_type_for_mode (inner_mode
, unsignedp
);
3207 if (inner_type
!= NULL_TREE
)
3208 return build_vector_type_for_mode (inner_type
, mode
);
3214 for (i
= 0; i
<= MAX_REAL_KINDS
; ++i
)
3216 tree type
= base
[i
];
3217 if (type
&& mode
== TYPE_MODE (type
))
3224 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3228 gfc_get_array_descr_info (const_tree type
, struct array_descr_info
*info
)
3231 bool indirect
= false;
3232 tree etype
, ptype
, t
, base_decl
;
3233 tree data_off
, dim_off
, dtype_off
, dim_size
, elem_size
;
3234 tree lower_suboff
, upper_suboff
, stride_suboff
;
3236 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3238 if (! POINTER_TYPE_P (type
))
3240 type
= TREE_TYPE (type
);
3241 if (! GFC_DESCRIPTOR_TYPE_P (type
))
3246 rank
= GFC_TYPE_ARRAY_RANK (type
);
3247 if (rank
>= (int) (sizeof (info
->dimen
) / sizeof (info
->dimen
[0])))
3250 etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3251 gcc_assert (POINTER_TYPE_P (etype
));
3252 etype
= TREE_TYPE (etype
);
3254 /* If the type is not a scalar coarray. */
3255 if (TREE_CODE (etype
) == ARRAY_TYPE
)
3256 etype
= TREE_TYPE (etype
);
3258 /* Can't handle variable sized elements yet. */
3259 if (int_size_in_bytes (etype
) <= 0)
3261 /* Nor non-constant lower bounds in assumed shape arrays. */
3262 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3263 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3265 for (dim
= 0; dim
< rank
; dim
++)
3266 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
3267 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) != INTEGER_CST
)
3271 memset (info
, '\0', sizeof (*info
));
3272 info
->ndimensions
= rank
;
3273 info
->ordering
= array_descr_ordering_column_major
;
3274 info
->element_type
= etype
;
3275 ptype
= build_pointer_type (gfc_array_index_type
);
3276 base_decl
= GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
);
3279 base_decl
= make_node (DEBUG_EXPR_DECL
);
3280 DECL_ARTIFICIAL (base_decl
) = 1;
3281 TREE_TYPE (base_decl
) = indirect
? build_pointer_type (ptype
) : ptype
;
3282 SET_DECL_MODE (base_decl
, TYPE_MODE (TREE_TYPE (base_decl
)));
3283 GFC_TYPE_ARRAY_BASE_DECL (type
, indirect
) = base_decl
;
3285 info
->base_decl
= base_decl
;
3287 base_decl
= build1 (INDIRECT_REF
, ptype
, base_decl
);
3289 elem_size
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (etype
));
3291 gfc_get_descriptor_offsets_for_info (type
, &data_off
, &dtype_off
, &dim_off
,
3292 &dim_size
, &stride_suboff
,
3293 &lower_suboff
, &upper_suboff
);
3296 if (!integer_zerop (data_off
))
3297 t
= fold_build_pointer_plus (t
, data_off
);
3298 t
= build1 (NOP_EXPR
, build_pointer_type (ptr_type_node
), t
);
3299 info
->data_location
= build1 (INDIRECT_REF
, ptr_type_node
, t
);
3300 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
3301 info
->allocated
= build2 (NE_EXPR
, logical_type_node
,
3302 info
->data_location
, null_pointer_node
);
3303 else if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
3304 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
3305 info
->associated
= build2 (NE_EXPR
, logical_type_node
,
3306 info
->data_location
, null_pointer_node
);
3307 if ((GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK
3308 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_RANK_CONT
)
3309 && dwarf_version
>= 5)
3312 info
->ndimensions
= 1;
3314 if (!integer_zerop (dtype_off
))
3315 t
= fold_build_pointer_plus (t
, dtype_off
);
3316 t
= build1 (NOP_EXPR
, build_pointer_type (gfc_array_index_type
), t
);
3317 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3318 info
->rank
= build2 (BIT_AND_EXPR
, gfc_array_index_type
, t
,
3319 build_int_cst (gfc_array_index_type
,
3320 GFC_DTYPE_RANK_MASK
));
3321 t
= build0 (PLACEHOLDER_EXPR
, TREE_TYPE (dim_off
));
3322 t
= size_binop (MULT_EXPR
, t
, dim_size
);
3323 dim_off
= build2 (PLUS_EXPR
, TREE_TYPE (dim_off
), t
, dim_off
);
3326 for (dim
= 0; dim
< rank
; dim
++)
3328 t
= fold_build_pointer_plus (base_decl
,
3329 size_binop (PLUS_EXPR
,
3330 dim_off
, lower_suboff
));
3331 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3332 info
->dimen
[dim
].lower_bound
= t
;
3333 t
= fold_build_pointer_plus (base_decl
,
3334 size_binop (PLUS_EXPR
,
3335 dim_off
, upper_suboff
));
3336 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3337 info
->dimen
[dim
].upper_bound
= t
;
3338 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE
3339 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ASSUMED_SHAPE_CONT
)
3341 /* Assumed shape arrays have known lower bounds. */
3342 info
->dimen
[dim
].upper_bound
3343 = build2 (MINUS_EXPR
, gfc_array_index_type
,
3344 info
->dimen
[dim
].upper_bound
,
3345 info
->dimen
[dim
].lower_bound
);
3346 info
->dimen
[dim
].lower_bound
3347 = fold_convert (gfc_array_index_type
,
3348 GFC_TYPE_ARRAY_LBOUND (type
, dim
));
3349 info
->dimen
[dim
].upper_bound
3350 = build2 (PLUS_EXPR
, gfc_array_index_type
,
3351 info
->dimen
[dim
].lower_bound
,
3352 info
->dimen
[dim
].upper_bound
);
3354 t
= fold_build_pointer_plus (base_decl
,
3355 size_binop (PLUS_EXPR
,
3356 dim_off
, stride_suboff
));
3357 t
= build1 (INDIRECT_REF
, gfc_array_index_type
, t
);
3358 t
= build2 (MULT_EXPR
, gfc_array_index_type
, t
, elem_size
);
3359 info
->dimen
[dim
].stride
= t
;
3361 dim_off
= size_binop (PLUS_EXPR
, dim_off
, dim_size
);
3368 /* Create a type to handle vector subscripts for coarray library calls. It
3370 struct caf_vector_t {
3371 size_t nvec; // size of the vector
3378 ptrdiff_t lower_bound;
3379 ptrdiff_t upper_bound;
3384 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3385 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3388 gfc_get_caf_vector_type (int dim
)
3390 static tree vector_types
[GFC_MAX_DIMENSIONS
];
3391 static tree vec_type
= NULL_TREE
;
3392 tree triplet_struct_type
, vect_struct_type
, union_type
, tmp
, *chain
;
3394 if (vector_types
[dim
-1] != NULL_TREE
)
3395 return vector_types
[dim
-1];
3397 if (vec_type
== NULL_TREE
)
3400 vect_struct_type
= make_node (RECORD_TYPE
);
3401 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3402 get_identifier ("vector"),
3403 pvoid_type_node
, &chain
);
3404 TREE_NO_WARNING (tmp
) = 1;
3405 tmp
= gfc_add_field_to_struct_1 (vect_struct_type
,
3406 get_identifier ("kind"),
3407 integer_type_node
, &chain
);
3408 TREE_NO_WARNING (tmp
) = 1;
3409 gfc_finish_type (vect_struct_type
);
3412 triplet_struct_type
= make_node (RECORD_TYPE
);
3413 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3414 get_identifier ("lower_bound"),
3415 gfc_array_index_type
, &chain
);
3416 TREE_NO_WARNING (tmp
) = 1;
3417 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
,
3418 get_identifier ("upper_bound"),
3419 gfc_array_index_type
, &chain
);
3420 TREE_NO_WARNING (tmp
) = 1;
3421 tmp
= gfc_add_field_to_struct_1 (triplet_struct_type
, get_identifier ("stride"),
3422 gfc_array_index_type
, &chain
);
3423 TREE_NO_WARNING (tmp
) = 1;
3424 gfc_finish_type (triplet_struct_type
);
3427 union_type
= make_node (UNION_TYPE
);
3428 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3429 vect_struct_type
, &chain
);
3430 TREE_NO_WARNING (tmp
) = 1;
3431 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("triplet"),
3432 triplet_struct_type
, &chain
);
3433 TREE_NO_WARNING (tmp
) = 1;
3434 gfc_finish_type (union_type
);
3437 vec_type
= make_node (RECORD_TYPE
);
3438 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("nvec"),
3439 size_type_node
, &chain
);
3440 TREE_NO_WARNING (tmp
) = 1;
3441 tmp
= gfc_add_field_to_struct_1 (vec_type
, get_identifier ("u"),
3442 union_type
, &chain
);
3443 TREE_NO_WARNING (tmp
) = 1;
3444 gfc_finish_type (vec_type
);
3445 TYPE_NAME (vec_type
) = get_identifier ("caf_vector_t");
3448 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3449 gfc_rank_cst
[dim
-1]);
3450 vector_types
[dim
-1] = build_array_type (vec_type
, tmp
);
3451 return vector_types
[dim
-1];
3456 gfc_get_caf_reference_type ()
3458 static tree reference_type
= NULL_TREE
;
3459 tree c_struct_type
, s_struct_type
, v_struct_type
, union_type
, dim_union_type
,
3460 a_struct_type
, u_union_type
, tmp
, *chain
;
3462 if (reference_type
!= NULL_TREE
)
3463 return reference_type
;
3466 c_struct_type
= make_node (RECORD_TYPE
);
3467 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3468 get_identifier ("offset"),
3469 gfc_array_index_type
, &chain
);
3470 TREE_NO_WARNING (tmp
) = 1;
3471 tmp
= gfc_add_field_to_struct_1 (c_struct_type
,
3472 get_identifier ("caf_token_offset"),
3473 gfc_array_index_type
, &chain
);
3474 TREE_NO_WARNING (tmp
) = 1;
3475 gfc_finish_type (c_struct_type
);
3478 s_struct_type
= make_node (RECORD_TYPE
);
3479 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3480 get_identifier ("start"),
3481 gfc_array_index_type
, &chain
);
3482 TREE_NO_WARNING (tmp
) = 1;
3483 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3484 get_identifier ("end"),
3485 gfc_array_index_type
, &chain
);
3486 TREE_NO_WARNING (tmp
) = 1;
3487 tmp
= gfc_add_field_to_struct_1 (s_struct_type
,
3488 get_identifier ("stride"),
3489 gfc_array_index_type
, &chain
);
3490 TREE_NO_WARNING (tmp
) = 1;
3491 gfc_finish_type (s_struct_type
);
3494 v_struct_type
= make_node (RECORD_TYPE
);
3495 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3496 get_identifier ("vector"),
3497 pvoid_type_node
, &chain
);
3498 TREE_NO_WARNING (tmp
) = 1;
3499 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3500 get_identifier ("nvec"),
3501 size_type_node
, &chain
);
3502 TREE_NO_WARNING (tmp
) = 1;
3503 tmp
= gfc_add_field_to_struct_1 (v_struct_type
,
3504 get_identifier ("kind"),
3505 integer_type_node
, &chain
);
3506 TREE_NO_WARNING (tmp
) = 1;
3507 gfc_finish_type (v_struct_type
);
3510 union_type
= make_node (UNION_TYPE
);
3511 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("s"),
3512 s_struct_type
, &chain
);
3513 TREE_NO_WARNING (tmp
) = 1;
3514 tmp
= gfc_add_field_to_struct_1 (union_type
, get_identifier ("v"),
3515 v_struct_type
, &chain
);
3516 TREE_NO_WARNING (tmp
) = 1;
3517 gfc_finish_type (union_type
);
3519 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
3520 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1]);
3521 dim_union_type
= build_array_type (union_type
, tmp
);
3524 a_struct_type
= make_node (RECORD_TYPE
);
3525 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("mode"),
3526 build_array_type (unsigned_char_type_node
,
3527 build_range_type (gfc_array_index_type
,
3528 gfc_index_zero_node
,
3529 gfc_rank_cst
[GFC_MAX_DIMENSIONS
- 1])),
3531 TREE_NO_WARNING (tmp
) = 1;
3532 tmp
= gfc_add_field_to_struct_1 (a_struct_type
,
3533 get_identifier ("static_array_type"),
3534 integer_type_node
, &chain
);
3535 TREE_NO_WARNING (tmp
) = 1;
3536 tmp
= gfc_add_field_to_struct_1 (a_struct_type
, get_identifier ("dim"),
3537 dim_union_type
, &chain
);
3538 TREE_NO_WARNING (tmp
) = 1;
3539 gfc_finish_type (a_struct_type
);
3542 u_union_type
= make_node (UNION_TYPE
);
3543 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("c"),
3544 c_struct_type
, &chain
);
3545 TREE_NO_WARNING (tmp
) = 1;
3546 tmp
= gfc_add_field_to_struct_1 (u_union_type
, get_identifier ("a"),
3547 a_struct_type
, &chain
);
3548 TREE_NO_WARNING (tmp
) = 1;
3549 gfc_finish_type (u_union_type
);
3552 reference_type
= make_node (RECORD_TYPE
);
3553 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("next"),
3554 build_pointer_type (reference_type
), &chain
);
3555 TREE_NO_WARNING (tmp
) = 1;
3556 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("type"),
3557 integer_type_node
, &chain
);
3558 TREE_NO_WARNING (tmp
) = 1;
3559 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("item_size"),
3560 size_type_node
, &chain
);
3561 TREE_NO_WARNING (tmp
) = 1;
3562 tmp
= gfc_add_field_to_struct_1 (reference_type
, get_identifier ("u"),
3563 u_union_type
, &chain
);
3564 TREE_NO_WARNING (tmp
) = 1;
3565 gfc_finish_type (reference_type
);
3566 TYPE_NAME (reference_type
) = get_identifier ("caf_reference_t");
3568 return reference_type
;
3571 #include "gt-fortran-trans-types.h"