1	/* Backend support for Fortran 95 basic types and derived types.
2	Copyright (C) 2002-2023 Free Software Foundation, Inc.
3	Contributed by Paul Brook <paul@nowt.org>
4	and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6	This file is part of GCC.
7
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.
12
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.
17
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/>. */
21
22	/* trans-types.cc -- gfortran backend types */
23
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"
41	#include "alias.h"
42
43
44	#if (GFC_MAX_DIMENSIONS < 10)
45	#define GFC_RANK_DIGITS 1
46	#define GFC_RANK_PRINTF_FORMAT "%01d"
47	#elif (GFC_MAX_DIMENSIONS < 100)
48	#define GFC_RANK_DIGITS 2
49	#define GFC_RANK_PRINTF_FORMAT "%02d"
50	#else
51	#error If you really need >99 dimensions, continue the sequence above...
52	#endif
53
54	/* array of structs so we don't have to worry about xmalloc or free */
55	CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
56
57	tree gfc_array_index_type;
58	tree gfc_array_range_type;
59	tree gfc_character1_type_node;
60	tree pvoid_type_node;
61	tree prvoid_type_node;
62	tree ppvoid_type_node;
63	tree pchar_type_node;
64	static tree pfunc_type_node;
65
66	tree logical_type_node;
67	tree logical_true_node;
68	tree logical_false_node;
69	tree gfc_charlen_type_node;
70
71	tree gfc_float128_type_node = NULL_TREE;
72	tree gfc_complex_float128_type_node = NULL_TREE;
73
74	bool gfc_real16_is_float128 = false;
75	bool gfc_real16_use_iec_60559 = false;
76
77	static GTY(()) tree gfc_desc_dim_type;
78	static GTY(()) tree gfc_max_array_element_size;
79	static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
80	static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
81	static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
82
83	/* Arrays for all integral and real kinds. We'll fill this in at runtime
84	after the target has a chance to process command-line options. */
85
86	#define MAX_INT_KINDS 5
87	gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
88	gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
89	static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
90	static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
91
92	#define MAX_REAL_KINDS 5
93	gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
94	static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
95	static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
96
97	#define MAX_CHARACTER_KINDS 2
98	gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
99	static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
100	static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
101
102	static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **);
103
104	/* The integer kind to use for array indices. This will be set to the
105	proper value based on target information from the backend. */
106
107	int gfc_index_integer_kind;
108
109	/* The default kinds of the various types. */
110
111	int gfc_default_integer_kind;
112	int gfc_max_integer_kind;
113	int gfc_default_real_kind;
114	int gfc_default_double_kind;
115	int gfc_default_character_kind;
116	int gfc_default_logical_kind;
117	int gfc_default_complex_kind;
118	int gfc_c_int_kind;
119	int gfc_c_intptr_kind;
120	int gfc_atomic_int_kind;
121	int gfc_atomic_logical_kind;
122
123	/* The kind size used for record offsets. If the target system supports
124	kind=8, this will be set to 8, otherwise it is set to 4. */
125	int gfc_intio_kind;
126
127	/* The integer kind used to store character lengths. */
128	int gfc_charlen_int_kind;
129
130	/* Kind of internal integer for storing object sizes. */
131	int gfc_size_kind;
132
133	/* The size of the numeric storage unit and character storage unit. */
134	int gfc_numeric_storage_size;
135	int gfc_character_storage_size;
136
137	static tree dtype_type_node = NULL_TREE;
138
139
140	/* Build the dtype_type_node if necessary. */
141	tree get_dtype_type_node (void)
142	{
143	tree field;
144	tree dtype_node;
145	tree *dtype_chain = NULL;
146
147	if (dtype_type_node == NULL_TREE)
148	{
149	dtype_node = make_node (RECORD_TYPE);
150	TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
151	TYPE_NAMELESS (dtype_node) = 1;
152	field = gfc_add_field_to_struct_1 (dtype_node,
153	get_identifier ("elem_len"),
154	size_type_node, &dtype_chain);
155	suppress_warning (field);
156	field = gfc_add_field_to_struct_1 (dtype_node,
157	get_identifier ("version"),
158	integer_type_node, &dtype_chain);
159	suppress_warning (field);
160	field = gfc_add_field_to_struct_1 (dtype_node,
161	get_identifier ("rank"),
162	signed_char_type_node, &dtype_chain);
163	suppress_warning (field);
164	field = gfc_add_field_to_struct_1 (dtype_node,
165	get_identifier ("type"),
166	signed_char_type_node, &dtype_chain);
167	suppress_warning (field);
168	field = gfc_add_field_to_struct_1 (dtype_node,
169	get_identifier ("attribute"),
170	short_integer_type_node, &dtype_chain);
171	suppress_warning (field);
172	gfc_finish_type (dtype_node);
173	TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
174	dtype_type_node = dtype_node;
175	}
176	return dtype_type_node;
177	}
178
179	static int
180	get_real_kind_from_node (tree type)
181	{
182	int i;
183
184	for (i = 0; gfc_real_kinds[i].kind != 0; i++)
185	if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
186	return gfc_real_kinds[i].kind;
187
188	return -4;
189	}
190
191	static int
192	get_int_kind_from_node (tree type)
193	{
194	int i;
195
196	if (!type)
197	return -2;
198
199	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
200	if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
201	return gfc_integer_kinds[i].kind;
202
203	return -1;
204	}
205
206	static int
207	get_int_kind_from_name (const char *name)
208	{
209	return get_int_kind_from_node (type: get_typenode_from_name (name));
210	}
211
212
213	/* Get the kind number corresponding to an integer of given size,
214	following the required return values for ISO_FORTRAN_ENV INT* constants:
215	-2 is returned if we support a kind of larger size, -1 otherwise. */
216	int
217	gfc_get_int_kind_from_width_isofortranenv (int size)
218	{
219	int i;
220
221	/* Look for a kind with matching storage size. */
222	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
223	if (gfc_integer_kinds[i].bit_size == size)
224	return gfc_integer_kinds[i].kind;
225
226	/* Look for a kind with larger storage size. */
227	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
228	if (gfc_integer_kinds[i].bit_size > size)
229	return -2;
230
231	return -1;
232	}
233
234
235	/* Get the kind number corresponding to a real of a given storage size.
236	If two real's have the same storage size, then choose the real with
237	the largest precision. If a kind type is unavailable and a real
238	exists with wider storage, then return -2; otherwise, return -1. */
239
240	int
241	gfc_get_real_kind_from_width_isofortranenv (int size)
242	{
243	int digits, i, kind;
244
245	size /= 8;
246
247	kind = -1;
248	digits = 0;
249
250	/* Look for a kind with matching storage size. */
251	for (i = 0; gfc_real_kinds[i].kind != 0; i++)
252	if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
253	{
254	if (gfc_real_kinds[i].digits > digits)
255	{
256	digits = gfc_real_kinds[i].digits;
257	kind = gfc_real_kinds[i].kind;
258	}
259	}
260
261	if (kind != -1)
262	return kind;
263
264	/* Look for a kind with larger storage size. */
265	for (i = 0; gfc_real_kinds[i].kind != 0; i++)
266	if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
267	kind = -2;
268
269	return kind;
270	}
271
272
273
274	static int
275	get_int_kind_from_width (int size)
276	{
277	int i;
278
279	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
280	if (gfc_integer_kinds[i].bit_size == size)
281	return gfc_integer_kinds[i].kind;
282
283	return -2;
284	}
285
286	static int
287	get_int_kind_from_minimal_width (int size)
288	{
289	int i;
290
291	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
292	if (gfc_integer_kinds[i].bit_size >= size)
293	return gfc_integer_kinds[i].kind;
294
295	return -2;
296	}
297
298
299	/* Generate the CInteropKind_t objects for the C interoperable
300	kinds. */
301
302	void
303	gfc_init_c_interop_kinds (void)
304	{
305	int i;
306
307	/* init all pointers in the list to NULL */
308	for (i = 0; i < ISOCBINDING_NUMBER; i++)
309	{
310	/* Initialize the name and value fields. */
311	c_interop_kinds_table[i].name[0] = '\0';
312	c_interop_kinds_table[i].value = -100;
313	c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
314	}
315
316	#define NAMED_INTCST(a,b,c,d) \
317	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
318	c_interop_kinds_table[a].f90_type = BT_INTEGER; \
319	c_interop_kinds_table[a].value = c;
320	#define NAMED_REALCST(a,b,c,d) \
321	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
322	c_interop_kinds_table[a].f90_type = BT_REAL; \
323	c_interop_kinds_table[a].value = c;
324	#define NAMED_CMPXCST(a,b,c,d) \
325	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
326	c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
327	c_interop_kinds_table[a].value = c;
328	#define NAMED_LOGCST(a,b,c) \
329	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
330	c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
331	c_interop_kinds_table[a].value = c;
332	#define NAMED_CHARKNDCST(a,b,c) \
333	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
334	c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
335	c_interop_kinds_table[a].value = c;
336	#define NAMED_CHARCST(a,b,c) \
337	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
338	c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
339	c_interop_kinds_table[a].value = c;
340	#define DERIVED_TYPE(a,b,c) \
341	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
342	c_interop_kinds_table[a].f90_type = BT_DERIVED; \
343	c_interop_kinds_table[a].value = c;
344	#define NAMED_FUNCTION(a,b,c,d) \
345	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
346	c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
347	c_interop_kinds_table[a].value = c;
348	#define NAMED_SUBROUTINE(a,b,c,d) \
349	strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
350	c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
351	c_interop_kinds_table[a].value = c;
352	#include "iso-c-binding.def"
353	}
354
355
356	/* Query the target to determine which machine modes are available for
357	computation. Choose KIND numbers for them. */
358
359	void
360	gfc_init_kinds (void)
361	{
362	opt_scalar_int_mode int_mode_iter;
363	opt_scalar_float_mode float_mode_iter;
364	int i_index, r_index, kind;
365	bool saw_i4 = false, saw_i8 = false;
366	bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
367	scalar_mode r16_mode = QImode;
368	scalar_mode composite_mode = QImode;
369
370	i_index = 0;
371	FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT)
372	{
373	scalar_int_mode mode = int_mode_iter.require ();
374	int kind, bitsize;
375
376	if (!targetm.scalar_mode_supported_p (mode))
377	continue;
378
379	/* The middle end doesn't support constants larger than 2*HWI.
380	Perhaps the target hook shouldn't have accepted these either,
381	but just to be safe... */
382	bitsize = GET_MODE_BITSIZE (mode);
383	if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
384	continue;
385
386	gcc_assert (i_index != MAX_INT_KINDS);
387
388	/* Let the kind equal the bit size divided by 8. This insulates the
389	programmer from the underlying byte size. */
390	kind = bitsize / 8;
391
392	if (kind == 4)
393	saw_i4 = true;
394	if (kind == 8)
395	saw_i8 = true;
396
397	gfc_integer_kinds[i_index].kind = kind;
398	gfc_integer_kinds[i_index].radix = 2;
399	gfc_integer_kinds[i_index].digits = bitsize - 1;
400	gfc_integer_kinds[i_index].bit_size = bitsize;
401
402	gfc_logical_kinds[i_index].kind = kind;
403	gfc_logical_kinds[i_index].bit_size = bitsize;
404
405	i_index += 1;
406	}
407
408	/* Set the kind used to match GFC_INT_IO in libgfortran. This is
409	used for large file access. */
410
411	if (saw_i8)
412	gfc_intio_kind = 8;
413	else
414	gfc_intio_kind = 4;
415
416	/* If we do not at least have kind = 4, everything is pointless. */
417	gcc_assert(saw_i4);
418
419	/* Set the maximum integer kind. Used with at least BOZ constants. */
420	gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
421
422	r_index = 0;
423	FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT)
424	{
425	scalar_float_mode mode = float_mode_iter.require ();
426	const struct real_format *fmt = REAL_MODE_FORMAT (mode);
427	int kind;
428
429	if (fmt == NULL)
430	continue;
431	if (!targetm.scalar_mode_supported_p (mode))
432	continue;
433
434	if (MODE_COMPOSITE_P (mode)
435	&& (GET_MODE_PRECISION (mode) + 7) / 8 == 16)
436	composite_mode = mode;
437
438	/* Only let float, double, long double and TFmode go through.
439	Runtime support for others is not provided, so they would be
440	useless. */
441	if (!targetm.libgcc_floating_mode_supported_p (mode))
442	continue;
443	if (mode != TYPE_MODE (float_type_node)
444	&& (mode != TYPE_MODE (double_type_node))
445	&& (mode != TYPE_MODE (long_double_type_node))
446	#if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
447	&& (mode != TFmode)
448	#endif
449	)
450	continue;
451
452	/* Let the kind equal the precision divided by 8, rounding up. Again,
453	this insulates the programmer from the underlying byte size.
454
455	Also, it effectively deals with IEEE extended formats. There, the
456	total size of the type may equal 16, but it's got 6 bytes of padding
457	and the increased size can get in the way of a real IEEE quad format
458	which may also be supported by the target.
459
460	We round up so as to handle IA-64 __floatreg (RFmode), which is an
461	82 bit type. Not to be confused with __float80 (XFmode), which is
462	an 80 bit type also supported by IA-64. So XFmode should come out
463	to be kind=10, and RFmode should come out to be kind=11. Egads.
464
465	TODO: The kind calculation has to be modified to support all
466	three 128-bit floating-point modes on PowerPC as IFmode, KFmode,
467	and TFmode since the following line would all map to kind=16.
468	However, currently only float, double, long double, and TFmode
469	reach this code.
470	*/
471
472	kind = (GET_MODE_PRECISION (mode) + 7) / 8;
473
474	if (kind == 4)
475	saw_r4 = true;
476	if (kind == 8)
477	saw_r8 = true;
478	if (kind == 10)
479	saw_r10 = true;
480	if (kind == 16)
481	{
482	saw_r16 = true;
483	r16_mode = mode;
484	}
485
486	/* Careful we don't stumble a weird internal mode. */
487	gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
488	/* Or have too many modes for the allocated space. */
489	gcc_assert (r_index != MAX_REAL_KINDS);
490
491	gfc_real_kinds[r_index].kind = kind;
492	gfc_real_kinds[r_index].abi_kind = kind;
493	gfc_real_kinds[r_index].radix = fmt->b;
494	gfc_real_kinds[r_index].digits = fmt->p;
495	gfc_real_kinds[r_index].min_exponent = fmt->emin;
496	gfc_real_kinds[r_index].max_exponent = fmt->emax;
497	if (fmt->pnan < fmt->p)
498	/* This is an IBM extended double format (or the MIPS variant)
499	made up of two IEEE doubles. The value of the long double is
500	the sum of the values of the two parts. The most significant
501	part is required to be the value of the long double rounded
502	to the nearest double. If we use emax of 1024 then we can't
503	represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
504	rounding will make the most significant part overflow. */
505	gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
506	gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
507	r_index += 1;
508	}
509
510	/* Detect the powerpc64le-linux case with -mabi=ieeelongdouble, where
511	the long double type is non-MODE_COMPOSITE_P TFmode but one can use
512	-mabi=ibmlongdouble too and get MODE_COMPOSITE_P TFmode with the same
513	precision. For libgfortran calls pretend the IEEE 754 quad TFmode has
514	kind 17 rather than 16 and use kind 16 for the IBM extended format
515	TFmode. */
516	if (composite_mode != QImode && saw_r16 && !MODE_COMPOSITE_P (r16_mode))
517	{
518	for (int i = 0; i < r_index; ++i)
519	if (gfc_real_kinds[i].kind == 16)
520	{
521	gfc_real_kinds[i].abi_kind = 17;
522	if (flag_building_libgfortran
523	&& (TARGET_GLIBC_MAJOR < 2
524	|| (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR < 32)))
525	{
526	if (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26)
527	{
528	gfc_real16_use_iec_60559 = true;
529	gfc_real_kinds[i].use_iec_60559 = 1;
530	}
531	gfc_real16_is_float128 = true;
532	gfc_real_kinds[i].c_float128 = 1;
533	}
534	}
535	}
536	else if ((flag_convert & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM)) != 0)
537	gfc_fatal_error ("%<-fconvert=r16_ieee%> or %<-fconvert=r16_ibm%> not "
538	"supported on this architecture");
539
540	/* Choose the default integer kind. We choose 4 unless the user directs us
541	otherwise. Even if the user specified that the default integer kind is 8,
542	the numeric storage size is not 64 bits. In this case, a warning will be
543	issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
544
545	gfc_numeric_storage_size = 4 * 8;
546
547	if (flag_default_integer)
548	{
549	if (!saw_i8)
550	gfc_fatal_error ("INTEGER(KIND=8) is not available for "
551	"%<-fdefault-integer-8%> option");
552
553	gfc_default_integer_kind = 8;
554
555	}
556	else if (flag_integer4_kind == 8)
557	{
558	if (!saw_i8)
559	gfc_fatal_error ("INTEGER(KIND=8) is not available for "
560	"%<-finteger-4-integer-8%> option");
561
562	gfc_default_integer_kind = 8;
563	}
564	else if (saw_i4)
565	{
566	gfc_default_integer_kind = 4;
567	}
568	else
569	{
570	gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
571	gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
572	}
573
574	/* Choose the default real kind. Again, we choose 4 when possible. */
575	if (flag_default_real_8)
576	{
577	if (!saw_r8)
578	gfc_fatal_error ("REAL(KIND=8) is not available for "
579	"%<-fdefault-real-8%> option");
580
581	gfc_default_real_kind = 8;
582	}
583	else if (flag_default_real_10)
584	{
585	if (!saw_r10)
586	gfc_fatal_error ("REAL(KIND=10) is not available for "
587	"%<-fdefault-real-10%> option");
588
589	gfc_default_real_kind = 10;
590	}
591	else if (flag_default_real_16)
592	{
593	if (!saw_r16)
594	gfc_fatal_error ("REAL(KIND=16) is not available for "
595	"%<-fdefault-real-16%> option");
596
597	gfc_default_real_kind = 16;
598	}
599	else if (flag_real4_kind == 8)
600	{
601	if (!saw_r8)
602	gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
603	"option");
604
605	gfc_default_real_kind = 8;
606	}
607	else if (flag_real4_kind == 10)
608	{
609	if (!saw_r10)
610	gfc_fatal_error ("REAL(KIND=10) is not available for "
611	"%<-freal-4-real-10%> option");
612
613	gfc_default_real_kind = 10;
614	}
615	else if (flag_real4_kind == 16)
616	{
617	if (!saw_r16)
618	gfc_fatal_error ("REAL(KIND=16) is not available for "
619	"%<-freal-4-real-16%> option");
620
621	gfc_default_real_kind = 16;
622	}
623	else if (saw_r4)
624	gfc_default_real_kind = 4;
625	else
626	gfc_default_real_kind = gfc_real_kinds[0].kind;
627
628	/* Choose the default double kind. If -fdefault-real and -fdefault-double
629	are specified, we use kind=8, if it's available. If -fdefault-real is
630	specified without -fdefault-double, we use kind=16, if it's available.
631	Otherwise we do not change anything. */
632	if (flag_default_double && saw_r8)
633	gfc_default_double_kind = 8;
634	else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16)
635	{
636	/* Use largest available kind. */
637	if (saw_r16)
638	gfc_default_double_kind = 16;
639	else if (saw_r10)
640	gfc_default_double_kind = 10;
641	else if (saw_r8)
642	gfc_default_double_kind = 8;
643	else
644	gfc_default_double_kind = gfc_default_real_kind;
645	}
646	else if (flag_real8_kind == 4)
647	{
648	if (!saw_r4)
649	gfc_fatal_error ("REAL(KIND=4) is not available for "
650	"%<-freal-8-real-4%> option");
651
652	gfc_default_double_kind = 4;
653	}
654	else if (flag_real8_kind == 10 )
655	{
656	if (!saw_r10)
657	gfc_fatal_error ("REAL(KIND=10) is not available for "
658	"%<-freal-8-real-10%> option");
659
660	gfc_default_double_kind = 10;
661	}
662	else if (flag_real8_kind == 16 )
663	{
664	if (!saw_r16)
665	gfc_fatal_error ("REAL(KIND=10) is not available for "
666	"%<-freal-8-real-16%> option");
667
668	gfc_default_double_kind = 16;
669	}
670	else if (saw_r4 && saw_r8)
671	gfc_default_double_kind = 8;
672	else
673	{
674	/* F95 14.6.3.1: A nonpointer scalar object of type double precision
675	real ... occupies two contiguous numeric storage units.
676
677	Therefore we must be supplied a kind twice as large as we chose
678	for single precision. There are loopholes, in that double
679	precision must *occupy* two storage units, though it doesn't have
680	to *use* two storage units. Which means that you can make this
681	kind artificially wide by padding it. But at present there are
682	no GCC targets for which a two-word type does not exist, so we
683	just let gfc_validate_kind abort and tell us if something breaks. */
684
685	gfc_default_double_kind
686	= gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
687	}
688
689	/* The default logical kind is constrained to be the same as the
690	default integer kind. Similarly with complex and real. */
691	gfc_default_logical_kind = gfc_default_integer_kind;
692	gfc_default_complex_kind = gfc_default_real_kind;
693
694	/* We only have two character kinds: ASCII and UCS-4.
695	ASCII corresponds to a 8-bit integer type, if one is available.
696	UCS-4 corresponds to a 32-bit integer type, if one is available. */
697	i_index = 0;
698	if ((kind = get_int_kind_from_width (size: 8)) > 0)
699	{
700	gfc_character_kinds[i_index].kind = kind;
701	gfc_character_kinds[i_index].bit_size = 8;
702	gfc_character_kinds[i_index].name = "ascii";
703	i_index++;
704	}
705	if ((kind = get_int_kind_from_width (size: 32)) > 0)
706	{
707	gfc_character_kinds[i_index].kind = kind;
708	gfc_character_kinds[i_index].bit_size = 32;
709	gfc_character_kinds[i_index].name = "iso_10646";
710	i_index++;
711	}
712
713	/* Choose the smallest integer kind for our default character. */
714	gfc_default_character_kind = gfc_character_kinds[0].kind;
715	gfc_character_storage_size = gfc_default_character_kind * 8;
716
717	gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);
718
719	/* Pick a kind the same size as the C "int" type. */
720	gfc_c_int_kind = INT_TYPE_SIZE / 8;
721
722	/* Choose atomic kinds to match C's int. */
723	gfc_atomic_int_kind = gfc_c_int_kind;
724	gfc_atomic_logical_kind = gfc_c_int_kind;
725
726	gfc_c_intptr_kind = POINTER_SIZE / 8;
727	}
728
729
730	/* Make sure that a valid kind is present. Returns an index into the
731	associated kinds array, -1 if the kind is not present. */
732
733	static int
734	validate_integer (int kind)
735	{
736	int i;
737
738	for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
739	if (gfc_integer_kinds[i].kind == kind)
740	return i;
741
742	return -1;
743	}
744
745	static int
746	validate_real (int kind)
747	{
748	int i;
749
750	for (i = 0; gfc_real_kinds[i].kind != 0; i++)
751	if (gfc_real_kinds[i].kind == kind)
752	return i;
753
754	return -1;
755	}
756
757	static int
758	validate_logical (int kind)
759	{
760	int i;
761
762	for (i = 0; gfc_logical_kinds[i].kind; i++)
763	if (gfc_logical_kinds[i].kind == kind)
764	return i;
765
766	return -1;
767	}
768
769	static int
770	validate_character (int kind)
771	{
772	int i;
773
774	for (i = 0; gfc_character_kinds[i].kind; i++)
775	if (gfc_character_kinds[i].kind == kind)
776	return i;
777
778	return -1;
779	}
780
781	/* Validate a kind given a basic type. The return value is the same
782	for the child functions, with -1 indicating nonexistence of the
783	type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
784
785	int
786	gfc_validate_kind (bt type, int kind, bool may_fail)
787	{
788	int rc;
789
790	switch (type)
791	{
792	case BT_REAL: /* Fall through */
793	case BT_COMPLEX:
794	rc = validate_real (kind);
795	break;
796	case BT_INTEGER:
797	rc = validate_integer (kind);
798	break;
799	case BT_LOGICAL:
800	rc = validate_logical (kind);
801	break;
802	case BT_CHARACTER:
803	rc = validate_character (kind);
804	break;
805
806	default:
807	gfc_internal_error ("gfc_validate_kind(): Got bad type");
808	}
809
810	if (rc < 0 && !may_fail)
811	gfc_internal_error ("gfc_validate_kind(): Got bad kind");
812
813	return rc;
814	}
815
816
817	/* Four subroutines of gfc_init_types. Create type nodes for the given kind.
818	Reuse common type nodes where possible. Recognize if the kind matches up
819	with a C type. This will be used later in determining which routines may
820	be scarfed from libm. */
821
822	static tree
823	gfc_build_int_type (gfc_integer_info *info)
824	{
825	int mode_precision = info->bit_size;
826
827	if (mode_precision == CHAR_TYPE_SIZE)
828	info->c_char = 1;
829	if (mode_precision == SHORT_TYPE_SIZE)
830	info->c_short = 1;
831	if (mode_precision == INT_TYPE_SIZE)
832	info->c_int = 1;
833	if (mode_precision == LONG_TYPE_SIZE)
834	info->c_long = 1;
835	if (mode_precision == LONG_LONG_TYPE_SIZE)
836	info->c_long_long = 1;
837
838	if (TYPE_PRECISION (intQI_type_node) == mode_precision)
839	return intQI_type_node;
840	if (TYPE_PRECISION (intHI_type_node) == mode_precision)
841	return intHI_type_node;
842	if (TYPE_PRECISION (intSI_type_node) == mode_precision)
843	return intSI_type_node;
844	if (TYPE_PRECISION (intDI_type_node) == mode_precision)
845	return intDI_type_node;
846	if (TYPE_PRECISION (intTI_type_node) == mode_precision)
847	return intTI_type_node;
848
849	return make_signed_type (mode_precision);
850	}
851
852	tree
853	gfc_build_uint_type (int size)
854	{
855	if (size == CHAR_TYPE_SIZE)
856	return unsigned_char_type_node;
857	if (size == SHORT_TYPE_SIZE)
858	return short_unsigned_type_node;
859	if (size == INT_TYPE_SIZE)
860	return unsigned_type_node;
861	if (size == LONG_TYPE_SIZE)
862	return long_unsigned_type_node;
863	if (size == LONG_LONG_TYPE_SIZE)
864	return long_long_unsigned_type_node;
865
866	return make_unsigned_type (size);
867	}
868
869
870	static tree
871	gfc_build_real_type (gfc_real_info *info)
872	{
873	int mode_precision = info->mode_precision;
874	tree new_type;
875
876	if (mode_precision == FLOAT_TYPE_SIZE)
877	info->c_float = 1;
878	if (mode_precision == DOUBLE_TYPE_SIZE)
879	info->c_double = 1;
880	if (mode_precision == LONG_DOUBLE_TYPE_SIZE && !info->c_float128)
881	info->c_long_double = 1;
882	if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
883	{
884	/* TODO: see PR101835. */
885	info->c_float128 = 1;
886	gfc_real16_is_float128 = true;
887	if (TARGET_GLIBC_MAJOR > 2
888	|| (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26))
889	{
890	info->use_iec_60559 = 1;
891	gfc_real16_use_iec_60559 = true;
892	}
893	}
894
895	if (TYPE_PRECISION (float_type_node) == mode_precision)
896	return float_type_node;
897	if (TYPE_PRECISION (double_type_node) == mode_precision)
898	return double_type_node;
899	if (TYPE_PRECISION (long_double_type_node) == mode_precision)
900	return long_double_type_node;
901
902	new_type = make_node (REAL_TYPE);
903	TYPE_PRECISION (new_type) = mode_precision;
904	layout_type (new_type);
905	return new_type;
906	}
907
908	static tree
909	gfc_build_complex_type (tree scalar_type)
910	{
911	tree new_type;
912
913	if (scalar_type == NULL)
914	return NULL;
915	if (scalar_type == float_type_node)
916	return complex_float_type_node;
917	if (scalar_type == double_type_node)
918	return complex_double_type_node;
919	if (scalar_type == long_double_type_node)
920	return complex_long_double_type_node;
921
922	new_type = make_node (COMPLEX_TYPE);
923	TREE_TYPE (new_type) = scalar_type;
924	layout_type (new_type);
925	return new_type;
926	}
927
928	static tree
929	gfc_build_logical_type (gfc_logical_info *info)
930	{
931	int bit_size = info->bit_size;
932	tree new_type;
933
934	if (bit_size == BOOL_TYPE_SIZE)
935	{
936	info->c_bool = 1;
937	return boolean_type_node;
938	}
939
940	new_type = make_unsigned_type (bit_size);
941	TREE_SET_CODE (new_type, BOOLEAN_TYPE);
942	TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
943	TYPE_PRECISION (new_type) = 1;
944
945	return new_type;
946	}
947
948
949	/* Create the backend type nodes. We map them to their
950	equivalent C type, at least for now. We also give
951	names to the types here, and we push them in the
952	global binding level context.*/
953
954	void
955	gfc_init_types (void)
956	{
957	char name_buf[26];
958	int index;
959	tree type;
960	unsigned n;
961
962	/* Create and name the types. */
963	#define PUSH_TYPE(name, node) \
964	pushdecl (build_decl (input_location, \
965	TYPE_DECL, get_identifier (name), node))
966
967	for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
968	{
969	type = gfc_build_int_type (info: &gfc_integer_kinds[index]);
970	/* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
971	if (TYPE_STRING_FLAG (type))
972	type = make_signed_type (gfc_integer_kinds[index].bit_size);
973	gfc_integer_types[index] = type;
974	snprintf (s: name_buf, maxlen: sizeof(name_buf), format: "integer(kind=%d)",
975	gfc_integer_kinds[index].kind);
976	PUSH_TYPE (name_buf, type);
977	}
978
979	for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
980	{
981	type = gfc_build_logical_type (info: &gfc_logical_kinds[index]);
982	gfc_logical_types[index] = type;
983	snprintf (s: name_buf, maxlen: sizeof(name_buf), format: "logical(kind=%d)",
984	gfc_logical_kinds[index].kind);
985	PUSH_TYPE (name_buf, type);
986	}
987
988	for (index = 0; gfc_real_kinds[index].kind != 0; index++)
989	{
990	type = gfc_build_real_type (info: &gfc_real_kinds[index]);
991	gfc_real_types[index] = type;
992	snprintf (s: name_buf, maxlen: sizeof(name_buf), format: "real(kind=%d)",
993	gfc_real_kinds[index].kind);
994	PUSH_TYPE (name_buf, type);
995
996	if (gfc_real_kinds[index].c_float128)
997	gfc_float128_type_node = type;
998
999	type = gfc_build_complex_type (scalar_type: type);
1000	gfc_complex_types[index] = type;
1001	snprintf (s: name_buf, maxlen: sizeof(name_buf), format: "complex(kind=%d)",
1002	gfc_real_kinds[index].kind);
1003	PUSH_TYPE (name_buf, type);
1004
1005	if (gfc_real_kinds[index].c_float128)
1006	gfc_complex_float128_type_node = type;
1007	}
1008
1009	for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
1010	{
1011	type = gfc_build_uint_type (size: gfc_character_kinds[index].bit_size);
1012	type = build_qualified_type (type, TYPE_UNQUALIFIED);
1013	snprintf (s: name_buf, maxlen: sizeof(name_buf), format: "character(kind=%d)",
1014	gfc_character_kinds[index].kind);
1015	PUSH_TYPE (name_buf, type);
1016	gfc_character_types[index] = type;
1017	gfc_pcharacter_types[index] = build_pointer_type (type);
1018	}
1019	gfc_character1_type_node = gfc_character_types[0];
1020
1021	PUSH_TYPE ("byte", unsigned_char_type_node);
1022	PUSH_TYPE ("void", void_type_node);
1023
1024	/* DBX debugging output gets upset if these aren't set. */
1025	if (!TYPE_NAME (integer_type_node))
1026	PUSH_TYPE ("c_integer", integer_type_node);
1027	if (!TYPE_NAME (char_type_node))
1028	PUSH_TYPE ("c_char", char_type_node);
1029
1030	#undef PUSH_TYPE
1031
1032	pvoid_type_node = build_pointer_type (void_type_node);
1033	prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
1034	ppvoid_type_node = build_pointer_type (pvoid_type_node);
1035	pchar_type_node = build_pointer_type (gfc_character1_type_node);
1036	pfunc_type_node
1037	= build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
1038
1039	gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
1040	/* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
1041	since this function is called before gfc_init_constants. */
1042	gfc_array_range_type
1043	= build_range_type (gfc_array_index_type,
1044	build_int_cst (gfc_array_index_type, 0),
1045	NULL_TREE);
1046
1047	/* The maximum array element size that can be handled is determined
1048	by the number of bits available to store this field in the array
1049	descriptor. */
1050
1051	n = TYPE_PRECISION (size_type_node);
1052	gfc_max_array_element_size
1053	= wide_int_to_tree (size_type_node,
1054	cst: wi::mask (width: n, negate_p: UNSIGNED,
1055	TYPE_PRECISION (size_type_node)));
1056
1057	logical_type_node = gfc_get_logical_type (gfc_default_logical_kind);
1058	logical_true_node = build_int_cst (logical_type_node, 1);
1059	logical_false_node = build_int_cst (logical_type_node, 0);
1060
1061	/* Character lengths are of type size_t, except signed. */
1062	gfc_charlen_int_kind = get_int_kind_from_node (size_type_node);
1063	gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
1064
1065	/* Fortran kind number of size_type_node (size_t). This is used for
1066	the _size member in vtables. */
1067	gfc_size_kind = get_int_kind_from_node (size_type_node);
1068	}
1069
1070	/* Get the type node for the given type and kind. */
1071
1072	tree
1073	gfc_get_int_type (int kind)
1074	{
1075	int index = gfc_validate_kind (type: BT_INTEGER, kind, may_fail: true);
1076	return index < 0 ? 0 : gfc_integer_types[index];
1077	}
1078
1079	tree
1080	gfc_get_real_type (int kind)
1081	{
1082	int index = gfc_validate_kind (type: BT_REAL, kind, may_fail: true);
1083	return index < 0 ? 0 : gfc_real_types[index];
1084	}
1085
1086	tree
1087	gfc_get_complex_type (int kind)
1088	{
1089	int index = gfc_validate_kind (type: BT_COMPLEX, kind, may_fail: true);
1090	return index < 0 ? 0 : gfc_complex_types[index];
1091	}
1092
1093	tree
1094	gfc_get_logical_type (int kind)
1095	{
1096	int index = gfc_validate_kind (type: BT_LOGICAL, kind, may_fail: true);
1097	return index < 0 ? 0 : gfc_logical_types[index];
1098	}
1099
1100	tree
1101	gfc_get_char_type (int kind)
1102	{
1103	int index = gfc_validate_kind (type: BT_CHARACTER, kind, may_fail: true);
1104	return index < 0 ? 0 : gfc_character_types[index];
1105	}
1106
1107	tree
1108	gfc_get_pchar_type (int kind)
1109	{
1110	int index = gfc_validate_kind (type: BT_CHARACTER, kind, may_fail: true);
1111	return index < 0 ? 0 : gfc_pcharacter_types[index];
1112	}
1113
1114
1115	/* Create a character type with the given kind and length. */
1116
1117	tree
1118	gfc_get_character_type_len_for_eltype (tree eltype, tree len)
1119	{
1120	tree bounds, type;
1121
1122	bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
1123	type = build_array_type (eltype, bounds);
1124	TYPE_STRING_FLAG (type) = 1;
1125
1126	return type;
1127	}
1128
1129	tree
1130	gfc_get_character_type_len (int kind, tree len)
1131	{
1132	gfc_validate_kind (type: BT_CHARACTER, kind, may_fail: false);
1133	return gfc_get_character_type_len_for_eltype (eltype: gfc_get_char_type (kind), len);
1134	}
1135
1136
1137	/* Get a type node for a character kind. */
1138
1139	tree
1140	gfc_get_character_type (int kind, gfc_charlen * cl)
1141	{
1142	tree len;
1143
1144	len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
1145	if (len && POINTER_TYPE_P (TREE_TYPE (len)))
1146	len = build_fold_indirect_ref (len);
1147
1148	return gfc_get_character_type_len (kind, len);
1149	}
1150
1151	/* Convert a basic type. This will be an array for character types. */
1152
1153	tree
1154	gfc_typenode_for_spec (gfc_typespec * spec, int codim)
1155	{
1156	tree basetype;
1157
1158	switch (spec->type)
1159	{
1160	case BT_UNKNOWN:
1161	gcc_unreachable ();
1162
1163	case BT_INTEGER:
1164	/* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
1165	has been resolved. This is done so we can convert C_PTR and
1166	C_FUNPTR to simple variables that get translated to (void *). */
1167	if (spec->f90_type == BT_VOID)
1168	{
1169	if (spec->u.derived
1170	&& spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1171	basetype = ptr_type_node;
1172	else
1173	basetype = pfunc_type_node;
1174	}
1175	else
1176	basetype = gfc_get_int_type (kind: spec->kind);
1177	break;
1178
1179	case BT_REAL:
1180	basetype = gfc_get_real_type (kind: spec->kind);
1181	break;
1182
1183	case BT_COMPLEX:
1184	basetype = gfc_get_complex_type (kind: spec->kind);
1185	break;
1186
1187	case BT_LOGICAL:
1188	basetype = gfc_get_logical_type (kind: spec->kind);
1189	break;
1190
1191	case BT_CHARACTER:
1192	basetype = gfc_get_character_type (kind: spec->kind, cl: spec->u.cl);
1193	break;
1194
1195	case BT_HOLLERITH:
1196	/* Since this cannot be used, return a length one character. */
1197	basetype = gfc_get_character_type_len (kind: gfc_default_character_kind,
1198	gfc_index_one_node);
1199	break;
1200
1201	case BT_UNION:
1202	basetype = gfc_get_union_type (spec->u.derived);
1203	break;
1204
1205	case BT_DERIVED:
1206	case BT_CLASS:
1207	basetype = gfc_get_derived_type (derived: spec->u.derived, codimen: codim);
1208
1209	if (spec->type == BT_CLASS)
1210	GFC_CLASS_TYPE_P (basetype) = 1;
1211
1212	/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1213	type and kind to fit a (void *) and the basetype returned was a
1214	ptr_type_node. We need to pass up this new information to the
1215	symbol that was declared of type C_PTR or C_FUNPTR. */
1216	if (spec->u.derived->ts.f90_type == BT_VOID)
1217	{
1218	spec->type = BT_INTEGER;
1219	spec->kind = gfc_index_integer_kind;
1220	spec->f90_type = BT_VOID;
1221	spec->is_c_interop = 1; /* Mark as escaping later. */
1222	}
1223	break;
1224	case BT_VOID:
1225	case BT_ASSUMED:
1226	/* This is for the second arg to c_f_pointer and c_f_procpointer
1227	of the iso_c_binding module, to accept any ptr type. */
1228	basetype = ptr_type_node;
1229	if (spec->f90_type == BT_VOID)
1230	{
1231	if (spec->u.derived
1232	&& spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1233	basetype = ptr_type_node;
1234	else
1235	basetype = pfunc_type_node;
1236	}
1237	break;
1238	case BT_PROCEDURE:
1239	basetype = pfunc_type_node;
1240	break;
1241	default:
1242	gcc_unreachable ();
1243	}
1244	return basetype;
1245	}
1246
1247	/* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
1248
1249	static tree
1250	gfc_conv_array_bound (gfc_expr * expr)
1251	{
1252	/* If expr is an integer constant, return that. */
1253	if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
1254	return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
1255
1256	/* Otherwise return NULL. */
1257	return NULL_TREE;
1258	}
1259
1260	/* Return the type of an element of the array. Note that scalar coarrays
1261	are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
1262	(with POINTER_TYPE stripped) is returned. */
1263
1264	tree
1265	gfc_get_element_type (tree type)
1266	{
1267	tree element;
1268
1269	if (GFC_ARRAY_TYPE_P (type))
1270	{
1271	if (TREE_CODE (type) == POINTER_TYPE)
1272	type = TREE_TYPE (type);
1273	if (GFC_TYPE_ARRAY_RANK (type) == 0)
1274	{
1275	gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
1276	element = type;
1277	}
1278	else
1279	{
1280	gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1281	element = TREE_TYPE (type);
1282	}
1283	}
1284	else
1285	{
1286	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
1287	element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
1288
1289	gcc_assert (TREE_CODE (element) == POINTER_TYPE);
1290	element = TREE_TYPE (element);
1291
1292	/* For arrays, which are not scalar coarrays. */
1293	if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
1294	element = TREE_TYPE (element);
1295	}
1296
1297	return element;
1298	}
1299
1300	/* Build an array. This function is called from gfc_sym_type().
1301	Actually returns array descriptor type.
1302
1303	Format of array descriptors is as follows:
1304
1305	struct gfc_array_descriptor
1306	{
1307	array *data;
1308	index offset;
1309	struct dtype_type dtype;
1310	struct descriptor_dimension dimension[N_DIM];
1311	}
1312
1313	struct dtype_type
1314	{
1315	size_t elem_len;
1316	int version;
1317	signed char rank;
1318	signed char type;
1319	signed short attribute;
1320	}
1321
1322	struct descriptor_dimension
1323	{
1324	index stride;
1325	index lbound;
1326	index ubound;
1327	}
1328
1329	Translation code should use gfc_conv_descriptor_* rather than
1330	accessing the descriptor directly. Any changes to the array
1331	descriptor type will require changes in gfc_conv_descriptor_* and
1332	gfc_build_array_initializer.
1333
1334	This is represented internally as a RECORD_TYPE. The index nodes
1335	are gfc_array_index_type and the data node is a pointer to the
1336	data. See below for the handling of character types.
1337
1338	I originally used nested ARRAY_TYPE nodes to represent arrays, but
1339	this generated poor code for assumed/deferred size arrays. These
1340	require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1341	of the GENERIC grammar. Also, there is no way to explicitly set
1342	the array stride, so all data must be packed(1). I've tried to
1343	mark all the functions which would require modification with a GCC
1344	ARRAYS comment.
1345
1346	The data component points to the first element in the array. The
1347	offset field is the position of the origin of the array (i.e. element
1348	(0, 0 ...)). This may be outside the bounds of the array.
1349
1350	An element is accessed by
1351	data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1352	This gives good performance as the computation does not involve the
1353	bounds of the array. For packed arrays, this is optimized further
1354	by substituting the known strides.
1355
1356	This system has one problem: all array bounds must be within 2^31
1357	elements of the origin (2^63 on 64-bit machines). For example
1358	integer, dimension (80000:90000, 80000:90000, 2) :: array
1359	may not work properly on 32-bit machines because 80000*80000 >
1360	2^31, so the calculation for stride2 would overflow. This may
1361	still work, but I haven't checked, and it relies on the overflow
1362	doing the right thing.
1363
1364	The way to fix this problem is to access elements as follows:
1365	data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1366	Obviously this is much slower. I will make this a compile time
1367	option, something like -fsmall-array-offsets. Mixing code compiled
1368	with and without this switch will work.
1369
1370	(1) This can be worked around by modifying the upper bound of the
1371	previous dimension. This requires extra fields in the descriptor
1372	(both real_ubound and fake_ubound). */
1373
1374
1375	/* Returns true if the array sym does not require a descriptor. */
1376
1377	bool
1378	gfc_is_nodesc_array (gfc_symbol * sym)
1379	{
1380	symbol_attribute *array_attr;
1381	gfc_array_spec *as;
1382	bool is_classarray = IS_CLASS_ARRAY (sym);
1383
1384	array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
1385	as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
1386
1387	gcc_assert (array_attr->dimension || array_attr->codimension);
1388
1389	/* We only want local arrays. */
1390	if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
1391	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
1392	|| array_attr->allocatable)
1393	return 0;
1394
1395	/* We want a descriptor for associate-name arrays that do not have an
1396	explicitly known shape already. */
1397	if (sym->assoc && as->type != AS_EXPLICIT)
1398	return 0;
1399
1400	/* The dummy is stored in sym and not in the component. */
1401	if (sym->attr.dummy)
1402	return as->type != AS_ASSUMED_SHAPE
1403	&& as->type != AS_ASSUMED_RANK;
1404
1405	if (sym->attr.result || sym->attr.function)
1406	return 0;
1407
1408	gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
1409
1410	return 1;
1411	}
1412
1413
1414	/* Create an array descriptor type. */
1415
1416	static tree
1417	gfc_build_array_type (tree type, gfc_array_spec * as,
1418	enum gfc_array_kind akind, bool restricted,
1419	bool contiguous, int codim)
1420	{
1421	tree lbound[GFC_MAX_DIMENSIONS];
1422	tree ubound[GFC_MAX_DIMENSIONS];
1423	int n, corank;
1424
1425	/* Assumed-shape arrays do not have codimension information stored in the
1426	descriptor. */
1427	corank = MAX (as->corank, codim);
1428	if (as->type == AS_ASSUMED_SHAPE ||
1429	(as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
1430	corank = codim;
1431
1432	if (as->type == AS_ASSUMED_RANK)
1433	for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1434	{
1435	lbound[n] = NULL_TREE;
1436	ubound[n] = NULL_TREE;
1437	}
1438
1439	for (n = 0; n < as->rank; n++)
1440	{
1441	/* Create expressions for the known bounds of the array. */
1442	if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1443	lbound[n] = gfc_index_one_node;
1444	else
1445	lbound[n] = gfc_conv_array_bound (expr: as->lower[n]);
1446	ubound[n] = gfc_conv_array_bound (expr: as->upper[n]);
1447	}
1448
1449	for (n = as->rank; n < as->rank + corank; n++)
1450	{
1451	if (as->type != AS_DEFERRED && as->lower[n] == NULL)
1452	lbound[n] = gfc_index_one_node;
1453	else
1454	lbound[n] = gfc_conv_array_bound (expr: as->lower[n]);
1455
1456	if (n < as->rank + corank - 1)
1457	ubound[n] = gfc_conv_array_bound (expr: as->upper[n]);
1458	}
1459
1460	if (as->type == AS_ASSUMED_SHAPE)
1461	akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
1462	: GFC_ARRAY_ASSUMED_SHAPE;
1463	else if (as->type == AS_ASSUMED_RANK)
1464	akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
1465	: GFC_ARRAY_ASSUMED_RANK;
1466	return gfc_get_array_type_bounds (type, as->rank == -1
1467	? GFC_MAX_DIMENSIONS : as->rank,
1468	corank, lbound, ubound, 0, akind,
1469	restricted);
1470	}
1471
1472	/* Returns the struct descriptor_dimension type. */
1473
1474	static tree
1475	gfc_get_desc_dim_type (void)
1476	{
1477	tree type;
1478	tree decl, *chain = NULL;
1479
1480	if (gfc_desc_dim_type)
1481	return gfc_desc_dim_type;
1482
1483	/* Build the type node. */
1484	type = make_node (RECORD_TYPE);
1485
1486	TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1487	TYPE_PACKED (type) = 1;
1488
1489	/* Consists of the stride, lbound and ubound members. */
1490	decl = gfc_add_field_to_struct_1 (type,
1491	get_identifier ("stride"),
1492	gfc_array_index_type, &chain);
1493	suppress_warning (decl);
1494
1495	decl = gfc_add_field_to_struct_1 (type,
1496	get_identifier ("lbound"),
1497	gfc_array_index_type, &chain);
1498	suppress_warning (decl);
1499
1500	decl = gfc_add_field_to_struct_1 (type,
1501	get_identifier ("ubound"),
1502	gfc_array_index_type, &chain);
1503	suppress_warning (decl);
1504
1505	/* Finish off the type. */
1506	gfc_finish_type (type);
1507	TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1508
1509	gfc_desc_dim_type = type;
1510	return type;
1511	}
1512
1513
1514	/* Return the DTYPE for an array. This describes the type and type parameters
1515	of the array. */
1516	/* TODO: Only call this when the value is actually used, and make all the
1517	unknown cases abort. */
1518
1519	tree
1520	gfc_get_dtype_rank_type (int rank, tree etype)
1521	{
1522	tree ptype;
1523	tree size;
1524	int n;
1525	tree tmp;
1526	tree dtype;
1527	tree field;
1528	vec<constructor_elt, va_gc> *v = NULL;
1529
1530	ptype = etype;
1531	while (TREE_CODE (etype) == POINTER_TYPE
1532	|| TREE_CODE (etype) == ARRAY_TYPE)
1533	{
1534	ptype = etype;
1535	etype = TREE_TYPE (etype);
1536	}
1537
1538	gcc_assert (etype);
1539
1540	switch (TREE_CODE (etype))
1541	{
1542	case INTEGER_TYPE:
1543	if (TREE_CODE (ptype) == ARRAY_TYPE
1544	&& TYPE_STRING_FLAG (ptype))
1545	n = BT_CHARACTER;
1546	else
1547	n = BT_INTEGER;
1548	break;
1549
1550	case BOOLEAN_TYPE:
1551	n = BT_LOGICAL;
1552	break;
1553
1554	case REAL_TYPE:
1555	n = BT_REAL;
1556	break;
1557
1558	case COMPLEX_TYPE:
1559	n = BT_COMPLEX;
1560	break;
1561
1562	case RECORD_TYPE:
1563	if (GFC_CLASS_TYPE_P (etype))
1564	n = BT_CLASS;
1565	else
1566	n = BT_DERIVED;
1567	break;
1568
1569	case FUNCTION_TYPE:
1570	case VOID_TYPE:
1571	n = BT_VOID;
1572	break;
1573
1574	default:
1575	/* TODO: Don't do dtype for temporary descriptorless arrays. */
1576	/* We can encounter strange array types for temporary arrays. */
1577	gcc_unreachable ();
1578	}
1579
1580	switch (n)
1581	{
1582	case BT_CHARACTER:
1583	gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE);
1584	size = gfc_get_character_len_in_bytes (ptype);
1585	break;
1586	case BT_VOID:
1587	gcc_assert (TREE_CODE (ptype) == POINTER_TYPE);
1588	size = size_in_bytes (t: ptype);
1589	break;
1590	default:
1591	size = size_in_bytes (t: etype);
1592	break;
1593	}
1594
1595	gcc_assert (size);
1596
1597	STRIP_NOPS (size);
1598	size = fold_convert (size_type_node, size);
1599	tmp = get_dtype_type_node ();
1600	field = gfc_advance_chain (TYPE_FIELDS (tmp),
1601	GFC_DTYPE_ELEM_LEN);
1602	CONSTRUCTOR_APPEND_ELT (v, field,
1603	fold_convert (TREE_TYPE (field), size));
1604
1605	field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
1606	GFC_DTYPE_RANK);
1607	if (rank >= 0)
1608	CONSTRUCTOR_APPEND_ELT (v, field,
1609	build_int_cst (TREE_TYPE (field), rank));
1610
1611	field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
1612	GFC_DTYPE_TYPE);
1613	CONSTRUCTOR_APPEND_ELT (v, field,
1614	build_int_cst (TREE_TYPE (field), n));
1615
1616	dtype = build_constructor (tmp, v);
1617
1618	return dtype;
1619	}
1620
1621
1622	tree
1623	gfc_get_dtype (tree type, int * rank)
1624	{
1625	tree dtype;
1626	tree etype;
1627	int irnk;
1628
1629	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1630
1631	irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type));
1632	etype = gfc_get_element_type (type);
1633	dtype = gfc_get_dtype_rank_type (rank: irnk, etype);
1634
1635	GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1636	return dtype;
1637	}
1638
1639
1640	/* Build an array type for use without a descriptor, packed according
1641	to the value of PACKED. */
1642
1643	tree
1644	gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
1645	bool restricted)
1646	{
1647	tree range;
1648	tree type;
1649	tree tmp;
1650	int n;
1651	int known_stride;
1652	int known_offset;
1653	mpz_t offset;
1654	mpz_t stride;
1655	mpz_t delta;
1656	gfc_expr *expr;
1657
1658	mpz_init_set_ui (offset, 0);
1659	mpz_init_set_ui (stride, 1);
1660	mpz_init (delta);
1661
1662	/* We don't use build_array_type because this does not include
1663	lang-specific information (i.e. the bounds of the array) when checking
1664	for duplicates. */
1665	if (as->rank)
1666	type = make_node (ARRAY_TYPE);
1667	else
1668	type = build_variant_type_copy (etype);
1669
1670	GFC_ARRAY_TYPE_P (type) = 1;
1671	TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
1672
1673	known_stride = (packed != PACKED_NO);
1674	known_offset = 1;
1675	for (n = 0; n < as->rank; n++)
1676	{
1677	/* Fill in the stride and bound components of the type. */
1678	if (known_stride)
1679	tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1680	else
1681	tmp = NULL_TREE;
1682	GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1683
1684	expr = as->lower[n];
1685	if (expr && expr->expr_type == EXPR_CONSTANT)
1686	{
1687	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1688	gfc_index_integer_kind);
1689	}
1690	else
1691	{
1692	known_stride = 0;
1693	tmp = NULL_TREE;
1694	}
1695	GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1696
1697	if (known_stride)
1698	{
1699	/* Calculate the offset. */
1700	mpz_mul (delta, stride, as->lower[n]->value.integer);
1701	mpz_sub (offset, offset, delta);
1702	}
1703	else
1704	known_offset = 0;
1705
1706	expr = as->upper[n];
1707	if (expr && expr->expr_type == EXPR_CONSTANT)
1708	{
1709	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1710	gfc_index_integer_kind);
1711	}
1712	else
1713	{
1714	tmp = NULL_TREE;
1715	known_stride = 0;
1716	}
1717	GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1718
1719	if (known_stride)
1720	{
1721	/* Calculate the stride. */
1722	mpz_sub (delta, as->upper[n]->value.integer,
1723	as->lower[n]->value.integer);
1724	mpz_add_ui (delta, delta, 1);
1725	mpz_mul (stride, stride, delta);
1726	}
1727
1728	/* Only the first stride is known for partial packed arrays. */
1729	if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1730	known_stride = 0;
1731	}
1732	for (n = as->rank; n < as->rank + as->corank; n++)
1733	{
1734	expr = as->lower[n];
1735	if (expr && expr->expr_type == EXPR_CONSTANT)
1736	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1737	gfc_index_integer_kind);
1738	else
1739	tmp = NULL_TREE;
1740	GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1741
1742	expr = as->upper[n];
1743	if (expr && expr->expr_type == EXPR_CONSTANT)
1744	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1745	gfc_index_integer_kind);
1746	else
1747	tmp = NULL_TREE;
1748	if (n < as->rank + as->corank - 1)
1749	GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1750	}
1751
1752	if (known_offset)
1753	{
1754	GFC_TYPE_ARRAY_OFFSET (type) =
1755	gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1756	}
1757	else
1758	GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1759
1760	if (known_stride)
1761	{
1762	GFC_TYPE_ARRAY_SIZE (type) =
1763	gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1764	}
1765	else
1766	GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1767
1768	GFC_TYPE_ARRAY_RANK (type) = as->rank;
1769	GFC_TYPE_ARRAY_CORANK (type) = as->corank;
1770	GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1771	range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1772	NULL_TREE);
1773	/* TODO: use main type if it is unbounded. */
1774	GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1775	build_pointer_type (build_array_type (etype, range));
1776	if (restricted)
1777	GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1778	build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
1779	TYPE_QUAL_RESTRICT);
1780
1781	if (as->rank == 0)
1782	{
1783	if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB)
1784	{
1785	type = build_pointer_type (type);
1786
1787	if (restricted)
1788	type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1789
1790	GFC_ARRAY_TYPE_P (type) = 1;
1791	TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1792	}
1793
1794	return type;
1795	}
1796
1797	if (known_stride)
1798	{
1799	mpz_sub_ui (stride, stride, 1);
1800	range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1801	}
1802	else
1803	range = NULL_TREE;
1804
1805	range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1806	TYPE_DOMAIN (type) = range;
1807
1808	build_pointer_type (etype);
1809	TREE_TYPE (type) = etype;
1810
1811	layout_type (type);
1812
1813	mpz_clear (offset);
1814	mpz_clear (stride);
1815	mpz_clear (delta);
1816
1817	/* Represent packed arrays as multi-dimensional if they have rank >
1818	1 and with proper bounds, instead of flat arrays. This makes for
1819	better debug info. */
1820	if (known_offset)
1821	{
1822	tree gtype = etype, rtype, type_decl;
1823
1824	for (n = as->rank - 1; n >= 0; n--)
1825	{
1826	rtype = build_range_type (gfc_array_index_type,
1827	GFC_TYPE_ARRAY_LBOUND (type, n),
1828	GFC_TYPE_ARRAY_UBOUND (type, n));
1829	gtype = build_array_type (gtype, rtype);
1830	}
1831	TYPE_NAME (type) = type_decl = build_decl (input_location,
1832	TYPE_DECL, NULL, gtype);
1833	DECL_ORIGINAL_TYPE (type_decl) = gtype;
1834	}
1835
1836	if (packed != PACKED_STATIC || !known_stride
1837	|| (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
1838	{
1839	/* For dummy arrays and automatic (heap allocated) arrays we
1840	want a pointer to the array. */
1841	type = build_pointer_type (type);
1842	if (restricted)
1843	type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1844	GFC_ARRAY_TYPE_P (type) = 1;
1845	TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1846	}
1847	return type;
1848	}
1849
1850
1851	/* Return or create the base type for an array descriptor. */
1852
1853	static tree
1854	gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
1855	{
1856	tree fat_type, decl, arraytype, *chain = NULL;
1857	char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
1858	int idx;
1859
1860	/* Assumed-rank array. */
1861	if (dimen == -1)
1862	dimen = GFC_MAX_DIMENSIONS;
1863
1864	idx = 2 * (codimen + dimen) + restricted;
1865
1866	gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
1867
1868	if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
1869	{
1870	if (gfc_array_descriptor_base_caf[idx])
1871	return gfc_array_descriptor_base_caf[idx];
1872	}
1873	else if (gfc_array_descriptor_base[idx])
1874	return gfc_array_descriptor_base[idx];
1875
1876	/* Build the type node. */
1877	fat_type = make_node (RECORD_TYPE);
1878
1879	sprintf (s: name, format: "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
1880	TYPE_NAME (fat_type) = get_identifier (name);
1881	TYPE_NAMELESS (fat_type) = 1;
1882
1883	/* Add the data member as the first element of the descriptor. */
1884	gfc_add_field_to_struct_1 (fat_type,
1885	get_identifier ("data"),
1886	(restricted
1887	? prvoid_type_node
1888	: ptr_type_node), &chain);
1889
1890	/* Add the base component. */
1891	decl = gfc_add_field_to_struct_1 (fat_type,
1892	get_identifier ("offset"),
1893	gfc_array_index_type, &chain);
1894	suppress_warning (decl);
1895
1896	/* Add the dtype component. */
1897	decl = gfc_add_field_to_struct_1 (fat_type,
1898	get_identifier ("dtype"),
1899	get_dtype_type_node (), &chain);
1900	suppress_warning (decl);
1901
1902	/* Add the span component. */
1903	decl = gfc_add_field_to_struct_1 (fat_type,
1904	get_identifier ("span"),
1905	gfc_array_index_type, &chain);
1906	suppress_warning (decl);
1907
1908	/* Build the array type for the stride and bound components. */
1909	if (dimen + codimen > 0)
1910	{
1911	arraytype =
1912	build_array_type (gfc_get_desc_dim_type (),
1913	build_range_type (gfc_array_index_type,
1914	gfc_index_zero_node,
1915	gfc_rank_cst[codimen + dimen - 1]));
1916
1917	decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
1918	arraytype, &chain);
1919	suppress_warning (decl);
1920	}
1921
1922	if (flag_coarray == GFC_FCOARRAY_LIB)
1923	{
1924	decl = gfc_add_field_to_struct_1 (fat_type,
1925	get_identifier ("token"),
1926	prvoid_type_node, &chain);
1927	suppress_warning (decl);
1928	}
1929
1930	/* Finish off the type. */
1931	gfc_finish_type (fat_type);
1932	TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1933
1934	if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
1935	gfc_array_descriptor_base_caf[idx] = fat_type;
1936	else
1937	gfc_array_descriptor_base[idx] = fat_type;
1938
1939	return fat_type;
1940	}
1941
1942
1943	/* Build an array (descriptor) type with given bounds. */
1944
1945	tree
1946	gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
1947	tree * ubound, int packed,
1948	enum gfc_array_kind akind, bool restricted)
1949	{
1950	char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
1951	tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
1952	const char *type_name;
1953	int n;
1954
1955	base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
1956	fat_type = build_distinct_type_copy (base_type);
1957	/* Unshare TYPE_FIELDs. */
1958	for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp))
1959	{
1960	tree next = DECL_CHAIN (*tp);
1961	*tp = copy_node (*tp);
1962	DECL_CONTEXT (*tp) = fat_type;
1963	DECL_CHAIN (*tp) = next;
1964	}
1965	/* Make sure that nontarget and target array type have the same canonical
1966	type (and same stub decl for debug info). */
1967	base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted: false);
1968	TYPE_CANONICAL (fat_type) = base_type;
1969	TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
1970	/* Arrays of unknown type must alias with all array descriptors. */
1971	TYPE_TYPELESS_STORAGE (base_type) = 1;
1972	TYPE_TYPELESS_STORAGE (fat_type) = 1;
1973	gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type));
1974
1975	tmp = etype;
1976	if (TREE_CODE (tmp) == ARRAY_TYPE
1977	&& TYPE_STRING_FLAG (tmp))
1978	tmp = TREE_TYPE (etype);
1979	tmp = TYPE_NAME (tmp);
1980	if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1981	tmp = DECL_NAME (tmp);
1982	if (tmp)
1983	type_name = IDENTIFIER_POINTER (tmp);
1984	else
1985	type_name = "unknown";
1986	sprintf (s: name, format: "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
1987	GFC_MAX_SYMBOL_LEN, type_name);
1988	TYPE_NAME (fat_type) = get_identifier (name);
1989	TYPE_NAMELESS (fat_type) = 1;
1990
1991	GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1992	TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();
1993
1994	GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1995	GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
1996	GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1997	GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1998
1999	/* Build an array descriptor record type. */
2000	if (packed != 0)
2001	stride = gfc_index_one_node;
2002	else
2003	stride = NULL_TREE;
2004	for (n = 0; n < dimen + codimen; n++)
2005	{
2006	if (n < dimen)
2007	GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
2008
2009	if (lbound)
2010	lower = lbound[n];
2011	else
2012	lower = NULL_TREE;
2013
2014	if (lower != NULL_TREE)
2015	{
2016	if (INTEGER_CST_P (lower))
2017	GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
2018	else
2019	lower = NULL_TREE;
2020	}
2021
2022	if (codimen && n == dimen + codimen - 1)
2023	break;
2024
2025	upper = ubound[n];
2026	if (upper != NULL_TREE)
2027	{
2028	if (INTEGER_CST_P (upper))
2029	GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
2030	else
2031	upper = NULL_TREE;
2032	}
2033
2034	if (n >= dimen)
2035	continue;
2036
2037	if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
2038	{
2039	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2040	gfc_array_index_type, upper, lower);
2041	tmp = fold_build2_loc (input_location, PLUS_EXPR,
2042	gfc_array_index_type, tmp,
2043	gfc_index_one_node);
2044	stride = fold_build2_loc (input_location, MULT_EXPR,
2045	gfc_array_index_type, tmp, stride);
2046	/* Check the folding worked. */
2047	gcc_assert (INTEGER_CST_P (stride));
2048	}
2049	else
2050	stride = NULL_TREE;
2051	}
2052	GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
2053
2054	/* TODO: known offsets for descriptors. */
2055	GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
2056
2057	if (dimen == 0)
2058	{
2059	arraytype = build_pointer_type (etype);
2060	if (restricted)
2061	arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
2062
2063	GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
2064	return fat_type;
2065	}
2066
2067	/* We define data as an array with the correct size if possible.
2068	Much better than doing pointer arithmetic. */
2069	if (stride)
2070	rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
2071	int_const_binop (MINUS_EXPR, stride,
2072	build_int_cst (TREE_TYPE (stride), 1)));
2073	else
2074	rtype = gfc_array_range_type;
2075	arraytype = build_array_type (etype, rtype);
2076	arraytype = build_pointer_type (arraytype);
2077	if (restricted)
2078	arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
2079	GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
2080
2081	/* This will generate the base declarations we need to emit debug
2082	information for this type. FIXME: there must be a better way to
2083	avoid divergence between compilations with and without debug
2084	information. */
2085	{
2086	struct array_descr_info info;
2087	gfc_get_array_descr_info (fat_type, &info);
2088	gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
2089	}
2090
2091	return fat_type;
2092	}
2093
2094	/* Build a pointer type. This function is called from gfc_sym_type(). */
2095
2096	static tree
2097	gfc_build_pointer_type (gfc_symbol * sym, tree type)
2098	{
2099	/* Array pointer types aren't actually pointers. */
2100	if (sym->attr.dimension)
2101	return type;
2102	else
2103	return build_pointer_type (type);
2104	}
2105
2106	static tree gfc_nonrestricted_type (tree t);
2107	/* Given two record or union type nodes TO and FROM, ensure
2108	that all fields in FROM have a corresponding field in TO,
2109	their type being nonrestrict variants. This accepts a TO
2110	node that already has a prefix of the fields in FROM. */
2111	static void
2112	mirror_fields (tree to, tree from)
2113	{
2114	tree fto, ffrom;
2115	tree *chain;
2116
2117	/* Forward to the end of TOs fields. */
2118	fto = TYPE_FIELDS (to);
2119	ffrom = TYPE_FIELDS (from);
2120	chain = &TYPE_FIELDS (to);
2121	while (fto)
2122	{
2123	gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
2124	chain = &DECL_CHAIN (fto);
2125	fto = DECL_CHAIN (fto);
2126	ffrom = DECL_CHAIN (ffrom);
2127	}
2128
2129	/* Now add all fields remaining in FROM (starting with ffrom). */
2130	for (; ffrom; ffrom = DECL_CHAIN (ffrom))
2131	{
2132	tree newfield = copy_node (ffrom);
2133	DECL_CONTEXT (newfield) = to;
2134	/* The store to DECL_CHAIN might seem redundant with the
2135	stores to *chain, but not clearing it here would mean
2136	leaving a chain into the old fields. If ever
2137	our called functions would look at them confusion
2138	will arise. */
2139	DECL_CHAIN (newfield) = NULL_TREE;
2140	*chain = newfield;
2141	chain = &DECL_CHAIN (newfield);
2142
2143	if (TREE_CODE (ffrom) == FIELD_DECL)
2144	{
2145	tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
2146	TREE_TYPE (newfield) = elemtype;
2147	}
2148	}
2149	*chain = NULL_TREE;
2150	}
2151
2152	/* Given a type T, returns a different type of the same structure,
2153	except that all types it refers to (recursively) are always
2154	non-restrict qualified types. */
2155	static tree
2156	gfc_nonrestricted_type (tree t)
2157	{
2158	tree ret = t;
2159
2160	/* If the type isn't laid out yet, don't copy it. If something
2161	needs it for real it should wait until the type got finished. */
2162	if (!TYPE_SIZE (t))
2163	return t;
2164
2165	if (!TYPE_LANG_SPECIFIC (t))
2166	TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
2167	/* If we're dealing with this very node already further up
2168	the call chain (recursion via pointers and struct members)
2169	we haven't yet determined if we really need a new type node.
2170	Assume we don't, return T itself. */
2171	if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
2172	return t;
2173
2174	/* If we have calculated this all already, just return it. */
2175	if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
2176	return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
2177
2178	/* Mark this type. */
2179	TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
2180
2181	switch (TREE_CODE (t))
2182	{
2183	default:
2184	break;
2185
2186	case POINTER_TYPE:
2187	case REFERENCE_TYPE:
2188	{
2189	tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
2190	if (totype == TREE_TYPE (t))
2191	ret = t;
2192	else if (TREE_CODE (t) == POINTER_TYPE)
2193	ret = build_pointer_type (totype);
2194	else
2195	ret = build_reference_type (totype);
2196	ret = build_qualified_type (ret,
2197	TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
2198	}
2199	break;
2200
2201	case ARRAY_TYPE:
2202	{
2203	tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
2204	if (elemtype == TREE_TYPE (t))
2205	ret = t;
2206	else
2207	{
2208	ret = build_variant_type_copy (t);
2209	TREE_TYPE (ret) = elemtype;
2210	if (TYPE_LANG_SPECIFIC (t)
2211	&& GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
2212	{
2213	tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
2214	dataptr_type = gfc_nonrestricted_type (t: dataptr_type);
2215	if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
2216	{
2217	TYPE_LANG_SPECIFIC (ret)
2218	= ggc_cleared_alloc<struct lang_type> ();
2219	*TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
2220	GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
2221	}
2222	}
2223	}
2224	}
2225	break;
2226
2227	case RECORD_TYPE:
2228	case UNION_TYPE:
2229	case QUAL_UNION_TYPE:
2230	{
2231	tree field;
2232	/* First determine if we need a new type at all.
2233	Careful, the two calls to gfc_nonrestricted_type per field
2234	might return different values. That happens exactly when
2235	one of the fields reaches back to this very record type
2236	(via pointers). The first calls will assume that we don't
2237	need to copy T (see the error_mark_node marking). If there
2238	are any reasons for copying T apart from having to copy T,
2239	we'll indeed copy it, and the second calls to
2240	gfc_nonrestricted_type will use that new node if they
2241	reach back to T. */
2242	for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
2243	if (TREE_CODE (field) == FIELD_DECL)
2244	{
2245	tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
2246	if (elemtype != TREE_TYPE (field))
2247	break;
2248	}
2249	if (!field)
2250	break;
2251	ret = build_variant_type_copy (t);
2252	TYPE_FIELDS (ret) = NULL_TREE;
2253
2254	/* Here we make sure that as soon as we know we have to copy
2255	T, that also fields reaching back to us will use the new
2256	copy. It's okay if that copy still contains the old fields,
2257	we won't look at them. */
2258	TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
2259	mirror_fields (to: ret, from: t);
2260	}
2261	break;
2262	}
2263
2264	TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
2265	return ret;
2266	}
2267
2268
2269	/* Return the type for a symbol. Special handling is required for character
2270	types to get the correct level of indirection.
2271	For functions return the return type.
2272	For subroutines return void_type_node.
2273	Calling this multiple times for the same symbol should be avoided,
2274	especially for character and array types. */
2275
2276	tree
2277	gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
2278	{
2279	tree type;
2280	int byref;
2281	bool restricted;
2282
2283	/* Procedure Pointers inside COMMON blocks. */
2284	if (sym->attr.proc_pointer && sym->attr.in_common)
2285	{
2286	/* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
2287	sym->attr.proc_pointer = 0;
2288	type = build_pointer_type (gfc_get_function_type (sym));
2289	sym->attr.proc_pointer = 1;
2290	return type;
2291	}
2292
2293	if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2294	return void_type_node;
2295
2296	/* In the case of a function the fake result variable may have a
2297	type different from the function type, so don't return early in
2298	that case. */
2299	if (sym->backend_decl && !sym->attr.function)
2300	return TREE_TYPE (sym->backend_decl);
2301
2302	if (sym->attr.result
2303	&& sym->ts.type == BT_CHARACTER
2304	&& sym->ts.u.cl->backend_decl == NULL_TREE
2305	&& sym->ns->proc_name
2306	&& sym->ns->proc_name->ts.u.cl
2307	&& sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE)
2308	sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl;
2309
2310	if (sym->ts.type == BT_CHARACTER
2311	&& ((sym->attr.function && sym->attr.is_bind_c)
2312	|| ((sym->attr.result || sym->attr.value)
2313	&& sym->ns->proc_name
2314	&& sym->ns->proc_name->attr.is_bind_c)
2315	|| (sym->ts.deferred && (!sym->ts.u.cl
2316	|| !sym->ts.u.cl->backend_decl))
2317	|| (sym->attr.dummy
2318	&& sym->attr.value
2319	&& gfc_length_one_character_type_p (ts: &sym->ts))))
2320	type = gfc_get_char_type (kind: sym->ts.kind);
2321	else
2322	type = gfc_typenode_for_spec (spec: &sym->ts, codim: sym->attr.codimension);
2323
2324	if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
2325	&& !sym->pass_as_value)
2326	byref = 1;
2327	else
2328	byref = 0;
2329
2330	restricted = !sym->attr.target && !sym->attr.pointer
2331	&& !sym->attr.proc_pointer && !sym->attr.cray_pointee;
2332	if (!restricted)
2333	type = gfc_nonrestricted_type (t: type);
2334
2335	/* Dummy argument to a bind(C) procedure. */
2336	if (is_bind_c && is_CFI_desc (sym, NULL))
2337	type = gfc_get_cfi_type (dimen: sym->attr.dimension ? sym->as->rank : 0,
2338	/* restricted = */ false);
2339	else if (sym->attr.dimension || sym->attr.codimension)
2340	{
2341	if (gfc_is_nodesc_array (sym))
2342	{
2343	/* If this is a character argument of unknown length, just use the
2344	base type. */
2345	if (sym->ts.type != BT_CHARACTER
2346	|| !(sym->attr.dummy || sym->attr.function)
2347	|| sym->ts.u.cl->backend_decl)
2348	{
2349	type = gfc_get_nodesc_array_type (etype: type, as: sym->as,
2350	packed: byref ? PACKED_FULL
2351	: PACKED_STATIC,
2352	restricted);
2353	byref = 0;
2354	}
2355	}
2356	else
2357	{
2358	enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
2359	if (sym->attr.pointer)
2360	akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2361	: GFC_ARRAY_POINTER;
2362	else if (sym->attr.allocatable)
2363	akind = GFC_ARRAY_ALLOCATABLE;
2364	type = gfc_build_array_type (type, as: sym->as, akind, restricted,
2365	contiguous: sym->attr.contiguous, codim: false);
2366	}
2367	}
2368	else
2369	{
2370	if (sym->attr.allocatable || sym->attr.pointer
2371	|| gfc_is_associate_pointer (sym))
2372	type = gfc_build_pointer_type (sym, type);
2373	}
2374
2375	/* We currently pass all parameters by reference.
2376	See f95_get_function_decl. For dummy function parameters return the
2377	function type. */
2378	if (byref)
2379	{
2380	/* We must use pointer types for potentially absent variables. The
2381	optimizers assume a reference type argument is never NULL. */
2382	if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
2383	|| sym->attr.optional
2384	|| (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
2385	type = build_pointer_type (type);
2386	else
2387	{
2388	type = build_reference_type (type);
2389	if (restricted)
2390	type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
2391	}
2392	}
2393
2394	return (type);
2395	}
2396
2397	/* Layout and output debug info for a record type. */
2398
2399	void
2400	gfc_finish_type (tree type)
2401	{
2402	tree decl;
2403
2404	decl = build_decl (input_location,
2405	TYPE_DECL, NULL_TREE, type);
2406	TYPE_STUB_DECL (type) = decl;
2407	layout_type (type);
2408	rest_of_type_compilation (type, 1);
2409	rest_of_decl_compilation (decl, 1, 0);
2410	}
2411
2412	/* Add a field of given NAME and TYPE to the context of a UNION_TYPE
2413	or RECORD_TYPE pointed to by CONTEXT. The new field is chained
2414	to the end of the field list pointed to by *CHAIN.
2415
2416	Returns a pointer to the new field. */
2417
2418	static tree
2419	gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
2420	{
2421	tree decl = build_decl (input_location, FIELD_DECL, name, type);
2422
2423	DECL_CONTEXT (decl) = context;
2424	DECL_CHAIN (decl) = NULL_TREE;
2425	if (TYPE_FIELDS (context) == NULL_TREE)
2426	TYPE_FIELDS (context) = decl;
2427	if (chain != NULL)
2428	{
2429	if (*chain != NULL)
2430	**chain = decl;
2431	*chain = &DECL_CHAIN (decl);
2432	}
2433
2434	return decl;
2435	}
2436
2437	/* Like `gfc_add_field_to_struct_1', but adds alignment
2438	information. */
2439
2440	tree
2441	gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
2442	{
2443	tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
2444
2445	DECL_INITIAL (decl) = 0;
2446	SET_DECL_ALIGN (decl, 0);
2447	DECL_USER_ALIGN (decl) = 0;
2448
2449	return decl;
2450	}
2451
2452
2453	/* Copy the backend_decl and component backend_decls if
2454	the two derived type symbols are "equal", as described
2455	in 4.4.2 and resolved by gfc_compare_derived_types. */
2456
2457	bool
2458	gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
2459	bool from_gsym)
2460	{
2461	gfc_component *to_cm;
2462	gfc_component *from_cm;
2463
2464	if (from == to)
2465	return 1;
2466
2467	if (from->backend_decl == NULL
2468	|| !gfc_compare_derived_types (from, to))
2469	return 0;
2470
2471	to->backend_decl = from->backend_decl;
2472
2473	to_cm = to->components;
2474	from_cm = from->components;
2475
2476	/* Copy the component declarations. If a component is itself
2477	a derived type, we need a copy of its component declarations.
2478	This is done by recursing into gfc_get_derived_type and
2479	ensures that the component's component declarations have
2480	been built. If it is a character, we need the character
2481	length, as well. */
2482	for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
2483	{
2484	to_cm->backend_decl = from_cm->backend_decl;
2485	to_cm->caf_token = from_cm->caf_token;
2486	if (from_cm->ts.type == BT_UNION)
2487	gfc_get_union_type (to_cm->ts.u.derived);
2488	else if (from_cm->ts.type == BT_DERIVED
2489	&& (!from_cm->attr.pointer || from_gsym))
2490	gfc_get_derived_type (derived: to_cm->ts.u.derived);
2491	else if (from_cm->ts.type == BT_CLASS
2492	&& (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
2493	gfc_get_derived_type (derived: to_cm->ts.u.derived);
2494	else if (from_cm->ts.type == BT_CHARACTER)
2495	to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
2496	}
2497
2498	return 1;
2499	}
2500
2501
2502	/* Build a tree node for a procedure pointer component. */
2503
2504	static tree
2505	gfc_get_ppc_type (gfc_component* c)
2506	{
2507	tree t;
2508
2509	/* Explicit interface. */
2510	if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
2511	return build_pointer_type (gfc_get_function_type (c->ts.interface));
2512
2513	/* Implicit interface (only return value may be known). */
2514	if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
2515	t = gfc_typenode_for_spec (spec: &c->ts);
2516	else
2517	t = void_type_node;
2518
2519	/* FIXME: it would be better to provide explicit interfaces in all
2520	cases, since they should be known by the compiler. */
2521	return build_pointer_type (build_function_type (t, NULL_TREE));
2522	}
2523
2524
2525	/* Build a tree node for a union type. Requires building each map
2526	structure which is an element of the union. */
2527
2528	tree
2529	gfc_get_union_type (gfc_symbol *un)
2530	{
2531	gfc_component *map = NULL;
2532	tree typenode = NULL, map_type = NULL, map_field = NULL;
2533	tree *chain = NULL;
2534
2535	if (un->backend_decl)
2536	{
2537	if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp)
2538	return un->backend_decl;
2539	else
2540	typenode = un->backend_decl;
2541	}
2542	else
2543	{
2544	typenode = make_node (UNION_TYPE);
2545	TYPE_NAME (typenode) = get_identifier (un->name);
2546	}
2547
2548	/* Add each contained MAP as a field. */
2549	for (map = un->components; map; map = map->next)
2550	{
2551	gcc_assert (map->ts.type == BT_DERIVED);
2552
2553	/* The map's type node, which is defined within this union's context. */
2554	map_type = gfc_get_derived_type (derived: map->ts.u.derived);
2555	TYPE_CONTEXT (map_type) = typenode;
2556
2557	/* The map field's declaration. */
2558	map_field = gfc_add_field_to_struct(context: typenode, get_identifier(map->name),
2559	type: map_type, chain: &chain);
2560	if (map->loc.lb)
2561	gfc_set_decl_location (map_field, &map->loc);
2562	else if (un->declared_at.lb)
2563	gfc_set_decl_location (map_field, &un->declared_at);
2564
2565	DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
2566	DECL_NAMELESS(map_field) = true;
2567
2568	/* We should never clobber another backend declaration for this map,
2569	because each map component is unique. */
2570	if (!map->backend_decl)
2571	map->backend_decl = map_field;
2572	}
2573
2574	un->backend_decl = typenode;
2575	gfc_finish_type (type: typenode);
2576
2577	return typenode;
2578	}
2579
2580
2581	/* Build a tree node for a derived type. If there are equal
2582	derived types, with different local names, these are built
2583	at the same time. If an equal derived type has been built
2584	in a parent namespace, this is used. */
2585
2586	tree
2587	gfc_get_derived_type (gfc_symbol * derived, int codimen)
2588	{
2589	tree typenode = NULL, field = NULL, field_type = NULL;
2590	tree canonical = NULL_TREE;
2591	tree *chain = NULL;
2592	bool got_canonical = false;
2593	bool unlimited_entity = false;
2594	gfc_component *c;
2595	gfc_namespace *ns;
2596	tree tmp;
2597	bool coarray_flag;
2598
2599	coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
2600	&& derived->module && !derived->attr.vtype;
2601
2602	gcc_assert (!derived->attr.pdt_template);
2603
2604	if (derived->attr.unlimited_polymorphic
2605	|| (flag_coarray == GFC_FCOARRAY_LIB
2606	&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2607	&& (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
2608	|| derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
2609	|| derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
2610	return ptr_type_node;
2611
2612	if (flag_coarray != GFC_FCOARRAY_LIB
2613	&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2614	&& (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
2615	|| derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
2616	return gfc_get_int_type (kind: gfc_default_integer_kind);
2617
2618	if (derived && derived->attr.flavor == FL_PROCEDURE
2619	&& derived->attr.generic)
2620	derived = gfc_find_dt_in_generic (derived);
2621
2622	/* See if it's one of the iso_c_binding derived types. */
2623	if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
2624	{
2625	if (derived->backend_decl)
2626	return derived->backend_decl;
2627
2628	if (derived->intmod_sym_id == ISOCBINDING_PTR)
2629	derived->backend_decl = ptr_type_node;
2630	else
2631	derived->backend_decl = pfunc_type_node;
2632
2633	derived->ts.kind = gfc_index_integer_kind;
2634	derived->ts.type = BT_INTEGER;
2635	/* Set the f90_type to BT_VOID as a way to recognize something of type
2636	BT_INTEGER that needs to fit a void * for the purpose of the
2637	iso_c_binding derived types. */
2638	derived->ts.f90_type = BT_VOID;
2639
2640	return derived->backend_decl;
2641	}
2642
2643	/* If use associated, use the module type for this one. */
2644	if (derived->backend_decl == NULL
2645	&& (derived->attr.use_assoc || derived->attr.used_in_submodule)
2646	&& derived->module
2647	&& gfc_get_module_backend_decl (derived))
2648	goto copy_derived_types;
2649
2650	/* The derived types from an earlier namespace can be used as the
2651	canonical type. */
2652	if (derived->backend_decl == NULL
2653	&& !derived->attr.use_assoc
2654	&& !derived->attr.used_in_submodule
2655	&& gfc_global_ns_list)
2656	{
2657	for (ns = gfc_global_ns_list;
2658	ns->translated && !got_canonical;
2659	ns = ns->sibling)
2660	{
2661	if (ns->derived_types)
2662	{
2663	for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical;
2664	dt = dt->dt_next)
2665	{
2666	gfc_copy_dt_decls_ifequal (from: dt, to: derived, from_gsym: true);
2667	if (derived->backend_decl)
2668	got_canonical = true;
2669	if (dt->dt_next == ns->derived_types)
2670	break;
2671	}
2672	}
2673	}
2674	}
2675
2676	/* Store up the canonical type to be added to this one. */
2677	if (got_canonical)
2678	{
2679	if (TYPE_CANONICAL (derived->backend_decl))
2680	canonical = TYPE_CANONICAL (derived->backend_decl);
2681	else
2682	canonical = derived->backend_decl;
2683
2684	derived->backend_decl = NULL_TREE;
2685	}
2686
2687	/* derived->backend_decl != 0 means we saw it before, but its
2688	components' backend_decl may have not been built. */
2689	if (derived->backend_decl)
2690	{
2691	/* Its components' backend_decl have been built or we are
2692	seeing recursion through the formal arglist of a procedure
2693	pointer component. */
2694	if (TYPE_FIELDS (derived->backend_decl))
2695	return derived->backend_decl;
2696	else if (derived->attr.abstract
2697	&& derived->attr.proc_pointer_comp)
2698	{
2699	/* If an abstract derived type with procedure pointer
2700	components has no other type of component, return the
2701	backend_decl. Otherwise build the components if any of the
2702	non-procedure pointer components have no backend_decl. */
2703	for (c = derived->components; c; c = c->next)
2704	{
2705	bool same_alloc_type = c->attr.allocatable
2706	&& derived == c->ts.u.derived;
2707	if (!c->attr.proc_pointer
2708	&& !same_alloc_type
2709	&& c->backend_decl == NULL)
2710	break;
2711	else if (c->next == NULL)
2712	return derived->backend_decl;
2713	}
2714	typenode = derived->backend_decl;
2715	}
2716	else
2717	typenode = derived->backend_decl;
2718	}
2719	else
2720	{
2721	/* We see this derived type first time, so build the type node. */
2722	typenode = make_node (RECORD_TYPE);
2723	TYPE_NAME (typenode) = get_identifier (derived->name);
2724	TYPE_PACKED (typenode) = flag_pack_derived;
2725	derived->backend_decl = typenode;
2726	}
2727
2728	if (derived->components
2729	&& derived->components->ts.type == BT_DERIVED
2730	&& strcmp (s1: derived->components->name, s2: "_data") == 0
2731	&& derived->components->ts.u.derived->attr.unlimited_polymorphic)
2732	unlimited_entity = true;
2733
2734	/* Go through the derived type components, building them as
2735	necessary. The reason for doing this now is that it is
2736	possible to recurse back to this derived type through a
2737	pointer component (PR24092). If this happens, the fields
2738	will be built and so we can return the type. */
2739	for (c = derived->components; c; c = c->next)
2740	{
2741	bool same_alloc_type = c->attr.allocatable
2742	&& derived == c->ts.u.derived;
2743
2744	if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
2745	c->ts.u.derived->backend_decl = gfc_get_union_type (un: c->ts.u.derived);
2746
2747	if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
2748	continue;
2749
2750	if ((!c->attr.pointer && !c->attr.proc_pointer
2751	&& !same_alloc_type)
2752	|| c->ts.u.derived->backend_decl == NULL)
2753	{
2754	int local_codim = c->attr.codimension ? c->as->corank: codimen;
2755	c->ts.u.derived->backend_decl = gfc_get_derived_type (derived: c->ts.u.derived,
2756	codimen: local_codim);
2757	}
2758
2759	if (c->ts.u.derived->attr.is_iso_c)
2760	{
2761	/* Need to copy the modified ts from the derived type. The
2762	typespec was modified because C_PTR/C_FUNPTR are translated
2763	into (void *) from derived types. */
2764	c->ts.type = c->ts.u.derived->ts.type;
2765	c->ts.kind = c->ts.u.derived->ts.kind;
2766	c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2767	if (c->initializer)
2768	{
2769	c->initializer->ts.type = c->ts.type;
2770	c->initializer->ts.kind = c->ts.kind;
2771	c->initializer->ts.f90_type = c->ts.f90_type;
2772	c->initializer->expr_type = EXPR_NULL;
2773	}
2774	}
2775	}
2776
2777	if (TYPE_FIELDS (derived->backend_decl))
2778	return derived->backend_decl;
2779
2780	/* Build the type member list. Install the newly created RECORD_TYPE
2781	node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
2782	through only the top-level linked list of components so we correctly
2783	build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
2784	types are built as part of gfc_get_union_type. */
2785	for (c = derived->components; c; c = c->next)
2786	{
2787	bool same_alloc_type = c->attr.allocatable
2788	&& derived == c->ts.u.derived;
2789	/* Prevent infinite recursion, when the procedure pointer type is
2790	the same as derived, by forcing the procedure pointer component to
2791	be built as if the explicit interface does not exist. */
2792	if (c->attr.proc_pointer
2793	&& (c->ts.type != BT_DERIVED || (c->ts.u.derived
2794	&& !gfc_compare_derived_types (derived, c->ts.u.derived)))
2795	&& (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
2796	&& !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
2797	field_type = gfc_get_ppc_type (c);
2798	else if (c->attr.proc_pointer && derived->backend_decl)
2799	{
2800	tmp = build_function_type (derived->backend_decl, NULL_TREE);
2801	field_type = build_pointer_type (tmp);
2802	}
2803	else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2804	field_type = c->ts.u.derived->backend_decl;
2805	else if (c->attr.caf_token)
2806	field_type = pvoid_type_node;
2807	else
2808	{
2809	if (c->ts.type == BT_CHARACTER
2810	&& !c->ts.deferred && !c->attr.pdt_string)
2811	{
2812	/* Evaluate the string length. */
2813	gfc_conv_const_charlen (c->ts.u.cl);
2814	gcc_assert (c->ts.u.cl->backend_decl);
2815	}
2816	else if (c->ts.type == BT_CHARACTER)
2817	c->ts.u.cl->backend_decl
2818	= build_int_cst (gfc_charlen_type_node, 0);
2819
2820	field_type = gfc_typenode_for_spec (spec: &c->ts, codim: codimen);
2821	}
2822
2823	/* This returns an array descriptor type. Initialization may be
2824	required. */
2825	if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
2826	{
2827	if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
2828	{
2829	enum gfc_array_kind akind;
2830	if (c->attr.pointer)
2831	akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
2832	: GFC_ARRAY_POINTER;
2833	else
2834	akind = GFC_ARRAY_ALLOCATABLE;
2835	/* Pointers to arrays aren't actually pointer types. The
2836	descriptors are separate, but the data is common. */
2837	field_type = gfc_build_array_type (type: field_type, as: c->as, akind,
2838	restricted: !c->attr.target
2839	&& !c->attr.pointer,
2840	contiguous: c->attr.contiguous,
2841	codim: codimen);
2842	}
2843	else
2844	field_type = gfc_get_nodesc_array_type (etype: field_type, as: c->as,
2845	packed: PACKED_STATIC,
2846	restricted: !c->attr.target);
2847	}
2848	else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
2849	&& !c->attr.proc_pointer
2850	&& !(unlimited_entity && c == derived->components))
2851	field_type = build_pointer_type (field_type);
2852
2853	if (c->attr.pointer || same_alloc_type)
2854	field_type = gfc_nonrestricted_type (t: field_type);
2855
2856	/* vtype fields can point to different types to the base type. */
2857	if (c->ts.type == BT_DERIVED
2858	&& c->ts.u.derived && c->ts.u.derived->attr.vtype)
2859	field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
2860	ptr_mode, true);
2861
2862	/* Ensure that the CLASS language specific flag is set. */
2863	if (c->ts.type == BT_CLASS)
2864	{
2865	if (POINTER_TYPE_P (field_type))
2866	GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
2867	else
2868	GFC_CLASS_TYPE_P (field_type) = 1;
2869	}
2870
2871	field = gfc_add_field_to_struct (context: typenode,
2872	get_identifier (c->name),
2873	type: field_type, chain: &chain);
2874	if (c->loc.lb)
2875	gfc_set_decl_location (field, &c->loc);
2876	else if (derived->declared_at.lb)
2877	gfc_set_decl_location (field, &derived->declared_at);
2878
2879	gfc_finish_decl_attrs (field, &c->attr);
2880
2881	DECL_PACKED (field) |= TYPE_PACKED (typenode);
2882
2883	gcc_assert (field);
2884	if (!c->backend_decl)
2885	c->backend_decl = field;
2886
2887	if (c->attr.pointer && c->attr.dimension
2888	&& !(c->ts.type == BT_DERIVED
2889	&& strcmp (s1: c->name, s2: "_data") == 0))
2890	GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
2891	}
2892
2893	/* Now lay out the derived type, including the fields. */
2894	if (canonical)
2895	TYPE_CANONICAL (typenode) = canonical;
2896
2897	gfc_finish_type (type: typenode);
2898	gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2899	if (derived->module && derived->ns->proc_name
2900	&& derived->ns->proc_name->attr.flavor == FL_MODULE)
2901	{
2902	if (derived->ns->proc_name->backend_decl
2903	&& TREE_CODE (derived->ns->proc_name->backend_decl)
2904	== NAMESPACE_DECL)
2905	{
2906	TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2907	DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2908	= derived->ns->proc_name->backend_decl;
2909	}
2910	}
2911
2912	derived->backend_decl = typenode;
2913
2914	copy_derived_types:
2915
2916	for (c = derived->components; c; c = c->next)
2917	{
2918	/* Do not add a caf_token field for class container components. */
2919	if ((codimen || coarray_flag)
2920	&& !c->attr.dimension && !c->attr.codimension
2921	&& (c->attr.allocatable || c->attr.pointer)
2922	&& !derived->attr.is_class)
2923	{
2924	/* Provide sufficient space to hold "_caf_symbol". */
2925	char caf_name[GFC_MAX_SYMBOL_LEN + 6];
2926	gfc_component *token;
2927	snprintf (s: caf_name, maxlen: sizeof (caf_name), format: "_caf_%s", c->name);
2928	token = gfc_find_component (derived, caf_name, true, true, NULL);
2929	gcc_assert (token);
2930	c->caf_token = token->backend_decl;
2931	suppress_warning (c->caf_token);
2932	}
2933	}
2934
2935	for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
2936	{
2937	gfc_copy_dt_decls_ifequal (from: derived, to: dt, from_gsym: false);
2938	if (dt->dt_next == gfc_derived_types)
2939	break;
2940	}
2941
2942	return derived->backend_decl;
2943	}
2944
2945
2946	bool
2947	gfc_return_by_reference (gfc_symbol * sym)
2948	{
2949	if (!sym->attr.function)
2950	return 0;
2951
2952	if (sym->attr.dimension)
2953	return 1;
2954
2955	if (sym->ts.type == BT_CHARACTER
2956	&& !sym->attr.is_bind_c
2957	&& (!sym->attr.result
2958	|| !sym->ns->proc_name
2959	|| !sym->ns->proc_name->attr.is_bind_c))
2960	return 1;
2961
2962	/* Possibly return complex numbers by reference for g77 compatibility.
2963	We don't do this for calls to intrinsics (as the library uses the
2964	-fno-f2c calling convention), nor for calls to functions which always
2965	require an explicit interface, as no compatibility problems can
2966	arise there. */
2967	if (flag_f2c && sym->ts.type == BT_COMPLEX
2968	&& !sym->attr.pointer
2969	&& !sym->attr.allocatable
2970	&& !sym->attr.intrinsic && !sym->attr.always_explicit)
2971	return 1;
2972
2973	return 0;
2974	}
2975
2976	static tree
2977	gfc_get_mixed_entry_union (gfc_namespace *ns)
2978	{
2979	tree type;
2980	tree *chain = NULL;
2981	char name[GFC_MAX_SYMBOL_LEN + 1];
2982	gfc_entry_list *el, *el2;
2983
2984	gcc_assert (ns->proc_name->attr.mixed_entry_master);
2985	gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2986
2987	snprintf (s: name, GFC_MAX_SYMBOL_LEN, format: "munion.%s", ns->proc_name->name + 7);
2988
2989	/* Build the type node. */
2990	type = make_node (UNION_TYPE);
2991
2992	TYPE_NAME (type) = get_identifier (name);
2993
2994	for (el = ns->entries; el; el = el->next)
2995	{
2996	/* Search for duplicates. */
2997	for (el2 = ns->entries; el2 != el; el2 = el2->next)
2998	if (el2->sym->result == el->sym->result)
2999	break;
3000
3001	if (el == el2)
3002	gfc_add_field_to_struct_1 (context: type,
3003	get_identifier (el->sym->result->name),
3004	type: gfc_sym_type (sym: el->sym->result), chain: &chain);
3005	}
3006
3007	/* Finish off the type. */
3008	gfc_finish_type (type);
3009	TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
3010	return type;
3011	}
3012
3013	/* Create a "fn spec" based on the formal arguments;
3014	cf. create_function_arglist. */
3015
3016	static tree
3017	create_fn_spec (gfc_symbol *sym, tree fntype)
3018	{
3019	char spec[150];
3020	size_t spec_len;
3021	gfc_formal_arglist *f;
3022	tree tmp;
3023
3024	memset (s: &spec, c: 0, n: sizeof (spec));
3025	spec[0] = '.';
3026	spec[1] = ' ';
3027	spec_len = 2;
3028
3029	if (sym->attr.entry_master)
3030	{
3031	spec[spec_len++] = 'R';
3032	spec[spec_len++] = ' ';
3033	}
3034	if (gfc_return_by_reference (sym))
3035	{
3036	gfc_symbol *result = sym->result ? sym->result : sym;
3037
3038	if (result->attr.pointer || sym->attr.proc_pointer)
3039	{
3040	spec[spec_len++] = '.';
3041	spec[spec_len++] = ' ';
3042	}
3043	else
3044	{
3045	spec[spec_len++] = 'w';
3046	spec[spec_len++] = ' ';
3047	}
3048	if (sym->ts.type == BT_CHARACTER)
3049	{
3050	if (!sym->ts.u.cl->length
3051	&& (sym->attr.allocatable || sym->attr.pointer))
3052	spec[spec_len++] = 'w';
3053	else
3054	spec[spec_len++] = 'R';
3055	spec[spec_len++] = ' ';
3056	}
3057	}
3058
3059	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
3060	if (spec_len < sizeof (spec))
3061	{
3062	bool is_class = false;
3063	bool is_pointer = false;
3064
3065	if (f->sym)
3066	{
3067	is_class = f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)
3068	&& f->sym->attr.class_ok;
3069	is_pointer = is_class ? CLASS_DATA (f->sym)->attr.class_pointer
3070	: f->sym->attr.pointer;
3071	}
3072
3073	if (f->sym == NULL || is_pointer || f->sym->attr.target
3074	|| f->sym->attr.external || f->sym->attr.cray_pointer
3075	|| (f->sym->ts.type == BT_DERIVED
3076	&& (f->sym->ts.u.derived->attr.proc_pointer_comp
3077	|| f->sym->ts.u.derived->attr.pointer_comp))
3078	|| (is_class
3079	&& (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
3080	|| CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
3081	|| (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
3082	{
3083	spec[spec_len++] = '.';
3084	spec[spec_len++] = ' ';
3085	}
3086	else if (f->sym->attr.intent == INTENT_IN)
3087	{
3088	spec[spec_len++] = 'r';
3089	spec[spec_len++] = ' ';
3090	}
3091	else if (f->sym)
3092	{
3093	spec[spec_len++] = 'w';
3094	spec[spec_len++] = ' ';
3095	}
3096	}
3097
3098	tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
3099	tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
3100	return build_type_attribute_variant (fntype, tmp);
3101	}
3102
3103
3104	/* NOTE: The returned function type must match the argument list created by
3105	create_function_arglist. */
3106
3107	tree
3108	gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
3109	const char *fnspec)
3110	{
3111	tree type;
3112	vec<tree, va_gc> *typelist = NULL;
3113	vec<tree, va_gc> *hidden_typelist = NULL;
3114	gfc_formal_arglist *f;
3115	gfc_symbol *arg;
3116	int alternate_return = 0;
3117	bool is_varargs = true;
3118
3119	/* Make sure this symbol is a function, a subroutine or the main
3120	program. */
3121	gcc_assert (sym->attr.flavor == FL_PROCEDURE
3122	|| sym->attr.flavor == FL_PROGRAM);
3123
3124	/* To avoid recursing infinitely on recursive types, we use error_mark_node
3125	so that they can be detected here and handled further down. */
3126	if (sym->backend_decl == NULL)
3127	sym->backend_decl = error_mark_node;
3128	else if (sym->backend_decl == error_mark_node)
3129	goto arg_type_list_done;
3130	else if (sym->attr.proc_pointer)
3131	return TREE_TYPE (TREE_TYPE (sym->backend_decl));
3132	else
3133	return TREE_TYPE (sym->backend_decl);
3134
3135	if (sym->attr.entry_master)
3136	/* Additional parameter for selecting an entry point. */
3137	vec_safe_push (v&: typelist, obj: gfc_array_index_type);
3138
3139	if (sym->result)
3140	arg = sym->result;
3141	else
3142	arg = sym;
3143
3144	if (arg->ts.type == BT_CHARACTER)
3145	gfc_conv_const_charlen (arg->ts.u.cl);
3146
3147	/* Some functions we use an extra parameter for the return value. */
3148	if (gfc_return_by_reference (sym))
3149	{
3150	type = gfc_sym_type (sym: arg);
3151	if (arg->ts.type == BT_COMPLEX
3152	|| arg->attr.dimension
3153	|| arg->ts.type == BT_CHARACTER)
3154	type = build_reference_type (type);
3155
3156	vec_safe_push (v&: typelist, obj: type);
3157	if (arg->ts.type == BT_CHARACTER)
3158	{
3159	if (!arg->ts.deferred)
3160	/* Transfer by value. */
3161	vec_safe_push (v&: typelist, obj: gfc_charlen_type_node);
3162	else
3163	/* Deferred character lengths are transferred by reference
3164	so that the value can be returned. */
3165	vec_safe_push (v&: typelist, obj: build_pointer_type(gfc_charlen_type_node));
3166	}
3167	}
3168	if (sym->backend_decl == error_mark_node && actual_args != NULL
3169	&& sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
3170	|| sym->attr.proc == PROC_UNKNOWN))
3171	gfc_get_formal_from_actual_arglist (sym, actual_args);
3172
3173	/* Build the argument types for the function. */
3174	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
3175	{
3176	arg = f->sym;
3177	if (arg)
3178	{
3179	/* Evaluate constant character lengths here so that they can be
3180	included in the type. */
3181	if (arg->ts.type == BT_CHARACTER)
3182	gfc_conv_const_charlen (arg->ts.u.cl);
3183
3184	if (arg->attr.flavor == FL_PROCEDURE)
3185	{
3186	type = gfc_get_function_type (sym: arg);
3187	type = build_pointer_type (type);
3188	}
3189	else
3190	type = gfc_sym_type (sym: arg, is_bind_c: sym->attr.is_bind_c);
3191
3192	/* Parameter Passing Convention
3193
3194	We currently pass all parameters by reference.
3195	Parameters with INTENT(IN) could be passed by value.
3196	The problem arises if a function is called via an implicit
3197	prototype. In this situation the INTENT is not known.
3198	For this reason all parameters to global functions must be
3199	passed by reference. Passing by value would potentially
3200	generate bad code. Worse there would be no way of telling that
3201	this code was bad, except that it would give incorrect results.
3202
3203	Contained procedures could pass by value as these are never
3204	used without an explicit interface, and cannot be passed as
3205	actual parameters for a dummy procedure. */
3206
3207	vec_safe_push (v&: typelist, obj: type);
3208	}
3209	else
3210	{
3211	if (sym->attr.subroutine)
3212	alternate_return = 1;
3213	}
3214	}
3215
3216	/* Add hidden arguments. */
3217	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
3218	{
3219	arg = f->sym;
3220	/* Add hidden string length parameters. */
3221	if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
3222	{
3223	if (!arg->ts.deferred)
3224	/* Transfer by value. */
3225	type = gfc_charlen_type_node;
3226	else
3227	/* Deferred character lengths are transferred by reference
3228	so that the value can be returned. */
3229	type = build_pointer_type (gfc_charlen_type_node);
3230
3231	vec_safe_push (v&: hidden_typelist, obj: type);
3232	}
3233	/* For scalar intrinsic types, VALUE passes the value,
3234	hence, the optional status cannot be transferred via a NULL pointer.
3235	Thus, we will use a hidden argument in that case. */
3236	if (arg
3237	&& arg->attr.optional
3238	&& arg->attr.value
3239	&& !arg->attr.dimension
3240	&& arg->ts.type != BT_CLASS
3241	&& !gfc_bt_struct (arg->ts.type))
3242	vec_safe_push (v&: typelist, boolean_type_node);
3243	/* Coarrays which are descriptorless or assumed-shape pass with
3244	-fcoarray=lib the token and the offset as hidden arguments. */
3245	if (arg
3246	&& flag_coarray == GFC_FCOARRAY_LIB
3247	&& ((arg->ts.type != BT_CLASS
3248	&& arg->attr.codimension
3249	&& !arg->attr.allocatable)
3250	|| (arg->ts.type == BT_CLASS
3251	&& CLASS_DATA (arg)->attr.codimension
3252	&& !CLASS_DATA (arg)->attr.allocatable)))
3253	{
3254	vec_safe_push (v&: hidden_typelist, obj: pvoid_type_node); /* caf_token. */
3255	vec_safe_push (v&: hidden_typelist, obj: gfc_array_index_type); /* caf_offset. */
3256	}
3257	}
3258
3259	/* Put hidden character length, caf_token, caf_offset at the end. */
3260	vec_safe_reserve (v&: typelist, nelems: vec_safe_length (v: hidden_typelist));
3261	vec_safe_splice (dst&: typelist, src: hidden_typelist);
3262
3263	if (!vec_safe_is_empty (v: typelist)
3264	|| sym->attr.is_main_program
3265	|| sym->attr.if_source != IFSRC_UNKNOWN)
3266	is_varargs = false;
3267
3268	if (sym->backend_decl == error_mark_node)
3269	sym->backend_decl = NULL_TREE;
3270
3271	arg_type_list_done:
3272
3273	if (alternate_return)
3274	type = integer_type_node;
3275	else if (!sym->attr.function || gfc_return_by_reference (sym))
3276	type = void_type_node;
3277	else if (sym->attr.mixed_entry_master)
3278	type = gfc_get_mixed_entry_union (ns: sym->ns);
3279	else if (flag_f2c && sym->ts.type == BT_REAL
3280	&& sym->ts.kind == gfc_default_real_kind
3281	&& !sym->attr.pointer
3282	&& !sym->attr.allocatable
3283	&& !sym->attr.always_explicit)
3284	{
3285	/* Special case: f2c calling conventions require that (scalar)
3286	default REAL functions return the C type double instead. f2c
3287	compatibility is only an issue with functions that don't
3288	require an explicit interface, as only these could be
3289	implemented in Fortran 77. */
3290	sym->ts.kind = gfc_default_double_kind;
3291	type = gfc_typenode_for_spec (spec: &sym->ts);
3292	sym->ts.kind = gfc_default_real_kind;
3293	}
3294	else if (sym->result && sym->result->attr.proc_pointer)
3295	/* Procedure pointer return values. */
3296	{
3297	if (sym->result->attr.result && strcmp (s1: sym->name,s2: "ppr@") != 0)
3298	{
3299	/* Unset proc_pointer as gfc_get_function_type
3300	is called recursively. */
3301	sym->result->attr.proc_pointer = 0;
3302	type = build_pointer_type (gfc_get_function_type (sym: sym->result));
3303	sym->result->attr.proc_pointer = 1;
3304	}
3305	else
3306	type = gfc_sym_type (sym: sym->result);
3307	}
3308	else
3309	type = gfc_sym_type (sym);
3310
3311	if (is_varargs)
3312	/* This should be represented as an unprototyped type, not a type
3313	with (...) prototype. */
3314	type = build_function_type (type, NULL_TREE);
3315	else
3316	type = build_function_type_vec (type, typelist);
3317
3318	/* If we were passed an fn spec, add it here, otherwise determine it from
3319	the formal arguments. */
3320	if (fnspec)
3321	{
3322	tree tmp;
3323	int spec_len = strlen (s: fnspec);
3324	tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec));
3325	tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type));
3326	type = build_type_attribute_variant (type, tmp);
3327	}
3328	else
3329	type = create_fn_spec (sym, fntype: type);
3330
3331	return type;
3332	}
3333
3334	/* Language hooks for middle-end access to type nodes. */
3335
3336	/* Return an integer type with BITS bits of precision,
3337	that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
3338
3339	tree
3340	gfc_type_for_size (unsigned bits, int unsignedp)
3341	{
3342	if (!unsignedp)
3343	{
3344	int i;
3345	for (i = 0; i <= MAX_INT_KINDS; ++i)
3346	{
3347	tree type = gfc_integer_types[i];
3348	if (type && bits == TYPE_PRECISION (type))
3349	return type;
3350	}
3351
3352	/* Handle TImode as a special case because it is used by some backends
3353	(e.g. ARM) even though it is not available for normal use. */
3354	#if HOST_BITS_PER_WIDE_INT >= 64
3355	if (bits == TYPE_PRECISION (intTI_type_node))
3356	return intTI_type_node;
3357	#endif
3358
3359	if (bits <= TYPE_PRECISION (intQI_type_node))
3360	return intQI_type_node;
3361	if (bits <= TYPE_PRECISION (intHI_type_node))
3362	return intHI_type_node;
3363	if (bits <= TYPE_PRECISION (intSI_type_node))
3364	return intSI_type_node;
3365	if (bits <= TYPE_PRECISION (intDI_type_node))
3366	return intDI_type_node;
3367	if (bits <= TYPE_PRECISION (intTI_type_node))
3368	return intTI_type_node;
3369	}
3370	else
3371	{
3372	if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
3373	return unsigned_intQI_type_node;
3374	if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
3375	return unsigned_intHI_type_node;
3376	if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
3377	return unsigned_intSI_type_node;
3378	if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
3379	return unsigned_intDI_type_node;
3380	if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
3381	return unsigned_intTI_type_node;
3382	}
3383
3384	return NULL_TREE;
3385	}
3386
3387	/* Return a data type that has machine mode MODE. If the mode is an
3388	integer, then UNSIGNEDP selects between signed and unsigned types. */
3389
3390	tree
3391	gfc_type_for_mode (machine_mode mode, int unsignedp)
3392	{
3393	int i;
3394	tree *base;
3395	scalar_int_mode int_mode;
3396
3397	if (GET_MODE_CLASS (mode) == MODE_FLOAT)
3398	base = gfc_real_types;
3399	else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
3400	base = gfc_complex_types;
3401	else if (is_a <scalar_int_mode> (m: mode, result: &int_mode))
3402	{
3403	tree type = gfc_type_for_size (bits: GET_MODE_PRECISION (mode: int_mode), unsignedp);
3404	return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
3405	}
3406	else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL
3407	&& valid_vector_subparts_p (subparts: GET_MODE_NUNITS (mode)))
3408	{
3409	unsigned int elem_bits = vector_element_size (GET_MODE_PRECISION (mode),
3410	GET_MODE_NUNITS (mode));
3411	tree bool_type = build_nonstandard_boolean_type (elem_bits);
3412	return build_vector_type_for_mode (bool_type, mode);
3413	}
3414	else if (VECTOR_MODE_P (mode)
3415	&& valid_vector_subparts_p (subparts: GET_MODE_NUNITS (mode)))
3416	{
3417	machine_mode inner_mode = GET_MODE_INNER (mode);
3418	tree inner_type = gfc_type_for_mode (mode: inner_mode, unsignedp);
3419	if (inner_type != NULL_TREE)
3420	return build_vector_type_for_mode (inner_type, mode);
3421	return NULL_TREE;
3422	}
3423	else
3424	return NULL_TREE;
3425
3426	for (i = 0; i <= MAX_REAL_KINDS; ++i)
3427	{
3428	tree type = base[i];
3429	if (type && mode == TYPE_MODE (type))
3430	return type;
3431	}
3432
3433	return NULL_TREE;
3434	}
3435
3436	/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
3437	in that case. */
3438
3439	bool
3440	gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
3441	{
3442	int rank, dim;
3443	bool indirect = false;
3444	tree etype, ptype, t, base_decl;
3445	tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
3446	tree lower_suboff, upper_suboff, stride_suboff;
3447	tree dtype, field, rank_off;
3448
3449	if (! GFC_DESCRIPTOR_TYPE_P (type))
3450	{
3451	if (! POINTER_TYPE_P (type))
3452	return false;
3453	type = TREE_TYPE (type);
3454	if (! GFC_DESCRIPTOR_TYPE_P (type))
3455	return false;
3456	indirect = true;
3457	}
3458
3459	rank = GFC_TYPE_ARRAY_RANK (type);
3460	if (rank >= (int) (ARRAY_SIZE (info->dimen)))
3461	return false;
3462
3463	etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3464	gcc_assert (POINTER_TYPE_P (etype));
3465	etype = TREE_TYPE (etype);
3466
3467	/* If the type is not a scalar coarray. */
3468	if (TREE_CODE (etype) == ARRAY_TYPE)
3469	etype = TREE_TYPE (etype);
3470
3471	/* Can't handle variable sized elements yet. */
3472	if (int_size_in_bytes (etype) <= 0)
3473	return false;
3474	/* Nor non-constant lower bounds in assumed shape arrays. */
3475	if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
3476	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3477	{
3478	for (dim = 0; dim < rank; dim++)
3479	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
3480	|| TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
3481	return false;
3482	}
3483
3484	memset (s: info, c: '\0', n: sizeof (*info));
3485	info->ndimensions = rank;
3486	info->ordering = array_descr_ordering_column_major;
3487	info->element_type = etype;
3488	ptype = build_pointer_type (gfc_array_index_type);
3489	base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
3490	if (!base_decl)
3491	{
3492	base_decl = build_debug_expr_decl (type: indirect
3493	? build_pointer_type (ptype) : ptype);
3494	GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
3495	}
3496	info->base_decl = base_decl;
3497	if (indirect)
3498	base_decl = build1 (INDIRECT_REF, ptype, base_decl);
3499
3500	gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
3501	&dim_off, &dim_size, &stride_suboff,
3502	&lower_suboff, &upper_suboff);
3503
3504	t = fold_build_pointer_plus (base_decl, span_off);
3505	elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);
3506
3507	t = base_decl;
3508	if (!integer_zerop (data_off))
3509	t = fold_build_pointer_plus (t, data_off);
3510	t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
3511	info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
3512	if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
3513	info->allocated = build2 (NE_EXPR, logical_type_node,
3514	info->data_location, null_pointer_node);
3515	else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
3516	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
3517	info->associated = build2 (NE_EXPR, logical_type_node,
3518	info->data_location, null_pointer_node);
3519	if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
3520	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
3521	&& dwarf_version >= 5)
3522	{
3523	rank = 1;
3524	info->ndimensions = 1;
3525	t = base_decl;
3526	if (!integer_zerop (dtype_off))
3527	t = fold_build_pointer_plus (t, dtype_off);
3528	dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
3529	field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
3530	rank_off = byte_position (field);
3531	if (!integer_zerop (dtype_off))
3532	t = fold_build_pointer_plus (t, rank_off);
3533
3534	t = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (field)), t);
3535	t = build1 (INDIRECT_REF, TREE_TYPE (field), t);
3536	info->rank = t;
3537	t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
3538	t = size_binop (MULT_EXPR, t, dim_size);
3539	dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
3540	}
3541
3542	for (dim = 0; dim < rank; dim++)
3543	{
3544	t = fold_build_pointer_plus (base_decl,
3545	size_binop (PLUS_EXPR,
3546	dim_off, lower_suboff));
3547	t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3548	info->dimen[dim].lower_bound = t;
3549	t = fold_build_pointer_plus (base_decl,
3550	size_binop (PLUS_EXPR,
3551	dim_off, upper_suboff));
3552	t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3553	info->dimen[dim].upper_bound = t;
3554	if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
3555	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3556	{
3557	/* Assumed shape arrays have known lower bounds. */
3558	info->dimen[dim].upper_bound
3559	= build2 (MINUS_EXPR, gfc_array_index_type,
3560	info->dimen[dim].upper_bound,
3561	info->dimen[dim].lower_bound);
3562	info->dimen[dim].lower_bound
3563	= fold_convert (gfc_array_index_type,
3564	GFC_TYPE_ARRAY_LBOUND (type, dim));
3565	info->dimen[dim].upper_bound
3566	= build2 (PLUS_EXPR, gfc_array_index_type,
3567	info->dimen[dim].lower_bound,
3568	info->dimen[dim].upper_bound);
3569	}
3570	t = fold_build_pointer_plus (base_decl,
3571	size_binop (PLUS_EXPR,
3572	dim_off, stride_suboff));
3573	t = build1 (INDIRECT_REF, gfc_array_index_type, t);
3574	t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
3575	info->dimen[dim].stride = t;
3576	if (dim + 1 < rank)
3577	dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
3578	}
3579
3580	return true;
3581	}
3582
3583
3584	/* Create a type to handle vector subscripts for coarray library calls. It
3585	has the form:
3586	struct caf_vector_t {
3587	size_t nvec; // size of the vector
3588	union {
3589	struct {
3590	void *vector;
3591	int kind;
3592	} v;
3593	struct {
3594	ptrdiff_t lower_bound;
3595	ptrdiff_t upper_bound;
3596	ptrdiff_t stride;
3597	} triplet;
3598	} u;
3599	}
3600	where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
3601	size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
3602
3603	tree
3604	gfc_get_caf_vector_type (int dim)
3605	{
3606	static tree vector_types[GFC_MAX_DIMENSIONS];
3607	static tree vec_type = NULL_TREE;
3608	tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
3609
3610	if (vector_types[dim-1] != NULL_TREE)
3611	return vector_types[dim-1];
3612
3613	if (vec_type == NULL_TREE)
3614	{
3615	chain = 0;
3616	vect_struct_type = make_node (RECORD_TYPE);
3617	tmp = gfc_add_field_to_struct_1 (context: vect_struct_type,
3618	get_identifier ("vector"),
3619	type: pvoid_type_node, chain: &chain);
3620	suppress_warning (tmp);
3621	tmp = gfc_add_field_to_struct_1 (context: vect_struct_type,
3622	get_identifier ("kind"),
3623	integer_type_node, chain: &chain);
3624	suppress_warning (tmp);
3625	gfc_finish_type (type: vect_struct_type);
3626
3627	chain = 0;
3628	triplet_struct_type = make_node (RECORD_TYPE);
3629	tmp = gfc_add_field_to_struct_1 (context: triplet_struct_type,
3630	get_identifier ("lower_bound"),
3631	type: gfc_array_index_type, chain: &chain);
3632	suppress_warning (tmp);
3633	tmp = gfc_add_field_to_struct_1 (context: triplet_struct_type,
3634	get_identifier ("upper_bound"),
3635	type: gfc_array_index_type, chain: &chain);
3636	suppress_warning (tmp);
3637	tmp = gfc_add_field_to_struct_1 (context: triplet_struct_type, get_identifier ("stride"),
3638	type: gfc_array_index_type, chain: &chain);
3639	suppress_warning (tmp);
3640	gfc_finish_type (type: triplet_struct_type);
3641
3642	chain = 0;
3643	union_type = make_node (UNION_TYPE);
3644	tmp = gfc_add_field_to_struct_1 (context: union_type, get_identifier ("v"),
3645	type: vect_struct_type, chain: &chain);
3646	suppress_warning (tmp);
3647	tmp = gfc_add_field_to_struct_1 (context: union_type, get_identifier ("triplet"),
3648	type: triplet_struct_type, chain: &chain);
3649	suppress_warning (tmp);
3650	gfc_finish_type (type: union_type);
3651
3652	chain = 0;
3653	vec_type = make_node (RECORD_TYPE);
3654	tmp = gfc_add_field_to_struct_1 (context: vec_type, get_identifier ("nvec"),
3655	size_type_node, chain: &chain);
3656	suppress_warning (tmp);
3657	tmp = gfc_add_field_to_struct_1 (context: vec_type, get_identifier ("u"),
3658	type: union_type, chain: &chain);
3659	suppress_warning (tmp);
3660	gfc_finish_type (type: vec_type);
3661	TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
3662	}
3663
3664	tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
3665	gfc_rank_cst[dim-1]);
3666	vector_types[dim-1] = build_array_type (vec_type, tmp);
3667	return vector_types[dim-1];
3668	}
3669
3670
3671	tree
3672	gfc_get_caf_reference_type ()
3673	{
3674	static tree reference_type = NULL_TREE;
3675	tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
3676	a_struct_type, u_union_type, tmp, *chain;
3677
3678	if (reference_type != NULL_TREE)
3679	return reference_type;
3680
3681	chain = 0;
3682	c_struct_type = make_node (RECORD_TYPE);
3683	tmp = gfc_add_field_to_struct_1 (context: c_struct_type,
3684	get_identifier ("offset"),
3685	type: gfc_array_index_type, chain: &chain);
3686	suppress_warning (tmp);
3687	tmp = gfc_add_field_to_struct_1 (context: c_struct_type,
3688	get_identifier ("caf_token_offset"),
3689	type: gfc_array_index_type, chain: &chain);
3690	suppress_warning (tmp);
3691	gfc_finish_type (type: c_struct_type);
3692
3693	chain = 0;
3694	s_struct_type = make_node (RECORD_TYPE);
3695	tmp = gfc_add_field_to_struct_1 (context: s_struct_type,
3696	get_identifier ("start"),
3697	type: gfc_array_index_type, chain: &chain);
3698	suppress_warning (tmp);
3699	tmp = gfc_add_field_to_struct_1 (context: s_struct_type,
3700	get_identifier ("end"),
3701	type: gfc_array_index_type, chain: &chain);
3702	suppress_warning (tmp);
3703	tmp = gfc_add_field_to_struct_1 (context: s_struct_type,
3704	get_identifier ("stride"),
3705	type: gfc_array_index_type, chain: &chain);
3706	suppress_warning (tmp);
3707	gfc_finish_type (type: s_struct_type);
3708
3709	chain = 0;
3710	v_struct_type = make_node (RECORD_TYPE);
3711	tmp = gfc_add_field_to_struct_1 (context: v_struct_type,
3712	get_identifier ("vector"),
3713	type: pvoid_type_node, chain: &chain);
3714	suppress_warning (tmp);
3715	tmp = gfc_add_field_to_struct_1 (context: v_struct_type,
3716	get_identifier ("nvec"),
3717	size_type_node, chain: &chain);
3718	suppress_warning (tmp);
3719	tmp = gfc_add_field_to_struct_1 (context: v_struct_type,
3720	get_identifier ("kind"),
3721	integer_type_node, chain: &chain);
3722	suppress_warning (tmp);
3723	gfc_finish_type (type: v_struct_type);
3724
3725	chain = 0;
3726	union_type = make_node (UNION_TYPE);
3727	tmp = gfc_add_field_to_struct_1 (context: union_type, get_identifier ("s"),
3728	type: s_struct_type, chain: &chain);
3729	suppress_warning (tmp);
3730	tmp = gfc_add_field_to_struct_1 (context: union_type, get_identifier ("v"),
3731	type: v_struct_type, chain: &chain);
3732	suppress_warning (tmp);
3733	gfc_finish_type (type: union_type);
3734
3735	tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
3736	gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
3737	dim_union_type = build_array_type (union_type, tmp);
3738
3739	chain = 0;
3740	a_struct_type = make_node (RECORD_TYPE);
3741	tmp = gfc_add_field_to_struct_1 (context: a_struct_type, get_identifier ("mode"),
3742	type: build_array_type (unsigned_char_type_node,
3743	build_range_type (gfc_array_index_type,
3744	gfc_index_zero_node,
3745	gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
3746	chain: &chain);
3747	suppress_warning (tmp);
3748	tmp = gfc_add_field_to_struct_1 (context: a_struct_type,
3749	get_identifier ("static_array_type"),
3750	integer_type_node, chain: &chain);
3751	suppress_warning (tmp);
3752	tmp = gfc_add_field_to_struct_1 (context: a_struct_type, get_identifier ("dim"),
3753	type: dim_union_type, chain: &chain);
3754	suppress_warning (tmp);
3755	gfc_finish_type (type: a_struct_type);
3756
3757	chain = 0;
3758	u_union_type = make_node (UNION_TYPE);
3759	tmp = gfc_add_field_to_struct_1 (context: u_union_type, get_identifier ("c"),
3760	type: c_struct_type, chain: &chain);
3761	suppress_warning (tmp);
3762	tmp = gfc_add_field_to_struct_1 (context: u_union_type, get_identifier ("a"),
3763	type: a_struct_type, chain: &chain);
3764	suppress_warning (tmp);
3765	gfc_finish_type (type: u_union_type);
3766
3767	chain = 0;
3768	reference_type = make_node (RECORD_TYPE);
3769	tmp = gfc_add_field_to_struct_1 (context: reference_type, get_identifier ("next"),
3770	type: build_pointer_type (reference_type), chain: &chain);
3771	suppress_warning (tmp);
3772	tmp = gfc_add_field_to_struct_1 (context: reference_type, get_identifier ("type"),
3773	integer_type_node, chain: &chain);
3774	suppress_warning (tmp);
3775	tmp = gfc_add_field_to_struct_1 (context: reference_type, get_identifier ("item_size"),
3776	size_type_node, chain: &chain);
3777	suppress_warning (tmp);
3778	tmp = gfc_add_field_to_struct_1 (context: reference_type, get_identifier ("u"),
3779	type: u_union_type, chain: &chain);
3780	suppress_warning (tmp);
3781	gfc_finish_type (type: reference_type);
3782	TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");
3783
3784	return reference_type;
3785	}
3786
3787	static tree
3788	gfc_get_cfi_dim_type ()
3789	{
3790	static tree CFI_dim_t = NULL;
3791
3792	if (CFI_dim_t)
3793	return CFI_dim_t;
3794
3795	CFI_dim_t = make_node (RECORD_TYPE);
3796	TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
3797	TYPE_NAMELESS (CFI_dim_t) = 1;
3798	tree field;
3799	tree *chain = NULL;
3800	field = gfc_add_field_to_struct_1 (context: CFI_dim_t, get_identifier ("lower_bound"),
3801	type: gfc_array_index_type, chain: &chain);
3802	suppress_warning (field);
3803	field = gfc_add_field_to_struct_1 (context: CFI_dim_t, get_identifier ("extent"),
3804	type: gfc_array_index_type, chain: &chain);
3805	suppress_warning (field);
3806	field = gfc_add_field_to_struct_1 (context: CFI_dim_t, get_identifier ("sm"),
3807	type: gfc_array_index_type, chain: &chain);
3808	suppress_warning (field);
3809	gfc_finish_type (type: CFI_dim_t);
3810	TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
3811	return CFI_dim_t;
3812	}
3813
3814
3815	/* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
3816	otherwise dim[dimen] is used. */
3817
3818	tree
3819	gfc_get_cfi_type (int dimen, bool restricted)
3820	{
3821	gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);
3822
3823	int idx = 2*(dimen + 1) + restricted;
3824
3825	if (gfc_cfi_descriptor_base[idx])
3826	return gfc_cfi_descriptor_base[idx];
3827
3828	/* Build the type node. */
3829	tree CFI_cdesc_t = make_node (RECORD_TYPE);
3830	char name[GFC_MAX_SYMBOL_LEN + 1];
3831	if (dimen != -1)
3832	sprintf (s: name, format: "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
3833	TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
3834	TYPE_NAMELESS (CFI_cdesc_t) = 1;
3835
3836	tree field;
3837	tree *chain = NULL;
3838	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("base_addr"),
3839	type: (restricted ? prvoid_type_node
3840	: ptr_type_node), chain: &chain);
3841	suppress_warning (field);
3842	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("elem_len"),
3843	size_type_node, chain: &chain);
3844	suppress_warning (field);
3845	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("version"),
3846	integer_type_node, chain: &chain);
3847	suppress_warning (field);
3848	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("rank"),
3849	signed_char_type_node, chain: &chain);
3850	suppress_warning (field);
3851	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("attribute"),
3852	signed_char_type_node, chain: &chain);
3853	suppress_warning (field);
3854	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("type"),
3855	type: get_typenode_from_name (INT16_TYPE),
3856	chain: &chain);
3857	suppress_warning (field);
3858
3859	if (dimen != 0)
3860	{
3861	tree range = NULL_TREE;
3862	if (dimen > 0)
3863	range = gfc_rank_cst[dimen - 1];
3864	range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
3865	range);
3866	tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
3867	field = gfc_add_field_to_struct_1 (context: CFI_cdesc_t, get_identifier ("dim"),
3868	type: CFI_dim_t, chain: &chain);
3869	suppress_warning (field);
3870	}
3871
3872	TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1;
3873	gfc_finish_type (type: CFI_cdesc_t);
3874	gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
3875	return CFI_cdesc_t;
3876	}
3877
3878	#include "gt-fortran-trans-types.h"
3879