1	/* Intrinsic translation
2	Copyright (C) 2002-2026 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-intrinsic.cc-- generate GENERIC trees for calls to intrinsics. */
23
24	#include "config.h"
25	#include "system.h"
26	#include "coretypes.h"
27	#include "memmodel.h"
28	#include "tm.h" /* For UNITS_PER_WORD. */
29	#include "tree.h"
30	#include "gfortran.h"
31	#include "trans.h"
32	#include "stringpool.h"
33	#include "fold-const.h"
34	#include "internal-fn.h"
35	#include "tree-nested.h"
36	#include "stor-layout.h"
37	#include "toplev.h" /* For rest_of_decl_compilation. */
38	#include "arith.h"
39	#include "trans-const.h"
40	#include "trans-types.h"
41	#include "trans-array.h"
42	#include "dependency.h" /* For CAF array alias analysis. */
43	#include "attribs.h"
44	#include "realmpfr.h"
45	#include "constructor.h"
46
47	/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
48
49	/* This maps Fortran intrinsic math functions to external library or GCC
50	builtin functions. */
51	typedef struct GTY(()) gfc_intrinsic_map_t {
52	/* The explicit enum is required to work around inadequacies in the
53	garbage collection/gengtype parsing mechanism. */
54	enum gfc_isym_id id;
55
56	/* Enum value from the "language-independent", aka C-centric, part
57	of gcc, or END_BUILTINS of no such value set. */
58	enum built_in_function float_built_in;
59	enum built_in_function double_built_in;
60	enum built_in_function long_double_built_in;
61	enum built_in_function complex_float_built_in;
62	enum built_in_function complex_double_built_in;
63	enum built_in_function complex_long_double_built_in;
64
65	/* True if the naming pattern is to prepend "c" for complex and
66	append "f" for kind=4. False if the naming pattern is to
67	prepend "_gfortran_" and append "[rc](4|8|10|16)". */
68	bool libm_name;
69
70	/* True if a complex version of the function exists. */
71	bool complex_available;
72
73	/* True if the function should be marked const. */
74	bool is_constant;
75
76	/* The base library name of this function. */
77	const char *name;
78
79	/* Cache decls created for the various operand types. */
80	tree real4_decl;
81	tree real8_decl;
82	tree real10_decl;
83	tree real16_decl;
84	tree complex4_decl;
85	tree complex8_decl;
86	tree complex10_decl;
87	tree complex16_decl;
88	}
89	gfc_intrinsic_map_t;
90
91	/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92	defines complex variants of all of the entries in mathbuiltins.def
93	except for atan2. */
94	#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95	{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96	BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
97	true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99
100	#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101	{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102	BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
103	BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
104	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105
106	#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107	{ GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108	END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109	false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111
112	#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
113	{ GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
114	BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115	true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
116	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117
118	static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
119	{
120	/* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
121	DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
122	to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
123	#include "mathbuiltins.def"
124
125	/* Functions in libgfortran. */
126	LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
127	LIB_FUNCTION (SIND, "sind", false),
128	LIB_FUNCTION (COSD, "cosd", false),
129	LIB_FUNCTION (TAND, "tand", false),
130
131	/* End the list. */
132	LIB_FUNCTION (NONE, NULL, false)
133
134	};
135	#undef OTHER_BUILTIN
136	#undef LIB_FUNCTION
137	#undef DEFINE_MATH_BUILTIN
138	#undef DEFINE_MATH_BUILTIN_C
139
140
141	enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
142
143
144	/* Find the correct variant of a given builtin from its argument. */
145	static tree
146	builtin_decl_for_precision (enum built_in_function base_built_in,
147	int precision)
148	{
149	enum built_in_function i = END_BUILTINS;
150
151	gfc_intrinsic_map_t *m;
152	for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
153	;
154
155	if (precision == TYPE_PRECISION (float_type_node))
156	i = m->float_built_in;
157	else if (precision == TYPE_PRECISION (double_type_node))
158	i = m->double_built_in;
159	else if (precision == TYPE_PRECISION (long_double_type_node)
160	&& (!gfc_real16_is_float128
161	|| long_double_type_node != gfc_float128_type_node))
162	i = m->long_double_built_in;
163	else if (precision == TYPE_PRECISION (gfc_float128_type_node))
164	{
165	/* Special treatment, because it is not exactly a built-in, but
166	a library function. */
167	return m->real16_decl;
168	}
169
170	return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (fncode: i));
171	}
172
173
174	tree
175	gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
176	int kind)
177	{
178	int i = gfc_validate_kind (BT_REAL, kind, false);
179
180	if (gfc_real_kinds[i].c_float128)
181	{
182	/* For _Float128, the story is a bit different, because we return
183	a decl to a library function rather than a built-in. */
184	gfc_intrinsic_map_t *m;
185	for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
186	;
187
188	return m->real16_decl;
189	}
190
191	return builtin_decl_for_precision (base_built_in: double_built_in,
192	precision: gfc_real_kinds[i].mode_precision);
193	}
194
195
196	/* Evaluate the arguments to an intrinsic function. The value
197	of NARGS may be less than the actual number of arguments in EXPR
198	to allow optional "KIND" arguments that are not included in the
199	generated code to be ignored. */
200
201	static void
202	gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
203	tree *argarray, int nargs)
204	{
205	gfc_actual_arglist *actual;
206	gfc_expr *e;
207	gfc_intrinsic_arg *formal;
208	gfc_se argse;
209	int curr_arg;
210
211	formal = expr->value.function.isym->formal;
212	actual = expr->value.function.actual;
213
214	for (curr_arg = 0; curr_arg < nargs; curr_arg++,
215	actual = actual->next,
216	formal = formal ? formal->next : NULL)
217	{
218	gcc_assert (actual);
219	e = actual->expr;
220	/* Skip omitted optional arguments. */
221	if (!e)
222	{
223	--curr_arg;
224	continue;
225	}
226
227	/* Evaluate the parameter. This will substitute scalarized
228	references automatically. */
229	gfc_init_se (&argse, se);
230
231	if (e->ts.type == BT_CHARACTER)
232	{
233	gfc_conv_expr (se: &argse, expr: e);
234	gfc_conv_string_parameter (se: &argse);
235	argarray[curr_arg++] = argse.string_length;
236	gcc_assert (curr_arg < nargs);
237	}
238	else
239	gfc_conv_expr_val (se: &argse, expr: e);
240
241	/* If an optional argument is itself an optional dummy argument,
242	check its presence and substitute a null if absent. */
243	if (e->expr_type == EXPR_VARIABLE
244	&& e->symtree->n.sym->attr.optional
245	&& formal
246	&& formal->optional)
247	gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
248
249	gfc_add_block_to_block (&se->pre, &argse.pre);
250	gfc_add_block_to_block (&se->post, &argse.post);
251	argarray[curr_arg] = argse.expr;
252	}
253	}
254
255	/* Count the number of actual arguments to the intrinsic function EXPR
256	including any "hidden" string length arguments. */
257
258	static unsigned int
259	gfc_intrinsic_argument_list_length (gfc_expr *expr)
260	{
261	int n = 0;
262	gfc_actual_arglist *actual;
263
264	for (actual = expr->value.function.actual; actual; actual = actual->next)
265	{
266	if (!actual->expr)
267	continue;
268
269	if (actual->expr->ts.type == BT_CHARACTER)
270	n += 2;
271	else
272	n++;
273	}
274
275	return n;
276	}
277
278
279	/* Conversions between different types are output by the frontend as
280	intrinsic functions. We implement these directly with inline code. */
281
282	static void
283	gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
284	{
285	tree type;
286	tree *args;
287	int nargs;
288
289	nargs = gfc_intrinsic_argument_list_length (expr);
290	args = XALLOCAVEC (tree, nargs);
291
292	/* Evaluate all the arguments passed. Whilst we're only interested in the
293	first one here, there are other parts of the front-end that assume this
294	and will trigger an ICE if it's not the case. */
295	type = gfc_typenode_for_spec (&expr->ts);
296	gcc_assert (expr->value.function.actual->expr);
297	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
298
299	/* Conversion between character kinds involves a call to a library
300	function. */
301	if (expr->ts.type == BT_CHARACTER)
302	{
303	tree fndecl, var, addr, tmp;
304
305	if (expr->ts.kind == 1
306	&& expr->value.function.actual->expr->ts.kind == 4)
307	fndecl = gfor_fndecl_convert_char4_to_char1;
308	else if (expr->ts.kind == 4
309	&& expr->value.function.actual->expr->ts.kind == 1)
310	fndecl = gfor_fndecl_convert_char1_to_char4;
311	else
312	gcc_unreachable ();
313
314	/* Create the variable storing the converted value. */
315	type = gfc_get_pchar_type (expr->ts.kind);
316	var = gfc_create_var (type, "str");
317	addr = gfc_build_addr_expr (build_pointer_type (type), var);
318
319	/* Call the library function that will perform the conversion. */
320	gcc_assert (nargs >= 2);
321	tmp = build_call_expr_loc (input_location,
322	fndecl, 3, addr, args[0], args[1]);
323	gfc_add_expr_to_block (&se->pre, tmp);
324
325	/* Free the temporary afterwards. */
326	tmp = gfc_call_free (var);
327	gfc_add_expr_to_block (&se->post, tmp);
328
329	se->expr = var;
330	se->string_length = args[0];
331
332	return;
333	}
334
335	/* Conversion from complex to non-complex involves taking the real
336	component of the value. */
337	if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
338	&& expr->ts.type != BT_COMPLEX)
339	{
340	tree artype;
341
342	artype = TREE_TYPE (TREE_TYPE (args[0]));
343	args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
344	args[0]);
345	}
346
347	se->expr = convert (type, args[0]);
348	}
349
350	/* This is needed because the gcc backend only implements
351	FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
352	FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
353	Similarly for CEILING. */
354
355	static tree
356	build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
357	{
358	tree tmp;
359	tree cond;
360	tree argtype;
361	tree intval;
362
363	argtype = TREE_TYPE (arg);
364	arg = gfc_evaluate_now (arg, pblock);
365
366	intval = convert (type, arg);
367	intval = gfc_evaluate_now (intval, pblock);
368
369	tmp = convert (argtype, intval);
370	cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
371	logical_type_node, tmp, arg);
372
373	tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
374	intval, build_int_cst (type, 1));
375	tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
376	return tmp;
377	}
378
379
380	/* Round to nearest integer, away from zero. */
381
382	static tree
383	build_round_expr (tree arg, tree restype)
384	{
385	tree argtype;
386	tree fn;
387	int argprec, resprec;
388
389	argtype = TREE_TYPE (arg);
390	argprec = TYPE_PRECISION (argtype);
391	resprec = TYPE_PRECISION (restype);
392
393	/* Depending on the type of the result, choose the int intrinsic (iround,
394	available only as a builtin, therefore cannot use it for _Float128), long
395	int intrinsic (lround family) or long long intrinsic (llround). If we
396	don't have an appropriate function that converts directly to the integer
397	type (such as kind == 16), just use ROUND, and then convert the result to
398	an integer. We might also need to convert the result afterwards. */
399	if (resprec <= INT_TYPE_SIZE
400	&& argprec <= TYPE_PRECISION (long_double_type_node))
401	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_IROUND, precision: argprec);
402	else if (resprec <= LONG_TYPE_SIZE)
403	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_LROUND, precision: argprec);
404	else if (resprec <= LONG_LONG_TYPE_SIZE)
405	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_LLROUND, precision: argprec);
406	else if (resprec >= argprec)
407	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_ROUND, precision: argprec);
408	else
409	gcc_unreachable ();
410
411	return convert (restype, build_call_expr_loc (input_location,
412	fn, 1, arg));
413	}
414
415
416	/* Convert a real to an integer using a specific rounding mode.
417	Ideally we would just build the corresponding GENERIC node,
418	however the RTL expander only actually supports FIX_TRUNC_EXPR. */
419
420	static tree
421	build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
422	enum rounding_mode op)
423	{
424	switch (op)
425	{
426	case RND_FLOOR:
427	return build_fixbound_expr (pblock, arg, type, up: 0);
428
429	case RND_CEIL:
430	return build_fixbound_expr (pblock, arg, type, up: 1);
431
432	case RND_ROUND:
433	return build_round_expr (arg, restype: type);
434
435	case RND_TRUNC:
436	return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
437
438	default:
439	gcc_unreachable ();
440	}
441	}
442
443
444	/* Round a real value using the specified rounding mode.
445	We use a temporary integer of that same kind size as the result.
446	Values larger than those that can be represented by this kind are
447	unchanged, as they will not be accurate enough to represent the
448	rounding.
449	huge = HUGE (KIND (a))
450	aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
451	*/
452
453	static void
454	gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
455	{
456	tree type;
457	tree itype;
458	tree arg[2];
459	tree tmp;
460	tree cond;
461	tree decl;
462	mpfr_t huge;
463	int n, nargs;
464	int kind;
465
466	kind = expr->ts.kind;
467	nargs = gfc_intrinsic_argument_list_length (expr);
468
469	decl = NULL_TREE;
470	/* We have builtin functions for some cases. */
471	switch (op)
472	{
473	case RND_ROUND:
474	decl = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_ROUND, kind);
475	break;
476
477	case RND_TRUNC:
478	decl = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_TRUNC, kind);
479	break;
480
481	default:
482	gcc_unreachable ();
483	}
484
485	/* Evaluate the argument. */
486	gcc_assert (expr->value.function.actual->expr);
487	gfc_conv_intrinsic_function_args (se, expr, argarray: arg, nargs);
488
489	/* Use a builtin function if one exists. */
490	if (decl != NULL_TREE)
491	{
492	se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
493	return;
494	}
495
496	/* This code is probably redundant, but we'll keep it lying around just
497	in case. */
498	type = gfc_typenode_for_spec (&expr->ts);
499	arg[0] = gfc_evaluate_now (arg[0], &se->pre);
500
501	/* Test if the value is too large to handle sensibly. */
502	gfc_set_model_kind (kind);
503	mpfr_init (huge);
504	n = gfc_validate_kind (BT_INTEGER, kind, false);
505	mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
506	tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
507	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
508	tmp);
509
510	mpfr_neg (huge, huge, GFC_RND_MODE);
511	tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
512	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
513	tmp);
514	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
515	cond, tmp);
516	itype = gfc_get_int_type (kind);
517
518	tmp = build_fix_expr (pblock: &se->pre, arg: arg[0], type: itype, op);
519	tmp = convert (type, tmp);
520	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
521	arg[0]);
522	mpfr_clear (huge);
523	}
524
525
526	/* Convert to an integer using the specified rounding mode. */
527
528	static void
529	gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
530	{
531	tree type;
532	tree *args;
533	int nargs;
534
535	nargs = gfc_intrinsic_argument_list_length (expr);
536	args = XALLOCAVEC (tree, nargs);
537
538	/* Evaluate the argument, we process all arguments even though we only
539	use the first one for code generation purposes. */
540	type = gfc_typenode_for_spec (&expr->ts);
541	gcc_assert (expr->value.function.actual->expr);
542	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
543
544	if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
545	{
546	/* Conversion to a different integer kind. */
547	se->expr = convert (type, args[0]);
548	}
549	else
550	{
551	/* Conversion from complex to non-complex involves taking the real
552	component of the value. */
553	if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
554	&& expr->ts.type != BT_COMPLEX)
555	{
556	tree artype;
557
558	artype = TREE_TYPE (TREE_TYPE (args[0]));
559	args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
560	args[0]);
561	}
562
563	se->expr = build_fix_expr (pblock: &se->pre, arg: args[0], type, op);
564	}
565	}
566
567
568	/* Get the imaginary component of a value. */
569
570	static void
571	gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
572	{
573	tree arg;
574
575	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
576	se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
577	TREE_TYPE (TREE_TYPE (arg)), arg);
578	}
579
580
581	/* Get the complex conjugate of a value. */
582
583	static void
584	gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
585	{
586	tree arg;
587
588	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
589	se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
590	}
591
592
593
594	static tree
595	define_quad_builtin (const char *name, tree type, bool is_const)
596	{
597	tree fndecl;
598	fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
599	type);
600
601	/* Mark the decl as external. */
602	DECL_EXTERNAL (fndecl) = 1;
603	TREE_PUBLIC (fndecl) = 1;
604
605	/* Mark it __attribute__((const)). */
606	TREE_READONLY (fndecl) = is_const;
607
608	rest_of_decl_compilation (fndecl, 1, 0);
609
610	return fndecl;
611	}
612
613	/* Add SIMD attribute for FNDECL built-in if the built-in
614	name is in VECTORIZED_BUILTINS. */
615
616	static void
617	add_simd_flag_for_built_in (tree fndecl)
618	{
619	if (gfc_vectorized_builtins == NULL
620	|| fndecl == NULL_TREE)
621	return;
622
623	const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
624	int *clauses = gfc_vectorized_builtins->get (k: name);
625	if (clauses)
626	{
627	for (unsigned i = 0; i < 3; i++)
628	if (*clauses & (1 << i))
629	{
630	gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
631	tree omp_clause = NULL_TREE;
632	if (simd_type == SIMD_NONE)
633	; /* No SIMD clause. */
634	else
635	{
636	omp_clause_code code
637	= (simd_type == SIMD_INBRANCH
638	? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
639	omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
640	omp_clause = build_tree_list (NULL_TREE, omp_clause);
641	}
642
643	DECL_ATTRIBUTES (fndecl)
644	= tree_cons (get_identifier ("omp declare simd"), omp_clause,
645	DECL_ATTRIBUTES (fndecl));
646	}
647	}
648	}
649
650	/* Set SIMD attribute to all built-in functions that are mentioned
651	in gfc_vectorized_builtins vector. */
652
653	void
654	gfc_adjust_builtins (void)
655	{
656	gfc_intrinsic_map_t *m;
657	for (m = gfc_intrinsic_map;
658	m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
659	{
660	add_simd_flag_for_built_in (fndecl: m->real4_decl);
661	add_simd_flag_for_built_in (fndecl: m->complex4_decl);
662	add_simd_flag_for_built_in (fndecl: m->real8_decl);
663	add_simd_flag_for_built_in (fndecl: m->complex8_decl);
664	add_simd_flag_for_built_in (fndecl: m->real10_decl);
665	add_simd_flag_for_built_in (fndecl: m->complex10_decl);
666	add_simd_flag_for_built_in (fndecl: m->real16_decl);
667	add_simd_flag_for_built_in (fndecl: m->complex16_decl);
668	add_simd_flag_for_built_in (fndecl: m->real16_decl);
669	add_simd_flag_for_built_in (fndecl: m->complex16_decl);
670	}
671
672	/* Release all strings. */
673	if (gfc_vectorized_builtins != NULL)
674	{
675	for (hash_map<nofree_string_hash, int>::iterator it
676	= gfc_vectorized_builtins->begin ();
677	it != gfc_vectorized_builtins->end (); ++it)
678	free (ptr: const_cast<char *> ((*it).first));
679
680	delete gfc_vectorized_builtins;
681	gfc_vectorized_builtins = NULL;
682	}
683	}
684
685	/* Initialize function decls for library functions. The external functions
686	are created as required. Builtin functions are added here. */
687
688	void
689	gfc_build_intrinsic_lib_fndecls (void)
690	{
691	gfc_intrinsic_map_t *m;
692	tree quad_decls[END_BUILTINS + 1];
693
694	if (gfc_real16_is_float128)
695	{
696	/* If we have soft-float types, we create the decls for their
697	C99-like library functions. For now, we only handle _Float128
698	q-suffixed or IEC 60559 f128-suffixed functions. */
699
700	tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
701	tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
702
703	memset (s: quad_decls, c: 0, n: sizeof(tree) * (END_BUILTINS + 1));
704
705	type = gfc_float128_type_node;
706	complex_type = gfc_complex_float128_type_node;
707	/* type (*) (type) */
708	func_1 = build_function_type_list (type, type, NULL_TREE);
709	/* int (*) (type) */
710	func_iround = build_function_type_list (integer_type_node,
711	type, NULL_TREE);
712	/* long (*) (type) */
713	func_lround = build_function_type_list (long_integer_type_node,
714	type, NULL_TREE);
715	/* long long (*) (type) */
716	func_llround = build_function_type_list (long_long_integer_type_node,
717	type, NULL_TREE);
718	/* type (*) (type, type) */
719	func_2 = build_function_type_list (type, type, type, NULL_TREE);
720	/* type (*) (type, type, type) */
721	func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
722	/* type (*) (type, &int) */
723	func_frexp
724	= build_function_type_list (type,
725	type,
726	build_pointer_type (integer_type_node),
727	NULL_TREE);
728	/* type (*) (type, int) */
729	func_scalbn = build_function_type_list (type,
730	type, integer_type_node, NULL_TREE);
731	/* type (*) (complex type) */
732	func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
733	/* complex type (*) (complex type, complex type) */
734	func_cpow
735	= build_function_type_list (complex_type,
736	complex_type, complex_type, NULL_TREE);
737
738	#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
739	#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
740	#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
741
742	/* Only these built-ins are actually needed here. These are used directly
743	from the code, when calling builtin_decl_for_precision() or
744	builtin_decl_for_float_type(). The others are all constructed by
745	gfc_get_intrinsic_lib_fndecl(). */
746	#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
747	quad_decls[BUILT_IN_ ## ID] \
748	= define_quad_builtin (gfc_real16_use_iec_60559 \
749	? NAME "f128" : NAME "q", func_ ## TYPE, \
750	CONST);
751
752	#include "mathbuiltins.def"
753
754	#undef OTHER_BUILTIN
755	#undef LIB_FUNCTION
756	#undef DEFINE_MATH_BUILTIN
757	#undef DEFINE_MATH_BUILTIN_C
758
759	/* There is one built-in we defined manually, because it gets called
760	with builtin_decl_for_precision() or builtin_decl_for_float_type()
761	even though it is not an OTHER_BUILTIN: it is SQRT. */
762	quad_decls[BUILT_IN_SQRT]
763	= define_quad_builtin (name: gfc_real16_use_iec_60559
764	? "sqrtf128" : "sqrtq", type: func_1, is_const: true);
765	}
766
767	/* Add GCC builtin functions. */
768	for (m = gfc_intrinsic_map;
769	m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
770	{
771	if (m->float_built_in != END_BUILTINS)
772	m->real4_decl = builtin_decl_explicit (fncode: m->float_built_in);
773	if (m->complex_float_built_in != END_BUILTINS)
774	m->complex4_decl = builtin_decl_explicit (fncode: m->complex_float_built_in);
775	if (m->double_built_in != END_BUILTINS)
776	m->real8_decl = builtin_decl_explicit (fncode: m->double_built_in);
777	if (m->complex_double_built_in != END_BUILTINS)
778	m->complex8_decl = builtin_decl_explicit (fncode: m->complex_double_built_in);
779
780	/* If real(kind=10) exists, it is always long double. */
781	if (m->long_double_built_in != END_BUILTINS)
782	m->real10_decl = builtin_decl_explicit (fncode: m->long_double_built_in);
783	if (m->complex_long_double_built_in != END_BUILTINS)
784	m->complex10_decl
785	= builtin_decl_explicit (fncode: m->complex_long_double_built_in);
786
787	if (!gfc_real16_is_float128)
788	{
789	if (m->long_double_built_in != END_BUILTINS)
790	m->real16_decl = builtin_decl_explicit (fncode: m->long_double_built_in);
791	if (m->complex_long_double_built_in != END_BUILTINS)
792	m->complex16_decl
793	= builtin_decl_explicit (fncode: m->complex_long_double_built_in);
794	}
795	else if (quad_decls[m->double_built_in] != NULL_TREE)
796	{
797	/* Quad-precision function calls are constructed when first
798	needed by builtin_decl_for_precision(), except for those
799	that will be used directly (define by OTHER_BUILTIN). */
800	m->real16_decl = quad_decls[m->double_built_in];
801	}
802	else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
803	{
804	/* Same thing for the complex ones. */
805	m->complex16_decl = quad_decls[m->double_built_in];
806	}
807	}
808	}
809
810
811	/* Create a fndecl for a simple intrinsic library function. */
812
813	static tree
814	gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
815	{
816	tree type;
817	vec<tree, va_gc> *argtypes;
818	tree fndecl;
819	gfc_actual_arglist *actual;
820	tree *pdecl;
821	gfc_typespec *ts;
822	char name[GFC_MAX_SYMBOL_LEN + 3];
823
824	ts = &expr->ts;
825	if (ts->type == BT_REAL)
826	{
827	switch (ts->kind)
828	{
829	case 4:
830	pdecl = &m->real4_decl;
831	break;
832	case 8:
833	pdecl = &m->real8_decl;
834	break;
835	case 10:
836	pdecl = &m->real10_decl;
837	break;
838	case 16:
839	pdecl = &m->real16_decl;
840	break;
841	default:
842	gcc_unreachable ();
843	}
844	}
845	else if (ts->type == BT_COMPLEX)
846	{
847	gcc_assert (m->complex_available);
848
849	switch (ts->kind)
850	{
851	case 4:
852	pdecl = &m->complex4_decl;
853	break;
854	case 8:
855	pdecl = &m->complex8_decl;
856	break;
857	case 10:
858	pdecl = &m->complex10_decl;
859	break;
860	case 16:
861	pdecl = &m->complex16_decl;
862	break;
863	default:
864	gcc_unreachable ();
865	}
866	}
867	else
868	gcc_unreachable ();
869
870	if (*pdecl)
871	return *pdecl;
872
873	if (m->libm_name)
874	{
875	int n = gfc_validate_kind (BT_REAL, ts->kind, false);
876	if (gfc_real_kinds[n].c_float)
877	snprintf (s: name, maxlen: sizeof (name), format: "%s%s%s",
878	ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
879	else if (gfc_real_kinds[n].c_double)
880	snprintf (s: name, maxlen: sizeof (name), format: "%s%s",
881	ts->type == BT_COMPLEX ? "c" : "", m->name);
882	else if (gfc_real_kinds[n].c_long_double)
883	snprintf (s: name, maxlen: sizeof (name), format: "%s%s%s",
884	ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
885	else if (gfc_real_kinds[n].c_float128)
886	snprintf (s: name, maxlen: sizeof (name), format: "%s%s%s",
887	ts->type == BT_COMPLEX ? "c" : "", m->name,
888	gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
889	else
890	gcc_unreachable ();
891	}
892	else
893	{
894	snprintf (s: name, maxlen: sizeof (name), PREFIX ("%s_%c%d"), m->name,
895	ts->type == BT_COMPLEX ? 'c' : 'r',
896	gfc_type_abi_kind (ts));
897	}
898
899	argtypes = NULL;
900	for (actual = expr->value.function.actual; actual; actual = actual->next)
901	{
902	type = gfc_typenode_for_spec (&actual->expr->ts);
903	vec_safe_push (v&: argtypes, obj: type);
904	}
905	type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
906	fndecl = build_decl (input_location,
907	FUNCTION_DECL, get_identifier (name), type);
908
909	/* Mark the decl as external. */
910	DECL_EXTERNAL (fndecl) = 1;
911	TREE_PUBLIC (fndecl) = 1;
912
913	/* Mark it __attribute__((const)), if possible. */
914	TREE_READONLY (fndecl) = m->is_constant;
915
916	rest_of_decl_compilation (fndecl, 1, 0);
917
918	(*pdecl) = fndecl;
919	return fndecl;
920	}
921
922
923	/* Convert an intrinsic function into an external or builtin call. */
924
925	static void
926	gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
927	{
928	gfc_intrinsic_map_t *m;
929	tree fndecl;
930	tree rettype;
931	tree *args;
932	unsigned int num_args;
933	gfc_isym_id id;
934
935	id = expr->value.function.isym->id;
936	/* Find the entry for this function. */
937	for (m = gfc_intrinsic_map;
938	m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
939	{
940	if (id == m->id)
941	break;
942	}
943
944	if (m->id == GFC_ISYM_NONE)
945	{
946	gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
947	expr->value.function.name, id);
948	}
949
950	/* Get the decl and generate the call. */
951	num_args = gfc_intrinsic_argument_list_length (expr);
952	args = XALLOCAVEC (tree, num_args);
953
954	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
955	fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
956	rettype = TREE_TYPE (TREE_TYPE (fndecl));
957
958	fndecl = build_addr (fndecl);
959	se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
960	}
961
962
963	/* If bounds-checking is enabled, create code to verify at runtime that the
964	string lengths for both expressions are the same (needed for e.g. MERGE).
965	If bounds-checking is not enabled, does nothing. */
966
967	void
968	gfc_trans_same_strlen_check (const char* intr_name, locus* where,
969	tree a, tree b, stmtblock_t* target)
970	{
971	tree cond;
972	tree name;
973
974	/* If bounds-checking is disabled, do nothing. */
975	if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
976	return;
977
978	/* Compare the two string lengths. */
979	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
980
981	/* Output the runtime-check. */
982	name = gfc_build_cstring_const (intr_name);
983	name = gfc_build_addr_expr (pchar_type_node, name);
984	gfc_trans_runtime_check (true, false, cond, target, where,
985	"Unequal character lengths (%ld/%ld) in %s",
986	fold_convert (long_integer_type_node, a),
987	fold_convert (long_integer_type_node, b), name);
988	}
989
990
991	/* The EXPONENT(X) intrinsic function is translated into
992	int ret;
993	return isfinite(X) ? (frexp (X, &ret) , ret) : huge
994	so that if X is a NaN or infinity, the result is HUGE(0).
995	*/
996
997	static void
998	gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
999	{
1000	tree arg, type, res, tmp, frexp, cond, huge;
1001	int i;
1002
1003	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP,
1004	kind: expr->value.function.actual->expr->ts.kind);
1005
1006	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
1007	arg = gfc_evaluate_now (arg, &se->pre);
1008
1009	i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1010	huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1011	cond = build_call_expr_loc (input_location,
1012	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
1013	1, arg);
1014
1015	res = gfc_create_var (integer_type_node, NULL);
1016	tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1017	gfc_build_addr_expr (NULL_TREE, res));
1018	tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1019	tmp, res);
1020	se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1021	cond, tmp, huge);
1022
1023	type = gfc_typenode_for_spec (&expr->ts);
1024	se->expr = fold_convert (type, se->expr);
1025	}
1026
1027
1028	static int caf_call_cnt = 0;
1029
1030	static tree
1031	conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1032	gfc_expr *hash)
1033	{
1034	char *name;
1035	gfc_se argse;
1036	gfc_expr func_index;
1037	gfc_symtree *index_st;
1038	tree func_index_tree;
1039	stmtblock_t blk;
1040
1041	/* Need to get namespace where static variables are possible. */
1042	while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1043	ns = ns->parent;
1044	gcc_assert (ns);
1045
1046	name = xasprintf (pat, caf_call_cnt);
1047	gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1048	free (ptr: name);
1049
1050	index_st->n.sym->attr.flavor = FL_VARIABLE;
1051	index_st->n.sym->attr.save = SAVE_EXPLICIT;
1052	index_st->n.sym->value
1053	= gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1054	&gfc_current_locus);
1055	mpz_set_si (index_st->n.sym->value->value.integer, -1);
1056	index_st->n.sym->ts.type = BT_INTEGER;
1057	index_st->n.sym->ts.kind = gfc_default_integer_kind;
1058	gfc_set_sym_referenced (index_st->n.sym);
1059	memset (s: &func_index, c: 0, n: sizeof (gfc_expr));
1060	gfc_clear_ts (&func_index.ts);
1061	func_index.expr_type = EXPR_VARIABLE;
1062	func_index.symtree = index_st;
1063	func_index.ts = index_st->n.sym->ts;
1064	gfc_commit_symbol (index_st->n.sym);
1065
1066	gfc_init_se (&argse, NULL);
1067	gfc_conv_expr (se: &argse, expr: &func_index);
1068	gfc_add_block_to_block (block, &argse.pre);
1069	func_index_tree = argse.expr;
1070
1071	gfc_init_se (&argse, NULL);
1072	gfc_conv_expr (se: &argse, expr: hash);
1073
1074	gfc_init_block (&blk);
1075	gfc_add_modify (&blk, func_index_tree,
1076	build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1077	argse.expr));
1078	gfc_add_expr_to_block (
1079	block,
1080	build3 (COND_EXPR, void_type_node,
1081	gfc_likely (build2 (EQ_EXPR, logical_type_node, func_index_tree,
1082	build_int_cst (integer_type_node, -1)),
1083	PRED_FIRST_MATCH),
1084	gfc_finish_block (&blk), NULL_TREE));
1085
1086	return func_index_tree;
1087	}
1088
1089	static tree
1090	conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1091	gfc_symbol *data_sym, tree *data_size)
1092	{
1093	char *name;
1094	gfc_symtree *data_st;
1095	gfc_constructor *con;
1096	gfc_expr data, data_init;
1097	gfc_se argse;
1098	tree data_tree;
1099
1100	memset (s: &data, c: 0, n: sizeof (gfc_expr));
1101	gfc_clear_ts (&data.ts);
1102	data.expr_type = EXPR_VARIABLE;
1103	name = xasprintf (pat, caf_call_cnt);
1104	gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1105	free (ptr: name);
1106	data_st->n.sym->attr.flavor = FL_VARIABLE;
1107	data_st->n.sym->ts = data_sym->ts;
1108	data.symtree = data_st;
1109	gfc_set_sym_referenced (data.symtree->n.sym);
1110	data.ts = data_st->n.sym->ts;
1111	gfc_commit_symbol (data_st->n.sym);
1112
1113	memset (s: &data_init, c: 0, n: sizeof (gfc_expr));
1114	gfc_clear_ts (&data_init.ts);
1115	data_init.expr_type = EXPR_STRUCTURE;
1116	data_init.ts = data.ts;
1117	for (gfc_component *comp = data.ts.u.derived->components; comp;
1118	comp = comp->next)
1119	{
1120	con = gfc_constructor_get ();
1121	con->expr = comp->initializer;
1122	comp->initializer = NULL;
1123	gfc_constructor_append (base: &data_init.value.constructor, c: con);
1124	}
1125
1126	if (data.ts.u.derived->components)
1127	{
1128	gfc_init_se (&argse, NULL);
1129	gfc_conv_expr (se: &argse, expr: &data);
1130	data_tree = argse.expr;
1131	gfc_add_expr_to_block (blk,
1132	gfc_trans_structure_assign (data_tree, &data_init,
1133	true, c: true));
1134	gfc_constructor_free (base: data_init.value.constructor);
1135	*data_size = TREE_TYPE (data_tree)->type_common.size_unit;
1136	data_tree = gfc_build_addr_expr (pvoid_type_node, data_tree);
1137	}
1138	else
1139	{
1140	data_tree = build_zero_cst (pvoid_type_node);
1141	*data_size = build_zero_cst (size_type_node);
1142	}
1143
1144	return data_tree;
1145	}
1146
1147	static tree
1148	conv_shape_to_cst (gfc_expr *e)
1149	{
1150	tree tmp = NULL;
1151	for (int d = 0; d < e->rank; ++d)
1152	{
1153	if (!tmp)
1154	tmp = gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind);
1155	else
1156	tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp,
1157	gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind));
1158	}
1159	return fold_convert (size_type_node, tmp);
1160	}
1161
1162	static void
1163	conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1164	tree *team_no)
1165	{
1166	gfc_expr *stat_e, *team_e;
1167
1168	stat_e = gfc_find_stat_co (expr);
1169	if (stat_e)
1170	{
1171	gfc_se stat_se;
1172	gfc_init_se (&stat_se, NULL);
1173	gfc_conv_expr_reference (se: &stat_se, expr: stat_e);
1174	*stat = stat_se.expr;
1175	gfc_add_block_to_block (block, &stat_se.pre);
1176	gfc_add_block_to_block (block, &stat_se.post);
1177	}
1178	else
1179	*stat = null_pointer_node;
1180
1181	team_e = gfc_find_team_co (expr, req_team_type: TEAM_TEAM);
1182	if (team_e)
1183	{
1184	gfc_se team_se;
1185	gfc_init_se (&team_se, NULL);
1186	gfc_conv_expr (se: &team_se, expr: team_e);
1187	*team
1188	= gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
1189	team_se.expr));
1190	gfc_add_block_to_block (block, &team_se.pre);
1191	gfc_add_block_to_block (block, &team_se.post);
1192	}
1193	else
1194	*team = null_pointer_node;
1195
1196	team_e = gfc_find_team_co (expr, req_team_type: TEAM_NUMBER);
1197	if (team_e)
1198	{
1199	gfc_se team_se;
1200	gfc_init_se (&team_se, NULL);
1201	gfc_conv_expr (se: &team_se, expr: team_e);
1202	*team_no = gfc_build_addr_expr (
1203	NULL_TREE,
1204	gfc_trans_force_lval (&team_se.pre,
1205	fold_convert (integer_type_node, team_se.expr)));
1206	gfc_add_block_to_block (block, &team_se.pre);
1207	gfc_add_block_to_block (block, &team_se.post);
1208	}
1209	else
1210	*team_no = null_pointer_node;
1211	}
1212
1213	/* Get data from a remote coarray. */
1214
1215	static void
1216	gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1217	bool may_realloc, symbol_attribute *caf_attr)
1218	{
1219	gfc_expr *array_expr;
1220	tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
1221	dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
1222	opt_src_desc, opt_src_charlen, opt_dest_charlen, team, team_no;
1223	symbol_attribute caf_attr_store;
1224	gfc_namespace *ns;
1225	gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1226	*get_fn_expr = expr->value.function.actual->next->next->expr;
1227	gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1228
1229	gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1230
1231	if (se->ss && se->ss->info->useflags)
1232	{
1233	/* Access the previously obtained result. */
1234	gfc_conv_tmp_array_ref (se);
1235	return;
1236	}
1237
1238	array_expr = expr->value.function.actual->expr;
1239	ns = array_expr->expr_type == EXPR_VARIABLE
1240	&& !array_expr->symtree->n.sym->attr.associate_var
1241	? array_expr->symtree->n.sym->ns
1242	: gfc_current_ns;
1243	type = gfc_typenode_for_spec (&array_expr->ts);
1244
1245	if (caf_attr == NULL)
1246	{
1247	caf_attr_store = gfc_caf_attr (array_expr);
1248	caf_attr = &caf_attr_store;
1249	}
1250
1251	res_var = lhs;
1252
1253	conv_stat_and_team (block: &se->pre, expr, stat: &stat, team: &team, team_no: &team_no);
1254
1255	get_fn_index_tree
1256	= conv_caf_func_index (block: &se->pre, ns, pat: "__caf_get_from_remote_fn_index_%d",
1257	hash: get_fn_hash);
1258	add_data_tree
1259	= conv_caf_add_call_data (blk: &se->pre, ns, pat: "__caf_get_from_remote_add_data_%d",
1260	data_sym: add_data_sym, data_size: &add_data_size);
1261	++caf_call_cnt;
1262
1263	if (array_expr->rank == 0)
1264	{
1265	res_var = gfc_create_var (type, "caf_res");
1266	if (array_expr->ts.type == BT_CHARACTER)
1267	{
1268	gfc_conv_string_length (array_expr->ts.u.cl, array_expr, &se->pre);
1269	se->string_length = array_expr->ts.u.cl->backend_decl;
1270	opt_src_charlen = gfc_build_addr_expr (
1271	NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1272	dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1273	}
1274	else
1275	{
1276	dest_size = res_var->typed.type->type_common.size_unit;
1277	opt_src_charlen
1278	= build_zero_cst (build_pointer_type (size_type_node));
1279	}
1280	dest_data
1281	= gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1282	res_var = build_fold_indirect_ref (dest_data);
1283	dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1284	opt_dest_desc = build_zero_cst (pvoid_type_node);
1285	}
1286	else
1287	{
1288	/* Create temporary. */
1289	may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
1290	type, NULL_TREE, false, false,
1291	false, &array_expr->where)
1292	== NULL_TREE;
1293	res_var = se->ss->info->data.array.descriptor;
1294	if (array_expr->ts.type == BT_CHARACTER)
1295	{
1296	se->string_length = array_expr->ts.u.cl->backend_decl;
1297	opt_src_charlen = gfc_build_addr_expr (
1298	NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1299	dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1300	}
1301	else
1302	{
1303	opt_src_charlen
1304	= build_zero_cst (build_pointer_type (size_type_node));
1305	dest_size = fold_build2 (
1306	MULT_EXPR, size_type_node,
1307	fold_convert (size_type_node,
1308	array_expr->shape
1309	? conv_shape_to_cst (array_expr)
1310	: gfc_conv_descriptor_size (res_var,
1311	array_expr->rank)),
1312	fold_convert (size_type_node,
1313	gfc_conv_descriptor_span_get (res_var)));
1314	}
1315	opt_dest_desc = res_var;
1316	dest_data = gfc_conv_descriptor_data_get (res_var);
1317	opt_dest_desc = gfc_build_addr_expr (NULL_TREE, opt_dest_desc);
1318	if (may_realloc)
1319	{
1320	tmp = gfc_conv_descriptor_data_get (res_var);
1321	tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1322	NULL_TREE, NULL_TREE, true, NULL,
1323	GFC_CAF_COARRAY_NOCOARRAY);
1324	gfc_add_expr_to_block (&se->post, tmp);
1325	}
1326	dest_data
1327	= gfc_build_addr_expr (NULL_TREE,
1328	gfc_trans_force_lval (&se->pre, dest_data));
1329	}
1330
1331	opt_dest_charlen = opt_src_charlen;
1332	caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1333	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1334	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1335
1336	if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1337	|| GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1338	opt_src_desc = build_zero_cst (pvoid_type_node);
1339	else
1340	opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl);
1341
1342	image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1343	gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1344
1345	/* It guarantees memory consistency within the same segment. */
1346	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
1347	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
1348	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1349	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1350	ASM_VOLATILE_P (tmp) = 1;
1351	gfc_add_expr_to_block (&se->pre, tmp);
1352
1353	tmp = build_call_expr_loc (
1354	input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
1355	opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
1356	opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
1357	get_fn_index_tree, add_data_tree, add_data_size, stat, team, team_no);
1358
1359	gfc_add_expr_to_block (&se->pre, tmp);
1360
1361	if (se->ss)
1362	gfc_advance_se_ss_chain (se);
1363
1364	se->expr = res_var;
1365
1366	return;
1367	}
1368
1369	/* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
1370	calls. */
1371
1372	static void
1373	gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1374	{
1375	gfc_expr *caf_expr, *hash, *present_fn;
1376	gfc_symbol *add_data_sym;
1377	tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1378
1379	gcc_assert (e->expr_type == EXPR_FUNCTION
1380	&& e->value.function.isym->id
1381	== GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1382	caf_expr = e->value.function.actual->expr;
1383	hash = e->value.function.actual->next->expr;
1384	present_fn = e->value.function.actual->next->next->expr;
1385	add_data_sym = present_fn->symtree->n.sym->formal->sym;
1386
1387	fn_index = conv_caf_func_index (block: &se->pre, ns: e->symtree->n.sym->ns,
1388	pat: "__caf_present_on_remote_fn_index_%d", hash);
1389	add_data_tree = conv_caf_add_call_data (blk: &se->pre, ns: e->symtree->n.sym->ns,
1390	pat: "__caf_present_on_remote_add_data_%d",
1391	data_sym: add_data_sym, data_size: &add_data_size);
1392	++caf_call_cnt;
1393
1394	caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1395	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1396	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1397
1398	image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1399	gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1400
1401	se->expr
1402	= fold_convert (logical_type_node,
1403	build_call_expr_loc (input_location,
1404	gfor_fndecl_caf_is_present_on_remote,
1405	5, token, image_index, fn_index,
1406	add_data_tree, add_data_size));
1407	}
1408
1409	static tree
1410	conv_caf_send_to_remote (gfc_code *code)
1411	{
1412	gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
1413	gfc_symbol *add_data_sym;
1414	gfc_se lhs_se, rhs_se;
1415	stmtblock_t block;
1416	gfc_namespace *ns;
1417	tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
1418	tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
1419	tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
1420	tree receiver_fn_index_tree, add_data_tree, add_data_size;
1421
1422	gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1423	gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
1424
1425	lhs_expr = code->ext.actual->expr;
1426	rhs_expr = code->ext.actual->next->expr;
1427	lhs_hash = code->ext.actual->next->next->expr;
1428	receiver_fn_expr = code->ext.actual->next->next->next->expr;
1429	add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1430
1431	ns = lhs_expr->expr_type == EXPR_VARIABLE
1432	&& !lhs_expr->symtree->n.sym->attr.associate_var
1433	? lhs_expr->symtree->n.sym->ns
1434	: gfc_current_ns;
1435
1436	gfc_init_block (&block);
1437
1438	/* LHS. */
1439	gfc_init_se (&lhs_se, NULL);
1440	caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1441	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1442	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1443	if (lhs_expr->rank == 0)
1444	{
1445	if (lhs_expr->ts.type == BT_CHARACTER)
1446	{
1447	gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1448	lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1449	opt_lhs_charlen = gfc_build_addr_expr (
1450	NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1451	}
1452	else
1453	opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1454	opt_lhs_desc = null_pointer_node;
1455	}
1456	else
1457	{
1458	gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1459	gfc_add_block_to_block (&block, &lhs_se.pre);
1460	opt_lhs_desc = lhs_se.expr;
1461	if (lhs_expr->ts.type == BT_CHARACTER)
1462	opt_lhs_charlen = gfc_build_addr_expr (
1463	NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1464	else
1465	opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1466	/* Get the third formal argument of the receiver function. (This is the
1467	location where to put the data on the remote image.) Need to look at
1468	the argument in the function decl, because in the gfc_symbol's formal
1469	argument an array may have no descriptor while in the generated
1470	function decl it has. */
1471	tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1472	TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1473	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1474	opt_lhs_desc = null_pointer_node;
1475	else
1476	opt_lhs_desc
1477	= gfc_build_addr_expr (NULL_TREE,
1478	gfc_trans_force_lval (&block, opt_lhs_desc));
1479	}
1480
1481	/* Obtain token, offset and image index for the LHS. */
1482	image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1483	gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
1484
1485	/* RHS. */
1486	gfc_init_se (&rhs_se, NULL);
1487	if (rhs_expr->rank == 0)
1488	{
1489	rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER;
1490	gfc_conv_expr (se: &rhs_se, expr: rhs_expr);
1491	gfc_add_block_to_block (&block, &rhs_se.pre);
1492	opt_rhs_desc = null_pointer_node;
1493	if (rhs_expr->ts.type == BT_CHARACTER)
1494	{
1495	rhs_data
1496	= rhs_expr->expr_type == EXPR_CONSTANT
1497	? gfc_build_addr_expr (NULL_TREE,
1498	gfc_trans_force_lval (&block,
1499	rhs_se.expr))
1500	: rhs_se.expr;
1501	opt_rhs_charlen = gfc_build_addr_expr (
1502	NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1503	rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1504	}
1505	else
1506	{
1507	rhs_data
1508	= gfc_build_addr_expr (NULL_TREE,
1509	gfc_trans_force_lval (&block, rhs_se.expr));
1510	opt_rhs_charlen
1511	= build_zero_cst (build_pointer_type (size_type_node));
1512	rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1513	}
1514	}
1515	else
1516	{
1517	rhs_se.force_tmp = rhs_expr->shape == NULL
1518	|| !gfc_is_simply_contiguous (rhs_expr, false, false);
1519	gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1520	gfc_add_block_to_block (&block, &rhs_se.pre);
1521	opt_rhs_desc = rhs_se.expr;
1522	if (rhs_expr->ts.type == BT_CHARACTER)
1523	{
1524	opt_rhs_charlen = gfc_build_addr_expr (
1525	NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1526	rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1527	}
1528	else
1529	{
1530	opt_rhs_charlen
1531	= build_zero_cst (build_pointer_type (size_type_node));
1532	rhs_size = fold_build2 (
1533	MULT_EXPR, size_type_node,
1534	fold_convert (size_type_node,
1535	rhs_expr->shape
1536	? conv_shape_to_cst (rhs_expr)
1537	: gfc_conv_descriptor_size (rhs_se.expr,
1538	rhs_expr->rank)),
1539	fold_convert (size_type_node,
1540	gfc_conv_descriptor_span_get (rhs_se.expr)));
1541	}
1542
1543	rhs_data = gfc_build_addr_expr (
1544	NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
1545	opt_rhs_desc)));
1546	opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1547	}
1548	gfc_add_block_to_block (&block, &rhs_se.pre);
1549
1550	conv_stat_and_team (block: &block, expr: lhs_expr, stat: &lhs_stat, team: &lhs_team, team_no: &lhs_team_no);
1551
1552	receiver_fn_index_tree
1553	= conv_caf_func_index (block: &block, ns, pat: "__caf_send_to_remote_fn_index_%d",
1554	hash: lhs_hash);
1555	add_data_tree
1556	= conv_caf_add_call_data (blk: &block, ns, pat: "__caf_send_to_remote_add_data_%d",
1557	data_sym: add_data_sym, data_size: &add_data_size);
1558	++caf_call_cnt;
1559
1560	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
1561	token, opt_lhs_desc, opt_lhs_charlen, image_index,
1562	rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
1563	receiver_fn_index_tree, add_data_tree,
1564	add_data_size, lhs_stat, lhs_team, lhs_team_no);
1565
1566	gfc_add_expr_to_block (&block, tmp);
1567	gfc_add_block_to_block (&block, &lhs_se.post);
1568	gfc_add_block_to_block (&block, &rhs_se.post);
1569
1570	/* It guarantees memory consistency within the same segment. */
1571	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
1572	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
1573	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1574	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1575	ASM_VOLATILE_P (tmp) = 1;
1576	gfc_add_expr_to_block (&block, tmp);
1577
1578	return gfc_finish_block (&block);
1579	}
1580
1581	/* Send-get data to a remote coarray. */
1582
1583	static tree
1584	conv_caf_sendget (gfc_code *code)
1585	{
1586	/* lhs stuff */
1587	gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
1588	gfc_symbol *lhs_add_data_sym;
1589	gfc_se lhs_se;
1590	tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
1591	opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
1592	lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
1593	int transfer_rank;
1594
1595	/* rhs stuff */
1596	gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
1597	gfc_symbol *rhs_add_data_sym;
1598	gfc_se rhs_se;
1599	tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
1600	opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
1601	rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
1602
1603	/* shared */
1604	stmtblock_t block;
1605	gfc_namespace *ns;
1606	tree tmp, rhs_size;
1607
1608	gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1609	gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
1610
1611	lhs_expr = code->ext.actual->expr;
1612	rhs_expr = code->ext.actual->next->expr;
1613	lhs_hash = code->ext.actual->next->next->expr;
1614	receiver_fn_expr = code->ext.actual->next->next->next->expr;
1615	rhs_hash = code->ext.actual->next->next->next->next->expr;
1616	sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
1617
1618	lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1619	rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
1620
1621	ns = lhs_expr->expr_type == EXPR_VARIABLE
1622	&& !lhs_expr->symtree->n.sym->attr.associate_var
1623	? lhs_expr->symtree->n.sym->ns
1624	: gfc_current_ns;
1625
1626	gfc_init_block (&block);
1627
1628	lhs_stat = null_pointer_node;
1629	lhs_team = null_pointer_node;
1630	rhs_stat = null_pointer_node;
1631	rhs_team = null_pointer_node;
1632
1633	/* LHS. */
1634	gfc_init_se (&lhs_se, NULL);
1635	lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1636	if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
1637	lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
1638	if (lhs_expr->rank == 0)
1639	{
1640	if (lhs_expr->ts.type == BT_CHARACTER)
1641	{
1642	gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1643	lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1644	opt_lhs_charlen = gfc_build_addr_expr (
1645	NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1646	}
1647	else
1648	opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1649	opt_lhs_desc = null_pointer_node;
1650	}
1651	else
1652	{
1653	gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1654	gfc_add_block_to_block (&block, &lhs_se.pre);
1655	opt_lhs_desc = lhs_se.expr;
1656	if (lhs_expr->ts.type == BT_CHARACTER)
1657	opt_lhs_charlen = gfc_build_addr_expr (
1658	NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1659	else
1660	opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1661	/* Get the third formal argument of the receiver function. (This is the
1662	location where to put the data on the remote image.) Need to look at
1663	the argument in the function decl, because in the gfc_symbol's formal
1664	argument an array may have no descriptor while in the generated
1665	function decl it has. */
1666	tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1667	TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1668	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1669	opt_lhs_desc = null_pointer_node;
1670	else
1671	opt_lhs_desc
1672	= gfc_build_addr_expr (NULL_TREE,
1673	gfc_trans_force_lval (&block, opt_lhs_desc));
1674	}
1675
1676	/* Obtain token, offset and image index for the LHS. */
1677	lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
1678	gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
1679	lhs_expr);
1680
1681	/* RHS. */
1682	rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1683	if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
1684	rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
1685	transfer_rank = rhs_expr->rank;
1686	gfc_expression_rank (rhs_expr);
1687	gfc_init_se (&rhs_se, NULL);
1688	if (rhs_expr->rank == 0)
1689	{
1690	opt_rhs_desc = null_pointer_node;
1691	if (rhs_expr->ts.type == BT_CHARACTER)
1692	{
1693	gfc_conv_expr (se: &rhs_se, expr: rhs_expr);
1694	gfc_add_block_to_block (&block, &rhs_se.pre);
1695	opt_rhs_charlen = gfc_build_addr_expr (
1696	NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1697	rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1698	}
1699	else
1700	{
1701	gfc_typespec *ts
1702	= &sender_fn_expr->symtree->n.sym->formal->next->next->sym->ts;
1703
1704	opt_rhs_charlen
1705	= build_zero_cst (build_pointer_type (size_type_node));
1706	rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
1707	}
1708	}
1709	/* Get the fifth formal argument of the getter function. This is the argument
1710	pointing to the data to get on the remote image. Need to look at the
1711	argument in the function decl, because in the gfc_symbol's formal argument
1712	an array may have no descriptor while in the generated function decl it
1713	has. */
1714	else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
1715	TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1716	TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
1717	{
1718	rhs_se.data_not_needed = 1;
1719	gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1720	gfc_add_block_to_block (&block, &rhs_se.pre);
1721	if (rhs_expr->ts.type == BT_CHARACTER)
1722	{
1723	opt_rhs_charlen = gfc_build_addr_expr (
1724	NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1725	rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1726	}
1727	else
1728	{
1729	opt_rhs_charlen
1730	= build_zero_cst (build_pointer_type (size_type_node));
1731	rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1732	}
1733	opt_rhs_desc = null_pointer_node;
1734	}
1735	else
1736	{
1737	gfc_ref *arr_ref = rhs_expr->ref;
1738	while (arr_ref && arr_ref->type != REF_ARRAY)
1739	arr_ref = arr_ref->next;
1740	rhs_se.force_tmp
1741	= (rhs_expr->shape == NULL
1742	&& (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
1743	|| !gfc_is_simply_contiguous (rhs_expr, false, false);
1744	gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1745	gfc_add_block_to_block (&block, &rhs_se.pre);
1746	opt_rhs_desc = rhs_se.expr;
1747	if (rhs_expr->ts.type == BT_CHARACTER)
1748	{
1749	opt_rhs_charlen = gfc_build_addr_expr (
1750	NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1751	rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1752	}
1753	else
1754	{
1755	opt_rhs_charlen
1756	= build_zero_cst (build_pointer_type (size_type_node));
1757	rhs_size = fold_build2 (
1758	MULT_EXPR, size_type_node,
1759	fold_convert (size_type_node,
1760	rhs_expr->shape
1761	? conv_shape_to_cst (rhs_expr)
1762	: gfc_conv_descriptor_size (rhs_se.expr,
1763	rhs_expr->rank)),
1764	fold_convert (size_type_node,
1765	gfc_conv_descriptor_span_get (rhs_se.expr)));
1766	}
1767
1768	opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1769	}
1770	gfc_add_block_to_block (&block, &rhs_se.pre);
1771
1772	/* Obtain token, offset and image index for the RHS. */
1773	rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
1774	gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
1775	rhs_expr);
1776
1777	/* stat and team. */
1778	conv_stat_and_team (block: &block, expr: lhs_expr, stat: &lhs_stat, team: &lhs_team, team_no: &lhs_team_no);
1779	conv_stat_and_team (block: &block, expr: rhs_expr, stat: &rhs_stat, team: &rhs_team, team_no: &rhs_team_no);
1780
1781	sender_fn_index_tree
1782	= conv_caf_func_index (block: &block, ns, pat: "__caf_transfer_from_fn_index_%d",
1783	hash: rhs_hash);
1784	rhs_add_data_tree
1785	= conv_caf_add_call_data (blk: &block, ns,
1786	pat: "__caf_transfer_from_remote_add_data_%d",
1787	data_sym: rhs_add_data_sym, data_size: &rhs_add_data_size);
1788	receiver_fn_index_tree
1789	= conv_caf_func_index (block: &block, ns, pat: "__caf_transfer_to_remote_fn_index_%d",
1790	hash: lhs_hash);
1791	lhs_add_data_tree
1792	= conv_caf_add_call_data (blk: &block, ns,
1793	pat: "__caf_transfer_to_remote_add_data_%d",
1794	data_sym: lhs_add_data_sym, data_size: &lhs_add_data_size);
1795	++caf_call_cnt;
1796
1797	tmp = build_call_expr_loc (
1798	input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
1799	opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
1800	lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
1801	opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
1802	rhs_add_data_size, rhs_size,
1803	transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
1804	rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
1805
1806	gfc_add_expr_to_block (&block, tmp);
1807	gfc_add_block_to_block (&block, &lhs_se.post);
1808	gfc_add_block_to_block (&block, &rhs_se.post);
1809
1810	/* It guarantees memory consistency within the same segment. */
1811	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
1812	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
1813	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1814	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1815	ASM_VOLATILE_P (tmp) = 1;
1816	gfc_add_expr_to_block (&block, tmp);
1817
1818	return gfc_finish_block (&block);
1819	}
1820
1821
1822	static void
1823	trans_this_image (gfc_se * se, gfc_expr *expr)
1824	{
1825	stmtblock_t loop;
1826	tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1827	ubound, extent, ml, team;
1828	gfc_se argse;
1829	int rank, corank;
1830
1831	/* The case -fcoarray=single is handled elsewhere. */
1832	gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1833
1834	/* Translate team, if present. */
1835	if (expr->value.function.actual->next->next->expr)
1836	{
1837	gfc_init_se (&argse, NULL);
1838	gfc_conv_expr_val (se: &argse, expr: expr->value.function.actual->next->next->expr);
1839	gfc_add_block_to_block (&se->pre, &argse.pre);
1840	gfc_add_block_to_block (&se->post, &argse.post);
1841	team = fold_convert (pvoid_type_node, argse.expr);
1842	}
1843	else
1844	team = null_pointer_node;
1845
1846	/* Argument-free version: THIS_IMAGE(). */
1847	if (expr->value.function.actual->expr == NULL)
1848	{
1849	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1850	team);
1851	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1852	tmp);
1853	return;
1854	}
1855
1856	/* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1857
1858	type = gfc_get_int_type (gfc_default_integer_kind);
1859	corank = expr->value.function.actual->expr->corank;
1860	rank = expr->value.function.actual->expr->rank;
1861
1862	/* Obtain the descriptor of the COARRAY. */
1863	gfc_init_se (&argse, NULL);
1864	argse.want_coarray = 1;
1865	gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1866	gfc_add_block_to_block (&se->pre, &argse.pre);
1867	gfc_add_block_to_block (&se->post, &argse.post);
1868	desc = argse.expr;
1869
1870	if (se->ss)
1871	{
1872	/* Create an implicit second parameter from the loop variable. */
1873	gcc_assert (!expr->value.function.actual->next->expr);
1874	gcc_assert (corank > 0);
1875	gcc_assert (se->loop->dimen == 1);
1876	gcc_assert (se->ss->info->expr == expr);
1877
1878	dim_arg = se->loop->loopvar[0];
1879	dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1880	gfc_array_index_type, dim_arg,
1881	build_int_cst (TREE_TYPE (dim_arg), 1));
1882	gfc_advance_se_ss_chain (se);
1883	}
1884	else
1885	{
1886	/* Use the passed DIM= argument. */
1887	gcc_assert (expr->value.function.actual->next->expr);
1888	gfc_init_se (&argse, NULL);
1889	gfc_conv_expr_type (se: &argse, expr->value.function.actual->next->expr,
1890	gfc_array_index_type);
1891	gfc_add_block_to_block (&se->pre, &argse.pre);
1892	dim_arg = argse.expr;
1893
1894	if (INTEGER_CST_P (dim_arg))
1895	{
1896	if (wi::ltu_p (x: wi::to_wide (t: dim_arg), y: 1)
1897	|| wi::gtu_p (x: wi::to_wide (t: dim_arg),
1898	GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1899	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1900	"dimension index", expr->value.function.isym->name,
1901	&expr->where);
1902	}
1903	else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1904	{
1905	dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1906	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1907	dim_arg,
1908	build_int_cst (TREE_TYPE (dim_arg), 1));
1909	tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1910	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1911	dim_arg, tmp);
1912	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1913	logical_type_node, cond, tmp);
1914	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1915	gfc_msg_fault);
1916	}
1917	}
1918
1919	/* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1920	one always has a dim_arg argument.
1921
1922	m = this_image() - 1
1923	if (corank == 1)
1924	{
1925	sub(1) = m + lcobound(corank)
1926	return;
1927	}
1928	i = rank
1929	min_var = min (rank + corank - 2, rank + dim_arg - 1)
1930	for (;;)
1931	{
1932	extent = gfc_extent(i)
1933	ml = m
1934	m = m/extent
1935	if (i >= min_var)
1936	goto exit_label
1937	i++
1938	}
1939	exit_label:
1940	sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1941	: m + lcobound(corank)
1942	*/
1943
1944	/* this_image () - 1. */
1945	tmp
1946	= build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
1947	tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1948	fold_convert (type, tmp), build_int_cst (type, 1));
1949	if (corank == 1)
1950	{
1951	/* sub(1) = m + lcobound(corank). */
1952	lbound = gfc_conv_descriptor_lbound_get (desc,
1953	build_int_cst (TREE_TYPE (gfc_array_index_type),
1954	corank+rank-1));
1955	lbound = fold_convert (type, lbound);
1956	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1957
1958	se->expr = tmp;
1959	return;
1960	}
1961
1962	m = gfc_create_var (type, NULL);
1963	ml = gfc_create_var (type, NULL);
1964	loop_var = gfc_create_var (integer_type_node, NULL);
1965	min_var = gfc_create_var (integer_type_node, NULL);
1966
1967	/* m = this_image () - 1. */
1968	gfc_add_modify (&se->pre, m, tmp);
1969
1970	/* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1971	tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1972	fold_convert (integer_type_node, dim_arg),
1973	build_int_cst (integer_type_node, rank - 1));
1974	tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1975	build_int_cst (integer_type_node, rank + corank - 2),
1976	tmp);
1977	gfc_add_modify (&se->pre, min_var, tmp);
1978
1979	/* i = rank. */
1980	tmp = build_int_cst (integer_type_node, rank);
1981	gfc_add_modify (&se->pre, loop_var, tmp);
1982
1983	exit_label = gfc_build_label_decl (NULL_TREE);
1984	TREE_USED (exit_label) = 1;
1985
1986	/* Loop body. */
1987	gfc_init_block (&loop);
1988
1989	/* ml = m. */
1990	gfc_add_modify (&loop, ml, m);
1991
1992	/* extent = ... */
1993	lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1994	ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1995	extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1996	extent = fold_convert (type, extent);
1997
1998	/* m = m/extent. */
1999	gfc_add_modify (&loop, m,
2000	fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2001	m, extent));
2002
2003	/* Exit condition: if (i >= min_var) goto exit_label. */
2004	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2005	min_var);
2006	tmp = build1_v (GOTO_EXPR, exit_label);
2007	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2008	build_empty_stmt (input_location));
2009	gfc_add_expr_to_block (&loop, tmp);
2010
2011	/* Increment loop variable: i++. */
2012	gfc_add_modify (&loop, loop_var,
2013	fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2014	loop_var,
2015	integer_one_node));
2016
2017	/* Making the loop... actually loop! */
2018	tmp = gfc_finish_block (&loop);
2019	tmp = build1_v (LOOP_EXPR, tmp);
2020	gfc_add_expr_to_block (&se->pre, tmp);
2021
2022	/* The exit label. */
2023	tmp = build1_v (LABEL_EXPR, exit_label);
2024	gfc_add_expr_to_block (&se->pre, tmp);
2025
2026	/* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2027	: m + lcobound(corank) */
2028
2029	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2030	build_int_cst (TREE_TYPE (dim_arg), corank));
2031
2032	lbound = gfc_conv_descriptor_lbound_get (desc,
2033	fold_build2_loc (input_location, PLUS_EXPR,
2034	gfc_array_index_type, dim_arg,
2035	build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2036	lbound = fold_convert (type, lbound);
2037
2038	tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2039	fold_build2_loc (input_location, MULT_EXPR, type,
2040	m, extent));
2041	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2042
2043	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2044	fold_build2_loc (input_location, PLUS_EXPR, type,
2045	m, lbound));
2046	}
2047
2048
2049	/* Convert a call to image_status. */
2050
2051	static void
2052	conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2053	{
2054	unsigned int num_args;
2055	tree *args, tmp;
2056
2057	num_args = gfc_intrinsic_argument_list_length (expr);
2058	args = XALLOCAVEC (tree, num_args);
2059	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
2060	/* In args[0] the number of the image the status is desired for has to be
2061	given. */
2062
2063	if (flag_coarray == GFC_FCOARRAY_SINGLE)
2064	{
2065	tree arg;
2066	arg = gfc_evaluate_now (args[0], &se->pre);
2067	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2068	fold_convert (integer_type_node, arg),
2069	integer_one_node);
2070	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2071	tmp, integer_zero_node,
2072	build_int_cst (integer_type_node,
2073	GFC_STAT_STOPPED_IMAGE));
2074	}
2075	else if (flag_coarray == GFC_FCOARRAY_LIB)
2076	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2077	args[0],
2078	num_args < 2 ? null_pointer_node : args[1]);
2079	else
2080	gcc_unreachable ();
2081
2082	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2083	}
2084
2085	static void
2086	conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2087	{
2088	unsigned int num_args;
2089
2090	tree *args, tmp;
2091
2092	num_args = gfc_intrinsic_argument_list_length (expr);
2093	args = XALLOCAVEC (tree, num_args);
2094	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
2095
2096	if (flag_coarray ==
2097	GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2098	tmp = gfc_evaluate_now (args[0], &se->pre);
2099	else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2100	{
2101	// the value -1 represents that no team has been created yet
2102	tmp = build_int_cst (integer_type_node, -1);
2103	}
2104	else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2105	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2106	args[0]);
2107	else if (flag_coarray == GFC_FCOARRAY_LIB)
2108	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2109	null_pointer_node);
2110	else
2111	gcc_unreachable ();
2112
2113	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2114	}
2115
2116
2117	static void
2118	trans_image_index (gfc_se * se, gfc_expr *expr)
2119	{
2120	tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2121	invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2122	gfc_se argse, subse;
2123	int rank, corank, codim;
2124
2125	type = gfc_get_int_type (gfc_default_integer_kind);
2126	corank = expr->value.function.actual->expr->corank;
2127	rank = expr->value.function.actual->expr->rank;
2128
2129	/* Obtain the descriptor of the COARRAY. */
2130	gfc_init_se (&argse, NULL);
2131	argse.want_coarray = 1;
2132	gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2133	gfc_add_block_to_block (&se->pre, &argse.pre);
2134	gfc_add_block_to_block (&se->post, &argse.post);
2135	desc = argse.expr;
2136
2137	/* Obtain a handle to the SUB argument. */
2138	gfc_init_se (&subse, NULL);
2139	gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2140	gfc_add_block_to_block (&se->pre, &subse.pre);
2141	gfc_add_block_to_block (&se->post, &subse.post);
2142	subdesc = build_fold_indirect_ref_loc (input_location,
2143	gfc_conv_descriptor_data_get (subse.expr));
2144
2145	if (expr->value.function.actual->next->next->expr)
2146	{
2147	gfc_init_se (&argse, NULL);
2148	gfc_conv_expr_descriptor (&argse,
2149	expr->value.function.actual->next->next->expr);
2150	if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
2151	team = argse.expr;
2152	else
2153	team_number = gfc_build_addr_expr (
2154	NULL_TREE,
2155	gfc_trans_force_lval (&argse.pre,
2156	fold_convert (integer_type_node, argse.expr)));
2157	gfc_add_block_to_block (&se->pre, &argse.pre);
2158	gfc_add_block_to_block (&se->post, &argse.post);
2159	}
2160
2161	/* Fortran 2008 does not require that the values remain in the cobounds,
2162	thus we need explicitly check this - and return 0 if they are exceeded. */
2163
2164	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2165	tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2166	invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2167	fold_convert (gfc_array_index_type, tmp),
2168	lbound);
2169
2170	for (codim = corank + rank - 2; codim >= rank; codim--)
2171	{
2172	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2173	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2174	tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2175	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2176	fold_convert (gfc_array_index_type, tmp),
2177	lbound);
2178	invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2179	logical_type_node, invalid_bound, cond);
2180	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2181	fold_convert (gfc_array_index_type, tmp),
2182	ubound);
2183	invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2184	logical_type_node, invalid_bound, cond);
2185	}
2186
2187	invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2188
2189	/* See Fortran 2008, C.10 for the following algorithm. */
2190
2191	/* coindex = sub(corank) - lcobound(n). */
2192	coindex = fold_convert (gfc_array_index_type,
2193	gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2194	NULL));
2195	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2196	coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2197	fold_convert (gfc_array_index_type, coindex),
2198	lbound);
2199
2200	for (codim = corank + rank - 2; codim >= rank; codim--)
2201	{
2202	tree extent, ubound;
2203
2204	/* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2205	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2206	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2207	extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2208
2209	/* coindex *= extent. */
2210	coindex = fold_build2_loc (input_location, MULT_EXPR,
2211	gfc_array_index_type, coindex, extent);
2212
2213	/* coindex += sub(codim). */
2214	tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2215	coindex = fold_build2_loc (input_location, PLUS_EXPR,
2216	gfc_array_index_type, coindex,
2217	fold_convert (gfc_array_index_type, tmp));
2218
2219	/* coindex -= lbound(codim). */
2220	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2221	coindex = fold_build2_loc (input_location, MINUS_EXPR,
2222	gfc_array_index_type, coindex, lbound);
2223	}
2224
2225	coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2226	fold_convert(type, coindex),
2227	build_int_cst (type, 1));
2228
2229	/* Return 0 if "coindex" exceeds num_images(). */
2230
2231	if (flag_coarray == GFC_FCOARRAY_SINGLE)
2232	num_images = build_int_cst (type, 1);
2233	else
2234	{
2235	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2236	team, team_number);
2237	num_images = fold_convert (type, tmp);
2238	}
2239
2240	tmp = gfc_create_var (type, NULL);
2241	gfc_add_modify (&se->pre, tmp, coindex);
2242
2243	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2244	num_images);
2245	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2246	cond,
2247	fold_convert (logical_type_node, invalid_bound));
2248	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2249	build_int_cst (type, 0), tmp);
2250	}
2251
2252	static void
2253	trans_num_images (gfc_se * se, gfc_expr *expr)
2254	{
2255	tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2256	gfc_se argse;
2257
2258	if (expr->value.function.actual->expr)
2259	{
2260	gfc_init_se (&argse, NULL);
2261	gfc_conv_expr_val (se: &argse, expr: expr->value.function.actual->expr);
2262	if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2263	team = argse.expr;
2264	else
2265	team_number = gfc_build_addr_expr (
2266	NULL_TREE,
2267	gfc_trans_force_lval (&se->pre,
2268	fold_convert (integer_type_node, argse.expr)));
2269	gfc_add_block_to_block (&se->pre, &argse.pre);
2270	gfc_add_block_to_block (&se->post, &argse.post);
2271	}
2272
2273	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2274	team, team_number);
2275	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2276	}
2277
2278
2279	static void
2280	gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2281	{
2282	gfc_se argse;
2283
2284	gfc_init_se (&argse, NULL);
2285	argse.data_not_needed = 1;
2286	argse.descriptor_only = 1;
2287
2288	gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2289	gfc_add_block_to_block (&se->pre, &argse.pre);
2290	gfc_add_block_to_block (&se->post, &argse.post);
2291
2292	se->expr = gfc_conv_descriptor_rank (argse.expr);
2293	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2294	se->expr);
2295	}
2296
2297
2298	static void
2299	gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2300	{
2301	gfc_expr *arg;
2302	arg = expr->value.function.actual->expr;
2303	gfc_conv_is_contiguous_expr (se, arg);
2304	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2305	}
2306
2307	/* This function does the work for gfc_conv_intrinsic_is_contiguous,
2308	plus it can be called directly. */
2309
2310	void
2311	gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2312	{
2313	gfc_ss *ss;
2314	gfc_se argse;
2315	tree desc, tmp, stride, extent, cond;
2316	int i;
2317	tree fncall0;
2318	gfc_array_spec *as;
2319	gfc_symbol *sym = NULL;
2320
2321	if (arg->ts.type == BT_CLASS)
2322	gfc_add_class_array_ref (arg);
2323
2324	if (arg->expr_type == EXPR_VARIABLE)
2325	sym = arg->symtree->n.sym;
2326
2327	ss = gfc_walk_expr (arg);
2328	gcc_assert (ss != gfc_ss_terminator);
2329	gfc_init_se (&argse, NULL);
2330	argse.data_not_needed = 1;
2331	gfc_conv_expr_descriptor (&argse, arg);
2332
2333	as = gfc_get_full_arrayspec_from_expr (expr: arg);
2334
2335	/* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2336	Note in addition that zero-sized arrays don't count as contiguous. */
2337
2338	if (as && as->type == AS_ASSUMED_RANK)
2339	{
2340	/* Build the call to is_contiguous0. */
2341	argse.want_pointer = 1;
2342	gfc_conv_expr_descriptor (&argse, arg);
2343	gfc_add_block_to_block (&se->pre, &argse.pre);
2344	gfc_add_block_to_block (&se->post, &argse.post);
2345	desc = gfc_evaluate_now (argse.expr, &se->pre);
2346	fncall0 = build_call_expr_loc (input_location,
2347	gfor_fndecl_is_contiguous0, 1, desc);
2348	se->expr = fncall0;
2349	se->expr = convert (boolean_type_node, se->expr);
2350	}
2351	else
2352	{
2353	gfc_add_block_to_block (&se->pre, &argse.pre);
2354	gfc_add_block_to_block (&se->post, &argse.post);
2355	desc = gfc_evaluate_now (argse.expr, &se->pre);
2356
2357	stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2358	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2359	stride, build_int_cst (TREE_TYPE (stride), 1));
2360
2361	for (i = 0; i < arg->rank - 1; i++)
2362	{
2363	tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2364	extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2365	extent = fold_build2_loc (input_location, MINUS_EXPR,
2366	gfc_array_index_type, extent, tmp);
2367	extent = fold_build2_loc (input_location, PLUS_EXPR,
2368	gfc_array_index_type, extent,
2369	gfc_index_one_node);
2370	tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2371	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2372	tmp, extent);
2373	stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2374	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2375	stride, tmp);
2376	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2377	boolean_type_node, cond, tmp);
2378	}
2379	se->expr = cond;
2380	}
2381
2382	/* A pointer that does not have the CONTIGUOUS attribute needs to be checked
2383	if it points to an array whose span differs from the element size. */
2384	if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
2385	{
2386	tree span = gfc_conv_descriptor_span_get (desc);
2387	tmp = fold_convert (TREE_TYPE (span),
2388	gfc_conv_descriptor_elem_len (desc));
2389	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2390	span, tmp);
2391	se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2392	boolean_type_node, cond,
2393	convert (boolean_type_node, se->expr));
2394	}
2395
2396	gfc_free_ss_chain (ss);
2397	}
2398
2399
2400	/* Evaluate a single upper or lower bound. */
2401	/* TODO: bound intrinsic generates way too much unnecessary code. */
2402
2403	static void
2404	gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2405	{
2406	gfc_actual_arglist *arg;
2407	gfc_actual_arglist *arg2;
2408	tree desc;
2409	tree type;
2410	tree bound;
2411	tree tmp;
2412	tree cond, cond1;
2413	tree ubound;
2414	tree lbound;
2415	tree size;
2416	gfc_se argse;
2417	gfc_array_spec * as;
2418	bool assumed_rank_lb_one;
2419
2420	arg = expr->value.function.actual;
2421	arg2 = arg->next;
2422
2423	if (se->ss)
2424	{
2425	/* Create an implicit second parameter from the loop variable. */
2426	gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2427	gcc_assert (se->loop->dimen == 1);
2428	gcc_assert (se->ss->info->expr == expr);
2429	gfc_advance_se_ss_chain (se);
2430	bound = se->loop->loopvar[0];
2431	bound = fold_build2_loc (input_location, MINUS_EXPR,
2432	gfc_array_index_type, bound,
2433	se->loop->from[0]);
2434	}
2435	else
2436	{
2437	/* use the passed argument. */
2438	gcc_assert (arg2->expr);
2439	gfc_init_se (&argse, NULL);
2440	gfc_conv_expr_type (se: &argse, arg2->expr, gfc_array_index_type);
2441	gfc_add_block_to_block (&se->pre, &argse.pre);
2442	bound = argse.expr;
2443	/* Convert from one based to zero based. */
2444	bound = fold_build2_loc (input_location, MINUS_EXPR,
2445	gfc_array_index_type, bound,
2446	gfc_index_one_node);
2447	}
2448
2449	/* TODO: don't re-evaluate the descriptor on each iteration. */
2450	/* Get a descriptor for the first parameter. */
2451	gfc_init_se (&argse, NULL);
2452	gfc_conv_expr_descriptor (&argse, arg->expr);
2453	gfc_add_block_to_block (&se->pre, &argse.pre);
2454	gfc_add_block_to_block (&se->post, &argse.post);
2455
2456	desc = argse.expr;
2457
2458	as = gfc_get_full_arrayspec_from_expr (expr: arg->expr);
2459
2460	if (INTEGER_CST_P (bound))
2461	{
2462	gcc_assert (op != GFC_ISYM_SHAPE);
2463	if (((!as || as->type != AS_ASSUMED_RANK)
2464	&& wi::geu_p (x: wi::to_wide (t: bound),
2465	GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2466	|| wi::gtu_p (x: wi::to_wide (t: bound), GFC_MAX_DIMENSIONS))
2467	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2468	"dimension index",
2469	(op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2470	&expr->where);
2471	}
2472
2473	if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2474	{
2475	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2476	{
2477	bound = gfc_evaluate_now (bound, &se->pre);
2478	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2479	bound, build_int_cst (TREE_TYPE (bound), 0));
2480	if (as && as->type == AS_ASSUMED_RANK)
2481	tmp = gfc_conv_descriptor_rank (desc);
2482	else
2483	tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2484	tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2485	bound, fold_convert(TREE_TYPE (bound), tmp));
2486	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2487	logical_type_node, cond, tmp);
2488	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2489	gfc_msg_fault);
2490	}
2491	}
2492
2493	/* Take care of the lbound shift for assumed-rank arrays that are
2494	nonallocatable and nonpointers. Those have a lbound of 1. */
2495	assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2496	&& ((arg->expr->ts.type != BT_CLASS
2497	&& !arg->expr->symtree->n.sym->attr.allocatable
2498	&& !arg->expr->symtree->n.sym->attr.pointer)
2499	|| (arg->expr->ts.type == BT_CLASS
2500	&& !CLASS_DATA (arg->expr)->attr.allocatable
2501	&& !CLASS_DATA (arg->expr)->attr.class_pointer));
2502
2503	ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2504	lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2505	size = fold_build2_loc (input_location, MINUS_EXPR,
2506	gfc_array_index_type, ubound, lbound);
2507	size = fold_build2_loc (input_location, PLUS_EXPR,
2508	gfc_array_index_type, size, gfc_index_one_node);
2509
2510	/* 13.14.53: Result value for LBOUND
2511
2512	Case (i): For an array section or for an array expression other than a
2513	whole array or array structure component, LBOUND(ARRAY, DIM)
2514	has the value 1. For a whole array or array structure
2515	component, LBOUND(ARRAY, DIM) has the value:
2516	(a) equal to the lower bound for subscript DIM of ARRAY if
2517	dimension DIM of ARRAY does not have extent zero
2518	or if ARRAY is an assumed-size array of rank DIM,
2519	or (b) 1 otherwise.
2520
2521	13.14.113: Result value for UBOUND
2522
2523	Case (i): For an array section or for an array expression other than a
2524	whole array or array structure component, UBOUND(ARRAY, DIM)
2525	has the value equal to the number of elements in the given
2526	dimension; otherwise, it has a value equal to the upper bound
2527	for subscript DIM of ARRAY if dimension DIM of ARRAY does
2528	not have size zero and has value zero if dimension DIM has
2529	size zero. */
2530
2531	if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2532	se->expr = gfc_index_one_node;
2533	else if (as)
2534	{
2535	if (op == GFC_ISYM_UBOUND)
2536	{
2537	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2538	size, gfc_index_zero_node);
2539	se->expr = fold_build3_loc (input_location, COND_EXPR,
2540	gfc_array_index_type, cond,
2541	(assumed_rank_lb_one ? size : ubound),
2542	gfc_index_zero_node);
2543	}
2544	else if (op == GFC_ISYM_LBOUND)
2545	{
2546	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2547	size, gfc_index_zero_node);
2548	if (as->type == AS_ASSUMED_SIZE)
2549	{
2550	cond1 = fold_build2_loc (input_location, EQ_EXPR,
2551	logical_type_node, bound,
2552	build_int_cst (TREE_TYPE (bound),
2553	arg->expr->rank - 1));
2554	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2555	logical_type_node, cond, cond1);
2556	}
2557	se->expr = fold_build3_loc (input_location, COND_EXPR,
2558	gfc_array_index_type, cond,
2559	lbound, gfc_index_one_node);
2560	}
2561	else if (op == GFC_ISYM_SHAPE)
2562	se->expr = fold_build2_loc (input_location, MAX_EXPR,
2563	gfc_array_index_type, size,
2564	gfc_index_zero_node);
2565	else
2566	gcc_unreachable ();
2567
2568	/* According to F2018 16.9.172, para 5, an assumed rank object,
2569	argument associated with and assumed size array, has the ubound
2570	of the final dimension set to -1 and UBOUND must return this.
2571	Similarly for the SHAPE intrinsic. */
2572	if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2573	{
2574	tree minus_one = build_int_cst (gfc_array_index_type, -1);
2575	tree rank = fold_convert (gfc_array_index_type,
2576	gfc_conv_descriptor_rank (desc));
2577	rank = fold_build2_loc (input_location, PLUS_EXPR,
2578	gfc_array_index_type, rank, minus_one);
2579
2580	/* Fix the expression to stop it from becoming even more
2581	complicated. */
2582	se->expr = gfc_evaluate_now (se->expr, &se->pre);
2583
2584	/* Descriptors for assumed-size arrays have ubound = -1
2585	in the last dimension. */
2586	cond1 = fold_build2_loc (input_location, EQ_EXPR,
2587	logical_type_node, ubound, minus_one);
2588	cond = fold_build2_loc (input_location, EQ_EXPR,
2589	logical_type_node, bound, rank);
2590	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2591	logical_type_node, cond, cond1);
2592	se->expr = fold_build3_loc (input_location, COND_EXPR,
2593	gfc_array_index_type, cond,
2594	minus_one, se->expr);
2595	}
2596	}
2597	else /* as is null; this is an old-fashioned 1-based array. */
2598	{
2599	if (op != GFC_ISYM_LBOUND)
2600	{
2601	se->expr = fold_build2_loc (input_location, MAX_EXPR,
2602	gfc_array_index_type, size,
2603	gfc_index_zero_node);
2604	}
2605	else
2606	se->expr = gfc_index_one_node;
2607	}
2608
2609
2610	type = gfc_typenode_for_spec (&expr->ts);
2611	se->expr = convert (type, se->expr);
2612	}
2613
2614
2615	static void
2616	conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2617	{
2618	gfc_actual_arglist *arg;
2619	gfc_actual_arglist *arg2;
2620	gfc_se argse;
2621	tree bound, resbound, resbound2, desc, cond, tmp;
2622	tree type;
2623	int corank;
2624
2625	gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2626	|| expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2627	|| expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2628
2629	arg = expr->value.function.actual;
2630	arg2 = arg->next;
2631
2632	gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2633	corank = arg->expr->corank;
2634
2635	gfc_init_se (&argse, NULL);
2636	argse.want_coarray = 1;
2637
2638	gfc_conv_expr_descriptor (&argse, arg->expr);
2639	gfc_add_block_to_block (&se->pre, &argse.pre);
2640	gfc_add_block_to_block (&se->post, &argse.post);
2641	desc = argse.expr;
2642
2643	if (se->ss)
2644	{
2645	/* Create an implicit second parameter from the loop variable. */
2646	gcc_assert (!arg2->expr);
2647	gcc_assert (corank > 0);
2648	gcc_assert (se->loop->dimen == 1);
2649	gcc_assert (se->ss->info->expr == expr);
2650
2651	bound = se->loop->loopvar[0];
2652	bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2653	bound, gfc_rank_cst[arg->expr->rank]);
2654	gfc_advance_se_ss_chain (se);
2655	}
2656	else
2657	{
2658	/* use the passed argument. */
2659	gcc_assert (arg2->expr);
2660	gfc_init_se (&argse, NULL);
2661	gfc_conv_expr_type (se: &argse, arg2->expr, gfc_array_index_type);
2662	gfc_add_block_to_block (&se->pre, &argse.pre);
2663	bound = argse.expr;
2664
2665	if (INTEGER_CST_P (bound))
2666	{
2667	if (wi::ltu_p (x: wi::to_wide (t: bound), y: 1)
2668	|| wi::gtu_p (x: wi::to_wide (t: bound),
2669	GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2670	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2671	"dimension index", expr->value.function.isym->name,
2672	&expr->where);
2673	}
2674	else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2675	{
2676	bound = gfc_evaluate_now (bound, &se->pre);
2677	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2678	bound, build_int_cst (TREE_TYPE (bound), 1));
2679	tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2680	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2681	bound, tmp);
2682	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2683	logical_type_node, cond, tmp);
2684	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2685	gfc_msg_fault);
2686	}
2687
2688
2689	/* Subtract 1 to get to zero based and add dimensions. */
2690	switch (arg->expr->rank)
2691	{
2692	case 0:
2693	bound = fold_build2_loc (input_location, MINUS_EXPR,
2694	gfc_array_index_type, bound,
2695	gfc_index_one_node);
2696	case 1:
2697	break;
2698	default:
2699	bound = fold_build2_loc (input_location, PLUS_EXPR,
2700	gfc_array_index_type, bound,
2701	gfc_rank_cst[arg->expr->rank - 1]);
2702	}
2703	}
2704
2705	resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2706
2707	/* Handle UCOBOUND with special handling of the last codimension. */
2708	if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
2709	{
2710	/* Last codimension: For -fcoarray=single just return
2711	the lcobound - otherwise add
2712	ceiling (real (num_images ()) / real (size)) - 1
2713	= (num_images () + size - 1) / size - 1
2714	= (num_images - 1) / size(),
2715	where size is the product of the extent of all but the last
2716	codimension. */
2717
2718	if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2719	{
2720	tree cosize;
2721
2722	cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2723	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2724	2, null_pointer_node, null_pointer_node);
2725	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2726	gfc_array_index_type,
2727	fold_convert (gfc_array_index_type, tmp),
2728	build_int_cst (gfc_array_index_type, 1));
2729	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2730	gfc_array_index_type, tmp,
2731	fold_convert (gfc_array_index_type, cosize));
2732	resbound = fold_build2_loc (input_location, PLUS_EXPR,
2733	gfc_array_index_type, resbound, tmp);
2734	}
2735	else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2736	{
2737	/* ubound = lbound + num_images() - 1. */
2738	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2739	2, null_pointer_node, null_pointer_node);
2740	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2741	gfc_array_index_type,
2742	fold_convert (gfc_array_index_type, tmp),
2743	build_int_cst (gfc_array_index_type, 1));
2744	resbound = fold_build2_loc (input_location, PLUS_EXPR,
2745	gfc_array_index_type, resbound, tmp);
2746	}
2747
2748	if (corank > 1)
2749	{
2750	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2751	bound,
2752	build_int_cst (TREE_TYPE (bound),
2753	arg->expr->rank + corank - 1));
2754
2755	resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2756	se->expr = fold_build3_loc (input_location, COND_EXPR,
2757	gfc_array_index_type, cond,
2758	resbound, resbound2);
2759	}
2760	else
2761	se->expr = resbound;
2762	}
2763	else
2764	se->expr = resbound;
2765
2766	type = gfc_typenode_for_spec (&expr->ts);
2767	se->expr = convert (type, se->expr);
2768	}
2769
2770
2771	static void
2772	conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2773	{
2774	gfc_actual_arglist *array_arg;
2775	gfc_actual_arglist *dim_arg;
2776	gfc_se argse;
2777	tree desc, tmp;
2778
2779	array_arg = expr->value.function.actual;
2780	dim_arg = array_arg->next;
2781
2782	gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2783
2784	gfc_init_se (&argse, NULL);
2785	gfc_conv_expr_descriptor (&argse, array_arg->expr);
2786	gfc_add_block_to_block (&se->pre, &argse.pre);
2787	gfc_add_block_to_block (&se->post, &argse.post);
2788	desc = argse.expr;
2789
2790	gcc_assert (dim_arg->expr);
2791	gfc_init_se (&argse, NULL);
2792	gfc_conv_expr_type (se: &argse, dim_arg->expr, gfc_array_index_type);
2793	gfc_add_block_to_block (&se->pre, &argse.pre);
2794	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2795	argse.expr, gfc_index_one_node);
2796	se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2797	}
2798
2799	static void
2800	gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2801	{
2802	tree arg, cabs;
2803
2804	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
2805
2806	switch (expr->value.function.actual->expr->ts.type)
2807	{
2808	case BT_INTEGER:
2809	case BT_REAL:
2810	se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2811	arg);
2812	break;
2813
2814	case BT_COMPLEX:
2815	cabs = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_CABS, kind: expr->ts.kind);
2816	se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2817	break;
2818
2819	default:
2820	gcc_unreachable ();
2821	}
2822	}
2823
2824
2825	/* Create a complex value from one or two real components. */
2826
2827	static void
2828	gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2829	{
2830	tree real;
2831	tree imag;
2832	tree type;
2833	tree *args;
2834	unsigned int num_args;
2835
2836	num_args = gfc_intrinsic_argument_list_length (expr);
2837	args = XALLOCAVEC (tree, num_args);
2838
2839	type = gfc_typenode_for_spec (&expr->ts);
2840	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
2841	real = convert (TREE_TYPE (type), args[0]);
2842	if (both)
2843	imag = convert (TREE_TYPE (type), args[1]);
2844	else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2845	{
2846	imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2847	TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2848	imag = convert (TREE_TYPE (type), imag);
2849	}
2850	else
2851	imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2852
2853	se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2854	}
2855
2856
2857	/* Remainder function MOD(A, P) = A - INT(A / P) * P
2858	MODULO(A, P) = A - FLOOR (A / P) * P
2859
2860	The obvious algorithms above are numerically instable for large
2861	arguments, hence these intrinsics are instead implemented via calls
2862	to the fmod family of functions. It is the responsibility of the
2863	user to ensure that the second argument is non-zero. */
2864
2865	static void
2866	gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2867	{
2868	tree type;
2869	tree tmp;
2870	tree test;
2871	tree test2;
2872	tree fmod;
2873	tree zero;
2874	tree args[2];
2875
2876	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
2877
2878	switch (expr->ts.type)
2879	{
2880	case BT_INTEGER:
2881	/* Integer case is easy, we've got a builtin op. */
2882	type = TREE_TYPE (args[0]);
2883
2884	if (modulo)
2885	se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2886	args[0], args[1]);
2887	else
2888	se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2889	args[0], args[1]);
2890	break;
2891
2892	case BT_UNSIGNED:
2893	/* Even easier, we only need one. */
2894	type = TREE_TYPE (args[0]);
2895	se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2896	args[0], args[1]);
2897	break;
2898
2899	case BT_REAL:
2900	fmod = NULL_TREE;
2901	/* Check if we have a builtin fmod. */
2902	fmod = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FMOD, kind: expr->ts.kind);
2903
2904	/* The builtin should always be available. */
2905	gcc_assert (fmod != NULL_TREE);
2906
2907	tmp = build_addr (fmod);
2908	se->expr = build_call_array_loc (input_location,
2909	TREE_TYPE (TREE_TYPE (fmod)),
2910	tmp, 2, args);
2911	if (modulo == 0)
2912	return;
2913
2914	type = TREE_TYPE (args[0]);
2915
2916	args[0] = gfc_evaluate_now (args[0], &se->pre);
2917	args[1] = gfc_evaluate_now (args[1], &se->pre);
2918
2919	/* Definition:
2920	modulo = arg - floor (arg/arg2) * arg2
2921
2922	In order to calculate the result accurately, we use the fmod
2923	function as follows.
2924
2925	res = fmod (arg, arg2);
2926	if (res)
2927	{
2928	if ((arg < 0) xor (arg2 < 0))
2929	res += arg2;
2930	}
2931	else
2932	res = copysign (0., arg2);
2933
2934	=> As two nested ternary exprs:
2935
2936	res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2937	: copysign (0., arg2);
2938
2939	*/
2940
2941	zero = gfc_build_const (type, integer_zero_node);
2942	tmp = gfc_evaluate_now (se->expr, &se->pre);
2943	if (!flag_signed_zeros)
2944	{
2945	test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2946	args[0], zero);
2947	test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2948	args[1], zero);
2949	test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2950	logical_type_node, test, test2);
2951	test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2952	tmp, zero);
2953	test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2954	logical_type_node, test, test2);
2955	test = gfc_evaluate_now (test, &se->pre);
2956	se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2957	fold_build2_loc (input_location,
2958	PLUS_EXPR,
2959	type, tmp, args[1]),
2960	tmp);
2961	}
2962	else
2963	{
2964	tree expr1, copysign, cscall;
2965	copysign = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_COPYSIGN,
2966	kind: expr->ts.kind);
2967	test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2968	args[0], zero);
2969	test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2970	args[1], zero);
2971	test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2972	logical_type_node, test, test2);
2973	expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
2974	fold_build2_loc (input_location,
2975	PLUS_EXPR,
2976	type, tmp, args[1]),
2977	tmp);
2978	test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2979	tmp, zero);
2980	cscall = build_call_expr_loc (input_location, copysign, 2, zero,
2981	args[1]);
2982	se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2983	expr1, cscall);
2984	}
2985	return;
2986
2987	default:
2988	gcc_unreachable ();
2989	}
2990	}
2991
2992	/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2993	DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2994	where the right shifts are logical (i.e. 0's are shifted in).
2995	Because SHIFT_EXPR's want shifts strictly smaller than the integral
2996	type width, we have to special-case both S == 0 and S == BITSIZE(J):
2997	DSHIFTL(I,J,0) = I
2998	DSHIFTL(I,J,BITSIZE) = J
2999	DSHIFTR(I,J,0) = J
3000	DSHIFTR(I,J,BITSIZE) = I. */
3001
3002	static void
3003	gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3004	{
3005	tree type, utype, stype, arg1, arg2, shift, res, left, right;
3006	tree args[3], cond, tmp;
3007	int bitsize;
3008
3009	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
3010
3011	gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3012	type = TREE_TYPE (args[0]);
3013	bitsize = TYPE_PRECISION (type);
3014	utype = unsigned_type_for (type);
3015	stype = TREE_TYPE (args[2]);
3016
3017	arg1 = gfc_evaluate_now (args[0], &se->pre);
3018	arg2 = gfc_evaluate_now (args[1], &se->pre);
3019	shift = gfc_evaluate_now (args[2], &se->pre);
3020
3021	/* The generic case. */
3022	tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3023	build_int_cst (stype, bitsize), shift);
3024	left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3025	arg1, dshiftl ? shift : tmp);
3026
3027	right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3028	fold_convert (utype, arg2), dshiftl ? tmp : shift);
3029	right = fold_convert (type, right);
3030
3031	res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3032
3033	/* Special cases. */
3034	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3035	build_int_cst (stype, 0));
3036	res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3037	dshiftl ? arg1 : arg2, res);
3038
3039	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3040	build_int_cst (stype, bitsize));
3041	res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3042	dshiftl ? arg2 : arg1, res);
3043
3044	se->expr = res;
3045	}
3046
3047
3048	/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3049
3050	static void
3051	gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3052	{
3053	tree val;
3054	tree tmp;
3055	tree type;
3056	tree zero;
3057	tree args[2];
3058
3059	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3060	type = TREE_TYPE (args[0]);
3061
3062	val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3063	val = gfc_evaluate_now (val, &se->pre);
3064
3065	zero = gfc_build_const (type, integer_zero_node);
3066	tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3067	se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3068	}
3069
3070
3071	/* SIGN(A, B) is absolute value of A times sign of B.
3072	The real value versions use library functions to ensure the correct
3073	handling of negative zero. Integer case implemented as:
3074	SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3075	*/
3076
3077	static void
3078	gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3079	{
3080	tree tmp;
3081	tree type;
3082	tree args[2];
3083
3084	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3085	if (expr->ts.type == BT_REAL)
3086	{
3087	tree abs;
3088
3089	tmp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_COPYSIGN, kind: expr->ts.kind);
3090	abs = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FABS, kind: expr->ts.kind);
3091
3092	/* We explicitly have to ignore the minus sign. We do so by using
3093	result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3094	if (!flag_sign_zero
3095	&& MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3096	{
3097	tree cond, zero;
3098	zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3099	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3100	args[1], zero);
3101	se->expr = fold_build3_loc (input_location, COND_EXPR,
3102	TREE_TYPE (args[0]), cond,
3103	build_call_expr_loc (input_location, abs, 1,
3104	args[0]),
3105	build_call_expr_loc (input_location, tmp, 2,
3106	args[0], args[1]));
3107	}
3108	else
3109	se->expr = build_call_expr_loc (input_location, tmp, 2,
3110	args[0], args[1]);
3111	return;
3112	}
3113
3114	/* Having excluded floating point types, we know we are now dealing
3115	with signed integer types. */
3116	type = TREE_TYPE (args[0]);
3117
3118	/* Args[0] is used multiple times below. */
3119	args[0] = gfc_evaluate_now (args[0], &se->pre);
3120
3121	/* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3122	the signs of A and B are the same, and of all ones if they differ. */
3123	tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3124	tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3125	build_int_cst (type, TYPE_PRECISION (type) - 1));
3126	tmp = gfc_evaluate_now (tmp, &se->pre);
3127
3128	/* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3129	is all ones (i.e. -1). */
3130	se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3131	fold_build2_loc (input_location, PLUS_EXPR,
3132	type, args[0], tmp), tmp);
3133	}
3134
3135
3136	/* Test for the presence of an optional argument. */
3137
3138	static void
3139	gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3140	{
3141	gfc_expr *arg;
3142
3143	arg = expr->value.function.actual->expr;
3144	gcc_assert (arg->expr_type == EXPR_VARIABLE);
3145	se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3146	se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3147	}
3148
3149
3150	/* Calculate the double precision product of two single precision values. */
3151
3152	static void
3153	gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3154	{
3155	tree type;
3156	tree args[2];
3157
3158	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3159
3160	/* Convert the args to double precision before multiplying. */
3161	type = gfc_typenode_for_spec (&expr->ts);
3162	args[0] = convert (type, args[0]);
3163	args[1] = convert (type, args[1]);
3164	se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3165	args[1]);
3166	}
3167
3168
3169	/* Return a length one character string containing an ascii character. */
3170
3171	static void
3172	gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3173	{
3174	tree arg[2];
3175	tree var;
3176	tree type;
3177	unsigned int num_args;
3178
3179	num_args = gfc_intrinsic_argument_list_length (expr);
3180	gfc_conv_intrinsic_function_args (se, expr, argarray: arg, nargs: num_args);
3181
3182	type = gfc_get_char_type (expr->ts.kind);
3183	var = gfc_create_var (type, "char");
3184
3185	arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3186	gfc_add_modify (&se->pre, var, arg[0]);
3187	se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3188	se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3189	}
3190
3191
3192	static void
3193	gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3194	{
3195	tree var;
3196	tree len;
3197	tree tmp;
3198	tree cond;
3199	tree fndecl;
3200	tree *args;
3201	unsigned int num_args;
3202
3203	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3204	args = XALLOCAVEC (tree, num_args);
3205
3206	var = gfc_create_var (pchar_type_node, "pstr");
3207	len = gfc_create_var (gfc_charlen_type_node, "len");
3208
3209	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
3210	args[0] = gfc_build_addr_expr (NULL_TREE, var);
3211	args[1] = gfc_build_addr_expr (NULL_TREE, len);
3212
3213	fndecl = build_addr (gfor_fndecl_ctime);
3214	tmp = build_call_array_loc (input_location,
3215	TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3216	fndecl, num_args, args);
3217	gfc_add_expr_to_block (&se->pre, tmp);
3218
3219	/* Free the temporary afterwards, if necessary. */
3220	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3221	len, build_int_cst (TREE_TYPE (len), 0));
3222	tmp = gfc_call_free (var);
3223	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3224	gfc_add_expr_to_block (&se->post, tmp);
3225
3226	se->expr = var;
3227	se->string_length = len;
3228	}
3229
3230
3231	static void
3232	gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3233	{
3234	tree var;
3235	tree len;
3236	tree tmp;
3237	tree cond;
3238	tree fndecl;
3239	tree *args;
3240	unsigned int num_args;
3241
3242	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3243	args = XALLOCAVEC (tree, num_args);
3244
3245	var = gfc_create_var (pchar_type_node, "pstr");
3246	len = gfc_create_var (gfc_charlen_type_node, "len");
3247
3248	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
3249	args[0] = gfc_build_addr_expr (NULL_TREE, var);
3250	args[1] = gfc_build_addr_expr (NULL_TREE, len);
3251
3252	fndecl = build_addr (gfor_fndecl_fdate);
3253	tmp = build_call_array_loc (input_location,
3254	TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3255	fndecl, num_args, args);
3256	gfc_add_expr_to_block (&se->pre, tmp);
3257
3258	/* Free the temporary afterwards, if necessary. */
3259	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3260	len, build_int_cst (TREE_TYPE (len), 0));
3261	tmp = gfc_call_free (var);
3262	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3263	gfc_add_expr_to_block (&se->post, tmp);
3264
3265	se->expr = var;
3266	se->string_length = len;
3267	}
3268
3269
3270	/* Generate a direct call to free() for the FREE subroutine. */
3271
3272	static tree
3273	conv_intrinsic_free (gfc_code *code)
3274	{
3275	stmtblock_t block;
3276	gfc_se argse;
3277	tree arg, call;
3278
3279	gfc_init_se (&argse, NULL);
3280	gfc_conv_expr (se: &argse, expr: code->ext.actual->expr);
3281	arg = fold_convert (ptr_type_node, argse.expr);
3282
3283	gfc_init_block (&block);
3284	call = build_call_expr_loc (input_location,
3285	builtin_decl_explicit (fncode: BUILT_IN_FREE), 1, arg);
3286	gfc_add_expr_to_block (&block, call);
3287	return gfc_finish_block (&block);
3288	}
3289
3290
3291	/* Call the RANDOM_INIT library subroutine with a hidden argument for
3292	handling seeding on coarray images. */
3293
3294	static tree
3295	conv_intrinsic_random_init (gfc_code *code)
3296	{
3297	stmtblock_t block;
3298	gfc_se se;
3299	tree arg1, arg2, tmp;
3300	/* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3301	tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3302	? logical_type_node
3303	: gfc_get_logical_type (4);
3304
3305	/* Make the function call. */
3306	gfc_init_block (&block);
3307	gfc_init_se (&se, NULL);
3308
3309	/* Convert REPEATABLE to the desired LOGICAL entity. */
3310	gfc_conv_expr (se: &se, expr: code->ext.actual->expr);
3311	gfc_add_block_to_block (&block, &se.pre);
3312	arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3313	gfc_add_block_to_block (&block, &se.post);
3314
3315	/* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3316	gfc_conv_expr (se: &se, expr: code->ext.actual->next->expr);
3317	gfc_add_block_to_block (&block, &se.pre);
3318	arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3319	gfc_add_block_to_block (&block, &se.post);
3320
3321	if (flag_coarray == GFC_FCOARRAY_LIB)
3322	{
3323	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3324	2, arg1, arg2);
3325	}
3326	else
3327	{
3328	/* The ABI for libgfortran needs to be maintained, so a hidden
3329	argument must be include if code is compiled with -fcoarray=single
3330	or without the option. Set to 0. */
3331	tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3332	tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3333	3, arg1, arg2, arg3);
3334	}
3335
3336	gfc_add_expr_to_block (&block, tmp);
3337
3338	return gfc_finish_block (&block);
3339	}
3340
3341
3342	/* Call the SYSTEM_CLOCK library functions, handling the type and kind
3343	conversions. */
3344
3345	static tree
3346	conv_intrinsic_system_clock (gfc_code *code)
3347	{
3348	stmtblock_t block;
3349	gfc_se count_se, count_rate_se, count_max_se;
3350	tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3351	tree tmp;
3352	int least;
3353
3354	gfc_expr *count = code->ext.actual->expr;
3355	gfc_expr *count_rate = code->ext.actual->next->expr;
3356	gfc_expr *count_max = code->ext.actual->next->next->expr;
3357
3358	/* Evaluate our arguments. */
3359	if (count)
3360	{
3361	gfc_init_se (&count_se, NULL);
3362	gfc_conv_expr (se: &count_se, expr: count);
3363	}
3364
3365	if (count_rate)
3366	{
3367	gfc_init_se (&count_rate_se, NULL);
3368	gfc_conv_expr (se: &count_rate_se, expr: count_rate);
3369	}
3370
3371	if (count_max)
3372	{
3373	gfc_init_se (&count_max_se, NULL);
3374	gfc_conv_expr (se: &count_max_se, expr: count_max);
3375	}
3376
3377	/* Find the smallest kind found of the arguments. */
3378	least = 16;
3379	least = (count && count->ts.kind < least) ? count->ts.kind : least;
3380	least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3381	: least;
3382	least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3383	: least;
3384
3385	/* Prepare temporary variables. */
3386
3387	if (count)
3388	{
3389	if (least >= 8)
3390	arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3391	else if (least == 4)
3392	arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3393	else if (count->ts.kind == 1)
3394	arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3395	count->ts.kind);
3396	else
3397	arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3398	count->ts.kind);
3399	}
3400
3401	if (count_rate)
3402	{
3403	if (least >= 8)
3404	arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3405	else if (least == 4)
3406	arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3407	else
3408	arg2 = integer_zero_node;
3409	}
3410
3411	if (count_max)
3412	{
3413	if (least >= 8)
3414	arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3415	else if (least == 4)
3416	arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3417	else
3418	arg3 = integer_zero_node;
3419	}
3420
3421	/* Make the function call. */
3422	gfc_init_block (&block);
3423
3424	if (least <= 2)
3425	{
3426	if (least == 1)
3427	{
3428	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3429	: null_pointer_node;
3430	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3431	: null_pointer_node;
3432	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3433	: null_pointer_node;
3434	}
3435
3436	if (least == 2)
3437	{
3438	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3439	: null_pointer_node;
3440	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3441	: null_pointer_node;
3442	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3443	: null_pointer_node;
3444	}
3445	}
3446	else
3447	{
3448	if (least == 4)
3449	{
3450	tmp = build_call_expr_loc (input_location,
3451	gfor_fndecl_system_clock4, 3,
3452	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3453	: null_pointer_node,
3454	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3455	: null_pointer_node,
3456	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3457	: null_pointer_node);
3458	gfc_add_expr_to_block (&block, tmp);
3459	}
3460	/* Handle kind>=8, 10, or 16 arguments */
3461	if (least >= 8)
3462	{
3463	tmp = build_call_expr_loc (input_location,
3464	gfor_fndecl_system_clock8, 3,
3465	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3466	: null_pointer_node,
3467	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3468	: null_pointer_node,
3469	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3470	: null_pointer_node);
3471	gfc_add_expr_to_block (&block, tmp);
3472	}
3473	}
3474
3475	/* And store values back if needed. */
3476	if (arg1 && arg1 != count_se.expr)
3477	gfc_add_modify (&block, count_se.expr,
3478	fold_convert (TREE_TYPE (count_se.expr), arg1));
3479	if (arg2 && arg2 != count_rate_se.expr)
3480	gfc_add_modify (&block, count_rate_se.expr,
3481	fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3482	if (arg3 && arg3 != count_max_se.expr)
3483	gfc_add_modify (&block, count_max_se.expr,
3484	fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3485
3486	return gfc_finish_block (&block);
3487	}
3488
3489	static tree
3490	conv_intrinsic_split (gfc_code *code)
3491	{
3492	stmtblock_t block, post_block;
3493	gfc_se se;
3494	gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3495	tree string, string_len;
3496	tree set, set_len;
3497	tree pos, pos_for_call;
3498	tree back;
3499	tree fndecl, call;
3500
3501	string_expr = code->ext.actual->expr;
3502	set_expr = code->ext.actual->next->expr;
3503	pos_expr = code->ext.actual->next->next->expr;
3504	back_expr = code->ext.actual->next->next->next->expr;
3505
3506	gfc_start_block (&block);
3507	gfc_init_block (&post_block);
3508
3509	gfc_init_se (&se, NULL);
3510	gfc_conv_expr (se: &se, expr: string_expr);
3511	gfc_conv_string_parameter (se: &se);
3512	gfc_add_block_to_block (&block, &se.pre);
3513	gfc_add_block_to_block (&post_block, &se.post);
3514	string = se.expr;
3515	string_len = se.string_length;
3516
3517	gfc_init_se (&se, NULL);
3518	gfc_conv_expr (se: &se, expr: set_expr);
3519	gfc_conv_string_parameter (se: &se);
3520	gfc_add_block_to_block (&block, &se.pre);
3521	gfc_add_block_to_block (&post_block, &se.post);
3522	set = se.expr;
3523	set_len = se.string_length;
3524
3525	gfc_init_se (&se, NULL);
3526	gfc_conv_expr (se: &se, expr: pos_expr);
3527	gfc_add_block_to_block (&block, &se.pre);
3528	gfc_add_block_to_block (&post_block, &se.post);
3529	pos = se.expr;
3530	pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3531
3532	if (back_expr)
3533	{
3534	gfc_init_se (&se, NULL);
3535	gfc_conv_expr (se: &se, expr: back_expr);
3536	gfc_add_block_to_block (&block, &se.pre);
3537	gfc_add_block_to_block (&post_block, &se.post);
3538	back = se.expr;
3539	}
3540	else
3541	back = logical_false_node;
3542
3543	if (string_expr->ts.kind == 1)
3544	fndecl = gfor_fndecl_string_split;
3545	else if (string_expr->ts.kind == 4)
3546	fndecl = gfor_fndecl_string_split_char4;
3547	else
3548	gcc_unreachable ();
3549
3550	call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3551	set_len, set, pos_for_call, back);
3552	gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3553
3554	gfc_add_block_to_block (&block, &post_block);
3555	return gfc_finish_block (&block);
3556	}
3557
3558	/* Return a character string containing the tty name. */
3559
3560	static void
3561	gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3562	{
3563	tree var;
3564	tree len;
3565	tree tmp;
3566	tree cond;
3567	tree fndecl;
3568	tree *args;
3569	unsigned int num_args;
3570
3571	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3572	args = XALLOCAVEC (tree, num_args);
3573
3574	var = gfc_create_var (pchar_type_node, "pstr");
3575	len = gfc_create_var (gfc_charlen_type_node, "len");
3576
3577	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
3578	args[0] = gfc_build_addr_expr (NULL_TREE, var);
3579	args[1] = gfc_build_addr_expr (NULL_TREE, len);
3580
3581	fndecl = build_addr (gfor_fndecl_ttynam);
3582	tmp = build_call_array_loc (input_location,
3583	TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3584	fndecl, num_args, args);
3585	gfc_add_expr_to_block (&se->pre, tmp);
3586
3587	/* Free the temporary afterwards, if necessary. */
3588	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3589	len, build_int_cst (TREE_TYPE (len), 0));
3590	tmp = gfc_call_free (var);
3591	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3592	gfc_add_expr_to_block (&se->post, tmp);
3593
3594	se->expr = var;
3595	se->string_length = len;
3596	}
3597
3598
3599	/* Get the minimum/maximum value of all the parameters.
3600	minmax (a1, a2, a3, ...)
3601	{
3602	mvar = a1;
3603	mvar = COMP (mvar, a2)
3604	mvar = COMP (mvar, a3)
3605	...
3606	return mvar;
3607	}
3608	Where COMP is MIN/MAX_EXPR for integral types or when we don't
3609	care about NaNs, or IFN_FMIN/MAX when the target has support for
3610	fast NaN-honouring min/max. When neither holds expand a sequence
3611	of explicit comparisons. */
3612
3613	/* TODO: Mismatching types can occur when specific names are used.
3614	These should be handled during resolution. */
3615	static void
3616	gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3617	{
3618	tree tmp;
3619	tree mvar;
3620	tree val;
3621	tree *args;
3622	tree type;
3623	tree argtype;
3624	gfc_actual_arglist *argexpr;
3625	unsigned int i, nargs;
3626
3627	nargs = gfc_intrinsic_argument_list_length (expr);
3628	args = XALLOCAVEC (tree, nargs);
3629
3630	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
3631	type = gfc_typenode_for_spec (&expr->ts);
3632
3633	/* Only evaluate the argument once. */
3634	if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3635	args[0] = gfc_evaluate_now (args[0], &se->pre);
3636
3637	/* Determine suitable type of temporary, as a GNU extension allows
3638	different argument kinds. */
3639	argtype = TREE_TYPE (args[0]);
3640	argexpr = expr->value.function.actual;
3641	for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3642	{
3643	tree tmptype = TREE_TYPE (args[i]);
3644	if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3645	argtype = tmptype;
3646	}
3647	mvar = gfc_create_var (argtype, "M");
3648	gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3649
3650	argexpr = expr->value.function.actual;
3651	for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3652	{
3653	tree cond = NULL_TREE;
3654	val = args[i];
3655
3656	/* Handle absent optional arguments by ignoring the comparison. */
3657	if (argexpr->expr->expr_type == EXPR_VARIABLE
3658	&& argexpr->expr->symtree->n.sym->attr.optional
3659	&& INDIRECT_REF_P (val))
3660	{
3661	cond = fold_build2_loc (input_location,
3662	NE_EXPR, logical_type_node,
3663	TREE_OPERAND (val, 0),
3664	build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3665	}
3666	else if (!VAR_P (val) && !TREE_CONSTANT (val))
3667	/* Only evaluate the argument once. */
3668	val = gfc_evaluate_now (val, &se->pre);
3669
3670	tree calc;
3671	/* For floating point types, the question is what MAX(a, NaN) or
3672	MIN(a, NaN) should return (where "a" is a normal number).
3673	There are valid use case for returning either one, but the
3674	Fortran standard doesn't specify which one should be chosen.
3675	Also, there is no consensus among other tested compilers. In
3676	short, it's a mess. So lets just do whatever is fastest. */
3677	tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3678	calc = fold_build2_loc (input_location, code, argtype,
3679	convert (argtype, val), mvar);
3680	tmp = build2_v (MODIFY_EXPR, mvar, calc);
3681
3682	if (cond != NULL_TREE)
3683	tmp = build3_v (COND_EXPR, cond, tmp,
3684	build_empty_stmt (input_location));
3685	gfc_add_expr_to_block (&se->pre, tmp);
3686	}
3687	se->expr = convert (type, mvar);
3688	}
3689
3690
3691	/* Generate library calls for MIN and MAX intrinsics for character
3692	variables. */
3693	static void
3694	gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3695	{
3696	tree *args;
3697	tree var, len, fndecl, tmp, cond, function;
3698	unsigned int nargs;
3699
3700	nargs = gfc_intrinsic_argument_list_length (expr);
3701	args = XALLOCAVEC (tree, nargs + 4);
3702	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[4], nargs);
3703
3704	/* Create the result variables. */
3705	len = gfc_create_var (gfc_charlen_type_node, "len");
3706	args[0] = gfc_build_addr_expr (NULL_TREE, len);
3707	var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3708	args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3709	args[2] = build_int_cst (integer_type_node, op);
3710	args[3] = build_int_cst (integer_type_node, nargs / 2);
3711
3712	if (expr->ts.kind == 1)
3713	function = gfor_fndecl_string_minmax;
3714	else if (expr->ts.kind == 4)
3715	function = gfor_fndecl_string_minmax_char4;
3716	else
3717	gcc_unreachable ();
3718
3719	/* Make the function call. */
3720	fndecl = build_addr (function);
3721	tmp = build_call_array_loc (input_location,
3722	TREE_TYPE (TREE_TYPE (function)), fndecl,
3723	nargs + 4, args);
3724	gfc_add_expr_to_block (&se->pre, tmp);
3725
3726	/* Free the temporary afterwards, if necessary. */
3727	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3728	len, build_int_cst (TREE_TYPE (len), 0));
3729	tmp = gfc_call_free (var);
3730	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3731	gfc_add_expr_to_block (&se->post, tmp);
3732
3733	se->expr = var;
3734	se->string_length = len;
3735	}
3736
3737
3738	/* Create a symbol node for this intrinsic. The symbol from the frontend
3739	has the generic name. */
3740
3741	static gfc_symbol *
3742	gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3743	{
3744	gfc_symbol *sym;
3745
3746	/* TODO: Add symbols for intrinsic function to the global namespace. */
3747	gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3748	sym = gfc_new_symbol (expr->value.function.name, NULL);
3749
3750	sym->ts = expr->ts;
3751	if (sym->ts.type == BT_CHARACTER)
3752	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3753	sym->attr.external = 1;
3754	sym->attr.function = 1;
3755	sym->attr.always_explicit = 1;
3756	sym->attr.proc = PROC_INTRINSIC;
3757	sym->attr.flavor = FL_PROCEDURE;
3758	sym->result = sym;
3759	if (expr->rank > 0)
3760	{
3761	sym->attr.dimension = 1;
3762	sym->as = gfc_get_array_spec ();
3763	sym->as->type = AS_ASSUMED_SHAPE;
3764	sym->as->rank = expr->rank;
3765	}
3766
3767	gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3768	ignore_optional ? expr->value.function.actual
3769	: NULL);
3770
3771	return sym;
3772	}
3773
3774	/* Remove empty actual arguments. */
3775
3776	static void
3777	remove_empty_actual_arguments (gfc_actual_arglist **ap)
3778	{
3779	while (*ap)
3780	{
3781	if ((*ap)->expr == NULL)
3782	{
3783	gfc_actual_arglist *r = *ap;
3784	*ap = r->next;
3785	r->next = NULL;
3786	gfc_free_actual_arglist (r);
3787	}
3788	else
3789	ap = &((*ap)->next);
3790	}
3791	}
3792
3793	#define MAX_SPEC_ARG 12
3794
3795	/* Make up an fn spec that's right for intrinsic functions that we
3796	want to call. */
3797
3798	static char *
3799	intrinsic_fnspec (gfc_expr *expr)
3800	{
3801	static char fnspec_buf[MAX_SPEC_ARG*2+1];
3802	char *fp;
3803	int i;
3804	int num_char_args;
3805
3806	#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3807
3808	/* Set the fndecl. */
3809	fp = fnspec_buf;
3810	/* Function return value. FIXME: Check if the second letter could
3811	be something other than a space, for further optimization. */
3812	ADD_CHAR ('.');
3813	if (expr->rank == 0)
3814	{
3815	if (expr->ts.type == BT_CHARACTER)
3816	{
3817	ADD_CHAR ('w'); /* Address of character. */
3818	ADD_CHAR ('.'); /* Length of character. */
3819	}
3820	}
3821	else
3822	ADD_CHAR ('w'); /* Return value is a descriptor. */
3823
3824	num_char_args = 0;
3825	for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3826	{
3827	if (a->expr == NULL)
3828	continue;
3829
3830	if (a->name && strcmp (s1: a->name,s2: "%VAL") == 0)
3831	ADD_CHAR ('.');
3832	else
3833	{
3834	if (a->expr->rank > 0)
3835	ADD_CHAR ('r');
3836	else
3837	ADD_CHAR ('R');
3838	}
3839	num_char_args += a->expr->ts.type == BT_CHARACTER;
3840	gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3841	}
3842
3843	for (i = 0; i < num_char_args; i++)
3844	ADD_CHAR ('.');
3845
3846	*fp = '\0';
3847	return fnspec_buf;
3848	}
3849
3850	#undef MAX_SPEC_ARG
3851	#undef ADD_CHAR
3852
3853	/* Generate the right symbol for the specific intrinsic function and
3854	modify the expr accordingly. This assumes that absent optional
3855	arguments should be removed. */
3856
3857	gfc_symbol *
3858	specific_intrinsic_symbol (gfc_expr *expr)
3859	{
3860	gfc_symbol *sym;
3861
3862	sym = gfc_find_intrinsic_symbol (expr);
3863	if (sym == NULL)
3864	{
3865	sym = gfc_get_intrinsic_function_symbol (expr);
3866	sym->ts = expr->ts;
3867	if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3868	sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3869
3870	gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3871	expr->value.function.actual, copy_type: true);
3872	sym->backend_decl
3873	= gfc_get_extern_function_decl (sym, args: expr->value.function.actual,
3874	fnspec: intrinsic_fnspec (expr));
3875	}
3876
3877	remove_empty_actual_arguments (ap: &(expr->value.function.actual));
3878
3879	return sym;
3880	}
3881
3882	/* Generate a call to an external intrinsic function. FIXME: So far,
3883	this only works for functions which are called with well-defined
3884	types; CSHIFT and friends will come later. */
3885
3886	static void
3887	gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3888	{
3889	gfc_symbol *sym;
3890	vec<tree, va_gc> *append_args;
3891	bool specific_symbol;
3892
3893	gcc_assert (!se->ss || se->ss->info->expr == expr);
3894
3895	if (se->ss)
3896	gcc_assert (expr->rank > 0);
3897	else
3898	gcc_assert (expr->rank == 0);
3899
3900	switch (expr->value.function.isym->id)
3901	{
3902	case GFC_ISYM_ANY:
3903	case GFC_ISYM_ALL:
3904	case GFC_ISYM_FINDLOC:
3905	case GFC_ISYM_MAXLOC:
3906	case GFC_ISYM_MINLOC:
3907	case GFC_ISYM_MAXVAL:
3908	case GFC_ISYM_MINVAL:
3909	case GFC_ISYM_NORM2:
3910	case GFC_ISYM_PRODUCT:
3911	case GFC_ISYM_SUM:
3912	specific_symbol = true;
3913	break;
3914	default:
3915	specific_symbol = false;
3916	}
3917
3918	if (specific_symbol)
3919	{
3920	/* Need to copy here because specific_intrinsic_symbol modifies
3921	expr to omit the absent optional arguments. */
3922	expr = gfc_copy_expr (expr);
3923	sym = specific_intrinsic_symbol (expr);
3924	}
3925	else
3926	sym = gfc_get_symbol_for_expr (expr, ignore_optional: se->ignore_optional);
3927
3928	/* Calls to libgfortran_matmul need to be appended special arguments,
3929	to be able to call the BLAS ?gemm functions if required and possible. */
3930	append_args = NULL;
3931	if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3932	&& !expr->external_blas
3933	&& sym->ts.type != BT_LOGICAL)
3934	{
3935	tree cint = gfc_get_int_type (gfc_c_int_kind);
3936
3937	if (flag_external_blas
3938	&& (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3939	&& (sym->ts.kind == 4 || sym->ts.kind == 8))
3940	{
3941	tree gemm_fndecl;
3942
3943	if (sym->ts.type == BT_REAL)
3944	{
3945	if (sym->ts.kind == 4)
3946	gemm_fndecl = gfor_fndecl_sgemm;
3947	else
3948	gemm_fndecl = gfor_fndecl_dgemm;
3949	}
3950	else
3951	{
3952	if (sym->ts.kind == 4)
3953	gemm_fndecl = gfor_fndecl_cgemm;
3954	else
3955	gemm_fndecl = gfor_fndecl_zgemm;
3956	}
3957
3958	vec_alloc (v&: append_args, nelems: 3);
3959	append_args->quick_push (obj: build_int_cst (cint, 1));
3960	append_args->quick_push (obj: build_int_cst (cint,
3961	flag_blas_matmul_limit));
3962	append_args->quick_push (obj: gfc_build_addr_expr (NULL_TREE,
3963	gemm_fndecl));
3964	}
3965	else
3966	{
3967	vec_alloc (v&: append_args, nelems: 3);
3968	append_args->quick_push (obj: build_int_cst (cint, 0));
3969	append_args->quick_push (obj: build_int_cst (cint, 0));
3970	append_args->quick_push (null_pointer_node);
3971	}
3972	}
3973	/* Non-character scalar reduce returns a pointer to a result of size set by
3974	the element size of 'array'. Setting 'sym' allocatable ensures that the
3975	result is deallocated at the appropriate time. */
3976	else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
3977	&& expr->rank == 0 && expr->ts.type != BT_CHARACTER)
3978	sym->attr.allocatable = 1;
3979
3980
3981	gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3982	append_args);
3983
3984	if (specific_symbol)
3985	gfc_free_expr (expr);
3986	else
3987	gfc_free_symbol (sym);
3988	}
3989
3990	/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3991	Implemented as
3992	any(a)
3993	{
3994	forall (i=...)
3995	if (a[i] != 0)
3996	return 1
3997	end forall
3998	return 0
3999	}
4000	all(a)
4001	{
4002	forall (i=...)
4003	if (a[i] == 0)
4004	return 0
4005	end forall
4006	return 1
4007	}
4008	*/
4009	static void
4010	gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4011	{
4012	tree resvar;
4013	stmtblock_t block;
4014	stmtblock_t body;
4015	tree type;
4016	tree tmp;
4017	tree found;
4018	gfc_loopinfo loop;
4019	gfc_actual_arglist *actual;
4020	gfc_ss *arrayss;
4021	gfc_se arrayse;
4022	tree exit_label;
4023
4024	if (se->ss)
4025	{
4026	gfc_conv_intrinsic_funcall (se, expr);
4027	return;
4028	}
4029
4030	actual = expr->value.function.actual;
4031	type = gfc_typenode_for_spec (&expr->ts);
4032	/* Initialize the result. */
4033	resvar = gfc_create_var (type, "test");
4034	if (op == EQ_EXPR)
4035	tmp = convert (type, boolean_true_node);
4036	else
4037	tmp = convert (type, boolean_false_node);
4038	gfc_add_modify (&se->pre, resvar, tmp);
4039
4040	/* Walk the arguments. */
4041	arrayss = gfc_walk_expr (actual->expr);
4042	gcc_assert (arrayss != gfc_ss_terminator);
4043
4044	/* Initialize the scalarizer. */
4045	gfc_init_loopinfo (&loop);
4046	exit_label = gfc_build_label_decl (NULL_TREE);
4047	TREE_USED (exit_label) = 1;
4048	gfc_add_ss_to_loop (&loop, arrayss);
4049
4050	/* Initialize the loop. */
4051	gfc_conv_ss_startstride (&loop);
4052	gfc_conv_loop_setup (&loop, &expr->where);
4053
4054	gfc_mark_ss_chain_used (arrayss, 1);
4055	/* Generate the loop body. */
4056	gfc_start_scalarized_body (&loop, &body);
4057
4058	/* If the condition matches then set the return value. */
4059	gfc_start_block (&block);
4060	if (op == EQ_EXPR)
4061	tmp = convert (type, boolean_false_node);
4062	else
4063	tmp = convert (type, boolean_true_node);
4064	gfc_add_modify (&block, resvar, tmp);
4065
4066	/* And break out of the loop. */
4067	tmp = build1_v (GOTO_EXPR, exit_label);
4068	gfc_add_expr_to_block (&block, tmp);
4069
4070	found = gfc_finish_block (&block);
4071
4072	/* Check this element. */
4073	gfc_init_se (&arrayse, NULL);
4074	gfc_copy_loopinfo_to_se (&arrayse, &loop);
4075	arrayse.ss = arrayss;
4076	gfc_conv_expr_val (se: &arrayse, expr: actual->expr);
4077
4078	gfc_add_block_to_block (&body, &arrayse.pre);
4079	tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4080	build_int_cst (TREE_TYPE (arrayse.expr), 0));
4081	tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4082	gfc_add_expr_to_block (&body, tmp);
4083	gfc_add_block_to_block (&body, &arrayse.post);
4084
4085	gfc_trans_scalarizing_loops (&loop, &body);
4086
4087	/* Add the exit label. */
4088	tmp = build1_v (LABEL_EXPR, exit_label);
4089	gfc_add_expr_to_block (&loop.pre, tmp);
4090
4091	gfc_add_block_to_block (&se->pre, &loop.pre);
4092	gfc_add_block_to_block (&se->pre, &loop.post);
4093	gfc_cleanup_loop (&loop);
4094
4095	se->expr = resvar;
4096	}
4097
4098
4099	/* Generate the constant 180 / pi, which is used in the conversion
4100	of acosd(), asind(), atand(), atan2d(). */
4101
4102	static tree
4103	rad2deg (int kind)
4104	{
4105	tree retval;
4106	mpfr_t pi, t0;
4107
4108	gfc_set_model_kind (kind);
4109	mpfr_init (pi);
4110	mpfr_init (t0);
4111	mpfr_set_si (t0, 180, GFC_RND_MODE);
4112	mpfr_const_pi (pi, GFC_RND_MODE);
4113	mpfr_div (t0, t0, pi, GFC_RND_MODE);
4114	retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4115	mpfr_clear (t0);
4116	mpfr_clear (pi);
4117	return retval;
4118	}
4119
4120
4121	static gfc_intrinsic_map_t *
4122	gfc_lookup_intrinsic (gfc_isym_id id)
4123	{
4124	gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4125	for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4126	if (id == m->id)
4127	break;
4128	gcc_assert (id == m->id);
4129	return m;
4130	}
4131
4132
4133	/* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4134	ASIND(x) is translated into ASIN(x) * 180 / pi.
4135	ATAND(x) is translated into ATAN(x) * 180 / pi. */
4136
4137	static void
4138	gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4139	{
4140	tree arg;
4141	tree atrigd;
4142	tree type;
4143	gfc_intrinsic_map_t *m;
4144
4145	type = gfc_typenode_for_spec (&expr->ts);
4146
4147	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
4148
4149	switch (id)
4150	{
4151	case GFC_ISYM_ACOSD:
4152	m = gfc_lookup_intrinsic (id: GFC_ISYM_ACOS);
4153	break;
4154	case GFC_ISYM_ASIND:
4155	m = gfc_lookup_intrinsic (id: GFC_ISYM_ASIN);
4156	break;
4157	case GFC_ISYM_ATAND:
4158	m = gfc_lookup_intrinsic (id: GFC_ISYM_ATAN);
4159	break;
4160	default:
4161	gcc_unreachable ();
4162	}
4163	atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4164	atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4165
4166	se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4167	fold_convert (type, rad2deg (expr->ts.kind)));
4168	}
4169
4170
4171	/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4172	COS(X) / SIN(X) for COMPLEX argument. */
4173
4174	static void
4175	gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4176	{
4177	gfc_intrinsic_map_t *m;
4178	tree arg;
4179	tree type;
4180
4181	type = gfc_typenode_for_spec (&expr->ts);
4182	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
4183
4184	if (expr->ts.type == BT_REAL)
4185	{
4186	tree tan;
4187	tree tmp;
4188	mpfr_t pio2;
4189
4190	/* Create pi/2. */
4191	gfc_set_model_kind (expr->ts.kind);
4192	mpfr_init (pio2);
4193	mpfr_const_pi (pio2, GFC_RND_MODE);
4194	mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4195	tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4196	mpfr_clear (pio2);
4197
4198	/* Find tan builtin function. */
4199	m = gfc_lookup_intrinsic (id: GFC_ISYM_TAN);
4200	tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4201	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4202	tan = build_call_expr_loc (input_location, tan, 1, tmp);
4203	se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4204	}
4205	else
4206	{
4207	tree sin;
4208	tree cos;
4209
4210	/* Find cos builtin function. */
4211	m = gfc_lookup_intrinsic (id: GFC_ISYM_COS);
4212	cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4213	cos = build_call_expr_loc (input_location, cos, 1, arg);
4214
4215	/* Find sin builtin function. */
4216	m = gfc_lookup_intrinsic (id: GFC_ISYM_SIN);
4217	sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4218	sin = build_call_expr_loc (input_location, sin, 1, arg);
4219
4220	/* Divide cos by sin. */
4221	se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4222	}
4223	}
4224
4225
4226	/* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4227
4228	static void
4229	gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4230	{
4231	tree arg;
4232	tree type;
4233	tree ninety_tree;
4234	mpfr_t ninety;
4235
4236	type = gfc_typenode_for_spec (&expr->ts);
4237	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
4238
4239	gfc_set_model_kind (expr->ts.kind);
4240
4241	/* Build the tree for x + 90. */
4242	mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4243	ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4244	arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4245	mpfr_clear (ninety);
4246
4247	/* Find tand. */
4248	gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (id: GFC_ISYM_TAND);
4249	tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4250	tand = build_call_expr_loc (input_location, tand, 1, arg);
4251
4252	se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4253	}
4254
4255
4256	/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4257
4258	static void
4259	gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4260	{
4261	tree args[2];
4262	tree atan2d;
4263	tree type;
4264
4265	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
4266	type = TREE_TYPE (args[0]);
4267
4268	gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (id: GFC_ISYM_ATAN2);
4269	atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4270	atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4271
4272	se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4273	rad2deg (kind: expr->ts.kind));
4274	}
4275
4276
4277	/* COUNT(A) = Number of true elements in A. */
4278	static void
4279	gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4280	{
4281	tree resvar;
4282	tree type;
4283	stmtblock_t body;
4284	tree tmp;
4285	gfc_loopinfo loop;
4286	gfc_actual_arglist *actual;
4287	gfc_ss *arrayss;
4288	gfc_se arrayse;
4289
4290	if (se->ss)
4291	{
4292	gfc_conv_intrinsic_funcall (se, expr);
4293	return;
4294	}
4295
4296	actual = expr->value.function.actual;
4297
4298	type = gfc_typenode_for_spec (&expr->ts);
4299	/* Initialize the result. */
4300	resvar = gfc_create_var (type, "count");
4301	gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4302
4303	/* Walk the arguments. */
4304	arrayss = gfc_walk_expr (actual->expr);
4305	gcc_assert (arrayss != gfc_ss_terminator);
4306
4307	/* Initialize the scalarizer. */
4308	gfc_init_loopinfo (&loop);
4309	gfc_add_ss_to_loop (&loop, arrayss);
4310
4311	/* Initialize the loop. */
4312	gfc_conv_ss_startstride (&loop);
4313	gfc_conv_loop_setup (&loop, &expr->where);
4314
4315	gfc_mark_ss_chain_used (arrayss, 1);
4316	/* Generate the loop body. */
4317	gfc_start_scalarized_body (&loop, &body);
4318
4319	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4320	resvar, build_int_cst (TREE_TYPE (resvar), 1));
4321	tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4322
4323	gfc_init_se (&arrayse, NULL);
4324	gfc_copy_loopinfo_to_se (&arrayse, &loop);
4325	arrayse.ss = arrayss;
4326	gfc_conv_expr_val (se: &arrayse, expr: actual->expr);
4327	tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4328	build_empty_stmt (input_location));
4329
4330	gfc_add_block_to_block (&body, &arrayse.pre);
4331	gfc_add_expr_to_block (&body, tmp);
4332	gfc_add_block_to_block (&body, &arrayse.post);
4333
4334	gfc_trans_scalarizing_loops (&loop, &body);
4335
4336	gfc_add_block_to_block (&se->pre, &loop.pre);
4337	gfc_add_block_to_block (&se->pre, &loop.post);
4338	gfc_cleanup_loop (&loop);
4339
4340	se->expr = resvar;
4341	}
4342
4343
4344	/* Update given gfc_se to have ss component pointing to the nested gfc_ss
4345	struct and return the corresponding loopinfo. */
4346
4347	static gfc_loopinfo *
4348	enter_nested_loop (gfc_se *se)
4349	{
4350	se->ss = se->ss->nested_ss;
4351	gcc_assert (se->ss == se->ss->loop->ss);
4352
4353	return se->ss->loop;
4354	}
4355
4356	/* Build the condition for a mask, which may be optional. */
4357
4358	static tree
4359	conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4360	bool optional_mask)
4361	{
4362	tree present;
4363	tree type;
4364
4365	if (optional_mask)
4366	{
4367	type = TREE_TYPE (maskse->expr);
4368	present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4369	present = convert (type, present);
4370	present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4371	present);
4372	return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4373	type, present, maskse->expr);
4374	}
4375	else
4376	return maskse->expr;
4377	}
4378
4379	/* Inline implementation of the sum and product intrinsics. */
4380	static void
4381	gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4382	bool norm2)
4383	{
4384	tree resvar;
4385	tree scale = NULL_TREE;
4386	tree type;
4387	stmtblock_t body;
4388	stmtblock_t block;
4389	tree tmp;
4390	gfc_loopinfo loop, *ploop;
4391	gfc_actual_arglist *arg_array, *arg_mask;
4392	gfc_ss *arrayss = NULL;
4393	gfc_ss *maskss = NULL;
4394	gfc_se arrayse;
4395	gfc_se maskse;
4396	gfc_se *parent_se;
4397	gfc_expr *arrayexpr;
4398	gfc_expr *maskexpr;
4399	bool optional_mask;
4400
4401	if (expr->rank > 0)
4402	{
4403	gcc_assert (gfc_inline_intrinsic_function_p (expr));
4404	parent_se = se;
4405	}
4406	else
4407	parent_se = NULL;
4408
4409	type = gfc_typenode_for_spec (&expr->ts);
4410	/* Initialize the result. */
4411	resvar = gfc_create_var (type, "val");
4412	if (norm2)
4413	{
4414	/* result = 0.0;
4415	scale = 1.0. */
4416	scale = gfc_create_var (type, "scale");
4417	gfc_add_modify (&se->pre, scale,
4418	gfc_build_const (type, integer_one_node));
4419	tmp = gfc_build_const (type, integer_zero_node);
4420	}
4421	else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4422	tmp = gfc_build_const (type, integer_zero_node);
4423	else if (op == NE_EXPR)
4424	/* PARITY. */
4425	tmp = convert (type, boolean_false_node);
4426	else if (op == BIT_AND_EXPR)
4427	tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4428	type, integer_one_node));
4429	else
4430	tmp = gfc_build_const (type, integer_one_node);
4431
4432	gfc_add_modify (&se->pre, resvar, tmp);
4433
4434	arg_array = expr->value.function.actual;
4435
4436	arrayexpr = arg_array->expr;
4437
4438	if (op == NE_EXPR || norm2)
4439	{
4440	/* PARITY and NORM2. */
4441	maskexpr = NULL;
4442	optional_mask = false;
4443	}
4444	else
4445	{
4446	arg_mask = arg_array->next->next;
4447	gcc_assert (arg_mask != NULL);
4448	maskexpr = arg_mask->expr;
4449	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4450	&& maskexpr->symtree->n.sym->attr.dummy
4451	&& maskexpr->symtree->n.sym->attr.optional;
4452	}
4453
4454	if (expr->rank == 0)
4455	{
4456	/* Walk the arguments. */
4457	arrayss = gfc_walk_expr (arrayexpr);
4458	gcc_assert (arrayss != gfc_ss_terminator);
4459
4460	if (maskexpr && maskexpr->rank > 0)
4461	{
4462	maskss = gfc_walk_expr (maskexpr);
4463	gcc_assert (maskss != gfc_ss_terminator);
4464	}
4465	else
4466	maskss = NULL;
4467
4468	/* Initialize the scalarizer. */
4469	gfc_init_loopinfo (&loop);
4470
4471	/* We add the mask first because the number of iterations is
4472	taken from the last ss, and this breaks if an absent
4473	optional argument is used for mask. */
4474
4475	if (maskexpr && maskexpr->rank > 0)
4476	gfc_add_ss_to_loop (&loop, maskss);
4477	gfc_add_ss_to_loop (&loop, arrayss);
4478
4479	/* Initialize the loop. */
4480	gfc_conv_ss_startstride (&loop);
4481	gfc_conv_loop_setup (&loop, &expr->where);
4482
4483	if (maskexpr && maskexpr->rank > 0)
4484	gfc_mark_ss_chain_used (maskss, 1);
4485	gfc_mark_ss_chain_used (arrayss, 1);
4486
4487	ploop = &loop;
4488	}
4489	else
4490	/* All the work has been done in the parent loops. */
4491	ploop = enter_nested_loop (se);
4492
4493	gcc_assert (ploop);
4494
4495	/* Generate the loop body. */
4496	gfc_start_scalarized_body (ploop, &body);
4497
4498	/* If we have a mask, only add this element if the mask is set. */
4499	if (maskexpr && maskexpr->rank > 0)
4500	{
4501	gfc_init_se (&maskse, parent_se);
4502	gfc_copy_loopinfo_to_se (&maskse, ploop);
4503	if (expr->rank == 0)
4504	maskse.ss = maskss;
4505	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
4506	gfc_add_block_to_block (&body, &maskse.pre);
4507
4508	gfc_start_block (&block);
4509	}
4510	else
4511	gfc_init_block (&block);
4512
4513	/* Do the actual summation/product. */
4514	gfc_init_se (&arrayse, parent_se);
4515	gfc_copy_loopinfo_to_se (&arrayse, ploop);
4516	if (expr->rank == 0)
4517	arrayse.ss = arrayss;
4518	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
4519	gfc_add_block_to_block (&block, &arrayse.pre);
4520
4521	if (norm2)
4522	{
4523	/* if (x (i) != 0.0)
4524	{
4525	absX = abs(x(i))
4526	if (absX > scale)
4527	{
4528	val = scale/absX;
4529	result = 1.0 + result * val * val;
4530	scale = absX;
4531	}
4532	else
4533	{
4534	val = absX/scale;
4535	result += val * val;
4536	}
4537	} */
4538	tree res1, res2, cond, absX, val;
4539	stmtblock_t ifblock1, ifblock2, ifblock3;
4540
4541	gfc_init_block (&ifblock1);
4542
4543	absX = gfc_create_var (type, "absX");
4544	gfc_add_modify (&ifblock1, absX,
4545	fold_build1_loc (input_location, ABS_EXPR, type,
4546	arrayse.expr));
4547	val = gfc_create_var (type, "val");
4548	gfc_add_expr_to_block (&ifblock1, val);
4549
4550	gfc_init_block (&ifblock2);
4551	gfc_add_modify (&ifblock2, val,
4552	fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4553	absX));
4554	res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4555	res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4556	res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4557	gfc_build_const (type, integer_one_node));
4558	gfc_add_modify (&ifblock2, resvar, res1);
4559	gfc_add_modify (&ifblock2, scale, absX);
4560	res1 = gfc_finish_block (&ifblock2);
4561
4562	gfc_init_block (&ifblock3);
4563	gfc_add_modify (&ifblock3, val,
4564	fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4565	scale));
4566	res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4567	res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4568	gfc_add_modify (&ifblock3, resvar, res2);
4569	res2 = gfc_finish_block (&ifblock3);
4570
4571	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4572	absX, scale);
4573	tmp = build3_v (COND_EXPR, cond, res1, res2);
4574	gfc_add_expr_to_block (&ifblock1, tmp);
4575	tmp = gfc_finish_block (&ifblock1);
4576
4577	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4578	arrayse.expr,
4579	gfc_build_const (type, integer_zero_node));
4580
4581	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4582	gfc_add_expr_to_block (&block, tmp);
4583	}
4584	else
4585	{
4586	tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4587	gfc_add_modify (&block, resvar, tmp);
4588	}
4589
4590	gfc_add_block_to_block (&block, &arrayse.post);
4591
4592	if (maskexpr && maskexpr->rank > 0)
4593	{
4594	/* We enclose the above in if (mask) {...} . If the mask is an
4595	optional argument, generate
4596	IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4597	tree ifmask;
4598	tmp = gfc_finish_block (&block);
4599	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
4600	tmp = build3_v (COND_EXPR, ifmask, tmp,
4601	build_empty_stmt (input_location));
4602	}
4603	else
4604	tmp = gfc_finish_block (&block);
4605	gfc_add_expr_to_block (&body, tmp);
4606
4607	gfc_trans_scalarizing_loops (ploop, &body);
4608
4609	/* For a scalar mask, enclose the loop in an if statement. */
4610	if (maskexpr && maskexpr->rank == 0)
4611	{
4612	gfc_init_block (&block);
4613	gfc_add_block_to_block (&block, &ploop->pre);
4614	gfc_add_block_to_block (&block, &ploop->post);
4615	tmp = gfc_finish_block (&block);
4616
4617	if (expr->rank > 0)
4618	{
4619	tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4620	build_empty_stmt (input_location));
4621	gfc_advance_se_ss_chain (se);
4622	}
4623	else
4624	{
4625	tree ifmask;
4626
4627	gcc_assert (expr->rank == 0);
4628	gfc_init_se (&maskse, NULL);
4629	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
4630	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
4631	tmp = build3_v (COND_EXPR, ifmask, tmp,
4632	build_empty_stmt (input_location));
4633	}
4634
4635	gfc_add_expr_to_block (&block, tmp);
4636	gfc_add_block_to_block (&se->pre, &block);
4637	gcc_assert (se->post.head == NULL);
4638	}
4639	else
4640	{
4641	gfc_add_block_to_block (&se->pre, &ploop->pre);
4642	gfc_add_block_to_block (&se->pre, &ploop->post);
4643	}
4644
4645	if (expr->rank == 0)
4646	gfc_cleanup_loop (ploop);
4647
4648	if (norm2)
4649	{
4650	/* result = scale * sqrt(result). */
4651	tree sqrt;
4652	sqrt = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SQRT, kind: expr->ts.kind);
4653	resvar = build_call_expr_loc (input_location,
4654	sqrt, 1, resvar);
4655	resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4656	}
4657
4658	se->expr = resvar;
4659	}
4660
4661
4662	/* Inline implementation of the dot_product intrinsic. This function
4663	is based on gfc_conv_intrinsic_arith (the previous function). */
4664	static void
4665	gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4666	{
4667	tree resvar;
4668	tree type;
4669	stmtblock_t body;
4670	stmtblock_t block;
4671	tree tmp;
4672	gfc_loopinfo loop;
4673	gfc_actual_arglist *actual;
4674	gfc_ss *arrayss1, *arrayss2;
4675	gfc_se arrayse1, arrayse2;
4676	gfc_expr *arrayexpr1, *arrayexpr2;
4677
4678	type = gfc_typenode_for_spec (&expr->ts);
4679
4680	/* Initialize the result. */
4681	resvar = gfc_create_var (type, "val");
4682	if (expr->ts.type == BT_LOGICAL)
4683	tmp = build_int_cst (type, 0);
4684	else
4685	tmp = gfc_build_const (type, integer_zero_node);
4686
4687	gfc_add_modify (&se->pre, resvar, tmp);
4688
4689	/* Walk argument #1. */
4690	actual = expr->value.function.actual;
4691	arrayexpr1 = actual->expr;
4692	arrayss1 = gfc_walk_expr (arrayexpr1);
4693	gcc_assert (arrayss1 != gfc_ss_terminator);
4694
4695	/* Walk argument #2. */
4696	actual = actual->next;
4697	arrayexpr2 = actual->expr;
4698	arrayss2 = gfc_walk_expr (arrayexpr2);
4699	gcc_assert (arrayss2 != gfc_ss_terminator);
4700
4701	/* Initialize the scalarizer. */
4702	gfc_init_loopinfo (&loop);
4703	gfc_add_ss_to_loop (&loop, arrayss1);
4704	gfc_add_ss_to_loop (&loop, arrayss2);
4705
4706	/* Initialize the loop. */
4707	gfc_conv_ss_startstride (&loop);
4708	gfc_conv_loop_setup (&loop, &expr->where);
4709
4710	gfc_mark_ss_chain_used (arrayss1, 1);
4711	gfc_mark_ss_chain_used (arrayss2, 1);
4712
4713	/* Generate the loop body. */
4714	gfc_start_scalarized_body (&loop, &body);
4715	gfc_init_block (&block);
4716
4717	/* Make the tree expression for [conjg(]array1[)]. */
4718	gfc_init_se (&arrayse1, NULL);
4719	gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4720	arrayse1.ss = arrayss1;
4721	gfc_conv_expr_val (se: &arrayse1, expr: arrayexpr1);
4722	if (expr->ts.type == BT_COMPLEX)
4723	arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4724	arrayse1.expr);
4725	gfc_add_block_to_block (&block, &arrayse1.pre);
4726
4727	/* Make the tree expression for array2. */
4728	gfc_init_se (&arrayse2, NULL);
4729	gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4730	arrayse2.ss = arrayss2;
4731	gfc_conv_expr_val (se: &arrayse2, expr: arrayexpr2);
4732	gfc_add_block_to_block (&block, &arrayse2.pre);
4733
4734	/* Do the actual product and sum. */
4735	if (expr->ts.type == BT_LOGICAL)
4736	{
4737	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4738	arrayse1.expr, arrayse2.expr);
4739	tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4740	}
4741	else
4742	{
4743	tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4744	arrayse2.expr);
4745	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4746	}
4747	gfc_add_modify (&block, resvar, tmp);
4748
4749	/* Finish up the loop block and the loop. */
4750	tmp = gfc_finish_block (&block);
4751	gfc_add_expr_to_block (&body, tmp);
4752
4753	gfc_trans_scalarizing_loops (&loop, &body);
4754	gfc_add_block_to_block (&se->pre, &loop.pre);
4755	gfc_add_block_to_block (&se->pre, &loop.post);
4756	gfc_cleanup_loop (&loop);
4757
4758	se->expr = resvar;
4759	}
4760
4761
4762	/* Tells whether the expression E is a reference to an optional variable whose
4763	presence is not known at compile time. Those are variable references without
4764	subreference; if there is a subreference, we can assume the variable is
4765	present. We have to special case full arrays, which we represent with a fake
4766	"full" reference, and class descriptors for which a reference to data is not
4767	really a subreference. */
4768
4769	bool
4770	maybe_absent_optional_variable (gfc_expr *e)
4771	{
4772	if (!(e && e->expr_type == EXPR_VARIABLE))
4773	return false;
4774
4775	gfc_symbol *sym = e->symtree->n.sym;
4776	if (!sym->attr.optional)
4777	return false;
4778
4779	gfc_ref *ref = e->ref;
4780	if (ref == nullptr)
4781	return true;
4782
4783	if (ref->type == REF_ARRAY
4784	&& ref->u.ar.type == AR_FULL
4785	&& ref->next == nullptr)
4786	return true;
4787
4788	if (!(sym->ts.type == BT_CLASS
4789	&& ref->type == REF_COMPONENT
4790	&& ref->u.c.component == CLASS_DATA (sym)))
4791	return false;
4792
4793	gfc_ref *next_ref = ref->next;
4794	if (next_ref == nullptr)
4795	return true;
4796
4797	if (next_ref->type == REF_ARRAY
4798	&& next_ref->u.ar.type == AR_FULL
4799	&& next_ref->next == nullptr)
4800	return true;
4801
4802	return false;
4803	}
4804
4805
4806	/* Emit code for minloc or maxloc intrinsic. There are many different cases
4807	we need to handle. For performance reasons we sometimes create two
4808	loops instead of one, where the second one is much simpler.
4809	Examples for minloc intrinsic:
4810	A: Result is scalar.
4811	1) Array mask is used and NaNs need to be supported:
4812	limit = Infinity;
4813	pos = 0;
4814	S = from;
4815	while (S <= to) {
4816	if (mask[S]) {
4817	if (pos == 0) pos = S + (1 - from);
4818	if (a[S] <= limit) {
4819	limit = a[S];
4820	pos = S + (1 - from);
4821	goto lab1;
4822	}
4823	}
4824	S++;
4825	}
4826	goto lab2;
4827	lab1:;
4828	while (S <= to) {
4829	if (mask[S])
4830	if (a[S] < limit) {
4831	limit = a[S];
4832	pos = S + (1 - from);
4833	}
4834	S++;
4835	}
4836	lab2:;
4837	2) NaNs need to be supported, but it is known at compile time or cheaply
4838	at runtime whether array is nonempty or not:
4839	limit = Infinity;
4840	pos = 0;
4841	S = from;
4842	while (S <= to) {
4843	if (a[S] <= limit) {
4844	limit = a[S];
4845	pos = S + (1 - from);
4846	goto lab1;
4847	}
4848	S++;
4849	}
4850	if (from <= to) pos = 1;
4851	goto lab2;
4852	lab1:;
4853	while (S <= to) {
4854	if (a[S] < limit) {
4855	limit = a[S];
4856	pos = S + (1 - from);
4857	}
4858	S++;
4859	}
4860	lab2:;
4861	3) NaNs aren't supported, array mask is used:
4862	limit = infinities_supported ? Infinity : huge (limit);
4863	pos = 0;
4864	S = from;
4865	while (S <= to) {
4866	if (mask[S]) {
4867	limit = a[S];
4868	pos = S + (1 - from);
4869	goto lab1;
4870	}
4871	S++;
4872	}
4873	goto lab2;
4874	lab1:;
4875	while (S <= to) {
4876	if (mask[S])
4877	if (a[S] < limit) {
4878	limit = a[S];
4879	pos = S + (1 - from);
4880	}
4881	S++;
4882	}
4883	lab2:;
4884	4) Same without array mask:
4885	limit = infinities_supported ? Infinity : huge (limit);
4886	pos = (from <= to) ? 1 : 0;
4887	S = from;
4888	while (S <= to) {
4889	if (a[S] < limit) {
4890	limit = a[S];
4891	pos = S + (1 - from);
4892	}
4893	S++;
4894	}
4895	B: Array result, non-CHARACTER type, DIM absent
4896	Generate similar code as in the scalar case, using a collection of
4897	variables (one per dimension) instead of a single variable as result.
4898	Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4899	becomes:
4900	1) Array mask is used and NaNs need to be supported:
4901	limit = Infinity;
4902	pos0 = 0;
4903	pos1 = 0;
4904	S1 = from1;
4905	second_loop_entry = false;
4906	while (S1 <= to1) {
4907	S0 = from0;
4908	while (s0 <= to0 {
4909	if (mask[S1][S0]) {
4910	if (pos0 == 0) {
4911	pos0 = S0 + (1 - from0);
4912	pos1 = S1 + (1 - from1);
4913	}
4914	if (a[S1][S0] <= limit) {
4915	limit = a[S1][S0];
4916	pos0 = S0 + (1 - from0);
4917	pos1 = S1 + (1 - from1);
4918	second_loop_entry = true;
4919	goto lab1;
4920	}
4921	}
4922	S0++;
4923	}
4924	S1++;
4925	}
4926	goto lab2;
4927	lab1:;
4928	S1 = second_loop_entry ? S1 : from1;
4929	while (S1 <= to1) {
4930	S0 = second_loop_entry ? S0 : from0;
4931	while (S0 <= to0) {
4932	if (mask[S1][S0])
4933	if (a[S1][S0] < limit) {
4934	limit = a[S1][S0];
4935	pos0 = S + (1 - from0);
4936	pos1 = S + (1 - from1);
4937	}
4938	second_loop_entry = false;
4939	S0++;
4940	}
4941	S1++;
4942	}
4943	lab2:;
4944	result = { pos0, pos1 };
4945	...
4946	4) NANs aren't supported, no array mask.
4947	limit = infinities_supported ? Infinity : huge (limit);
4948	pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4949	pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4950	S1 = from1;
4951	while (S1 <= to1) {
4952	S0 = from0;
4953	while (S0 <= to0) {
4954	if (a[S1][S0] < limit) {
4955	limit = a[S1][S0];
4956	pos0 = S + (1 - from0);
4957	pos1 = S + (1 - from1);
4958	}
4959	S0++;
4960	}
4961	S1++;
4962	}
4963	result = { pos0, pos1 };
4964	C: Otherwise, a call is generated.
4965	For 2) and 4), if mask is scalar, this all goes into a conditional,
4966	setting pos = 0; in the else branch.
4967
4968	Since we now also support the BACK argument, instead of using
4969	if (a[S] < limit), we now use
4970
4971	if (back)
4972	cond = a[S] <= limit;
4973	else
4974	cond = a[S] < limit;
4975	if (cond) {
4976	....
4977
4978	The optimizer is smart enough to move the condition out of the loop.
4979	They are now marked as unlikely too for further speedup. */
4980
4981	static void
4982	gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
4983	{
4984	stmtblock_t body;
4985	stmtblock_t block;
4986	stmtblock_t ifblock;
4987	stmtblock_t elseblock;
4988	tree limit;
4989	tree type;
4990	tree tmp;
4991	tree cond;
4992	tree elsetmp;
4993	tree ifbody;
4994	tree offset[GFC_MAX_DIMENSIONS];
4995	tree nonempty;
4996	tree lab1, lab2;
4997	tree b_if, b_else;
4998	tree back;
4999	gfc_loopinfo loop, *ploop;
5000	gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5001	gfc_actual_arglist *back_arg;
5002	gfc_ss *arrayss = nullptr;
5003	gfc_ss *maskss = nullptr;
5004	gfc_ss *orig_ss = nullptr;
5005	gfc_se arrayse;
5006	gfc_se maskse;
5007	gfc_se nested_se;
5008	gfc_se *base_se;
5009	gfc_expr *arrayexpr;
5010	gfc_expr *maskexpr;
5011	gfc_expr *backexpr;
5012	gfc_se backse;
5013	tree pos[GFC_MAX_DIMENSIONS];
5014	tree idx[GFC_MAX_DIMENSIONS];
5015	tree result_var = NULL_TREE;
5016	int n;
5017	bool optional_mask;
5018
5019	array_arg = expr->value.function.actual;
5020	dim_arg = array_arg->next;
5021	mask_arg = dim_arg->next;
5022	kind_arg = mask_arg->next;
5023	back_arg = kind_arg->next;
5024
5025	bool dim_present = dim_arg->expr != nullptr;
5026	bool nested_loop = dim_present && expr->rank > 0;
5027
5028	/* Remove kind. */
5029	if (kind_arg->expr)
5030	{
5031	gfc_free_expr (kind_arg->expr);
5032	kind_arg->expr = NULL;
5033	}
5034
5035	/* Pass BACK argument by value. */
5036	back_arg->name = "%VAL";
5037
5038	if (se->ss)
5039	{
5040	if (se->ss->info->useflags)
5041	{
5042	if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5043	{
5044	/* The code generating and initializing the result array has been
5045	generated already before the scalarization loop, either with a
5046	library function call or with inline code; now we can just use
5047	the result. */
5048	gfc_conv_tmp_array_ref (se);
5049	return;
5050	}
5051	}
5052	else if (!gfc_inline_intrinsic_function_p (expr))
5053	{
5054	gfc_conv_intrinsic_funcall (se, expr);
5055	return;
5056	}
5057	}
5058
5059	arrayexpr = array_arg->expr;
5060
5061	/* Special case for character maxloc. Remove unneeded "dim" actual
5062	argument, then call a library function. */
5063
5064	if (arrayexpr->ts.type == BT_CHARACTER)
5065	{
5066	gcc_assert (expr->rank == 0);
5067
5068	if (dim_arg->expr)
5069	{
5070	gfc_free_expr (dim_arg->expr);
5071	dim_arg->expr = NULL;
5072	}
5073	gfc_conv_intrinsic_funcall (se, expr);
5074	return;
5075	}
5076
5077	type = gfc_typenode_for_spec (&expr->ts);
5078
5079	if (expr->rank > 0 && !dim_present)
5080	{
5081	gfc_array_spec as;
5082	memset (s: &as, c: 0, n: sizeof (as));
5083
5084	as.rank = 1;
5085	as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5086	&arrayexpr->where,
5087	HOST_WIDE_INT_1);
5088	as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5089	&arrayexpr->where,
5090	arrayexpr->rank);
5091
5092	tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5093
5094	result_var = gfc_create_var (array, "loc_result");
5095	}
5096
5097	const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5098
5099	/* Initialize the result. */
5100	for (int i = 0; i < reduction_dimensions; i++)
5101	{
5102	pos[i] = gfc_create_var (gfc_array_index_type,
5103	gfc_get_string ("pos%d", i));
5104	offset[i] = gfc_create_var (gfc_array_index_type,
5105	gfc_get_string ("offset%d", i));
5106	idx[i] = gfc_create_var (gfc_array_index_type,
5107	gfc_get_string ("idx%d", i));
5108	}
5109
5110	maskexpr = mask_arg->expr;
5111	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5112	&& maskexpr->symtree->n.sym->attr.dummy
5113	&& maskexpr->symtree->n.sym->attr.optional;
5114	backexpr = back_arg->expr;
5115
5116	gfc_init_se (&backse, nested_loop ? se : nullptr);
5117	if (backexpr == nullptr)
5118	back = logical_false_node;
5119	else if (maybe_absent_optional_variable (e: backexpr))
5120	{
5121	/* This should have been checked already by
5122	maybe_absent_optional_variable. */
5123	gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5124
5125	gfc_conv_expr (se: &backse, expr: backexpr);
5126	tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, use_saved_decl: false);
5127	back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5128	logical_type_node, present, backse.expr);
5129	}
5130	else
5131	{
5132	gfc_conv_expr (se: &backse, expr: backexpr);
5133	back = backse.expr;
5134	}
5135	gfc_add_block_to_block (&se->pre, &backse.pre);
5136	back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5137	gfc_add_block_to_block (&se->pre, &backse.post);
5138
5139	if (nested_loop)
5140	{
5141	gfc_init_se (&nested_se, se);
5142	base_se = &nested_se;
5143	}
5144	else
5145	{
5146	/* Walk the arguments. */
5147	arrayss = gfc_walk_expr (arrayexpr);
5148	gcc_assert (arrayss != gfc_ss_terminator);
5149
5150	if (maskexpr && maskexpr->rank != 0)
5151	{
5152	maskss = gfc_walk_expr (maskexpr);
5153	gcc_assert (maskss != gfc_ss_terminator);
5154	}
5155
5156	base_se = nullptr;
5157	}
5158
5159	nonempty = nullptr;
5160	if (!(maskexpr && maskexpr->rank > 0))
5161	{
5162	mpz_t asize;
5163	bool reduction_size_known;
5164
5165	if (dim_present)
5166	{
5167	int reduction_dim;
5168	if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5169	reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5170	else if (arrayexpr->rank == 1)
5171	reduction_dim = 0;
5172	else
5173	gcc_unreachable ();
5174	reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5175	&asize);
5176	}
5177	else
5178	reduction_size_known = gfc_array_size (arrayexpr, &asize);
5179
5180	if (reduction_size_known)
5181	{
5182	nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5183	mpz_clear (asize);
5184	nonempty = fold_build2_loc (input_location, GT_EXPR,
5185	logical_type_node, nonempty,
5186	gfc_index_zero_node);
5187	}
5188	maskss = NULL;
5189	}
5190
5191	limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5192	switch (arrayexpr->ts.type)
5193	{
5194	case BT_REAL:
5195	tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5196	break;
5197
5198	case BT_INTEGER:
5199	n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5200	tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5201	arrayexpr->ts.kind);
5202	break;
5203
5204	case BT_UNSIGNED:
5205	/* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5206	if (op == GT_EXPR)
5207	{
5208	tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5209	tmp = build_int_cst (tmp, 0);
5210	}
5211	else
5212	{
5213	n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5214	tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5215	expr->ts.kind);
5216	}
5217	break;
5218
5219	default:
5220	gcc_unreachable ();
5221	}
5222
5223	/* We start with the most negative possible value for MAXLOC, and the most
5224	positive possible value for MINLOC. The most negative possible value is
5225	-HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5226	possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5227	with above. */
5228	if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5229	tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5230	if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5231	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5232	build_int_cst (TREE_TYPE (tmp), 1));
5233
5234	gfc_add_modify (&se->pre, limit, tmp);
5235
5236	/* If we are in a case where we generate two sets of loops, the second one
5237	should continue where the first stopped instead of restarting from the
5238	beginning. So nested loops in the second set should have a partial range
5239	on the first iteration, but they should start from the beginning and span
5240	their full range on the following iterations. So we use conditionals in
5241	the loops lower bounds, and use the following variable in those
5242	conditionals to decide whether to use the original loop bound or to use
5243	the index at which the loop from the first set stopped. */
5244	tree second_loop_entry = gfc_create_var (logical_type_node,
5245	"second_loop_entry");
5246	gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5247
5248	if (nested_loop)
5249	{
5250	ploop = enter_nested_loop (se: &nested_se);
5251	orig_ss = nested_se.ss;
5252	ploop->temp_dim = 1;
5253	}
5254	else
5255	{
5256	/* Initialize the scalarizer. */
5257	gfc_init_loopinfo (&loop);
5258
5259	/* We add the mask first because the number of iterations is taken
5260	from the last ss, and this breaks if an absent optional argument
5261	is used for mask. */
5262
5263	if (maskss)
5264	gfc_add_ss_to_loop (&loop, maskss);
5265
5266	gfc_add_ss_to_loop (&loop, arrayss);
5267
5268	/* Initialize the loop. */
5269	gfc_conv_ss_startstride (&loop);
5270
5271	/* The code generated can have more than one loop in sequence (see the
5272	comment at the function header). This doesn't work well with the
5273	scalarizer, which changes arrays' offset when the scalarization loops
5274	are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5275	the scalarizer temporary code to handle multiple loops. Thus, we set
5276	temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5277	we use gfc_trans_scalarized_loop_boundary even later to restore
5278	offset. */
5279	loop.temp_dim = loop.dimen;
5280	gfc_conv_loop_setup (&loop, &expr->where);
5281
5282	ploop = &loop;
5283	}
5284
5285	gcc_assert (reduction_dimensions == ploop->dimen);
5286
5287	if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5288	{
5289	nonempty = logical_true_node;
5290
5291	for (int i = 0; i < ploop->dimen; i++)
5292	{
5293	if (!(ploop->from[i] && ploop->to[i]))
5294	{
5295	nonempty = NULL;
5296	break;
5297	}
5298
5299	tree tmp = fold_build2_loc (input_location, LE_EXPR,
5300	logical_type_node, ploop->from[i],
5301	ploop->to[i]);
5302
5303	nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5304	logical_type_node, nonempty, tmp);
5305	}
5306	}
5307
5308	lab1 = NULL;
5309	lab2 = NULL;
5310	/* Initialize the position to zero, following Fortran 2003. We are free
5311	to do this because Fortran 95 allows the result of an entirely false
5312	mask to be processor dependent. If we know at compile time the array
5313	is non-empty and no MASK is used, we can initialize to 1 to simplify
5314	the inner loop. */
5315	if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5316	{
5317	tree init = fold_build3_loc (input_location, COND_EXPR,
5318	gfc_array_index_type, nonempty,
5319	gfc_index_one_node,
5320	gfc_index_zero_node);
5321	for (int i = 0; i < ploop->dimen; i++)
5322	gfc_add_modify (&ploop->pre, pos[i], init);
5323	}
5324	else
5325	{
5326	for (int i = 0; i < ploop->dimen; i++)
5327	gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5328	lab1 = gfc_build_label_decl (NULL_TREE);
5329	TREE_USED (lab1) = 1;
5330	lab2 = gfc_build_label_decl (NULL_TREE);
5331	TREE_USED (lab2) = 1;
5332	}
5333
5334	/* An offset must be added to the loop
5335	counter to obtain the required position. */
5336	for (int i = 0; i < ploop->dimen; i++)
5337	{
5338	gcc_assert (ploop->from[i]);
5339
5340	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5341	gfc_index_one_node, ploop->from[i]);
5342	gfc_add_modify (&ploop->pre, offset[i], tmp);
5343	}
5344
5345	if (!nested_loop)
5346	{
5347	gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5348	if (maskss)
5349	gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5350	}
5351
5352	/* Generate the loop body. */
5353	gfc_start_scalarized_body (ploop, &body);
5354
5355	/* If we have a mask, only check this element if the mask is set. */
5356	if (maskexpr && maskexpr->rank > 0)
5357	{
5358	gfc_init_se (&maskse, base_se);
5359	gfc_copy_loopinfo_to_se (&maskse, ploop);
5360	if (!nested_loop)
5361	maskse.ss = maskss;
5362	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5363	gfc_add_block_to_block (&body, &maskse.pre);
5364
5365	gfc_start_block (&block);
5366	}
5367	else
5368	gfc_init_block (&block);
5369
5370	/* Compare with the current limit. */
5371	gfc_init_se (&arrayse, base_se);
5372	gfc_copy_loopinfo_to_se (&arrayse, ploop);
5373	if (!nested_loop)
5374	arrayse.ss = arrayss;
5375	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
5376	gfc_add_block_to_block (&block, &arrayse.pre);
5377
5378	/* We do the following if this is a more extreme value. */
5379	gfc_start_block (&ifblock);
5380
5381	/* Assign the value to the limit... */
5382	gfc_add_modify (&ifblock, limit, arrayse.expr);
5383
5384	if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5385	{
5386	stmtblock_t ifblock2;
5387	tree ifbody2;
5388
5389	gfc_start_block (&ifblock2);
5390	for (int i = 0; i < ploop->dimen; i++)
5391	{
5392	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5393	ploop->loopvar[i], offset[i]);
5394	gfc_add_modify (&ifblock2, pos[i], tmp);
5395	}
5396	ifbody2 = gfc_finish_block (&ifblock2);
5397
5398	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5399	pos[0], gfc_index_zero_node);
5400	tmp = build3_v (COND_EXPR, cond, ifbody2,
5401	build_empty_stmt (input_location));
5402	gfc_add_expr_to_block (&block, tmp);
5403	}
5404
5405	for (int i = 0; i < ploop->dimen; i++)
5406	{
5407	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5408	ploop->loopvar[i], offset[i]);
5409	gfc_add_modify (&ifblock, pos[i], tmp);
5410	gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5411	}
5412
5413	gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5414
5415	if (lab1)
5416	gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5417
5418	ifbody = gfc_finish_block (&ifblock);
5419
5420	if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5421	{
5422	if (lab1)
5423	cond = fold_build2_loc (input_location,
5424	op == GT_EXPR ? GE_EXPR : LE_EXPR,
5425	logical_type_node, arrayse.expr, limit);
5426	else
5427	{
5428	tree ifbody2, elsebody2;
5429
5430	/* We switch to > or >= depending on the value of the BACK argument. */
5431	cond = gfc_create_var (logical_type_node, "cond");
5432
5433	gfc_start_block (&ifblock);
5434	b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5435	logical_type_node, arrayse.expr, limit);
5436
5437	gfc_add_modify (&ifblock, cond, b_if);
5438	ifbody2 = gfc_finish_block (&ifblock);
5439
5440	gfc_start_block (&elseblock);
5441	b_else = fold_build2_loc (input_location, op, logical_type_node,
5442	arrayse.expr, limit);
5443
5444	gfc_add_modify (&elseblock, cond, b_else);
5445	elsebody2 = gfc_finish_block (&elseblock);
5446
5447	tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5448	back, ifbody2, elsebody2);
5449
5450	gfc_add_expr_to_block (&block, tmp);
5451	}
5452
5453	cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5454	ifbody = build3_v (COND_EXPR, cond, ifbody,
5455	build_empty_stmt (input_location));
5456	}
5457	gfc_add_expr_to_block (&block, ifbody);
5458
5459	if (maskexpr && maskexpr->rank > 0)
5460	{
5461	/* We enclose the above in if (mask) {...}. If the mask is an
5462	optional argument, generate IF (.NOT. PRESENT(MASK)
5463	.OR. MASK(I)). */
5464
5465	tree ifmask;
5466	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5467	tmp = gfc_finish_block (&block);
5468	tmp = build3_v (COND_EXPR, ifmask, tmp,
5469	build_empty_stmt (input_location));
5470	}
5471	else
5472	tmp = gfc_finish_block (&block);
5473	gfc_add_expr_to_block (&body, tmp);
5474
5475	if (lab1)
5476	{
5477	for (int i = 0; i < ploop->dimen; i++)
5478	ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5479	TREE_TYPE (ploop->from[i]),
5480	second_loop_entry, idx[i],
5481	ploop->from[i]);
5482
5483	gfc_trans_scalarized_loop_boundary (ploop, &body);
5484
5485	if (nested_loop)
5486	{
5487	/* The first loop already advanced the parent se'ss chain, so clear
5488	the parent now to avoid doing it a second time, making the chain
5489	out of sync. */
5490	nested_se.parent = nullptr;
5491	nested_se.ss = orig_ss;
5492	}
5493
5494	stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5495
5496	if (HONOR_NANS (DECL_MODE (limit)))
5497	{
5498	if (nonempty != NULL)
5499	{
5500	stmtblock_t init_block;
5501	gfc_init_block (&init_block);
5502
5503	for (int i = 0; i < ploop->dimen; i++)
5504	gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5505
5506	tree ifbody = gfc_finish_block (&init_block);
5507	tmp = build3_v (COND_EXPR, nonempty, ifbody,
5508	build_empty_stmt (input_location));
5509	gfc_add_expr_to_block (outer_block, tmp);
5510	}
5511	}
5512
5513	gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5514	gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5515
5516	/* If we have a mask, only check this element if the mask is set. */
5517	if (maskexpr && maskexpr->rank > 0)
5518	{
5519	gfc_init_se (&maskse, base_se);
5520	gfc_copy_loopinfo_to_se (&maskse, ploop);
5521	if (!nested_loop)
5522	maskse.ss = maskss;
5523	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5524	gfc_add_block_to_block (&body, &maskse.pre);
5525
5526	gfc_start_block (&block);
5527	}
5528	else
5529	gfc_init_block (&block);
5530
5531	/* Compare with the current limit. */
5532	gfc_init_se (&arrayse, base_se);
5533	gfc_copy_loopinfo_to_se (&arrayse, ploop);
5534	if (!nested_loop)
5535	arrayse.ss = arrayss;
5536	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
5537	gfc_add_block_to_block (&block, &arrayse.pre);
5538
5539	/* We do the following if this is a more extreme value. */
5540	gfc_start_block (&ifblock);
5541
5542	/* Assign the value to the limit... */
5543	gfc_add_modify (&ifblock, limit, arrayse.expr);
5544
5545	for (int i = 0; i < ploop->dimen; i++)
5546	{
5547	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5548	ploop->loopvar[i], offset[i]);
5549	gfc_add_modify (&ifblock, pos[i], tmp);
5550	}
5551
5552	ifbody = gfc_finish_block (&ifblock);
5553
5554	/* We switch to > or >= depending on the value of the BACK argument. */
5555	{
5556	tree ifbody2, elsebody2;
5557
5558	cond = gfc_create_var (logical_type_node, "cond");
5559
5560	gfc_start_block (&ifblock);
5561	b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5562	logical_type_node, arrayse.expr, limit);
5563
5564	gfc_add_modify (&ifblock, cond, b_if);
5565	ifbody2 = gfc_finish_block (&ifblock);
5566
5567	gfc_start_block (&elseblock);
5568	b_else = fold_build2_loc (input_location, op, logical_type_node,
5569	arrayse.expr, limit);
5570
5571	gfc_add_modify (&elseblock, cond, b_else);
5572	elsebody2 = gfc_finish_block (&elseblock);
5573
5574	tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5575	back, ifbody2, elsebody2);
5576	}
5577
5578	gfc_add_expr_to_block (&block, tmp);
5579	cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5580	tmp = build3_v (COND_EXPR, cond, ifbody,
5581	build_empty_stmt (input_location));
5582
5583	gfc_add_expr_to_block (&block, tmp);
5584
5585	if (maskexpr && maskexpr->rank > 0)
5586	{
5587	/* We enclose the above in if (mask) {...}. If the mask is
5588	an optional argument, generate IF (.NOT. PRESENT(MASK)
5589	.OR. MASK(I)).*/
5590
5591	tree ifmask;
5592	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5593	tmp = gfc_finish_block (&block);
5594	tmp = build3_v (COND_EXPR, ifmask, tmp,
5595	build_empty_stmt (input_location));
5596	}
5597	else
5598	tmp = gfc_finish_block (&block);
5599
5600	gfc_add_expr_to_block (&body, tmp);
5601	gfc_add_modify (&body, second_loop_entry, logical_false_node);
5602	}
5603
5604	gfc_trans_scalarizing_loops (ploop, &body);
5605
5606	if (lab2)
5607	gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5608
5609	/* For a scalar mask, enclose the loop in an if statement. */
5610	if (maskexpr && maskexpr->rank == 0)
5611	{
5612	tree ifmask;
5613
5614	gfc_init_se (&maskse, nested_loop ? se : nullptr);
5615	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5616	gfc_add_block_to_block (&se->pre, &maskse.pre);
5617	gfc_init_block (&block);
5618	gfc_add_block_to_block (&block, &ploop->pre);
5619	gfc_add_block_to_block (&block, &ploop->post);
5620	tmp = gfc_finish_block (&block);
5621
5622	/* For the else part of the scalar mask, just initialize
5623	the pos variable the same way as above. */
5624
5625	gfc_init_block (&elseblock);
5626	for (int i = 0; i < ploop->dimen; i++)
5627	gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5628	elsetmp = gfc_finish_block (&elseblock);
5629	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5630	tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5631	gfc_add_expr_to_block (&block, tmp);
5632	gfc_add_block_to_block (&se->pre, &block);
5633	}
5634	else
5635	{
5636	gfc_add_block_to_block (&se->pre, &ploop->pre);
5637	gfc_add_block_to_block (&se->pre, &ploop->post);
5638	}
5639
5640	if (!nested_loop)
5641	gfc_cleanup_loop (&loop);
5642
5643	if (!dim_present)
5644	{
5645	for (int i = 0; i < arrayexpr->rank; i++)
5646	{
5647	tree res_idx = build_int_cst (gfc_array_index_type, i);
5648	tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5649	NULL_TREE, non_negative_offset: true);
5650
5651	tree value = convert (type, pos[i]);
5652	gfc_add_modify (&se->pre, res_arr_ref, value);
5653	}
5654
5655	se->expr = result_var;
5656	}
5657	else
5658	se->expr = convert (type, pos[0]);
5659	}
5660
5661	/* Emit code for findloc. */
5662
5663	static void
5664	gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5665	{
5666	gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5667	*kind_arg, *back_arg;
5668	gfc_expr *value_expr;
5669	int ikind;
5670	tree resvar;
5671	stmtblock_t block;
5672	stmtblock_t body;
5673	stmtblock_t loopblock;
5674	tree type;
5675	tree tmp;
5676	tree found;
5677	tree forward_branch = NULL_TREE;
5678	tree back_branch;
5679	gfc_loopinfo loop;
5680	gfc_ss *arrayss;
5681	gfc_ss *maskss;
5682	gfc_se arrayse;
5683	gfc_se valuese;
5684	gfc_se maskse;
5685	gfc_se backse;
5686	tree exit_label;
5687	gfc_expr *maskexpr;
5688	tree offset;
5689	int i;
5690	bool optional_mask;
5691
5692	array_arg = expr->value.function.actual;
5693	value_arg = array_arg->next;
5694	dim_arg = value_arg->next;
5695	mask_arg = dim_arg->next;
5696	kind_arg = mask_arg->next;
5697	back_arg = kind_arg->next;
5698
5699	/* Remove kind and set ikind. */
5700	if (kind_arg->expr)
5701	{
5702	ikind = mpz_get_si (kind_arg->expr->value.integer);
5703	gfc_free_expr (kind_arg->expr);
5704	kind_arg->expr = NULL;
5705	}
5706	else
5707	ikind = gfc_default_integer_kind;
5708
5709	value_expr = value_arg->expr;
5710
5711	/* Unless it's a string, pass VALUE by value. */
5712	if (value_expr->ts.type != BT_CHARACTER)
5713	value_arg->name = "%VAL";
5714
5715	/* Pass BACK argument by value. */
5716	back_arg->name = "%VAL";
5717
5718	/* Call the library if we have a character function or if
5719	rank > 0. */
5720	if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5721	{
5722	se->ignore_optional = 1;
5723	if (expr->rank == 0)
5724	{
5725	/* Remove dim argument. */
5726	gfc_free_expr (dim_arg->expr);
5727	dim_arg->expr = NULL;
5728	}
5729	gfc_conv_intrinsic_funcall (se, expr);
5730	return;
5731	}
5732
5733	type = gfc_get_int_type (ikind);
5734
5735	/* Initialize the result. */
5736	resvar = gfc_create_var (gfc_array_index_type, "pos");
5737	gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5738	offset = gfc_create_var (gfc_array_index_type, "offset");
5739
5740	maskexpr = mask_arg->expr;
5741	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5742	&& maskexpr->symtree->n.sym->attr.dummy
5743	&& maskexpr->symtree->n.sym->attr.optional;
5744
5745	/* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5746
5747	for (i = 0 ; i < 2; i++)
5748	{
5749	/* Walk the arguments. */
5750	arrayss = gfc_walk_expr (array_arg->expr);
5751	gcc_assert (arrayss != gfc_ss_terminator);
5752
5753	if (maskexpr && maskexpr->rank != 0)
5754	{
5755	maskss = gfc_walk_expr (maskexpr);
5756	gcc_assert (maskss != gfc_ss_terminator);
5757	}
5758	else
5759	maskss = NULL;
5760
5761	/* Initialize the scalarizer. */
5762	gfc_init_loopinfo (&loop);
5763	exit_label = gfc_build_label_decl (NULL_TREE);
5764	TREE_USED (exit_label) = 1;
5765
5766	/* We add the mask first because the number of iterations is
5767	taken from the last ss, and this breaks if an absent
5768	optional argument is used for mask. */
5769
5770	if (maskss)
5771	gfc_add_ss_to_loop (&loop, maskss);
5772	gfc_add_ss_to_loop (&loop, arrayss);
5773
5774	/* Initialize the loop. */
5775	gfc_conv_ss_startstride (&loop);
5776	gfc_conv_loop_setup (&loop, &expr->where);
5777
5778	/* Calculate the offset. */
5779	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5780	gfc_index_one_node, loop.from[0]);
5781	gfc_add_modify (&loop.pre, offset, tmp);
5782
5783	gfc_mark_ss_chain_used (arrayss, 1);
5784	if (maskss)
5785	gfc_mark_ss_chain_used (maskss, 1);
5786
5787	/* The first loop is for BACK=.true. */
5788	if (i == 0)
5789	loop.reverse[0] = GFC_REVERSE_SET;
5790
5791	/* Generate the loop body. */
5792	gfc_start_scalarized_body (&loop, &body);
5793
5794	/* If we have an array mask, only add the element if it is
5795	set. */
5796	if (maskss)
5797	{
5798	gfc_init_se (&maskse, NULL);
5799	gfc_copy_loopinfo_to_se (&maskse, &loop);
5800	maskse.ss = maskss;
5801	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5802	gfc_add_block_to_block (&body, &maskse.pre);
5803	}
5804
5805	/* If the condition matches then set the return value. */
5806	gfc_start_block (&block);
5807
5808	/* Add the offset. */
5809	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5810	TREE_TYPE (resvar),
5811	loop.loopvar[0], offset);
5812	gfc_add_modify (&block, resvar, tmp);
5813	/* And break out of the loop. */
5814	tmp = build1_v (GOTO_EXPR, exit_label);
5815	gfc_add_expr_to_block (&block, tmp);
5816
5817	found = gfc_finish_block (&block);
5818
5819	/* Check this element. */
5820	gfc_init_se (&arrayse, NULL);
5821	gfc_copy_loopinfo_to_se (&arrayse, &loop);
5822	arrayse.ss = arrayss;
5823	gfc_conv_expr_val (se: &arrayse, expr: array_arg->expr);
5824	gfc_add_block_to_block (&body, &arrayse.pre);
5825
5826	gfc_init_se (&valuese, NULL);
5827	gfc_conv_expr_val (se: &valuese, expr: value_arg->expr);
5828	gfc_add_block_to_block (&body, &valuese.pre);
5829
5830	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5831	arrayse.expr, valuese.expr);
5832
5833	tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5834	if (maskss)
5835	{
5836	/* We enclose the above in if (mask) {...}. If the mask is
5837	an optional argument, generate IF (.NOT. PRESENT(MASK)
5838	.OR. MASK(I)). */
5839
5840	tree ifmask;
5841	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5842	tmp = build3_v (COND_EXPR, ifmask, tmp,
5843	build_empty_stmt (input_location));
5844	}
5845
5846	gfc_add_expr_to_block (&body, tmp);
5847	gfc_add_block_to_block (&body, &arrayse.post);
5848
5849	gfc_trans_scalarizing_loops (&loop, &body);
5850
5851	/* Add the exit label. */
5852	tmp = build1_v (LABEL_EXPR, exit_label);
5853	gfc_add_expr_to_block (&loop.pre, tmp);
5854	gfc_start_block (&loopblock);
5855	gfc_add_block_to_block (&loopblock, &loop.pre);
5856	gfc_add_block_to_block (&loopblock, &loop.post);
5857	if (i == 0)
5858	forward_branch = gfc_finish_block (&loopblock);
5859	else
5860	back_branch = gfc_finish_block (&loopblock);
5861
5862	gfc_cleanup_loop (&loop);
5863	}
5864
5865	/* Enclose the two loops in an IF statement. */
5866
5867	gfc_init_se (&backse, NULL);
5868	gfc_conv_expr_val (se: &backse, expr: back_arg->expr);
5869	gfc_add_block_to_block (&se->pre, &backse.pre);
5870	tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5871
5872	/* For a scalar mask, enclose the loop in an if statement. */
5873	if (maskexpr && maskss == NULL)
5874	{
5875	tree ifmask;
5876	tree if_stmt;
5877
5878	gfc_init_se (&maskse, NULL);
5879	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5880	gfc_init_block (&block);
5881	gfc_add_expr_to_block (&block, maskse.expr);
5882	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5883	if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5884	build_empty_stmt (input_location));
5885	gfc_add_expr_to_block (&block, if_stmt);
5886	tmp = gfc_finish_block (&block);
5887	}
5888
5889	gfc_add_expr_to_block (&se->pre, tmp);
5890	se->expr = convert (type, resvar);
5891
5892	}
5893
5894	/* Emit code for fstat, lstat and stat intrinsic subroutines. */
5895
5896	static tree
5897	conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5898	{
5899	stmtblock_t block;
5900	gfc_se se, se_stat;
5901	tree unit = NULL_TREE;
5902	tree name = NULL_TREE;
5903	tree slen = NULL_TREE;
5904	tree vals;
5905	tree arg3 = NULL_TREE;
5906	tree stat = NULL_TREE ;
5907	tree present = NULL_TREE;
5908	tree tmp;
5909	int kind;
5910
5911	gfc_init_block (&block);
5912	gfc_init_se (&se, NULL);
5913
5914	switch (code->resolved_isym->id)
5915	{
5916	case GFC_ISYM_FSTAT:
5917	/* Deal with the UNIT argument. */
5918	gfc_conv_expr (se: &se, expr: code->ext.actual->expr);
5919	gfc_add_block_to_block (&block, &se.pre);
5920	unit = gfc_evaluate_now (se.expr, &block);
5921	unit = gfc_build_addr_expr (NULL_TREE, unit);
5922	gfc_add_block_to_block (&block, &se.post);
5923	break;
5924
5925	case GFC_ISYM_LSTAT:
5926	case GFC_ISYM_STAT:
5927	/* Deal with the NAME argument. */
5928	gfc_conv_expr (se: &se, expr: code->ext.actual->expr);
5929	gfc_conv_string_parameter (se: &se);
5930	gfc_add_block_to_block (&block, &se.pre);
5931	name = se.expr;
5932	slen = se.string_length;
5933	gfc_add_block_to_block (&block, &se.post);
5934	break;
5935
5936	default:
5937	gcc_unreachable ();
5938	}
5939
5940	/* Deal with the VALUES argument. */
5941	gfc_init_se (&se, NULL);
5942	gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5943	vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5944	gfc_add_block_to_block (&block, &se.pre);
5945	gfc_add_block_to_block (&block, &se.post);
5946	kind = code->ext.actual->next->expr->ts.kind;
5947
5948	/* Deal with an optional STATUS. */
5949	if (code->ext.actual->next->next->expr)
5950	{
5951	gfc_init_se (&se_stat, NULL);
5952	gfc_conv_expr (se: &se_stat, expr: code->ext.actual->next->next->expr);
5953	stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5954	arg3 = gfc_build_addr_expr (NULL_TREE, stat);
5955
5956	/* Handle case of status being an optional dummy. */
5957	gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
5958	if (sym->attr.dummy && sym->attr.optional)
5959	{
5960	present = gfc_conv_expr_present (sym);
5961	arg3 = fold_build3_loc (input_location, COND_EXPR,
5962	TREE_TYPE (arg3), present, arg3,
5963	fold_convert (TREE_TYPE (arg3),
5964	null_pointer_node));
5965	}
5966	}
5967
5968	/* Call library function depending on KIND of VALUES argument. */
5969	switch (code->resolved_isym->id)
5970	{
5971	case GFC_ISYM_FSTAT:
5972	tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
5973	break;
5974	case GFC_ISYM_LSTAT:
5975	tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
5976	break;
5977	case GFC_ISYM_STAT:
5978	tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
5979	break;
5980	default:
5981	gcc_unreachable ();
5982	}
5983
5984	if (code->resolved_isym->id == GFC_ISYM_FSTAT)
5985	tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
5986	stat ? arg3 : null_pointer_node);
5987	else
5988	tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
5989	stat ? arg3 : null_pointer_node, slen);
5990	gfc_add_expr_to_block (&block, tmp);
5991
5992	/* Handle kind conversion of status. */
5993	if (stat && stat != se_stat.expr)
5994	{
5995	stmtblock_t block2;
5996
5997	gfc_init_block (&block2);
5998	gfc_add_modify (&block2, se_stat.expr,
5999	fold_convert (TREE_TYPE (se_stat.expr), stat));
6000
6001	if (present)
6002	{
6003	tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6004	build_empty_stmt (input_location));
6005	gfc_add_expr_to_block (&block, tmp);
6006	}
6007	else
6008	gfc_add_block_to_block (&block, &block2);
6009	}
6010
6011	return gfc_finish_block (&block);
6012	}
6013
6014	/* Emit code for minval or maxval intrinsic. There are many different cases
6015	we need to handle. For performance reasons we sometimes create two
6016	loops instead of one, where the second one is much simpler.
6017	Examples for minval intrinsic:
6018	1) Result is an array, a call is generated
6019	2) Array mask is used and NaNs need to be supported, rank 1:
6020	limit = Infinity;
6021	nonempty = false;
6022	S = from;
6023	while (S <= to) {
6024	if (mask[S]) {
6025	nonempty = true;
6026	if (a[S] <= limit) {
6027	limit = a[S];
6028	S++;
6029	goto lab;
6030	}
6031	else
6032	S++;
6033	}
6034	}
6035	limit = nonempty ? NaN : huge (limit);
6036	lab:
6037	while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6038	3) NaNs need to be supported, but it is known at compile time or cheaply
6039	at runtime whether array is nonempty or not, rank 1:
6040	limit = Infinity;
6041	S = from;
6042	while (S <= to) {
6043	if (a[S] <= limit) {
6044	limit = a[S];
6045	S++;
6046	goto lab;
6047	}
6048	else
6049	S++;
6050	}
6051	limit = (from <= to) ? NaN : huge (limit);
6052	lab:
6053	while (S <= to) { limit = min (a[S], limit); S++; }
6054	4) Array mask is used and NaNs need to be supported, rank > 1:
6055	limit = Infinity;
6056	nonempty = false;
6057	fast = false;
6058	S1 = from1;
6059	while (S1 <= to1) {
6060	S2 = from2;
6061	while (S2 <= to2) {
6062	if (mask[S1][S2]) {
6063	if (fast) limit = min (a[S1][S2], limit);
6064	else {
6065	nonempty = true;
6066	if (a[S1][S2] <= limit) {
6067	limit = a[S1][S2];
6068	fast = true;
6069	}
6070	}
6071	}
6072	S2++;
6073	}
6074	S1++;
6075	}
6076	if (!fast)
6077	limit = nonempty ? NaN : huge (limit);
6078	5) NaNs need to be supported, but it is known at compile time or cheaply
6079	at runtime whether array is nonempty or not, rank > 1:
6080	limit = Infinity;
6081	fast = false;
6082	S1 = from1;
6083	while (S1 <= to1) {
6084	S2 = from2;
6085	while (S2 <= to2) {
6086	if (fast) limit = min (a[S1][S2], limit);
6087	else {
6088	if (a[S1][S2] <= limit) {
6089	limit = a[S1][S2];
6090	fast = true;
6091	}
6092	}
6093	S2++;
6094	}
6095	S1++;
6096	}
6097	if (!fast)
6098	limit = (nonempty_array) ? NaN : huge (limit);
6099	6) NaNs aren't supported, but infinities are. Array mask is used:
6100	limit = Infinity;
6101	nonempty = false;
6102	S = from;
6103	while (S <= to) {
6104	if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6105	S++;
6106	}
6107	limit = nonempty ? limit : huge (limit);
6108	7) Same without array mask:
6109	limit = Infinity;
6110	S = from;
6111	while (S <= to) { limit = min (a[S], limit); S++; }
6112	limit = (from <= to) ? limit : huge (limit);
6113	8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6114	limit = huge (limit);
6115	S = from;
6116	while (S <= to) { limit = min (a[S], limit); S++); }
6117	(or
6118	while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6119	with array mask instead).
6120	For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6121	setting limit = huge (limit); in the else branch. */
6122
6123	static void
6124	gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6125	{
6126	tree limit;
6127	tree type;
6128	tree tmp;
6129	tree ifbody;
6130	tree nonempty;
6131	tree nonempty_var;
6132	tree lab;
6133	tree fast;
6134	tree huge_cst = NULL, nan_cst = NULL;
6135	stmtblock_t body;
6136	stmtblock_t block, block2;
6137	gfc_loopinfo loop;
6138	gfc_actual_arglist *actual;
6139	gfc_ss *arrayss;
6140	gfc_ss *maskss;
6141	gfc_se arrayse;
6142	gfc_se maskse;
6143	gfc_expr *arrayexpr;
6144	gfc_expr *maskexpr;
6145	int n;
6146	bool optional_mask;
6147
6148	if (se->ss)
6149	{
6150	gfc_conv_intrinsic_funcall (se, expr);
6151	return;
6152	}
6153
6154	actual = expr->value.function.actual;
6155	arrayexpr = actual->expr;
6156
6157	if (arrayexpr->ts.type == BT_CHARACTER)
6158	{
6159	gfc_actual_arglist *dim = actual->next;
6160	if (expr->rank == 0 && dim->expr != 0)
6161	{
6162	gfc_free_expr (dim->expr);
6163	dim->expr = NULL;
6164	}
6165	gfc_conv_intrinsic_funcall (se, expr);
6166	return;
6167	}
6168
6169	type = gfc_typenode_for_spec (&expr->ts);
6170	/* Initialize the result. */
6171	limit = gfc_create_var (type, "limit");
6172	n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6173	switch (expr->ts.type)
6174	{
6175	case BT_REAL:
6176	huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6177	expr->ts.kind, 0);
6178	if (HONOR_INFINITIES (DECL_MODE (limit)))
6179	{
6180	REAL_VALUE_TYPE real;
6181	real_inf (&real);
6182	tmp = build_real (type, real);
6183	}
6184	else
6185	tmp = huge_cst;
6186	if (HONOR_NANS (DECL_MODE (limit)))
6187	nan_cst = gfc_build_nan (type, "");
6188	break;
6189
6190	case BT_INTEGER:
6191	tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6192	break;
6193
6194	case BT_UNSIGNED:
6195	/* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6196	if (op == GT_EXPR)
6197	tmp = build_int_cst (type, 0);
6198	else
6199	tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6200	expr->ts.kind);
6201	break;
6202
6203	default:
6204	gcc_unreachable ();
6205	}
6206
6207	/* We start with the most negative possible value for MAXVAL, and the most
6208	positive possible value for MINVAL. The most negative possible value is
6209	-HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6210	possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6211	with above. */
6212	if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6213	{
6214	tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6215	if (huge_cst)
6216	huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6217	TREE_TYPE (huge_cst), huge_cst);
6218	}
6219
6220	if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6221	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6222	tmp, build_int_cst (type, 1));
6223
6224	gfc_add_modify (&se->pre, limit, tmp);
6225
6226	/* Walk the arguments. */
6227	arrayss = gfc_walk_expr (arrayexpr);
6228	gcc_assert (arrayss != gfc_ss_terminator);
6229
6230	actual = actual->next->next;
6231	gcc_assert (actual);
6232	maskexpr = actual->expr;
6233	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6234	&& maskexpr->symtree->n.sym->attr.dummy
6235	&& maskexpr->symtree->n.sym->attr.optional;
6236	nonempty = NULL;
6237	if (maskexpr && maskexpr->rank != 0)
6238	{
6239	maskss = gfc_walk_expr (maskexpr);
6240	gcc_assert (maskss != gfc_ss_terminator);
6241	}
6242	else
6243	{
6244	mpz_t asize;
6245	if (gfc_array_size (arrayexpr, &asize))
6246	{
6247	nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6248	mpz_clear (asize);
6249	nonempty = fold_build2_loc (input_location, GT_EXPR,
6250	logical_type_node, nonempty,
6251	gfc_index_zero_node);
6252	}
6253	maskss = NULL;
6254	}
6255
6256	/* Initialize the scalarizer. */
6257	gfc_init_loopinfo (&loop);
6258
6259	/* We add the mask first because the number of iterations is taken
6260	from the last ss, and this breaks if an absent optional argument
6261	is used for mask. */
6262
6263	if (maskss)
6264	gfc_add_ss_to_loop (&loop, maskss);
6265	gfc_add_ss_to_loop (&loop, arrayss);
6266
6267	/* Initialize the loop. */
6268	gfc_conv_ss_startstride (&loop);
6269
6270	/* The code generated can have more than one loop in sequence (see the
6271	comment at the function header). This doesn't work well with the
6272	scalarizer, which changes arrays' offset when the scalarization loops
6273	are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6274	are currently inlined in the scalar case only. As there is no dependency
6275	to care about in that case, there is no temporary, so that we can use the
6276	scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6277	here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6278	gfc_trans_scalarized_loop_boundary even later to restore offset.
6279	TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6280	should eventually go away. We could either create two loops properly,
6281	or find another way to save/restore the array offsets between the two
6282	loops (without conflicting with temporary management), or use a single
6283	loop minmaxval implementation. See PR 31067. */
6284	loop.temp_dim = loop.dimen;
6285	gfc_conv_loop_setup (&loop, &expr->where);
6286
6287	if (nonempty == NULL && maskss == NULL
6288	&& loop.dimen == 1 && loop.from[0] && loop.to[0])
6289	nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6290	loop.from[0], loop.to[0]);
6291	nonempty_var = NULL;
6292	if (nonempty == NULL
6293	&& (HONOR_INFINITIES (DECL_MODE (limit))
6294	|| HONOR_NANS (DECL_MODE (limit))))
6295	{
6296	nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6297	gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6298	nonempty = nonempty_var;
6299	}
6300	lab = NULL;
6301	fast = NULL;
6302	if (HONOR_NANS (DECL_MODE (limit)))
6303	{
6304	if (loop.dimen == 1)
6305	{
6306	lab = gfc_build_label_decl (NULL_TREE);
6307	TREE_USED (lab) = 1;
6308	}
6309	else
6310	{
6311	fast = gfc_create_var (logical_type_node, "fast");
6312	gfc_add_modify (&se->pre, fast, logical_false_node);
6313	}
6314	}
6315
6316	gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6317	if (maskss)
6318	gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6319	/* Generate the loop body. */
6320	gfc_start_scalarized_body (&loop, &body);
6321
6322	/* If we have a mask, only add this element if the mask is set. */
6323	if (maskss)
6324	{
6325	gfc_init_se (&maskse, NULL);
6326	gfc_copy_loopinfo_to_se (&maskse, &loop);
6327	maskse.ss = maskss;
6328	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
6329	gfc_add_block_to_block (&body, &maskse.pre);
6330
6331	gfc_start_block (&block);
6332	}
6333	else
6334	gfc_init_block (&block);
6335
6336	/* Compare with the current limit. */
6337	gfc_init_se (&arrayse, NULL);
6338	gfc_copy_loopinfo_to_se (&arrayse, &loop);
6339	arrayse.ss = arrayss;
6340	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
6341	arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6342	gfc_add_block_to_block (&block, &arrayse.pre);
6343
6344	gfc_init_block (&block2);
6345
6346	if (nonempty_var)
6347	gfc_add_modify (&block2, nonempty_var, logical_true_node);
6348
6349	if (HONOR_NANS (DECL_MODE (limit)))
6350	{
6351	tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6352	logical_type_node, arrayse.expr, limit);
6353	if (lab)
6354	{
6355	stmtblock_t ifblock;
6356	tree inc_loop;
6357	inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6358	TREE_TYPE (loop.loopvar[0]),
6359	loop.loopvar[0], gfc_index_one_node);
6360	gfc_init_block (&ifblock);
6361	gfc_add_modify (&ifblock, limit, arrayse.expr);
6362	gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6363	gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6364	ifbody = gfc_finish_block (&ifblock);
6365	}
6366	else
6367	{
6368	stmtblock_t ifblock;
6369
6370	gfc_init_block (&ifblock);
6371	gfc_add_modify (&ifblock, limit, arrayse.expr);
6372	gfc_add_modify (&ifblock, fast, logical_true_node);
6373	ifbody = gfc_finish_block (&ifblock);
6374	}
6375	tmp = build3_v (COND_EXPR, tmp, ifbody,
6376	build_empty_stmt (input_location));
6377	gfc_add_expr_to_block (&block2, tmp);
6378	}
6379	else
6380	{
6381	/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6382	signed zeros. */
6383	tmp = fold_build2_loc (input_location,
6384	op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6385	type, arrayse.expr, limit);
6386	gfc_add_modify (&block2, limit, tmp);
6387	}
6388
6389	if (fast)
6390	{
6391	tree elsebody = gfc_finish_block (&block2);
6392
6393	/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6394	signed zeros. */
6395	if (HONOR_NANS (DECL_MODE (limit)))
6396	{
6397	tmp = fold_build2_loc (input_location, op, logical_type_node,
6398	arrayse.expr, limit);
6399	ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6400	ifbody = build3_v (COND_EXPR, tmp, ifbody,
6401	build_empty_stmt (input_location));
6402	}
6403	else
6404	{
6405	tmp = fold_build2_loc (input_location,
6406	op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6407	type, arrayse.expr, limit);
6408	ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6409	}
6410	tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6411	gfc_add_expr_to_block (&block, tmp);
6412	}
6413	else
6414	gfc_add_block_to_block (&block, &block2);
6415
6416	gfc_add_block_to_block (&block, &arrayse.post);
6417
6418	tmp = gfc_finish_block (&block);
6419	if (maskss)
6420	{
6421	/* We enclose the above in if (mask) {...}. If the mask is an
6422	optional argument, generate IF (.NOT. PRESENT(MASK)
6423	.OR. MASK(I)). */
6424	tree ifmask;
6425	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
6426	tmp = build3_v (COND_EXPR, ifmask, tmp,
6427	build_empty_stmt (input_location));
6428	}
6429	gfc_add_expr_to_block (&body, tmp);
6430
6431	if (lab)
6432	{
6433	gfc_trans_scalarized_loop_boundary (&loop, &body);
6434
6435	tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6436	nan_cst, huge_cst);
6437	gfc_add_modify (&loop.code[0], limit, tmp);
6438	gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6439
6440	/* If we have a mask, only add this element if the mask is set. */
6441	if (maskss)
6442	{
6443	gfc_init_se (&maskse, NULL);
6444	gfc_copy_loopinfo_to_se (&maskse, &loop);
6445	maskse.ss = maskss;
6446	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
6447	gfc_add_block_to_block (&body, &maskse.pre);
6448
6449	gfc_start_block (&block);
6450	}
6451	else
6452	gfc_init_block (&block);
6453
6454	/* Compare with the current limit. */
6455	gfc_init_se (&arrayse, NULL);
6456	gfc_copy_loopinfo_to_se (&arrayse, &loop);
6457	arrayse.ss = arrayss;
6458	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
6459	arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6460	gfc_add_block_to_block (&block, &arrayse.pre);
6461
6462	/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6463	signed zeros. */
6464	if (HONOR_NANS (DECL_MODE (limit)))
6465	{
6466	tmp = fold_build2_loc (input_location, op, logical_type_node,
6467	arrayse.expr, limit);
6468	ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6469	tmp = build3_v (COND_EXPR, tmp, ifbody,
6470	build_empty_stmt (input_location));
6471	gfc_add_expr_to_block (&block, tmp);
6472	}
6473	else
6474	{
6475	tmp = fold_build2_loc (input_location,
6476	op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6477	type, arrayse.expr, limit);
6478	gfc_add_modify (&block, limit, tmp);
6479	}
6480
6481	gfc_add_block_to_block (&block, &arrayse.post);
6482
6483	tmp = gfc_finish_block (&block);
6484	if (maskss)
6485	/* We enclose the above in if (mask) {...}. */
6486	{
6487	tree ifmask;
6488	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
6489	tmp = build3_v (COND_EXPR, ifmask, tmp,
6490	build_empty_stmt (input_location));
6491	}
6492
6493	gfc_add_expr_to_block (&body, tmp);
6494	/* Avoid initializing loopvar[0] again, it should be left where
6495	it finished by the first loop. */
6496	loop.from[0] = loop.loopvar[0];
6497	}
6498	gfc_trans_scalarizing_loops (&loop, &body);
6499
6500	if (fast)
6501	{
6502	tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6503	nan_cst, huge_cst);
6504	ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6505	tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6506	ifbody);
6507	gfc_add_expr_to_block (&loop.pre, tmp);
6508	}
6509	else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6510	{
6511	tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6512	huge_cst);
6513	gfc_add_modify (&loop.pre, limit, tmp);
6514	}
6515
6516	/* For a scalar mask, enclose the loop in an if statement. */
6517	if (maskexpr && maskss == NULL)
6518	{
6519	tree else_stmt;
6520	tree ifmask;
6521
6522	gfc_init_se (&maskse, NULL);
6523	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
6524	gfc_init_block (&block);
6525	gfc_add_block_to_block (&block, &loop.pre);
6526	gfc_add_block_to_block (&block, &loop.post);
6527	tmp = gfc_finish_block (&block);
6528
6529	if (HONOR_INFINITIES (DECL_MODE (limit)))
6530	else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6531	else
6532	else_stmt = build_empty_stmt (input_location);
6533
6534	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
6535	tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6536	gfc_add_expr_to_block (&block, tmp);
6537	gfc_add_block_to_block (&se->pre, &block);
6538	}
6539	else
6540	{
6541	gfc_add_block_to_block (&se->pre, &loop.pre);
6542	gfc_add_block_to_block (&se->pre, &loop.post);
6543	}
6544
6545	gfc_cleanup_loop (&loop);
6546
6547	se->expr = limit;
6548	}
6549
6550	/* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6551	static void
6552	gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6553	{
6554	tree args[2];
6555	tree type;
6556	tree tmp;
6557
6558	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6559	type = TREE_TYPE (args[0]);
6560
6561	/* Optionally generate code for runtime argument check. */
6562	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6563	{
6564	tree below = fold_build2_loc (input_location, LT_EXPR,
6565	logical_type_node, args[1],
6566	build_int_cst (TREE_TYPE (args[1]), 0));
6567	tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6568	tree above = fold_build2_loc (input_location, GE_EXPR,
6569	logical_type_node, args[1], nbits);
6570	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6571	logical_type_node, below, above);
6572	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6573	"POS argument (%ld) out of range 0:%ld "
6574	"in intrinsic BTEST",
6575	fold_convert (long_integer_type_node, args[1]),
6576	fold_convert (long_integer_type_node, nbits));
6577	}
6578
6579	tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6580	build_int_cst (type, 1), args[1]);
6581	tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6582	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6583	build_int_cst (type, 0));
6584	type = gfc_typenode_for_spec (&expr->ts);
6585	se->expr = convert (type, tmp);
6586	}
6587
6588
6589	/* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6590	static void
6591	gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6592	{
6593	tree args[2];
6594
6595	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6596
6597	/* Convert both arguments to the unsigned type of the same size. */
6598	args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6599	args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6600
6601	/* If they have unequal type size, convert to the larger one. */
6602	if (TYPE_PRECISION (TREE_TYPE (args[0]))
6603	> TYPE_PRECISION (TREE_TYPE (args[1])))
6604	args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6605	else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6606	> TYPE_PRECISION (TREE_TYPE (args[0])))
6607	args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6608
6609	/* Now, we compare them. */
6610	se->expr = fold_build2_loc (input_location, op, logical_type_node,
6611	args[0], args[1]);
6612	}
6613
6614
6615	/* Generate code to perform the specified operation. */
6616	static void
6617	gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6618	{
6619	tree args[2];
6620
6621	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6622	se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6623	args[0], args[1]);
6624	}
6625
6626	/* Bitwise not. */
6627	static void
6628	gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6629	{
6630	tree arg;
6631
6632	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
6633	se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6634	TREE_TYPE (arg), arg);
6635	}
6636
6637
6638	/* Generate code for OUT_OF_RANGE. */
6639	static void
6640	gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6641	{
6642	tree *args;
6643	tree type;
6644	tree tmp = NULL_TREE, tmp1, tmp2;
6645	unsigned int num_args;
6646	int k;
6647	gfc_se rnd_se;
6648	gfc_actual_arglist *arg = expr->value.function.actual;
6649	gfc_expr *x = arg->expr;
6650	gfc_expr *mold = arg->next->expr;
6651
6652	num_args = gfc_intrinsic_argument_list_length (expr);
6653	args = XALLOCAVEC (tree, num_args);
6654
6655	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
6656
6657	gfc_init_se (&rnd_se, NULL);
6658
6659	if (num_args == 3)
6660	{
6661	/* The ROUND argument is optional and shall appear only if X is
6662	of type real and MOLD is of type integer (see edit F23/004). */
6663	gfc_expr *round = arg->next->next->expr;
6664	gfc_conv_expr (se: &rnd_se, expr: round);
6665
6666	if (round->expr_type == EXPR_VARIABLE
6667	&& round->symtree->n.sym->attr.dummy
6668	&& round->symtree->n.sym->attr.optional)
6669	{
6670	tree present = gfc_conv_expr_present (round->symtree->n.sym);
6671	rnd_se.expr = build3_loc (loc: input_location, code: COND_EXPR,
6672	type: logical_type_node, arg0: present,
6673	arg1: rnd_se.expr, arg2: logical_false_node);
6674	gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6675	}
6676	}
6677	else
6678	{
6679	/* If ROUND is absent, it is equivalent to having the value false. */
6680	rnd_se.expr = logical_false_node;
6681	}
6682
6683	type = TREE_TYPE (args[0]);
6684	k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6685
6686	switch (x->ts.type)
6687	{
6688	case BT_REAL:
6689	/* X may be IEEE infinity or NaN, but the representation of MOLD may not
6690	support infinity or NaN. */
6691	tree finite;
6692	finite = build_call_expr_loc (input_location,
6693	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
6694	1, args[0]);
6695	finite = convert (logical_type_node, finite);
6696
6697	if (mold->ts.type == BT_REAL)
6698	{
6699	tmp1 = build1 (ABS_EXPR, type, args[0]);
6700	tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6701	mold->ts.kind, 0);
6702	tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6703	convert (type, tmp2));
6704
6705	/* Check if MOLD representation supports infinity or NaN. */
6706	bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6707	|| HONOR_NANS (TREE_TYPE (args[1])));
6708	tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6709	infnan ? logical_false_node : logical_true_node);
6710	}
6711	else
6712	{
6713	tree rounded;
6714	tree decl;
6715
6716	decl = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_TRUNC, kind: x->ts.kind);
6717	gcc_assert (decl != NULL_TREE);
6718
6719	/* Round or truncate argument X, depending on the optional argument
6720	ROUND (default: .false.). */
6721	tmp1 = build_round_expr (arg: args[0], restype: type);
6722	tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6723	rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6724
6725	if (mold->ts.type == BT_INTEGER)
6726	{
6727	tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6728	x->ts.kind);
6729	tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6730	x->ts.kind);
6731	}
6732	else if (mold->ts.type == BT_UNSIGNED)
6733	{
6734	tmp1 = build_real_from_int_cst (type, integer_zero_node);
6735	tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6736	x->ts.kind);
6737	}
6738	else
6739	gcc_unreachable ();
6740
6741	tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6742	convert (type, tmp1));
6743	tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6744	convert (type, tmp2));
6745	tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6746	tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6747	build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6748	tmp);
6749	}
6750	break;
6751
6752	case BT_INTEGER:
6753	if (mold->ts.type == BT_INTEGER)
6754	{
6755	tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6756	x->ts.kind);
6757	tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6758	x->ts.kind);
6759	tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6760	convert (type, tmp1));
6761	tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6762	convert (type, tmp2));
6763	tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6764	}
6765	else if (mold->ts.type == BT_UNSIGNED)
6766	{
6767	int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6768	tmp = build_int_cst (type, 0);
6769	tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6770	if (mpz_cmp (gfc_integer_kinds[i].huge,
6771	gfc_unsigned_kinds[k].huge) > 0)
6772	{
6773	tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6774	x->ts.kind);
6775	tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6776	convert (type, tmp2));
6777	tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6778	}
6779	}
6780	else if (mold->ts.type == BT_REAL)
6781	{
6782	tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6783	mold->ts.kind, 0);
6784	tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6785	tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6786	convert (type, tmp1));
6787	tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6788	convert (type, tmp2));
6789	tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6790	}
6791	else
6792	gcc_unreachable ();
6793	break;
6794
6795	case BT_UNSIGNED:
6796	if (mold->ts.type == BT_UNSIGNED)
6797	{
6798	tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6799	x->ts.kind);
6800	tmp = build2 (GT_EXPR, logical_type_node, args[0],
6801	convert (type, tmp));
6802	}
6803	else if (mold->ts.type == BT_INTEGER)
6804	{
6805	tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6806	x->ts.kind);
6807	tmp = build2 (GT_EXPR, logical_type_node, args[0],
6808	convert (type, tmp));
6809	}
6810	else if (mold->ts.type == BT_REAL)
6811	{
6812	tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6813	mold->ts.kind, 0);
6814	tmp = build2 (GT_EXPR, logical_type_node, args[0],
6815	convert (type, tmp));
6816	}
6817	else
6818	gcc_unreachable ();
6819	break;
6820
6821	default:
6822	gcc_unreachable ();
6823	}
6824
6825	se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6826	}
6827
6828
6829	/* Set or clear a single bit. */
6830	static void
6831	gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6832	{
6833	tree args[2];
6834	tree type;
6835	tree tmp;
6836	enum tree_code op;
6837
6838	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6839	type = TREE_TYPE (args[0]);
6840
6841	/* Optionally generate code for runtime argument check. */
6842	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6843	{
6844	tree below = fold_build2_loc (input_location, LT_EXPR,
6845	logical_type_node, args[1],
6846	build_int_cst (TREE_TYPE (args[1]), 0));
6847	tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6848	tree above = fold_build2_loc (input_location, GE_EXPR,
6849	logical_type_node, args[1], nbits);
6850	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6851	logical_type_node, below, above);
6852	size_t len_name = strlen (s: expr->value.function.isym->name);
6853	char *name = XALLOCAVEC (char, len_name + 1);
6854	for (size_t i = 0; i < len_name; i++)
6855	name[i] = TOUPPER (expr->value.function.isym->name[i]);
6856	name[len_name] = '\0';
6857	tree iname = gfc_build_addr_expr (pchar_type_node,
6858	gfc_build_cstring_const (name));
6859	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6860	"POS argument (%ld) out of range 0:%ld "
6861	"in intrinsic %s",
6862	fold_convert (long_integer_type_node, args[1]),
6863	fold_convert (long_integer_type_node, nbits),
6864	iname);
6865	}
6866
6867	tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6868	build_int_cst (type, 1), args[1]);
6869	if (set)
6870	op = BIT_IOR_EXPR;
6871	else
6872	{
6873	op = BIT_AND_EXPR;
6874	tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6875	}
6876	se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6877	}
6878
6879	/* Extract a sequence of bits.
6880	IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6881	static void
6882	gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6883	{
6884	tree args[3];
6885	tree type;
6886	tree tmp;
6887	tree mask;
6888	tree num_bits, cond;
6889
6890	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
6891	type = TREE_TYPE (args[0]);
6892
6893	/* Optionally generate code for runtime argument check. */
6894	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6895	{
6896	tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6897	tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6898	tree nbits = build_int_cst (long_integer_type_node,
6899	TYPE_PRECISION (type));
6900	tree below = fold_build2_loc (input_location, LT_EXPR,
6901	logical_type_node, args[1],
6902	build_int_cst (TREE_TYPE (args[1]), 0));
6903	tree above = fold_build2_loc (input_location, GT_EXPR,
6904	logical_type_node, tmp1, nbits);
6905	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6906	logical_type_node, below, above);
6907	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6908	"POS argument (%ld) out of range 0:%ld "
6909	"in intrinsic IBITS", tmp1, nbits);
6910	below = fold_build2_loc (input_location, LT_EXPR,
6911	logical_type_node, args[2],
6912	build_int_cst (TREE_TYPE (args[2]), 0));
6913	above = fold_build2_loc (input_location, GT_EXPR,
6914	logical_type_node, tmp2, nbits);
6915	scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6916	logical_type_node, below, above);
6917	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6918	"LEN argument (%ld) out of range 0:%ld "
6919	"in intrinsic IBITS", tmp2, nbits);
6920	above = fold_build2_loc (input_location, PLUS_EXPR,
6921	long_integer_type_node, tmp1, tmp2);
6922	scond = fold_build2_loc (input_location, GT_EXPR,
6923	logical_type_node, above, nbits);
6924	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6925	"POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6926	"in intrinsic IBITS", tmp1, tmp2, nbits);
6927	}
6928
6929	/* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6930	gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6931	special case. See also gfc_conv_intrinsic_ishft (). */
6932	num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6933
6934	mask = build_int_cst (type, -1);
6935	mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6936	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6937	num_bits);
6938	mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6939	build_int_cst (type, 0), mask);
6940	mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6941
6942	tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6943
6944	se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6945	}
6946
6947	static void
6948	gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6949	bool arithmetic)
6950	{
6951	tree args[2], type, num_bits, cond;
6952	tree bigshift;
6953	bool do_convert = false;
6954
6955	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6956
6957	args[0] = gfc_evaluate_now (args[0], &se->pre);
6958	args[1] = gfc_evaluate_now (args[1], &se->pre);
6959	type = TREE_TYPE (args[0]);
6960
6961	if (!arithmetic)
6962	{
6963	args[0] = fold_convert (unsigned_type_for (type), args[0]);
6964	do_convert = true;
6965	}
6966	else
6967	gcc_assert (right_shift);
6968
6969	if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
6970	{
6971	do_convert = true;
6972	args[0] = fold_convert (signed_type_for (type), args[0]);
6973	}
6974
6975	se->expr = fold_build2_loc (input_location,
6976	right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
6977	TREE_TYPE (args[0]), args[0], args[1]);
6978
6979	if (do_convert)
6980	se->expr = fold_convert (type, se->expr);
6981
6982	if (!arithmetic)
6983	bigshift = build_int_cst (type, 0);
6984	else
6985	{
6986	tree nonneg = fold_build2_loc (input_location, GE_EXPR,
6987	logical_type_node, args[0],
6988	build_int_cst (TREE_TYPE (args[0]), 0));
6989	bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
6990	build_int_cst (type, 0),
6991	build_int_cst (type, -1));
6992	}
6993
6994	/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6995	gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6996	special case. */
6997	num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6998
6999	/* Optionally generate code for runtime argument check. */
7000	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7001	{
7002	tree below = fold_build2_loc (input_location, LT_EXPR,
7003	logical_type_node, args[1],
7004	build_int_cst (TREE_TYPE (args[1]), 0));
7005	tree above = fold_build2_loc (input_location, GT_EXPR,
7006	logical_type_node, args[1], num_bits);
7007	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7008	logical_type_node, below, above);
7009	size_t len_name = strlen (s: expr->value.function.isym->name);
7010	char *name = XALLOCAVEC (char, len_name + 1);
7011	for (size_t i = 0; i < len_name; i++)
7012	name[i] = TOUPPER (expr->value.function.isym->name[i]);
7013	name[len_name] = '\0';
7014	tree iname = gfc_build_addr_expr (pchar_type_node,
7015	gfc_build_cstring_const (name));
7016	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7017	"SHIFT argument (%ld) out of range 0:%ld "
7018	"in intrinsic %s",
7019	fold_convert (long_integer_type_node, args[1]),
7020	fold_convert (long_integer_type_node, num_bits),
7021	iname);
7022	}
7023
7024	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7025	args[1], num_bits);
7026
7027	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7028	bigshift, se->expr);
7029	}
7030
7031	/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7032	? 0
7033	: ((shift >= 0) ? i << shift : i >> -shift)
7034	where all shifts are logical shifts. */
7035	static void
7036	gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7037	{
7038	tree args[2];
7039	tree type;
7040	tree utype;
7041	tree tmp;
7042	tree width;
7043	tree num_bits;
7044	tree cond;
7045	tree lshift;
7046	tree rshift;
7047
7048	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7049
7050	args[0] = gfc_evaluate_now (args[0], &se->pre);
7051	args[1] = gfc_evaluate_now (args[1], &se->pre);
7052
7053	type = TREE_TYPE (args[0]);
7054	utype = unsigned_type_for (type);
7055
7056	width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7057	args[1]);
7058
7059	/* Left shift if positive. */
7060	lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7061
7062	/* Right shift if negative.
7063	We convert to an unsigned type because we want a logical shift.
7064	The standard doesn't define the case of shifting negative
7065	numbers, and we try to be compatible with other compilers, most
7066	notably g77, here. */
7067	rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7068	utype, convert (utype, args[0]), width));
7069
7070	tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7071	build_int_cst (TREE_TYPE (args[1]), 0));
7072	tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7073
7074	/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7075	gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7076	special case. */
7077	num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7078
7079	/* Optionally generate code for runtime argument check. */
7080	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7081	{
7082	tree outside = fold_build2_loc (input_location, GT_EXPR,
7083	logical_type_node, width, num_bits);
7084	gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7085	"SHIFT argument (%ld) out of range -%ld:%ld "
7086	"in intrinsic ISHFT",
7087	fold_convert (long_integer_type_node, args[1]),
7088	fold_convert (long_integer_type_node, num_bits),
7089	fold_convert (long_integer_type_node, num_bits));
7090	}
7091
7092	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7093	num_bits);
7094	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7095	build_int_cst (type, 0), tmp);
7096	}
7097
7098
7099	/* Circular shift. AKA rotate or barrel shift. */
7100
7101	static void
7102	gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7103	{
7104	tree *args;
7105	tree type;
7106	tree tmp;
7107	tree lrot;
7108	tree rrot;
7109	tree zero;
7110	tree nbits;
7111	unsigned int num_args;
7112
7113	num_args = gfc_intrinsic_argument_list_length (expr);
7114	args = XALLOCAVEC (tree, num_args);
7115
7116	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
7117
7118	type = TREE_TYPE (args[0]);
7119	nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7120
7121	if (num_args == 3)
7122	{
7123	gfc_expr *size = expr->value.function.actual->next->next->expr;
7124
7125	/* Use a library function for the 3 parameter version. */
7126	tree int4type = gfc_get_int_type (4);
7127
7128	/* Treat optional SIZE argument when it is passed as an optional
7129	dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7130	if (size->expr_type == EXPR_VARIABLE
7131	&& size->symtree->n.sym->attr.dummy
7132	&& size->symtree->n.sym->attr.optional)
7133	{
7134	tree type_of_size = TREE_TYPE (args[2]);
7135	args[2] = build3_loc (loc: input_location, code: COND_EXPR, type: type_of_size,
7136	arg0: gfc_conv_expr_present (size->symtree->n.sym),
7137	arg1: args[2], fold_convert (type_of_size, nbits));
7138	}
7139
7140	/* We convert the first argument to at least 4 bytes, and
7141	convert back afterwards. This removes the need for library
7142	functions for all argument sizes, and function will be
7143	aligned to at least 32 bits, so there's no loss. */
7144	if (expr->ts.kind < 4)
7145	args[0] = convert (int4type, args[0]);
7146
7147	/* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7148	need loads of library functions. They cannot have values >
7149	BIT_SIZE (I) so the conversion is safe. */
7150	args[1] = convert (int4type, args[1]);
7151	args[2] = convert (int4type, args[2]);
7152
7153	/* Optionally generate code for runtime argument check. */
7154	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7155	{
7156	tree size = fold_convert (long_integer_type_node, args[2]);
7157	tree below = fold_build2_loc (input_location, LE_EXPR,
7158	logical_type_node, size,
7159	build_int_cst (TREE_TYPE (args[1]), 0));
7160	tree above = fold_build2_loc (input_location, GT_EXPR,
7161	logical_type_node, size, nbits);
7162	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7163	logical_type_node, below, above);
7164	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7165	"SIZE argument (%ld) out of range 1:%ld "
7166	"in intrinsic ISHFTC", size, nbits);
7167	tree width = fold_convert (long_integer_type_node, args[1]);
7168	width = fold_build1_loc (input_location, ABS_EXPR,
7169	long_integer_type_node, width);
7170	scond = fold_build2_loc (input_location, GT_EXPR,
7171	logical_type_node, width, size);
7172	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7173	"SHIFT argument (%ld) out of range -%ld:%ld "
7174	"in intrinsic ISHFTC",
7175	fold_convert (long_integer_type_node, args[1]),
7176	size, size);
7177	}
7178
7179	switch (expr->ts.kind)
7180	{
7181	case 1:
7182	case 2:
7183	case 4:
7184	tmp = gfor_fndecl_math_ishftc4;
7185	break;
7186	case 8:
7187	tmp = gfor_fndecl_math_ishftc8;
7188	break;
7189	case 16:
7190	tmp = gfor_fndecl_math_ishftc16;
7191	break;
7192	default:
7193	gcc_unreachable ();
7194	}
7195	se->expr = build_call_expr_loc (input_location,
7196	tmp, 3, args[0], args[1], args[2]);
7197	/* Convert the result back to the original type, if we extended
7198	the first argument's width above. */
7199	if (expr->ts.kind < 4)
7200	se->expr = convert (type, se->expr);
7201
7202	return;
7203	}
7204
7205	/* Evaluate arguments only once. */
7206	args[0] = gfc_evaluate_now (args[0], &se->pre);
7207	args[1] = gfc_evaluate_now (args[1], &se->pre);
7208
7209	/* Optionally generate code for runtime argument check. */
7210	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7211	{
7212	tree width = fold_convert (long_integer_type_node, args[1]);
7213	width = fold_build1_loc (input_location, ABS_EXPR,
7214	long_integer_type_node, width);
7215	tree outside = fold_build2_loc (input_location, GT_EXPR,
7216	logical_type_node, width, nbits);
7217	gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7218	"SHIFT argument (%ld) out of range -%ld:%ld "
7219	"in intrinsic ISHFTC",
7220	fold_convert (long_integer_type_node, args[1]),
7221	nbits, nbits);
7222	}
7223
7224	/* Rotate left if positive. */
7225	lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7226
7227	/* Rotate right if negative. */
7228	tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7229	args[1]);
7230	rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7231
7232	zero = build_int_cst (TREE_TYPE (args[1]), 0);
7233	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7234	zero);
7235	rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7236
7237	/* Do nothing if shift == 0. */
7238	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7239	zero);
7240	se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7241	rrot);
7242	}
7243
7244
7245	/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7246	: __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7247
7248	The conditional expression is necessary because the result of LEADZ(0)
7249	is defined, but the result of __builtin_clz(0) is undefined for most
7250	targets.
7251
7252	For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7253	difference in bit size between the argument of LEADZ and the C int. */
7254
7255	static void
7256	gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7257	{
7258	tree arg;
7259	tree arg_type;
7260	tree cond;
7261	tree result_type;
7262	tree leadz;
7263	tree bit_size;
7264	tree tmp;
7265	tree func;
7266	int s, argsize;
7267
7268	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7269	argsize = TYPE_PRECISION (TREE_TYPE (arg));
7270
7271	/* Which variant of __builtin_clz* should we call? */
7272	if (argsize <= INT_TYPE_SIZE)
7273	{
7274	arg_type = unsigned_type_node;
7275	func = builtin_decl_explicit (fncode: BUILT_IN_CLZ);
7276	}
7277	else if (argsize <= LONG_TYPE_SIZE)
7278	{
7279	arg_type = long_unsigned_type_node;
7280	func = builtin_decl_explicit (fncode: BUILT_IN_CLZL);
7281	}
7282	else if (argsize <= LONG_LONG_TYPE_SIZE)
7283	{
7284	arg_type = long_long_unsigned_type_node;
7285	func = builtin_decl_explicit (fncode: BUILT_IN_CLZLL);
7286	}
7287	else
7288	{
7289	gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7290	arg_type = gfc_build_uint_type (argsize);
7291	func = NULL_TREE;
7292	}
7293
7294	/* Convert the actual argument twice: first, to the unsigned type of the
7295	same size; then, to the proper argument type for the built-in
7296	function. But the return type is of the default INTEGER kind. */
7297	arg = fold_convert (gfc_build_uint_type (argsize), arg);
7298	arg = fold_convert (arg_type, arg);
7299	arg = gfc_evaluate_now (arg, &se->pre);
7300	result_type = gfc_get_int_type (gfc_default_integer_kind);
7301
7302	/* Compute LEADZ for the case i .ne. 0. */
7303	if (func)
7304	{
7305	s = TYPE_PRECISION (arg_type) - argsize;
7306	tmp = fold_convert (result_type,
7307	build_call_expr_loc (input_location, func,
7308	1, arg));
7309	leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7310	tmp, build_int_cst (result_type, s));
7311	}
7312	else
7313	{
7314	/* We end up here if the argument type is larger than 'long long'.
7315	We generate this code:
7316
7317	if (x & (ULL_MAX << ULL_SIZE) != 0)
7318	return clzll ((unsigned long long) (x >> ULLSIZE));
7319	else
7320	return ULL_SIZE + clzll ((unsigned long long) x);
7321	where ULL_MAX is the largest value that a ULL_MAX can hold
7322	(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7323	is the bit-size of the long long type (64 in this example). */
7324	tree ullsize, ullmax, tmp1, tmp2, btmp;
7325
7326	ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7327	ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7328	long_long_unsigned_type_node,
7329	build_int_cst (long_long_unsigned_type_node,
7330	0));
7331
7332	cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7333	fold_convert (arg_type, ullmax), ullsize);
7334	cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7335	arg, cond);
7336	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7337	cond, build_int_cst (arg_type, 0));
7338
7339	tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7340	arg, ullsize);
7341	tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7342	btmp = builtin_decl_explicit (fncode: BUILT_IN_CLZLL);
7343	tmp1 = fold_convert (result_type,
7344	build_call_expr_loc (input_location, btmp, 1, tmp1));
7345
7346	tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7347	btmp = builtin_decl_explicit (fncode: BUILT_IN_CLZLL);
7348	tmp2 = fold_convert (result_type,
7349	build_call_expr_loc (input_location, btmp, 1, tmp2));
7350	tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7351	tmp2, ullsize);
7352
7353	leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7354	cond, tmp1, tmp2);
7355	}
7356
7357	/* Build BIT_SIZE. */
7358	bit_size = build_int_cst (result_type, argsize);
7359
7360	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7361	arg, build_int_cst (arg_type, 0));
7362	se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7363	bit_size, leadz);
7364	}
7365
7366
7367	/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7368
7369	The conditional expression is necessary because the result of TRAILZ(0)
7370	is defined, but the result of __builtin_ctz(0) is undefined for most
7371	targets. */
7372
7373	static void
7374	gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7375	{
7376	tree arg;
7377	tree arg_type;
7378	tree cond;
7379	tree result_type;
7380	tree trailz;
7381	tree bit_size;
7382	tree func;
7383	int argsize;
7384
7385	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7386	argsize = TYPE_PRECISION (TREE_TYPE (arg));
7387
7388	/* Which variant of __builtin_ctz* should we call? */
7389	if (argsize <= INT_TYPE_SIZE)
7390	{
7391	arg_type = unsigned_type_node;
7392	func = builtin_decl_explicit (fncode: BUILT_IN_CTZ);
7393	}
7394	else if (argsize <= LONG_TYPE_SIZE)
7395	{
7396	arg_type = long_unsigned_type_node;
7397	func = builtin_decl_explicit (fncode: BUILT_IN_CTZL);
7398	}
7399	else if (argsize <= LONG_LONG_TYPE_SIZE)
7400	{
7401	arg_type = long_long_unsigned_type_node;
7402	func = builtin_decl_explicit (fncode: BUILT_IN_CTZLL);
7403	}
7404	else
7405	{
7406	gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7407	arg_type = gfc_build_uint_type (argsize);
7408	func = NULL_TREE;
7409	}
7410
7411	/* Convert the actual argument twice: first, to the unsigned type of the
7412	same size; then, to the proper argument type for the built-in
7413	function. But the return type is of the default INTEGER kind. */
7414	arg = fold_convert (gfc_build_uint_type (argsize), arg);
7415	arg = fold_convert (arg_type, arg);
7416	arg = gfc_evaluate_now (arg, &se->pre);
7417	result_type = gfc_get_int_type (gfc_default_integer_kind);
7418
7419	/* Compute TRAILZ for the case i .ne. 0. */
7420	if (func)
7421	trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7422	func, 1, arg));
7423	else
7424	{
7425	/* We end up here if the argument type is larger than 'long long'.
7426	We generate this code:
7427
7428	if ((x & ULL_MAX) == 0)
7429	return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7430	else
7431	return ctzll ((unsigned long long) x);
7432
7433	where ULL_MAX is the largest value that a ULL_MAX can hold
7434	(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7435	is the bit-size of the long long type (64 in this example). */
7436	tree ullsize, ullmax, tmp1, tmp2, btmp;
7437
7438	ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7439	ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7440	long_long_unsigned_type_node,
7441	build_int_cst (long_long_unsigned_type_node, 0));
7442
7443	cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7444	fold_convert (arg_type, ullmax));
7445	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7446	build_int_cst (arg_type, 0));
7447
7448	tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7449	arg, ullsize);
7450	tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7451	btmp = builtin_decl_explicit (fncode: BUILT_IN_CTZLL);
7452	tmp1 = fold_convert (result_type,
7453	build_call_expr_loc (input_location, btmp, 1, tmp1));
7454	tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7455	tmp1, ullsize);
7456
7457	tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7458	btmp = builtin_decl_explicit (fncode: BUILT_IN_CTZLL);
7459	tmp2 = fold_convert (result_type,
7460	build_call_expr_loc (input_location, btmp, 1, tmp2));
7461
7462	trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7463	cond, tmp1, tmp2);
7464	}
7465
7466	/* Build BIT_SIZE. */
7467	bit_size = build_int_cst (result_type, argsize);
7468
7469	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7470	arg, build_int_cst (arg_type, 0));
7471	se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7472	bit_size, trailz);
7473	}
7474
7475	/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7476	for types larger than "long long", we call the long long built-in for
7477	the lower and higher bits and combine the result. */
7478
7479	static void
7480	gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7481	{
7482	tree arg;
7483	tree arg_type;
7484	tree result_type;
7485	tree func;
7486	int argsize;
7487
7488	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7489	argsize = TYPE_PRECISION (TREE_TYPE (arg));
7490	result_type = gfc_get_int_type (gfc_default_integer_kind);
7491
7492	/* Which variant of the builtin should we call? */
7493	if (argsize <= INT_TYPE_SIZE)
7494	{
7495	arg_type = unsigned_type_node;
7496	func = builtin_decl_explicit (fncode: parity
7497	? BUILT_IN_PARITY
7498	: BUILT_IN_POPCOUNT);
7499	}
7500	else if (argsize <= LONG_TYPE_SIZE)
7501	{
7502	arg_type = long_unsigned_type_node;
7503	func = builtin_decl_explicit (fncode: parity
7504	? BUILT_IN_PARITYL
7505	: BUILT_IN_POPCOUNTL);
7506	}
7507	else if (argsize <= LONG_LONG_TYPE_SIZE)
7508	{
7509	arg_type = long_long_unsigned_type_node;
7510	func = builtin_decl_explicit (fncode: parity
7511	? BUILT_IN_PARITYLL
7512	: BUILT_IN_POPCOUNTLL);
7513	}
7514	else
7515	{
7516	/* Our argument type is larger than 'long long', which mean none
7517	of the POPCOUNT builtins covers it. We thus call the 'long long'
7518	variant multiple times, and add the results. */
7519	tree utype, arg2, call1, call2;
7520
7521	/* For now, we only cover the case where argsize is twice as large
7522	as 'long long'. */
7523	gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7524
7525	func = builtin_decl_explicit (fncode: parity
7526	? BUILT_IN_PARITYLL
7527	: BUILT_IN_POPCOUNTLL);
7528
7529	/* Convert it to an integer, and store into a variable. */
7530	utype = gfc_build_uint_type (argsize);
7531	arg = fold_convert (utype, arg);
7532	arg = gfc_evaluate_now (arg, &se->pre);
7533
7534	/* Call the builtin twice. */
7535	call1 = build_call_expr_loc (input_location, func, 1,
7536	fold_convert (long_long_unsigned_type_node,
7537	arg));
7538
7539	arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7540	build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7541	call2 = build_call_expr_loc (input_location, func, 1,
7542	fold_convert (long_long_unsigned_type_node,
7543	arg2));
7544
7545	/* Combine the results. */
7546	if (parity)
7547	se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7548	integer_type_node, call1, call2);
7549	else
7550	se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7551	integer_type_node, call1, call2);
7552
7553	se->expr = convert (result_type, se->expr);
7554	return;
7555	}
7556
7557	/* Convert the actual argument twice: first, to the unsigned type of the
7558	same size; then, to the proper argument type for the built-in
7559	function. */
7560	arg = fold_convert (gfc_build_uint_type (argsize), arg);
7561	arg = fold_convert (arg_type, arg);
7562
7563	se->expr = fold_convert (result_type,
7564	build_call_expr_loc (input_location, func, 1, arg));
7565	}
7566
7567
7568	/* Process an intrinsic with unspecified argument-types that has an optional
7569	argument (which could be of type character), e.g. EOSHIFT. For those, we
7570	need to append the string length of the optional argument if it is not
7571	present and the type is really character.
7572	primary specifies the position (starting at 1) of the non-optional argument
7573	specifying the type and optional gives the position of the optional
7574	argument in the arglist. */
7575
7576	static void
7577	conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7578	unsigned primary, unsigned optional)
7579	{
7580	gfc_actual_arglist* prim_arg;
7581	gfc_actual_arglist* opt_arg;
7582	unsigned cur_pos;
7583	gfc_actual_arglist* arg;
7584	gfc_symbol* sym;
7585	vec<tree, va_gc> *append_args;
7586
7587	/* Find the two arguments given as position. */
7588	cur_pos = 0;
7589	prim_arg = NULL;
7590	opt_arg = NULL;
7591	for (arg = expr->value.function.actual; arg; arg = arg->next)
7592	{
7593	++cur_pos;
7594
7595	if (cur_pos == primary)
7596	prim_arg = arg;
7597	if (cur_pos == optional)
7598	opt_arg = arg;
7599
7600	if (cur_pos >= primary && cur_pos >= optional)
7601	break;
7602	}
7603	gcc_assert (prim_arg);
7604	gcc_assert (prim_arg->expr);
7605	gcc_assert (opt_arg);
7606
7607	/* If we do have type CHARACTER and the optional argument is really absent,
7608	append a dummy 0 as string length. */
7609	append_args = NULL;
7610	if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7611	{
7612	tree dummy;
7613
7614	dummy = build_int_cst (gfc_charlen_type_node, 0);
7615	vec_alloc (v&: append_args, nelems: 1);
7616	append_args->quick_push (obj: dummy);
7617	}
7618
7619	/* Build the call itself. */
7620	gcc_assert (!se->ignore_optional);
7621	sym = gfc_get_symbol_for_expr (expr, ignore_optional: false);
7622	gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7623	append_args);
7624	gfc_free_symbol (sym);
7625	}
7626
7627	/* The length of a character string. */
7628	static void
7629	gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7630	{
7631	tree len;
7632	tree type;
7633	tree decl;
7634	gfc_symbol *sym;
7635	gfc_se argse;
7636	gfc_expr *arg;
7637
7638	gcc_assert (!se->ss);
7639
7640	arg = expr->value.function.actual->expr;
7641
7642	type = gfc_typenode_for_spec (&expr->ts);
7643	switch (arg->expr_type)
7644	{
7645	case EXPR_CONSTANT:
7646	len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7647	break;
7648
7649	case EXPR_ARRAY:
7650	/* Obtain the string length from the function used by
7651	trans-array.cc(gfc_trans_array_constructor). */
7652	len = NULL_TREE;
7653	get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7654	break;
7655
7656	case EXPR_VARIABLE:
7657	if (arg->ref == NULL
7658	|| (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7659	{
7660	/* This doesn't catch all cases.
7661	See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7662	and the surrounding thread. */
7663	sym = arg->symtree->n.sym;
7664	decl = gfc_get_symbol_decl (sym);
7665	if (decl == current_function_decl && sym->attr.function
7666	&& (sym->result == sym))
7667	decl = gfc_get_fake_result_decl (sym, 0);
7668
7669	len = sym->ts.u.cl->backend_decl;
7670	gcc_assert (len);
7671	break;
7672	}
7673
7674	/* Fall through. */
7675
7676	default:
7677	gfc_init_se (&argse, se);
7678	if (arg->rank == 0)
7679	gfc_conv_expr (se: &argse, expr: arg);
7680	else
7681	gfc_conv_expr_descriptor (&argse, arg);
7682	gfc_add_block_to_block (&se->pre, &argse.pre);
7683	gfc_add_block_to_block (&se->post, &argse.post);
7684	len = argse.string_length;
7685	break;
7686	}
7687	se->expr = convert (type, len);
7688	}
7689
7690	/* The length of a character string not including trailing blanks. */
7691	static void
7692	gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7693	{
7694	int kind = expr->value.function.actual->expr->ts.kind;
7695	tree args[2], type, fndecl;
7696
7697	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7698	type = gfc_typenode_for_spec (&expr->ts);
7699
7700	if (kind == 1)
7701	fndecl = gfor_fndecl_string_len_trim;
7702	else if (kind == 4)
7703	fndecl = gfor_fndecl_string_len_trim_char4;
7704	else
7705	gcc_unreachable ();
7706
7707	se->expr = build_call_expr_loc (input_location,
7708	fndecl, 2, args[0], args[1]);
7709	se->expr = convert (type, se->expr);
7710	}
7711
7712
7713	/* Returns the starting position of a substring within a string. */
7714
7715	static void
7716	gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7717	tree function)
7718	{
7719	tree logical4_type_node = gfc_get_logical_type (4);
7720	tree type;
7721	tree fndecl;
7722	tree *args;
7723	unsigned int num_args;
7724
7725	args = XALLOCAVEC (tree, 5);
7726
7727	/* Get number of arguments; characters count double due to the
7728	string length argument. Kind= is not passed to the library
7729	and thus ignored. */
7730	if (expr->value.function.actual->next->next->expr == NULL)
7731	num_args = 4;
7732	else
7733	num_args = 5;
7734
7735	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
7736	type = gfc_typenode_for_spec (&expr->ts);
7737
7738	if (num_args == 4)
7739	args[4] = build_int_cst (logical4_type_node, 0);
7740	else
7741	args[4] = convert (logical4_type_node, args[4]);
7742
7743	fndecl = build_addr (function);
7744	se->expr = build_call_array_loc (input_location,
7745	TREE_TYPE (TREE_TYPE (function)), fndecl,
7746	5, args);
7747	se->expr = convert (type, se->expr);
7748
7749	}
7750
7751	/* The ascii value for a single character. */
7752	static void
7753	gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7754	{
7755	tree args[3], type, pchartype;
7756	int nargs;
7757
7758	nargs = gfc_intrinsic_argument_list_length (expr);
7759	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
7760	gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7761	pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7762	args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7763	type = gfc_typenode_for_spec (&expr->ts);
7764
7765	se->expr = build_fold_indirect_ref_loc (input_location,
7766	args[1]);
7767	se->expr = convert (type, se->expr);
7768	}
7769
7770
7771	/* Intrinsic ISNAN calls __builtin_isnan. */
7772
7773	static void
7774	gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7775	{
7776	tree arg;
7777
7778	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7779	se->expr = build_call_expr_loc (input_location,
7780	builtin_decl_explicit (fncode: BUILT_IN_ISNAN),
7781	1, arg);
7782	STRIP_TYPE_NOPS (se->expr);
7783	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7784	}
7785
7786
7787	/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7788	their argument against a constant integer value. */
7789
7790	static void
7791	gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7792	{
7793	tree arg;
7794
7795	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7796	se->expr = fold_build2_loc (input_location, EQ_EXPR,
7797	gfc_typenode_for_spec (&expr->ts),
7798	arg, build_int_cst (TREE_TYPE (arg), value));
7799	}
7800
7801
7802
7803	/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7804
7805	static void
7806	gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7807	{
7808	tree tsource;
7809	tree fsource;
7810	tree mask;
7811	tree type;
7812	tree len, len2;
7813	tree *args;
7814	unsigned int num_args;
7815
7816	num_args = gfc_intrinsic_argument_list_length (expr);
7817	args = XALLOCAVEC (tree, num_args);
7818
7819	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
7820	if (expr->ts.type != BT_CHARACTER)
7821	{
7822	tsource = args[0];
7823	fsource = args[1];
7824	mask = args[2];
7825	}
7826	else
7827	{
7828	/* We do the same as in the non-character case, but the argument
7829	list is different because of the string length arguments. We
7830	also have to set the string length for the result. */
7831	len = args[0];
7832	tsource = args[1];
7833	len2 = args[2];
7834	fsource = args[3];
7835	mask = args[4];
7836
7837	gfc_trans_same_strlen_check (intr_name: "MERGE intrinsic", where: &expr->where, a: len, b: len2,
7838	target: &se->pre);
7839	se->string_length = len;
7840	}
7841	tsource = gfc_evaluate_now (tsource, &se->pre);
7842	fsource = gfc_evaluate_now (fsource, &se->pre);
7843	mask = gfc_evaluate_now (mask, &se->pre);
7844	type = TREE_TYPE (tsource);
7845	se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7846	fold_convert (type, fsource));
7847	}
7848
7849
7850	/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7851
7852	static void
7853	gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7854	{
7855	tree args[3], mask, type;
7856
7857	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
7858	mask = gfc_evaluate_now (args[2], &se->pre);
7859
7860	type = TREE_TYPE (args[0]);
7861	gcc_assert (TREE_TYPE (args[1]) == type);
7862	gcc_assert (TREE_TYPE (mask) == type);
7863
7864	args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7865	args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7866	fold_build1_loc (input_location, BIT_NOT_EXPR,
7867	type, mask));
7868	se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7869	args[0], args[1]);
7870	}
7871
7872
7873	/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7874	MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7875
7876	static void
7877	gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7878	{
7879	tree arg, allones, type, utype, res, cond, bitsize;
7880	int i;
7881
7882	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7883	arg = gfc_evaluate_now (arg, &se->pre);
7884
7885	type = gfc_get_int_type (expr->ts.kind);
7886	utype = unsigned_type_for (type);
7887
7888	i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7889	bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7890
7891	allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7892	build_int_cst (utype, 0));
7893
7894	if (left)
7895	{
7896	/* Left-justified mask. */
7897	res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7898	bitsize, arg);
7899	res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7900	fold_convert (utype, res));
7901
7902	/* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7903	smaller than type width. */
7904	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7905	build_int_cst (TREE_TYPE (arg), 0));
7906	res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7907	build_int_cst (utype, 0), res);
7908	}
7909	else
7910	{
7911	/* Right-justified mask. */
7912	res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7913	fold_convert (utype, arg));
7914	res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7915
7916	/* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7917	strictly smaller than type width. */
7918	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7919	arg, bitsize);
7920	res = fold_build3_loc (input_location, COND_EXPR, utype,
7921	cond, allones, res);
7922	}
7923
7924	se->expr = fold_convert (type, res);
7925	}
7926
7927
7928	/* FRACTION (s) is translated into:
7929	isfinite (s) ? frexp (s, &dummy_int) : NaN */
7930	static void
7931	gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7932	{
7933	tree arg, type, tmp, res, frexp, cond;
7934
7935	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
7936
7937	type = gfc_typenode_for_spec (&expr->ts);
7938	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7939	arg = gfc_evaluate_now (arg, &se->pre);
7940
7941	cond = build_call_expr_loc (input_location,
7942	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
7943	1, arg);
7944
7945	tmp = gfc_create_var (integer_type_node, NULL);
7946	res = build_call_expr_loc (input_location, frexp, 2,
7947	fold_convert (type, arg),
7948	gfc_build_addr_expr (NULL_TREE, tmp));
7949	res = fold_convert (type, res);
7950
7951	se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7952	cond, res, gfc_build_nan (type, ""));
7953	}
7954
7955
7956	/* NEAREST (s, dir) is translated into
7957	tmp = copysign (HUGE_VAL, dir);
7958	return nextafter (s, tmp);
7959	*/
7960	static void
7961	gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7962	{
7963	tree args[2], type, tmp, nextafter, copysign, huge_val;
7964
7965	nextafter = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_NEXTAFTER, kind: expr->ts.kind);
7966	copysign = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_COPYSIGN, kind: expr->ts.kind);
7967
7968	type = gfc_typenode_for_spec (&expr->ts);
7969	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7970
7971	huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
7972	tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
7973	fold_convert (type, args[1]));
7974	se->expr = build_call_expr_loc (input_location, nextafter, 2,
7975	fold_convert (type, args[0]), tmp);
7976	se->expr = fold_convert (type, se->expr);
7977	}
7978
7979
7980	/* SPACING (s) is translated into
7981	int e;
7982	if (!isfinite (s))
7983	res = NaN;
7984	else if (s == 0)
7985	res = tiny;
7986	else
7987	{
7988	frexp (s, &e);
7989	e = e - prec;
7990	e = MAX_EXPR (e, emin);
7991	res = scalbn (1., e);
7992	}
7993	return res;
7994
7995	where prec is the precision of s, gfc_real_kinds[k].digits,
7996	emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7997	and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7998
7999	static void
8000	gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8001	{
8002	tree arg, type, prec, emin, tiny, res, e;
8003	tree cond, nan, tmp, frexp, scalbn;
8004	int k;
8005	stmtblock_t block;
8006
8007	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8008	prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8009	emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8010	tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8011
8012	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
8013	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
8014
8015	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
8016	arg = gfc_evaluate_now (arg, &se->pre);
8017
8018	type = gfc_typenode_for_spec (&expr->ts);
8019	e = gfc_create_var (integer_type_node, NULL);
8020	res = gfc_create_var (type, NULL);
8021
8022
8023	/* Build the block for s /= 0. */
8024	gfc_start_block (&block);
8025	tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8026	gfc_build_addr_expr (NULL_TREE, e));
8027	gfc_add_expr_to_block (&block, tmp);
8028
8029	tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8030	prec);
8031	gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8032	integer_type_node, tmp, emin));
8033
8034	tmp = build_call_expr_loc (input_location, scalbn, 2,
8035	build_real_from_int_cst (type, integer_one_node), e);
8036	gfc_add_modify (&block, res, tmp);
8037
8038	/* Finish by building the IF statement for value zero. */
8039	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8040	build_real_from_int_cst (type, integer_zero_node));
8041	tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8042	gfc_finish_block (&block));
8043
8044	/* And deal with infinities and NaNs. */
8045	cond = build_call_expr_loc (input_location,
8046	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
8047	1, arg);
8048	nan = gfc_build_nan (type, "");
8049	tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8050
8051	gfc_add_expr_to_block (&se->pre, tmp);
8052	se->expr = res;
8053	}
8054
8055
8056	/* RRSPACING (s) is translated into
8057	int e;
8058	real x;
8059	x = fabs (s);
8060	if (isfinite (x))
8061	{
8062	if (x != 0)
8063	{
8064	frexp (s, &e);
8065	x = scalbn (x, precision - e);
8066	}
8067	}
8068	else
8069	x = NaN;
8070	return x;
8071
8072	where precision is gfc_real_kinds[k].digits. */
8073
8074	static void
8075	gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8076	{
8077	tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8078	int prec, k;
8079	stmtblock_t block;
8080
8081	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8082	prec = gfc_real_kinds[k].digits;
8083
8084	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
8085	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
8086	fabs = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FABS, kind: expr->ts.kind);
8087
8088	type = gfc_typenode_for_spec (&expr->ts);
8089	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
8090	arg = gfc_evaluate_now (arg, &se->pre);
8091
8092	e = gfc_create_var (integer_type_node, NULL);
8093	x = gfc_create_var (type, NULL);
8094	gfc_add_modify (&se->pre, x,
8095	build_call_expr_loc (input_location, fabs, 1, arg));
8096
8097
8098	gfc_start_block (&block);
8099	tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8100	gfc_build_addr_expr (NULL_TREE, e));
8101	gfc_add_expr_to_block (&block, tmp);
8102
8103	tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8104	build_int_cst (integer_type_node, prec), e);
8105	tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8106	gfc_add_modify (&block, x, tmp);
8107	stmt = gfc_finish_block (&block);
8108
8109	/* if (x != 0) */
8110	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8111	build_real_from_int_cst (type, integer_zero_node));
8112	tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8113
8114	/* And deal with infinities and NaNs. */
8115	cond = build_call_expr_loc (input_location,
8116	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
8117	1, x);
8118	nan = gfc_build_nan (type, "");
8119	tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8120
8121	gfc_add_expr_to_block (&se->pre, tmp);
8122	se->expr = fold_convert (type, x);
8123	}
8124
8125
8126	/* SCALE (s, i) is translated into scalbn (s, i). */
8127	static void
8128	gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8129	{
8130	tree args[2], type, scalbn;
8131
8132	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
8133
8134	type = gfc_typenode_for_spec (&expr->ts);
8135	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
8136	se->expr = build_call_expr_loc (input_location, scalbn, 2,
8137	fold_convert (type, args[0]),
8138	fold_convert (integer_type_node, args[1]));
8139	se->expr = fold_convert (type, se->expr);
8140	}
8141
8142
8143	/* SET_EXPONENT (s, i) is translated into
8144	isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8145	static void
8146	gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8147	{
8148	tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8149
8150	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
8151	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
8152
8153	type = gfc_typenode_for_spec (&expr->ts);
8154	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
8155	args[0] = gfc_evaluate_now (args[0], &se->pre);
8156
8157	tmp = gfc_create_var (integer_type_node, NULL);
8158	tmp = build_call_expr_loc (input_location, frexp, 2,
8159	fold_convert (type, args[0]),
8160	gfc_build_addr_expr (NULL_TREE, tmp));
8161	res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8162	fold_convert (integer_type_node, args[1]));
8163	res = fold_convert (type, res);
8164
8165	/* Call to isfinite */
8166	cond = build_call_expr_loc (input_location,
8167	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
8168	1, args[0]);
8169	nan = gfc_build_nan (type, "");
8170
8171	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8172	res, nan);
8173	}
8174
8175
8176	static void
8177	gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8178	{
8179	gfc_actual_arglist *actual;
8180	tree arg1;
8181	tree type;
8182	tree size;
8183	gfc_se argse;
8184	gfc_expr *e;
8185	gfc_symbol *sym = NULL;
8186
8187	gfc_init_se (&argse, NULL);
8188	actual = expr->value.function.actual;
8189
8190	if (actual->expr->ts.type == BT_CLASS)
8191	gfc_add_class_array_ref (actual->expr);
8192
8193	e = actual->expr;
8194
8195	/* These are emerging from the interface mapping, when a class valued
8196	function appears as the rhs in a realloc on assign statement, where
8197	the size of the result is that of one of the actual arguments. */
8198	if (e->expr_type == EXPR_VARIABLE
8199	&& e->symtree->n.sym->ns == NULL /* This is distinctive! */
8200	&& e->symtree->n.sym->ts.type == BT_CLASS
8201	&& e->ref && e->ref->type == REF_COMPONENT
8202	&& strcmp (s1: e->ref->u.c.component->name, s2: "_data") == 0)
8203	sym = e->symtree->n.sym;
8204
8205	if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8206	&& e
8207	&& (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8208	{
8209	symbol_attribute attr;
8210	char *msg;
8211	tree temp;
8212	tree cond;
8213
8214	if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8215	{
8216	attr = CLASS_DATA (e->symtree->n.sym)->attr;
8217	attr.pointer = attr.class_pointer;
8218	}
8219	else
8220	attr = gfc_expr_attr (e);
8221
8222	if (attr.allocatable)
8223	msg = xasprintf ("Allocatable argument '%s' is not allocated",
8224	e->symtree->n.sym->name);
8225	else if (attr.pointer)
8226	msg = xasprintf ("Pointer argument '%s' is not associated",
8227	e->symtree->n.sym->name);
8228	else
8229	goto end_arg_check;
8230
8231	if (sym)
8232	{
8233	temp = gfc_class_data_get (sym->backend_decl);
8234	temp = gfc_conv_descriptor_data_get (temp);
8235	}
8236	else
8237	{
8238	argse.descriptor_only = 1;
8239	gfc_conv_expr_descriptor (&argse, actual->expr);
8240	temp = gfc_conv_descriptor_data_get (argse.expr);
8241	}
8242
8243	cond = fold_build2_loc (input_location, EQ_EXPR,
8244	logical_type_node, temp,
8245	fold_convert (TREE_TYPE (temp),
8246	null_pointer_node));
8247	gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8248
8249	free (ptr: msg);
8250	}
8251	end_arg_check:
8252
8253	argse.data_not_needed = 1;
8254	if (gfc_is_class_array_function (e))
8255	{
8256	/* For functions that return a class array conv_expr_descriptor is not
8257	able to get the descriptor right. Therefore this special case. */
8258	gfc_conv_expr_reference (se: &argse, expr: e);
8259	argse.expr = gfc_class_data_get (argse.expr);
8260	}
8261	else if (sym && sym->backend_decl)
8262	{
8263	gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8264	argse.expr = gfc_class_data_get (sym->backend_decl);
8265	}
8266	else
8267	gfc_conv_expr_descriptor (&argse, actual->expr);
8268	gfc_add_block_to_block (&se->pre, &argse.pre);
8269	gfc_add_block_to_block (&se->post, &argse.post);
8270	arg1 = argse.expr;
8271
8272	actual = actual->next;
8273	if (actual->expr)
8274	{
8275	stmtblock_t block;
8276	gfc_init_block (&block);
8277	gfc_init_se (&argse, NULL);
8278	gfc_conv_expr_type (se: &argse, actual->expr,
8279	gfc_array_index_type);
8280	gfc_add_block_to_block (&block, &argse.pre);
8281	tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8282	argse.expr, gfc_index_one_node);
8283	size = gfc_tree_array_size (&block, arg1, e, tmp);
8284
8285	/* Unusually, for an intrinsic, size does not exclude
8286	an optional arg2, so we must test for it. */
8287	if (actual->expr->expr_type == EXPR_VARIABLE
8288	&& actual->expr->symtree->n.sym->attr.dummy
8289	&& actual->expr->symtree->n.sym->attr.optional)
8290	{
8291	tree cond;
8292	stmtblock_t block2;
8293	gfc_init_block (&block2);
8294	gfc_init_se (&argse, NULL);
8295	argse.want_pointer = 1;
8296	argse.data_not_needed = 1;
8297	gfc_conv_expr (se: &argse, expr: actual->expr);
8298	gfc_add_block_to_block (&se->pre, &argse.pre);
8299	/* 'block2' contains the arg2 absent case, 'block' the arg2 present
8300	case; size_var can be used in both blocks. */
8301	tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8302	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8303	TREE_TYPE (size_var), size_var, size);
8304	gfc_add_expr_to_block (&block, tmp);
8305	size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8306	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8307	TREE_TYPE (size_var), size_var, size);
8308	gfc_add_expr_to_block (&block2, tmp);
8309	cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8310	tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8311	gfc_finish_block (&block2));
8312	gfc_add_expr_to_block (&se->pre, tmp);
8313	size = size_var;
8314	}
8315	else
8316	gfc_add_block_to_block (&se->pre, &block);
8317	}
8318	else
8319	size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8320	type = gfc_typenode_for_spec (&expr->ts);
8321	se->expr = convert (type, size);
8322	}
8323
8324
8325	/* Helper function to compute the size of a character variable,
8326	excluding the terminating null characters. The result has
8327	gfc_array_index_type type. */
8328
8329	tree
8330	size_of_string_in_bytes (int kind, tree string_length)
8331	{
8332	tree bytesize;
8333	int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8334
8335	bytesize = build_int_cst (gfc_array_index_type,
8336	gfc_character_kinds[i].bit_size / 8);
8337
8338	return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8339	bytesize,
8340	fold_convert (gfc_array_index_type, string_length));
8341	}
8342
8343
8344	static void
8345	gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8346	{
8347	gfc_expr *arg;
8348	gfc_se argse;
8349	tree source_bytes;
8350	tree tmp;
8351	tree lower;
8352	tree upper;
8353	tree byte_size;
8354	tree field;
8355	int n;
8356
8357	gfc_init_se (&argse, NULL);
8358	arg = expr->value.function.actual->expr;
8359
8360	if (arg->rank || arg->ts.type == BT_ASSUMED)
8361	gfc_conv_expr_descriptor (&argse, arg);
8362	else
8363	gfc_conv_expr_reference (se: &argse, expr: arg);
8364
8365	if (arg->ts.type == BT_ASSUMED)
8366	{
8367	/* This only works if an array descriptor has been passed; thus, extract
8368	the size from the descriptor. */
8369	gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8370	== TYPE_PRECISION (size_type_node));
8371	tmp = arg->symtree->n.sym->backend_decl;
8372	tmp = DECL_LANG_SPECIFIC (tmp)
8373	&& GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8374	? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8375	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8376	tmp = build_fold_indirect_ref_loc (input_location, tmp);
8377
8378	tmp = gfc_conv_descriptor_dtype (tmp);
8379	field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8380	GFC_DTYPE_ELEM_LEN);
8381	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8382	tmp, field, NULL_TREE);
8383
8384	byte_size = fold_convert (gfc_array_index_type, tmp);
8385	}
8386	else if (arg->ts.type == BT_CLASS)
8387	{
8388	/* Conv_expr_descriptor returns a component_ref to _data component of the
8389	class object. The class object may be a non-pointer object, e.g.
8390	located on the stack, or a memory location pointed to, e.g. a
8391	parameter, i.e., an indirect_ref. */
8392	if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8393	&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8394	byte_size
8395	= gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8396	else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8397	byte_size = gfc_class_vtab_size_get (argse.expr);
8398	else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8399	&& TREE_CODE (argse.expr) == COMPONENT_REF)
8400	byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8401	else if (arg->rank > 0
8402	|| (arg->rank == 0
8403	&& arg->ref && arg->ref->type == REF_COMPONENT))
8404	{
8405	/* The scalarizer added an additional temp. To get the class' vptr
8406	one has to look at the original backend_decl. */
8407	if (argse.class_container)
8408	byte_size = gfc_class_vtab_size_get (argse.class_container);
8409	else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8410	byte_size = gfc_class_vtab_size_get (
8411	GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8412	else
8413	gcc_unreachable ();
8414	}
8415	else
8416	gcc_unreachable ();
8417	}
8418	else
8419	{
8420	if (arg->ts.type == BT_CHARACTER)
8421	byte_size = size_of_string_in_bytes (kind: arg->ts.kind, string_length: argse.string_length);
8422	else
8423	{
8424	if (arg->rank == 0)
8425	byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8426	argse.expr));
8427	else
8428	byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8429	byte_size = fold_convert (gfc_array_index_type,
8430	size_in_bytes (byte_size));
8431	}
8432	}
8433
8434	if (arg->rank == 0)
8435	se->expr = byte_size;
8436	else
8437	{
8438	source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8439	gfc_add_modify (&argse.pre, source_bytes, byte_size);
8440
8441	if (arg->rank == -1)
8442	{
8443	tree cond, loop_var, exit_label;
8444	stmtblock_t body;
8445
8446	tmp = fold_convert (gfc_array_index_type,
8447	gfc_conv_descriptor_rank (argse.expr));
8448	loop_var = gfc_create_var (gfc_array_index_type, "i");
8449	gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8450	exit_label = gfc_build_label_decl (NULL_TREE);
8451
8452	/* Create loop:
8453	for (;;)
8454	{
8455	if (i >= rank)
8456	goto exit;
8457	source_bytes = source_bytes * array.dim[i].extent;
8458	i = i + 1;
8459	}
8460	exit: */
8461	gfc_start_block (&body);
8462	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8463	loop_var, tmp);
8464	tmp = build1_v (GOTO_EXPR, exit_label);
8465	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8466	cond, tmp, build_empty_stmt (input_location));
8467	gfc_add_expr_to_block (&body, tmp);
8468
8469	lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8470	upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8471	tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8472	tmp = fold_build2_loc (input_location, MULT_EXPR,
8473	gfc_array_index_type, tmp, source_bytes);
8474	gfc_add_modify (&body, source_bytes, tmp);
8475
8476	tmp = fold_build2_loc (input_location, PLUS_EXPR,
8477	gfc_array_index_type, loop_var,
8478	gfc_index_one_node);
8479	gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8480
8481	tmp = gfc_finish_block (&body);
8482
8483	tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8484	tmp);
8485	gfc_add_expr_to_block (&argse.pre, tmp);
8486
8487	tmp = build1_v (LABEL_EXPR, exit_label);
8488	gfc_add_expr_to_block (&argse.pre, tmp);
8489	}
8490	else
8491	{
8492	/* Obtain the size of the array in bytes. */
8493	for (n = 0; n < arg->rank; n++)
8494	{
8495	tree idx;
8496	idx = gfc_rank_cst[n];
8497	lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8498	upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8499	tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8500	tmp = fold_build2_loc (input_location, MULT_EXPR,
8501	gfc_array_index_type, tmp, source_bytes);
8502	gfc_add_modify (&argse.pre, source_bytes, tmp);
8503	}
8504	}
8505	se->expr = source_bytes;
8506	}
8507
8508	gfc_add_block_to_block (&se->pre, &argse.pre);
8509	}
8510
8511
8512	static void
8513	gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8514	{
8515	gfc_expr *arg;
8516	gfc_se argse;
8517	tree type, result_type, tmp, class_decl = NULL;
8518	gfc_symbol *sym;
8519	bool unlimited = false;
8520
8521	arg = expr->value.function.actual->expr;
8522
8523	gfc_init_se (&argse, NULL);
8524	result_type = gfc_get_int_type (expr->ts.kind);
8525
8526	if (arg->rank == 0)
8527	{
8528	if (arg->ts.type == BT_CLASS)
8529	{
8530	unlimited = UNLIMITED_POLY (arg);
8531	gfc_add_vptr_component (arg);
8532	gfc_add_size_component (arg);
8533	gfc_conv_expr (se: &argse, expr: arg);
8534	tmp = fold_convert (result_type, argse.expr);
8535	class_decl = gfc_get_class_from_expr (argse.expr);
8536	goto done;
8537	}
8538
8539	gfc_conv_expr_reference (se: &argse, expr: arg);
8540	type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8541	argse.expr));
8542	}
8543	else
8544	{
8545	argse.want_pointer = 0;
8546	gfc_conv_expr_descriptor (&argse, arg);
8547	sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8548	if (arg->ts.type == BT_CLASS)
8549	{
8550	unlimited = UNLIMITED_POLY (arg);
8551	if (TREE_CODE (argse.expr) == COMPONENT_REF)
8552	tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8553	else if (arg->rank > 0 && sym
8554	&& DECL_LANG_SPECIFIC (sym->backend_decl))
8555	tmp = gfc_class_vtab_size_get (
8556	GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8557	else
8558	gcc_unreachable ();
8559	tmp = fold_convert (result_type, tmp);
8560	class_decl = gfc_get_class_from_expr (argse.expr);
8561	goto done;
8562	}
8563	type = gfc_get_element_type (TREE_TYPE (argse.expr));
8564	}
8565
8566	/* Obtain the argument's word length. */
8567	if (arg->ts.type == BT_CHARACTER)
8568	tmp = size_of_string_in_bytes (kind: arg->ts.kind, string_length: argse.string_length);
8569	else
8570	tmp = size_in_bytes (t: type);
8571	tmp = fold_convert (result_type, tmp);
8572
8573	done:
8574	if (unlimited && class_decl)
8575	tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8576
8577	se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8578	build_int_cst (result_type, BITS_PER_UNIT));
8579	gfc_add_block_to_block (&se->pre, &argse.pre);
8580	}
8581
8582
8583	/* Intrinsic string comparison functions. */
8584
8585	static void
8586	gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8587	{
8588	tree args[4];
8589
8590	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 4);
8591
8592	se->expr
8593	= gfc_build_compare_string (args[0], args[1], args[2], args[3],
8594	expr->value.function.actual->expr->ts.kind,
8595	op);
8596	se->expr = fold_build2_loc (input_location, op,
8597	gfc_typenode_for_spec (&expr->ts), se->expr,
8598	build_int_cst (TREE_TYPE (se->expr), 0));
8599	}
8600
8601	/* Generate a call to the adjustl/adjustr library function. */
8602	static void
8603	gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8604	{
8605	tree args[3];
8606	tree len;
8607	tree type;
8608	tree var;
8609	tree tmp;
8610
8611	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[1], nargs: 2);
8612	len = args[1];
8613
8614	type = TREE_TYPE (args[2]);
8615	var = gfc_conv_string_tmp (se, type, len);
8616	args[0] = var;
8617
8618	tmp = build_call_expr_loc (input_location,
8619	fndecl, 3, args[0], args[1], args[2]);
8620	gfc_add_expr_to_block (&se->pre, tmp);
8621	se->expr = var;
8622	se->string_length = len;
8623	}
8624
8625
8626	/* Generate code for the TRANSFER intrinsic:
8627	For scalar results:
8628	DEST = TRANSFER (SOURCE, MOLD)
8629	where:
8630	typeof<DEST> = typeof<MOLD>
8631	and:
8632	MOLD is scalar.
8633
8634	For array results:
8635	DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8636	where:
8637	typeof<DEST> = typeof<MOLD>
8638	and:
8639	N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8640	sizeof (DEST(0) * SIZE). */
8641	static void
8642	gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8643	{
8644	tree tmp;
8645	tree tmpdecl;
8646	tree ptr;
8647	tree extent;
8648	tree source;
8649	tree source_type;
8650	tree source_bytes;
8651	tree mold_type;
8652	tree dest_word_len;
8653	tree size_words;
8654	tree size_bytes;
8655	tree upper;
8656	tree lower;
8657	tree stmt;
8658	tree class_ref = NULL_TREE;
8659	gfc_actual_arglist *arg;
8660	gfc_se argse;
8661	gfc_array_info *info;
8662	stmtblock_t block;
8663	int n;
8664	bool scalar_mold;
8665	gfc_expr *source_expr, *mold_expr, *class_expr;
8666
8667	info = NULL;
8668	if (se->loop)
8669	info = &se->ss->info->data.array;
8670
8671	/* Convert SOURCE. The output from this stage is:-
8672	source_bytes = length of the source in bytes
8673	source = pointer to the source data. */
8674	arg = expr->value.function.actual;
8675	source_expr = arg->expr;
8676
8677	/* Ensure double transfer through LOGICAL preserves all
8678	the needed bits. */
8679	if (arg->expr->expr_type == EXPR_FUNCTION
8680	&& arg->expr->value.function.esym == NULL
8681	&& arg->expr->value.function.isym != NULL
8682	&& arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8683	&& arg->expr->ts.type == BT_LOGICAL
8684	&& expr->ts.type != arg->expr->ts.type)
8685	arg->expr->value.function.name = "__transfer_in_transfer";
8686
8687	gfc_init_se (&argse, NULL);
8688
8689	source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8690
8691	/* Obtain the pointer to source and the length of source in bytes. */
8692	if (arg->expr->rank == 0)
8693	{
8694	gfc_conv_expr_reference (se: &argse, expr: arg->expr);
8695	if (arg->expr->ts.type == BT_CLASS)
8696	{
8697	tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8698	if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8699	{
8700	source = gfc_class_data_get (tmp);
8701	class_ref = tmp;
8702	}
8703	else
8704	{
8705	/* Array elements are evaluated as a reference to the data.
8706	To obtain the vptr for the element size, the argument
8707	expression must be stripped to the class reference and
8708	re-evaluated. The pre and post blocks are not needed. */
8709	gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8710	source = argse.expr;
8711	class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8712	gfc_init_se (&argse, NULL);
8713	gfc_conv_expr (se: &argse, expr: class_expr);
8714	class_ref = argse.expr;
8715	}
8716	}
8717	else
8718	source = argse.expr;
8719
8720	/* Obtain the source word length. */
8721	switch (arg->expr->ts.type)
8722	{
8723	case BT_CHARACTER:
8724	tmp = size_of_string_in_bytes (kind: arg->expr->ts.kind,
8725	string_length: argse.string_length);
8726	break;
8727	case BT_CLASS:
8728	if (class_ref != NULL_TREE)
8729	{
8730	tmp = gfc_class_vtab_size_get (class_ref);
8731	if (UNLIMITED_POLY (source_expr))
8732	tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8733	}
8734	else
8735	{
8736	tmp = gfc_class_vtab_size_get (argse.expr);
8737	if (UNLIMITED_POLY (source_expr))
8738	tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8739	}
8740	break;
8741	default:
8742	source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8743	source));
8744	tmp = fold_convert (gfc_array_index_type,
8745	size_in_bytes (source_type));
8746	break;
8747	}
8748	}
8749	else
8750	{
8751	bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8752	false, true);
8753	argse.want_pointer = 0;
8754	/* A non-contiguous SOURCE needs packing. */
8755	if (!simply_contiguous)
8756	argse.force_tmp = 1;
8757	gfc_conv_expr_descriptor (&argse, arg->expr);
8758	source = gfc_conv_descriptor_data_get (argse.expr);
8759	source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8760
8761	/* Repack the source if not simply contiguous. */
8762	if (!simply_contiguous)
8763	{
8764	tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8765
8766	if (warn_array_temporaries)
8767	gfc_warning (opt: OPT_Warray_temporaries,
8768	"Creating array temporary at %L", &expr->where);
8769
8770	source = build_call_expr_loc (input_location,
8771	gfor_fndecl_in_pack, 1, tmp);
8772	source = gfc_evaluate_now (source, &argse.pre);
8773
8774	/* Free the temporary. */
8775	gfc_start_block (&block);
8776	tmp = gfc_call_free (source);
8777	gfc_add_expr_to_block (&block, tmp);
8778	stmt = gfc_finish_block (&block);
8779
8780	/* Clean up if it was repacked. */
8781	gfc_init_block (&block);
8782	tmp = gfc_conv_array_data (argse.expr);
8783	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8784	source, tmp);
8785	tmp = build3_v (COND_EXPR, tmp, stmt,
8786	build_empty_stmt (input_location));
8787	gfc_add_expr_to_block (&block, tmp);
8788	gfc_add_block_to_block (&block, &se->post);
8789	gfc_init_block (&se->post);
8790	gfc_add_block_to_block (&se->post, &block);
8791	}
8792
8793	/* Obtain the source word length. */
8794	if (arg->expr->ts.type == BT_CHARACTER)
8795	tmp = size_of_string_in_bytes (kind: arg->expr->ts.kind,
8796	string_length: argse.string_length);
8797	else if (arg->expr->ts.type == BT_CLASS)
8798	{
8799	if (UNLIMITED_POLY (source_expr)
8800	&& DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8801	class_ref = GFC_DECL_SAVED_DESCRIPTOR
8802	(source_expr->symtree->n.sym->backend_decl);
8803	else
8804	class_ref = TREE_OPERAND (argse.expr, 0);
8805	tmp = gfc_class_vtab_size_get (class_ref);
8806	if (UNLIMITED_POLY (arg->expr))
8807	tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8808	}
8809	else
8810	tmp = fold_convert (gfc_array_index_type,
8811	size_in_bytes (source_type));
8812
8813	/* Obtain the size of the array in bytes. */
8814	extent = gfc_create_var (gfc_array_index_type, NULL);
8815	for (n = 0; n < arg->expr->rank; n++)
8816	{
8817	tree idx;
8818	idx = gfc_rank_cst[n];
8819	gfc_add_modify (&argse.pre, source_bytes, tmp);
8820	lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8821	upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8822	tmp = fold_build2_loc (input_location, MINUS_EXPR,
8823	gfc_array_index_type, upper, lower);
8824	gfc_add_modify (&argse.pre, extent, tmp);
8825	tmp = fold_build2_loc (input_location, PLUS_EXPR,
8826	gfc_array_index_type, extent,
8827	gfc_index_one_node);
8828	tmp = fold_build2_loc (input_location, MULT_EXPR,
8829	gfc_array_index_type, tmp, source_bytes);
8830	}
8831	}
8832
8833	gfc_add_modify (&argse.pre, source_bytes, tmp);
8834	gfc_add_block_to_block (&se->pre, &argse.pre);
8835	gfc_add_block_to_block (&se->post, &argse.post);
8836
8837	/* Now convert MOLD. The outputs are:
8838	mold_type = the TREE type of MOLD
8839	dest_word_len = destination word length in bytes. */
8840	arg = arg->next;
8841	mold_expr = arg->expr;
8842
8843	gfc_init_se (&argse, NULL);
8844
8845	scalar_mold = arg->expr->rank == 0;
8846
8847	if (arg->expr->rank == 0)
8848	{
8849	gfc_conv_expr_reference (se: &argse, expr: mold_expr);
8850	mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8851	argse.expr));
8852	}
8853	else
8854	{
8855	argse.want_pointer = 0;
8856	gfc_conv_expr_descriptor (&argse, mold_expr);
8857	mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8858	}
8859
8860	gfc_add_block_to_block (&se->pre, &argse.pre);
8861	gfc_add_block_to_block (&se->post, &argse.post);
8862
8863	if (strcmp (s1: expr->value.function.name, s2: "__transfer_in_transfer") == 0)
8864	{
8865	/* If this TRANSFER is nested in another TRANSFER, use a type
8866	that preserves all bits. */
8867	if (mold_expr->ts.type == BT_LOGICAL)
8868	mold_type = gfc_get_int_type (mold_expr->ts.kind);
8869	}
8870
8871	/* Obtain the destination word length. */
8872	switch (mold_expr->ts.type)
8873	{
8874	case BT_CHARACTER:
8875	tmp = size_of_string_in_bytes (kind: mold_expr->ts.kind, string_length: argse.string_length);
8876	mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8877	argse.string_length);
8878	break;
8879	case BT_CLASS:
8880	if (scalar_mold)
8881	class_ref = argse.expr;
8882	else
8883	class_ref = TREE_OPERAND (argse.expr, 0);
8884	tmp = gfc_class_vtab_size_get (class_ref);
8885	if (UNLIMITED_POLY (arg->expr))
8886	tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8887	break;
8888	default:
8889	tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8890	break;
8891	}
8892
8893	/* Do not fix dest_word_len if it is a variable, since the temporary can wind
8894	up being used before the assignment. */
8895	if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8896	dest_word_len = tmp;
8897	else
8898	{
8899	dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8900	gfc_add_modify (&se->pre, dest_word_len, tmp);
8901	}
8902
8903	/* Finally convert SIZE, if it is present. */
8904	arg = arg->next;
8905	size_words = gfc_create_var (gfc_array_index_type, NULL);
8906
8907	if (arg->expr)
8908	{
8909	gfc_init_se (&argse, NULL);
8910	gfc_conv_expr_reference (se: &argse, expr: arg->expr);
8911	tmp = convert (gfc_array_index_type,
8912	build_fold_indirect_ref_loc (input_location,
8913	argse.expr));
8914	gfc_add_block_to_block (&se->pre, &argse.pre);
8915	gfc_add_block_to_block (&se->post, &argse.post);
8916	}
8917	else
8918	tmp = NULL_TREE;
8919
8920	/* Separate array and scalar results. */
8921	if (scalar_mold && tmp == NULL_TREE)
8922	goto scalar_transfer;
8923
8924	size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8925	if (tmp != NULL_TREE)
8926	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8927	tmp, dest_word_len);
8928	else
8929	tmp = source_bytes;
8930
8931	gfc_add_modify (&se->pre, size_bytes, tmp);
8932	gfc_add_modify (&se->pre, size_words,
8933	fold_build2_loc (input_location, CEIL_DIV_EXPR,
8934	gfc_array_index_type,
8935	size_bytes, dest_word_len));
8936
8937	/* Evaluate the bounds of the result. If the loop range exists, we have
8938	to check if it is too large. If so, we modify loop->to be consistent
8939	with min(size, size(source)). Otherwise, size is made consistent with
8940	the loop range, so that the right number of bytes is transferred.*/
8941	n = se->loop->order[0];
8942	if (se->loop->to[n] != NULL_TREE)
8943	{
8944	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8945	se->loop->to[n], se->loop->from[n]);
8946	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8947	tmp, gfc_index_one_node);
8948	tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8949	tmp, size_words);
8950	gfc_add_modify (&se->pre, size_words, tmp);
8951	gfc_add_modify (&se->pre, size_bytes,
8952	fold_build2_loc (input_location, MULT_EXPR,
8953	gfc_array_index_type,
8954	size_words, dest_word_len));
8955	upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8956	size_words, se->loop->from[n]);
8957	upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8958	upper, gfc_index_one_node);
8959	}
8960	else
8961	{
8962	upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8963	size_words, gfc_index_one_node);
8964	se->loop->from[n] = gfc_index_zero_node;
8965	}
8966
8967	se->loop->to[n] = upper;
8968
8969	/* Build a destination descriptor, using the pointer, source, as the
8970	data field. */
8971	gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
8972	NULL_TREE, false, true, false, &expr->where);
8973
8974	/* Cast the pointer to the result. */
8975	tmp = gfc_conv_descriptor_data_get (info->descriptor);
8976	tmp = fold_convert (pvoid_type_node, tmp);
8977
8978	/* Use memcpy to do the transfer. */
8979	tmp
8980	= build_call_expr_loc (input_location,
8981	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3, tmp,
8982	fold_convert (pvoid_type_node, source),
8983	fold_convert (size_type_node,
8984	fold_build2_loc (input_location,
8985	MIN_EXPR,
8986	gfc_array_index_type,
8987	size_bytes,
8988	source_bytes)));
8989	gfc_add_expr_to_block (&se->pre, tmp);
8990
8991	se->expr = info->descriptor;
8992	if (expr->ts.type == BT_CHARACTER)
8993	{
8994	tmp = fold_convert (gfc_charlen_type_node,
8995	TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
8996	se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
8997	gfc_charlen_type_node,
8998	dest_word_len, tmp);
8999	}
9000
9001	return;
9002
9003	/* Deal with scalar results. */
9004	scalar_transfer:
9005	extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9006	dest_word_len, source_bytes);
9007	extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9008	extent, gfc_index_zero_node);
9009
9010	if (expr->ts.type == BT_CHARACTER)
9011	{
9012	tree direct, indirect, free;
9013
9014	ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9015	tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9016	"transfer");
9017
9018	/* If source is longer than the destination, use a pointer to
9019	the source directly. */
9020	gfc_init_block (&block);
9021	gfc_add_modify (&block, tmpdecl, ptr);
9022	direct = gfc_finish_block (&block);
9023
9024	/* Otherwise, allocate a string with the length of the destination
9025	and copy the source into it. */
9026	gfc_init_block (&block);
9027	tmp = gfc_get_pchar_type (expr->ts.kind);
9028	tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9029	gfc_add_modify (&block, tmpdecl,
9030	fold_convert (TREE_TYPE (ptr), tmp));
9031	tmp = build_call_expr_loc (input_location,
9032	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3,
9033	fold_convert (pvoid_type_node, tmpdecl),
9034	fold_convert (pvoid_type_node, ptr),
9035	fold_convert (size_type_node, extent));
9036	gfc_add_expr_to_block (&block, tmp);
9037	indirect = gfc_finish_block (&block);
9038
9039	/* Wrap it up with the condition. */
9040	tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9041	dest_word_len, source_bytes);
9042	tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9043	gfc_add_expr_to_block (&se->pre, tmp);
9044
9045	/* Free the temporary string, if necessary. */
9046	free = gfc_call_free (tmpdecl);
9047	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9048	dest_word_len, source_bytes);
9049	tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9050	gfc_add_expr_to_block (&se->post, tmp);
9051
9052	se->expr = tmpdecl;
9053	tmp = fold_convert (gfc_charlen_type_node,
9054	TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9055	se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9056	gfc_charlen_type_node,
9057	dest_word_len, tmp);
9058	}
9059	else
9060	{
9061	tmpdecl = gfc_create_var (mold_type, "transfer");
9062
9063	ptr = convert (build_pointer_type (mold_type), source);
9064
9065	/* For CLASS results, allocate the needed memory first. */
9066	if (mold_expr->ts.type == BT_CLASS)
9067	{
9068	tree cdata;
9069	cdata = gfc_class_data_get (tmpdecl);
9070	tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9071	gfc_add_modify (&se->pre, cdata, tmp);
9072	}
9073
9074	/* Use memcpy to do the transfer. */
9075	if (mold_expr->ts.type == BT_CLASS)
9076	tmp = gfc_class_data_get (tmpdecl);
9077	else
9078	tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9079
9080	tmp = build_call_expr_loc (input_location,
9081	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3,
9082	fold_convert (pvoid_type_node, tmp),
9083	fold_convert (pvoid_type_node, ptr),
9084	fold_convert (size_type_node, extent));
9085	gfc_add_expr_to_block (&se->pre, tmp);
9086
9087	/* For CLASS results, set the _vptr. */
9088	if (mold_expr->ts.type == BT_CLASS)
9089	gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9090
9091	se->expr = tmpdecl;
9092	}
9093	}
9094
9095
9096	/* Generate code for the ALLOCATED intrinsic.
9097	Generate inline code that directly check the address of the argument. */
9098
9099	static void
9100	gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9101	{
9102	gfc_se arg1se;
9103	tree tmp;
9104	gfc_expr *e = expr->value.function.actual->expr;
9105
9106	gfc_init_se (&arg1se, NULL);
9107	if (e->ts.type == BT_CLASS)
9108	{
9109	/* Make sure that class array expressions have both a _data
9110	component reference and an array reference.... */
9111	if (CLASS_DATA (e)->attr.dimension)
9112	gfc_add_class_array_ref (e);
9113	/* .... whilst scalars only need the _data component. */
9114	else
9115	gfc_add_data_component (e);
9116	}
9117
9118	gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9119
9120	if (e->rank == 0)
9121	{
9122	/* Allocatable scalar. */
9123	arg1se.want_pointer = 1;
9124	gfc_conv_expr (se: &arg1se, expr: e);
9125	tmp = arg1se.expr;
9126	}
9127	else
9128	{
9129	/* Allocatable array. */
9130	arg1se.descriptor_only = 1;
9131	gfc_conv_expr_descriptor (&arg1se, e);
9132	tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9133	}
9134
9135	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9136	fold_convert (TREE_TYPE (tmp), null_pointer_node));
9137
9138	/* Components of pointer array references sometimes come back with a pre block. */
9139	if (arg1se.pre.head)
9140	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9141
9142	se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9143	}
9144
9145
9146	/* Generate code for the ASSOCIATED intrinsic.
9147	If both POINTER and TARGET are arrays, generate a call to library function
9148	_gfor_associated, and pass descriptors of POINTER and TARGET to it.
9149	In other cases, generate inline code that directly compare the address of
9150	POINTER with the address of TARGET. */
9151
9152	static void
9153	gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9154	{
9155	gfc_actual_arglist *arg1;
9156	gfc_actual_arglist *arg2;
9157	gfc_se arg1se;
9158	gfc_se arg2se;
9159	tree tmp2;
9160	tree tmp;
9161	tree nonzero_arraylen = NULL_TREE;
9162	gfc_ss *ss;
9163	bool scalar;
9164
9165	gfc_init_se (&arg1se, NULL);
9166	gfc_init_se (&arg2se, NULL);
9167	arg1 = expr->value.function.actual;
9168	arg2 = arg1->next;
9169
9170	/* Check whether the expression is a scalar or not; we cannot use
9171	arg1->expr->rank as it can be nonzero for proc pointers. */
9172	ss = gfc_walk_expr (arg1->expr);
9173	scalar = ss == gfc_ss_terminator;
9174	if (!scalar)
9175	gfc_free_ss_chain (ss);
9176
9177	if (!arg2->expr)
9178	{
9179	/* No optional target. */
9180	if (scalar)
9181	{
9182	/* A pointer to a scalar. */
9183	arg1se.want_pointer = 1;
9184	gfc_conv_expr (se: &arg1se, expr: arg1->expr);
9185	if (arg1->expr->symtree->n.sym->attr.proc_pointer
9186	&& arg1->expr->symtree->n.sym->attr.dummy)
9187	arg1se.expr = build_fold_indirect_ref_loc (input_location,
9188	arg1se.expr);
9189	if (arg1->expr->ts.type == BT_CLASS)
9190	{
9191	tmp2 = gfc_class_data_get (arg1se.expr);
9192	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9193	tmp2 = gfc_conv_descriptor_data_get (tmp2);
9194	}
9195	else
9196	tmp2 = arg1se.expr;
9197	}
9198	else
9199	{
9200	/* A pointer to an array. */
9201	gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9202	tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9203	}
9204	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9205	gfc_add_block_to_block (&se->post, &arg1se.post);
9206	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9207	fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9208	se->expr = tmp;
9209	}
9210	else
9211	{
9212	/* An optional target. */
9213	if (arg2->expr->ts.type == BT_CLASS
9214	&& arg2->expr->expr_type != EXPR_FUNCTION)
9215	gfc_add_data_component (arg2->expr);
9216
9217	if (scalar)
9218	{
9219	/* A pointer to a scalar. */
9220	arg1se.want_pointer = 1;
9221	gfc_conv_expr (se: &arg1se, expr: arg1->expr);
9222	if (arg1->expr->symtree->n.sym->attr.proc_pointer
9223	&& arg1->expr->symtree->n.sym->attr.dummy)
9224	arg1se.expr = build_fold_indirect_ref_loc (input_location,
9225	arg1se.expr);
9226	if (arg1->expr->ts.type == BT_CLASS)
9227	arg1se.expr = gfc_class_data_get (arg1se.expr);
9228
9229	arg2se.want_pointer = 1;
9230	gfc_conv_expr (se: &arg2se, expr: arg2->expr);
9231	if (arg2->expr->symtree->n.sym->attr.proc_pointer
9232	&& arg2->expr->symtree->n.sym->attr.dummy)
9233	arg2se.expr = build_fold_indirect_ref_loc (input_location,
9234	arg2se.expr);
9235	if (arg2->expr->ts.type == BT_CLASS)
9236	{
9237	arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9238	arg2se.expr = gfc_class_data_get (arg2se.expr);
9239	}
9240	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9241	gfc_add_block_to_block (&se->post, &arg1se.post);
9242	gfc_add_block_to_block (&se->pre, &arg2se.pre);
9243	gfc_add_block_to_block (&se->post, &arg2se.post);
9244	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9245	arg1se.expr, arg2se.expr);
9246	tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9247	arg1se.expr, null_pointer_node);
9248	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9249	logical_type_node, tmp, tmp2);
9250	}
9251	else
9252	{
9253	/* An array pointer of zero length is not associated if target is
9254	present. */
9255	arg1se.descriptor_only = 1;
9256	gfc_conv_expr_lhs (se: &arg1se, expr: arg1->expr);
9257	if (arg1->expr->rank == -1)
9258	{
9259	tmp = gfc_conv_descriptor_rank (arg1se.expr);
9260	tmp = fold_build2_loc (input_location, MINUS_EXPR,
9261	TREE_TYPE (tmp), tmp,
9262	build_int_cst (TREE_TYPE (tmp), 1));
9263	}
9264	else
9265	tmp = gfc_rank_cst[arg1->expr->rank - 1];
9266	tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9267	if (arg2->expr->rank != 0)
9268	nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9269	logical_type_node, tmp,
9270	build_int_cst (TREE_TYPE (tmp), 0));
9271
9272	/* A pointer to an array, call library function _gfor_associated. */
9273	arg1se.want_pointer = 1;
9274	gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9275	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9276	gfc_add_block_to_block (&se->post, &arg1se.post);
9277
9278	arg2se.want_pointer = 1;
9279	arg2se.force_no_tmp = 1;
9280	if (arg2->expr->rank != 0)
9281	gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9282	else
9283	{
9284	gfc_conv_expr (se: &arg2se, expr: arg2->expr);
9285	arg2se.expr
9286	= gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9287	gfc_expr_attr (arg2->expr));
9288	arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9289	}
9290	gfc_add_block_to_block (&se->pre, &arg2se.pre);
9291	gfc_add_block_to_block (&se->post, &arg2se.post);
9292	se->expr = build_call_expr_loc (input_location,
9293	gfor_fndecl_associated, 2,
9294	arg1se.expr, arg2se.expr);
9295	se->expr = convert (logical_type_node, se->expr);
9296	if (arg2->expr->rank != 0)
9297	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9298	logical_type_node, se->expr,
9299	nonzero_arraylen);
9300	}
9301
9302	/* If target is present zero character length pointers cannot
9303	be associated. */
9304	if (arg1->expr->ts.type == BT_CHARACTER)
9305	{
9306	tmp = arg1se.string_length;
9307	tmp = fold_build2_loc (input_location, NE_EXPR,
9308	logical_type_node, tmp,
9309	build_zero_cst (TREE_TYPE (tmp)));
9310	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9311	logical_type_node, se->expr, tmp);
9312	}
9313	}
9314
9315	se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9316	}
9317
9318
9319	/* Generate code for the SAME_TYPE_AS intrinsic.
9320	Generate inline code that directly checks the vindices. */
9321
9322	static void
9323	gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9324	{
9325	gfc_expr *a, *b;
9326	gfc_se se1, se2;
9327	tree tmp;
9328	tree conda = NULL_TREE, condb = NULL_TREE;
9329
9330	gfc_init_se (&se1, NULL);
9331	gfc_init_se (&se2, NULL);
9332
9333	a = expr->value.function.actual->expr;
9334	b = expr->value.function.actual->next->expr;
9335
9336	bool unlimited_poly_a = UNLIMITED_POLY (a);
9337	bool unlimited_poly_b = UNLIMITED_POLY (b);
9338	if (unlimited_poly_a)
9339	{
9340	se1.want_pointer = 1;
9341	gfc_add_vptr_component (a);
9342	}
9343	else if (a->ts.type == BT_CLASS)
9344	{
9345	gfc_add_vptr_component (a);
9346	gfc_add_hash_component (a);
9347	}
9348	else if (a->ts.type == BT_DERIVED)
9349	a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9350	a->ts.u.derived->hash_value);
9351
9352	if (unlimited_poly_b)
9353	{
9354	se2.want_pointer = 1;
9355	gfc_add_vptr_component (b);
9356	}
9357	else if (b->ts.type == BT_CLASS)
9358	{
9359	gfc_add_vptr_component (b);
9360	gfc_add_hash_component (b);
9361	}
9362	else if (b->ts.type == BT_DERIVED)
9363	b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9364	b->ts.u.derived->hash_value);
9365
9366	gfc_conv_expr (se: &se1, expr: a);
9367	gfc_conv_expr (se: &se2, expr: b);
9368
9369	if (unlimited_poly_a)
9370	{
9371	conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9372	se1.expr,
9373	build_int_cst (TREE_TYPE (se1.expr), 0));
9374	se1.expr = gfc_vptr_hash_get (se1.expr);
9375	}
9376
9377	if (unlimited_poly_b)
9378	{
9379	condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9380	se2.expr,
9381	build_int_cst (TREE_TYPE (se2.expr), 0));
9382	se2.expr = gfc_vptr_hash_get (se2.expr);
9383	}
9384
9385	tmp = fold_build2_loc (input_location, EQ_EXPR,
9386	logical_type_node, se1.expr,
9387	fold_convert (TREE_TYPE (se1.expr), se2.expr));
9388
9389	if (conda)
9390	tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9391	logical_type_node, conda, tmp);
9392
9393	if (condb)
9394	tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9395	logical_type_node, condb, tmp);
9396
9397	se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9398	}
9399
9400
9401	/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9402
9403	static void
9404	gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9405	{
9406	tree args[2];
9407
9408	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
9409	se->expr = build_call_expr_loc (input_location,
9410	gfor_fndecl_sc_kind, 2, args[0], args[1]);
9411	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9412	}
9413
9414
9415	/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9416
9417	static void
9418	gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9419	{
9420	tree arg, type;
9421
9422	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
9423
9424	/* The argument to SELECTED_INT_KIND is INTEGER(4). */
9425	type = gfc_get_int_type (4);
9426	arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9427
9428	/* Convert it to the required type. */
9429	type = gfc_typenode_for_spec (&expr->ts);
9430	se->expr = build_call_expr_loc (input_location,
9431	gfor_fndecl_si_kind, 1, arg);
9432	se->expr = fold_convert (type, se->expr);
9433	}
9434
9435
9436	/* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9437
9438	static void
9439	gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9440	{
9441	tree arg, type;
9442
9443	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
9444
9445	/* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9446	type = gfc_get_int_type (4);
9447	arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9448
9449	/* Convert it to the required type. */
9450	type = gfc_typenode_for_spec (&expr->ts);
9451	se->expr = build_call_expr_loc (input_location,
9452	gfor_fndecl_sl_kind, 1, arg);
9453	se->expr = fold_convert (type, se->expr);
9454	}
9455
9456
9457	/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9458
9459	static void
9460	gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9461	{
9462	gfc_actual_arglist *actual;
9463	tree type;
9464	gfc_se argse;
9465	vec<tree, va_gc> *args = NULL;
9466
9467	for (actual = expr->value.function.actual; actual; actual = actual->next)
9468	{
9469	gfc_init_se (&argse, se);
9470
9471	/* Pass a NULL pointer for an absent arg. */
9472	if (actual->expr == NULL)
9473	argse.expr = null_pointer_node;
9474	else
9475	{
9476	gfc_typespec ts;
9477	gfc_clear_ts (&ts);
9478
9479	if (actual->expr->ts.kind != gfc_c_int_kind)
9480	{
9481	/* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9482	ts.type = BT_INTEGER;
9483	ts.kind = gfc_c_int_kind;
9484	gfc_convert_type (actual->expr, &ts, 2);
9485	}
9486	gfc_conv_expr_reference (se: &argse, expr: actual->expr);
9487	}
9488
9489	gfc_add_block_to_block (&se->pre, &argse.pre);
9490	gfc_add_block_to_block (&se->post, &argse.post);
9491	vec_safe_push (v&: args, obj: argse.expr);
9492	}
9493
9494	/* Convert it to the required type. */
9495	type = gfc_typenode_for_spec (&expr->ts);
9496	se->expr = build_call_expr_loc_vec (input_location,
9497	gfor_fndecl_sr_kind, args);
9498	se->expr = fold_convert (type, se->expr);
9499	}
9500
9501
9502	/* Generate code for TRIM (A) intrinsic function. */
9503
9504	static void
9505	gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9506	{
9507	tree var;
9508	tree len;
9509	tree addr;
9510	tree tmp;
9511	tree cond;
9512	tree fndecl;
9513	tree function;
9514	tree *args;
9515	unsigned int num_args;
9516
9517	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9518	args = XALLOCAVEC (tree, num_args);
9519
9520	var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9521	addr = gfc_build_addr_expr (ppvoid_type_node, var);
9522	len = gfc_create_var (gfc_charlen_type_node, "len");
9523
9524	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
9525	args[0] = gfc_build_addr_expr (NULL_TREE, len);
9526	args[1] = addr;
9527
9528	if (expr->ts.kind == 1)
9529	function = gfor_fndecl_string_trim;
9530	else if (expr->ts.kind == 4)
9531	function = gfor_fndecl_string_trim_char4;
9532	else
9533	gcc_unreachable ();
9534
9535	fndecl = build_addr (function);
9536	tmp = build_call_array_loc (input_location,
9537	TREE_TYPE (TREE_TYPE (function)), fndecl,
9538	num_args, args);
9539	gfc_add_expr_to_block (&se->pre, tmp);
9540
9541	/* Free the temporary afterwards, if necessary. */
9542	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9543	len, build_int_cst (TREE_TYPE (len), 0));
9544	tmp = gfc_call_free (var);
9545	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9546	gfc_add_expr_to_block (&se->post, tmp);
9547
9548	se->expr = var;
9549	se->string_length = len;
9550	}
9551
9552
9553	/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9554
9555	static void
9556	gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9557	{
9558	tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9559	tree type, cond, tmp, count, exit_label, n, max, largest;
9560	tree size;
9561	stmtblock_t block, body;
9562	int i;
9563
9564	/* We store in charsize the size of a character. */
9565	i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9566	size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9567
9568	/* Get the arguments. */
9569	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
9570	slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9571	src = args[1];
9572	ncopies = gfc_evaluate_now (args[2], &se->pre);
9573	ncopies_type = TREE_TYPE (ncopies);
9574
9575	/* Check that NCOPIES is not negative. */
9576	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9577	build_int_cst (ncopies_type, 0));
9578	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9579	"Argument NCOPIES of REPEAT intrinsic is negative "
9580	"(its value is %ld)",
9581	fold_convert (long_integer_type_node, ncopies));
9582
9583	/* If the source length is zero, any non negative value of NCOPIES
9584	is valid, and nothing happens. */
9585	n = gfc_create_var (ncopies_type, "ncopies");
9586	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9587	size_zero_node);
9588	tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9589	build_int_cst (ncopies_type, 0), ncopies);
9590	gfc_add_modify (&se->pre, n, tmp);
9591	ncopies = n;
9592
9593	/* Check that ncopies is not too large: ncopies should be less than
9594	(or equal to) MAX / slen, where MAX is the maximal integer of
9595	the gfc_charlen_type_node type. If slen == 0, we need a special
9596	case to avoid the division by zero. */
9597	max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9598	fold_convert (sizetype,
9599	TYPE_MAX_VALUE (gfc_charlen_type_node)),
9600	slen);
9601	largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9602	? sizetype : ncopies_type;
9603	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9604	fold_convert (largest, ncopies),
9605	fold_convert (largest, max));
9606	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9607	size_zero_node);
9608	cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9609	logical_false_node, cond);
9610	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9611	"Argument NCOPIES of REPEAT intrinsic is too large");
9612
9613	/* Compute the destination length. */
9614	dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9615	fold_convert (gfc_charlen_type_node, slen),
9616	fold_convert (gfc_charlen_type_node, ncopies));
9617	type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9618	dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9619
9620	/* Generate the code to do the repeat operation:
9621	for (i = 0; i < ncopies; i++)
9622	memmove (dest + (i * slen * size), src, slen*size); */
9623	gfc_start_block (&block);
9624	count = gfc_create_var (sizetype, "count");
9625	gfc_add_modify (&block, count, size_zero_node);
9626	exit_label = gfc_build_label_decl (NULL_TREE);
9627
9628	/* Start the loop body. */
9629	gfc_start_block (&body);
9630
9631	/* Exit the loop if count >= ncopies. */
9632	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9633	fold_convert (sizetype, ncopies));
9634	tmp = build1_v (GOTO_EXPR, exit_label);
9635	TREE_USED (exit_label) = 1;
9636	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9637	build_empty_stmt (input_location));
9638	gfc_add_expr_to_block (&body, tmp);
9639
9640	/* Call memmove (dest + (i*slen*size), src, slen*size). */
9641	tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9642	count);
9643	tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9644	size);
9645	tmp = fold_build_pointer_plus_loc (loc: input_location,
9646	fold_convert (pvoid_type_node, dest), off: tmp);
9647	tmp = build_call_expr_loc (input_location,
9648	builtin_decl_explicit (fncode: BUILT_IN_MEMMOVE),
9649	3, tmp, src,
9650	fold_build2_loc (input_location, MULT_EXPR,
9651	size_type_node, slen, size));
9652	gfc_add_expr_to_block (&body, tmp);
9653
9654	/* Increment count. */
9655	tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9656	count, size_one_node);
9657	gfc_add_modify (&body, count, tmp);
9658
9659	/* Build the loop. */
9660	tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9661	gfc_add_expr_to_block (&block, tmp);
9662
9663	/* Add the exit label. */
9664	tmp = build1_v (LABEL_EXPR, exit_label);
9665	gfc_add_expr_to_block (&block, tmp);
9666
9667	/* Finish the block. */
9668	tmp = gfc_finish_block (&block);
9669	gfc_add_expr_to_block (&se->pre, tmp);
9670
9671	/* Set the result value. */
9672	se->expr = dest;
9673	se->string_length = dlen;
9674	}
9675
9676
9677	/* Generate code for the IARGC intrinsic. */
9678
9679	static void
9680	gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9681	{
9682	tree tmp;
9683	tree fndecl;
9684	tree type;
9685
9686	/* Call the library function. This always returns an INTEGER(4). */
9687	fndecl = gfor_fndecl_iargc;
9688	tmp = build_call_expr_loc (input_location,
9689	fndecl, 0);
9690
9691	/* Convert it to the required type. */
9692	type = gfc_typenode_for_spec (&expr->ts);
9693	tmp = fold_convert (type, tmp);
9694
9695	se->expr = tmp;
9696	}
9697
9698
9699	/* Generate code for the KILL intrinsic. */
9700
9701	static void
9702	conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9703	{
9704	tree *args;
9705	tree int4_type_node = gfc_get_int_type (4);
9706	tree pid;
9707	tree sig;
9708	tree tmp;
9709	unsigned int num_args;
9710
9711	num_args = gfc_intrinsic_argument_list_length (expr);
9712	args = XALLOCAVEC (tree, num_args);
9713	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
9714
9715	/* Convert PID to a INTEGER(4) entity. */
9716	pid = convert (int4_type_node, args[0]);
9717
9718	/* Convert SIG to a INTEGER(4) entity. */
9719	sig = convert (int4_type_node, args[1]);
9720
9721	tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9722
9723	se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9724	}
9725
9726
9727	static tree
9728	conv_intrinsic_kill_sub (gfc_code *code)
9729	{
9730	stmtblock_t block;
9731	gfc_se se, se_stat;
9732	tree int4_type_node = gfc_get_int_type (4);
9733	tree pid;
9734	tree sig;
9735	tree statp;
9736	tree tmp;
9737
9738	/* Make the function call. */
9739	gfc_init_block (&block);
9740	gfc_init_se (&se, NULL);
9741
9742	/* Convert PID to a INTEGER(4) entity. */
9743	gfc_conv_expr (se: &se, expr: code->ext.actual->expr);
9744	gfc_add_block_to_block (&block, &se.pre);
9745	pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9746	gfc_add_block_to_block (&block, &se.post);
9747
9748	/* Convert SIG to a INTEGER(4) entity. */
9749	gfc_conv_expr (se: &se, expr: code->ext.actual->next->expr);
9750	gfc_add_block_to_block (&block, &se.pre);
9751	sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9752	gfc_add_block_to_block (&block, &se.post);
9753
9754	/* Deal with an optional STATUS. */
9755	if (code->ext.actual->next->next->expr)
9756	{
9757	gfc_init_se (&se_stat, NULL);
9758	gfc_conv_expr (se: &se_stat, expr: code->ext.actual->next->next->expr);
9759	statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9760	}
9761	else
9762	statp = NULL_TREE;
9763
9764	tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9765	statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9766
9767	gfc_add_expr_to_block (&block, tmp);
9768
9769	if (statp && statp != se_stat.expr)
9770	gfc_add_modify (&block, se_stat.expr,
9771	fold_convert (TREE_TYPE (se_stat.expr), statp));
9772
9773	return gfc_finish_block (&block);
9774	}
9775
9776
9777
9778	/* The loc intrinsic returns the address of its argument as
9779	gfc_index_integer_kind integer. */
9780
9781	static void
9782	gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9783	{
9784	tree temp_var;
9785	gfc_expr *arg_expr;
9786
9787	gcc_assert (!se->ss);
9788
9789	arg_expr = expr->value.function.actual->expr;
9790	if (arg_expr->rank == 0)
9791	{
9792	if (arg_expr->ts.type == BT_CLASS)
9793	gfc_add_data_component (arg_expr);
9794	gfc_conv_expr_reference (se, expr: arg_expr);
9795	}
9796	else
9797	gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9798	se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9799
9800	/* Create a temporary variable for loc return value. Without this,
9801	we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9802	temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9803	gfc_add_modify (&se->pre, temp_var, se->expr);
9804	se->expr = temp_var;
9805	}
9806
9807
9808	/* Specialized trim for f_c_string. */
9809
9810	static void
9811	conv_trim (gfc_se *tse, gfc_se *str)
9812	{
9813	tree cond, plen, pvar, tlen, ttmp, tvar;
9814
9815	tlen = gfc_create_var (gfc_charlen_type_node, "tlen");
9816	plen = gfc_build_addr_expr (NULL_TREE, tlen);
9817
9818	tvar = gfc_create_var (pchar_type_node, "tstr");
9819	pvar = gfc_build_addr_expr (ppvoid_type_node, tvar);
9820
9821	ttmp = build_call_expr_loc (input_location, gfor_fndecl_string_trim, 4,
9822	plen, pvar, str->string_length, str->expr);
9823
9824	gfc_add_expr_to_block (&tse->pre, ttmp);
9825
9826	/* Free the temporary afterwards, if necessary. */
9827	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9828	tlen, build_int_cst (TREE_TYPE (tlen), 0));
9829	ttmp = gfc_call_free (tvar);
9830	ttmp = build3_v (COND_EXPR, cond, ttmp, build_empty_stmt (input_location));
9831	gfc_add_expr_to_block (&tse->post, ttmp);
9832
9833	tse->expr = tvar;
9834	tse->string_length = tlen;
9835	}
9836
9837
9838	/* The following routine generates code for the intrinsic functions from
9839	the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9840	F_C_STRING. */
9841
9842	static void
9843	conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9844	{
9845	gfc_actual_arglist *arg = expr->value.function.actual;
9846
9847	if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9848	{
9849	if (arg->expr->rank == 0)
9850	gfc_conv_expr_reference (se, expr: arg->expr);
9851	else if (gfc_is_simply_contiguous (arg->expr, false, false))
9852	gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9853	else
9854	{
9855	gfc_conv_expr_descriptor (se, arg->expr);
9856	se->expr = gfc_conv_descriptor_data_get (se->expr);
9857	}
9858
9859	/* TODO -- the following two lines shouldn't be necessary, but if
9860	they're removed, a bug is exposed later in the code path.
9861	This workaround was thus introduced, but will have to be
9862	removed; please see PR 35150 for details about the issue. */
9863	se->expr = convert (pvoid_type_node, se->expr);
9864	se->expr = gfc_evaluate_now (se->expr, &se->pre);
9865	}
9866	else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9867	{
9868	gfc_conv_expr_reference (se, expr: arg->expr);
9869	/* The code below is necessary to create a reference from the calling
9870	subprogram to the argument of C_FUNLOC() in the call graph.
9871	Please see PR 117303 for more details. */
9872	se->expr = convert (pvoid_type_node, se->expr);
9873	se->expr = gfc_evaluate_now (se->expr, &se->pre);
9874	}
9875	else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9876	{
9877	gfc_se arg1se;
9878	gfc_se arg2se;
9879
9880	/* Build the addr_expr for the first argument. The argument is
9881	already an *address* so we don't need to set want_pointer in
9882	the gfc_se. */
9883	gfc_init_se (&arg1se, NULL);
9884	gfc_conv_expr (se: &arg1se, expr: arg->expr);
9885	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9886	gfc_add_block_to_block (&se->post, &arg1se.post);
9887
9888	/* See if we were given two arguments. */
9889	if (arg->next->expr == NULL)
9890	/* Only given one arg so generate a null and do a
9891	not-equal comparison against the first arg. */
9892	se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9893	arg1se.expr,
9894	fold_convert (TREE_TYPE (arg1se.expr),
9895	null_pointer_node));
9896	else
9897	{
9898	tree eq_expr;
9899	tree not_null_expr;
9900
9901	/* Given two arguments so build the arg2se from second arg. */
9902	gfc_init_se (&arg2se, NULL);
9903	gfc_conv_expr (se: &arg2se, expr: arg->next->expr);
9904	gfc_add_block_to_block (&se->pre, &arg2se.pre);
9905	gfc_add_block_to_block (&se->post, &arg2se.post);
9906
9907	/* Generate test to compare that the two args are equal. */
9908	eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9909	arg1se.expr, arg2se.expr);
9910	/* Generate test to ensure that the first arg is not null. */
9911	not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9912	logical_type_node,
9913	arg1se.expr, null_pointer_node);
9914
9915	/* Finally, the generated test must check that both arg1 is not
9916	NULL and that it is equal to the second arg. */
9917	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9918	logical_type_node,
9919	not_null_expr, eq_expr);
9920	}
9921	}
9922	else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9923	{
9924	/* There are three cases:
9925	f_c_string(string) -> trim(string) // c_null_char
9926	f_c_string(string, .false.) -> trim(string) // c_null_char
9927	f_c_string(string, .true.) -> string // c_null_char */
9928
9929	gfc_se lse, rse, tse;
9930	tree len, tmp, var;
9931	gfc_expr *string = arg->expr;
9932	gfc_expr *asis = arg->next->expr;
9933	gfc_expr *cnc;
9934
9935	/* Convert string. */
9936	gfc_init_se (&lse, se);
9937	gfc_conv_expr (se: &lse, expr: string);
9938	gfc_conv_string_parameter (se: &lse);
9939
9940	/* Create a string for C_NULL_CHAR and convert it. */
9941	cnc = gfc_get_character_expr (gfc_default_character_kind,
9942	&string->where, "\0", len: 1);
9943	gfc_init_se (&rse, se);
9944	gfc_conv_expr (se: &rse, expr: cnc);
9945	gfc_conv_string_parameter (se: &rse);
9946	gfc_free_expr (cnc);
9947
9948	#ifdef cnode
9949	#undef cnode
9950	#endif
9951	#define cnode gfc_charlen_type_node
9952	if (asis)
9953	{
9954	stmtblock_t block;
9955	gfc_se asis_se, vse;
9956	tree elen, evar, tlen, tvar;
9957	tree else_branch, then_branch;
9958
9959	elen = evar = tlen = tvar = NULL_TREE;
9960
9961	/* f_c_string(string, .true.) -> string // c_null_char */
9962
9963	gfc_init_block (&block);
9964
9965	gfc_add_block_to_block (&block, &lse.pre);
9966	gfc_add_block_to_block (&block, &rse.pre);
9967
9968	tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
9969	fold_convert (cnode, lse.string_length),
9970	fold_convert (cnode, rse.string_length));
9971
9972	gfc_init_se (&vse, se);
9973	tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen);
9974	gfc_add_block_to_block (&block, &vse.pre);
9975
9976	tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
9977	6, tlen, tvar,
9978	lse.string_length, lse.expr,
9979	rse.string_length, rse.expr);
9980	gfc_add_expr_to_block (&block, tmp);
9981
9982	then_branch = gfc_finish_block (&block);
9983
9984	/* f_c_string(string, .false.) = trim(string) // c_null_char */
9985
9986	gfc_init_block (&block);
9987
9988	gfc_init_se (&tse, se);
9989	conv_trim (tse: &tse, str: &lse);
9990	gfc_add_block_to_block (&block, &tse.pre);
9991	gfc_add_block_to_block (&block, &rse.pre);
9992
9993	elen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
9994	fold_convert (cnode, tse.string_length),
9995	fold_convert (cnode, rse.string_length));
9996
9997	gfc_init_se (&vse, se);
9998	evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen);
9999	gfc_add_block_to_block (&block, &vse.pre);
10000
10001	tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10002	6, elen, evar,
10003	tse.string_length, tse.expr,
10004	rse.string_length, rse.expr);
10005	gfc_add_expr_to_block (&block, tmp);
10006
10007	else_branch = gfc_finish_block (&block);
10008
10009	gfc_init_se (&asis_se, se);
10010	gfc_conv_expr (se: &asis_se, expr: asis);
10011	if (asis->expr_type == EXPR_VARIABLE
10012	&& asis->symtree->n.sym->attr.dummy
10013	&& asis->symtree->n.sym->attr.optional)
10014	{
10015	tree present = gfc_conv_expr_present (asis->symtree->n.sym);
10016	asis_se.expr = build3_loc (loc: input_location, code: COND_EXPR,
10017	type: logical_type_node, arg0: present,
10018	arg1: asis_se.expr,
10019	arg2: build_int_cst (logical_type_node, 0));
10020	}
10021	gfc_add_block_to_block (&se->pre, &asis_se.pre);
10022	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10023	asis_se.expr, then_branch, else_branch);
10024
10025	gfc_add_expr_to_block (&se->pre, tmp);
10026
10027	var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node,
10028	asis_se.expr, tvar, evar);
10029	gfc_add_expr_to_block (&se->pre, var);
10030
10031	len = fold_build3_loc (input_location, COND_EXPR, cnode,
10032	asis_se.expr, tlen, elen);
10033	gfc_add_expr_to_block (&se->pre, len);
10034	}
10035	else
10036	{
10037	/* f_c_string(string) = trim(string) // c_null_char */
10038
10039	gfc_add_block_to_block (&se->pre, &lse.pre);
10040	gfc_add_block_to_block (&se->pre, &rse.pre);
10041
10042	gfc_init_se (&tse, se);
10043	conv_trim (tse: &tse, str: &lse);
10044	gfc_add_block_to_block (&se->pre, &tse.pre);
10045	gfc_add_block_to_block (&se->post, &tse.post);
10046
10047	len = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10048	fold_convert (cnode, tse.string_length),
10049	fold_convert (cnode, rse.string_length));
10050
10051	var = gfc_conv_string_tmp (se, pchar_type_node, len);
10052
10053	tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10054	6, len, var,
10055	tse.string_length, tse.expr,
10056	rse.string_length, rse.expr);
10057	gfc_add_expr_to_block (&se->pre, tmp);
10058	}
10059
10060	se->expr = var;
10061	se->string_length = len;
10062
10063	#undef cnode
10064	}
10065	else
10066	gcc_unreachable ();
10067	}
10068
10069
10070	/* The following routine generates code for the intrinsic
10071	subroutines from the ISO_C_BINDING module:
10072	* C_F_POINTER
10073	* C_F_PROCPOINTER. */
10074
10075	static tree
10076	conv_isocbinding_subroutine (gfc_code *code)
10077	{
10078	gfc_expr *cptr, *fptr, *shape, *lower;
10079	gfc_se se, cptrse, fptrse, shapese, lowerse;
10080	gfc_ss *shape_ss, *lower_ss;
10081	tree desc, dim, tmp, stride, offset, lbound, ubound;
10082	stmtblock_t body, block;
10083	gfc_loopinfo loop;
10084	gfc_actual_arglist *arg;
10085
10086	arg = code->ext.actual;
10087	cptr = arg->expr;
10088	fptr = arg->next->expr;
10089	shape = arg->next->next ? arg->next->next->expr : NULL;
10090	lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10091
10092	gfc_init_se (&se, NULL);
10093	gfc_init_se (&cptrse, NULL);
10094	gfc_conv_expr (se: &cptrse, expr: cptr);
10095	gfc_add_block_to_block (&se.pre, &cptrse.pre);
10096	gfc_add_block_to_block (&se.post, &cptrse.post);
10097
10098	gfc_init_se (&fptrse, NULL);
10099	if (fptr->rank == 0)
10100	{
10101	fptrse.want_pointer = 1;
10102	gfc_conv_expr (se: &fptrse, expr: fptr);
10103	gfc_add_block_to_block (&se.pre, &fptrse.pre);
10104	gfc_add_block_to_block (&se.post, &fptrse.post);
10105	if (fptr->symtree->n.sym->attr.proc_pointer
10106	&& fptr->symtree->n.sym->attr.dummy)
10107	fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10108	se.expr
10109	= fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10110	fptrse.expr,
10111	fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10112	gfc_add_expr_to_block (&se.pre, se.expr);
10113	gfc_add_block_to_block (&se.pre, &se.post);
10114	return gfc_finish_block (&se.pre);
10115	}
10116
10117	gfc_start_block (&block);
10118
10119	/* Get the descriptor of the Fortran pointer. */
10120	fptrse.descriptor_only = 1;
10121	gfc_conv_expr_descriptor (&fptrse, fptr);
10122	gfc_add_block_to_block (&block, &fptrse.pre);
10123	desc = fptrse.expr;
10124
10125	/* Set the span field. */
10126	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10127	tmp = fold_convert (gfc_array_index_type, tmp);
10128	gfc_conv_descriptor_span_set (&block, desc, tmp);
10129
10130	/* Set data value, dtype, and offset. */
10131	tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10132	gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10133	gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10134	gfc_get_dtype (TREE_TYPE (desc)));
10135
10136	/* Start scalarization of the bounds, using the shape argument. */
10137
10138	shape_ss = gfc_walk_expr (shape);
10139	gcc_assert (shape_ss != gfc_ss_terminator);
10140	gfc_init_se (&shapese, NULL);
10141	if (lower)
10142	{
10143	lower_ss = gfc_walk_expr (lower);
10144	gcc_assert (lower_ss != gfc_ss_terminator);
10145	gfc_init_se (&lowerse, NULL);
10146	}
10147
10148	gfc_init_loopinfo (&loop);
10149	gfc_add_ss_to_loop (&loop, shape_ss);
10150	if (lower)
10151	gfc_add_ss_to_loop (&loop, lower_ss);
10152	gfc_conv_ss_startstride (&loop);
10153	gfc_conv_loop_setup (&loop, &fptr->where);
10154	gfc_mark_ss_chain_used (shape_ss, 1);
10155	if (lower)
10156	gfc_mark_ss_chain_used (lower_ss, 1);
10157
10158	gfc_copy_loopinfo_to_se (&shapese, &loop);
10159	shapese.ss = shape_ss;
10160	if (lower)
10161	{
10162	gfc_copy_loopinfo_to_se (&lowerse, &loop);
10163	lowerse.ss = lower_ss;
10164	}
10165
10166	stride = gfc_create_var (gfc_array_index_type, "stride");
10167	offset = gfc_create_var (gfc_array_index_type, "offset");
10168	gfc_add_modify (&block, stride, gfc_index_one_node);
10169	gfc_add_modify (&block, offset, gfc_index_zero_node);
10170
10171	/* Loop body. */
10172	gfc_start_scalarized_body (&loop, &body);
10173
10174	dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10175	loop.loopvar[0], loop.from[0]);
10176
10177	if (lower)
10178	{
10179	gfc_conv_expr (se: &lowerse, expr: lower);
10180	gfc_add_block_to_block (&body, &lowerse.pre);
10181	lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10182	gfc_add_block_to_block (&body, &lowerse.post);
10183	}
10184	else
10185	lbound = gfc_index_one_node;
10186
10187	/* Set bounds and stride. */
10188	gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10189	gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10190
10191	gfc_conv_expr (se: &shapese, expr: shape);
10192	gfc_add_block_to_block (&body, &shapese.pre);
10193	ubound = fold_build2_loc (
10194	input_location, MINUS_EXPR, gfc_array_index_type,
10195	fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10196	fold_convert (gfc_array_index_type, shapese.expr)),
10197	gfc_index_one_node);
10198	gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10199	gfc_add_block_to_block (&body, &shapese.post);
10200
10201	/* Calculate offset. */
10202	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10203	stride, lbound);
10204	gfc_add_modify (&body, offset,
10205	fold_build2_loc (input_location, PLUS_EXPR,
10206	gfc_array_index_type, offset, tmp));
10207
10208	/* Update stride. */
10209	gfc_add_modify (
10210	&body, stride,
10211	fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10212	fold_convert (gfc_array_index_type, shapese.expr)));
10213	/* Finish scalarization loop. */
10214	gfc_trans_scalarizing_loops (&loop, &body);
10215	gfc_add_block_to_block (&block, &loop.pre);
10216	gfc_add_block_to_block (&block, &loop.post);
10217	gfc_add_block_to_block (&block, &fptrse.post);
10218	gfc_cleanup_loop (&loop);
10219
10220	gfc_add_modify (&block, offset,
10221	fold_build1_loc (input_location, NEGATE_EXPR,
10222	gfc_array_index_type, offset));
10223	gfc_conv_descriptor_offset_set (&block, desc, offset);
10224
10225	gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10226	gfc_add_block_to_block (&se.pre, &se.post);
10227	return gfc_finish_block (&se.pre);
10228	}
10229
10230
10231	/* Save and restore floating-point state. */
10232
10233	tree
10234	gfc_save_fp_state (stmtblock_t *block)
10235	{
10236	tree type, fpstate, tmp;
10237
10238	type = build_array_type (char_type_node,
10239	build_range_type (size_type_node, size_zero_node,
10240	size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10241	fpstate = gfc_create_var (type, "fpstate");
10242	fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10243
10244	tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10245	1, fpstate);
10246	gfc_add_expr_to_block (block, tmp);
10247
10248	return fpstate;
10249	}
10250
10251
10252	void
10253	gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10254	{
10255	tree tmp;
10256
10257	tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10258	1, fpstate);
10259	gfc_add_expr_to_block (block, tmp);
10260	}
10261
10262
10263	/* Generate code for arguments of IEEE functions. */
10264
10265	static void
10266	conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10267	int nargs)
10268	{
10269	gfc_actual_arglist *actual;
10270	gfc_expr *e;
10271	gfc_se argse;
10272	int arg;
10273
10274	actual = expr->value.function.actual;
10275	for (arg = 0; arg < nargs; arg++, actual = actual->next)
10276	{
10277	gcc_assert (actual);
10278	e = actual->expr;
10279
10280	gfc_init_se (&argse, se);
10281	gfc_conv_expr_val (se: &argse, expr: e);
10282
10283	gfc_add_block_to_block (&se->pre, &argse.pre);
10284	gfc_add_block_to_block (&se->post, &argse.post);
10285	argarray[arg] = argse.expr;
10286	}
10287	}
10288
10289
10290	/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10291	and IEEE_UNORDERED, which translate directly to GCC type-generic
10292	built-ins. */
10293
10294	static void
10295	conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10296	enum built_in_function code, int nargs)
10297	{
10298	tree args[2];
10299	gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10300
10301	conv_ieee_function_args (se, expr, argarray: args, nargs);
10302	se->expr = build_call_expr_loc_array (input_location,
10303	builtin_decl_explicit (fncode: code),
10304	nargs, args);
10305	STRIP_TYPE_NOPS (se->expr);
10306	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10307	}
10308
10309
10310	/* Generate code for intrinsics IEEE_SIGNBIT. */
10311
10312	static void
10313	conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10314	{
10315	tree arg, signbit;
10316
10317	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
10318	signbit = build_call_expr_loc (input_location,
10319	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT),
10320	1, arg);
10321	signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10322	signbit, integer_zero_node);
10323	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10324	}
10325
10326
10327	/* Generate code for IEEE_IS_NORMAL intrinsic:
10328	IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10329
10330	static void
10331	conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10332	{
10333	tree arg, isnormal, iszero;
10334
10335	/* Convert arg, evaluate it only once. */
10336	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
10337	arg = gfc_evaluate_now (arg, &se->pre);
10338
10339	isnormal = build_call_expr_loc (input_location,
10340	builtin_decl_explicit (fncode: BUILT_IN_ISNORMAL),
10341	1, arg);
10342	iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10343	build_real_from_int_cst (TREE_TYPE (arg),
10344	integer_zero_node));
10345	se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10346	logical_type_node, isnormal, iszero);
10347	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10348	}
10349
10350
10351	/* Generate code for IEEE_IS_NEGATIVE intrinsic:
10352	IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10353
10354	static void
10355	conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10356	{
10357	tree arg, signbit, isnan;
10358
10359	/* Convert arg, evaluate it only once. */
10360	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
10361	arg = gfc_evaluate_now (arg, &se->pre);
10362
10363	isnan = build_call_expr_loc (input_location,
10364	builtin_decl_explicit (fncode: BUILT_IN_ISNAN),
10365	1, arg);
10366	STRIP_TYPE_NOPS (isnan);
10367
10368	signbit = build_call_expr_loc (input_location,
10369	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT),
10370	1, arg);
10371	signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10372	signbit, integer_zero_node);
10373
10374	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10375	logical_type_node, signbit,
10376	fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10377	TREE_TYPE(isnan), isnan));
10378
10379	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10380	}
10381
10382
10383	/* Generate code for IEEE_LOGB and IEEE_RINT. */
10384
10385	static void
10386	conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10387	enum built_in_function code)
10388	{
10389	tree arg, decl, call, fpstate;
10390	int argprec;
10391
10392	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
10393	argprec = TYPE_PRECISION (TREE_TYPE (arg));
10394	decl = builtin_decl_for_precision (base_built_in: code, precision: argprec);
10395
10396	/* Save floating-point state. */
10397	fpstate = gfc_save_fp_state (block: &se->pre);
10398
10399	/* Make the function call. */
10400	call = build_call_expr_loc (input_location, decl, 1, arg);
10401	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10402
10403	/* Restore floating-point state. */
10404	gfc_restore_fp_state (block: &se->post, fpstate);
10405	}
10406
10407
10408	/* Generate code for IEEE_REM. */
10409
10410	static void
10411	conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10412	{
10413	tree args[2], decl, call, fpstate;
10414	int argprec;
10415
10416	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10417
10418	/* If arguments have unequal size, convert them to the larger. */
10419	if (TYPE_PRECISION (TREE_TYPE (args[0]))
10420	> TYPE_PRECISION (TREE_TYPE (args[1])))
10421	args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10422	else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10423	> TYPE_PRECISION (TREE_TYPE (args[0])))
10424	args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10425
10426	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10427	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_REMAINDER, precision: argprec);
10428
10429	/* Save floating-point state. */
10430	fpstate = gfc_save_fp_state (block: &se->pre);
10431
10432	/* Make the function call. */
10433	call = build_call_expr_loc_array (input_location, decl, 2, args);
10434	se->expr = fold_convert (TREE_TYPE (args[0]), call);
10435
10436	/* Restore floating-point state. */
10437	gfc_restore_fp_state (block: &se->post, fpstate);
10438	}
10439
10440
10441	/* Generate code for IEEE_NEXT_AFTER. */
10442
10443	static void
10444	conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10445	{
10446	tree args[2], decl, call, fpstate;
10447	int argprec;
10448
10449	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10450
10451	/* Result has the characteristics of first argument. */
10452	args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10453	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10454	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_NEXTAFTER, precision: argprec);
10455
10456	/* Save floating-point state. */
10457	fpstate = gfc_save_fp_state (block: &se->pre);
10458
10459	/* Make the function call. */
10460	call = build_call_expr_loc_array (input_location, decl, 2, args);
10461	se->expr = fold_convert (TREE_TYPE (args[0]), call);
10462
10463	/* Restore floating-point state. */
10464	gfc_restore_fp_state (block: &se->post, fpstate);
10465	}
10466
10467
10468	/* Generate code for IEEE_SCALB. */
10469
10470	static void
10471	conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10472	{
10473	tree args[2], decl, call, huge, type;
10474	int argprec, n;
10475
10476	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10477
10478	/* Result has the characteristics of first argument. */
10479	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10480	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_SCALBN, precision: argprec);
10481
10482	if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10483	{
10484	/* We need to fold the integer into the range of a C int. */
10485	args[1] = gfc_evaluate_now (args[1], &se->pre);
10486	type = TREE_TYPE (args[1]);
10487
10488	n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10489	huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10490	gfc_c_int_kind);
10491	huge = fold_convert (type, huge);
10492	args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10493	huge);
10494	args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10495	fold_build1_loc (input_location, NEGATE_EXPR,
10496	type, huge));
10497	}
10498
10499	args[1] = fold_convert (integer_type_node, args[1]);
10500
10501	/* Make the function call. */
10502	call = build_call_expr_loc_array (input_location, decl, 2, args);
10503	se->expr = fold_convert (TREE_TYPE (args[0]), call);
10504	}
10505
10506
10507	/* Generate code for IEEE_COPY_SIGN. */
10508
10509	static void
10510	conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10511	{
10512	tree args[2], decl, sign;
10513	int argprec;
10514
10515	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10516
10517	/* Get the sign of the second argument. */
10518	sign = build_call_expr_loc (input_location,
10519	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT),
10520	1, args[1]);
10521	sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10522	sign, integer_zero_node);
10523
10524	/* Create a value of one, with the right sign. */
10525	sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10526	sign,
10527	fold_build1_loc (input_location, NEGATE_EXPR,
10528	integer_type_node,
10529	integer_one_node),
10530	integer_one_node);
10531	args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10532
10533	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10534	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_COPYSIGN, precision: argprec);
10535
10536	se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10537	}
10538
10539
10540	/* Generate code for IEEE_CLASS. */
10541
10542	static void
10543	conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10544	{
10545	tree arg, c, t1, t2, t3, t4;
10546
10547	/* Convert arg, evaluate it only once. */
10548	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
10549	arg = gfc_evaluate_now (arg, &se->pre);
10550
10551	c = build_call_expr_loc (input_location,
10552	builtin_decl_explicit (fncode: BUILT_IN_FPCLASSIFY), 6,
10553	build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10554	build_int_cst (integer_type_node,
10555	IEEE_POSITIVE_INF),
10556	build_int_cst (integer_type_node,
10557	IEEE_POSITIVE_NORMAL),
10558	build_int_cst (integer_type_node,
10559	IEEE_POSITIVE_DENORMAL),
10560	build_int_cst (integer_type_node,
10561	IEEE_POSITIVE_ZERO),
10562	arg);
10563	c = gfc_evaluate_now (c, &se->pre);
10564	t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10565	c, build_int_cst (integer_type_node,
10566	IEEE_QUIET_NAN));
10567	t2 = build_call_expr_loc (input_location,
10568	builtin_decl_explicit (fncode: BUILT_IN_ISSIGNALING), 1,
10569	arg);
10570	t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10571	t2, build_zero_cst (TREE_TYPE (t2)));
10572	t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10573	logical_type_node, t1, t2);
10574	t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10575	c, build_int_cst (integer_type_node,
10576	IEEE_POSITIVE_ZERO));
10577	t4 = build_call_expr_loc (input_location,
10578	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT), 1,
10579	arg);
10580	t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10581	t4, build_zero_cst (TREE_TYPE (t4)));
10582	t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10583	logical_type_node, t3, t4);
10584	int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10585	gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10586	gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10587	gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10588	gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10589	gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10590	t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10591	build_int_cst (TREE_TYPE (c), s), c);
10592	t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10593	t3, t4, c);
10594	t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10595	build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10596	t3);
10597	tree type = gfc_typenode_for_spec (&expr->ts);
10598	/* Perform a quick sanity check that the return type is
10599	IEEE_CLASS_TYPE derived type defined in
10600	libgfortran/ieee/ieee_arithmetic.F90
10601	Primarily check that it is a derived type with a single
10602	member in it. */
10603	gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10604	tree field = NULL_TREE;
10605	for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10606	if (TREE_CODE (f) == FIELD_DECL)
10607	{
10608	gcc_assert (field == NULL_TREE);
10609	field = f;
10610	}
10611	gcc_assert (field);
10612	t1 = fold_convert (TREE_TYPE (field), t1);
10613	se->expr = build_constructor_single (type, field, t1);
10614	}
10615
10616
10617	/* Generate code for IEEE_VALUE. */
10618
10619	static void
10620	conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10621	{
10622	tree args[2], arg, ret, tmp;
10623	stmtblock_t body;
10624
10625	/* Convert args, evaluate the second one only once. */
10626	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10627	arg = gfc_evaluate_now (args[1], &se->pre);
10628
10629	tree type = TREE_TYPE (arg);
10630	/* Perform a quick sanity check that the second argument's type is
10631	IEEE_CLASS_TYPE derived type defined in
10632	libgfortran/ieee/ieee_arithmetic.F90
10633	Primarily check that it is a derived type with a single
10634	member in it. */
10635	gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10636	tree field = NULL_TREE;
10637	for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10638	if (TREE_CODE (f) == FIELD_DECL)
10639	{
10640	gcc_assert (field == NULL_TREE);
10641	field = f;
10642	}
10643	gcc_assert (field);
10644	arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10645	arg, field, NULL_TREE);
10646	arg = gfc_evaluate_now (arg, &se->pre);
10647
10648	type = gfc_typenode_for_spec (&expr->ts);
10649	gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10650	ret = gfc_create_var (type, NULL);
10651
10652	gfc_init_block (&body);
10653
10654	tree end_label = gfc_build_label_decl (NULL_TREE);
10655	for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10656	{
10657	tree label = gfc_build_label_decl (NULL_TREE);
10658	tree low = build_int_cst (TREE_TYPE (arg), c);
10659	tmp = build_case_label (low, low, label);
10660	gfc_add_expr_to_block (&body, tmp);
10661
10662	REAL_VALUE_TYPE real;
10663	int k;
10664	switch (c)
10665	{
10666	case IEEE_SIGNALING_NAN:
10667	real_nan (&real, "", 0, TYPE_MODE (type));
10668	break;
10669	case IEEE_QUIET_NAN:
10670	real_nan (&real, "", 1, TYPE_MODE (type));
10671	break;
10672	case IEEE_NEGATIVE_INF:
10673	real_inf (&real);
10674	real = real_value_negate (&real);
10675	break;
10676	case IEEE_NEGATIVE_NORMAL:
10677	real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10678	break;
10679	case IEEE_NEGATIVE_DENORMAL:
10680	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10681	real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10682	type, GFC_RND_MODE);
10683	real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10684	real = real_value_negate (&real);
10685	break;
10686	case IEEE_NEGATIVE_ZERO:
10687	real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10688	real = real_value_negate (&real);
10689	break;
10690	case IEEE_POSITIVE_ZERO:
10691	/* Make this also the default: label. The other possibility
10692	would be to add a separate default: label followed by
10693	__builtin_unreachable (). */
10694	label = gfc_build_label_decl (NULL_TREE);
10695	tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10696	gfc_add_expr_to_block (&body, tmp);
10697	real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10698	break;
10699	case IEEE_POSITIVE_DENORMAL:
10700	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10701	real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10702	type, GFC_RND_MODE);
10703	real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10704	break;
10705	case IEEE_POSITIVE_NORMAL:
10706	real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10707	break;
10708	case IEEE_POSITIVE_INF:
10709	real_inf (&real);
10710	break;
10711	default:
10712	gcc_unreachable ();
10713	}
10714
10715	tree val = build_real (type, real);
10716	gfc_add_modify (&body, ret, val);
10717
10718	tmp = build1_v (GOTO_EXPR, end_label);
10719	gfc_add_expr_to_block (&body, tmp);
10720	}
10721
10722	tmp = gfc_finish_block (&body);
10723	tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10724	gfc_add_expr_to_block (&se->pre, tmp);
10725
10726	tmp = build1_v (LABEL_EXPR, end_label);
10727	gfc_add_expr_to_block (&se->pre, tmp);
10728
10729	se->expr = ret;
10730	}
10731
10732
10733	/* Generate code for IEEE_FMA. */
10734
10735	static void
10736	conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10737	{
10738	tree args[3], decl, call;
10739	int argprec;
10740
10741	conv_ieee_function_args (se, expr, argarray: args, nargs: 3);
10742
10743	/* All three arguments should have the same type. */
10744	gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10745	gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10746
10747	/* Call the type-generic FMA built-in. */
10748	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10749	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_FMA, precision: argprec);
10750	call = build_call_expr_loc_array (input_location, decl, 3, args);
10751
10752	/* Convert to the final type. */
10753	se->expr = fold_convert (TREE_TYPE (args[0]), call);
10754	}
10755
10756
10757	/* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10758
10759	static void
10760	conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10761	const char *name)
10762	{
10763	tree args[2], func;
10764	built_in_function fn;
10765
10766	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10767	gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10768	args[0] = gfc_evaluate_now (args[0], &se->pre);
10769	args[1] = gfc_evaluate_now (args[1], &se->pre);
10770
10771	if (startswith (str: name, prefix: "mag"))
10772	{
10773	/* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10774	fminmag() and fmaxmag(), which do not exist as built-ins.
10775
10776	Following glibc, we emit this:
10777
10778	fminmag (x, y) {
10779	ax = ABS (x);
10780	ay = ABS (y);
10781	if (isless (ax, ay))
10782	return x;
10783	else if (isgreater (ax, ay))
10784	return y;
10785	else if (ax == ay)
10786	return x < y ? x : y;
10787	else if (issignaling (x) || issignaling (y))
10788	return x + y;
10789	else
10790	return isnan (y) ? x : y;
10791	}
10792
10793	fmaxmag (x, y) {
10794	ax = ABS (x);
10795	ay = ABS (y);
10796	if (isgreater (ax, ay))
10797	return x;
10798	else if (isless (ax, ay))
10799	return y;
10800	else if (ax == ay)
10801	return x > y ? x : y;
10802	else if (issignaling (x) || issignaling (y))
10803	return x + y;
10804	else
10805	return isnan (y) ? x : y;
10806	}
10807
10808	*/
10809
10810	tree abs0, abs1, sig0, sig1;
10811	tree cond1, cond2, cond3, cond4, cond5;
10812	tree res;
10813	tree type = TREE_TYPE (args[0]);
10814
10815	func = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FABS, kind: expr->ts.kind);
10816	abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10817	abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10818	abs0 = gfc_evaluate_now (abs0, &se->pre);
10819	abs1 = gfc_evaluate_now (abs1, &se->pre);
10820
10821	cond5 = build_call_expr_loc (input_location,
10822	builtin_decl_explicit (fncode: BUILT_IN_ISNAN),
10823	1, args[1]);
10824	res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10825	args[0], args[1]);
10826
10827	sig0 = build_call_expr_loc (input_location,
10828	builtin_decl_explicit (fncode: BUILT_IN_ISSIGNALING),
10829	1, args[0]);
10830	sig1 = build_call_expr_loc (input_location,
10831	builtin_decl_explicit (fncode: BUILT_IN_ISSIGNALING),
10832	1, args[1]);
10833	cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
10834	logical_type_node, sig0, sig1);
10835	res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
10836	fold_build2_loc (input_location, PLUS_EXPR,
10837	type, args[0], args[1]),
10838	res);
10839
10840	cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10841	abs0, abs1);
10842	res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
10843	fold_build2_loc (input_location,
10844	max ? MAX_EXPR : MIN_EXPR,
10845	type, args[0], args[1]),
10846	res);
10847
10848	func = builtin_decl_explicit (fncode: max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
10849	cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10850	res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
10851	args[1], res);
10852
10853	func = builtin_decl_explicit (fncode: max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
10854	cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10855	res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
10856	args[0], res);
10857
10858	se->expr = res;
10859	}
10860	else
10861	{
10862	/* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10863	fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
10864	func = gfc_builtin_decl_for_float_kind (double_built_in: fn, kind: expr->ts.kind);
10865	se->expr = build_call_expr_loc_array (input_location, func, 2, args);
10866	}
10867	}
10868
10869
10870	/* Generate code for comparison functions IEEE_QUIET_* and
10871	IEEE_SIGNALING_*. */
10872
10873	static void
10874	conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
10875	const char *name)
10876	{
10877	tree args[2];
10878	tree arg1, arg2, res;
10879
10880	/* Evaluate arguments only once. */
10881	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10882	arg1 = gfc_evaluate_now (args[0], &se->pre);
10883	arg2 = gfc_evaluate_now (args[1], &se->pre);
10884
10885	if (startswith (str: name, prefix: "eq"))
10886	{
10887	if (signaling)
10888	res = build_call_expr_loc (input_location,
10889	builtin_decl_explicit (fncode: BUILT_IN_ISEQSIG),
10890	2, arg1, arg2);
10891	else
10892	res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10893	arg1, arg2);
10894	}
10895	else if (startswith (str: name, prefix: "ne"))
10896	{
10897	if (signaling)
10898	{
10899	res = build_call_expr_loc (input_location,
10900	builtin_decl_explicit (fncode: BUILT_IN_ISEQSIG),
10901	2, arg1, arg2);
10902	res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10903	logical_type_node, res);
10904	}
10905	else
10906	res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10907	arg1, arg2);
10908	}
10909	else if (startswith (str: name, prefix: "ge"))
10910	{
10911	if (signaling)
10912	res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10913	arg1, arg2);
10914	else
10915	res = build_call_expr_loc (input_location,
10916	builtin_decl_explicit (fncode: BUILT_IN_ISGREATEREQUAL),
10917	2, arg1, arg2);
10918	}
10919	else if (startswith (str: name, prefix: "gt"))
10920	{
10921	if (signaling)
10922	res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
10923	arg1, arg2);
10924	else
10925	res = build_call_expr_loc (input_location,
10926	builtin_decl_explicit (fncode: BUILT_IN_ISGREATER),
10927	2, arg1, arg2);
10928	}
10929	else if (startswith (str: name, prefix: "le"))
10930	{
10931	if (signaling)
10932	res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
10933	arg1, arg2);
10934	else
10935	res = build_call_expr_loc (input_location,
10936	builtin_decl_explicit (fncode: BUILT_IN_ISLESSEQUAL),
10937	2, arg1, arg2);
10938	}
10939	else if (startswith (str: name, prefix: "lt"))
10940	{
10941	if (signaling)
10942	res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10943	arg1, arg2);
10944	else
10945	res = build_call_expr_loc (input_location,
10946	builtin_decl_explicit (fncode: BUILT_IN_ISLESS),
10947	2, arg1, arg2);
10948	}
10949	else
10950	gcc_unreachable ();
10951
10952	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
10953	}
10954
10955
10956	/* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10957	module. */
10958
10959	bool
10960	gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10961	{
10962	const char *name = expr->value.function.name;
10963
10964	if (startswith (str: name, prefix: "_gfortran_ieee_is_nan"))
10965	conv_intrinsic_ieee_builtin (se, expr, code: BUILT_IN_ISNAN, nargs: 1);
10966	else if (startswith (str: name, prefix: "_gfortran_ieee_is_finite"))
10967	conv_intrinsic_ieee_builtin (se, expr, code: BUILT_IN_ISFINITE, nargs: 1);
10968	else if (startswith (str: name, prefix: "_gfortran_ieee_unordered"))
10969	conv_intrinsic_ieee_builtin (se, expr, code: BUILT_IN_ISUNORDERED, nargs: 2);
10970	else if (startswith (str: name, prefix: "_gfortran_ieee_signbit"))
10971	conv_intrinsic_ieee_signbit (se, expr);
10972	else if (startswith (str: name, prefix: "_gfortran_ieee_is_normal"))
10973	conv_intrinsic_ieee_is_normal (se, expr);
10974	else if (startswith (str: name, prefix: "_gfortran_ieee_is_negative"))
10975	conv_intrinsic_ieee_is_negative (se, expr);
10976	else if (startswith (str: name, prefix: "_gfortran_ieee_copy_sign"))
10977	conv_intrinsic_ieee_copy_sign (se, expr);
10978	else if (startswith (str: name, prefix: "_gfortran_ieee_scalb"))
10979	conv_intrinsic_ieee_scalb (se, expr);
10980	else if (startswith (str: name, prefix: "_gfortran_ieee_next_after"))
10981	conv_intrinsic_ieee_next_after (se, expr);
10982	else if (startswith (str: name, prefix: "_gfortran_ieee_rem"))
10983	conv_intrinsic_ieee_rem (se, expr);
10984	else if (startswith (str: name, prefix: "_gfortran_ieee_logb"))
10985	conv_intrinsic_ieee_logb_rint (se, expr, code: BUILT_IN_LOGB);
10986	else if (startswith (str: name, prefix: "_gfortran_ieee_rint"))
10987	conv_intrinsic_ieee_logb_rint (se, expr, code: BUILT_IN_RINT);
10988	else if (startswith (str: name, prefix: "ieee_class_") && ISDIGIT (name[11]))
10989	conv_intrinsic_ieee_class (se, expr);
10990	else if (startswith (str: name, prefix: "ieee_value_") && ISDIGIT (name[11]))
10991	conv_intrinsic_ieee_value (se, expr);
10992	else if (startswith (str: name, prefix: "_gfortran_ieee_fma"))
10993	conv_intrinsic_ieee_fma (se, expr);
10994	else if (startswith (str: name, prefix: "_gfortran_ieee_min_num_"))
10995	conv_intrinsic_ieee_minmax (se, expr, max: 0, name: name + 23);
10996	else if (startswith (str: name, prefix: "_gfortran_ieee_max_num_"))
10997	conv_intrinsic_ieee_minmax (se, expr, max: 1, name: name + 23);
10998	else if (startswith (str: name, prefix: "_gfortran_ieee_quiet_"))
10999	conv_intrinsic_ieee_comparison (se, expr, signaling: 0, name: name + 21);
11000	else if (startswith (str: name, prefix: "_gfortran_ieee_signaling_"))
11001	conv_intrinsic_ieee_comparison (se, expr, signaling: 1, name: name + 25);
11002	else
11003	/* It is not among the functions we translate directly. We return
11004	false, so a library function call is emitted. */
11005	return false;
11006
11007	return true;
11008	}
11009
11010
11011	/* Generate a direct call to malloc() for the MALLOC intrinsic. */
11012
11013	static void
11014	gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11015	{
11016	tree arg, res, restype;
11017
11018	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
11019	arg = fold_convert (size_type_node, arg);
11020	res = build_call_expr_loc (input_location,
11021	builtin_decl_explicit (fncode: BUILT_IN_MALLOC), 1, arg);
11022	restype = gfc_typenode_for_spec (&expr->ts);
11023	se->expr = fold_convert (restype, res);
11024	}
11025
11026
11027	/* Generate code for an intrinsic function. Some map directly to library
11028	calls, others get special handling. In some cases the name of the function
11029	used depends on the type specifiers. */
11030
11031	void
11032	gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11033	{
11034	const char *name;
11035	int lib, kind;
11036	tree fndecl;
11037
11038	name = &expr->value.function.name[2];
11039
11040	if (expr->rank > 0)
11041	{
11042	lib = gfc_is_intrinsic_libcall (expr);
11043	if (lib != 0)
11044	{
11045	if (lib == 1)
11046	se->ignore_optional = 1;
11047
11048	switch (expr->value.function.isym->id)
11049	{
11050	case GFC_ISYM_EOSHIFT:
11051	case GFC_ISYM_PACK:
11052	case GFC_ISYM_RESHAPE:
11053	case GFC_ISYM_REDUCE:
11054	/* For all of those the first argument specifies the type and the
11055	third is optional. */
11056	conv_generic_with_optional_char_arg (se, expr, primary: 1, optional: 3);
11057	break;
11058
11059	case GFC_ISYM_FINDLOC:
11060	gfc_conv_intrinsic_findloc (se, expr);
11061	break;
11062
11063	case GFC_ISYM_MINLOC:
11064	gfc_conv_intrinsic_minmaxloc (se, expr, op: LT_EXPR);
11065	break;
11066
11067	case GFC_ISYM_MAXLOC:
11068	gfc_conv_intrinsic_minmaxloc (se, expr, op: GT_EXPR);
11069	break;
11070
11071	default:
11072	gfc_conv_intrinsic_funcall (se, expr);
11073	break;
11074	}
11075
11076	return;
11077	}
11078	}
11079
11080	switch (expr->value.function.isym->id)
11081	{
11082	case GFC_ISYM_NONE:
11083	gcc_unreachable ();
11084
11085	case GFC_ISYM_REPEAT:
11086	gfc_conv_intrinsic_repeat (se, expr);
11087	break;
11088
11089	case GFC_ISYM_TRIM:
11090	gfc_conv_intrinsic_trim (se, expr);
11091	break;
11092
11093	case GFC_ISYM_SC_KIND:
11094	gfc_conv_intrinsic_sc_kind (se, expr);
11095	break;
11096
11097	case GFC_ISYM_SI_KIND:
11098	gfc_conv_intrinsic_si_kind (se, expr);
11099	break;
11100
11101	case GFC_ISYM_SL_KIND:
11102	gfc_conv_intrinsic_sl_kind (se, expr);
11103	break;
11104
11105	case GFC_ISYM_SR_KIND:
11106	gfc_conv_intrinsic_sr_kind (se, expr);
11107	break;
11108
11109	case GFC_ISYM_EXPONENT:
11110	gfc_conv_intrinsic_exponent (se, expr);
11111	break;
11112
11113	case GFC_ISYM_SCAN:
11114	kind = expr->value.function.actual->expr->ts.kind;
11115	if (kind == 1)
11116	fndecl = gfor_fndecl_string_scan;
11117	else if (kind == 4)
11118	fndecl = gfor_fndecl_string_scan_char4;
11119	else
11120	gcc_unreachable ();
11121
11122	gfc_conv_intrinsic_index_scan_verify (se, expr, function: fndecl);
11123	break;
11124
11125	case GFC_ISYM_VERIFY:
11126	kind = expr->value.function.actual->expr->ts.kind;
11127	if (kind == 1)
11128	fndecl = gfor_fndecl_string_verify;
11129	else if (kind == 4)
11130	fndecl = gfor_fndecl_string_verify_char4;
11131	else
11132	gcc_unreachable ();
11133
11134	gfc_conv_intrinsic_index_scan_verify (se, expr, function: fndecl);
11135	break;
11136
11137	case GFC_ISYM_ALLOCATED:
11138	gfc_conv_allocated (se, expr);
11139	break;
11140
11141	case GFC_ISYM_ASSOCIATED:
11142	gfc_conv_associated(se, expr);
11143	break;
11144
11145	case GFC_ISYM_SAME_TYPE_AS:
11146	gfc_conv_same_type_as (se, expr);
11147	break;
11148
11149	case GFC_ISYM_ABS:
11150	gfc_conv_intrinsic_abs (se, expr);
11151	break;
11152
11153	case GFC_ISYM_ADJUSTL:
11154	if (expr->ts.kind == 1)
11155	fndecl = gfor_fndecl_adjustl;
11156	else if (expr->ts.kind == 4)
11157	fndecl = gfor_fndecl_adjustl_char4;
11158	else
11159	gcc_unreachable ();
11160
11161	gfc_conv_intrinsic_adjust (se, expr, fndecl);
11162	break;
11163
11164	case GFC_ISYM_ADJUSTR:
11165	if (expr->ts.kind == 1)
11166	fndecl = gfor_fndecl_adjustr;
11167	else if (expr->ts.kind == 4)
11168	fndecl = gfor_fndecl_adjustr_char4;
11169	else
11170	gcc_unreachable ();
11171
11172	gfc_conv_intrinsic_adjust (se, expr, fndecl);
11173	break;
11174
11175	case GFC_ISYM_AIMAG:
11176	gfc_conv_intrinsic_imagpart (se, expr);
11177	break;
11178
11179	case GFC_ISYM_AINT:
11180	gfc_conv_intrinsic_aint (se, expr, op: RND_TRUNC);
11181	break;
11182
11183	case GFC_ISYM_ALL:
11184	gfc_conv_intrinsic_anyall (se, expr, op: EQ_EXPR);
11185	break;
11186
11187	case GFC_ISYM_ANINT:
11188	gfc_conv_intrinsic_aint (se, expr, op: RND_ROUND);
11189	break;
11190
11191	case GFC_ISYM_AND:
11192	gfc_conv_intrinsic_bitop (se, expr, op: BIT_AND_EXPR);
11193	break;
11194
11195	case GFC_ISYM_ANY:
11196	gfc_conv_intrinsic_anyall (se, expr, op: NE_EXPR);
11197	break;
11198
11199	case GFC_ISYM_ACOSD:
11200	case GFC_ISYM_ASIND:
11201	case GFC_ISYM_ATAND:
11202	gfc_conv_intrinsic_atrigd (se, expr, id: expr->value.function.isym->id);
11203	break;
11204
11205	case GFC_ISYM_COTAN:
11206	gfc_conv_intrinsic_cotan (se, expr);
11207	break;
11208
11209	case GFC_ISYM_COTAND:
11210	gfc_conv_intrinsic_cotand (se, expr);
11211	break;
11212
11213	case GFC_ISYM_ATAN2D:
11214	gfc_conv_intrinsic_atan2d (se, expr);
11215	break;
11216
11217	case GFC_ISYM_BTEST:
11218	gfc_conv_intrinsic_btest (se, expr);
11219	break;
11220
11221	case GFC_ISYM_BGE:
11222	gfc_conv_intrinsic_bitcomp (se, expr, op: GE_EXPR);
11223	break;
11224
11225	case GFC_ISYM_BGT:
11226	gfc_conv_intrinsic_bitcomp (se, expr, op: GT_EXPR);
11227	break;
11228
11229	case GFC_ISYM_BLE:
11230	gfc_conv_intrinsic_bitcomp (se, expr, op: LE_EXPR);
11231	break;
11232
11233	case GFC_ISYM_BLT:
11234	gfc_conv_intrinsic_bitcomp (se, expr, op: LT_EXPR);
11235	break;
11236
11237	case GFC_ISYM_C_ASSOCIATED:
11238	case GFC_ISYM_C_FUNLOC:
11239	case GFC_ISYM_C_LOC:
11240	case GFC_ISYM_F_C_STRING:
11241	conv_isocbinding_function (se, expr);
11242	break;
11243
11244	case GFC_ISYM_ACHAR:
11245	case GFC_ISYM_CHAR:
11246	gfc_conv_intrinsic_char (se, expr);
11247	break;
11248
11249	case GFC_ISYM_CONVERSION:
11250	case GFC_ISYM_DBLE:
11251	case GFC_ISYM_DFLOAT:
11252	case GFC_ISYM_FLOAT:
11253	case GFC_ISYM_LOGICAL:
11254	case GFC_ISYM_REAL:
11255	case GFC_ISYM_REALPART:
11256	case GFC_ISYM_SNGL:
11257	gfc_conv_intrinsic_conversion (se, expr);
11258	break;
11259
11260	/* Integer conversions are handled separately to make sure we get the
11261	correct rounding mode. */
11262	case GFC_ISYM_INT:
11263	case GFC_ISYM_INT2:
11264	case GFC_ISYM_INT8:
11265	case GFC_ISYM_LONG:
11266	case GFC_ISYM_UINT:
11267	gfc_conv_intrinsic_int (se, expr, op: RND_TRUNC);
11268	break;
11269
11270	case GFC_ISYM_NINT:
11271	gfc_conv_intrinsic_int (se, expr, op: RND_ROUND);
11272	break;
11273
11274	case GFC_ISYM_CEILING:
11275	gfc_conv_intrinsic_int (se, expr, op: RND_CEIL);
11276	break;
11277
11278	case GFC_ISYM_FLOOR:
11279	gfc_conv_intrinsic_int (se, expr, op: RND_FLOOR);
11280	break;
11281
11282	case GFC_ISYM_MOD:
11283	gfc_conv_intrinsic_mod (se, expr, modulo: 0);
11284	break;
11285
11286	case GFC_ISYM_MODULO:
11287	gfc_conv_intrinsic_mod (se, expr, modulo: 1);
11288	break;
11289
11290	case GFC_ISYM_CAF_GET:
11291	gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, may_realloc: false, NULL);
11292	break;
11293
11294	case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11295	gfc_conv_intrinsic_caf_is_present_remote (se, e: expr);
11296	break;
11297
11298	case GFC_ISYM_CMPLX:
11299	gfc_conv_intrinsic_cmplx (se, expr, both: name[5] == '1');
11300	break;
11301
11302	case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11303	gfc_conv_intrinsic_iargc (se, expr);
11304	break;
11305
11306	case GFC_ISYM_COMPLEX:
11307	gfc_conv_intrinsic_cmplx (se, expr, both: 1);
11308	break;
11309
11310	case GFC_ISYM_CONJG:
11311	gfc_conv_intrinsic_conjg (se, expr);
11312	break;
11313
11314	case GFC_ISYM_COUNT:
11315	gfc_conv_intrinsic_count (se, expr);
11316	break;
11317
11318	case GFC_ISYM_CTIME:
11319	gfc_conv_intrinsic_ctime (se, expr);
11320	break;
11321
11322	case GFC_ISYM_DIM:
11323	gfc_conv_intrinsic_dim (se, expr);
11324	break;
11325
11326	case GFC_ISYM_DOT_PRODUCT:
11327	gfc_conv_intrinsic_dot_product (se, expr);
11328	break;
11329
11330	case GFC_ISYM_DPROD:
11331	gfc_conv_intrinsic_dprod (se, expr);
11332	break;
11333
11334	case GFC_ISYM_DSHIFTL:
11335	gfc_conv_intrinsic_dshift (se, expr, dshiftl: true);
11336	break;
11337
11338	case GFC_ISYM_DSHIFTR:
11339	gfc_conv_intrinsic_dshift (se, expr, dshiftl: false);
11340	break;
11341
11342	case GFC_ISYM_FDATE:
11343	gfc_conv_intrinsic_fdate (se, expr);
11344	break;
11345
11346	case GFC_ISYM_FRACTION:
11347	gfc_conv_intrinsic_fraction (se, expr);
11348	break;
11349
11350	case GFC_ISYM_IALL:
11351	gfc_conv_intrinsic_arith (se, expr, op: BIT_AND_EXPR, norm2: false);
11352	break;
11353
11354	case GFC_ISYM_IAND:
11355	gfc_conv_intrinsic_bitop (se, expr, op: BIT_AND_EXPR);
11356	break;
11357
11358	case GFC_ISYM_IANY:
11359	gfc_conv_intrinsic_arith (se, expr, op: BIT_IOR_EXPR, norm2: false);
11360	break;
11361
11362	case GFC_ISYM_IBCLR:
11363	gfc_conv_intrinsic_singlebitop (se, expr, set: 0);
11364	break;
11365
11366	case GFC_ISYM_IBITS:
11367	gfc_conv_intrinsic_ibits (se, expr);
11368	break;
11369
11370	case GFC_ISYM_IBSET:
11371	gfc_conv_intrinsic_singlebitop (se, expr, set: 1);
11372	break;
11373
11374	case GFC_ISYM_IACHAR:
11375	case GFC_ISYM_ICHAR:
11376	/* We assume ASCII character sequence. */
11377	gfc_conv_intrinsic_ichar (se, expr);
11378	break;
11379
11380	case GFC_ISYM_IARGC:
11381	gfc_conv_intrinsic_iargc (se, expr);
11382	break;
11383
11384	case GFC_ISYM_IEOR:
11385	gfc_conv_intrinsic_bitop (se, expr, op: BIT_XOR_EXPR);
11386	break;
11387
11388	case GFC_ISYM_INDEX:
11389	kind = expr->value.function.actual->expr->ts.kind;
11390	if (kind == 1)
11391	fndecl = gfor_fndecl_string_index;
11392	else if (kind == 4)
11393	fndecl = gfor_fndecl_string_index_char4;
11394	else
11395	gcc_unreachable ();
11396
11397	gfc_conv_intrinsic_index_scan_verify (se, expr, function: fndecl);
11398	break;
11399
11400	case GFC_ISYM_IOR:
11401	gfc_conv_intrinsic_bitop (se, expr, op: BIT_IOR_EXPR);
11402	break;
11403
11404	case GFC_ISYM_IPARITY:
11405	gfc_conv_intrinsic_arith (se, expr, op: BIT_XOR_EXPR, norm2: false);
11406	break;
11407
11408	case GFC_ISYM_IS_IOSTAT_END:
11409	gfc_conv_has_intvalue (se, expr, value: LIBERROR_END);
11410	break;
11411
11412	case GFC_ISYM_IS_IOSTAT_EOR:
11413	gfc_conv_has_intvalue (se, expr, value: LIBERROR_EOR);
11414	break;
11415
11416	case GFC_ISYM_IS_CONTIGUOUS:
11417	gfc_conv_intrinsic_is_contiguous (se, expr);
11418	break;
11419
11420	case GFC_ISYM_ISNAN:
11421	gfc_conv_intrinsic_isnan (se, expr);
11422	break;
11423
11424	case GFC_ISYM_KILL:
11425	conv_intrinsic_kill (se, expr);
11426	break;
11427
11428	case GFC_ISYM_LSHIFT:
11429	gfc_conv_intrinsic_shift (se, expr, right_shift: false, arithmetic: false);
11430	break;
11431
11432	case GFC_ISYM_RSHIFT:
11433	gfc_conv_intrinsic_shift (se, expr, right_shift: true, arithmetic: true);
11434	break;
11435
11436	case GFC_ISYM_SHIFTA:
11437	gfc_conv_intrinsic_shift (se, expr, right_shift: true, arithmetic: true);
11438	break;
11439
11440	case GFC_ISYM_SHIFTL:
11441	gfc_conv_intrinsic_shift (se, expr, right_shift: false, arithmetic: false);
11442	break;
11443
11444	case GFC_ISYM_SHIFTR:
11445	gfc_conv_intrinsic_shift (se, expr, right_shift: true, arithmetic: false);
11446	break;
11447
11448	case GFC_ISYM_ISHFT:
11449	gfc_conv_intrinsic_ishft (se, expr);
11450	break;
11451
11452	case GFC_ISYM_ISHFTC:
11453	gfc_conv_intrinsic_ishftc (se, expr);
11454	break;
11455
11456	case GFC_ISYM_LEADZ:
11457	gfc_conv_intrinsic_leadz (se, expr);
11458	break;
11459
11460	case GFC_ISYM_TRAILZ:
11461	gfc_conv_intrinsic_trailz (se, expr);
11462	break;
11463
11464	case GFC_ISYM_POPCNT:
11465	gfc_conv_intrinsic_popcnt_poppar (se, expr, parity: 0);
11466	break;
11467
11468	case GFC_ISYM_POPPAR:
11469	gfc_conv_intrinsic_popcnt_poppar (se, expr, parity: 1);
11470	break;
11471
11472	case GFC_ISYM_LBOUND:
11473	gfc_conv_intrinsic_bound (se, expr, op: GFC_ISYM_LBOUND);
11474	break;
11475
11476	case GFC_ISYM_LCOBOUND:
11477	conv_intrinsic_cobound (se, expr);
11478	break;
11479
11480	case GFC_ISYM_TRANSPOSE:
11481	/* The scalarizer has already been set up for reversed dimension access
11482	order ; now we just get the argument value normally. */
11483	gfc_conv_expr (se, expr: expr->value.function.actual->expr);
11484	break;
11485
11486	case GFC_ISYM_LEN:
11487	gfc_conv_intrinsic_len (se, expr);
11488	break;
11489
11490	case GFC_ISYM_LEN_TRIM:
11491	gfc_conv_intrinsic_len_trim (se, expr);
11492	break;
11493
11494	case GFC_ISYM_LGE:
11495	gfc_conv_intrinsic_strcmp (se, expr, op: GE_EXPR);
11496	break;
11497
11498	case GFC_ISYM_LGT:
11499	gfc_conv_intrinsic_strcmp (se, expr, op: GT_EXPR);
11500	break;
11501
11502	case GFC_ISYM_LLE:
11503	gfc_conv_intrinsic_strcmp (se, expr, op: LE_EXPR);
11504	break;
11505
11506	case GFC_ISYM_LLT:
11507	gfc_conv_intrinsic_strcmp (se, expr, op: LT_EXPR);
11508	break;
11509
11510	case GFC_ISYM_MALLOC:
11511	gfc_conv_intrinsic_malloc (se, expr);
11512	break;
11513
11514	case GFC_ISYM_MASKL:
11515	gfc_conv_intrinsic_mask (se, expr, left: 1);
11516	break;
11517
11518	case GFC_ISYM_MASKR:
11519	gfc_conv_intrinsic_mask (se, expr, left: 0);
11520	break;
11521
11522	case GFC_ISYM_MAX:
11523	if (expr->ts.type == BT_CHARACTER)
11524	gfc_conv_intrinsic_minmax_char (se, expr, op: 1);
11525	else
11526	gfc_conv_intrinsic_minmax (se, expr, op: GT_EXPR);
11527	break;
11528
11529	case GFC_ISYM_MAXLOC:
11530	gfc_conv_intrinsic_minmaxloc (se, expr, op: GT_EXPR);
11531	break;
11532
11533	case GFC_ISYM_FINDLOC:
11534	gfc_conv_intrinsic_findloc (se, expr);
11535	break;
11536
11537	case GFC_ISYM_MAXVAL:
11538	gfc_conv_intrinsic_minmaxval (se, expr, op: GT_EXPR);
11539	break;
11540
11541	case GFC_ISYM_MERGE:
11542	gfc_conv_intrinsic_merge (se, expr);
11543	break;
11544
11545	case GFC_ISYM_MERGE_BITS:
11546	gfc_conv_intrinsic_merge_bits (se, expr);
11547	break;
11548
11549	case GFC_ISYM_MIN:
11550	if (expr->ts.type == BT_CHARACTER)
11551	gfc_conv_intrinsic_minmax_char (se, expr, op: -1);
11552	else
11553	gfc_conv_intrinsic_minmax (se, expr, op: LT_EXPR);
11554	break;
11555
11556	case GFC_ISYM_MINLOC:
11557	gfc_conv_intrinsic_minmaxloc (se, expr, op: LT_EXPR);
11558	break;
11559
11560	case GFC_ISYM_MINVAL:
11561	gfc_conv_intrinsic_minmaxval (se, expr, op: LT_EXPR);
11562	break;
11563
11564	case GFC_ISYM_NEAREST:
11565	gfc_conv_intrinsic_nearest (se, expr);
11566	break;
11567
11568	case GFC_ISYM_NORM2:
11569	gfc_conv_intrinsic_arith (se, expr, op: PLUS_EXPR, norm2: true);
11570	break;
11571
11572	case GFC_ISYM_NOT:
11573	gfc_conv_intrinsic_not (se, expr);
11574	break;
11575
11576	case GFC_ISYM_OR:
11577	gfc_conv_intrinsic_bitop (se, expr, op: BIT_IOR_EXPR);
11578	break;
11579
11580	case GFC_ISYM_OUT_OF_RANGE:
11581	gfc_conv_intrinsic_out_of_range (se, expr);
11582	break;
11583
11584	case GFC_ISYM_PARITY:
11585	gfc_conv_intrinsic_arith (se, expr, op: NE_EXPR, norm2: false);
11586	break;
11587
11588	case GFC_ISYM_PRESENT:
11589	gfc_conv_intrinsic_present (se, expr);
11590	break;
11591
11592	case GFC_ISYM_PRODUCT:
11593	gfc_conv_intrinsic_arith (se, expr, op: MULT_EXPR, norm2: false);
11594	break;
11595
11596	case GFC_ISYM_RANK:
11597	gfc_conv_intrinsic_rank (se, expr);
11598	break;
11599
11600	case GFC_ISYM_RRSPACING:
11601	gfc_conv_intrinsic_rrspacing (se, expr);
11602	break;
11603
11604	case GFC_ISYM_SET_EXPONENT:
11605	gfc_conv_intrinsic_set_exponent (se, expr);
11606	break;
11607
11608	case GFC_ISYM_SCALE:
11609	gfc_conv_intrinsic_scale (se, expr);
11610	break;
11611
11612	case GFC_ISYM_SHAPE:
11613	gfc_conv_intrinsic_bound (se, expr, op: GFC_ISYM_SHAPE);
11614	break;
11615
11616	case GFC_ISYM_SIGN:
11617	gfc_conv_intrinsic_sign (se, expr);
11618	break;
11619
11620	case GFC_ISYM_SIZE:
11621	gfc_conv_intrinsic_size (se, expr);
11622	break;
11623
11624	case GFC_ISYM_SIZEOF:
11625	case GFC_ISYM_C_SIZEOF:
11626	gfc_conv_intrinsic_sizeof (se, expr);
11627	break;
11628
11629	case GFC_ISYM_STORAGE_SIZE:
11630	gfc_conv_intrinsic_storage_size (se, expr);
11631	break;
11632
11633	case GFC_ISYM_SPACING:
11634	gfc_conv_intrinsic_spacing (se, expr);
11635	break;
11636
11637	case GFC_ISYM_STRIDE:
11638	conv_intrinsic_stride (se, expr);
11639	break;
11640
11641	case GFC_ISYM_SUM:
11642	gfc_conv_intrinsic_arith (se, expr, op: PLUS_EXPR, norm2: false);
11643	break;
11644
11645	case GFC_ISYM_TEAM_NUMBER:
11646	conv_intrinsic_team_number (se, expr);
11647	break;
11648
11649	case GFC_ISYM_TRANSFER:
11650	if (se->ss && se->ss->info->useflags)
11651	/* Access the previously obtained result. */
11652	gfc_conv_tmp_array_ref (se);
11653	else
11654	gfc_conv_intrinsic_transfer (se, expr);
11655	break;
11656
11657	case GFC_ISYM_TTYNAM:
11658	gfc_conv_intrinsic_ttynam (se, expr);
11659	break;
11660
11661	case GFC_ISYM_UBOUND:
11662	gfc_conv_intrinsic_bound (se, expr, op: GFC_ISYM_UBOUND);
11663	break;
11664
11665	case GFC_ISYM_UCOBOUND:
11666	conv_intrinsic_cobound (se, expr);
11667	break;
11668
11669	case GFC_ISYM_XOR:
11670	gfc_conv_intrinsic_bitop (se, expr, op: BIT_XOR_EXPR);
11671	break;
11672
11673	case GFC_ISYM_LOC:
11674	gfc_conv_intrinsic_loc (se, expr);
11675	break;
11676
11677	case GFC_ISYM_THIS_IMAGE:
11678	/* For num_images() == 1, handle as LCOBOUND. */
11679	if (expr->value.function.actual->expr
11680	&& flag_coarray == GFC_FCOARRAY_SINGLE)
11681	conv_intrinsic_cobound (se, expr);
11682	else
11683	trans_this_image (se, expr);
11684	break;
11685
11686	case GFC_ISYM_IMAGE_INDEX:
11687	trans_image_index (se, expr);
11688	break;
11689
11690	case GFC_ISYM_IMAGE_STATUS:
11691	conv_intrinsic_image_status (se, expr);
11692	break;
11693
11694	case GFC_ISYM_NUM_IMAGES:
11695	trans_num_images (se, expr);
11696	break;
11697
11698	case GFC_ISYM_ACCESS:
11699	case GFC_ISYM_CHDIR:
11700	case GFC_ISYM_CHMOD:
11701	case GFC_ISYM_DTIME:
11702	case GFC_ISYM_ETIME:
11703	case GFC_ISYM_EXTENDS_TYPE_OF:
11704	case GFC_ISYM_FGET:
11705	case GFC_ISYM_FGETC:
11706	case GFC_ISYM_FNUM:
11707	case GFC_ISYM_FPUT:
11708	case GFC_ISYM_FPUTC:
11709	case GFC_ISYM_FSTAT:
11710	case GFC_ISYM_FTELL:
11711	case GFC_ISYM_GETCWD:
11712	case GFC_ISYM_GETGID:
11713	case GFC_ISYM_GETPID:
11714	case GFC_ISYM_GETUID:
11715	case GFC_ISYM_GET_TEAM:
11716	case GFC_ISYM_HOSTNM:
11717	case GFC_ISYM_IERRNO:
11718	case GFC_ISYM_IRAND:
11719	case GFC_ISYM_ISATTY:
11720	case GFC_ISYM_JN2:
11721	case GFC_ISYM_LINK:
11722	case GFC_ISYM_LSTAT:
11723	case GFC_ISYM_MATMUL:
11724	case GFC_ISYM_MCLOCK:
11725	case GFC_ISYM_MCLOCK8:
11726	case GFC_ISYM_RAND:
11727	case GFC_ISYM_REDUCE:
11728	case GFC_ISYM_RENAME:
11729	case GFC_ISYM_SECOND:
11730	case GFC_ISYM_SECNDS:
11731	case GFC_ISYM_SIGNAL:
11732	case GFC_ISYM_STAT:
11733	case GFC_ISYM_SYMLNK:
11734	case GFC_ISYM_SYSTEM:
11735	case GFC_ISYM_TIME:
11736	case GFC_ISYM_TIME8:
11737	case GFC_ISYM_UMASK:
11738	case GFC_ISYM_UNLINK:
11739	case GFC_ISYM_YN2:
11740	gfc_conv_intrinsic_funcall (se, expr);
11741	break;
11742
11743	case GFC_ISYM_EOSHIFT:
11744	case GFC_ISYM_PACK:
11745	case GFC_ISYM_RESHAPE:
11746	/* For those, expr->rank should always be >0 and thus the if above the
11747	switch should have matched. */
11748	gcc_unreachable ();
11749	break;
11750
11751	default:
11752	gfc_conv_intrinsic_lib_function (se, expr);
11753	break;
11754	}
11755	}
11756
11757
11758	static gfc_ss *
11759	walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11760	{
11761	gfc_ss *arg_ss, *tmp_ss;
11762	gfc_actual_arglist *arg;
11763
11764	arg = expr->value.function.actual;
11765
11766	gcc_assert (arg->expr);
11767
11768	arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11769	gcc_assert (arg_ss != gfc_ss_terminator);
11770
11771	for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11772	{
11773	if (tmp_ss->info->type != GFC_SS_SCALAR
11774	&& tmp_ss->info->type != GFC_SS_REFERENCE)
11775	{
11776	gcc_assert (tmp_ss->dimen == 2);
11777
11778	/* We just invert dimensions. */
11779	std::swap (a&: tmp_ss->dim[0], b&: tmp_ss->dim[1]);
11780	}
11781
11782	/* Stop when tmp_ss points to the last valid element of the chain... */
11783	if (tmp_ss->next == gfc_ss_terminator)
11784	break;
11785	}
11786
11787	/* ... so that we can attach the rest of the chain to it. */
11788	tmp_ss->next = ss;
11789
11790	return arg_ss;
11791	}
11792
11793
11794	/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11795	This has the side effect of reversing the nested list, so there is no
11796	need to call gfc_reverse_ss on it (the given list is assumed not to be
11797	reversed yet). */
11798
11799	static gfc_ss *
11800	nest_loop_dimension (gfc_ss *ss, int dim)
11801	{
11802	int ss_dim, i;
11803	gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11804	gfc_loopinfo *new_loop;
11805
11806	gcc_assert (ss != gfc_ss_terminator);
11807
11808	for (; ss != gfc_ss_terminator; ss = ss->next)
11809	{
11810	new_ss = gfc_get_ss ();
11811	new_ss->next = prev_ss;
11812	new_ss->parent = ss;
11813	new_ss->info = ss->info;
11814	new_ss->info->refcount++;
11815	if (ss->dimen != 0)
11816	{
11817	gcc_assert (ss->info->type != GFC_SS_SCALAR
11818	&& ss->info->type != GFC_SS_REFERENCE);
11819
11820	new_ss->dimen = 1;
11821	new_ss->dim[0] = ss->dim[dim];
11822
11823	gcc_assert (dim < ss->dimen);
11824
11825	ss_dim = --ss->dimen;
11826	for (i = dim; i < ss_dim; i++)
11827	ss->dim[i] = ss->dim[i + 1];
11828
11829	ss->dim[ss_dim] = 0;
11830	}
11831	prev_ss = new_ss;
11832
11833	if (ss->nested_ss)
11834	{
11835	ss->nested_ss->parent = new_ss;
11836	new_ss->nested_ss = ss->nested_ss;
11837	}
11838	ss->nested_ss = new_ss;
11839	}
11840
11841	new_loop = gfc_get_loopinfo ();
11842	gfc_init_loopinfo (new_loop);
11843
11844	gcc_assert (prev_ss != NULL);
11845	gcc_assert (prev_ss != gfc_ss_terminator);
11846	gfc_add_ss_to_loop (new_loop, prev_ss);
11847	return new_ss->parent;
11848	}
11849
11850
11851	/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11852	is to be inlined. */
11853
11854	static gfc_ss *
11855	walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
11856	{
11857	gfc_ss *tmp_ss, *tail, *array_ss;
11858	gfc_actual_arglist *arg1, *arg2, *arg3;
11859	int sum_dim;
11860	bool scalar_mask = false;
11861
11862	/* The rank of the result will be determined later. */
11863	arg1 = expr->value.function.actual;
11864	arg2 = arg1->next;
11865	arg3 = arg2->next;
11866	gcc_assert (arg3 != NULL);
11867
11868	if (expr->rank == 0)
11869	return ss;
11870
11871	tmp_ss = gfc_ss_terminator;
11872
11873	if (arg3->expr)
11874	{
11875	gfc_ss *mask_ss;
11876
11877	mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
11878	if (mask_ss == tmp_ss)
11879	scalar_mask = 1;
11880
11881	tmp_ss = mask_ss;
11882	}
11883
11884	array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
11885	gcc_assert (array_ss != tmp_ss);
11886
11887	/* Odd thing: If the mask is scalar, it is used by the frontend after
11888	the array (to make an if around the nested loop). Thus it shall
11889	be after array_ss once the gfc_ss list is reversed. */
11890	if (scalar_mask)
11891	tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
11892	else
11893	tmp_ss = array_ss;
11894
11895	/* "Hide" the dimension on which we will sum in the first arg's scalarization
11896	chain. */
11897	sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
11898	tail = nest_loop_dimension (ss: tmp_ss, dim: sum_dim);
11899	tail->next = ss;
11900
11901	return tmp_ss;
11902	}
11903
11904
11905	/* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
11906	function is to be inlined. */
11907
11908	static gfc_ss *
11909	walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
11910	{
11911	if (expr->rank == 0)
11912	return ss;
11913
11914	gfc_actual_arglist *array_arg = expr->value.function.actual;
11915	gfc_actual_arglist *dim_arg = array_arg->next;
11916	gfc_actual_arglist *mask_arg = dim_arg->next;
11917	gfc_actual_arglist *kind_arg = mask_arg->next;
11918	gfc_actual_arglist *back_arg = kind_arg->next;
11919
11920	gfc_expr *array = array_arg->expr;
11921	gfc_expr *dim = dim_arg->expr;
11922	gfc_expr *mask = mask_arg->expr;
11923	gfc_expr *back = back_arg->expr;
11924
11925	if (dim == nullptr)
11926	return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11927
11928	gfc_ss *tmp_ss = gfc_ss_terminator;
11929
11930	bool scalar_mask = false;
11931	if (mask)
11932	{
11933	gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
11934	if (mask_ss == tmp_ss)
11935	scalar_mask = true;
11936	else if (maybe_absent_optional_variable (e: mask))
11937	mask_ss->info->can_be_null_ref = true;
11938
11939	tmp_ss = mask_ss;
11940	}
11941
11942	gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
11943	gcc_assert (array_ss != tmp_ss);
11944
11945	tmp_ss = array_ss;
11946
11947	/* Move the dimension on which we will sum to a separate nested scalarization
11948	chain, "hiding" that dimension from the outer scalarization. */
11949	int dim_val = mpz_get_si (dim->value.integer);
11950	gfc_ss *tail = nest_loop_dimension (ss: tmp_ss, dim: dim_val - 1);
11951
11952	if (back && array->rank > 1)
11953	{
11954	/* If there are nested scalarization loops, include BACK in the
11955	scalarization chains to avoid evaluating it multiple times in a loop.
11956	Otherwise, prefer to handle it outside of scalarization. */
11957	gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
11958	back_ss->info->type = GFC_SS_REFERENCE;
11959	if (maybe_absent_optional_variable (e: back))
11960	back_ss->info->can_be_null_ref = true;
11961
11962	tail->next = back_ss;
11963	}
11964	else
11965	tail->next = ss;
11966
11967	if (scalar_mask)
11968	{
11969	tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
11970	/* MASK can be a forwarded optional argument, so make the necessary setup
11971	to avoid the scalarizer generating any unguarded pointer dereference in
11972	that case. */
11973	tmp_ss->info->type = GFC_SS_REFERENCE;
11974	if (maybe_absent_optional_variable (e: mask))
11975	tmp_ss->info->can_be_null_ref = true;
11976	}
11977
11978	return tmp_ss;
11979	}
11980
11981
11982	static gfc_ss *
11983	walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
11984	{
11985
11986	switch (expr->value.function.isym->id)
11987	{
11988	case GFC_ISYM_PRODUCT:
11989	case GFC_ISYM_SUM:
11990	return walk_inline_intrinsic_arith (ss, expr);
11991
11992	case GFC_ISYM_TRANSPOSE:
11993	return walk_inline_intrinsic_transpose (ss, expr);
11994
11995	case GFC_ISYM_MAXLOC:
11996	case GFC_ISYM_MINLOC:
11997	return walk_inline_intrinsic_minmaxloc (ss, expr);
11998
11999	default:
12000	gcc_unreachable ();
12001	}
12002	gcc_unreachable ();
12003	}
12004
12005
12006	/* This generates code to execute before entering the scalarization loop.
12007	Currently does nothing. */
12008
12009	void
12010	gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12011	{
12012	switch (ss->info->expr->value.function.isym->id)
12013	{
12014	case GFC_ISYM_UBOUND:
12015	case GFC_ISYM_LBOUND:
12016	case GFC_ISYM_UCOBOUND:
12017	case GFC_ISYM_LCOBOUND:
12018	case GFC_ISYM_MAXLOC:
12019	case GFC_ISYM_MINLOC:
12020	case GFC_ISYM_THIS_IMAGE:
12021	case GFC_ISYM_SHAPE:
12022	break;
12023
12024	default:
12025	gcc_unreachable ();
12026	}
12027	}
12028
12029
12030	/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12031	one parameter are expanded into code inside the scalarization loop. */
12032
12033	static gfc_ss *
12034	gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12035	{
12036	if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12037	gfc_add_class_array_ref (expr->value.function.actual->expr);
12038
12039	/* The two argument version returns a scalar. */
12040	if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12041	&& expr->value.function.actual->next->expr)
12042	return ss;
12043
12044	return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12045	}
12046
12047
12048	/* Walk an intrinsic array libcall. */
12049
12050	static gfc_ss *
12051	gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12052	{
12053	gcc_assert (expr->rank > 0);
12054	return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12055	}
12056
12057
12058	/* Return whether the function call expression EXPR will be expanded
12059	inline by gfc_conv_intrinsic_function. */
12060
12061	bool
12062	gfc_inline_intrinsic_function_p (gfc_expr *expr)
12063	{
12064	gfc_actual_arglist *args, *dim_arg, *mask_arg;
12065	gfc_expr *maskexpr;
12066
12067	gfc_intrinsic_sym *isym = expr->value.function.isym;
12068	if (!isym)
12069	return false;
12070
12071	switch (isym->id)
12072	{
12073	case GFC_ISYM_PRODUCT:
12074	case GFC_ISYM_SUM:
12075	/* Disable inline expansion if code size matters. */
12076	if (optimize_size)
12077	return false;
12078
12079	args = expr->value.function.actual;
12080	dim_arg = args->next;
12081
12082	/* We need to be able to subset the SUM argument at compile-time. */
12083	if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12084	return false;
12085
12086	/* FIXME: If MASK is optional for a more than two-dimensional
12087	argument, the scalarizer gets confused if the mask is
12088	absent. See PR 82995. For now, fall back to the library
12089	function. */
12090
12091	mask_arg = dim_arg->next;
12092	maskexpr = mask_arg->expr;
12093
12094	if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12095	&& maskexpr->symtree->n.sym->attr.dummy
12096	&& maskexpr->symtree->n.sym->attr.optional)
12097	return false;
12098
12099	return true;
12100
12101	case GFC_ISYM_TRANSPOSE:
12102	return true;
12103
12104	case GFC_ISYM_MINLOC:
12105	case GFC_ISYM_MAXLOC:
12106	{
12107	if ((isym->id == GFC_ISYM_MINLOC
12108	&& (flag_inline_intrinsics
12109	& GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12110	|| (isym->id == GFC_ISYM_MAXLOC
12111	&& (flag_inline_intrinsics
12112	& GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12113	return false;
12114
12115	gfc_actual_arglist *array_arg = expr->value.function.actual;
12116	gfc_actual_arglist *dim_arg = array_arg->next;
12117
12118	gfc_expr *array = array_arg->expr;
12119	gfc_expr *dim = dim_arg->expr;
12120
12121	if (!(array->ts.type == BT_INTEGER
12122	|| array->ts.type == BT_REAL))
12123	return false;
12124
12125	if (array->rank == 1)
12126	return true;
12127
12128	if (dim != nullptr
12129	&& dim->expr_type != EXPR_CONSTANT)
12130	return false;
12131
12132	return true;
12133	}
12134
12135	default:
12136	return false;
12137	}
12138	}
12139
12140
12141	/* Returns nonzero if the specified intrinsic function call maps directly to
12142	an external library call. Should only be used for functions that return
12143	arrays. */
12144
12145	int
12146	gfc_is_intrinsic_libcall (gfc_expr * expr)
12147	{
12148	gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12149	gcc_assert (expr->rank > 0);
12150
12151	if (gfc_inline_intrinsic_function_p (expr))
12152	return 0;
12153
12154	switch (expr->value.function.isym->id)
12155	{
12156	case GFC_ISYM_ALL:
12157	case GFC_ISYM_ANY:
12158	case GFC_ISYM_COUNT:
12159	case GFC_ISYM_FINDLOC:
12160	case GFC_ISYM_JN2:
12161	case GFC_ISYM_IANY:
12162	case GFC_ISYM_IALL:
12163	case GFC_ISYM_IPARITY:
12164	case GFC_ISYM_MATMUL:
12165	case GFC_ISYM_MAXLOC:
12166	case GFC_ISYM_MAXVAL:
12167	case GFC_ISYM_MINLOC:
12168	case GFC_ISYM_MINVAL:
12169	case GFC_ISYM_NORM2:
12170	case GFC_ISYM_PARITY:
12171	case GFC_ISYM_PRODUCT:
12172	case GFC_ISYM_SUM:
12173	case GFC_ISYM_SPREAD:
12174	case GFC_ISYM_YN2:
12175	/* Ignore absent optional parameters. */
12176	return 1;
12177
12178	case GFC_ISYM_CSHIFT:
12179	case GFC_ISYM_EOSHIFT:
12180	case GFC_ISYM_GET_TEAM:
12181	case GFC_ISYM_FAILED_IMAGES:
12182	case GFC_ISYM_STOPPED_IMAGES:
12183	case GFC_ISYM_PACK:
12184	case GFC_ISYM_REDUCE:
12185	case GFC_ISYM_RESHAPE:
12186	case GFC_ISYM_UNPACK:
12187	/* Pass absent optional parameters. */
12188	return 2;
12189
12190	default:
12191	return 0;
12192	}
12193	}
12194
12195	/* Walk an intrinsic function. */
12196	gfc_ss *
12197	gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12198	gfc_intrinsic_sym * isym)
12199	{
12200	gcc_assert (isym);
12201
12202	if (isym->elemental)
12203	return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12204	expr->value.function.isym,
12205	GFC_SS_SCALAR);
12206
12207	if (expr->rank == 0 && expr->corank == 0)
12208	return ss;
12209
12210	if (gfc_inline_intrinsic_function_p (expr))
12211	return walk_inline_intrinsic_function (ss, expr);
12212
12213	if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12214	return gfc_walk_intrinsic_libfunc (ss, expr);
12215
12216	/* Special cases. */
12217	switch (isym->id)
12218	{
12219	case GFC_ISYM_LBOUND:
12220	case GFC_ISYM_LCOBOUND:
12221	case GFC_ISYM_UBOUND:
12222	case GFC_ISYM_UCOBOUND:
12223	case GFC_ISYM_THIS_IMAGE:
12224	case GFC_ISYM_SHAPE:
12225	return gfc_walk_intrinsic_bound (ss, expr);
12226
12227	case GFC_ISYM_TRANSFER:
12228	case GFC_ISYM_CAF_GET:
12229	return gfc_walk_intrinsic_libfunc (ss, expr);
12230
12231	default:
12232	/* This probably meant someone forgot to add an intrinsic to the above
12233	list(s) when they implemented it, or something's gone horribly
12234	wrong. */
12235	gcc_unreachable ();
12236	}
12237	}
12238
12239	static tree
12240	conv_co_collective (gfc_code *code)
12241	{
12242	gfc_se argse;
12243	stmtblock_t block, post_block;
12244	tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12245	gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12246
12247	gfc_start_block (&block);
12248	gfc_init_block (&post_block);
12249
12250	if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12251	{
12252	opr_expr = code->ext.actual->next->expr;
12253	image_idx_expr = code->ext.actual->next->next->expr;
12254	stat_expr = code->ext.actual->next->next->next->expr;
12255	errmsg_expr = code->ext.actual->next->next->next->next->expr;
12256	}
12257	else
12258	{
12259	opr_expr = NULL;
12260	image_idx_expr = code->ext.actual->next->expr;
12261	stat_expr = code->ext.actual->next->next->expr;
12262	errmsg_expr = code->ext.actual->next->next->next->expr;
12263	}
12264
12265	/* stat. */
12266	if (stat_expr)
12267	{
12268	gfc_init_se (&argse, NULL);
12269	gfc_conv_expr (se: &argse, expr: stat_expr);
12270	gfc_add_block_to_block (&block, &argse.pre);
12271	gfc_add_block_to_block (&post_block, &argse.post);
12272	stat = argse.expr;
12273	if (flag_coarray != GFC_FCOARRAY_SINGLE)
12274	stat = gfc_build_addr_expr (NULL_TREE, stat);
12275	}
12276	else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12277	stat = NULL_TREE;
12278	else
12279	stat = null_pointer_node;
12280
12281	/* Early exit for GFC_FCOARRAY_SINGLE. */
12282	if (flag_coarray == GFC_FCOARRAY_SINGLE)
12283	{
12284	if (stat != NULL_TREE)
12285	{
12286	/* For optional stats, check the pointer is valid before zero'ing. */
12287	if (gfc_expr_attr (stat_expr).optional)
12288	{
12289	tree tmp;
12290	stmtblock_t ass_block;
12291	gfc_start_block (&ass_block);
12292	gfc_add_modify (&ass_block, stat,
12293	fold_convert (TREE_TYPE (stat),
12294	integer_zero_node));
12295	tmp = fold_build2 (NE_EXPR, logical_type_node,
12296	gfc_build_addr_expr (NULL_TREE, stat),
12297	null_pointer_node);
12298	tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12299	gfc_finish_block (&ass_block),
12300	build_empty_stmt (input_location));
12301	gfc_add_expr_to_block (&block, tmp);
12302	}
12303	else
12304	gfc_add_modify (&block, stat,
12305	fold_convert (TREE_TYPE (stat), integer_zero_node));
12306	}
12307	return gfc_finish_block (&block);
12308	}
12309
12310	gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12311	? code->ext.actual->expr->ts.u.derived : NULL;
12312
12313	/* Handle the array. */
12314	gfc_init_se (&argse, NULL);
12315	if (!derived || !derived->attr.alloc_comp
12316	|| code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12317	{
12318	if (code->ext.actual->expr->rank == 0)
12319	{
12320	symbol_attribute attr;
12321	gfc_clear_attr (&attr);
12322	gfc_init_se (&argse, NULL);
12323	gfc_conv_expr (se: &argse, expr: code->ext.actual->expr);
12324	gfc_add_block_to_block (&block, &argse.pre);
12325	gfc_add_block_to_block (&post_block, &argse.post);
12326	array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12327	array = gfc_build_addr_expr (NULL_TREE, array);
12328	}
12329	else
12330	{
12331	argse.want_pointer = 1;
12332	gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12333	array = argse.expr;
12334	}
12335	}
12336
12337	gfc_add_block_to_block (&block, &argse.pre);
12338	gfc_add_block_to_block (&post_block, &argse.post);
12339
12340	if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12341	strlen = argse.string_length;
12342	else
12343	strlen = integer_zero_node;
12344
12345	/* image_index. */
12346	if (image_idx_expr)
12347	{
12348	gfc_init_se (&argse, NULL);
12349	gfc_conv_expr (se: &argse, expr: image_idx_expr);
12350	gfc_add_block_to_block (&block, &argse.pre);
12351	gfc_add_block_to_block (&post_block, &argse.post);
12352	image_index = fold_convert (integer_type_node, argse.expr);
12353	}
12354	else
12355	image_index = integer_zero_node;
12356
12357	/* errmsg. */
12358	if (errmsg_expr)
12359	{
12360	gfc_init_se (&argse, NULL);
12361	gfc_conv_expr (se: &argse, expr: errmsg_expr);
12362	gfc_add_block_to_block (&block, &argse.pre);
12363	gfc_add_block_to_block (&post_block, &argse.post);
12364	errmsg = argse.expr;
12365	errmsg_len = fold_convert (size_type_node, argse.string_length);
12366	}
12367	else
12368	{
12369	errmsg = null_pointer_node;
12370	errmsg_len = build_zero_cst (size_type_node);
12371	}
12372
12373	/* Generate the function call. */
12374	switch (code->resolved_isym->id)
12375	{
12376	case GFC_ISYM_CO_BROADCAST:
12377	fndecl = gfor_fndecl_co_broadcast;
12378	break;
12379	case GFC_ISYM_CO_MAX:
12380	fndecl = gfor_fndecl_co_max;
12381	break;
12382	case GFC_ISYM_CO_MIN:
12383	fndecl = gfor_fndecl_co_min;
12384	break;
12385	case GFC_ISYM_CO_REDUCE:
12386	fndecl = gfor_fndecl_co_reduce;
12387	break;
12388	case GFC_ISYM_CO_SUM:
12389	fndecl = gfor_fndecl_co_sum;
12390	break;
12391	default:
12392	gcc_unreachable ();
12393	}
12394
12395	if (derived && derived->attr.alloc_comp
12396	&& code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12397	/* The derived type has the attribute 'alloc_comp'. */
12398	{
12399	tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12400	code->ext.actual->expr->rank,
12401	image_index, stat, errmsg, errmsg_len);
12402	gfc_add_expr_to_block (&block, tmp);
12403	}
12404	else
12405	{
12406	if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12407	|| code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12408	fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12409	image_index, stat, errmsg, errmsg_len);
12410	else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12411	fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12412	image_index, stat, errmsg,
12413	strlen, errmsg_len);
12414	else
12415	{
12416	tree opr, opr_flags;
12417
12418	// FIXME: Handle TS29113's bind(C) strings with descriptor.
12419	int opr_flag_int;
12420	if (gfc_is_proc_ptr_comp (opr_expr))
12421	{
12422	gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12423	opr_flag_int = sym->attr.dimension
12424	|| (sym->ts.type == BT_CHARACTER
12425	&& !sym->attr.is_bind_c)
12426	? GFC_CAF_BYREF : 0;
12427	opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12428	&& !sym->attr.is_bind_c
12429	? GFC_CAF_HIDDENLEN : 0;
12430	opr_flag_int |= sym->formal->sym->attr.value
12431	? GFC_CAF_ARG_VALUE : 0;
12432	}
12433	else
12434	{
12435	opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12436	? GFC_CAF_BYREF : 0;
12437	opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12438	&& !opr_expr->symtree->n.sym->attr.is_bind_c
12439	? GFC_CAF_HIDDENLEN : 0;
12440	opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12441	? GFC_CAF_ARG_VALUE : 0;
12442	}
12443	opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12444	gfc_conv_expr (se: &argse, expr: opr_expr);
12445	opr = argse.expr;
12446	fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12447	opr_flags, image_index, stat, errmsg,
12448	strlen, errmsg_len);
12449	}
12450	}
12451
12452	gfc_add_expr_to_block (&block, fndecl);
12453	gfc_add_block_to_block (&block, &post_block);
12454
12455	return gfc_finish_block (&block);
12456	}
12457
12458
12459	static tree
12460	conv_intrinsic_atomic_op (gfc_code *code)
12461	{
12462	gfc_se argse;
12463	tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12464	stmtblock_t block, post_block;
12465	gfc_expr *atom_expr = code->ext.actual->expr;
12466	gfc_expr *stat_expr;
12467	built_in_function fn;
12468
12469	if (atom_expr->expr_type == EXPR_FUNCTION
12470	&& atom_expr->value.function.isym
12471	&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12472	atom_expr = atom_expr->value.function.actual->expr;
12473
12474	gfc_start_block (&block);
12475	gfc_init_block (&post_block);
12476
12477	gfc_init_se (&argse, NULL);
12478	argse.want_pointer = 1;
12479	gfc_conv_expr (se: &argse, expr: atom_expr);
12480	gfc_add_block_to_block (&block, &argse.pre);
12481	gfc_add_block_to_block (&post_block, &argse.post);
12482	atom = argse.expr;
12483
12484	gfc_init_se (&argse, NULL);
12485	if (flag_coarray == GFC_FCOARRAY_LIB
12486	&& code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12487	argse.want_pointer = 1;
12488	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->expr);
12489	gfc_add_block_to_block (&block, &argse.pre);
12490	gfc_add_block_to_block (&post_block, &argse.post);
12491	value = argse.expr;
12492
12493	switch (code->resolved_isym->id)
12494	{
12495	case GFC_ISYM_ATOMIC_ADD:
12496	case GFC_ISYM_ATOMIC_AND:
12497	case GFC_ISYM_ATOMIC_DEF:
12498	case GFC_ISYM_ATOMIC_OR:
12499	case GFC_ISYM_ATOMIC_XOR:
12500	stat_expr = code->ext.actual->next->next->expr;
12501	if (flag_coarray == GFC_FCOARRAY_LIB)
12502	old = null_pointer_node;
12503	break;
12504	default:
12505	gfc_init_se (&argse, NULL);
12506	if (flag_coarray == GFC_FCOARRAY_LIB)
12507	argse.want_pointer = 1;
12508	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->next->expr);
12509	gfc_add_block_to_block (&block, &argse.pre);
12510	gfc_add_block_to_block (&post_block, &argse.post);
12511	old = argse.expr;
12512	stat_expr = code->ext.actual->next->next->next->expr;
12513	}
12514
12515	/* STAT= */
12516	if (stat_expr != NULL)
12517	{
12518	gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12519	gfc_init_se (&argse, NULL);
12520	if (flag_coarray == GFC_FCOARRAY_LIB)
12521	argse.want_pointer = 1;
12522	gfc_conv_expr_val (se: &argse, expr: stat_expr);
12523	gfc_add_block_to_block (&block, &argse.pre);
12524	gfc_add_block_to_block (&post_block, &argse.post);
12525	stat = argse.expr;
12526	}
12527	else if (flag_coarray == GFC_FCOARRAY_LIB)
12528	stat = null_pointer_node;
12529
12530	if (flag_coarray == GFC_FCOARRAY_LIB)
12531	{
12532	tree image_index, caf_decl, offset, token;
12533	int op;
12534
12535	switch (code->resolved_isym->id)
12536	{
12537	case GFC_ISYM_ATOMIC_ADD:
12538	case GFC_ISYM_ATOMIC_FETCH_ADD:
12539	op = (int) GFC_CAF_ATOMIC_ADD;
12540	break;
12541	case GFC_ISYM_ATOMIC_AND:
12542	case GFC_ISYM_ATOMIC_FETCH_AND:
12543	op = (int) GFC_CAF_ATOMIC_AND;
12544	break;
12545	case GFC_ISYM_ATOMIC_OR:
12546	case GFC_ISYM_ATOMIC_FETCH_OR:
12547	op = (int) GFC_CAF_ATOMIC_OR;
12548	break;
12549	case GFC_ISYM_ATOMIC_XOR:
12550	case GFC_ISYM_ATOMIC_FETCH_XOR:
12551	op = (int) GFC_CAF_ATOMIC_XOR;
12552	break;
12553	case GFC_ISYM_ATOMIC_DEF:
12554	op = 0; /* Unused. */
12555	break;
12556	default:
12557	gcc_unreachable ();
12558	}
12559
12560	caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12561	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12562	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12563
12564	if (gfc_is_coindexed (atom_expr))
12565	image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12566	else
12567	image_index = integer_zero_node;
12568
12569	/* Ensure VALUE names addressable storage: taking the address of a
12570	constant is invalid in C, and scalars need a temporary as well. */
12571	if (!POINTER_TYPE_P (TREE_TYPE (value)))
12572	{
12573	tree elem
12574	= fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12575	elem = gfc_trans_force_lval (&block, elem);
12576	value = gfc_build_addr_expr (NULL_TREE, elem);
12577	}
12578	else if (TREE_CODE (value) == ADDR_EXPR
12579	&& TREE_CONSTANT (TREE_OPERAND (value, 0)))
12580	{
12581	tree elem
12582	= fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12583	build_fold_indirect_ref (value));
12584	elem = gfc_trans_force_lval (&block, elem);
12585	value = gfc_build_addr_expr (NULL_TREE, elem);
12586	}
12587
12588	gfc_init_se (&argse, NULL);
12589	gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12590	atom_expr);
12591
12592	gfc_add_block_to_block (&block, &argse.pre);
12593	if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12594	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12595	token, offset, image_index, value, stat,
12596	build_int_cst (integer_type_node,
12597	(int) atom_expr->ts.type),
12598	build_int_cst (integer_type_node,
12599	(int) atom_expr->ts.kind));
12600	else
12601	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12602	build_int_cst (integer_type_node, op),
12603	token, offset, image_index, value, old, stat,
12604	build_int_cst (integer_type_node,
12605	(int) atom_expr->ts.type),
12606	build_int_cst (integer_type_node,
12607	(int) atom_expr->ts.kind));
12608
12609	gfc_add_expr_to_block (&block, tmp);
12610	gfc_add_block_to_block (&block, &argse.post);
12611	gfc_add_block_to_block (&block, &post_block);
12612	return gfc_finish_block (&block);
12613	}
12614
12615
12616	switch (code->resolved_isym->id)
12617	{
12618	case GFC_ISYM_ATOMIC_ADD:
12619	case GFC_ISYM_ATOMIC_FETCH_ADD:
12620	fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12621	break;
12622	case GFC_ISYM_ATOMIC_AND:
12623	case GFC_ISYM_ATOMIC_FETCH_AND:
12624	fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12625	break;
12626	case GFC_ISYM_ATOMIC_DEF:
12627	fn = BUILT_IN_ATOMIC_STORE_N;
12628	break;
12629	case GFC_ISYM_ATOMIC_OR:
12630	case GFC_ISYM_ATOMIC_FETCH_OR:
12631	fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12632	break;
12633	case GFC_ISYM_ATOMIC_XOR:
12634	case GFC_ISYM_ATOMIC_FETCH_XOR:
12635	fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12636	break;
12637	default:
12638	gcc_unreachable ();
12639	}
12640
12641	tmp = TREE_TYPE (TREE_TYPE (atom));
12642	fn = (built_in_function) ((int) fn
12643	+ exact_log2 (x: tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12644	+ 1);
12645	tree itype = TREE_TYPE (TREE_TYPE (atom));
12646	tmp = builtin_decl_explicit (fncode: fn);
12647
12648	switch (code->resolved_isym->id)
12649	{
12650	case GFC_ISYM_ATOMIC_ADD:
12651	case GFC_ISYM_ATOMIC_AND:
12652	case GFC_ISYM_ATOMIC_DEF:
12653	case GFC_ISYM_ATOMIC_OR:
12654	case GFC_ISYM_ATOMIC_XOR:
12655	tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12656	fold_convert (itype, value),
12657	build_int_cst (NULL, MEMMODEL_RELAXED));
12658	gfc_add_expr_to_block (&block, tmp);
12659	break;
12660	default:
12661	tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12662	fold_convert (itype, value),
12663	build_int_cst (NULL, MEMMODEL_RELAXED));
12664	gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12665	break;
12666	}
12667
12668	if (stat != NULL_TREE)
12669	gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12670	gfc_add_block_to_block (&block, &post_block);
12671	return gfc_finish_block (&block);
12672	}
12673
12674
12675	static tree
12676	conv_intrinsic_atomic_ref (gfc_code *code)
12677	{
12678	gfc_se argse;
12679	tree tmp, atom, value, stat = NULL_TREE;
12680	stmtblock_t block, post_block;
12681	built_in_function fn;
12682	gfc_expr *atom_expr = code->ext.actual->next->expr;
12683
12684	if (atom_expr->expr_type == EXPR_FUNCTION
12685	&& atom_expr->value.function.isym
12686	&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12687	atom_expr = atom_expr->value.function.actual->expr;
12688
12689	gfc_start_block (&block);
12690	gfc_init_block (&post_block);
12691	gfc_init_se (&argse, NULL);
12692	argse.want_pointer = 1;
12693	gfc_conv_expr (se: &argse, expr: atom_expr);
12694	gfc_add_block_to_block (&block, &argse.pre);
12695	gfc_add_block_to_block (&post_block, &argse.post);
12696	atom = argse.expr;
12697
12698	gfc_init_se (&argse, NULL);
12699	if (flag_coarray == GFC_FCOARRAY_LIB
12700	&& code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12701	argse.want_pointer = 1;
12702	gfc_conv_expr (se: &argse, expr: code->ext.actual->expr);
12703	gfc_add_block_to_block (&block, &argse.pre);
12704	gfc_add_block_to_block (&post_block, &argse.post);
12705	value = argse.expr;
12706
12707	/* STAT= */
12708	if (code->ext.actual->next->next->expr != NULL)
12709	{
12710	gcc_assert (code->ext.actual->next->next->expr->expr_type
12711	== EXPR_VARIABLE);
12712	gfc_init_se (&argse, NULL);
12713	if (flag_coarray == GFC_FCOARRAY_LIB)
12714	argse.want_pointer = 1;
12715	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->next->next->expr);
12716	gfc_add_block_to_block (&block, &argse.pre);
12717	gfc_add_block_to_block (&post_block, &argse.post);
12718	stat = argse.expr;
12719	}
12720	else if (flag_coarray == GFC_FCOARRAY_LIB)
12721	stat = null_pointer_node;
12722
12723	if (flag_coarray == GFC_FCOARRAY_LIB)
12724	{
12725	tree image_index, caf_decl, offset, token;
12726	tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12727
12728	caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12729	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12730	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12731
12732	if (gfc_is_coindexed (atom_expr))
12733	image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12734	else
12735	image_index = integer_zero_node;
12736
12737	gfc_init_se (&argse, NULL);
12738	gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12739	atom_expr);
12740	gfc_add_block_to_block (&block, &argse.pre);
12741
12742	/* Different type, need type conversion. */
12743	if (!POINTER_TYPE_P (TREE_TYPE (value)))
12744	{
12745	vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12746	orig_value = value;
12747	value = gfc_build_addr_expr (NULL_TREE, vardecl);
12748	}
12749
12750	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12751	token, offset, image_index, value, stat,
12752	build_int_cst (integer_type_node,
12753	(int) atom_expr->ts.type),
12754	build_int_cst (integer_type_node,
12755	(int) atom_expr->ts.kind));
12756	gfc_add_expr_to_block (&block, tmp);
12757	if (vardecl != NULL_TREE)
12758	gfc_add_modify (&block, orig_value,
12759	fold_convert (TREE_TYPE (orig_value), vardecl));
12760	gfc_add_block_to_block (&block, &argse.post);
12761	gfc_add_block_to_block (&block, &post_block);
12762	return gfc_finish_block (&block);
12763	}
12764
12765	tmp = TREE_TYPE (TREE_TYPE (atom));
12766	fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12767	+ exact_log2 (x: tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12768	+ 1);
12769	tmp = builtin_decl_explicit (fncode: fn);
12770	tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12771	build_int_cst (integer_type_node,
12772	MEMMODEL_RELAXED));
12773	gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12774
12775	if (stat != NULL_TREE)
12776	gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12777	gfc_add_block_to_block (&block, &post_block);
12778	return gfc_finish_block (&block);
12779	}
12780
12781
12782	static tree
12783	conv_intrinsic_atomic_cas (gfc_code *code)
12784	{
12785	gfc_se argse;
12786	tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12787	stmtblock_t block, post_block;
12788	built_in_function fn;
12789	gfc_expr *atom_expr = code->ext.actual->expr;
12790
12791	if (atom_expr->expr_type == EXPR_FUNCTION
12792	&& atom_expr->value.function.isym
12793	&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12794	atom_expr = atom_expr->value.function.actual->expr;
12795
12796	gfc_init_block (&block);
12797	gfc_init_block (&post_block);
12798	gfc_init_se (&argse, NULL);
12799	argse.want_pointer = 1;
12800	gfc_conv_expr (se: &argse, expr: atom_expr);
12801	atom = argse.expr;
12802
12803	gfc_init_se (&argse, NULL);
12804	if (flag_coarray == GFC_FCOARRAY_LIB)
12805	argse.want_pointer = 1;
12806	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->expr);
12807	gfc_add_block_to_block (&block, &argse.pre);
12808	gfc_add_block_to_block (&post_block, &argse.post);
12809	old = argse.expr;
12810
12811	gfc_init_se (&argse, NULL);
12812	if (flag_coarray == GFC_FCOARRAY_LIB)
12813	argse.want_pointer = 1;
12814	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->next->expr);
12815	gfc_add_block_to_block (&block, &argse.pre);
12816	gfc_add_block_to_block (&post_block, &argse.post);
12817	comp = argse.expr;
12818
12819	gfc_init_se (&argse, NULL);
12820	if (flag_coarray == GFC_FCOARRAY_LIB
12821	&& code->ext.actual->next->next->next->expr->ts.kind
12822	== atom_expr->ts.kind)
12823	argse.want_pointer = 1;
12824	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->next->next->expr);
12825	gfc_add_block_to_block (&block, &argse.pre);
12826	gfc_add_block_to_block (&post_block, &argse.post);
12827	new_val = argse.expr;
12828
12829	/* STAT= */
12830	if (code->ext.actual->next->next->next->next->expr != NULL)
12831	{
12832	gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
12833	== EXPR_VARIABLE);
12834	gfc_init_se (&argse, NULL);
12835	if (flag_coarray == GFC_FCOARRAY_LIB)
12836	argse.want_pointer = 1;
12837	gfc_conv_expr_val (se: &argse,
12838	expr: code->ext.actual->next->next->next->next->expr);
12839	gfc_add_block_to_block (&block, &argse.pre);
12840	gfc_add_block_to_block (&post_block, &argse.post);
12841	stat = argse.expr;
12842	}
12843	else if (flag_coarray == GFC_FCOARRAY_LIB)
12844	stat = null_pointer_node;
12845
12846	if (flag_coarray == GFC_FCOARRAY_LIB)
12847	{
12848	tree image_index, caf_decl, offset, token;
12849
12850	caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12851	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12852	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12853
12854	if (gfc_is_coindexed (atom_expr))
12855	image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12856	else
12857	image_index = integer_zero_node;
12858
12859	if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
12860	{
12861	tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
12862	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
12863	new_val = gfc_build_addr_expr (NULL_TREE, tmp);
12864	}
12865
12866	gfc_init_se (&argse, NULL);
12867	gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12868	atom_expr);
12869	gfc_add_block_to_block (&block, &argse.pre);
12870
12871	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
12872	token, offset, image_index, old, comp, new_val,
12873	stat, build_int_cst (integer_type_node,
12874	(int) atom_expr->ts.type),
12875	build_int_cst (integer_type_node,
12876	(int) atom_expr->ts.kind));
12877	gfc_add_expr_to_block (&block, tmp);
12878	gfc_add_block_to_block (&block, &argse.post);
12879	gfc_add_block_to_block (&block, &post_block);
12880	return gfc_finish_block (&block);
12881	}
12882
12883	tmp = TREE_TYPE (TREE_TYPE (atom));
12884	fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12885	+ exact_log2 (x: tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12886	+ 1);
12887	tmp = builtin_decl_explicit (fncode: fn);
12888
12889	gfc_add_modify (&block, old, comp);
12890	tmp = build_call_expr_loc (input_location, tmp, 6, atom,
12891	gfc_build_addr_expr (NULL, old),
12892	fold_convert (TREE_TYPE (old), new_val),
12893	boolean_false_node,
12894	build_int_cst (NULL, MEMMODEL_RELAXED),
12895	build_int_cst (NULL, MEMMODEL_RELAXED));
12896	gfc_add_expr_to_block (&block, tmp);
12897
12898	if (stat != NULL_TREE)
12899	gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12900	gfc_add_block_to_block (&block, &post_block);
12901	return gfc_finish_block (&block);
12902	}
12903
12904	static tree
12905	conv_intrinsic_event_query (gfc_code *code)
12906	{
12907	gfc_se se, argse;
12908	tree stat = NULL_TREE, stat2 = NULL_TREE;
12909	tree count = NULL_TREE, count2 = NULL_TREE;
12910
12911	gfc_expr *event_expr = code->ext.actual->expr;
12912
12913	if (code->ext.actual->next->next->expr)
12914	{
12915	gcc_assert (code->ext.actual->next->next->expr->expr_type
12916	== EXPR_VARIABLE);
12917	gfc_init_se (&argse, NULL);
12918	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->next->next->expr);
12919	stat = argse.expr;
12920	}
12921	else if (flag_coarray == GFC_FCOARRAY_LIB)
12922	stat = null_pointer_node;
12923
12924	if (code->ext.actual->next->expr)
12925	{
12926	gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
12927	gfc_init_se (&argse, NULL);
12928	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->next->expr);
12929	count = argse.expr;
12930	}
12931
12932	gfc_start_block (&se.pre);
12933	if (flag_coarray == GFC_FCOARRAY_LIB)
12934	{
12935	tree tmp, token, image_index;
12936	tree index = build_zero_cst (gfc_array_index_type);
12937
12938	if (event_expr->expr_type == EXPR_FUNCTION
12939	&& event_expr->value.function.isym
12940	&& event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12941	event_expr = event_expr->value.function.actual->expr;
12942
12943	tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
12944
12945	if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
12946	|| event_expr->symtree->n.sym->ts.u.derived->from_intmod
12947	!= INTMOD_ISO_FORTRAN_ENV
12948	|| event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
12949	!= ISOFORTRAN_EVENT_TYPE)
12950	{
12951	gfc_error ("Sorry, the event component of derived type at %L is not "
12952	"yet supported", &event_expr->where);
12953	return NULL_TREE;
12954	}
12955
12956	if (gfc_is_coindexed (event_expr))
12957	{
12958	gfc_error ("The event variable at %L shall not be coindexed",
12959	&event_expr->where);
12960	return NULL_TREE;
12961	}
12962
12963	image_index = integer_zero_node;
12964
12965	gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
12966	event_expr);
12967
12968	/* For arrays, obtain the array index. */
12969	if (gfc_expr_attr (event_expr).dimension)
12970	{
12971	tree desc, tmp, extent, lbound, ubound;
12972	gfc_array_ref *ar, ar2;
12973	int i;
12974
12975	/* TODO: Extend this, once DT components are supported. */
12976	ar = &event_expr->ref->u.ar;
12977	ar2 = *ar;
12978	memset (s: ar, c: '\0', n: sizeof (*ar));
12979	ar->as = ar2.as;
12980	ar->type = AR_FULL;
12981
12982	gfc_init_se (&argse, NULL);
12983	argse.descriptor_only = 1;
12984	gfc_conv_expr_descriptor (&argse, event_expr);
12985	gfc_add_block_to_block (&se.pre, &argse.pre);
12986	desc = argse.expr;
12987	*ar = ar2;
12988
12989	extent = build_one_cst (gfc_array_index_type);
12990	for (i = 0; i < ar->dimen; i++)
12991	{
12992	gfc_init_se (&argse, NULL);
12993	gfc_conv_expr_type (se: &argse, ar->start[i], gfc_array_index_type);
12994	gfc_add_block_to_block (&argse.pre, &argse.pre);
12995	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
12996	tmp = fold_build2_loc (input_location, MINUS_EXPR,
12997	TREE_TYPE (lbound), argse.expr, lbound);
12998	tmp = fold_build2_loc (input_location, MULT_EXPR,
12999	TREE_TYPE (tmp), extent, tmp);
13000	index = fold_build2_loc (input_location, PLUS_EXPR,
13001	TREE_TYPE (tmp), index, tmp);
13002	if (i < ar->dimen - 1)
13003	{
13004	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13005	tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13006	extent = fold_build2_loc (input_location, MULT_EXPR,
13007	TREE_TYPE (tmp), extent, tmp);
13008	}
13009	}
13010	}
13011
13012	if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13013	{
13014	count2 = count;
13015	count = gfc_create_var (integer_type_node, "count");
13016	}
13017
13018	if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13019	{
13020	stat2 = stat;
13021	stat = gfc_create_var (integer_type_node, "stat");
13022	}
13023
13024	index = fold_convert (size_type_node, index);
13025	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13026	token, index, image_index, count
13027	? gfc_build_addr_expr (NULL, count) : count,
13028	stat != null_pointer_node
13029	? gfc_build_addr_expr (NULL, stat) : stat);
13030	gfc_add_expr_to_block (&se.pre, tmp);
13031
13032	if (count2 != NULL_TREE)
13033	gfc_add_modify (&se.pre, count2,
13034	fold_convert (TREE_TYPE (count2), count));
13035
13036	if (stat2 != NULL_TREE)
13037	gfc_add_modify (&se.pre, stat2,
13038	fold_convert (TREE_TYPE (stat2), stat));
13039
13040	return gfc_finish_block (&se.pre);
13041	}
13042
13043	gfc_init_se (&argse, NULL);
13044	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->expr);
13045	gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13046
13047	if (stat != NULL_TREE)
13048	gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13049
13050	return gfc_finish_block (&se.pre);
13051	}
13052
13053
13054	/* This is a peculiar case because of the need to do dependency checking.
13055	It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13056	a special case and this function called instead of
13057	gfc_conv_procedure_call. */
13058	void
13059	gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13060	gfc_loopinfo *loop)
13061	{
13062	gfc_actual_arglist *actual;
13063	gfc_se argse[5];
13064	gfc_expr *arg[5];
13065	gfc_ss *lss;
13066	int n;
13067
13068	tree from, frompos, len, to, topos;
13069	tree lenmask, oldbits, newbits, bitsize;
13070	tree type, utype, above, mask1, mask2;
13071
13072	if (loop)
13073	lss = loop->ss;
13074	else
13075	lss = gfc_ss_terminator;
13076
13077	actual = actual_args;
13078	for (n = 0; n < 5; n++, actual = actual->next)
13079	{
13080	arg[n] = actual->expr;
13081	gfc_init_se (&argse[n], NULL);
13082
13083	if (lss != gfc_ss_terminator)
13084	{
13085	gfc_copy_loopinfo_to_se (&argse[n], loop);
13086	/* Find the ss for the expression if it is there. */
13087	argse[n].ss = lss;
13088	gfc_mark_ss_chain_used (lss, 1);
13089	}
13090
13091	gfc_conv_expr (se: &argse[n], expr: arg[n]);
13092
13093	if (loop)
13094	lss = argse[n].ss;
13095	}
13096
13097	from = argse[0].expr;
13098	frompos = argse[1].expr;
13099	len = argse[2].expr;
13100	to = argse[3].expr;
13101	topos = argse[4].expr;
13102
13103	/* The type of the result (TO). */
13104	type = TREE_TYPE (to);
13105	bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13106
13107	/* Optionally generate code for runtime argument check. */
13108	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13109	{
13110	tree nbits, below, ccond;
13111	tree fp = fold_convert (long_integer_type_node, frompos);
13112	tree ln = fold_convert (long_integer_type_node, len);
13113	tree tp = fold_convert (long_integer_type_node, topos);
13114	below = fold_build2_loc (input_location, LT_EXPR,
13115	logical_type_node, frompos,
13116	build_int_cst (TREE_TYPE (frompos), 0));
13117	above = fold_build2_loc (input_location, GT_EXPR,
13118	logical_type_node, frompos,
13119	fold_convert (TREE_TYPE (frompos), bitsize));
13120	ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13121	logical_type_node, below, above);
13122	gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13123	&arg[1]->where,
13124	"FROMPOS argument (%ld) out of range 0:%d "
13125	"in intrinsic MVBITS", fp, bitsize);
13126	below = fold_build2_loc (input_location, LT_EXPR,
13127	logical_type_node, len,
13128	build_int_cst (TREE_TYPE (len), 0));
13129	above = fold_build2_loc (input_location, GT_EXPR,
13130	logical_type_node, len,
13131	fold_convert (TREE_TYPE (len), bitsize));
13132	ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13133	logical_type_node, below, above);
13134	gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13135	&arg[2]->where,
13136	"LEN argument (%ld) out of range 0:%d "
13137	"in intrinsic MVBITS", ln, bitsize);
13138	below = fold_build2_loc (input_location, LT_EXPR,
13139	logical_type_node, topos,
13140	build_int_cst (TREE_TYPE (topos), 0));
13141	above = fold_build2_loc (input_location, GT_EXPR,
13142	logical_type_node, topos,
13143	fold_convert (TREE_TYPE (topos), bitsize));
13144	ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13145	logical_type_node, below, above);
13146	gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13147	&arg[4]->where,
13148	"TOPOS argument (%ld) out of range 0:%d "
13149	"in intrinsic MVBITS", tp, bitsize);
13150
13151	/* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13152	integers. Additions below cannot overflow. */
13153	nbits = fold_convert (long_integer_type_node, bitsize);
13154	above = fold_build2_loc (input_location, PLUS_EXPR,
13155	long_integer_type_node, fp, ln);
13156	ccond = fold_build2_loc (input_location, GT_EXPR,
13157	logical_type_node, above, nbits);
13158	gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13159	&arg[1]->where,
13160	"FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13161	"in intrinsic MVBITS", fp, ln, bitsize);
13162	above = fold_build2_loc (input_location, PLUS_EXPR,
13163	long_integer_type_node, tp, ln);
13164	ccond = fold_build2_loc (input_location, GT_EXPR,
13165	logical_type_node, above, nbits);
13166	gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13167	&arg[4]->where,
13168	"TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13169	"in intrinsic MVBITS", tp, ln, bitsize);
13170	}
13171
13172	for (n = 0; n < 5; n++)
13173	{
13174	gfc_add_block_to_block (&se->pre, &argse[n].pre);
13175	gfc_add_block_to_block (&se->post, &argse[n].post);
13176	}
13177
13178	/* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13179	above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13180	len, fold_convert (TREE_TYPE (len), bitsize));
13181	mask1 = build_int_cst (type, -1);
13182	mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13183	build_int_cst (type, 1), len);
13184	mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13185	mask2, build_int_cst (type, 1));
13186	lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13187	above, mask1, mask2);
13188
13189	/* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13190	* For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13191	* not strictly necessary; artificial bits from rshift will be masked. */
13192	utype = unsigned_type_for (type);
13193	newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13194	fold_convert (utype, from), frompos);
13195	newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13196	fold_convert (type, newbits), lenmask);
13197	newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13198	newbits, topos);
13199
13200	/* oldbits = TO & (~(lenmask << TOPOS)). */
13201	oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13202	lenmask, topos);
13203	oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13204	oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13205
13206	/* TO = newbits | oldbits. */
13207	se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13208	oldbits, newbits);
13209
13210	/* Return the assignment. */
13211	se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13212	void_type_node, to, se->expr);
13213	}
13214
13215	/* Comes from trans-stmt.cc, but we don't want the whole header included. */
13216	extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13217	tree *stat, tree *errmsg, tree *errmsg_len);
13218
13219	static tree
13220	conv_intrinsic_move_alloc (gfc_code *code)
13221	{
13222	stmtblock_t block;
13223	gfc_expr *from_expr, *to_expr;
13224	gfc_se from_se, to_se;
13225	tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13226	bool coarray, from_is_class, from_is_scalar;
13227	gfc_actual_arglist *arg = code->ext.actual;
13228	sync_stat tmp_sync_stat = {.stat: nullptr, .errmsg: nullptr};
13229
13230	gfc_start_block (&block);
13231
13232	from_expr = arg->expr;
13233	arg = arg->next;
13234	to_expr = arg->expr;
13235	arg = arg->next;
13236
13237	while (arg)
13238	{
13239	if (arg->expr)
13240	{
13241	if (!strcmp (s1: "stat", s2: arg->name))
13242	tmp_sync_stat.stat = arg->expr;
13243	else if (!strcmp (s1: "errmsg", s2: arg->name))
13244	tmp_sync_stat.errmsg = arg->expr;
13245	}
13246	arg = arg->next;
13247	}
13248
13249	gfc_init_se (&from_se, NULL);
13250	gfc_init_se (&to_se, NULL);
13251
13252	gfc_trans_sync_stat (sync_stat: &tmp_sync_stat, se: &from_se, stat: &stat, errmsg: &errmsg, errmsg_len: &errmsg_len);
13253	if (stat != null_pointer_node)
13254	fin_label = gfc_build_label_decl (NULL_TREE);
13255
13256	gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13257	coarray = from_expr->corank != 0;
13258
13259	from_is_class = from_expr->ts.type == BT_CLASS;
13260	from_is_scalar = from_expr->rank == 0 && !coarray;
13261	if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13262	{
13263	from_se.want_pointer = 1;
13264	if (from_is_scalar)
13265	gfc_conv_expr (se: &from_se, expr: from_expr);
13266	else
13267	gfc_conv_expr_descriptor (&from_se, from_expr);
13268	if (from_is_class)
13269	from_tree = gfc_class_data_get (from_se.expr);
13270	else
13271	{
13272	gfc_symbol *vtab;
13273	from_tree = from_se.expr;
13274
13275	if (to_expr->ts.type == BT_CLASS)
13276	{
13277	vtab = gfc_find_vtab (&from_expr->ts);
13278	gcc_assert (vtab);
13279	from_se.expr = gfc_get_symbol_decl (vtab);
13280	}
13281	}
13282	gfc_add_block_to_block (&block, &from_se.pre);
13283
13284	to_se.want_pointer = 1;
13285	if (to_expr->rank == 0)
13286	gfc_conv_expr (se: &to_se, expr: to_expr);
13287	else
13288	gfc_conv_expr_descriptor (&to_se, to_expr);
13289	if (to_expr->ts.type == BT_CLASS)
13290	to_tree = gfc_class_data_get (to_se.expr);
13291	else
13292	to_tree = to_se.expr;
13293	gfc_add_block_to_block (&block, &to_se.pre);
13294
13295	/* Deallocate "to". */
13296	if (to_expr->rank == 0)
13297	{
13298	tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13299	true, to_expr, to_expr->ts,
13300	NULL_TREE, c: false, u: true,
13301	errmsg, errmsg_len);
13302	gfc_add_expr_to_block (&block, tmp);
13303	}
13304
13305	if (from_is_scalar)
13306	{
13307	/* Assign (_data) pointers. */
13308	gfc_add_modify_loc (input_location, &block, to_tree,
13309	fold_convert (TREE_TYPE (to_tree), from_tree));
13310
13311	/* Set "from" to NULL. */
13312	gfc_add_modify_loc (input_location, &block, from_tree,
13313	fold_convert (TREE_TYPE (from_tree),
13314	null_pointer_node));
13315
13316	gfc_add_block_to_block (&block, &from_se.post);
13317	}
13318	gfc_add_block_to_block (&block, &to_se.post);
13319
13320	/* Set _vptr. */
13321	if (to_expr->ts.type == BT_CLASS)
13322	{
13323	gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13324	if (from_is_class)
13325	gfc_reset_vptr (&block, from_expr);
13326	if (UNLIMITED_POLY (to_expr))
13327	{
13328	tree to_len = gfc_class_len_get (to_se.class_container);
13329	tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13330	? from_se.string_length
13331	: size_zero_node;
13332	gfc_add_modify_loc (input_location, &block, to_len,
13333	fold_convert (TREE_TYPE (to_len), tmp));
13334	}
13335	}
13336
13337	if (from_is_scalar)
13338	{
13339	if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13340	{
13341	gfc_add_modify_loc (input_location, &block, to_se.string_length,
13342	fold_convert (TREE_TYPE (to_se.string_length),
13343	from_se.string_length));
13344	if (from_expr->ts.deferred)
13345	gfc_add_modify_loc (
13346	input_location, &block, from_se.string_length,
13347	build_int_cst (TREE_TYPE (from_se.string_length), 0));
13348	}
13349	if (UNLIMITED_POLY (from_expr))
13350	gfc_reset_len (&block, from_expr);
13351
13352	return gfc_finish_block (&block);
13353	}
13354
13355	gfc_init_se (&to_se, NULL);
13356	gfc_init_se (&from_se, NULL);
13357	}
13358
13359	/* Deallocate "to". */
13360	if (from_expr->rank == 0)
13361	{
13362	to_se.want_coarray = 1;
13363	from_se.want_coarray = 1;
13364	}
13365	gfc_conv_expr_descriptor (&to_se, to_expr);
13366	gfc_conv_expr_descriptor (&from_se, from_expr);
13367	gfc_add_block_to_block (&block, &to_se.pre);
13368	gfc_add_block_to_block (&block, &from_se.pre);
13369
13370	/* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13371	is an image control "statement", cf. IR F08/0040 in 12-006A. */
13372	if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13373	{
13374	tree cond;
13375
13376	tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13377	fin_label, true, to_expr,
13378	GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13379	NULL_TREE, NULL_TREE,
13380	c: gfc_conv_descriptor_token (to_se.expr),
13381	u: true);
13382	gfc_add_expr_to_block (&block, tmp);
13383
13384	tmp = gfc_conv_descriptor_data_get (to_se.expr);
13385	cond = fold_build2_loc (input_location, EQ_EXPR,
13386	logical_type_node, tmp,
13387	fold_convert (TREE_TYPE (tmp),
13388	null_pointer_node));
13389	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13390	3, null_pointer_node, null_pointer_node,
13391	integer_zero_node);
13392
13393	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13394	tmp, build_empty_stmt (input_location));
13395	gfc_add_expr_to_block (&block, tmp);
13396	}
13397	else
13398	{
13399	if (to_expr->ts.type == BT_DERIVED
13400	&& to_expr->ts.u.derived->attr.alloc_comp)
13401	{
13402	tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13403	to_se.expr, to_expr->rank);
13404	gfc_add_expr_to_block (&block, tmp);
13405	}
13406
13407	tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13408	fin_label, true, to_expr,
13409	GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13410	NULL_TREE, NULL_TREE, u: true);
13411	gfc_add_expr_to_block (&block, tmp);
13412	}
13413
13414	/* Copy the array descriptor data. */
13415	gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13416
13417	/* Set "from" to NULL. */
13418	tmp = gfc_conv_descriptor_data_get (from_se.expr);
13419	gfc_add_modify_loc (input_location, &block, tmp,
13420	fold_convert (TREE_TYPE (tmp), null_pointer_node));
13421
13422	if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13423	{
13424	/* Copy the array descriptor data has overwritten the to-token and cleared
13425	from.data. Now also clear the from.token. */
13426	gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13427	null_pointer_node);
13428	}
13429
13430	if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13431	{
13432	gfc_add_modify_loc (input_location, &block, to_se.string_length,
13433	fold_convert (TREE_TYPE (to_se.string_length),
13434	from_se.string_length));
13435	if (from_expr->ts.deferred)
13436	gfc_add_modify_loc (input_location, &block, from_se.string_length,
13437	build_int_cst (TREE_TYPE (from_se.string_length), 0));
13438	}
13439	if (fin_label)
13440	gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13441
13442	gfc_add_block_to_block (&block, &to_se.post);
13443	gfc_add_block_to_block (&block, &from_se.post);
13444
13445	return gfc_finish_block (&block);
13446	}
13447
13448
13449	tree
13450	gfc_conv_intrinsic_subroutine (gfc_code *code)
13451	{
13452	tree res;
13453
13454	gcc_assert (code->resolved_isym);
13455
13456	switch (code->resolved_isym->id)
13457	{
13458	case GFC_ISYM_MOVE_ALLOC:
13459	res = conv_intrinsic_move_alloc (code);
13460	break;
13461
13462	case GFC_ISYM_ATOMIC_CAS:
13463	res = conv_intrinsic_atomic_cas (code);
13464	break;
13465
13466	case GFC_ISYM_ATOMIC_ADD:
13467	case GFC_ISYM_ATOMIC_AND:
13468	case GFC_ISYM_ATOMIC_DEF:
13469	case GFC_ISYM_ATOMIC_OR:
13470	case GFC_ISYM_ATOMIC_XOR:
13471	case GFC_ISYM_ATOMIC_FETCH_ADD:
13472	case GFC_ISYM_ATOMIC_FETCH_AND:
13473	case GFC_ISYM_ATOMIC_FETCH_OR:
13474	case GFC_ISYM_ATOMIC_FETCH_XOR:
13475	res = conv_intrinsic_atomic_op (code);
13476	break;
13477
13478	case GFC_ISYM_ATOMIC_REF:
13479	res = conv_intrinsic_atomic_ref (code);
13480	break;
13481
13482	case GFC_ISYM_EVENT_QUERY:
13483	res = conv_intrinsic_event_query (code);
13484	break;
13485
13486	case GFC_ISYM_C_F_POINTER:
13487	case GFC_ISYM_C_F_PROCPOINTER:
13488	res = conv_isocbinding_subroutine (code);
13489	break;
13490
13491	case GFC_ISYM_CAF_SEND:
13492	res = conv_caf_send_to_remote (code);
13493	break;
13494
13495	case GFC_ISYM_CAF_SENDGET:
13496	res = conv_caf_sendget (code);
13497	break;
13498
13499	case GFC_ISYM_CO_BROADCAST:
13500	case GFC_ISYM_CO_MIN:
13501	case GFC_ISYM_CO_MAX:
13502	case GFC_ISYM_CO_REDUCE:
13503	case GFC_ISYM_CO_SUM:
13504	res = conv_co_collective (code);
13505	break;
13506
13507	case GFC_ISYM_FREE:
13508	res = conv_intrinsic_free (code);
13509	break;
13510
13511	case GFC_ISYM_FSTAT:
13512	case GFC_ISYM_LSTAT:
13513	case GFC_ISYM_STAT:
13514	res = conv_intrinsic_fstat_lstat_stat_sub (code);
13515	break;
13516
13517	case GFC_ISYM_RANDOM_INIT:
13518	res = conv_intrinsic_random_init (code);
13519	break;
13520
13521	case GFC_ISYM_KILL:
13522	res = conv_intrinsic_kill_sub (code);
13523	break;
13524
13525	case GFC_ISYM_MVBITS:
13526	res = NULL_TREE;
13527	break;
13528
13529	case GFC_ISYM_SYSTEM_CLOCK:
13530	res = conv_intrinsic_system_clock (code);
13531	break;
13532
13533	case GFC_ISYM_SPLIT:
13534	res = conv_intrinsic_split (code);
13535	break;
13536
13537	default:
13538	res = NULL_TREE;
13539	break;
13540	}
13541
13542	return res;
13543	}
13544
13545	#include "gt-fortran-trans-intrinsic.h"
13546