2018-05-27 Steven G. Kargl <kargl@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-types.c
blobf50eb0a9f01d809839ae05fde06df5251b43b4ca
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
11 version.
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
16 for more details.
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 */
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "target.h"
28 #include "tree.h"
29 #include "gfortran.h"
30 #include "trans.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. */
40 #include "attribs.h"
43 #if (GFC_MAX_DIMENSIONS < 10)
44 #define GFC_RANK_DIGITS 1
45 #define GFC_RANK_PRINTF_FORMAT "%01d"
46 #elif (GFC_MAX_DIMENSIONS < 100)
47 #define GFC_RANK_DIGITS 2
48 #define GFC_RANK_PRINTF_FORMAT "%02d"
49 #else
50 #error If you really need >99 dimensions, continue the sequence above...
51 #endif
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;
59 tree pvoid_type_node;
60 tree prvoid_type_node;
61 tree ppvoid_type_node;
62 tree pchar_type_node;
63 tree pfunc_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;
115 int gfc_c_int_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. */
121 int gfc_intio_kind;
123 /* The integer kind used to store character lengths. */
124 int gfc_charlen_int_kind;
126 /* Kind of internal integer for storing object sizes. */
127 int gfc_size_kind;
129 /* The size of the numeric storage unit and character storage unit. */
130 int gfc_numeric_storage_size;
131 int gfc_character_storage_size;
133 tree dtype_type_node = NULL_TREE;
136 /* Build the dtype_type_node if necessary. */
137 tree get_dtype_type_node (void)
139 tree field;
140 tree dtype_node;
141 tree *dtype_chain = NULL;
143 if (dtype_type_node == NULL_TREE)
145 dtype_node = make_node (RECORD_TYPE);
146 TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
147 TYPE_NAMELESS (dtype_node) = 1;
148 field = gfc_add_field_to_struct_1 (dtype_node,
149 get_identifier ("elem_len"),
150 size_type_node, &dtype_chain);
151 TREE_NO_WARNING (field) = 1;
152 field = gfc_add_field_to_struct_1 (dtype_node,
153 get_identifier ("version"),
154 integer_type_node, &dtype_chain);
155 TREE_NO_WARNING (field) = 1;
156 field = gfc_add_field_to_struct_1 (dtype_node,
157 get_identifier ("rank"),
158 signed_char_type_node, &dtype_chain);
159 TREE_NO_WARNING (field) = 1;
160 field = gfc_add_field_to_struct_1 (dtype_node,
161 get_identifier ("type"),
162 signed_char_type_node, &dtype_chain);
163 TREE_NO_WARNING (field) = 1;
164 field = gfc_add_field_to_struct_1 (dtype_node,
165 get_identifier ("attribute"),
166 short_integer_type_node, &dtype_chain);
167 TREE_NO_WARNING (field) = 1;
168 gfc_finish_type (dtype_node);
169 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
170 dtype_type_node = dtype_node;
172 return dtype_type_node;
175 bool
176 gfc_check_any_c_kind (gfc_typespec *ts)
178 int i;
180 for (i = 0; i < ISOCBINDING_NUMBER; i++)
182 /* Check for any C interoperable kind for the given type/kind in ts.
183 This can be used after verify_c_interop to make sure that the
184 Fortran kind being used exists in at least some form for C. */
185 if (c_interop_kinds_table[i].f90_type == ts->type &&
186 c_interop_kinds_table[i].value == ts->kind)
187 return true;
190 return false;
194 static int
195 get_real_kind_from_node (tree type)
197 int i;
199 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
200 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
201 return gfc_real_kinds[i].kind;
203 return -4;
206 static int
207 get_int_kind_from_node (tree type)
209 int i;
211 if (!type)
212 return -2;
214 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
215 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
216 return gfc_integer_kinds[i].kind;
218 return -1;
221 /* Return a typenode for the "standard" C type with a given name. */
222 static tree
223 get_typenode_from_name (const char *name)
225 if (name == NULL || *name == '\0')
226 return NULL_TREE;
228 if (strcmp (name, "char") == 0)
229 return char_type_node;
230 if (strcmp (name, "unsigned char") == 0)
231 return unsigned_char_type_node;
232 if (strcmp (name, "signed char") == 0)
233 return signed_char_type_node;
235 if (strcmp (name, "short int") == 0)
236 return short_integer_type_node;
237 if (strcmp (name, "short unsigned int") == 0)
238 return short_unsigned_type_node;
240 if (strcmp (name, "int") == 0)
241 return integer_type_node;
242 if (strcmp (name, "unsigned int") == 0)
243 return unsigned_type_node;
245 if (strcmp (name, "long int") == 0)
246 return long_integer_type_node;
247 if (strcmp (name, "long unsigned int") == 0)
248 return long_unsigned_type_node;
250 if (strcmp (name, "long long int") == 0)
251 return long_long_integer_type_node;
252 if (strcmp (name, "long long unsigned int") == 0)
253 return long_long_unsigned_type_node;
255 gcc_unreachable ();
258 static int
259 get_int_kind_from_name (const char *name)
261 return get_int_kind_from_node (get_typenode_from_name (name));
265 /* Get the kind number corresponding to an integer of given size,
266 following the required return values for ISO_FORTRAN_ENV INT* constants:
267 -2 is returned if we support a kind of larger size, -1 otherwise. */
269 gfc_get_int_kind_from_width_isofortranenv (int size)
271 int i;
273 /* Look for a kind with matching storage size. */
274 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
275 if (gfc_integer_kinds[i].bit_size == size)
276 return gfc_integer_kinds[i].kind;
278 /* Look for a kind with larger storage size. */
279 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
280 if (gfc_integer_kinds[i].bit_size > size)
281 return -2;
283 return -1;
287 /* Get the kind number corresponding to a real of a given storage size.
288 If two real's have the same storage size, then choose the real with
289 the largest precision. If a kind type is unavailable and a real
290 exists with wider storage, then return -2; otherwise, return -1. */
293 gfc_get_real_kind_from_width_isofortranenv (int size)
295 int digits, i, kind;
297 size /= 8;
299 kind = -1;
300 digits = 0;
302 /* Look for a kind with matching storage size. */
303 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
304 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
306 if (gfc_real_kinds[i].digits > digits)
308 digits = gfc_real_kinds[i].digits;
309 kind = gfc_real_kinds[i].kind;
313 if (kind != -1)
314 return kind;
316 /* Look for a kind with larger storage size. */
317 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
318 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
319 kind = -2;
321 return kind;
326 static int
327 get_int_kind_from_width (int size)
329 int i;
331 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
332 if (gfc_integer_kinds[i].bit_size == size)
333 return gfc_integer_kinds[i].kind;
335 return -2;
338 static int
339 get_int_kind_from_minimal_width (int size)
341 int i;
343 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
344 if (gfc_integer_kinds[i].bit_size >= size)
345 return gfc_integer_kinds[i].kind;
347 return -2;
351 /* Generate the CInteropKind_t objects for the C interoperable
352 kinds. */
354 void
355 gfc_init_c_interop_kinds (void)
357 int i;
359 /* init all pointers in the list to NULL */
360 for (i = 0; i < ISOCBINDING_NUMBER; i++)
362 /* Initialize the name and value fields. */
363 c_interop_kinds_table[i].name[0] = '\0';
364 c_interop_kinds_table[i].value = -100;
365 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
368 #define NAMED_INTCST(a,b,c,d) \
369 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
370 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
371 c_interop_kinds_table[a].value = c;
372 #define NAMED_REALCST(a,b,c,d) \
373 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
374 c_interop_kinds_table[a].f90_type = BT_REAL; \
375 c_interop_kinds_table[a].value = c;
376 #define NAMED_CMPXCST(a,b,c,d) \
377 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
378 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
379 c_interop_kinds_table[a].value = c;
380 #define NAMED_LOGCST(a,b,c) \
381 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
382 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
383 c_interop_kinds_table[a].value = c;
384 #define NAMED_CHARKNDCST(a,b,c) \
385 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
386 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
387 c_interop_kinds_table[a].value = c;
388 #define NAMED_CHARCST(a,b,c) \
389 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
390 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
391 c_interop_kinds_table[a].value = c;
392 #define DERIVED_TYPE(a,b,c) \
393 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
394 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
395 c_interop_kinds_table[a].value = c;
396 #define NAMED_FUNCTION(a,b,c,d) \
397 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
398 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
399 c_interop_kinds_table[a].value = c;
400 #define NAMED_SUBROUTINE(a,b,c,d) \
401 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
402 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
403 c_interop_kinds_table[a].value = c;
404 #include "iso-c-binding.def"
408 /* Query the target to determine which machine modes are available for
409 computation. Choose KIND numbers for them. */
411 void
412 gfc_init_kinds (void)
414 opt_scalar_int_mode int_mode_iter;
415 opt_scalar_float_mode float_mode_iter;
416 int i_index, r_index, kind;
417 bool saw_i4 = false, saw_i8 = false;
418 bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
420 i_index = 0;
421 FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT)
423 scalar_int_mode mode = int_mode_iter.require ();
424 int kind, bitsize;
426 if (!targetm.scalar_mode_supported_p (mode))
427 continue;
429 /* The middle end doesn't support constants larger than 2*HWI.
430 Perhaps the target hook shouldn't have accepted these either,
431 but just to be safe... */
432 bitsize = GET_MODE_BITSIZE (mode);
433 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
434 continue;
436 gcc_assert (i_index != MAX_INT_KINDS);
438 /* Let the kind equal the bit size divided by 8. This insulates the
439 programmer from the underlying byte size. */
440 kind = bitsize / 8;
442 if (kind == 4)
443 saw_i4 = true;
444 if (kind == 8)
445 saw_i8 = true;
447 gfc_integer_kinds[i_index].kind = kind;
448 gfc_integer_kinds[i_index].radix = 2;
449 gfc_integer_kinds[i_index].digits = bitsize - 1;
450 gfc_integer_kinds[i_index].bit_size = bitsize;
452 gfc_logical_kinds[i_index].kind = kind;
453 gfc_logical_kinds[i_index].bit_size = bitsize;
455 i_index += 1;
458 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
459 used for large file access. */
461 if (saw_i8)
462 gfc_intio_kind = 8;
463 else
464 gfc_intio_kind = 4;
466 /* If we do not at least have kind = 4, everything is pointless. */
467 gcc_assert(saw_i4);
469 /* Set the maximum integer kind. Used with at least BOZ constants. */
470 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
472 r_index = 0;
473 FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT)
475 scalar_float_mode mode = float_mode_iter.require ();
476 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
477 int kind;
479 if (fmt == NULL)
480 continue;
481 if (!targetm.scalar_mode_supported_p (mode))
482 continue;
484 /* Only let float, double, long double and __float128 go through.
485 Runtime support for others is not provided, so they would be
486 useless. */
487 if (!targetm.libgcc_floating_mode_supported_p (mode))
488 continue;
489 if (mode != TYPE_MODE (float_type_node)
490 && (mode != TYPE_MODE (double_type_node))
491 && (mode != TYPE_MODE (long_double_type_node))
492 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
493 && (mode != TFmode)
494 #endif
496 continue;
498 /* Let the kind equal the precision divided by 8, rounding up. Again,
499 this insulates the programmer from the underlying byte size.
501 Also, it effectively deals with IEEE extended formats. There, the
502 total size of the type may equal 16, but it's got 6 bytes of padding
503 and the increased size can get in the way of a real IEEE quad format
504 which may also be supported by the target.
506 We round up so as to handle IA-64 __floatreg (RFmode), which is an
507 82 bit type. Not to be confused with __float80 (XFmode), which is
508 an 80 bit type also supported by IA-64. So XFmode should come out
509 to be kind=10, and RFmode should come out to be kind=11. Egads. */
511 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
513 if (kind == 4)
514 saw_r4 = true;
515 if (kind == 8)
516 saw_r8 = true;
517 if (kind == 10)
518 saw_r10 = true;
519 if (kind == 16)
520 saw_r16 = true;
522 /* Careful we don't stumble a weird internal mode. */
523 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
524 /* Or have too many modes for the allocated space. */
525 gcc_assert (r_index != MAX_REAL_KINDS);
527 gfc_real_kinds[r_index].kind = kind;
528 gfc_real_kinds[r_index].radix = fmt->b;
529 gfc_real_kinds[r_index].digits = fmt->p;
530 gfc_real_kinds[r_index].min_exponent = fmt->emin;
531 gfc_real_kinds[r_index].max_exponent = fmt->emax;
532 if (fmt->pnan < fmt->p)
533 /* This is an IBM extended double format (or the MIPS variant)
534 made up of two IEEE doubles. The value of the long double is
535 the sum of the values of the two parts. The most significant
536 part is required to be the value of the long double rounded
537 to the nearest double. If we use emax of 1024 then we can't
538 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
539 rounding will make the most significant part overflow. */
540 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
541 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
542 r_index += 1;
545 /* Choose the default integer kind. We choose 4 unless the user directs us
546 otherwise. Even if the user specified that the default integer kind is 8,
547 the numeric storage size is not 64 bits. In this case, a warning will be
548 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
550 gfc_numeric_storage_size = 4 * 8;
552 if (flag_default_integer)
554 if (!saw_i8)
555 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
556 "%<-fdefault-integer-8%> option");
558 gfc_default_integer_kind = 8;
561 else if (flag_integer4_kind == 8)
563 if (!saw_i8)
564 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
565 "%<-finteger-4-integer-8%> option");
567 gfc_default_integer_kind = 8;
569 else if (saw_i4)
571 gfc_default_integer_kind = 4;
573 else
575 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
576 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
579 /* Choose the default real kind. Again, we choose 4 when possible. */
580 if (flag_default_real_8)
582 if (!saw_r8)
583 gfc_fatal_error ("REAL(KIND=8) is not available for "
584 "%<-fdefault-real-8%> option");
586 gfc_default_real_kind = 8;
588 else if (flag_default_real_10)
590 if (!saw_r10)
591 gfc_fatal_error ("REAL(KIND=10) is not available for "
592 "%<-fdefault-real-10%> option");
594 gfc_default_real_kind = 10;
596 else if (flag_default_real_16)
598 if (!saw_r16)
599 gfc_fatal_error ("REAL(KIND=16) is not available for "
600 "%<-fdefault-real-16%> option");
602 gfc_default_real_kind = 16;
604 else if (flag_real4_kind == 8)
606 if (!saw_r8)
607 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
608 "option");
610 gfc_default_real_kind = 8;
612 else if (flag_real4_kind == 10)
614 if (!saw_r10)
615 gfc_fatal_error ("REAL(KIND=10) is not available for "
616 "%<-freal-4-real-10%> option");
618 gfc_default_real_kind = 10;
620 else if (flag_real4_kind == 16)
622 if (!saw_r16)
623 gfc_fatal_error ("REAL(KIND=16) is not available for "
624 "%<-freal-4-real-16%> option");
626 gfc_default_real_kind = 16;
628 else if (saw_r4)
629 gfc_default_real_kind = 4;
630 else
631 gfc_default_real_kind = gfc_real_kinds[0].kind;
633 /* Choose the default double kind. If -fdefault-real and -fdefault-double
634 are specified, we use kind=8, if it's available. If -fdefault-real is
635 specified without -fdefault-double, we use kind=16, if it's available.
636 Otherwise we do not change anything. */
637 if (flag_default_double && saw_r8)
638 gfc_default_double_kind = 8;
639 else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16)
641 /* Use largest available kind. */
642 if (saw_r16)
643 gfc_default_double_kind = 16;
644 else if (saw_r10)
645 gfc_default_double_kind = 10;
646 else if (saw_r8)
647 gfc_default_double_kind = 8;
648 else
649 gfc_default_double_kind = gfc_default_real_kind;
651 else if (flag_real8_kind == 4)
653 if (!saw_r4)
654 gfc_fatal_error ("REAL(KIND=4) is not available for "
655 "%<-freal-8-real-4%> option");
657 gfc_default_double_kind = 4;
659 else if (flag_real8_kind == 10 )
661 if (!saw_r10)
662 gfc_fatal_error ("REAL(KIND=10) is not available for "
663 "%<-freal-8-real-10%> option");
665 gfc_default_double_kind = 10;
667 else if (flag_real8_kind == 16 )
669 if (!saw_r16)
670 gfc_fatal_error ("REAL(KIND=10) is not available for "
671 "%<-freal-8-real-16%> option");
673 gfc_default_double_kind = 16;
675 else if (saw_r4 && saw_r8)
676 gfc_default_double_kind = 8;
677 else
679 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
680 real ... occupies two contiguous numeric storage units.
682 Therefore we must be supplied a kind twice as large as we chose
683 for single precision. There are loopholes, in that double
684 precision must *occupy* two storage units, though it doesn't have
685 to *use* two storage units. Which means that you can make this
686 kind artificially wide by padding it. But at present there are
687 no GCC targets for which a two-word type does not exist, so we
688 just let gfc_validate_kind abort and tell us if something breaks. */
690 gfc_default_double_kind
691 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
694 /* The default logical kind is constrained to be the same as the
695 default integer kind. Similarly with complex and real. */
696 gfc_default_logical_kind = gfc_default_integer_kind;
697 gfc_default_complex_kind = gfc_default_real_kind;
699 /* We only have two character kinds: ASCII and UCS-4.
700 ASCII corresponds to a 8-bit integer type, if one is available.
701 UCS-4 corresponds to a 32-bit integer type, if one is available. */
702 i_index = 0;
703 if ((kind = get_int_kind_from_width (8)) > 0)
705 gfc_character_kinds[i_index].kind = kind;
706 gfc_character_kinds[i_index].bit_size = 8;
707 gfc_character_kinds[i_index].name = "ascii";
708 i_index++;
710 if ((kind = get_int_kind_from_width (32)) > 0)
712 gfc_character_kinds[i_index].kind = kind;
713 gfc_character_kinds[i_index].bit_size = 32;
714 gfc_character_kinds[i_index].name = "iso_10646";
715 i_index++;
718 /* Choose the smallest integer kind for our default character. */
719 gfc_default_character_kind = gfc_character_kinds[0].kind;
720 gfc_character_storage_size = gfc_default_character_kind * 8;
722 gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);
724 /* Pick a kind the same size as the C "int" type. */
725 gfc_c_int_kind = INT_TYPE_SIZE / 8;
727 /* Choose atomic kinds to match C's int. */
728 gfc_atomic_int_kind = gfc_c_int_kind;
729 gfc_atomic_logical_kind = gfc_c_int_kind;
733 /* Make sure that a valid kind is present. Returns an index into the
734 associated kinds array, -1 if the kind is not present. */
736 static int
737 validate_integer (int kind)
739 int i;
741 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
742 if (gfc_integer_kinds[i].kind == kind)
743 return i;
745 return -1;
748 static int
749 validate_real (int kind)
751 int i;
753 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
754 if (gfc_real_kinds[i].kind == kind)
755 return i;
757 return -1;
760 static int
761 validate_logical (int kind)
763 int i;
765 for (i = 0; gfc_logical_kinds[i].kind; i++)
766 if (gfc_logical_kinds[i].kind == kind)
767 return i;
769 return -1;
772 static int
773 validate_character (int kind)
775 int i;
777 for (i = 0; gfc_character_kinds[i].kind; i++)
778 if (gfc_character_kinds[i].kind == kind)
779 return i;
781 return -1;
784 /* Validate a kind given a basic type. The return value is the same
785 for the child functions, with -1 indicating nonexistence of the
786 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
789 gfc_validate_kind (bt type, int kind, bool may_fail)
791 int rc;
793 switch (type)
795 case BT_REAL: /* Fall through */
796 case BT_COMPLEX:
797 rc = validate_real (kind);
798 break;
799 case BT_INTEGER:
800 rc = validate_integer (kind);
801 break;
802 case BT_LOGICAL:
803 rc = validate_logical (kind);
804 break;
805 case BT_CHARACTER:
806 rc = validate_character (kind);
807 break;
809 default:
810 gfc_internal_error ("gfc_validate_kind(): Got bad type");
813 if (rc < 0 && !may_fail)
814 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
816 return rc;
820 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
821 Reuse common type nodes where possible. Recognize if the kind matches up
822 with a C type. This will be used later in determining which routines may
823 be scarfed from libm. */
825 static tree
826 gfc_build_int_type (gfc_integer_info *info)
828 int mode_precision = info->bit_size;
830 if (mode_precision == CHAR_TYPE_SIZE)
831 info->c_char = 1;
832 if (mode_precision == SHORT_TYPE_SIZE)
833 info->c_short = 1;
834 if (mode_precision == INT_TYPE_SIZE)
835 info->c_int = 1;
836 if (mode_precision == LONG_TYPE_SIZE)
837 info->c_long = 1;
838 if (mode_precision == LONG_LONG_TYPE_SIZE)
839 info->c_long_long = 1;
841 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
842 return intQI_type_node;
843 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
844 return intHI_type_node;
845 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
846 return intSI_type_node;
847 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
848 return intDI_type_node;
849 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
850 return intTI_type_node;
852 return make_signed_type (mode_precision);
855 tree
856 gfc_build_uint_type (int size)
858 if (size == CHAR_TYPE_SIZE)
859 return unsigned_char_type_node;
860 if (size == SHORT_TYPE_SIZE)
861 return short_unsigned_type_node;
862 if (size == INT_TYPE_SIZE)
863 return unsigned_type_node;
864 if (size == LONG_TYPE_SIZE)
865 return long_unsigned_type_node;
866 if (size == LONG_LONG_TYPE_SIZE)
867 return long_long_unsigned_type_node;
869 return make_unsigned_type (size);
873 static tree
874 gfc_build_real_type (gfc_real_info *info)
876 int mode_precision = info->mode_precision;
877 tree new_type;
879 if (mode_precision == FLOAT_TYPE_SIZE)
880 info->c_float = 1;
881 if (mode_precision == DOUBLE_TYPE_SIZE)
882 info->c_double = 1;
883 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
884 info->c_long_double = 1;
885 if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
887 info->c_float128 = 1;
888 gfc_real16_is_float128 = true;
891 if (TYPE_PRECISION (float_type_node) == mode_precision)
892 return float_type_node;
893 if (TYPE_PRECISION (double_type_node) == mode_precision)
894 return double_type_node;
895 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
896 return long_double_type_node;
898 new_type = make_node (REAL_TYPE);
899 TYPE_PRECISION (new_type) = mode_precision;
900 layout_type (new_type);
901 return new_type;
904 static tree
905 gfc_build_complex_type (tree scalar_type)
907 tree new_type;
909 if (scalar_type == NULL)
910 return NULL;
911 if (scalar_type == float_type_node)
912 return complex_float_type_node;
913 if (scalar_type == double_type_node)
914 return complex_double_type_node;
915 if (scalar_type == long_double_type_node)
916 return complex_long_double_type_node;
918 new_type = make_node (COMPLEX_TYPE);
919 TREE_TYPE (new_type) = scalar_type;
920 layout_type (new_type);
921 return new_type;
924 static tree
925 gfc_build_logical_type (gfc_logical_info *info)
927 int bit_size = info->bit_size;
928 tree new_type;
930 if (bit_size == BOOL_TYPE_SIZE)
932 info->c_bool = 1;
933 return boolean_type_node;
936 new_type = make_unsigned_type (bit_size);
937 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
938 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
939 TYPE_PRECISION (new_type) = 1;
941 return new_type;
945 /* Create the backend type nodes. We map them to their
946 equivalent C type, at least for now. We also give
947 names to the types here, and we push them in the
948 global binding level context.*/
950 void
951 gfc_init_types (void)
953 char name_buf[26];
954 int index;
955 tree type;
956 unsigned n;
958 /* Create and name the types. */
959 #define PUSH_TYPE(name, node) \
960 pushdecl (build_decl (input_location, \
961 TYPE_DECL, get_identifier (name), node))
963 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
965 type = gfc_build_int_type (&gfc_integer_kinds[index]);
966 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
967 if (TYPE_STRING_FLAG (type))
968 type = make_signed_type (gfc_integer_kinds[index].bit_size);
969 gfc_integer_types[index] = type;
970 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
971 gfc_integer_kinds[index].kind);
972 PUSH_TYPE (name_buf, type);
975 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
977 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
978 gfc_logical_types[index] = type;
979 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
980 gfc_logical_kinds[index].kind);
981 PUSH_TYPE (name_buf, type);
984 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
986 type = gfc_build_real_type (&gfc_real_kinds[index]);
987 gfc_real_types[index] = type;
988 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
989 gfc_real_kinds[index].kind);
990 PUSH_TYPE (name_buf, type);
992 if (gfc_real_kinds[index].c_float128)
993 gfc_float128_type_node = type;
995 type = gfc_build_complex_type (type);
996 gfc_complex_types[index] = type;
997 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
998 gfc_real_kinds[index].kind);
999 PUSH_TYPE (name_buf, type);
1001 if (gfc_real_kinds[index].c_float128)
1002 gfc_complex_float128_type_node = type;
1005 for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
1007 type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
1008 type = build_qualified_type (type, TYPE_UNQUALIFIED);
1009 snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
1010 gfc_character_kinds[index].kind);
1011 PUSH_TYPE (name_buf, type);
1012 gfc_character_types[index] = type;
1013 gfc_pcharacter_types[index] = build_pointer_type (type);
1015 gfc_character1_type_node = gfc_character_types[0];
1017 PUSH_TYPE ("byte", unsigned_char_type_node);
1018 PUSH_TYPE ("void", void_type_node);
1020 /* DBX debugging output gets upset if these aren't set. */
1021 if (!TYPE_NAME (integer_type_node))
1022 PUSH_TYPE ("c_integer", integer_type_node);
1023 if (!TYPE_NAME (char_type_node))
1024 PUSH_TYPE ("c_char", char_type_node);
1026 #undef PUSH_TYPE
1028 pvoid_type_node = build_pointer_type (void_type_node);
1029 prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
1030 ppvoid_type_node = build_pointer_type (pvoid_type_node);
1031 pchar_type_node = build_pointer_type (gfc_character1_type_node);
1032 pfunc_type_node
1033 = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
1035 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
1036 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
1037 since this function is called before gfc_init_constants. */
1038 gfc_array_range_type
1039 = build_range_type (gfc_array_index_type,
1040 build_int_cst (gfc_array_index_type, 0),
1041 NULL_TREE);
1043 /* The maximum array element size that can be handled is determined
1044 by the number of bits available to store this field in the array
1045 descriptor. */
1047 n = TYPE_PRECISION (size_type_node);
1048 gfc_max_array_element_size
1049 = wide_int_to_tree (size_type_node,
1050 wi::mask (n, UNSIGNED,
1051 TYPE_PRECISION (size_type_node)));
1053 logical_type_node = gfc_get_logical_type (gfc_default_logical_kind);
1054 logical_true_node = build_int_cst (logical_type_node, 1);
1055 logical_false_node = build_int_cst (logical_type_node, 0);
1057 /* Character lengths are of type size_t, except signed. */
1058 gfc_charlen_int_kind = get_int_kind_from_node (size_type_node);
1059 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
1061 /* Fortran kind number of size_type_node (size_t). This is used for
1062 the _size member in vtables. */
1063 gfc_size_kind = get_int_kind_from_node (size_type_node);
1066 /* Get the type node for the given type and kind. */
1068 tree
1069 gfc_get_int_type (int kind)
1071 int index = gfc_validate_kind (BT_INTEGER, kind, true);
1072 return index < 0 ? 0 : gfc_integer_types[index];
1075 tree
1076 gfc_get_real_type (int kind)
1078 int index = gfc_validate_kind (BT_REAL, kind, true);
1079 return index < 0 ? 0 : gfc_real_types[index];
1082 tree
1083 gfc_get_complex_type (int kind)
1085 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
1086 return index < 0 ? 0 : gfc_complex_types[index];
1089 tree
1090 gfc_get_logical_type (int kind)
1092 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
1093 return index < 0 ? 0 : gfc_logical_types[index];
1096 tree
1097 gfc_get_char_type (int kind)
1099 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
1100 return index < 0 ? 0 : gfc_character_types[index];
1103 tree
1104 gfc_get_pchar_type (int kind)
1106 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
1107 return index < 0 ? 0 : gfc_pcharacter_types[index];
1111 /* Create a character type with the given kind and length. */
1113 tree
1114 gfc_get_character_type_len_for_eltype (tree eltype, tree len)
1116 tree bounds, type;
1118 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
1119 type = build_array_type (eltype, bounds);
1120 TYPE_STRING_FLAG (type) = 1;
1122 return type;
1125 tree
1126 gfc_get_character_type_len (int kind, tree len)
1128 gfc_validate_kind (BT_CHARACTER, kind, false);
1129 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
1133 /* Get a type node for a character kind. */
1135 tree
1136 gfc_get_character_type (int kind, gfc_charlen * cl)
1138 tree len;
1140 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
1141 if (len && POINTER_TYPE_P (TREE_TYPE (len)))
1142 len = build_fold_indirect_ref (len);
1144 return gfc_get_character_type_len (kind, len);
1147 /* Convert a basic type. This will be an array for character types. */
1149 tree
1150 gfc_typenode_for_spec (gfc_typespec * spec, int codim)
1152 tree basetype;
1154 switch (spec->type)
1156 case BT_UNKNOWN:
1157 gcc_unreachable ();
1159 case BT_INTEGER:
1160 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1161 has been resolved. This is done so we can convert C_PTR and
1162 C_FUNPTR to simple variables that get translated to (void *). */
1163 if (spec->f90_type == BT_VOID)
1165 if (spec->u.derived
1166 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1167 basetype = ptr_type_node;
1168 else
1169 basetype = pfunc_type_node;
1171 else
1172 basetype = gfc_get_int_type (spec->kind);
1173 break;
1175 case BT_REAL:
1176 basetype = gfc_get_real_type (spec->kind);
1177 break;
1179 case BT_COMPLEX:
1180 basetype = gfc_get_complex_type (spec->kind);
1181 break;
1183 case BT_LOGICAL:
1184 basetype = gfc_get_logical_type (spec->kind);
1185 break;
1187 case BT_CHARACTER:
1188 basetype = gfc_get_character_type (spec->kind, spec->u.cl);
1189 break;
1191 case BT_HOLLERITH:
1192 /* Since this cannot be used, return a length one character. */
1193 basetype = gfc_get_character_type_len (gfc_default_character_kind,
1194 gfc_index_one_node);
1195 break;
1197 case BT_UNION:
1198 basetype = gfc_get_union_type (spec->u.derived);
1199 break;
1201 case BT_DERIVED:
1202 case BT_CLASS:
1203 basetype = gfc_get_derived_type (spec->u.derived, codim);
1205 if (spec->type == BT_CLASS)
1206 GFC_CLASS_TYPE_P (basetype) = 1;
1208 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1209 type and kind to fit a (void *) and the basetype returned was a
1210 ptr_type_node. We need to pass up this new information to the
1211 symbol that was declared of type C_PTR or C_FUNPTR. */
1212 if (spec->u.derived->ts.f90_type == BT_VOID)
1214 spec->type = BT_INTEGER;
1215 spec->kind = gfc_index_integer_kind;
1216 spec->f90_type = BT_VOID;
1218 break;
1219 case BT_VOID:
1220 case BT_ASSUMED:
1221 /* This is for the second arg to c_f_pointer and c_f_procpointer
1222 of the iso_c_binding module, to accept any ptr type. */
1223 basetype = ptr_type_node;
1224 if (spec->f90_type == BT_VOID)
1226 if (spec->u.derived
1227 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1228 basetype = ptr_type_node;
1229 else
1230 basetype = pfunc_type_node;
1232 break;
1233 default:
1234 gcc_unreachable ();
1236 return basetype;
1239 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1241 static tree
1242 gfc_conv_array_bound (gfc_expr * expr)
1244 /* If expr is an integer constant, return that. */
1245 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
1246 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
1248 /* Otherwise return NULL. */
1249 return NULL_TREE;
1252 /* Return the type of an element of the array. Note that scalar coarrays
1253 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1254 (with POINTER_TYPE stripped) is returned. */
1256 tree
1257 gfc_get_element_type (tree type)
1259 tree element;
1261 if (GFC_ARRAY_TYPE_P (type))
1263 if (TREE_CODE (type) == POINTER_TYPE)
1264 type = TREE_TYPE (type);
1265 if (GFC_TYPE_ARRAY_RANK (type) == 0)
1267 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
1268 element = type;
1270 else
1272 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1273 element = TREE_TYPE (type);
1276 else
1278 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
1279 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
1281 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
1282 element = TREE_TYPE (element);
1284 /* For arrays, which are not scalar coarrays. */
1285 if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
1286 element = TREE_TYPE (element);
1289 return element;
1292 /* Build an array. This function is called from gfc_sym_type().
1293 Actually returns array descriptor type.
1295 Format of array descriptors is as follows:
1297 struct gfc_array_descriptor
1299 array *data;
1300 index offset;
1301 struct dtype_type dtype;
1302 struct descriptor_dimension dimension[N_DIM];
1305 struct dtype_type
1307 size_t elem_len;
1308 int version;
1309 signed char rank;
1310 signed char type;
1311 signed short attribute;
1314 struct descriptor_dimension
1316 index stride;
1317 index lbound;
1318 index ubound;
1321 Translation code should use gfc_conv_descriptor_* rather than
1322 accessing the descriptor directly. Any changes to the array
1323 descriptor type will require changes in gfc_conv_descriptor_* and
1324 gfc_build_array_initializer.
1326 This is represented internally as a RECORD_TYPE. The index nodes
1327 are gfc_array_index_type and the data node is a pointer to the
1328 data. See below for the handling of character types.
1330 I originally used nested ARRAY_TYPE nodes to represent arrays, but
1331 this generated poor code for assumed/deferred size arrays. These
1332 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1333 of the GENERIC grammar. Also, there is no way to explicitly set
1334 the array stride, so all data must be packed(1). I've tried to
1335 mark all the functions which would require modification with a GCC
1336 ARRAYS comment.
1338 The data component points to the first element in the array. The
1339 offset field is the position of the origin of the array (i.e. element
1340 (0, 0 ...)). This may be outside the bounds of the array.
1342 An element is accessed by
1343 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1344 This gives good performance as the computation does not involve the
1345 bounds of the array. For packed arrays, this is optimized further
1346 by substituting the known strides.
1348 This system has one problem: all array bounds must be within 2^31
1349 elements of the origin (2^63 on 64-bit machines). For example
1350 integer, dimension (80000:90000, 80000:90000, 2) :: array
1351 may not work properly on 32-bit machines because 80000*80000 >
1352 2^31, so the calculation for stride2 would overflow. This may
1353 still work, but I haven't checked, and it relies on the overflow
1354 doing the right thing.
1356 The way to fix this problem is to access elements as follows:
1357 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1358 Obviously this is much slower. I will make this a compile time
1359 option, something like -fsmall-array-offsets. Mixing code compiled
1360 with and without this switch will work.
1362 (1) This can be worked around by modifying the upper bound of the
1363 previous dimension. This requires extra fields in the descriptor
1364 (both real_ubound and fake_ubound). */
1367 /* Returns true if the array sym does not require a descriptor. */
1370 gfc_is_nodesc_array (gfc_symbol * sym)
1372 symbol_attribute *array_attr;
1373 gfc_array_spec *as;
1374 bool is_classarray = IS_CLASS_ARRAY (sym);
1376 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
1377 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
1379 gcc_assert (array_attr->dimension || array_attr->codimension);
1381 /* We only want local arrays. */
1382 if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
1383 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
1384 || array_attr->allocatable)
1385 return 0;
1387 /* We want a descriptor for associate-name arrays that do not have an
1388 explicitly known shape already. */
1389 if (sym->assoc && as->type != AS_EXPLICIT)
1390 return 0;
1392 /* The dummy is stored in sym and not in the component. */
1393 if (sym->attr.dummy)
1394 return as->type != AS_ASSUMED_SHAPE
1395 && as->type != AS_ASSUMED_RANK;
1397 if (sym->attr.result || sym->attr.function)
1398 return 0;
1400 gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
1402 return 1;
1406 /* Create an array descriptor type. */
1408 static tree
1409 gfc_build_array_type (tree type, gfc_array_spec * as,
1410 enum gfc_array_kind akind, bool restricted,
1411 bool contiguous, int codim)
1413 tree lbound[GFC_MAX_DIMENSIONS];
1414 tree ubound[GFC_MAX_DIMENSIONS];
1415 int n, corank;
1417 /* Assumed-shape arrays do not have codimension information stored in the
1418 descriptor. */
1419 corank = MAX (as->corank, codim);
1420 if (as->type == AS_ASSUMED_SHAPE ||
1421 (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
1422 corank = codim;
1424 if (as->type == AS_ASSUMED_RANK)
1425 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1427 lbound[n] = NULL_TREE;
1428 ubound[n] = NULL_TREE;
1431 for (n = 0; n < as->rank; n++)
1433 /* Create expressions for the known bounds of the array. */
1434 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1435 lbound[n] = gfc_index_one_node;
1436 else
1437 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1438 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1441 for (n = as->rank; n < as->rank + corank; n++)
1443 if (as->type != AS_DEFERRED && as->lower[n] == NULL)
1444 lbound[n] = gfc_index_one_node;
1445 else
1446 lbound[n] = gfc_conv_array_bound (as->lower[n]);
1448 if (n < as->rank + corank - 1)
1449 ubound[n] = gfc_conv_array_bound (as->upper[n]);
1452 if (as->type == AS_ASSUMED_SHAPE)
1453 akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
1454 : GFC_ARRAY_ASSUMED_SHAPE;
1455 else if (as->type == AS_ASSUMED_RANK)
1456 akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
1457 : GFC_ARRAY_ASSUMED_RANK;
1458 return gfc_get_array_type_bounds (type, as->rank == -1
1459 ? GFC_MAX_DIMENSIONS : as->rank,
1460 corank, lbound, ubound, 0, akind,
1461 restricted);
1464 /* Returns the struct descriptor_dimension type. */
1466 static tree
1467 gfc_get_desc_dim_type (void)
1469 tree type;
1470 tree decl, *chain = NULL;
1472 if (gfc_desc_dim_type)
1473 return gfc_desc_dim_type;
1475 /* Build the type node. */
1476 type = make_node (RECORD_TYPE);
1478 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1479 TYPE_PACKED (type) = 1;
1481 /* Consists of the stride, lbound and ubound members. */
1482 decl = gfc_add_field_to_struct_1 (type,
1483 get_identifier ("stride"),
1484 gfc_array_index_type, &chain);
1485 TREE_NO_WARNING (decl) = 1;
1487 decl = gfc_add_field_to_struct_1 (type,
1488 get_identifier ("lbound"),
1489 gfc_array_index_type, &chain);
1490 TREE_NO_WARNING (decl) = 1;
1492 decl = gfc_add_field_to_struct_1 (type,
1493 get_identifier ("ubound"),
1494 gfc_array_index_type, &chain);
1495 TREE_NO_WARNING (decl) = 1;
1497 /* Finish off the type. */
1498 gfc_finish_type (type);
1499 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1501 gfc_desc_dim_type = type;
1502 return type;
1506 /* Return the DTYPE for an array. This describes the type and type parameters
1507 of the array. */
1508 /* TODO: Only call this when the value is actually used, and make all the
1509 unknown cases abort. */
1511 tree
1512 gfc_get_dtype_rank_type (int rank, tree etype)
1514 tree size;
1515 int n;
1516 tree tmp;
1517 tree dtype;
1518 tree field;
1519 vec<constructor_elt, va_gc> *v = NULL;
1521 size = TYPE_SIZE_UNIT (etype);
1523 switch (TREE_CODE (etype))
1525 case INTEGER_TYPE:
1526 n = BT_INTEGER;
1527 break;
1529 case BOOLEAN_TYPE:
1530 n = BT_LOGICAL;
1531 break;
1533 case REAL_TYPE:
1534 n = BT_REAL;
1535 break;
1537 case COMPLEX_TYPE:
1538 n = BT_COMPLEX;
1539 break;
1541 case RECORD_TYPE:
1542 if (GFC_CLASS_TYPE_P (etype))
1543 n = BT_CLASS;
1544 else
1545 n = BT_DERIVED;
1546 break;
1548 /* We will never have arrays of arrays. */
1549 case ARRAY_TYPE:
1550 n = BT_CHARACTER;
1551 if (size == NULL_TREE)
1552 size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
1553 break;
1555 case POINTER_TYPE:
1556 n = BT_ASSUMED;
1557 if (TREE_CODE (TREE_TYPE (etype)) != VOID_TYPE)
1558 size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
1559 else
1560 size = build_int_cst (size_type_node, 0);
1561 break;
1563 default:
1564 /* TODO: Don't do dtype for temporary descriptorless arrays. */
1565 /* We can encounter strange array types for temporary arrays. */
1566 return gfc_index_zero_node;
1569 tmp = get_dtype_type_node ();
1570 field = gfc_advance_chain (TYPE_FIELDS (tmp),
1571 GFC_DTYPE_ELEM_LEN);
1572 CONSTRUCTOR_APPEND_ELT (v, field,
1573 fold_convert (TREE_TYPE (field), size));
1575 field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
1576 GFC_DTYPE_RANK);
1577 CONSTRUCTOR_APPEND_ELT (v, field,
1578 build_int_cst (TREE_TYPE (field), rank));
1580 field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
1581 GFC_DTYPE_TYPE);
1582 CONSTRUCTOR_APPEND_ELT (v, field,
1583 build_int_cst (TREE_TYPE (field), n));
1585 dtype = build_constructor (tmp, v);
1587 return dtype;
1591 tree
1592 gfc_get_dtype (tree type)
1594 tree dtype;
1595 tree etype;
1596 int rank;
1598 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1600 rank = GFC_TYPE_ARRAY_RANK (type);
1601 etype = gfc_get_element_type (type);
1602 dtype = gfc_get_dtype_rank_type (rank, etype);
1604 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1605 return dtype;
1609 /* Build an array type for use without a descriptor, packed according
1610 to the value of PACKED. */
1612 tree
1613 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
1614 bool restricted)
1616 tree range;
1617 tree type;
1618 tree tmp;
1619 int n;
1620 int known_stride;
1621 int known_offset;
1622 mpz_t offset;
1623 mpz_t stride;
1624 mpz_t delta;
1625 gfc_expr *expr;
1627 mpz_init_set_ui (offset, 0);
1628 mpz_init_set_ui (stride, 1);
1629 mpz_init (delta);
1631 /* We don't use build_array_type because this does not include include
1632 lang-specific information (i.e. the bounds of the array) when checking
1633 for duplicates. */
1634 if (as->rank)
1635 type = make_node (ARRAY_TYPE);
1636 else
1637 type = build_variant_type_copy (etype);
1639 GFC_ARRAY_TYPE_P (type) = 1;
1640 TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
1642 known_stride = (packed != PACKED_NO);
1643 known_offset = 1;
1644 for (n = 0; n < as->rank; n++)
1646 /* Fill in the stride and bound components of the type. */
1647 if (known_stride)
1648 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1649 else
1650 tmp = NULL_TREE;
1651 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1653 expr = as->lower[n];
1654 if (expr->expr_type == EXPR_CONSTANT)
1656 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1657 gfc_index_integer_kind);
1659 else
1661 known_stride = 0;
1662 tmp = NULL_TREE;
1664 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1666 if (known_stride)
1668 /* Calculate the offset. */
1669 mpz_mul (delta, stride, as->lower[n]->value.integer);
1670 mpz_sub (offset, offset, delta);
1672 else
1673 known_offset = 0;
1675 expr = as->upper[n];
1676 if (expr && expr->expr_type == EXPR_CONSTANT)
1678 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1679 gfc_index_integer_kind);
1681 else
1683 tmp = NULL_TREE;
1684 known_stride = 0;
1686 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1688 if (known_stride)
1690 /* Calculate the stride. */
1691 mpz_sub (delta, as->upper[n]->value.integer,
1692 as->lower[n]->value.integer);
1693 mpz_add_ui (delta, delta, 1);
1694 mpz_mul (stride, stride, delta);
1697 /* Only the first stride is known for partial packed arrays. */
1698 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1699 known_stride = 0;
1701 for (n = as->rank; n < as->rank + as->corank; n++)
1703 expr = as->lower[n];
1704 if (expr->expr_type == EXPR_CONSTANT)
1705 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1706 gfc_index_integer_kind);
1707 else
1708 tmp = NULL_TREE;
1709 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1711 expr = as->upper[n];
1712 if (expr && expr->expr_type == EXPR_CONSTANT)
1713 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1714 gfc_index_integer_kind);
1715 else
1716 tmp = NULL_TREE;
1717 if (n < as->rank + as->corank - 1)
1718 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1721 if (known_offset)
1723 GFC_TYPE_ARRAY_OFFSET (type) =
1724 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1726 else
1727 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1729 if (known_stride)
1731 GFC_TYPE_ARRAY_SIZE (type) =
1732 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1734 else
1735 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1737 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1738 GFC_TYPE_ARRAY_CORANK (type) = as->corank;
1739 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1740 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1741 NULL_TREE);
1742 /* TODO: use main type if it is unbounded. */
1743 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1744 build_pointer_type (build_array_type (etype, range));
1745 if (restricted)
1746 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1747 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
1748 TYPE_QUAL_RESTRICT);
1750 if (as->rank == 0)
1752 if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB)
1754 type = build_pointer_type (type);
1756 if (restricted)
1757 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1759 GFC_ARRAY_TYPE_P (type) = 1;
1760 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1763 return type;
1766 if (known_stride)
1768 mpz_sub_ui (stride, stride, 1);
1769 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1771 else
1772 range = NULL_TREE;
1774 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1775 TYPE_DOMAIN (type) = range;
1777 build_pointer_type (etype);
1778 TREE_TYPE (type) = etype;
1780 layout_type (type);
1782 mpz_clear (offset);
1783 mpz_clear (stride);
1784 mpz_clear (delta);
1786 /* Represent packed arrays as multi-dimensional if they have rank >
1787 1 and with proper bounds, instead of flat arrays. This makes for
1788 better debug info. */
1789 if (known_offset)
1791 tree gtype = etype, rtype, type_decl;
1793 for (n = as->rank - 1; n >= 0; n--)
1795 rtype = build_range_type (gfc_array_index_type,
1796 GFC_TYPE_ARRAY_LBOUND (type, n),
1797 GFC_TYPE_ARRAY_UBOUND (type, n));
1798 gtype = build_array_type (gtype, rtype);
1800 TYPE_NAME (type) = type_decl = build_decl (input_location,
1801 TYPE_DECL, NULL, gtype);
1802 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1805 if (packed != PACKED_STATIC || !known_stride
1806 || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
1808 /* For dummy arrays and automatic (heap allocated) arrays we
1809 want a pointer to the array. */
1810 type = build_pointer_type (type);
1811 if (restricted)
1812 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1813 GFC_ARRAY_TYPE_P (type) = 1;
1814 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1816 return type;
1820 /* Return or create the base type for an array descriptor. */
1822 static tree
1823 gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
1825 tree fat_type, decl, arraytype, *chain = NULL;
1826 char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
1827 int idx;
1829 /* Assumed-rank array. */
1830 if (dimen == -1)
1831 dimen = GFC_MAX_DIMENSIONS;
1833 idx = 2 * (codimen + dimen) + restricted;
1835 gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
1837 if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
1839 if (gfc_array_descriptor_base_caf[idx])
1840 return gfc_array_descriptor_base_caf[idx];
1842 else if (gfc_array_descriptor_base[idx])
1843 return gfc_array_descriptor_base[idx];
1845 /* Build the type node. */
1846 fat_type = make_node (RECORD_TYPE);
1848 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
1849 TYPE_NAME (fat_type) = get_identifier (name);
1850 TYPE_NAMELESS (fat_type) = 1;
1852 /* Add the data member as the first element of the descriptor. */
1853 decl = gfc_add_field_to_struct_1 (fat_type,
1854 get_identifier ("data"),
1855 (restricted
1856 ? prvoid_type_node
1857 : ptr_type_node), &chain);
1859 /* Add the base component. */
1860 decl = gfc_add_field_to_struct_1 (fat_type,
1861 get_identifier ("offset"),
1862 gfc_array_index_type, &chain);
1863 TREE_NO_WARNING (decl) = 1;
1865 /* Add the dtype component. */
1866 decl = gfc_add_field_to_struct_1 (fat_type,
1867 get_identifier ("dtype"),
1868 get_dtype_type_node (), &chain);
1869 TREE_NO_WARNING (decl) = 1;
1871 /* Add the span component. */
1872 decl = gfc_add_field_to_struct_1 (fat_type,
1873 get_identifier ("span"),
1874 gfc_array_index_type, &chain);
1875 TREE_NO_WARNING (decl) = 1;
1877 /* Build the array type for the stride and bound components. */
1878 if (dimen + codimen > 0)
1880 arraytype =
1881 build_array_type (gfc_get_desc_dim_type (),
1882 build_range_type (gfc_array_index_type,
1883 gfc_index_zero_node,
1884 gfc_rank_cst[codimen + dimen - 1]));
1886 decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
1887 arraytype, &chain);
1888 TREE_NO_WARNING (decl) = 1;
1891 if (flag_coarray == GFC_FCOARRAY_LIB)
1893 decl = gfc_add_field_to_struct_1 (fat_type,
1894 get_identifier ("token"),
1895 prvoid_type_node, &chain);
1896 TREE_NO_WARNING (decl) = 1;
1899 /* Finish off the type. */
1900 gfc_finish_type (fat_type);
1901 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1903 if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
1904 gfc_array_descriptor_base_caf[idx] = fat_type;
1905 else
1906 gfc_array_descriptor_base[idx] = fat_type;
1908 return fat_type;
1912 /* Build an array (descriptor) type with given bounds. */
1914 tree
1915 gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
1916 tree * ubound, int packed,
1917 enum gfc_array_kind akind, bool restricted)
1919 char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
1920 tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
1921 const char *type_name;
1922 int n;
1924 base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
1925 fat_type = build_distinct_type_copy (base_type);
1926 /* Make sure that nontarget and target array type have the same canonical
1927 type (and same stub decl for debug info). */
1928 base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
1929 TYPE_CANONICAL (fat_type) = base_type;
1930 TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
1932 tmp = TYPE_NAME (etype);
1933 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1934 tmp = DECL_NAME (tmp);
1935 if (tmp)
1936 type_name = IDENTIFIER_POINTER (tmp);
1937 else
1938 type_name = "unknown";
1939 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
1940 GFC_MAX_SYMBOL_LEN, type_name);
1941 TYPE_NAME (fat_type) = get_identifier (name);
1942 TYPE_NAMELESS (fat_type) = 1;
1944 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1945 TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();
1947 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1948 GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
1949 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1950 GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1952 /* Build an array descriptor record type. */
1953 if (packed != 0)
1954 stride = gfc_index_one_node;
1955 else
1956 stride = NULL_TREE;
1957 for (n = 0; n < dimen + codimen; n++)
1959 if (n < dimen)
1960 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1962 if (lbound)
1963 lower = lbound[n];
1964 else
1965 lower = NULL_TREE;
1967 if (lower != NULL_TREE)
1969 if (INTEGER_CST_P (lower))
1970 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1971 else
1972 lower = NULL_TREE;
1975 if (codimen && n == dimen + codimen - 1)
1976 break;
1978 upper = ubound[n];
1979 if (upper != NULL_TREE)
1981 if (INTEGER_CST_P (upper))
1982 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1983 else
1984 upper = NULL_TREE;
1987 if (n >= dimen)
1988 continue;
1990 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1992 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1993 gfc_array_index_type, upper, lower);
1994 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1995 gfc_array_index_type, tmp,
1996 gfc_index_one_node);
1997 stride = fold_build2_loc (input_location, MULT_EXPR,
1998 gfc_array_index_type, tmp, stride);
1999 /* Check the folding worked. */
2000 gcc_assert (INTEGER_CST_P (stride));
2002 else
2003 stride = NULL_TREE;
2005 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
2007 /* TODO: known offsets for descriptors. */
2008 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
2010 if (dimen == 0)
2012 arraytype = build_pointer_type (etype);
2013 if (restricted)
2014 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
2016 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
2017 return fat_type;
2020 /* We define data as an array with the correct size if possible.
2021 Much better than doing pointer arithmetic. */
2022 if (stride)
2023 rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
2024 int_const_binop (MINUS_EXPR, stride,
2025 build_int_cst (TREE_TYPE (stride), 1)));
2026 else
2027 rtype = gfc_array_range_type;
2028 arraytype = build_array_type (etype, rtype);
2029 arraytype = build_pointer_type (arraytype);
2030 if (restricted)
2031 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
2032 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
2034 /* This will generate the base declarations we need to emit debug
2035 information for this type. FIXME: there must be a better way to
2036 avoid divergence between compilations with and without debug
2037 information. */
2039 struct array_descr_info info;
2040 gfc_get_array_descr_info (fat_type, &info);
2041 gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
2044 return fat_type;
2047 /* Build a pointer type. This function is called from gfc_sym_type(). */
2049 static tree
2050 gfc_build_pointer_type (gfc_symbol * sym, tree type)
2052 /* Array pointer types aren't actually pointers. */
2053 if (sym->attr.dimension)
2054 return type;
2055 else
2056 return build_pointer_type (type);
2059 static tree gfc_nonrestricted_type (tree t);
2060 /* Given two record or union type nodes TO and FROM, ensure
2061 that all fields in FROM have a corresponding field in TO,
2062 their type being nonrestrict variants. This accepts a TO
2063 node that already has a prefix of the fields in FROM. */
2064 static void
2065 mirror_fields (tree to, tree from)
2067 tree fto, ffrom;
2068 tree *chain;
2070 /* Forward to the end of TOs fields. */
2071 fto = TYPE_FIELDS (to);
2072 ffrom = TYPE_FIELDS (from);
2073 chain = &TYPE_FIELDS (to);
2074 while (fto)
2076 gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
2077 chain = &DECL_CHAIN (fto);
2078 fto = DECL_CHAIN (fto);
2079 ffrom = DECL_CHAIN (ffrom);
2082 /* Now add all fields remaining in FROM (starting with ffrom). */
2083 for (; ffrom; ffrom = DECL_CHAIN (ffrom))
2085 tree newfield = copy_node (ffrom);
2086 DECL_CONTEXT (newfield) = to;
2087 /* The store to DECL_CHAIN might seem redundant with the
2088 stores to *chain, but not clearing it here would mean
2089 leaving a chain into the old fields. If ever
2090 our called functions would look at them confusion
2091 will arise. */
2092 DECL_CHAIN (newfield) = NULL_TREE;
2093 *chain = newfield;
2094 chain = &DECL_CHAIN (newfield);
2096 if (TREE_CODE (ffrom) == FIELD_DECL)
2098 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
2099 TREE_TYPE (newfield) = elemtype;
2102 *chain = NULL_TREE;
2105 /* Given a type T, returns a different type of the same structure,
2106 except that all types it refers to (recursively) are always
2107 non-restrict qualified types. */
2108 static tree
2109 gfc_nonrestricted_type (tree t)
2111 tree ret = t;
2113 /* If the type isn't laid out yet, don't copy it. If something
2114 needs it for real it should wait until the type got finished. */
2115 if (!TYPE_SIZE (t))
2116 return t;
2118 if (!TYPE_LANG_SPECIFIC (t))
2119 TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
2120 /* If we're dealing with this very node already further up
2121 the call chain (recursion via pointers and struct members)
2122 we haven't yet determined if we really need a new type node.
2123 Assume we don't, return T itself. */
2124 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
2125 return t;
2127 /* If we have calculated this all already, just return it. */
2128 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
2129 return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
2131 /* Mark this type. */
2132 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
2134 switch (TREE_CODE (t))
2136 default:
2137 break;
2139 case POINTER_TYPE:
2140 case REFERENCE_TYPE:
2142 tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
2143 if (totype == TREE_TYPE (t))
2144 ret = t;
2145 else if (TREE_CODE (t) == POINTER_TYPE)
2146 ret = build_pointer_type (totype);
2147 else
2148 ret = build_reference_type (totype);
2149 ret = build_qualified_type (ret,
2150 TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
2152 break;
2154 case ARRAY_TYPE:
2156 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
2157 if (elemtype == TREE_TYPE (t))
2158 ret = t;
2159 else
2161 ret = build_variant_type_copy (t);
2162 TREE_TYPE (ret) = elemtype;
2163 if (TYPE_LANG_SPECIFIC (t)
2164 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
2166 tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
2167 dataptr_type = gfc_nonrestricted_type (dataptr_type);
2168 if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
2170 TYPE_LANG_SPECIFIC (ret)
2171 = ggc_cleared_alloc<struct lang_type> ();
2172 *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
2173 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
2178 break;
2180 case RECORD_TYPE:
2181 case UNION_TYPE:
2182 case QUAL_UNION_TYPE:
2184 tree field;
2185 /* First determine if we need a new type at all.
2186 Careful, the two calls to gfc_nonrestricted_type per field
2187 might return different values. That happens exactly when
2188 one of the fields reaches back to this very record type
2189 (via pointers). The first calls will assume that we don't
2190 need to copy T (see the error_mark_node marking). If there
2191 are any reasons for copying T apart from having to copy T,
2192 we'll indeed copy it, and the second calls to
2193 gfc_nonrestricted_type will use that new node if they
2194 reach back to T. */
2195 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
2196 if (TREE_CODE (field) == FIELD_DECL)
2198 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
2199 if (elemtype != TREE_TYPE (field))
2200 break;
2202 if (!field)
2203 break;
2204 ret = build_variant_type_copy (t);
2205 TYPE_FIELDS (ret) = NULL_TREE;
2207 /* Here we make sure that as soon as we know we have to copy
2208 T, that also fields reaching back to us will use the new
2209 copy. It's okay if that copy still contains the old fields,
2210 we won't look at them. */
2211 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
2212 mirror_fields (ret, t);
2214 break;
2217 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
2218 return ret;
2222 /* Return the type for a symbol. Special handling is required for character
2223 types to get the correct level of indirection.
2224 For functions return the return type.
2225 For subroutines return void_type_node.
2226 Calling this multiple times for the same symbol should be avoided,
2227 especially for character and array types. */
2229 tree
2230 gfc_sym_type (gfc_symbol * sym)
2232 tree type;
2233 int byref;
2234 bool restricted;
2236 /* Procedure Pointers inside COMMON blocks. */
2237 if (sym->attr.proc_pointer && sym->attr.in_common)
2239 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2240 sym->attr.proc_pointer = 0;
2241 type = build_pointer_type (gfc_get_function_type (sym));
2242 sym->attr.proc_pointer = 1;
2243 return type;
2246 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2247 return void_type_node;
2249 /* In the case of a function the fake result variable may have a
2250 type different from the function type, so don't return early in
2251 that case. */
2252 if (sym->backend_decl && !sym->attr.function)
2253 return TREE_TYPE (sym->backend_decl);
2255 if (sym->attr.result
2256 && sym->ts.type == BT_CHARACTER
2257 && sym->ts.u.cl->backend_decl == NULL_TREE
2258 && sym->ns->proc_name
2259 && sym->ns->proc_name->ts.u.cl
2260 && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE)
2261 sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl;
2263 if (sym->ts.type == BT_CHARACTER
2264 && ((sym->attr.function && sym->attr.is_bind_c)
2265 || (sym->attr.result
2266 && sym->ns->proc_name
2267 && sym->ns->proc_name->attr.is_bind_c)
2268 || (sym->ts.deferred && (!sym->ts.u.cl
2269 || !sym->ts.u.cl->backend_decl))))
2270 type = gfc_character1_type_node;
2271 else
2272 type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
2274 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
2275 byref = 1;
2276 else
2277 byref = 0;
2279 restricted = !sym->attr.target && !sym->attr.pointer
2280 && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
2281 if (!restricted)
2282 type = gfc_nonrestricted_type (type);
2284 if (sym->attr.dimension || sym->attr.codimension)
2286 if (gfc_is_nodesc_array (sym))
2288 /* If this is a character argument of unknown length, just use the
2289 base type. */
2290 if (sym->ts.type != BT_CHARACTER
2291 || !(sym->attr.dummy || sym->attr.function)
2292 || sym->ts.u.cl->backend_decl)
2294 type = gfc_get_nodesc_array_type (type, sym->as,
2295 byref ? PACKED_FULL
2296 : PACKED_STATIC,
2297 restricted);
2298 byref = 0;
2301 else
2303 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
2304 if (sym->attr.pointer)
2305 akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2306 : GFC_ARRAY_POINTER;
2307 else if (sym->attr.allocatable)
2308 akind = GFC_ARRAY_ALLOCATABLE;
2309 type = gfc_build_array_type (type, sym->as, akind, restricted,
2310 sym->attr.contiguous, false);
2313 else
2315 if (sym->attr.allocatable || sym->attr.pointer
2316 || gfc_is_associate_pointer (sym))
2317 type = gfc_build_pointer_type (sym, type);
2320 /* We currently pass all parameters by reference.
2321 See f95_get_function_decl. For dummy function parameters return the
2322 function type. */
2323 if (byref)
2325 /* We must use pointer types for potentially absent variables. The
2326 optimizers assume a reference type argument is never NULL. */
2327 if (sym->attr.optional
2328 || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
2329 type = build_pointer_type (type);
2330 else
2332 type = build_reference_type (type);
2333 if (restricted)
2334 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
2338 return (type);
2341 /* Layout and output debug info for a record type. */
2343 void
2344 gfc_finish_type (tree type)
2346 tree decl;
2348 decl = build_decl (input_location,
2349 TYPE_DECL, NULL_TREE, type);
2350 TYPE_STUB_DECL (type) = decl;
2351 layout_type (type);
2352 rest_of_type_compilation (type, 1);
2353 rest_of_decl_compilation (decl, 1, 0);
2356 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2357 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2358 to the end of the field list pointed to by *CHAIN.
2360 Returns a pointer to the new field. */
2362 static tree
2363 gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
2365 tree decl = build_decl (input_location, FIELD_DECL, name, type);
2367 DECL_CONTEXT (decl) = context;
2368 DECL_CHAIN (decl) = NULL_TREE;
2369 if (TYPE_FIELDS (context) == NULL_TREE)
2370 TYPE_FIELDS (context) = decl;
2371 if (chain != NULL)
2373 if (*chain != NULL)
2374 **chain = decl;
2375 *chain = &DECL_CHAIN (decl);
2378 return decl;
2381 /* Like `gfc_add_field_to_struct_1', but adds alignment
2382 information. */
2384 tree
2385 gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
2387 tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
2389 DECL_INITIAL (decl) = 0;
2390 SET_DECL_ALIGN (decl, 0);
2391 DECL_USER_ALIGN (decl) = 0;
2393 return decl;
2397 /* Copy the backend_decl and component backend_decls if
2398 the two derived type symbols are "equal", as described
2399 in 4.4.2 and resolved by gfc_compare_derived_types. */
2402 gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
2403 bool from_gsym)
2405 gfc_component *to_cm;
2406 gfc_component *from_cm;
2408 if (from == to)
2409 return 1;
2411 if (from->backend_decl == NULL
2412 || !gfc_compare_derived_types (from, to))
2413 return 0;
2415 to->backend_decl = from->backend_decl;
2417 to_cm = to->components;
2418 from_cm = from->components;
2420 /* Copy the component declarations. If a component is itself
2421 a derived type, we need a copy of its component declarations.
2422 This is done by recursing into gfc_get_derived_type and
2423 ensures that the component's component declarations have
2424 been built. If it is a character, we need the character
2425 length, as well. */
2426 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
2428 to_cm->backend_decl = from_cm->backend_decl;
2429 to_cm->caf_token = from_cm->caf_token;
2430 if (from_cm->ts.type == BT_UNION)
2431 gfc_get_union_type (to_cm->ts.u.derived);
2432 else if (from_cm->ts.type == BT_DERIVED
2433 && (!from_cm->attr.pointer || from_gsym))
2434 gfc_get_derived_type (to_cm->ts.u.derived);
2435 else if (from_cm->ts.type == BT_CLASS
2436 && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
2437 gfc_get_derived_type (to_cm->ts.u.derived);
2438 else if (from_cm->ts.type == BT_CHARACTER)
2439 to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
2442 return 1;
2446 /* Build a tree node for a procedure pointer component. */
2448 tree
2449 gfc_get_ppc_type (gfc_component* c)
2451 tree t;
2453 /* Explicit interface. */
2454 if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
2455 return build_pointer_type (gfc_get_function_type (c->ts.interface));
2457 /* Implicit interface (only return value may be known). */
2458 if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
2459 t = gfc_typenode_for_spec (&c->ts);
2460 else
2461 t = void_type_node;
2463 return build_pointer_type (build_function_type_list (t, NULL_TREE));
2467 /* Build a tree node for a union type. Requires building each map
2468 structure which is an element of the union. */
2470 tree
2471 gfc_get_union_type (gfc_symbol *un)
2473 gfc_component *map = NULL;
2474 tree typenode = NULL, map_type = NULL, map_field = NULL;
2475 tree *chain = NULL;
2477 if (un->backend_decl)
2479 if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp)
2480 return un->backend_decl;
2481 else
2482 typenode = un->backend_decl;
2484 else
2486 typenode = make_node (UNION_TYPE);
2487 TYPE_NAME (typenode) = get_identifier (un->name);
2490 /* Add each contained MAP as a field. */
2491 for (map = un->components; map; map = map->next)
2493 gcc_assert (map->ts.type == BT_DERIVED);
2495 /* The map's type node, which is defined within this union's context. */
2496 map_type = gfc_get_derived_type (map->ts.u.derived);
2497 TYPE_CONTEXT (map_type) = typenode;
2499 /* The map field's declaration. */
2500 map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name),
2501 map_type, &chain);
2502 if (map->loc.lb)
2503 gfc_set_decl_location (map_field, &map->loc);
2504 else if (un->declared_at.lb)
2505 gfc_set_decl_location (map_field, &un->declared_at);
2507 DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
2508 DECL_NAMELESS(map_field) = true;
2510 /* We should never clobber another backend declaration for this map,
2511 because each map component is unique. */
2512 if (!map->backend_decl)
2513 map->backend_decl = map_field;
2516 un->backend_decl = typenode;
2517 gfc_finish_type (typenode);
2519 return typenode;
2523 /* Build a tree node for a derived type. If there are equal
2524 derived types, with different local names, these are built
2525 at the same time. If an equal derived type has been built
2526 in a parent namespace, this is used. */
2528 tree
2529 gfc_get_derived_type (gfc_symbol * derived, int codimen)
2531 tree typenode = NULL, field = NULL, field_type = NULL;
2532 tree canonical = NULL_TREE;
2533 tree *chain = NULL;
2534 bool got_canonical = false;
2535 bool unlimited_entity = false;
2536 gfc_component *c;
2537 gfc_dt_list *dt;
2538 gfc_namespace *ns;
2539 tree tmp;
2540 bool coarray_flag;
2542 coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
2543 && derived->module && !derived->attr.vtype;
2545 gcc_assert (!derived->attr.pdt_template);
2547 if (derived->attr.unlimited_polymorphic
2548 || (flag_coarray == GFC_FCOARRAY_LIB
2549 && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2550 && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
2551 || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
2552 || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
2553 return ptr_type_node;
2555 if (flag_coarray != GFC_FCOARRAY_LIB
2556 && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2557 && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
2558 || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
2559 return gfc_get_int_type (gfc_default_integer_kind);
2561 if (derived && derived->attr.flavor == FL_PROCEDURE
2562 && derived->attr.generic)
2563 derived = gfc_find_dt_in_generic (derived);
2565 /* See if it's one of the iso_c_binding derived types. */
2566 if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
2568 if (derived->backend_decl)
2569 return derived->backend_decl;
2571 if (derived->intmod_sym_id == ISOCBINDING_PTR)
2572 derived->backend_decl = ptr_type_node;
2573 else
2574 derived->backend_decl = pfunc_type_node;
2576 derived->ts.kind = gfc_index_integer_kind;
2577 derived->ts.type = BT_INTEGER;
2578 /* Set the f90_type to BT_VOID as a way to recognize something of type
2579 BT_INTEGER that needs to fit a void * for the purpose of the
2580 iso_c_binding derived types. */
2581 derived->ts.f90_type = BT_VOID;
2583 return derived->backend_decl;
2586 /* If use associated, use the module type for this one. */
2587 if (derived->backend_decl == NULL
2588 && derived->attr.use_assoc
2589 && derived->module
2590 && gfc_get_module_backend_decl (derived))
2591 goto copy_derived_types;
2593 /* The derived types from an earlier namespace can be used as the
2594 canonical type. */
2595 if (derived->backend_decl == NULL && !derived->attr.use_assoc
2596 && gfc_global_ns_list)
2598 for (ns = gfc_global_ns_list;
2599 ns->translated && !got_canonical;
2600 ns = ns->sibling)
2602 dt = ns->derived_types;
2603 for (; dt && !canonical; dt = dt->next)
2605 gfc_copy_dt_decls_ifequal (dt->derived, derived, true);
2606 if (derived->backend_decl)
2607 got_canonical = true;
2612 /* Store up the canonical type to be added to this one. */
2613 if (got_canonical)
2615 if (TYPE_CANONICAL (derived->backend_decl))
2616 canonical = TYPE_CANONICAL (derived->backend_decl);
2617 else
2618 canonical = derived->backend_decl;
2620 derived->backend_decl = NULL_TREE;
2623 /* derived->backend_decl != 0 means we saw it before, but its
2624 components' backend_decl may have not been built. */
2625 if (derived->backend_decl)
2627 /* Its components' backend_decl have been built or we are
2628 seeing recursion through the formal arglist of a procedure
2629 pointer component. */
2630 if (TYPE_FIELDS (derived->backend_decl))
2631 return derived->backend_decl;
2632 else if (derived->attr.abstract
2633 && derived->attr.proc_pointer_comp)
2635 /* If an abstract derived type with procedure pointer
2636 components has no other type of component, return the
2637 backend_decl. Otherwise build the components if any of the
2638 non-procedure pointer components have no backend_decl. */
2639 for (c = derived->components; c; c = c->next)
2641 bool same_alloc_type = c->attr.allocatable
2642 && derived == c->ts.u.derived;
2643 if (!c->attr.proc_pointer
2644 && !same_alloc_type
2645 && c->backend_decl == NULL)
2646 break;
2647 else if (c->next == NULL)
2648 return derived->backend_decl;
2650 typenode = derived->backend_decl;
2652 else
2653 typenode = derived->backend_decl;
2655 else
2657 /* We see this derived type first time, so build the type node. */
2658 typenode = make_node (RECORD_TYPE);
2659 TYPE_NAME (typenode) = get_identifier (derived->name);
2660 TYPE_PACKED (typenode) = flag_pack_derived;
2661 derived->backend_decl = typenode;
2664 if (derived->components
2665 && derived->components->ts.type == BT_DERIVED
2666 && strcmp (derived->components->name, "_data") == 0
2667 && derived->components->ts.u.derived->attr.unlimited_polymorphic)
2668 unlimited_entity = true;
2670 /* Go through the derived type components, building them as
2671 necessary. The reason for doing this now is that it is
2672 possible to recurse back to this derived type through a
2673 pointer component (PR24092). If this happens, the fields
2674 will be built and so we can return the type. */
2675 for (c = derived->components; c; c = c->next)
2677 bool same_alloc_type = c->attr.allocatable
2678 && derived == c->ts.u.derived;
2680 if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
2681 c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived);
2683 if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
2684 continue;
2686 if ((!c->attr.pointer && !c->attr.proc_pointer
2687 && !same_alloc_type)
2688 || c->ts.u.derived->backend_decl == NULL)
2690 int local_codim = c->attr.codimension ? c->as->corank: codimen;
2691 c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
2692 local_codim);
2695 if (c->ts.u.derived->attr.is_iso_c)
2697 /* Need to copy the modified ts from the derived type. The
2698 typespec was modified because C_PTR/C_FUNPTR are translated
2699 into (void *) from derived types. */
2700 c->ts.type = c->ts.u.derived->ts.type;
2701 c->ts.kind = c->ts.u.derived->ts.kind;
2702 c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2703 if (c->initializer)
2705 c->initializer->ts.type = c->ts.type;
2706 c->initializer->ts.kind = c->ts.kind;
2707 c->initializer->ts.f90_type = c->ts.f90_type;
2708 c->initializer->expr_type = EXPR_NULL;
2713 if (TYPE_FIELDS (derived->backend_decl))
2714 return derived->backend_decl;
2716 /* Build the type member list. Install the newly created RECORD_TYPE
2717 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2718 through only the top-level linked list of components so we correctly
2719 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2720 types are built as part of gfc_get_union_type. */
2721 for (c = derived->components; c; c = c->next)
2723 bool same_alloc_type = c->attr.allocatable
2724 && derived == c->ts.u.derived;
2725 /* Prevent infinite recursion, when the procedure pointer type is
2726 the same as derived, by forcing the procedure pointer component to
2727 be built as if the explicit interface does not exist. */
2728 if (c->attr.proc_pointer
2729 && (c->ts.type != BT_DERIVED || (c->ts.u.derived
2730 && !gfc_compare_derived_types (derived, c->ts.u.derived)))
2731 && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
2732 && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
2733 field_type = gfc_get_ppc_type (c);
2734 else if (c->attr.proc_pointer && derived->backend_decl)
2736 tmp = build_function_type_list (derived->backend_decl, NULL_TREE);
2737 field_type = build_pointer_type (tmp);
2739 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2740 field_type = c->ts.u.derived->backend_decl;
2741 else if (c->attr.caf_token)
2742 field_type = pvoid_type_node;
2743 else
2745 if (c->ts.type == BT_CHARACTER
2746 && !c->ts.deferred && !c->attr.pdt_string)
2748 /* Evaluate the string length. */
2749 gfc_conv_const_charlen (c->ts.u.cl);
2750 gcc_assert (c->ts.u.cl->backend_decl);
2752 else if (c->ts.type == BT_CHARACTER)
2753 c->ts.u.cl->backend_decl
2754 = build_int_cst (gfc_charlen_type_node, 0);
2756 field_type = gfc_typenode_for_spec (&c->ts, codimen);
2759 /* This returns an array descriptor type. Initialization may be
2760 required. */
2761 if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
2763 if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
2765 enum gfc_array_kind akind;
2766 if (c->attr.pointer)
2767 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2768 : GFC_ARRAY_POINTER;
2769 else
2770 akind = GFC_ARRAY_ALLOCATABLE;
2771 /* Pointers to arrays aren't actually pointer types. The
2772 descriptors are separate, but the data is common. */
2773 field_type = gfc_build_array_type (field_type, c->as, akind,
2774 !c->attr.target
2775 && !c->attr.pointer,
2776 c->attr.contiguous,
2777 codimen);
2779 else
2780 field_type = gfc_get_nodesc_array_type (field_type, c->as,
2781 PACKED_STATIC,
2782 !c->attr.target);
2784 else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
2785 && !c->attr.proc_pointer
2786 && !(unlimited_entity && c == derived->components))
2787 field_type = build_pointer_type (field_type);
2789 if (c->attr.pointer || same_alloc_type)
2790 field_type = gfc_nonrestricted_type (field_type);
2792 /* vtype fields can point to different types to the base type. */
2793 if (c->ts.type == BT_DERIVED
2794 && c->ts.u.derived && c->ts.u.derived->attr.vtype)
2795 field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
2796 ptr_mode, true);
2798 /* Ensure that the CLASS language specific flag is set. */
2799 if (c->ts.type == BT_CLASS)
2801 if (POINTER_TYPE_P (field_type))
2802 GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
2803 else
2804 GFC_CLASS_TYPE_P (field_type) = 1;
2807 field = gfc_add_field_to_struct (typenode,
2808 get_identifier (c->name),
2809 field_type, &chain);
2810 if (c->loc.lb)
2811 gfc_set_decl_location (field, &c->loc);
2812 else if (derived->declared_at.lb)
2813 gfc_set_decl_location (field, &derived->declared_at);
2815 gfc_finish_decl_attrs (field, &c->attr);
2817 DECL_PACKED (field) |= TYPE_PACKED (typenode);
2819 gcc_assert (field);
2820 if (!c->backend_decl)
2821 c->backend_decl = field;
2823 if (c->attr.pointer && c->attr.dimension
2824 && !(c->ts.type == BT_DERIVED
2825 && strcmp (c->name, "_data") == 0))
2826 GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
2829 /* Now lay out the derived type, including the fields. */
2830 if (canonical)
2831 TYPE_CANONICAL (typenode) = canonical;
2833 gfc_finish_type (typenode);
2834 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2835 if (derived->module && derived->ns->proc_name
2836 && derived->ns->proc_name->attr.flavor == FL_MODULE)
2838 if (derived->ns->proc_name->backend_decl
2839 && TREE_CODE (derived->ns->proc_name->backend_decl)
2840 == NAMESPACE_DECL)
2842 TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2843 DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2844 = derived->ns->proc_name->backend_decl;
2848 derived->backend_decl = typenode;
2850 copy_derived_types:
2852 for (c = derived->components; c; c = c->next)
2854 /* Do not add a caf_token field for class container components. */
2855 if ((codimen || coarray_flag)
2856 && !c->attr.dimension && !c->attr.codimension
2857 && (c->attr.allocatable || c->attr.pointer)
2858 && !derived->attr.is_class)
2860 char caf_name[GFC_MAX_SYMBOL_LEN];
2861 gfc_component *token;
2862 snprintf (caf_name, GFC_MAX_SYMBOL_LEN, "_caf_%s", c->name);
2863 token = gfc_find_component (derived, caf_name, true, true, NULL);
2864 gcc_assert (token);
2865 c->caf_token = token->backend_decl;
2866 TREE_NO_WARNING (c->caf_token) = 1;
2870 for (dt = gfc_derived_types; dt; dt = dt->next)
2871 gfc_copy_dt_decls_ifequal (derived, dt->derived, false);
2873 return derived->backend_decl;
2878 gfc_return_by_reference (gfc_symbol * sym)
2880 if (!sym->attr.function)
2881 return 0;
2883 if (sym->attr.dimension)
2884 return 1;
2886 if (sym->ts.type == BT_CHARACTER
2887 && !sym->attr.is_bind_c
2888 && (!sym->attr.result
2889 || !sym->ns->proc_name
2890 || !sym->ns->proc_name->attr.is_bind_c))
2891 return 1;
2893 /* Possibly return complex numbers by reference for g77 compatibility.
2894 We don't do this for calls to intrinsics (as the library uses the
2895 -fno-f2c calling convention), nor for calls to functions which always
2896 require an explicit interface, as no compatibility problems can
2897 arise there. */
2898 if (flag_f2c && sym->ts.type == BT_COMPLEX
2899 && !sym->attr.intrinsic && !sym->attr.always_explicit)
2900 return 1;
2902 return 0;
2905 static tree
2906 gfc_get_mixed_entry_union (gfc_namespace *ns)
2908 tree type;
2909 tree *chain = NULL;
2910 char name[GFC_MAX_SYMBOL_LEN + 1];
2911 gfc_entry_list *el, *el2;
2913 gcc_assert (ns->proc_name->attr.mixed_entry_master);
2914 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2916 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
2918 /* Build the type node. */
2919 type = make_node (UNION_TYPE);
2921 TYPE_NAME (type) = get_identifier (name);
2923 for (el = ns->entries; el; el = el->next)
2925 /* Search for duplicates. */
2926 for (el2 = ns->entries; el2 != el; el2 = el2->next)
2927 if (el2->sym->result == el->sym->result)
2928 break;
2930 if (el == el2)
2931 gfc_add_field_to_struct_1 (type,
2932 get_identifier (el->sym->result->name),
2933 gfc_sym_type (el->sym->result), &chain);
2936 /* Finish off the type. */
2937 gfc_finish_type (type);
2938 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
2939 return type;
2942 /* Create a "fn spec" based on the formal arguments;
2943 cf. create_function_arglist. */
2945 static tree
2946 create_fn_spec (gfc_symbol *sym, tree fntype)
2948 char spec[150];
2949 size_t spec_len;
2950 gfc_formal_arglist *f;
2951 tree tmp;
2953 memset (&spec, 0, sizeof (spec));
2954 spec[0] = '.';
2955 spec_len = 1;
2957 if (sym->attr.entry_master)
2958 spec[spec_len++] = 'R';
2959 if (gfc_return_by_reference (sym))
2961 gfc_symbol *result = sym->result ? sym->result : sym;
2963 if (result->attr.pointer || sym->attr.proc_pointer)
2964 spec[spec_len++] = '.';
2965 else
2966 spec[spec_len++] = 'w';
2967 if (sym->ts.type == BT_CHARACTER)
2968 spec[spec_len++] = 'R';
2971 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2972 if (spec_len < sizeof (spec))
2974 if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
2975 || f->sym->attr.external || f->sym->attr.cray_pointer
2976 || (f->sym->ts.type == BT_DERIVED
2977 && (f->sym->ts.u.derived->attr.proc_pointer_comp
2978 || f->sym->ts.u.derived->attr.pointer_comp))
2979 || (f->sym->ts.type == BT_CLASS
2980 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
2981 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)))
2982 spec[spec_len++] = '.';
2983 else if (f->sym->attr.intent == INTENT_IN)
2984 spec[spec_len++] = 'r';
2985 else if (f->sym)
2986 spec[spec_len++] = 'w';
2989 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
2990 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
2991 return build_type_attribute_variant (fntype, tmp);
2995 tree
2996 gfc_get_function_type (gfc_symbol * sym)
2998 tree type;
2999 vec<tree, va_gc> *typelist = NULL;
3000 gfc_formal_arglist *f;
3001 gfc_symbol *arg;
3002 int alternate_return = 0;
3003 bool is_varargs = true;
3005 /* Make sure this symbol is a function, a subroutine or the main
3006 program. */
3007 gcc_assert (sym->attr.flavor == FL_PROCEDURE
3008 || sym->attr.flavor == FL_PROGRAM);
3010 /* To avoid recursing infinitely on recursive types, we use error_mark_node
3011 so that they can be detected here and handled further down. */
3012 if (sym->backend_decl == NULL)
3013 sym->backend_decl = error_mark_node;
3014 else if (sym->backend_decl == error_mark_node)
3015 goto arg_type_list_done;
3016 else if (sym->attr.proc_pointer)
3017 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
3018 else
3019 return TREE_TYPE (sym->backend_decl);
3021 if (sym->attr.entry_master)
3022 /* Additional parameter for selecting an entry point. */
3023 vec_safe_push (typelist, gfc_array_index_type);
3025 if (sym->result)
3026 arg = sym->result;
3027 else
3028 arg = sym;
3030 if (arg->ts.type == BT_CHARACTER)
3031 gfc_conv_const_charlen (arg->ts.u.cl);
3033 /* Some functions we use an extra parameter for the return value. */
3034 if (gfc_return_by_reference (sym))
3036 type = gfc_sym_type (arg);
3037 if (arg->ts.type == BT_COMPLEX
3038 || arg->attr.dimension
3039 || arg->ts.type == BT_CHARACTER)
3040 type = build_reference_type (type);
3042 vec_safe_push (typelist, type);
3043 if (arg->ts.type == BT_CHARACTER)
3045 if (!arg->ts.deferred)
3046 /* Transfer by value. */
3047 vec_safe_push (typelist, gfc_charlen_type_node);
3048 else
3049 /* Deferred character lengths are transferred by reference
3050 so that the value can be returned. */
3051 vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
3055 /* Build the argument types for the function. */
3056 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
3058 arg = f->sym;
3059 if (arg)
3061 /* Evaluate constant character lengths here so that they can be
3062 included in the type. */
3063 if (arg->ts.type == BT_CHARACTER)
3064 gfc_conv_const_charlen (arg->ts.u.cl);
3066 if (arg->attr.flavor == FL_PROCEDURE)
3068 type = gfc_get_function_type (arg);
3069 type = build_pointer_type (type);
3071 else
3072 type = gfc_sym_type (arg);
3074 /* Parameter Passing Convention
3076 We currently pass all parameters by reference.
3077 Parameters with INTENT(IN) could be passed by value.
3078 The problem arises if a function is called via an implicit
3079 prototype. In this situation the INTENT is not known.
3080 For this reason all parameters to global functions must be
3081 passed by reference. Passing by value would potentially
3082 generate bad code. Worse there would be no way of telling that
3083 this code was bad, except that it would give incorrect results.
3085 Contained procedures could pass by value as these are never
3086 used without an explicit interface, and cannot be passed as
3087 actual parameters for a dummy procedure. */
3089 vec_safe_push (typelist, type);
3091 else
3093 if (sym->attr.subroutine)
3094 alternate_return = 1;
3098 /* Add hidden string length parameters. */
3099 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
3101 arg = f->sym;
3102 if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
3104 if (!arg->ts.deferred)
3105 /* Transfer by value. */
3106 type = gfc_charlen_type_node;
3107 else
3108 /* Deferred character lengths are transferred by reference
3109 so that the value can be returned. */
3110 type = build_pointer_type (gfc_charlen_type_node);
3112 vec_safe_push (typelist, type);
3116 if (!vec_safe_is_empty (typelist)
3117 || sym->attr.is_main_program
3118 || sym->attr.if_source != IFSRC_UNKNOWN)
3119 is_varargs = false;
3121 if (sym->backend_decl == error_mark_node)
3122 sym->backend_decl = NULL_TREE;
3124 arg_type_list_done:
3126 if (alternate_return)
3127 type = integer_type_node;
3128 else if (!sym->attr.function || gfc_return_by_reference (sym))
3129 type = void_type_node;
3130 else if (sym->attr.mixed_entry_master)
3131 type = gfc_get_mixed_entry_union (sym->ns);
3132 else if (flag_f2c && sym->ts.type == BT_REAL
3133 && sym->ts.kind == gfc_default_real_kind
3134 && !sym->attr.always_explicit)
3136 /* Special case: f2c calling conventions require that (scalar)
3137 default REAL functions return the C type double instead. f2c
3138 compatibility is only an issue with functions that don't
3139 require an explicit interface, as only these could be
3140 implemented in Fortran 77. */
3141 sym->ts.kind = gfc_default_double_kind;
3142 type = gfc_typenode_for_spec (&sym->ts);
3143 sym->ts.kind = gfc_default_real_kind;
3145 else if (sym->result && sym->result->attr.proc_pointer)
3146 /* Procedure pointer return values. */
3148 if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
3150 /* Unset proc_pointer as gfc_get_function_type
3151 is called recursively. */
3152 sym->result->attr.proc_pointer = 0;
3153 type = build_pointer_type (gfc_get_function_type (sym->result));
3154 sym->result->attr.proc_pointer = 1;
3156 else
3157 type = gfc_sym_type (sym->result);
3159 else
3160 type = gfc_sym_type (sym);
3162 if (is_varargs)
3163 type = build_varargs_function_type_vec (type, typelist);
3164 else
3165 type = build_function_type_vec (type, typelist);
3166 type = create_fn_spec (sym, type);
3168 return type;
3171 /* Language hooks for middle-end access to type nodes. */
3173 /* Return an integer type with BITS bits of precision,
3174 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3176 tree
3177 gfc_type_for_size (unsigned bits, int unsignedp)
3179 if (!unsignedp)
3181 int i;
3182 for (i = 0; i <= MAX_INT_KINDS; ++i)
3184 tree type = gfc_integer_types[i];
3185 if (type && bits == TYPE_PRECISION (type))
3186 return type;
3189 /* Handle TImode as a special case because it is used by some backends
3190 (e.g. ARM) even though it is not available for normal use. */
3191 #if HOST_BITS_PER_WIDE_INT >= 64
3192 if (bits == TYPE_PRECISION (intTI_type_node))
3193 return intTI_type_node;
3194 #endif
3196 if (bits <= TYPE_PRECISION (intQI_type_node))
3197 return intQI_type_node;
3198 if (bits <= TYPE_PRECISION (intHI_type_node))
3199 return intHI_type_node;
3200 if (bits <= TYPE_PRECISION (intSI_type_node))
3201 return intSI_type_node;
3202 if (bits <= TYPE_PRECISION (intDI_type_node))
3203 return intDI_type_node;
3204 if (bits <= TYPE_PRECISION (intTI_type_node))
3205 return intTI_type_node;
3207 else
3209 if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
3210 return unsigned_intQI_type_node;
3211 if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
3212 return unsigned_intHI_type_node;
3213 if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
3214 return unsigned_intSI_type_node;
3215 if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
3216 return unsigned_intDI_type_node;
3217 if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
3218 return unsigned_intTI_type_node;
3221 return NULL_TREE;
3224 /* Return a data type that has machine mode MODE. If the mode is an
3225 integer, then UNSIGNEDP selects between signed and unsigned types. */
3227 tree
3228 gfc_type_for_mode (machine_mode mode, int unsignedp)
3230 int i;
3231 tree *base;
3232 scalar_int_mode int_mode;
3234 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
3235 base = gfc_real_types;
3236 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
3237 base = gfc_complex_types;
3238 else if (is_a <scalar_int_mode> (mode, &int_mode))
3240 tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp);
3241 return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
3243 else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL
3244 && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
3246 unsigned int elem_bits = vector_element_size (GET_MODE_BITSIZE (mode),
3247 GET_MODE_NUNITS (mode));
3248 tree bool_type = build_nonstandard_boolean_type (elem_bits);
3249 return build_vector_type_for_mode (bool_type, mode);
3251 else if (VECTOR_MODE_P (mode)
3252 && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
3254 machine_mode inner_mode = GET_MODE_INNER (mode);
3255 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
3256 if (inner_type != NULL_TREE)
3257 return build_vector_type_for_mode (inner_type, mode);
3258 return NULL_TREE;
3260 else
3261 return NULL_TREE;
3263 for (i = 0; i <= MAX_REAL_KINDS; ++i)
3265 tree type = base[i];
3266 if (type && mode == TYPE_MODE (type))
3267 return type;
3270 return NULL_TREE;
3273 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3274 in that case. */
3276 bool
3277 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
3279 int rank, dim;
3280 bool indirect = false;
3281 tree etype, ptype, t, base_decl;
3282 tree data_off, dim_off, dtype_off, dim_size, elem_size;
3283 tree lower_suboff, upper_suboff, stride_suboff;
3284 tree dtype, field, rank_off;
3286 if (! GFC_DESCRIPTOR_TYPE_P (type))
3288 if (! POINTER_TYPE_P (type))
3289 return false;
3290 type = TREE_TYPE (type);
3291 if (! GFC_DESCRIPTOR_TYPE_P (type))
3292 return false;
3293 indirect = true;
3296 rank = GFC_TYPE_ARRAY_RANK (type);
3297 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
3298 return false;
3300 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3301 gcc_assert (POINTER_TYPE_P (etype));
3302 etype = TREE_TYPE (etype);
3304 /* If the type is not a scalar coarray. */
3305 if (TREE_CODE (etype) == ARRAY_TYPE)
3306 etype = TREE_TYPE (etype);
3308 /* Can't handle variable sized elements yet. */
3309 if (int_size_in_bytes (etype) <= 0)
3310 return false;
3311 /* Nor non-constant lower bounds in assumed shape arrays. */
3312 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
3313 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3315 for (dim = 0; dim < rank; dim++)
3316 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
3317 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
3318 return false;
3321 memset (info, '\0', sizeof (*info));
3322 info->ndimensions = rank;
3323 info->ordering = array_descr_ordering_column_major;
3324 info->element_type = etype;
3325 ptype = build_pointer_type (gfc_array_index_type);
3326 base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
3327 if (!base_decl)
3329 base_decl = make_node (DEBUG_EXPR_DECL);
3330 DECL_ARTIFICIAL (base_decl) = 1;
3331 TREE_TYPE (base_decl) = indirect ? build_pointer_type (ptype) : ptype;
3332 SET_DECL_MODE (base_decl, TYPE_MODE (TREE_TYPE (base_decl)));
3333 GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
3335 info->base_decl = base_decl;
3336 if (indirect)
3337 base_decl = build1 (INDIRECT_REF, ptype, base_decl);
3339 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
3341 gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &dim_off,
3342 &dim_size, &stride_suboff,
3343 &lower_suboff, &upper_suboff);
3345 t = base_decl;
3346 if (!integer_zerop (data_off))
3347 t = fold_build_pointer_plus (t, data_off);
3348 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
3349 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
3350 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
3351 info->allocated = build2 (NE_EXPR, logical_type_node,
3352 info->data_location, null_pointer_node);
3353 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
3354 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
3355 info->associated = build2 (NE_EXPR, logical_type_node,
3356 info->data_location, null_pointer_node);
3357 if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
3358 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
3359 && dwarf_version >= 5)
3361 rank = 1;
3362 info->ndimensions = 1;
3363 t = base_decl;
3364 if (!integer_zerop (dtype_off))
3365 t = fold_build_pointer_plus (t, dtype_off);
3366 dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
3367 field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
3368 rank_off = byte_position (field);
3369 if (!integer_zerop (dtype_off))
3370 t = fold_build_pointer_plus (t, rank_off);
3372 t = build1 (NOP_EXPR, build_pointer_type (gfc_array_index_type), t);
3373 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3374 info->rank = t;
3375 t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
3376 t = size_binop (MULT_EXPR, t, dim_size);
3377 dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
3380 for (dim = 0; dim < rank; dim++)
3382 t = fold_build_pointer_plus (base_decl,
3383 size_binop (PLUS_EXPR,
3384 dim_off, lower_suboff));
3385 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3386 info->dimen[dim].lower_bound = t;
3387 t = fold_build_pointer_plus (base_decl,
3388 size_binop (PLUS_EXPR,
3389 dim_off, upper_suboff));
3390 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3391 info->dimen[dim].upper_bound = t;
3392 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
3393 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3395 /* Assumed shape arrays have known lower bounds. */
3396 info->dimen[dim].upper_bound
3397 = build2 (MINUS_EXPR, gfc_array_index_type,
3398 info->dimen[dim].upper_bound,
3399 info->dimen[dim].lower_bound);
3400 info->dimen[dim].lower_bound
3401 = fold_convert (gfc_array_index_type,
3402 GFC_TYPE_ARRAY_LBOUND (type, dim));
3403 info->dimen[dim].upper_bound
3404 = build2 (PLUS_EXPR, gfc_array_index_type,
3405 info->dimen[dim].lower_bound,
3406 info->dimen[dim].upper_bound);
3408 t = fold_build_pointer_plus (base_decl,
3409 size_binop (PLUS_EXPR,
3410 dim_off, stride_suboff));
3411 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3412 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
3413 info->dimen[dim].stride = t;
3414 if (dim + 1 < rank)
3415 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
3418 return true;
3422 /* Create a type to handle vector subscripts for coarray library calls. It
3423 has the form:
3424 struct caf_vector_t {
3425 size_t nvec; // size of the vector
3426 union {
3427 struct {
3428 void *vector;
3429 int kind;
3430 } v;
3431 struct {
3432 ptrdiff_t lower_bound;
3433 ptrdiff_t upper_bound;
3434 ptrdiff_t stride;
3435 } triplet;
3436 } u;
3438 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3439 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3441 tree
3442 gfc_get_caf_vector_type (int dim)
3444 static tree vector_types[GFC_MAX_DIMENSIONS];
3445 static tree vec_type = NULL_TREE;
3446 tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
3448 if (vector_types[dim-1] != NULL_TREE)
3449 return vector_types[dim-1];
3451 if (vec_type == NULL_TREE)
3453 chain = 0;
3454 vect_struct_type = make_node (RECORD_TYPE);
3455 tmp = gfc_add_field_to_struct_1 (vect_struct_type,
3456 get_identifier ("vector"),
3457 pvoid_type_node, &chain);
3458 TREE_NO_WARNING (tmp) = 1;
3459 tmp = gfc_add_field_to_struct_1 (vect_struct_type,
3460 get_identifier ("kind"),
3461 integer_type_node, &chain);
3462 TREE_NO_WARNING (tmp) = 1;
3463 gfc_finish_type (vect_struct_type);
3465 chain = 0;
3466 triplet_struct_type = make_node (RECORD_TYPE);
3467 tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
3468 get_identifier ("lower_bound"),
3469 gfc_array_index_type, &chain);
3470 TREE_NO_WARNING (tmp) = 1;
3471 tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
3472 get_identifier ("upper_bound"),
3473 gfc_array_index_type, &chain);
3474 TREE_NO_WARNING (tmp) = 1;
3475 tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
3476 gfc_array_index_type, &chain);
3477 TREE_NO_WARNING (tmp) = 1;
3478 gfc_finish_type (triplet_struct_type);
3480 chain = 0;
3481 union_type = make_node (UNION_TYPE);
3482 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
3483 vect_struct_type, &chain);
3484 TREE_NO_WARNING (tmp) = 1;
3485 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
3486 triplet_struct_type, &chain);
3487 TREE_NO_WARNING (tmp) = 1;
3488 gfc_finish_type (union_type);
3490 chain = 0;
3491 vec_type = make_node (RECORD_TYPE);
3492 tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
3493 size_type_node, &chain);
3494 TREE_NO_WARNING (tmp) = 1;
3495 tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
3496 union_type, &chain);
3497 TREE_NO_WARNING (tmp) = 1;
3498 gfc_finish_type (vec_type);
3499 TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
3502 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
3503 gfc_rank_cst[dim-1]);
3504 vector_types[dim-1] = build_array_type (vec_type, tmp);
3505 return vector_types[dim-1];
3509 tree
3510 gfc_get_caf_reference_type ()
3512 static tree reference_type = NULL_TREE;
3513 tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
3514 a_struct_type, u_union_type, tmp, *chain;
3516 if (reference_type != NULL_TREE)
3517 return reference_type;
3519 chain = 0;
3520 c_struct_type = make_node (RECORD_TYPE);
3521 tmp = gfc_add_field_to_struct_1 (c_struct_type,
3522 get_identifier ("offset"),
3523 gfc_array_index_type, &chain);
3524 TREE_NO_WARNING (tmp) = 1;
3525 tmp = gfc_add_field_to_struct_1 (c_struct_type,
3526 get_identifier ("caf_token_offset"),
3527 gfc_array_index_type, &chain);
3528 TREE_NO_WARNING (tmp) = 1;
3529 gfc_finish_type (c_struct_type);
3531 chain = 0;
3532 s_struct_type = make_node (RECORD_TYPE);
3533 tmp = gfc_add_field_to_struct_1 (s_struct_type,
3534 get_identifier ("start"),
3535 gfc_array_index_type, &chain);
3536 TREE_NO_WARNING (tmp) = 1;
3537 tmp = gfc_add_field_to_struct_1 (s_struct_type,
3538 get_identifier ("end"),
3539 gfc_array_index_type, &chain);
3540 TREE_NO_WARNING (tmp) = 1;
3541 tmp = gfc_add_field_to_struct_1 (s_struct_type,
3542 get_identifier ("stride"),
3543 gfc_array_index_type, &chain);
3544 TREE_NO_WARNING (tmp) = 1;
3545 gfc_finish_type (s_struct_type);
3547 chain = 0;
3548 v_struct_type = make_node (RECORD_TYPE);
3549 tmp = gfc_add_field_to_struct_1 (v_struct_type,
3550 get_identifier ("vector"),
3551 pvoid_type_node, &chain);
3552 TREE_NO_WARNING (tmp) = 1;
3553 tmp = gfc_add_field_to_struct_1 (v_struct_type,
3554 get_identifier ("nvec"),
3555 size_type_node, &chain);
3556 TREE_NO_WARNING (tmp) = 1;
3557 tmp = gfc_add_field_to_struct_1 (v_struct_type,
3558 get_identifier ("kind"),
3559 integer_type_node, &chain);
3560 TREE_NO_WARNING (tmp) = 1;
3561 gfc_finish_type (v_struct_type);
3563 chain = 0;
3564 union_type = make_node (UNION_TYPE);
3565 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"),
3566 s_struct_type, &chain);
3567 TREE_NO_WARNING (tmp) = 1;
3568 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
3569 v_struct_type, &chain);
3570 TREE_NO_WARNING (tmp) = 1;
3571 gfc_finish_type (union_type);
3573 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
3574 gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
3575 dim_union_type = build_array_type (union_type, tmp);
3577 chain = 0;
3578 a_struct_type = make_node (RECORD_TYPE);
3579 tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"),
3580 build_array_type (unsigned_char_type_node,
3581 build_range_type (gfc_array_index_type,
3582 gfc_index_zero_node,
3583 gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
3584 &chain);
3585 TREE_NO_WARNING (tmp) = 1;
3586 tmp = gfc_add_field_to_struct_1 (a_struct_type,
3587 get_identifier ("static_array_type"),
3588 integer_type_node, &chain);
3589 TREE_NO_WARNING (tmp) = 1;
3590 tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"),
3591 dim_union_type, &chain);
3592 TREE_NO_WARNING (tmp) = 1;
3593 gfc_finish_type (a_struct_type);
3595 chain = 0;
3596 u_union_type = make_node (UNION_TYPE);
3597 tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"),
3598 c_struct_type, &chain);
3599 TREE_NO_WARNING (tmp) = 1;
3600 tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"),
3601 a_struct_type, &chain);
3602 TREE_NO_WARNING (tmp) = 1;
3603 gfc_finish_type (u_union_type);
3605 chain = 0;
3606 reference_type = make_node (RECORD_TYPE);
3607 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"),
3608 build_pointer_type (reference_type), &chain);
3609 TREE_NO_WARNING (tmp) = 1;
3610 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"),
3611 integer_type_node, &chain);
3612 TREE_NO_WARNING (tmp) = 1;
3613 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"),
3614 size_type_node, &chain);
3615 TREE_NO_WARNING (tmp) = 1;
3616 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"),
3617 u_union_type, &chain);
3618 TREE_NO_WARNING (tmp) = 1;
3619 gfc_finish_type (reference_type);
3620 TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");
3622 return reference_type;
3625 #include "gt-fortran-trans-types.h"