1	/* Intrinsic translation
2	Copyright (C) 2002-2023 Free Software Foundation, Inc.
3	Contributed by Paul Brook <paul@nowt.org>
4	and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6	This file is part of GCC.
7
8	GCC is free software; you can redistribute it and/or modify it under
9	the terms of the GNU General Public License as published by the Free
10	Software Foundation; either version 3, or (at your option) any later
11	version.
12
13	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14	WARRANTY; without even the implied warranty of MERCHANTABILITY or
15	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16	for more details.
17
18	You should have received a copy of the GNU General Public License
19	along with GCC; see the file COPYING3. If not see
20	<http://www.gnu.org/licenses/>. */
21
22	/* trans-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
46	/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
47
48	/* This maps Fortran intrinsic math functions to external library or GCC
49	builtin functions. */
50	typedef struct GTY(()) gfc_intrinsic_map_t {
51	/* The explicit enum is required to work around inadequacies in the
52	garbage collection/gengtype parsing mechanism. */
53	enum gfc_isym_id id;
54
55	/* Enum value from the "language-independent", aka C-centric, part
56	of gcc, or END_BUILTINS of no such value set. */
57	enum built_in_function float_built_in;
58	enum built_in_function double_built_in;
59	enum built_in_function long_double_built_in;
60	enum built_in_function complex_float_built_in;
61	enum built_in_function complex_double_built_in;
62	enum built_in_function complex_long_double_built_in;
63
64	/* True if the naming pattern is to prepend "c" for complex and
65	append "f" for kind=4. False if the naming pattern is to
66	prepend "_gfortran_" and append "[rc](4|8|10|16)". */
67	bool libm_name;
68
69	/* True if a complex version of the function exists. */
70	bool complex_available;
71
72	/* True if the function should be marked const. */
73	bool is_constant;
74
75	/* The base library name of this function. */
76	const char *name;
77
78	/* Cache decls created for the various operand types. */
79	tree real4_decl;
80	tree real8_decl;
81	tree real10_decl;
82	tree real16_decl;
83	tree complex4_decl;
84	tree complex8_decl;
85	tree complex10_decl;
86	tree complex16_decl;
87	}
88	gfc_intrinsic_map_t;
89
90	/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91	defines complex variants of all of the entries in mathbuiltins.def
92	except for atan2. */
93	#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94	{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95	BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
96	true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
98
99	#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100	{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101	BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
102	BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
103	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
104
105	#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
106	{ GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107	END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108	false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
109	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
110
111	#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
112	{ GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
113	BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114	true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
115	NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
116
117	static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
118	{
119	/* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
120	DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
121	to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
122	#include "mathbuiltins.def"
123
124	/* Functions in libgfortran. */
125	LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
126	LIB_FUNCTION (SIND, "sind", false),
127	LIB_FUNCTION (COSD, "cosd", false),
128	LIB_FUNCTION (TAND, "tand", false),
129
130	/* End the list. */
131	LIB_FUNCTION (NONE, NULL, false)
132
133	};
134	#undef OTHER_BUILTIN
135	#undef LIB_FUNCTION
136	#undef DEFINE_MATH_BUILTIN
137	#undef DEFINE_MATH_BUILTIN_C
138
139
140	enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
141
142
143	/* Find the correct variant of a given builtin from its argument. */
144	static tree
145	builtin_decl_for_precision (enum built_in_function base_built_in,
146	int precision)
147	{
148	enum built_in_function i = END_BUILTINS;
149
150	gfc_intrinsic_map_t *m;
151	for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
152	;
153
154	if (precision == TYPE_PRECISION (float_type_node))
155	i = m->float_built_in;
156	else if (precision == TYPE_PRECISION (double_type_node))
157	i = m->double_built_in;
158	else if (precision == TYPE_PRECISION (long_double_type_node)
159	&& (!gfc_real16_is_float128
160	|| long_double_type_node != gfc_float128_type_node))
161	i = m->long_double_built_in;
162	else if (precision == TYPE_PRECISION (gfc_float128_type_node))
163	{
164	/* Special treatment, because it is not exactly a built-in, but
165	a library function. */
166	return m->real16_decl;
167	}
168
169	return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (fncode: i));
170	}
171
172
173	tree
174	gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
175	int kind)
176	{
177	int i = gfc_validate_kind (BT_REAL, kind, false);
178
179	if (gfc_real_kinds[i].c_float128)
180	{
181	/* For _Float128, the story is a bit different, because we return
182	a decl to a library function rather than a built-in. */
183	gfc_intrinsic_map_t *m;
184	for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
185	;
186
187	return m->real16_decl;
188	}
189
190	return builtin_decl_for_precision (base_built_in: double_built_in,
191	precision: gfc_real_kinds[i].mode_precision);
192	}
193
194
195	/* Evaluate the arguments to an intrinsic function. The value
196	of NARGS may be less than the actual number of arguments in EXPR
197	to allow optional "KIND" arguments that are not included in the
198	generated code to be ignored. */
199
200	static void
201	gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
202	tree *argarray, int nargs)
203	{
204	gfc_actual_arglist *actual;
205	gfc_expr *e;
206	gfc_intrinsic_arg *formal;
207	gfc_se argse;
208	int curr_arg;
209
210	formal = expr->value.function.isym->formal;
211	actual = expr->value.function.actual;
212
213	for (curr_arg = 0; curr_arg < nargs; curr_arg++,
214	actual = actual->next,
215	formal = formal ? formal->next : NULL)
216	{
217	gcc_assert (actual);
218	e = actual->expr;
219	/* Skip omitted optional arguments. */
220	if (!e)
221	{
222	--curr_arg;
223	continue;
224	}
225
226	/* Evaluate the parameter. This will substitute scalarized
227	references automatically. */
228	gfc_init_se (&argse, se);
229
230	if (e->ts.type == BT_CHARACTER)
231	{
232	gfc_conv_expr (se: &argse, expr: e);
233	gfc_conv_string_parameter (se: &argse);
234	argarray[curr_arg++] = argse.string_length;
235	gcc_assert (curr_arg < nargs);
236	}
237	else
238	gfc_conv_expr_val (se: &argse, expr: e);
239
240	/* If an optional argument is itself an optional dummy argument,
241	check its presence and substitute a null if absent. */
242	if (e->expr_type == EXPR_VARIABLE
243	&& e->symtree->n.sym->attr.optional
244	&& formal
245	&& formal->optional)
246	gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
247
248	gfc_add_block_to_block (&se->pre, &argse.pre);
249	gfc_add_block_to_block (&se->post, &argse.post);
250	argarray[curr_arg] = argse.expr;
251	}
252	}
253
254	/* Count the number of actual arguments to the intrinsic function EXPR
255	including any "hidden" string length arguments. */
256
257	static unsigned int
258	gfc_intrinsic_argument_list_length (gfc_expr *expr)
259	{
260	int n = 0;
261	gfc_actual_arglist *actual;
262
263	for (actual = expr->value.function.actual; actual; actual = actual->next)
264	{
265	if (!actual->expr)
266	continue;
267
268	if (actual->expr->ts.type == BT_CHARACTER)
269	n += 2;
270	else
271	n++;
272	}
273
274	return n;
275	}
276
277
278	/* Conversions between different types are output by the frontend as
279	intrinsic functions. We implement these directly with inline code. */
280
281	static void
282	gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
283	{
284	tree type;
285	tree *args;
286	int nargs;
287
288	nargs = gfc_intrinsic_argument_list_length (expr);
289	args = XALLOCAVEC (tree, nargs);
290
291	/* Evaluate all the arguments passed. Whilst we're only interested in the
292	first one here, there are other parts of the front-end that assume this
293	and will trigger an ICE if it's not the case. */
294	type = gfc_typenode_for_spec (&expr->ts);
295	gcc_assert (expr->value.function.actual->expr);
296	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
297
298	/* Conversion between character kinds involves a call to a library
299	function. */
300	if (expr->ts.type == BT_CHARACTER)
301	{
302	tree fndecl, var, addr, tmp;
303
304	if (expr->ts.kind == 1
305	&& expr->value.function.actual->expr->ts.kind == 4)
306	fndecl = gfor_fndecl_convert_char4_to_char1;
307	else if (expr->ts.kind == 4
308	&& expr->value.function.actual->expr->ts.kind == 1)
309	fndecl = gfor_fndecl_convert_char1_to_char4;
310	else
311	gcc_unreachable ();
312
313	/* Create the variable storing the converted value. */
314	type = gfc_get_pchar_type (expr->ts.kind);
315	var = gfc_create_var (type, "str");
316	addr = gfc_build_addr_expr (build_pointer_type (type), var);
317
318	/* Call the library function that will perform the conversion. */
319	gcc_assert (nargs >= 2);
320	tmp = build_call_expr_loc (input_location,
321	fndecl, 3, addr, args[0], args[1]);
322	gfc_add_expr_to_block (&se->pre, tmp);
323
324	/* Free the temporary afterwards. */
325	tmp = gfc_call_free (var);
326	gfc_add_expr_to_block (&se->post, tmp);
327
328	se->expr = var;
329	se->string_length = args[0];
330
331	return;
332	}
333
334	/* Conversion from complex to non-complex involves taking the real
335	component of the value. */
336	if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
337	&& expr->ts.type != BT_COMPLEX)
338	{
339	tree artype;
340
341	artype = TREE_TYPE (TREE_TYPE (args[0]));
342	args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
343	args[0]);
344	}
345
346	se->expr = convert (type, args[0]);
347	}
348
349	/* This is needed because the gcc backend only implements
350	FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
351	FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
352	Similarly for CEILING. */
353
354	static tree
355	build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
356	{
357	tree tmp;
358	tree cond;
359	tree argtype;
360	tree intval;
361
362	argtype = TREE_TYPE (arg);
363	arg = gfc_evaluate_now (arg, pblock);
364
365	intval = convert (type, arg);
366	intval = gfc_evaluate_now (intval, pblock);
367
368	tmp = convert (argtype, intval);
369	cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
370	logical_type_node, tmp, arg);
371
372	tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
373	intval, build_int_cst (type, 1));
374	tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
375	return tmp;
376	}
377
378
379	/* Round to nearest integer, away from zero. */
380
381	static tree
382	build_round_expr (tree arg, tree restype)
383	{
384	tree argtype;
385	tree fn;
386	int argprec, resprec;
387
388	argtype = TREE_TYPE (arg);
389	argprec = TYPE_PRECISION (argtype);
390	resprec = TYPE_PRECISION (restype);
391
392	/* Depending on the type of the result, choose the int intrinsic (iround,
393	available only as a builtin, therefore cannot use it for _Float128), long
394	int intrinsic (lround family) or long long intrinsic (llround). If we
395	don't have an appropriate function that converts directly to the integer
396	type (such as kind == 16), just use ROUND, and then convert the result to
397	an integer. We might also need to convert the result afterwards. */
398	if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
399	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_IROUND, precision: argprec);
400	else if (resprec <= LONG_TYPE_SIZE)
401	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_LROUND, precision: argprec);
402	else if (resprec <= LONG_LONG_TYPE_SIZE)
403	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_LLROUND, precision: argprec);
404	else if (resprec >= argprec)
405	fn = builtin_decl_for_precision (base_built_in: BUILT_IN_ROUND, precision: argprec);
406	else
407	gcc_unreachable ();
408
409	return convert (restype, build_call_expr_loc (input_location,
410	fn, 1, arg));
411	}
412
413
414	/* Convert a real to an integer using a specific rounding mode.
415	Ideally we would just build the corresponding GENERIC node,
416	however the RTL expander only actually supports FIX_TRUNC_EXPR. */
417
418	static tree
419	build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
420	enum rounding_mode op)
421	{
422	switch (op)
423	{
424	case RND_FLOOR:
425	return build_fixbound_expr (pblock, arg, type, up: 0);
426
427	case RND_CEIL:
428	return build_fixbound_expr (pblock, arg, type, up: 1);
429
430	case RND_ROUND:
431	return build_round_expr (arg, restype: type);
432
433	case RND_TRUNC:
434	return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
435
436	default:
437	gcc_unreachable ();
438	}
439	}
440
441
442	/* Round a real value using the specified rounding mode.
443	We use a temporary integer of that same kind size as the result.
444	Values larger than those that can be represented by this kind are
445	unchanged, as they will not be accurate enough to represent the
446	rounding.
447	huge = HUGE (KIND (a))
448	aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449	*/
450
451	static void
452	gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
453	{
454	tree type;
455	tree itype;
456	tree arg[2];
457	tree tmp;
458	tree cond;
459	tree decl;
460	mpfr_t huge;
461	int n, nargs;
462	int kind;
463
464	kind = expr->ts.kind;
465	nargs = gfc_intrinsic_argument_list_length (expr);
466
467	decl = NULL_TREE;
468	/* We have builtin functions for some cases. */
469	switch (op)
470	{
471	case RND_ROUND:
472	decl = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_ROUND, kind);
473	break;
474
475	case RND_TRUNC:
476	decl = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_TRUNC, kind);
477	break;
478
479	default:
480	gcc_unreachable ();
481	}
482
483	/* Evaluate the argument. */
484	gcc_assert (expr->value.function.actual->expr);
485	gfc_conv_intrinsic_function_args (se, expr, argarray: arg, nargs);
486
487	/* Use a builtin function if one exists. */
488	if (decl != NULL_TREE)
489	{
490	se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
491	return;
492	}
493
494	/* This code is probably redundant, but we'll keep it lying around just
495	in case. */
496	type = gfc_typenode_for_spec (&expr->ts);
497	arg[0] = gfc_evaluate_now (arg[0], &se->pre);
498
499	/* Test if the value is too large to handle sensibly. */
500	gfc_set_model_kind (kind);
501	mpfr_init (huge);
502	n = gfc_validate_kind (BT_INTEGER, kind, false);
503	mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
504	tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
505	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
506	tmp);
507
508	mpfr_neg (huge, huge, GFC_RND_MODE);
509	tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
510	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
511	tmp);
512	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
513	cond, tmp);
514	itype = gfc_get_int_type (kind);
515
516	tmp = build_fix_expr (pblock: &se->pre, arg: arg[0], type: itype, op);
517	tmp = convert (type, tmp);
518	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
519	arg[0]);
520	mpfr_clear (huge);
521	}
522
523
524	/* Convert to an integer using the specified rounding mode. */
525
526	static void
527	gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
528	{
529	tree type;
530	tree *args;
531	int nargs;
532
533	nargs = gfc_intrinsic_argument_list_length (expr);
534	args = XALLOCAVEC (tree, nargs);
535
536	/* Evaluate the argument, we process all arguments even though we only
537	use the first one for code generation purposes. */
538	type = gfc_typenode_for_spec (&expr->ts);
539	gcc_assert (expr->value.function.actual->expr);
540	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
541
542	if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
543	{
544	/* Conversion to a different integer kind. */
545	se->expr = convert (type, args[0]);
546	}
547	else
548	{
549	/* Conversion from complex to non-complex involves taking the real
550	component of the value. */
551	if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
552	&& expr->ts.type != BT_COMPLEX)
553	{
554	tree artype;
555
556	artype = TREE_TYPE (TREE_TYPE (args[0]));
557	args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
558	args[0]);
559	}
560
561	se->expr = build_fix_expr (pblock: &se->pre, arg: args[0], type, op);
562	}
563	}
564
565
566	/* Get the imaginary component of a value. */
567
568	static void
569	gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
570	{
571	tree arg;
572
573	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
574	se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
575	TREE_TYPE (TREE_TYPE (arg)), arg);
576	}
577
578
579	/* Get the complex conjugate of a value. */
580
581	static void
582	gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
583	{
584	tree arg;
585
586	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
587	se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
588	}
589
590
591
592	static tree
593	define_quad_builtin (const char *name, tree type, bool is_const)
594	{
595	tree fndecl;
596	fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
597	type);
598
599	/* Mark the decl as external. */
600	DECL_EXTERNAL (fndecl) = 1;
601	TREE_PUBLIC (fndecl) = 1;
602
603	/* Mark it __attribute__((const)). */
604	TREE_READONLY (fndecl) = is_const;
605
606	rest_of_decl_compilation (fndecl, 1, 0);
607
608	return fndecl;
609	}
610
611	/* Add SIMD attribute for FNDECL built-in if the built-in
612	name is in VECTORIZED_BUILTINS. */
613
614	static void
615	add_simd_flag_for_built_in (tree fndecl)
616	{
617	if (gfc_vectorized_builtins == NULL
618	|| fndecl == NULL_TREE)
619	return;
620
621	const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
622	int *clauses = gfc_vectorized_builtins->get (k: name);
623	if (clauses)
624	{
625	for (unsigned i = 0; i < 3; i++)
626	if (*clauses & (1 << i))
627	{
628	gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
629	tree omp_clause = NULL_TREE;
630	if (simd_type == SIMD_NONE)
631	; /* No SIMD clause. */
632	else
633	{
634	omp_clause_code code
635	= (simd_type == SIMD_INBRANCH
636	? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
637	omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
638	omp_clause = build_tree_list (NULL_TREE, omp_clause);
639	}
640
641	DECL_ATTRIBUTES (fndecl)
642	= tree_cons (get_identifier ("omp declare simd"), omp_clause,
643	DECL_ATTRIBUTES (fndecl));
644	}
645	}
646	}
647
648	/* Set SIMD attribute to all built-in functions that are mentioned
649	in gfc_vectorized_builtins vector. */
650
651	void
652	gfc_adjust_builtins (void)
653	{
654	gfc_intrinsic_map_t *m;
655	for (m = gfc_intrinsic_map;
656	m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
657	{
658	add_simd_flag_for_built_in (fndecl: m->real4_decl);
659	add_simd_flag_for_built_in (fndecl: m->complex4_decl);
660	add_simd_flag_for_built_in (fndecl: m->real8_decl);
661	add_simd_flag_for_built_in (fndecl: m->complex8_decl);
662	add_simd_flag_for_built_in (fndecl: m->real10_decl);
663	add_simd_flag_for_built_in (fndecl: m->complex10_decl);
664	add_simd_flag_for_built_in (fndecl: m->real16_decl);
665	add_simd_flag_for_built_in (fndecl: m->complex16_decl);
666	add_simd_flag_for_built_in (fndecl: m->real16_decl);
667	add_simd_flag_for_built_in (fndecl: m->complex16_decl);
668	}
669
670	/* Release all strings. */
671	if (gfc_vectorized_builtins != NULL)
672	{
673	for (hash_map<nofree_string_hash, int>::iterator it
674	= gfc_vectorized_builtins->begin ();
675	it != gfc_vectorized_builtins->end (); ++it)
676	free (CONST_CAST (char *, (*it).first));
677
678	delete gfc_vectorized_builtins;
679	gfc_vectorized_builtins = NULL;
680	}
681	}
682
683	/* Initialize function decls for library functions. The external functions
684	are created as required. Builtin functions are added here. */
685
686	void
687	gfc_build_intrinsic_lib_fndecls (void)
688	{
689	gfc_intrinsic_map_t *m;
690	tree quad_decls[END_BUILTINS + 1];
691
692	if (gfc_real16_is_float128)
693	{
694	/* If we have soft-float types, we create the decls for their
695	C99-like library functions. For now, we only handle _Float128
696	q-suffixed or IEC 60559 f128-suffixed functions. */
697
698	tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
699	tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
700
701	memset (s: quad_decls, c: 0, n: sizeof(tree) * (END_BUILTINS + 1));
702
703	type = gfc_float128_type_node;
704	complex_type = gfc_complex_float128_type_node;
705	/* type (*) (type) */
706	func_1 = build_function_type_list (type, type, NULL_TREE);
707	/* int (*) (type) */
708	func_iround = build_function_type_list (integer_type_node,
709	type, NULL_TREE);
710	/* long (*) (type) */
711	func_lround = build_function_type_list (long_integer_type_node,
712	type, NULL_TREE);
713	/* long long (*) (type) */
714	func_llround = build_function_type_list (long_long_integer_type_node,
715	type, NULL_TREE);
716	/* type (*) (type, type) */
717	func_2 = build_function_type_list (type, type, type, NULL_TREE);
718	/* type (*) (type, type, type) */
719	func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
720	/* type (*) (type, &int) */
721	func_frexp
722	= build_function_type_list (type,
723	type,
724	build_pointer_type (integer_type_node),
725	NULL_TREE);
726	/* type (*) (type, int) */
727	func_scalbn = build_function_type_list (type,
728	type, integer_type_node, NULL_TREE);
729	/* type (*) (complex type) */
730	func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
731	/* complex type (*) (complex type, complex type) */
732	func_cpow
733	= build_function_type_list (complex_type,
734	complex_type, complex_type, NULL_TREE);
735
736	#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
737	#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
738	#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
739
740	/* Only these built-ins are actually needed here. These are used directly
741	from the code, when calling builtin_decl_for_precision() or
742	builtin_decl_for_float_type(). The others are all constructed by
743	gfc_get_intrinsic_lib_fndecl(). */
744	#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
745	quad_decls[BUILT_IN_ ## ID] \
746	= define_quad_builtin (gfc_real16_use_iec_60559 \
747	? NAME "f128" : NAME "q", func_ ## TYPE, \
748	CONST);
749
750	#include "mathbuiltins.def"
751
752	#undef OTHER_BUILTIN
753	#undef LIB_FUNCTION
754	#undef DEFINE_MATH_BUILTIN
755	#undef DEFINE_MATH_BUILTIN_C
756
757	/* There is one built-in we defined manually, because it gets called
758	with builtin_decl_for_precision() or builtin_decl_for_float_type()
759	even though it is not an OTHER_BUILTIN: it is SQRT. */
760	quad_decls[BUILT_IN_SQRT]
761	= define_quad_builtin (name: gfc_real16_use_iec_60559
762	? "sqrtf128" : "sqrtq", type: func_1, is_const: true);
763	}
764
765	/* Add GCC builtin functions. */
766	for (m = gfc_intrinsic_map;
767	m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
768	{
769	if (m->float_built_in != END_BUILTINS)
770	m->real4_decl = builtin_decl_explicit (fncode: m->float_built_in);
771	if (m->complex_float_built_in != END_BUILTINS)
772	m->complex4_decl = builtin_decl_explicit (fncode: m->complex_float_built_in);
773	if (m->double_built_in != END_BUILTINS)
774	m->real8_decl = builtin_decl_explicit (fncode: m->double_built_in);
775	if (m->complex_double_built_in != END_BUILTINS)
776	m->complex8_decl = builtin_decl_explicit (fncode: m->complex_double_built_in);
777
778	/* If real(kind=10) exists, it is always long double. */
779	if (m->long_double_built_in != END_BUILTINS)
780	m->real10_decl = builtin_decl_explicit (fncode: m->long_double_built_in);
781	if (m->complex_long_double_built_in != END_BUILTINS)
782	m->complex10_decl
783	= builtin_decl_explicit (fncode: m->complex_long_double_built_in);
784
785	if (!gfc_real16_is_float128)
786	{
787	if (m->long_double_built_in != END_BUILTINS)
788	m->real16_decl = builtin_decl_explicit (fncode: m->long_double_built_in);
789	if (m->complex_long_double_built_in != END_BUILTINS)
790	m->complex16_decl
791	= builtin_decl_explicit (fncode: m->complex_long_double_built_in);
792	}
793	else if (quad_decls[m->double_built_in] != NULL_TREE)
794	{
795	/* Quad-precision function calls are constructed when first
796	needed by builtin_decl_for_precision(), except for those
797	that will be used directly (define by OTHER_BUILTIN). */
798	m->real16_decl = quad_decls[m->double_built_in];
799	}
800	else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
801	{
802	/* Same thing for the complex ones. */
803	m->complex16_decl = quad_decls[m->double_built_in];
804	}
805	}
806	}
807
808
809	/* Create a fndecl for a simple intrinsic library function. */
810
811	static tree
812	gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
813	{
814	tree type;
815	vec<tree, va_gc> *argtypes;
816	tree fndecl;
817	gfc_actual_arglist *actual;
818	tree *pdecl;
819	gfc_typespec *ts;
820	char name[GFC_MAX_SYMBOL_LEN + 3];
821
822	ts = &expr->ts;
823	if (ts->type == BT_REAL)
824	{
825	switch (ts->kind)
826	{
827	case 4:
828	pdecl = &m->real4_decl;
829	break;
830	case 8:
831	pdecl = &m->real8_decl;
832	break;
833	case 10:
834	pdecl = &m->real10_decl;
835	break;
836	case 16:
837	pdecl = &m->real16_decl;
838	break;
839	default:
840	gcc_unreachable ();
841	}
842	}
843	else if (ts->type == BT_COMPLEX)
844	{
845	gcc_assert (m->complex_available);
846
847	switch (ts->kind)
848	{
849	case 4:
850	pdecl = &m->complex4_decl;
851	break;
852	case 8:
853	pdecl = &m->complex8_decl;
854	break;
855	case 10:
856	pdecl = &m->complex10_decl;
857	break;
858	case 16:
859	pdecl = &m->complex16_decl;
860	break;
861	default:
862	gcc_unreachable ();
863	}
864	}
865	else
866	gcc_unreachable ();
867
868	if (*pdecl)
869	return *pdecl;
870
871	if (m->libm_name)
872	{
873	int n = gfc_validate_kind (BT_REAL, ts->kind, false);
874	if (gfc_real_kinds[n].c_float)
875	snprintf (s: name, maxlen: sizeof (name), format: "%s%s%s",
876	ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
877	else if (gfc_real_kinds[n].c_double)
878	snprintf (s: name, maxlen: sizeof (name), format: "%s%s",
879	ts->type == BT_COMPLEX ? "c" : "", m->name);
880	else if (gfc_real_kinds[n].c_long_double)
881	snprintf (s: name, maxlen: sizeof (name), format: "%s%s%s",
882	ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
883	else if (gfc_real_kinds[n].c_float128)
884	snprintf (s: name, maxlen: sizeof (name), format: "%s%s%s",
885	ts->type == BT_COMPLEX ? "c" : "", m->name,
886	gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
887	else
888	gcc_unreachable ();
889	}
890	else
891	{
892	snprintf (s: name, maxlen: sizeof (name), PREFIX ("%s_%c%d"), m->name,
893	ts->type == BT_COMPLEX ? 'c' : 'r',
894	gfc_type_abi_kind (ts));
895	}
896
897	argtypes = NULL;
898	for (actual = expr->value.function.actual; actual; actual = actual->next)
899	{
900	type = gfc_typenode_for_spec (&actual->expr->ts);
901	vec_safe_push (v&: argtypes, obj: type);
902	}
903	type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
904	fndecl = build_decl (input_location,
905	FUNCTION_DECL, get_identifier (name), type);
906
907	/* Mark the decl as external. */
908	DECL_EXTERNAL (fndecl) = 1;
909	TREE_PUBLIC (fndecl) = 1;
910
911	/* Mark it __attribute__((const)), if possible. */
912	TREE_READONLY (fndecl) = m->is_constant;
913
914	rest_of_decl_compilation (fndecl, 1, 0);
915
916	(*pdecl) = fndecl;
917	return fndecl;
918	}
919
920
921	/* Convert an intrinsic function into an external or builtin call. */
922
923	static void
924	gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
925	{
926	gfc_intrinsic_map_t *m;
927	tree fndecl;
928	tree rettype;
929	tree *args;
930	unsigned int num_args;
931	gfc_isym_id id;
932
933	id = expr->value.function.isym->id;
934	/* Find the entry for this function. */
935	for (m = gfc_intrinsic_map;
936	m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
937	{
938	if (id == m->id)
939	break;
940	}
941
942	if (m->id == GFC_ISYM_NONE)
943	{
944	gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
945	expr->value.function.name, id);
946	}
947
948	/* Get the decl and generate the call. */
949	num_args = gfc_intrinsic_argument_list_length (expr);
950	args = XALLOCAVEC (tree, num_args);
951
952	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
953	fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
954	rettype = TREE_TYPE (TREE_TYPE (fndecl));
955
956	fndecl = build_addr (fndecl);
957	se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
958	}
959
960
961	/* If bounds-checking is enabled, create code to verify at runtime that the
962	string lengths for both expressions are the same (needed for e.g. MERGE).
963	If bounds-checking is not enabled, does nothing. */
964
965	void
966	gfc_trans_same_strlen_check (const char* intr_name, locus* where,
967	tree a, tree b, stmtblock_t* target)
968	{
969	tree cond;
970	tree name;
971
972	/* If bounds-checking is disabled, do nothing. */
973	if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
974	return;
975
976	/* Compare the two string lengths. */
977	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
978
979	/* Output the runtime-check. */
980	name = gfc_build_cstring_const (intr_name);
981	name = gfc_build_addr_expr (pchar_type_node, name);
982	gfc_trans_runtime_check (true, false, cond, target, where,
983	"Unequal character lengths (%ld/%ld) in %s",
984	fold_convert (long_integer_type_node, a),
985	fold_convert (long_integer_type_node, b), name);
986	}
987
988
989	/* The EXPONENT(X) intrinsic function is translated into
990	int ret;
991	return isfinite(X) ? (frexp (X, &ret) , ret) : huge
992	so that if X is a NaN or infinity, the result is HUGE(0).
993	*/
994
995	static void
996	gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
997	{
998	tree arg, type, res, tmp, frexp, cond, huge;
999	int i;
1000
1001	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP,
1002	kind: expr->value.function.actual->expr->ts.kind);
1003
1004	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
1005	arg = gfc_evaluate_now (arg, &se->pre);
1006
1007	i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1008	huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1009	cond = build_call_expr_loc (input_location,
1010	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
1011	1, arg);
1012
1013	res = gfc_create_var (integer_type_node, NULL);
1014	tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1015	gfc_build_addr_expr (NULL_TREE, res));
1016	tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1017	tmp, res);
1018	se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1019	cond, tmp, huge);
1020
1021	type = gfc_typenode_for_spec (&expr->ts);
1022	se->expr = fold_convert (type, se->expr);
1023	}
1024
1025
1026	/* Fill in the following structure
1027	struct caf_vector_t {
1028	size_t nvec; // size of the vector
1029	union {
1030	struct {
1031	void *vector;
1032	int kind;
1033	} v;
1034	struct {
1035	ptrdiff_t lower_bound;
1036	ptrdiff_t upper_bound;
1037	ptrdiff_t stride;
1038	} triplet;
1039	} u;
1040	} */
1041
1042	static void
1043	conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
1044	tree lower, tree upper, tree stride,
1045	tree vector, int kind, tree nvec)
1046	{
1047	tree field, type, tmp;
1048
1049	desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
1050	type = TREE_TYPE (desc);
1051
1052	field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1053	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1054	desc, field, NULL_TREE);
1055	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
1056
1057	/* Access union. */
1058	field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1059	desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1060	desc, field, NULL_TREE);
1061	type = TREE_TYPE (desc);
1062
1063	/* Access the inner struct. */
1064	field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
1065	desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1066	desc, field, NULL_TREE);
1067	type = TREE_TYPE (desc);
1068
1069	if (vector != NULL_TREE)
1070	{
1071	/* Set vector and kind. */
1072	field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1073	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1074	desc, field, NULL_TREE);
1075	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
1076	field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1077	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1078	desc, field, NULL_TREE);
1079	gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
1080	}
1081	else
1082	{
1083	/* Set dim.lower/upper/stride. */
1084	field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1085	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1086	desc, field, NULL_TREE);
1087	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
1088
1089	field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1090	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1091	desc, field, NULL_TREE);
1092	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1093
1094	field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1095	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1096	desc, field, NULL_TREE);
1097	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1098	}
1099	}
1100
1101
1102	static tree
1103	conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1104	{
1105	gfc_se argse;
1106	tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1107	tree lbound, ubound, tmp;
1108	int i;
1109
1110	var = gfc_create_var (gfc_get_caf_vector_type (dim: ar->dimen), "vector");
1111
1112	for (i = 0; i < ar->dimen; i++)
1113	switch (ar->dimen_type[i])
1114	{
1115	case DIMEN_RANGE:
1116	if (ar->end[i])
1117	{
1118	gfc_init_se (&argse, NULL);
1119	gfc_conv_expr (se: &argse, expr: ar->end[i]);
1120	gfc_add_block_to_block (block, &argse.pre);
1121	upper = gfc_evaluate_now (argse.expr, block);
1122	}
1123	else
1124	upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1125	if (ar->stride[i])
1126	{
1127	gfc_init_se (&argse, NULL);
1128	gfc_conv_expr (se: &argse, expr: ar->stride[i]);
1129	gfc_add_block_to_block (block, &argse.pre);
1130	stride = gfc_evaluate_now (argse.expr, block);
1131	}
1132	else
1133	stride = gfc_index_one_node;
1134
1135	/* Fall through. */
1136	case DIMEN_ELEMENT:
1137	if (ar->start[i])
1138	{
1139	gfc_init_se (&argse, NULL);
1140	gfc_conv_expr (se: &argse, expr: ar->start[i]);
1141	gfc_add_block_to_block (block, &argse.pre);
1142	lower = gfc_evaluate_now (argse.expr, block);
1143	}
1144	else
1145	lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1146	if (ar->dimen_type[i] == DIMEN_ELEMENT)
1147	{
1148	upper = lower;
1149	stride = gfc_index_one_node;
1150	}
1151	vector = NULL_TREE;
1152	nvec = size_zero_node;
1153	conv_caf_vector_subscript_elem (block, i, desc: var, lower, upper, stride,
1154	vector, kind: 0, nvec);
1155	break;
1156
1157	case DIMEN_VECTOR:
1158	gfc_init_se (&argse, NULL);
1159	argse.descriptor_only = 1;
1160	gfc_conv_expr_descriptor (&argse, ar->start[i]);
1161	gfc_add_block_to_block (block, &argse.pre);
1162	vector = argse.expr;
1163	lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1164	ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1165	nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1166	tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1167	nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1168	TREE_TYPE (nvec), nvec, tmp);
1169	lower = gfc_index_zero_node;
1170	upper = gfc_index_zero_node;
1171	stride = gfc_index_zero_node;
1172	vector = gfc_conv_descriptor_data_get (vector);
1173	conv_caf_vector_subscript_elem (block, i, desc: var, lower, upper, stride,
1174	vector, kind: ar->start[i]->ts.kind, nvec);
1175	break;
1176	default:
1177	gcc_unreachable();
1178	}
1179	return gfc_build_addr_expr (NULL_TREE, var);
1180	}
1181
1182
1183	static tree
1184	compute_component_offset (tree field, tree type)
1185	{
1186	tree tmp;
1187	if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1188	&& !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1189	{
1190	tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1191	DECL_FIELD_BIT_OFFSET (field),
1192	bitsize_unit_node);
1193	return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1194	}
1195	else
1196	return DECL_FIELD_OFFSET (field);
1197	}
1198
1199
1200	static tree
1201	conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1202	{
1203	gfc_ref *ref = expr->ref, *last_comp_ref;
1204	tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1205	field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1206	start, end, stride, vector, nvec;
1207	gfc_se se;
1208	bool ref_static_array = false;
1209	tree last_component_ref_tree = NULL_TREE;
1210	int i, last_type_n;
1211
1212	if (expr->symtree)
1213	{
1214	last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1215	ref_static_array = !expr->symtree->n.sym->attr.allocatable
1216	&& !expr->symtree->n.sym->attr.pointer;
1217	}
1218
1219	/* Prevent uninit-warning. */
1220	reference_type = NULL_TREE;
1221
1222	/* Skip refs upto the first coarray-ref. */
1223	last_comp_ref = NULL;
1224	while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1225	{
1226	/* Remember the type of components skipped. */
1227	if (ref->type == REF_COMPONENT)
1228	last_comp_ref = ref;
1229	ref = ref->next;
1230	}
1231	/* When a component was skipped, get the type information of the last
1232	component ref, else get the type from the symbol. */
1233	if (last_comp_ref)
1234	{
1235	last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1236	last_type_n = last_comp_ref->u.c.component->ts.type;
1237	}
1238	else
1239	{
1240	last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1241	last_type_n = expr->symtree->n.sym->ts.type;
1242	}
1243
1244	while (ref)
1245	{
1246	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1247	&& ref->u.ar.dimen == 0)
1248	{
1249	/* Skip pure coindexes. */
1250	ref = ref->next;
1251	continue;
1252	}
1253	tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1254	reference_type = TREE_TYPE (tmp);
1255
1256	if (caf_ref == NULL_TREE)
1257	caf_ref = tmp;
1258
1259	/* Construct the chain of refs. */
1260	if (prev_caf_ref != NULL_TREE)
1261	{
1262	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1263	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1264	TREE_TYPE (field), prev_caf_ref, field,
1265	NULL_TREE);
1266	gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1267	tmp));
1268	}
1269	prev_caf_ref = tmp;
1270
1271	switch (ref->type)
1272	{
1273	case REF_COMPONENT:
1274	last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1275	last_type_n = ref->u.c.component->ts.type;
1276	/* Set the type of the ref. */
1277	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1278	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1279	TREE_TYPE (field), prev_caf_ref, field,
1280	NULL_TREE);
1281	gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1282	GFC_CAF_REF_COMPONENT));
1283
1284	/* Ref the c in union u. */
1285	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1286	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1287	TREE_TYPE (field), prev_caf_ref, field,
1288	NULL_TREE);
1289	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1290	inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1291	TREE_TYPE (field), tmp, field,
1292	NULL_TREE);
1293
1294	/* Set the offset. */
1295	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1296	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1297	TREE_TYPE (field), inner_struct, field,
1298	NULL_TREE);
1299	/* Computing the offset is somewhat harder. The bit_offset has to be
1300	taken into account. When the bit_offset in the field_decl is non-
1301	null, divide it by the bitsize_unit and add it to the regular
1302	offset. */
1303	tmp2 = compute_component_offset (field: ref->u.c.component->backend_decl,
1304	TREE_TYPE (tmp));
1305	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1306
1307	/* Set caf_token_offset. */
1308	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1309	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1310	TREE_TYPE (field), inner_struct, field,
1311	NULL_TREE);
1312	if ((ref->u.c.component->attr.allocatable
1313	|| ref->u.c.component->attr.pointer)
1314	&& ref->u.c.component->attr.dimension)
1315	{
1316	tree arr_desc_token_offset;
1317	/* Get the token field from the descriptor. */
1318	arr_desc_token_offset = TREE_OPERAND (
1319	gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
1320	arr_desc_token_offset
1321	= compute_component_offset (field: arr_desc_token_offset,
1322	TREE_TYPE (tmp));
1323	tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1324	TREE_TYPE (tmp2), tmp2,
1325	arr_desc_token_offset);
1326	}
1327	else if (ref->u.c.component->caf_token)
1328	tmp2 = compute_component_offset (field: ref->u.c.component->caf_token,
1329	TREE_TYPE (tmp));
1330	else
1331	tmp2 = integer_zero_node;
1332	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1333
1334	/* Remember whether this ref was to a non-allocatable/non-pointer
1335	component so the next array ref can be tailored correctly. */
1336	ref_static_array = !ref->u.c.component->attr.allocatable
1337	&& !ref->u.c.component->attr.pointer;
1338	last_component_ref_tree = ref_static_array
1339	? ref->u.c.component->backend_decl : NULL_TREE;
1340	break;
1341	case REF_ARRAY:
1342	if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1343	ref_static_array = false;
1344	/* Set the type of the ref. */
1345	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1346	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1347	TREE_TYPE (field), prev_caf_ref, field,
1348	NULL_TREE);
1349	gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1350	ref_static_array
1351	? GFC_CAF_REF_STATIC_ARRAY
1352	: GFC_CAF_REF_ARRAY));
1353
1354	/* Ref the a in union u. */
1355	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1356	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1357	TREE_TYPE (field), prev_caf_ref, field,
1358	NULL_TREE);
1359	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1360	inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1361	TREE_TYPE (field), tmp, field,
1362	NULL_TREE);
1363
1364	/* Set the static_array_type in a for static arrays. */
1365	if (ref_static_array)
1366	{
1367	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1368	1);
1369	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1370	TREE_TYPE (field), inner_struct, field,
1371	NULL_TREE);
1372	gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1373	last_type_n));
1374	}
1375	/* Ref the mode in the inner_struct. */
1376	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1377	mode = fold_build3_loc (input_location, COMPONENT_REF,
1378	TREE_TYPE (field), inner_struct, field,
1379	NULL_TREE);
1380	/* Ref the dim in the inner_struct. */
1381	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1382	dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1383	TREE_TYPE (field), inner_struct, field,
1384	NULL_TREE);
1385	for (i = 0; i < ref->u.ar.dimen; ++i)
1386	{
1387	/* Ref dim i. */
1388	dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1389	dim_type = TREE_TYPE (dim);
1390	mode_rhs = start = end = stride = NULL_TREE;
1391	switch (ref->u.ar.dimen_type[i])
1392	{
1393	case DIMEN_RANGE:
1394	if (ref->u.ar.end[i])
1395	{
1396	gfc_init_se (&se, NULL);
1397	gfc_conv_expr (se: &se, expr: ref->u.ar.end[i]);
1398	gfc_add_block_to_block (block, &se.pre);
1399	if (ref_static_array)
1400	{
1401	/* Make the index zero-based, when reffing a static
1402	array. */
1403	end = se.expr;
1404	gfc_init_se (&se, NULL);
1405	gfc_conv_expr (se: &se, expr: ref->u.ar.as->lower[i]);
1406	gfc_add_block_to_block (block, &se.pre);
1407	se.expr = fold_build2 (MINUS_EXPR,
1408	gfc_array_index_type,
1409	end, fold_convert (
1410	gfc_array_index_type,
1411	se.expr));
1412	}
1413	end = gfc_evaluate_now (fold_convert (
1414	gfc_array_index_type,
1415	se.expr),
1416	block);
1417	}
1418	else if (ref_static_array)
1419	end = fold_build2 (MINUS_EXPR,
1420	gfc_array_index_type,
1421	gfc_conv_array_ubound (
1422	last_component_ref_tree, i),
1423	gfc_conv_array_lbound (
1424	last_component_ref_tree, i));
1425	else
1426	{
1427	end = NULL_TREE;
1428	mode_rhs = build_int_cst (unsigned_char_type_node,
1429	GFC_CAF_ARR_REF_OPEN_END);
1430	}
1431	if (ref->u.ar.stride[i])
1432	{
1433	gfc_init_se (&se, NULL);
1434	gfc_conv_expr (se: &se, expr: ref->u.ar.stride[i]);
1435	gfc_add_block_to_block (block, &se.pre);
1436	stride = gfc_evaluate_now (fold_convert (
1437	gfc_array_index_type,
1438	se.expr),
1439	block);
1440	if (ref_static_array)
1441	{
1442	/* Make the index zero-based, when reffing a static
1443	array. */
1444	stride = fold_build2 (MULT_EXPR,
1445	gfc_array_index_type,
1446	gfc_conv_array_stride (
1447	last_component_ref_tree,
1448	i),
1449	stride);
1450	gcc_assert (end != NULL_TREE);
1451	/* Multiply with the product of array's stride and
1452	the step of the ref to a virtual upper bound.
1453	We cannot compute the actual upper bound here or
1454	the caflib would compute the extend
1455	incorrectly. */
1456	end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1457	end, gfc_conv_array_stride (
1458	last_component_ref_tree,
1459	i));
1460	end = gfc_evaluate_now (end, block);
1461	stride = gfc_evaluate_now (stride, block);
1462	}
1463	}
1464	else if (ref_static_array)
1465	{
1466	stride = gfc_conv_array_stride (last_component_ref_tree,
1467	i);
1468	end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1469	end, stride);
1470	end = gfc_evaluate_now (end, block);
1471	}
1472	else
1473	/* Always set a ref stride of one to make caflib's
1474	handling easier. */
1475	stride = gfc_index_one_node;
1476
1477	/* Fall through. */
1478	case DIMEN_ELEMENT:
1479	if (ref->u.ar.start[i])
1480	{
1481	gfc_init_se (&se, NULL);
1482	gfc_conv_expr (se: &se, expr: ref->u.ar.start[i]);
1483	gfc_add_block_to_block (block, &se.pre);
1484	if (ref_static_array)
1485	{
1486	/* Make the index zero-based, when reffing a static
1487	array. */
1488	start = fold_convert (gfc_array_index_type, se.expr);
1489	gfc_init_se (&se, NULL);
1490	gfc_conv_expr (se: &se, expr: ref->u.ar.as->lower[i]);
1491	gfc_add_block_to_block (block, &se.pre);
1492	se.expr = fold_build2 (MINUS_EXPR,
1493	gfc_array_index_type,
1494	start, fold_convert (
1495	gfc_array_index_type,
1496	se.expr));
1497	/* Multiply with the stride. */
1498	se.expr = fold_build2 (MULT_EXPR,
1499	gfc_array_index_type,
1500	se.expr,
1501	gfc_conv_array_stride (
1502	last_component_ref_tree,
1503	i));
1504	}
1505	start = gfc_evaluate_now (fold_convert (
1506	gfc_array_index_type,
1507	se.expr),
1508	block);
1509	if (mode_rhs == NULL_TREE)
1510	mode_rhs = build_int_cst (unsigned_char_type_node,
1511	ref->u.ar.dimen_type[i]
1512	== DIMEN_ELEMENT
1513	? GFC_CAF_ARR_REF_SINGLE
1514	: GFC_CAF_ARR_REF_RANGE);
1515	}
1516	else if (ref_static_array)
1517	{
1518	start = integer_zero_node;
1519	mode_rhs = build_int_cst (unsigned_char_type_node,
1520	ref->u.ar.start[i] == NULL
1521	? GFC_CAF_ARR_REF_FULL
1522	: GFC_CAF_ARR_REF_RANGE);
1523	}
1524	else if (end == NULL_TREE)
1525	mode_rhs = build_int_cst (unsigned_char_type_node,
1526	GFC_CAF_ARR_REF_FULL);
1527	else
1528	mode_rhs = build_int_cst (unsigned_char_type_node,
1529	GFC_CAF_ARR_REF_OPEN_START);
1530
1531	/* Ref the s in dim. */
1532	field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1533	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1534	TREE_TYPE (field), dim, field,
1535	NULL_TREE);
1536
1537	/* Set start in s. */
1538	if (start != NULL_TREE)
1539	{
1540	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1541	0);
1542	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1543	TREE_TYPE (field), tmp, field,
1544	NULL_TREE);
1545	gfc_add_modify (block, tmp2,
1546	fold_convert (TREE_TYPE (tmp2), start));
1547	}
1548
1549	/* Set end in s. */
1550	if (end != NULL_TREE)
1551	{
1552	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1553	1);
1554	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1555	TREE_TYPE (field), tmp, field,
1556	NULL_TREE);
1557	gfc_add_modify (block, tmp2,
1558	fold_convert (TREE_TYPE (tmp2), end));
1559	}
1560
1561	/* Set end in s. */
1562	if (stride != NULL_TREE)
1563	{
1564	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1565	2);
1566	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1567	TREE_TYPE (field), tmp, field,
1568	NULL_TREE);
1569	gfc_add_modify (block, tmp2,
1570	fold_convert (TREE_TYPE (tmp2), stride));
1571	}
1572	break;
1573	case DIMEN_VECTOR:
1574	/* TODO: In case of static array. */
1575	gcc_assert (!ref_static_array);
1576	mode_rhs = build_int_cst (unsigned_char_type_node,
1577	GFC_CAF_ARR_REF_VECTOR);
1578	gfc_init_se (&se, NULL);
1579	se.descriptor_only = 1;
1580	gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1581	gfc_add_block_to_block (block, &se.pre);
1582	vector = se.expr;
1583	tmp = gfc_conv_descriptor_lbound_get (vector,
1584	gfc_rank_cst[0]);
1585	tmp2 = gfc_conv_descriptor_ubound_get (vector,
1586	gfc_rank_cst[0]);
1587	nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1588	tmp = gfc_conv_descriptor_stride_get (vector,
1589	gfc_rank_cst[0]);
1590	nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1591	TREE_TYPE (nvec), nvec, tmp);
1592	vector = gfc_conv_descriptor_data_get (vector);
1593
1594	/* Ref the v in dim. */
1595	field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1596	tmp = fold_build3_loc (input_location, COMPONENT_REF,
1597	TREE_TYPE (field), dim, field,
1598	NULL_TREE);
1599
1600	/* Set vector in v. */
1601	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1602	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1603	TREE_TYPE (field), tmp, field,
1604	NULL_TREE);
1605	gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1606	vector));
1607
1608	/* Set nvec in v. */
1609	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1610	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1611	TREE_TYPE (field), tmp, field,
1612	NULL_TREE);
1613	gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1614	nvec));
1615
1616	/* Set kind in v. */
1617	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1618	tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1619	TREE_TYPE (field), tmp, field,
1620	NULL_TREE);
1621	gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1622	ref->u.ar.start[i]->ts.kind));
1623	break;
1624	default:
1625	gcc_unreachable ();
1626	}
1627	/* Set the mode for dim i. */
1628	tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1629	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1630	mode_rhs));
1631	}
1632
1633	/* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1634	if (i < GFC_MAX_DIMENSIONS)
1635	{
1636	tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1637	gfc_add_modify (block, tmp,
1638	build_int_cst (unsigned_char_type_node,
1639	GFC_CAF_ARR_REF_NONE));
1640	}
1641	break;
1642	default:
1643	gcc_unreachable ();
1644	}
1645
1646	/* Set the size of the current type. */
1647	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1648	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1649	prev_caf_ref, field, NULL_TREE);
1650	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1651	TYPE_SIZE_UNIT (last_type)));
1652
1653	ref = ref->next;
1654	}
1655
1656	if (prev_caf_ref != NULL_TREE)
1657	{
1658	field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1659	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1660	prev_caf_ref, field, NULL_TREE);
1661	gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1662	null_pointer_node));
1663	}
1664	return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1665	: NULL_TREE;
1666	}
1667
1668	/* Get data from a remote coarray. */
1669
1670	static void
1671	gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1672	tree may_require_tmp, bool may_realloc,
1673	symbol_attribute *caf_attr)
1674	{
1675	gfc_expr *array_expr, *tmp_stat;
1676	gfc_se argse;
1677	tree caf_decl, token, offset, image_index, tmp;
1678	tree res_var, dst_var, type, kind, vec, stat;
1679	tree caf_reference;
1680	symbol_attribute caf_attr_store;
1681
1682	gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1683
1684	if (se->ss && se->ss->info->useflags)
1685	{
1686	/* Access the previously obtained result. */
1687	gfc_conv_tmp_array_ref (se);
1688	return;
1689	}
1690
1691	/* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1692	array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1693	type = gfc_typenode_for_spec (&array_expr->ts);
1694
1695	if (caf_attr == NULL)
1696	{
1697	caf_attr_store = gfc_caf_attr (array_expr);
1698	caf_attr = &caf_attr_store;
1699	}
1700
1701	res_var = lhs;
1702	dst_var = lhs;
1703
1704	vec = null_pointer_node;
1705	tmp_stat = gfc_find_stat_co (expr);
1706
1707	if (tmp_stat)
1708	{
1709	gfc_se stat_se;
1710	gfc_init_se (&stat_se, NULL);
1711	gfc_conv_expr_reference (se: &stat_se, expr: tmp_stat);
1712	stat = stat_se.expr;
1713	gfc_add_block_to_block (&se->pre, &stat_se.pre);
1714	gfc_add_block_to_block (&se->post, &stat_se.post);
1715	}
1716	else
1717	stat = null_pointer_node;
1718
1719	/* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1720	is reallocatable or the right-hand side has allocatable components. */
1721	if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1722	{
1723	/* Get using caf_get_by_ref. */
1724	caf_reference = conv_expr_ref_to_caf_ref (block: &se->pre, expr: array_expr);
1725
1726	if (caf_reference != NULL_TREE)
1727	{
1728	if (lhs == NULL_TREE)
1729	{
1730	if (array_expr->ts.type == BT_CHARACTER)
1731	gfc_init_se (&argse, NULL);
1732	if (array_expr->rank == 0)
1733	{
1734	symbol_attribute attr;
1735	gfc_clear_attr (&attr);
1736	if (array_expr->ts.type == BT_CHARACTER)
1737	{
1738	res_var = gfc_conv_string_tmp (se,
1739	build_pointer_type (type),
1740	array_expr->ts.u.cl->backend_decl);
1741	argse.string_length = array_expr->ts.u.cl->backend_decl;
1742	}
1743	else
1744	res_var = gfc_create_var (type, "caf_res");
1745	dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1746	dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1747	}
1748	else
1749	{
1750	/* Create temporary. */
1751	if (array_expr->ts.type == BT_CHARACTER)
1752	gfc_conv_expr_descriptor (&argse, array_expr);
1753	may_realloc = gfc_trans_create_temp_array (&se->pre,
1754	&se->post,
1755	se->ss, type,
1756	NULL_TREE, false,
1757	false, false,
1758	&array_expr->where)
1759	== NULL_TREE;
1760	res_var = se->ss->info->data.array.descriptor;
1761	dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1762	if (may_realloc)
1763	{
1764	tmp = gfc_conv_descriptor_data_get (res_var);
1765	tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1766	NULL_TREE, NULL_TREE,
1767	NULL_TREE, true,
1768	NULL,
1769	GFC_CAF_COARRAY_NOCOARRAY);
1770	gfc_add_expr_to_block (&se->post, tmp);
1771	}
1772	}
1773	}
1774
1775	kind = build_int_cst (integer_type_node, expr->ts.kind);
1776	if (lhs_kind == NULL_TREE)
1777	lhs_kind = kind;
1778
1779	caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1780	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1781	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1782	image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1783	caf_decl);
1784	gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1785	array_expr);
1786
1787	/* No overlap possible as we have generated a temporary. */
1788	if (lhs == NULL_TREE)
1789	may_require_tmp = boolean_false_node;
1790
1791	/* It guarantees memory consistency within the same segment. */
1792	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
1793	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
1794	arg0: gfc_build_string_const (1, ""), NULL_TREE,
1795	NULL_TREE, arg3: tree_cons (NULL_TREE, tmp, NULL_TREE),
1796	NULL_TREE);
1797	ASM_VOLATILE_P (tmp) = 1;
1798	gfc_add_expr_to_block (&se->pre, tmp);
1799
1800	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1801	10, token, image_index, dst_var,
1802	caf_reference, lhs_kind, kind,
1803	may_require_tmp,
1804	may_realloc ? boolean_true_node :
1805	boolean_false_node,
1806	stat, build_int_cst (integer_type_node,
1807	array_expr->ts.type));
1808
1809	gfc_add_expr_to_block (&se->pre, tmp);
1810
1811	if (se->ss)
1812	gfc_advance_se_ss_chain (se);
1813
1814	se->expr = res_var;
1815	if (array_expr->ts.type == BT_CHARACTER)
1816	se->string_length = argse.string_length;
1817
1818	return;
1819	}
1820	}
1821
1822	gfc_init_se (&argse, NULL);
1823	if (array_expr->rank == 0)
1824	{
1825	symbol_attribute attr;
1826
1827	gfc_clear_attr (&attr);
1828	gfc_conv_expr (se: &argse, expr: array_expr);
1829
1830	if (lhs == NULL_TREE)
1831	{
1832	gfc_clear_attr (&attr);
1833	if (array_expr->ts.type == BT_CHARACTER)
1834	res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1835	argse.string_length);
1836	else
1837	res_var = gfc_create_var (type, "caf_res");
1838	dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1839	dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1840	}
1841	argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1842	argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1843	}
1844	else
1845	{
1846	/* If has_vector, pass descriptor for whole array and the
1847	vector bounds separately. */
1848	gfc_array_ref *ar, ar2;
1849	bool has_vector = false;
1850
1851	if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1852	{
1853	has_vector = true;
1854	ar = gfc_find_array_ref (expr);
1855	ar2 = *ar;
1856	memset (s: ar, c: '\0', n: sizeof (*ar));
1857	ar->as = ar2.as;
1858	ar->type = AR_FULL;
1859	}
1860	// TODO: Check whether argse.want_coarray = 1 can help with the below.
1861	gfc_conv_expr_descriptor (&argse, array_expr);
1862	/* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1863	has the wrong type if component references are done. */
1864	gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1865	gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1866	: array_expr->rank,
1867	type));
1868	if (has_vector)
1869	{
1870	vec = conv_caf_vector_subscript (block: &argse.pre, desc: argse.expr, ar: &ar2);
1871	*ar = ar2;
1872	}
1873
1874	if (lhs == NULL_TREE)
1875	{
1876	/* Create temporary. */
1877	for (int n = 0; n < se->ss->loop->dimen; n++)
1878	if (se->loop->to[n] == NULL_TREE)
1879	{
1880	se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1881	gfc_rank_cst[n]);
1882	se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1883	gfc_rank_cst[n]);
1884	}
1885	gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1886	NULL_TREE, false, true, false,
1887	&array_expr->where);
1888	res_var = se->ss->info->data.array.descriptor;
1889	dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1890	}
1891	argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1892	}
1893
1894	kind = build_int_cst (integer_type_node, expr->ts.kind);
1895	if (lhs_kind == NULL_TREE)
1896	lhs_kind = kind;
1897
1898	gfc_add_block_to_block (&se->pre, &argse.pre);
1899	gfc_add_block_to_block (&se->post, &argse.post);
1900
1901	caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1902	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1903	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1904	image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1905	gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1906	array_expr);
1907
1908	/* No overlap possible as we have generated a temporary. */
1909	if (lhs == NULL_TREE)
1910	may_require_tmp = boolean_false_node;
1911
1912	/* It guarantees memory consistency within the same segment. */
1913	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
1914	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
1915	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1916	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1917	ASM_VOLATILE_P (tmp) = 1;
1918	gfc_add_expr_to_block (&se->pre, tmp);
1919
1920	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1921	token, offset, image_index, argse.expr, vec,
1922	dst_var, kind, lhs_kind, may_require_tmp, stat);
1923
1924	gfc_add_expr_to_block (&se->pre, tmp);
1925
1926	if (se->ss)
1927	gfc_advance_se_ss_chain (se);
1928
1929	se->expr = res_var;
1930	if (array_expr->ts.type == BT_CHARACTER)
1931	se->string_length = argse.string_length;
1932	}
1933
1934
1935	/* Send data to a remote coarray. */
1936
1937	static tree
1938	conv_caf_send (gfc_code *code) {
1939	gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
1940	gfc_se lhs_se, rhs_se;
1941	stmtblock_t block;
1942	tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1943	tree may_require_tmp, src_stat, dst_stat, dst_team;
1944	tree lhs_type = NULL_TREE;
1945	tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1946	symbol_attribute lhs_caf_attr, rhs_caf_attr;
1947
1948	gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1949
1950	lhs_expr = code->ext.actual->expr;
1951	rhs_expr = code->ext.actual->next->expr;
1952	may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1953	? boolean_false_node : boolean_true_node;
1954	gfc_init_block (&block);
1955
1956	lhs_caf_attr = gfc_caf_attr (lhs_expr);
1957	rhs_caf_attr = gfc_caf_attr (rhs_expr);
1958	src_stat = dst_stat = null_pointer_node;
1959	dst_team = null_pointer_node;
1960
1961	/* LHS. */
1962	gfc_init_se (&lhs_se, NULL);
1963	if (lhs_expr->rank == 0)
1964	{
1965	if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
1966	{
1967	lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
1968	lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1969	}
1970	else
1971	{
1972	symbol_attribute attr;
1973	gfc_clear_attr (&attr);
1974	gfc_conv_expr (se: &lhs_se, expr: lhs_expr);
1975	lhs_type = TREE_TYPE (lhs_se.expr);
1976	lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
1977	attr);
1978	lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1979	}
1980	}
1981	else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1982	&& lhs_caf_attr.codimension)
1983	{
1984	lhs_se.want_pointer = 1;
1985	gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1986	/* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1987	has the wrong type if component references are done. */
1988	lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1989	tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1990	gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1991	gfc_get_dtype_rank_type (
1992	gfc_has_vector_subscript (lhs_expr)
1993	? gfc_find_array_ref (lhs_expr)->dimen
1994	: lhs_expr->rank,
1995	lhs_type));
1996	}
1997	else
1998	{
1999	bool has_vector = gfc_has_vector_subscript (lhs_expr);
2000
2001	if (gfc_is_coindexed (lhs_expr) || !has_vector)
2002	{
2003	/* If has_vector, pass descriptor for whole array and the
2004	vector bounds separately. */
2005	gfc_array_ref *ar, ar2;
2006	bool has_tmp_lhs_array = false;
2007	if (has_vector)
2008	{
2009	has_tmp_lhs_array = true;
2010	ar = gfc_find_array_ref (lhs_expr);
2011	ar2 = *ar;
2012	memset (s: ar, c: '\0', n: sizeof (*ar));
2013	ar->as = ar2.as;
2014	ar->type = AR_FULL;
2015	}
2016	lhs_se.want_pointer = 1;
2017	gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
2018	/* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2019	that has the wrong type if component references are done. */
2020	lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2021	tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
2022	gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2023	gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2024	: lhs_expr->rank,
2025	lhs_type));
2026	if (has_tmp_lhs_array)
2027	{
2028	vec = conv_caf_vector_subscript (block: &block, desc: lhs_se.expr, ar: &ar2);
2029	*ar = ar2;
2030	}
2031	}
2032	else
2033	{
2034	/* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2035	indexed array expression. This is rewritten to:
2036
2037	tmp_array = arr2[...]
2038	arr1 ([...]) = tmp_array
2039
2040	because using the standard gfc_conv_expr (lhs_expr) did the
2041	assignment with lhs and rhs exchanged. */
2042
2043	gfc_ss *lss_for_tmparray, *lss_real;
2044	gfc_loopinfo loop;
2045	gfc_se se;
2046	stmtblock_t body;
2047	tree tmparr_desc, src;
2048	tree index = gfc_index_zero_node;
2049	tree stride = gfc_index_zero_node;
2050	int n;
2051
2052	/* Walk both sides of the assignment, once to get the shape of the
2053	temporary array to create right. */
2054	lss_for_tmparray = gfc_walk_expr (lhs_expr);
2055	/* And a second time to be able to create an assignment of the
2056	temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2057	the tree in the descriptor with the one for the temporary
2058	array. */
2059	lss_real = gfc_walk_expr (lhs_expr);
2060	gfc_init_loopinfo (&loop);
2061	gfc_add_ss_to_loop (&loop, lss_for_tmparray);
2062	gfc_add_ss_to_loop (&loop, lss_real);
2063	gfc_conv_ss_startstride (&loop);
2064	gfc_conv_loop_setup (&loop, &lhs_expr->where);
2065	lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2066	gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
2067	lss_for_tmparray, lhs_type, NULL_TREE,
2068	false, true, false,
2069	&lhs_expr->where);
2070	tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
2071	gfc_start_scalarized_body (&loop, &body);
2072	gfc_init_se (&se, NULL);
2073	gfc_copy_loopinfo_to_se (&se, &loop);
2074	se.ss = lss_real;
2075	gfc_conv_expr (se: &se, expr: lhs_expr);
2076	gfc_add_block_to_block (&body, &se.pre);
2077
2078	/* Walk over all indexes of the loop. */
2079	for (n = loop.dimen - 1; n > 0; --n)
2080	{
2081	tmp = loop.loopvar[n];
2082	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2083	gfc_array_index_type, tmp, loop.from[n]);
2084	tmp = fold_build2_loc (input_location, PLUS_EXPR,
2085	gfc_array_index_type, tmp, index);
2086
2087	stride = fold_build2_loc (input_location, MINUS_EXPR,
2088	gfc_array_index_type,
2089	loop.to[n - 1], loop.from[n - 1]);
2090	stride = fold_build2_loc (input_location, PLUS_EXPR,
2091	gfc_array_index_type,
2092	stride, gfc_index_one_node);
2093
2094	index = fold_build2_loc (input_location, MULT_EXPR,
2095	gfc_array_index_type, tmp, stride);
2096	}
2097
2098	index = fold_build2_loc (input_location, MINUS_EXPR,
2099	gfc_array_index_type,
2100	index, loop.from[0]);
2101
2102	index = fold_build2_loc (input_location, PLUS_EXPR,
2103	gfc_array_index_type,
2104	loop.loopvar[0], index);
2105
2106	src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
2107	src = gfc_build_array_ref (src, index, NULL);
2108	/* Now create the assignment of lhs_expr = tmp_array. */
2109	gfc_add_modify (&body, se.expr, src);
2110	gfc_add_block_to_block (&body, &se.post);
2111	lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
2112	gfc_trans_scalarizing_loops (&loop, &body);
2113	gfc_add_block_to_block (&loop.pre, &loop.post);
2114	gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
2115	gfc_free_ss (lss_for_tmparray);
2116	gfc_free_ss (lss_real);
2117	}
2118	}
2119
2120	lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
2121
2122	/* Special case: RHS is a coarray but LHS is not; this code path avoids a
2123	temporary and a loop. */
2124	if (!gfc_is_coindexed (lhs_expr)
2125	&& (!lhs_caf_attr.codimension
2126	|| !(lhs_expr->rank > 0
2127	&& (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
2128	{
2129	bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
2130	gcc_assert (gfc_is_coindexed (rhs_expr));
2131	gfc_init_se (&rhs_se, NULL);
2132	if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
2133	{
2134	gfc_se scal_se;
2135	gfc_init_se (&scal_se, NULL);
2136	scal_se.want_pointer = 1;
2137	gfc_conv_expr (se: &scal_se, expr: lhs_expr);
2138	/* Ensure scalar on lhs is allocated. */
2139	gfc_add_block_to_block (&block, &scal_se.pre);
2140
2141	gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
2142	TYPE_SIZE_UNIT (
2143	gfc_typenode_for_spec (&lhs_expr->ts)),
2144	NULL_TREE);
2145	tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
2146	null_pointer_node);
2147	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2148	tmp, gfc_finish_block (&scal_se.pre),
2149	build_empty_stmt (input_location));
2150	gfc_add_expr_to_block (&block, tmp);
2151	}
2152	else
2153	lhs_may_realloc = lhs_may_realloc
2154	&& gfc_full_array_ref_p (lhs_expr->ref, NULL);
2155	gfc_add_block_to_block (&block, &lhs_se.pre);
2156	gfc_conv_intrinsic_caf_get (se: &rhs_se, expr: rhs_expr, lhs: lhs_se.expr, lhs_kind,
2157	may_require_tmp, may_realloc: lhs_may_realloc,
2158	caf_attr: &rhs_caf_attr);
2159	gfc_add_block_to_block (&block, &rhs_se.pre);
2160	gfc_add_block_to_block (&block, &rhs_se.post);
2161	gfc_add_block_to_block (&block, &lhs_se.post);
2162	return gfc_finish_block (&block);
2163	}
2164
2165	gfc_add_block_to_block (&block, &lhs_se.pre);
2166
2167	/* Obtain token, offset and image index for the LHS. */
2168	caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
2169	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2170	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2171	image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
2172	tmp = lhs_se.expr;
2173	if (lhs_caf_attr.alloc_comp)
2174	gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
2175	NULL);
2176	else
2177	gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
2178	lhs_expr);
2179	lhs_se.expr = tmp;
2180
2181	/* RHS. */
2182	gfc_init_se (&rhs_se, NULL);
2183	if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
2184	&& rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
2185	rhs_expr = rhs_expr->value.function.actual->expr;
2186	if (rhs_expr->rank == 0)
2187	{
2188	symbol_attribute attr;
2189	gfc_clear_attr (&attr);
2190	gfc_conv_expr (se: &rhs_se, expr: rhs_expr);
2191	rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2192	rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2193	}
2194	else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2195	&& rhs_caf_attr.codimension)
2196	{
2197	tree tmp2;
2198	rhs_se.want_pointer = 1;
2199	gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2200	/* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2201	has the wrong type if component references are done. */
2202	tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2203	tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2204	gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2205	gfc_get_dtype_rank_type (
2206	gfc_has_vector_subscript (rhs_expr)
2207	? gfc_find_array_ref (rhs_expr)->dimen
2208	: rhs_expr->rank,
2209	tmp2));
2210	}
2211	else
2212	{
2213	/* If has_vector, pass descriptor for whole array and the
2214	vector bounds separately. */
2215	gfc_array_ref *ar, ar2;
2216	bool has_vector = false;
2217	tree tmp2;
2218
2219	if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2220	{
2221	has_vector = true;
2222	ar = gfc_find_array_ref (rhs_expr);
2223	ar2 = *ar;
2224	memset (s: ar, c: '\0', n: sizeof (*ar));
2225	ar->as = ar2.as;
2226	ar->type = AR_FULL;
2227	}
2228	rhs_se.want_pointer = 1;
2229	gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2230	/* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2231	has the wrong type if component references are done. */
2232	tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2233	tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2234	gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2235	gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2236	: rhs_expr->rank,
2237	tmp2));
2238	if (has_vector)
2239	{
2240	rhs_vec = conv_caf_vector_subscript (block: &block, desc: rhs_se.expr, ar: &ar2);
2241	*ar = ar2;
2242	}
2243	}
2244
2245	gfc_add_block_to_block (&block, &rhs_se.pre);
2246
2247	rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2248
2249	tmp_stat = gfc_find_stat_co (lhs_expr);
2250
2251	if (tmp_stat)
2252	{
2253	gfc_se stat_se;
2254	gfc_init_se (&stat_se, NULL);
2255	gfc_conv_expr_reference (se: &stat_se, expr: tmp_stat);
2256	dst_stat = stat_se.expr;
2257	gfc_add_block_to_block (&block, &stat_se.pre);
2258	gfc_add_block_to_block (&block, &stat_se.post);
2259	}
2260
2261	tmp_team = gfc_find_team_co (lhs_expr);
2262
2263	if (tmp_team)
2264	{
2265	gfc_se team_se;
2266	gfc_init_se (&team_se, NULL);
2267	gfc_conv_expr_reference (se: &team_se, expr: tmp_team);
2268	dst_team = team_se.expr;
2269	gfc_add_block_to_block (&block, &team_se.pre);
2270	gfc_add_block_to_block (&block, &team_se.post);
2271	}
2272
2273	if (!gfc_is_coindexed (rhs_expr))
2274	{
2275	if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2276	{
2277	tree reference, dst_realloc;
2278	reference = conv_expr_ref_to_caf_ref (block: &block, expr: lhs_expr);
2279	dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2280	: boolean_false_node;
2281	tmp = build_call_expr_loc (input_location,
2282	gfor_fndecl_caf_send_by_ref,
2283	10, token, image_index, rhs_se.expr,
2284	reference, lhs_kind, rhs_kind,
2285	may_require_tmp, dst_realloc, src_stat,
2286	build_int_cst (integer_type_node,
2287	lhs_expr->ts.type));
2288	}
2289	else
2290	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
2291	token, offset, image_index, lhs_se.expr, vec,
2292	rhs_se.expr, lhs_kind, rhs_kind,
2293	may_require_tmp, src_stat, dst_team);
2294	}
2295	else
2296	{
2297	tree rhs_token, rhs_offset, rhs_image_index;
2298
2299	/* It guarantees memory consistency within the same segment. */
2300	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
2301	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
2302	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2303	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2304	ASM_VOLATILE_P (tmp) = 1;
2305	gfc_add_expr_to_block (&block, tmp);
2306
2307	caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2308	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2309	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2310	rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2311	tmp = rhs_se.expr;
2312	if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2313	{
2314	tmp_stat = gfc_find_stat_co (lhs_expr);
2315
2316	if (tmp_stat)
2317	{
2318	gfc_se stat_se;
2319	gfc_init_se (&stat_se, NULL);
2320	gfc_conv_expr_reference (se: &stat_se, expr: tmp_stat);
2321	src_stat = stat_se.expr;
2322	gfc_add_block_to_block (&block, &stat_se.pre);
2323	gfc_add_block_to_block (&block, &stat_se.post);
2324	}
2325
2326	gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2327	NULL_TREE, NULL);
2328	tree lhs_reference, rhs_reference;
2329	lhs_reference = conv_expr_ref_to_caf_ref (block: &block, expr: lhs_expr);
2330	rhs_reference = conv_expr_ref_to_caf_ref (block: &block, expr: rhs_expr);
2331	tmp = build_call_expr_loc (input_location,
2332	gfor_fndecl_caf_sendget_by_ref, 13,
2333	token, image_index, lhs_reference,
2334	rhs_token, rhs_image_index, rhs_reference,
2335	lhs_kind, rhs_kind, may_require_tmp,
2336	dst_stat, src_stat,
2337	build_int_cst (integer_type_node,
2338	lhs_expr->ts.type),
2339	build_int_cst (integer_type_node,
2340	rhs_expr->ts.type));
2341	}
2342	else
2343	{
2344	gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2345	tmp, rhs_expr);
2346	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2347	14, token, offset, image_index,
2348	lhs_se.expr, vec, rhs_token, rhs_offset,
2349	rhs_image_index, tmp, rhs_vec, lhs_kind,
2350	rhs_kind, may_require_tmp, src_stat);
2351	}
2352	}
2353	gfc_add_expr_to_block (&block, tmp);
2354	gfc_add_block_to_block (&block, &lhs_se.post);
2355	gfc_add_block_to_block (&block, &rhs_se.post);
2356
2357	/* It guarantees memory consistency within the same segment. */
2358	tmp = gfc_build_string_const (strlen (s: "memory") + 1, "memory");
2359	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
2360	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2361	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2362	ASM_VOLATILE_P (tmp) = 1;
2363	gfc_add_expr_to_block (&block, tmp);
2364
2365	return gfc_finish_block (&block);
2366	}
2367
2368
2369	static void
2370	trans_this_image (gfc_se * se, gfc_expr *expr)
2371	{
2372	stmtblock_t loop;
2373	tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2374	lbound, ubound, extent, ml;
2375	gfc_se argse;
2376	int rank, corank;
2377	gfc_expr *distance = expr->value.function.actual->next->next->expr;
2378
2379	if (expr->value.function.actual->expr
2380	&& !gfc_is_coarray (expr->value.function.actual->expr))
2381	distance = expr->value.function.actual->expr;
2382
2383	/* The case -fcoarray=single is handled elsewhere. */
2384	gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2385
2386	/* Argument-free version: THIS_IMAGE(). */
2387	if (distance || expr->value.function.actual->expr == NULL)
2388	{
2389	if (distance)
2390	{
2391	gfc_init_se (&argse, NULL);
2392	gfc_conv_expr_val (se: &argse, expr: distance);
2393	gfc_add_block_to_block (&se->pre, &argse.pre);
2394	gfc_add_block_to_block (&se->post, &argse.post);
2395	tmp = fold_convert (integer_type_node, argse.expr);
2396	}
2397	else
2398	tmp = integer_zero_node;
2399	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2400	tmp);
2401	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2402	tmp);
2403	return;
2404	}
2405
2406	/* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2407
2408	type = gfc_get_int_type (gfc_default_integer_kind);
2409	corank = gfc_get_corank (expr->value.function.actual->expr);
2410	rank = expr->value.function.actual->expr->rank;
2411
2412	/* Obtain the descriptor of the COARRAY. */
2413	gfc_init_se (&argse, NULL);
2414	argse.want_coarray = 1;
2415	gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2416	gfc_add_block_to_block (&se->pre, &argse.pre);
2417	gfc_add_block_to_block (&se->post, &argse.post);
2418	desc = argse.expr;
2419
2420	if (se->ss)
2421	{
2422	/* Create an implicit second parameter from the loop variable. */
2423	gcc_assert (!expr->value.function.actual->next->expr);
2424	gcc_assert (corank > 0);
2425	gcc_assert (se->loop->dimen == 1);
2426	gcc_assert (se->ss->info->expr == expr);
2427
2428	dim_arg = se->loop->loopvar[0];
2429	dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2430	gfc_array_index_type, dim_arg,
2431	build_int_cst (TREE_TYPE (dim_arg), 1));
2432	gfc_advance_se_ss_chain (se);
2433	}
2434	else
2435	{
2436	/* Use the passed DIM= argument. */
2437	gcc_assert (expr->value.function.actual->next->expr);
2438	gfc_init_se (&argse, NULL);
2439	gfc_conv_expr_type (se: &argse, expr->value.function.actual->next->expr,
2440	gfc_array_index_type);
2441	gfc_add_block_to_block (&se->pre, &argse.pre);
2442	dim_arg = argse.expr;
2443
2444	if (INTEGER_CST_P (dim_arg))
2445	{
2446	if (wi::ltu_p (x: wi::to_wide (t: dim_arg), y: 1)
2447	|| wi::gtu_p (x: wi::to_wide (t: dim_arg),
2448	GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2449	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2450	"dimension index", expr->value.function.isym->name,
2451	&expr->where);
2452	}
2453	else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2454	{
2455	dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2456	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2457	dim_arg,
2458	build_int_cst (TREE_TYPE (dim_arg), 1));
2459	tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2460	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2461	dim_arg, tmp);
2462	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2463	logical_type_node, cond, tmp);
2464	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2465	gfc_msg_fault);
2466	}
2467	}
2468
2469	/* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2470	one always has a dim_arg argument.
2471
2472	m = this_image() - 1
2473	if (corank == 1)
2474	{
2475	sub(1) = m + lcobound(corank)
2476	return;
2477	}
2478	i = rank
2479	min_var = min (rank + corank - 2, rank + dim_arg - 1)
2480	for (;;)
2481	{
2482	extent = gfc_extent(i)
2483	ml = m
2484	m = m/extent
2485	if (i >= min_var)
2486	goto exit_label
2487	i++
2488	}
2489	exit_label:
2490	sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2491	: m + lcobound(corank)
2492	*/
2493
2494	/* this_image () - 1. */
2495	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2496	integer_zero_node);
2497	tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2498	fold_convert (type, tmp), build_int_cst (type, 1));
2499	if (corank == 1)
2500	{
2501	/* sub(1) = m + lcobound(corank). */
2502	lbound = gfc_conv_descriptor_lbound_get (desc,
2503	build_int_cst (TREE_TYPE (gfc_array_index_type),
2504	corank+rank-1));
2505	lbound = fold_convert (type, lbound);
2506	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2507
2508	se->expr = tmp;
2509	return;
2510	}
2511
2512	m = gfc_create_var (type, NULL);
2513	ml = gfc_create_var (type, NULL);
2514	loop_var = gfc_create_var (integer_type_node, NULL);
2515	min_var = gfc_create_var (integer_type_node, NULL);
2516
2517	/* m = this_image () - 1. */
2518	gfc_add_modify (&se->pre, m, tmp);
2519
2520	/* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2521	tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2522	fold_convert (integer_type_node, dim_arg),
2523	build_int_cst (integer_type_node, rank - 1));
2524	tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2525	build_int_cst (integer_type_node, rank + corank - 2),
2526	tmp);
2527	gfc_add_modify (&se->pre, min_var, tmp);
2528
2529	/* i = rank. */
2530	tmp = build_int_cst (integer_type_node, rank);
2531	gfc_add_modify (&se->pre, loop_var, tmp);
2532
2533	exit_label = gfc_build_label_decl (NULL_TREE);
2534	TREE_USED (exit_label) = 1;
2535
2536	/* Loop body. */
2537	gfc_init_block (&loop);
2538
2539	/* ml = m. */
2540	gfc_add_modify (&loop, ml, m);
2541
2542	/* extent = ... */
2543	lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2544	ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2545	extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2546	extent = fold_convert (type, extent);
2547
2548	/* m = m/extent. */
2549	gfc_add_modify (&loop, m,
2550	fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2551	m, extent));
2552
2553	/* Exit condition: if (i >= min_var) goto exit_label. */
2554	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2555	min_var);
2556	tmp = build1_v (GOTO_EXPR, exit_label);
2557	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2558	build_empty_stmt (input_location));
2559	gfc_add_expr_to_block (&loop, tmp);
2560
2561	/* Increment loop variable: i++. */
2562	gfc_add_modify (&loop, loop_var,
2563	fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2564	loop_var,
2565	build_int_cst (integer_type_node, 1)));
2566
2567	/* Making the loop... actually loop! */
2568	tmp = gfc_finish_block (&loop);
2569	tmp = build1_v (LOOP_EXPR, tmp);
2570	gfc_add_expr_to_block (&se->pre, tmp);
2571
2572	/* The exit label. */
2573	tmp = build1_v (LABEL_EXPR, exit_label);
2574	gfc_add_expr_to_block (&se->pre, tmp);
2575
2576	/* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2577	: m + lcobound(corank) */
2578
2579	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2580	build_int_cst (TREE_TYPE (dim_arg), corank));
2581
2582	lbound = gfc_conv_descriptor_lbound_get (desc,
2583	fold_build2_loc (input_location, PLUS_EXPR,
2584	gfc_array_index_type, dim_arg,
2585	build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2586	lbound = fold_convert (type, lbound);
2587
2588	tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2589	fold_build2_loc (input_location, MULT_EXPR, type,
2590	m, extent));
2591	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2592
2593	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2594	fold_build2_loc (input_location, PLUS_EXPR, type,
2595	m, lbound));
2596	}
2597
2598
2599	/* Convert a call to image_status. */
2600
2601	static void
2602	conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2603	{
2604	unsigned int num_args;
2605	tree *args, tmp;
2606
2607	num_args = gfc_intrinsic_argument_list_length (expr);
2608	args = XALLOCAVEC (tree, num_args);
2609	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
2610	/* In args[0] the number of the image the status is desired for has to be
2611	given. */
2612
2613	if (flag_coarray == GFC_FCOARRAY_SINGLE)
2614	{
2615	tree arg;
2616	arg = gfc_evaluate_now (args[0], &se->pre);
2617	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2618	fold_convert (integer_type_node, arg),
2619	integer_one_node);
2620	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2621	tmp, integer_zero_node,
2622	build_int_cst (integer_type_node,
2623	GFC_STAT_STOPPED_IMAGE));
2624	}
2625	else if (flag_coarray == GFC_FCOARRAY_LIB)
2626	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2627	args[0], build_int_cst (integer_type_node, -1));
2628	else
2629	gcc_unreachable ();
2630
2631	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2632	}
2633
2634	static void
2635	conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2636	{
2637	unsigned int num_args;
2638
2639	tree *args, tmp;
2640
2641	num_args = gfc_intrinsic_argument_list_length (expr);
2642	args = XALLOCAVEC (tree, num_args);
2643	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
2644
2645	if (flag_coarray ==
2646	GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2647	{
2648	tree arg;
2649
2650	arg = gfc_evaluate_now (args[0], &se->pre);
2651	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2652	fold_convert (integer_type_node, arg),
2653	integer_one_node);
2654	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2655	tmp, integer_zero_node,
2656	build_int_cst (integer_type_node,
2657	GFC_STAT_STOPPED_IMAGE));
2658	}
2659	else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2660	{
2661	// the value -1 represents that no team has been created yet
2662	tmp = build_int_cst (integer_type_node, -1);
2663	}
2664	else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2665	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2666	args[0], build_int_cst (integer_type_node, -1));
2667	else if (flag_coarray == GFC_FCOARRAY_LIB)
2668	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2669	integer_zero_node, build_int_cst (integer_type_node, -1));
2670	else
2671	gcc_unreachable ();
2672
2673	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2674	}
2675
2676
2677	static void
2678	trans_image_index (gfc_se * se, gfc_expr *expr)
2679	{
2680	tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2681	tmp, invalid_bound;
2682	gfc_se argse, subse;
2683	int rank, corank, codim;
2684
2685	type = gfc_get_int_type (gfc_default_integer_kind);
2686	corank = gfc_get_corank (expr->value.function.actual->expr);
2687	rank = expr->value.function.actual->expr->rank;
2688
2689	/* Obtain the descriptor of the COARRAY. */
2690	gfc_init_se (&argse, NULL);
2691	argse.want_coarray = 1;
2692	gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2693	gfc_add_block_to_block (&se->pre, &argse.pre);
2694	gfc_add_block_to_block (&se->post, &argse.post);
2695	desc = argse.expr;
2696
2697	/* Obtain a handle to the SUB argument. */
2698	gfc_init_se (&subse, NULL);
2699	gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2700	gfc_add_block_to_block (&se->pre, &subse.pre);
2701	gfc_add_block_to_block (&se->post, &subse.post);
2702	subdesc = build_fold_indirect_ref_loc (input_location,
2703	gfc_conv_descriptor_data_get (subse.expr));
2704
2705	/* Fortran 2008 does not require that the values remain in the cobounds,
2706	thus we need explicitly check this - and return 0 if they are exceeded. */
2707
2708	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2709	tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2710	invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2711	fold_convert (gfc_array_index_type, tmp),
2712	lbound);
2713
2714	for (codim = corank + rank - 2; codim >= rank; codim--)
2715	{
2716	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2717	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2718	tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2719	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2720	fold_convert (gfc_array_index_type, tmp),
2721	lbound);
2722	invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2723	logical_type_node, invalid_bound, cond);
2724	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2725	fold_convert (gfc_array_index_type, tmp),
2726	ubound);
2727	invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2728	logical_type_node, invalid_bound, cond);
2729	}
2730
2731	invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2732
2733	/* See Fortran 2008, C.10 for the following algorithm. */
2734
2735	/* coindex = sub(corank) - lcobound(n). */
2736	coindex = fold_convert (gfc_array_index_type,
2737	gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2738	NULL));
2739	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2740	coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2741	fold_convert (gfc_array_index_type, coindex),
2742	lbound);
2743
2744	for (codim = corank + rank - 2; codim >= rank; codim--)
2745	{
2746	tree extent, ubound;
2747
2748	/* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2749	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2750	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2751	extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2752
2753	/* coindex *= extent. */
2754	coindex = fold_build2_loc (input_location, MULT_EXPR,
2755	gfc_array_index_type, coindex, extent);
2756
2757	/* coindex += sub(codim). */
2758	tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2759	coindex = fold_build2_loc (input_location, PLUS_EXPR,
2760	gfc_array_index_type, coindex,
2761	fold_convert (gfc_array_index_type, tmp));
2762
2763	/* coindex -= lbound(codim). */
2764	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2765	coindex = fold_build2_loc (input_location, MINUS_EXPR,
2766	gfc_array_index_type, coindex, lbound);
2767	}
2768
2769	coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2770	fold_convert(type, coindex),
2771	build_int_cst (type, 1));
2772
2773	/* Return 0 if "coindex" exceeds num_images(). */
2774
2775	if (flag_coarray == GFC_FCOARRAY_SINGLE)
2776	num_images = build_int_cst (type, 1);
2777	else
2778	{
2779	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2780	integer_zero_node,
2781	build_int_cst (integer_type_node, -1));
2782	num_images = fold_convert (type, tmp);
2783	}
2784
2785	tmp = gfc_create_var (type, NULL);
2786	gfc_add_modify (&se->pre, tmp, coindex);
2787
2788	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2789	num_images);
2790	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2791	cond,
2792	fold_convert (logical_type_node, invalid_bound));
2793	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2794	build_int_cst (type, 0), tmp);
2795	}
2796
2797	static void
2798	trans_num_images (gfc_se * se, gfc_expr *expr)
2799	{
2800	tree tmp, distance, failed;
2801	gfc_se argse;
2802
2803	if (expr->value.function.actual->expr)
2804	{
2805	gfc_init_se (&argse, NULL);
2806	gfc_conv_expr_val (se: &argse, expr: expr->value.function.actual->expr);
2807	gfc_add_block_to_block (&se->pre, &argse.pre);
2808	gfc_add_block_to_block (&se->post, &argse.post);
2809	distance = fold_convert (integer_type_node, argse.expr);
2810	}
2811	else
2812	distance = integer_zero_node;
2813
2814	if (expr->value.function.actual->next->expr)
2815	{
2816	gfc_init_se (&argse, NULL);
2817	gfc_conv_expr_val (se: &argse, expr: expr->value.function.actual->next->expr);
2818	gfc_add_block_to_block (&se->pre, &argse.pre);
2819	gfc_add_block_to_block (&se->post, &argse.post);
2820	failed = fold_convert (integer_type_node, argse.expr);
2821	}
2822	else
2823	failed = build_int_cst (integer_type_node, -1);
2824	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2825	distance, failed);
2826	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2827	}
2828
2829
2830	static void
2831	gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2832	{
2833	gfc_se argse;
2834
2835	gfc_init_se (&argse, NULL);
2836	argse.data_not_needed = 1;
2837	argse.descriptor_only = 1;
2838
2839	gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2840	gfc_add_block_to_block (&se->pre, &argse.pre);
2841	gfc_add_block_to_block (&se->post, &argse.post);
2842
2843	se->expr = gfc_conv_descriptor_rank (argse.expr);
2844	se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2845	se->expr);
2846	}
2847
2848
2849	static void
2850	gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2851	{
2852	gfc_expr *arg;
2853	arg = expr->value.function.actual->expr;
2854	gfc_conv_is_contiguous_expr (se, arg);
2855	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2856	}
2857
2858	/* This function does the work for gfc_conv_intrinsic_is_contiguous,
2859	plus it can be called directly. */
2860
2861	void
2862	gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2863	{
2864	gfc_ss *ss;
2865	gfc_se argse;
2866	tree desc, tmp, stride, extent, cond;
2867	int i;
2868	tree fncall0;
2869	gfc_array_spec *as;
2870
2871	if (arg->ts.type == BT_CLASS)
2872	gfc_add_class_array_ref (arg);
2873
2874	ss = gfc_walk_expr (arg);
2875	gcc_assert (ss != gfc_ss_terminator);
2876	gfc_init_se (&argse, NULL);
2877	argse.data_not_needed = 1;
2878	gfc_conv_expr_descriptor (&argse, arg);
2879
2880	as = gfc_get_full_arrayspec_from_expr (expr: arg);
2881
2882	/* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2883	Note in addition that zero-sized arrays don't count as contiguous. */
2884
2885	if (as && as->type == AS_ASSUMED_RANK)
2886	{
2887	/* Build the call to is_contiguous0. */
2888	argse.want_pointer = 1;
2889	gfc_conv_expr_descriptor (&argse, arg);
2890	gfc_add_block_to_block (&se->pre, &argse.pre);
2891	gfc_add_block_to_block (&se->post, &argse.post);
2892	desc = gfc_evaluate_now (argse.expr, &se->pre);
2893	fncall0 = build_call_expr_loc (input_location,
2894	gfor_fndecl_is_contiguous0, 1, desc);
2895	se->expr = fncall0;
2896	se->expr = convert (logical_type_node, se->expr);
2897	}
2898	else
2899	{
2900	gfc_add_block_to_block (&se->pre, &argse.pre);
2901	gfc_add_block_to_block (&se->post, &argse.post);
2902	desc = gfc_evaluate_now (argse.expr, &se->pre);
2903
2904	stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2905	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2906	stride, build_int_cst (TREE_TYPE (stride), 1));
2907
2908	for (i = 0; i < arg->rank - 1; i++)
2909	{
2910	tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2911	extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2912	extent = fold_build2_loc (input_location, MINUS_EXPR,
2913	gfc_array_index_type, extent, tmp);
2914	extent = fold_build2_loc (input_location, PLUS_EXPR,
2915	gfc_array_index_type, extent,
2916	gfc_index_one_node);
2917	tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2918	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2919	tmp, extent);
2920	stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2921	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2922	stride, tmp);
2923	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2924	boolean_type_node, cond, tmp);
2925	}
2926	se->expr = cond;
2927	}
2928	}
2929
2930
2931	/* Evaluate a single upper or lower bound. */
2932	/* TODO: bound intrinsic generates way too much unnecessary code. */
2933
2934	static void
2935	gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2936	{
2937	gfc_actual_arglist *arg;
2938	gfc_actual_arglist *arg2;
2939	tree desc;
2940	tree type;
2941	tree bound;
2942	tree tmp;
2943	tree cond, cond1;
2944	tree ubound;
2945	tree lbound;
2946	tree size;
2947	gfc_se argse;
2948	gfc_array_spec * as;
2949	bool assumed_rank_lb_one;
2950
2951	arg = expr->value.function.actual;
2952	arg2 = arg->next;
2953
2954	if (se->ss)
2955	{
2956	/* Create an implicit second parameter from the loop variable. */
2957	gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2958	gcc_assert (se->loop->dimen == 1);
2959	gcc_assert (se->ss->info->expr == expr);
2960	gfc_advance_se_ss_chain (se);
2961	bound = se->loop->loopvar[0];
2962	bound = fold_build2_loc (input_location, MINUS_EXPR,
2963	gfc_array_index_type, bound,
2964	se->loop->from[0]);
2965	}
2966	else
2967	{
2968	/* use the passed argument. */
2969	gcc_assert (arg2->expr);
2970	gfc_init_se (&argse, NULL);
2971	gfc_conv_expr_type (se: &argse, arg2->expr, gfc_array_index_type);
2972	gfc_add_block_to_block (&se->pre, &argse.pre);
2973	bound = argse.expr;
2974	/* Convert from one based to zero based. */
2975	bound = fold_build2_loc (input_location, MINUS_EXPR,
2976	gfc_array_index_type, bound,
2977	gfc_index_one_node);
2978	}
2979
2980	/* TODO: don't re-evaluate the descriptor on each iteration. */
2981	/* Get a descriptor for the first parameter. */
2982	gfc_init_se (&argse, NULL);
2983	gfc_conv_expr_descriptor (&argse, arg->expr);
2984	gfc_add_block_to_block (&se->pre, &argse.pre);
2985	gfc_add_block_to_block (&se->post, &argse.post);
2986
2987	desc = argse.expr;
2988
2989	as = gfc_get_full_arrayspec_from_expr (expr: arg->expr);
2990
2991	if (INTEGER_CST_P (bound))
2992	{
2993	gcc_assert (op != GFC_ISYM_SHAPE);
2994	if (((!as || as->type != AS_ASSUMED_RANK)
2995	&& wi::geu_p (x: wi::to_wide (t: bound),
2996	GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2997	|| wi::gtu_p (x: wi::to_wide (t: bound), GFC_MAX_DIMENSIONS))
2998	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2999	"dimension index",
3000	(op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
3001	&expr->where);
3002	}
3003
3004	if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
3005	{
3006	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3007	{
3008	bound = gfc_evaluate_now (bound, &se->pre);
3009	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3010	bound, build_int_cst (TREE_TYPE (bound), 0));
3011	if (as && as->type == AS_ASSUMED_RANK)
3012	tmp = gfc_conv_descriptor_rank (desc);
3013	else
3014	tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
3015	tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3016	bound, fold_convert(TREE_TYPE (bound), tmp));
3017	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3018	logical_type_node, cond, tmp);
3019	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3020	gfc_msg_fault);
3021	}
3022	}
3023
3024	/* Take care of the lbound shift for assumed-rank arrays that are
3025	nonallocatable and nonpointers. Those have a lbound of 1. */
3026	assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
3027	&& ((arg->expr->ts.type != BT_CLASS
3028	&& !arg->expr->symtree->n.sym->attr.allocatable
3029	&& !arg->expr->symtree->n.sym->attr.pointer)
3030	|| (arg->expr->ts.type == BT_CLASS
3031	&& !CLASS_DATA (arg->expr)->attr.allocatable
3032	&& !CLASS_DATA (arg->expr)->attr.class_pointer));
3033
3034	ubound = gfc_conv_descriptor_ubound_get (desc, bound);
3035	lbound = gfc_conv_descriptor_lbound_get (desc, bound);
3036	size = fold_build2_loc (input_location, MINUS_EXPR,
3037	gfc_array_index_type, ubound, lbound);
3038	size = fold_build2_loc (input_location, PLUS_EXPR,
3039	gfc_array_index_type, size, gfc_index_one_node);
3040
3041	/* 13.14.53: Result value for LBOUND
3042
3043	Case (i): For an array section or for an array expression other than a
3044	whole array or array structure component, LBOUND(ARRAY, DIM)
3045	has the value 1. For a whole array or array structure
3046	component, LBOUND(ARRAY, DIM) has the value:
3047	(a) equal to the lower bound for subscript DIM of ARRAY if
3048	dimension DIM of ARRAY does not have extent zero
3049	or if ARRAY is an assumed-size array of rank DIM,
3050	or (b) 1 otherwise.
3051
3052	13.14.113: Result value for UBOUND
3053
3054	Case (i): For an array section or for an array expression other than a
3055	whole array or array structure component, UBOUND(ARRAY, DIM)
3056	has the value equal to the number of elements in the given
3057	dimension; otherwise, it has a value equal to the upper bound
3058	for subscript DIM of ARRAY if dimension DIM of ARRAY does
3059	not have size zero and has value zero if dimension DIM has
3060	size zero. */
3061
3062	if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
3063	se->expr = gfc_index_one_node;
3064	else if (as)
3065	{
3066	if (op == GFC_ISYM_UBOUND)
3067	{
3068	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3069	size, gfc_index_zero_node);
3070	se->expr = fold_build3_loc (input_location, COND_EXPR,
3071	gfc_array_index_type, cond,
3072	(assumed_rank_lb_one ? size : ubound),
3073	gfc_index_zero_node);
3074	}
3075	else if (op == GFC_ISYM_LBOUND)
3076	{
3077	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3078	size, gfc_index_zero_node);
3079	if (as->type == AS_ASSUMED_SIZE)
3080	{
3081	cond1 = fold_build2_loc (input_location, EQ_EXPR,
3082	logical_type_node, bound,
3083	build_int_cst (TREE_TYPE (bound),
3084	arg->expr->rank - 1));
3085	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3086	logical_type_node, cond, cond1);
3087	}
3088	se->expr = fold_build3_loc (input_location, COND_EXPR,
3089	gfc_array_index_type, cond,
3090	lbound, gfc_index_one_node);
3091	}
3092	else if (op == GFC_ISYM_SHAPE)
3093	se->expr = size;
3094	else
3095	gcc_unreachable ();
3096
3097	/* According to F2018 16.9.172, para 5, an assumed rank object,
3098	argument associated with and assumed size array, has the ubound
3099	of the final dimension set to -1 and UBOUND must return this.
3100	Similarly for the SHAPE intrinsic. */
3101	if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
3102	{
3103	tree minus_one = build_int_cst (gfc_array_index_type, -1);
3104	tree rank = fold_convert (gfc_array_index_type,
3105	gfc_conv_descriptor_rank (desc));
3106	rank = fold_build2_loc (input_location, PLUS_EXPR,
3107	gfc_array_index_type, rank, minus_one);
3108
3109	/* Fix the expression to stop it from becoming even more
3110	complicated. */
3111	se->expr = gfc_evaluate_now (se->expr, &se->pre);
3112
3113	/* Descriptors for assumed-size arrays have ubound = -1
3114	in the last dimension. */
3115	cond1 = fold_build2_loc (input_location, EQ_EXPR,
3116	logical_type_node, ubound, minus_one);
3117	cond = fold_build2_loc (input_location, EQ_EXPR,
3118	logical_type_node, bound, rank);
3119	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3120	logical_type_node, cond, cond1);
3121	se->expr = fold_build3_loc (input_location, COND_EXPR,
3122	gfc_array_index_type, cond,
3123	minus_one, se->expr);
3124	}
3125	}
3126	else /* as is null; this is an old-fashioned 1-based array. */
3127	{
3128	if (op != GFC_ISYM_LBOUND)
3129	{
3130	se->expr = fold_build2_loc (input_location, MAX_EXPR,
3131	gfc_array_index_type, size,
3132	gfc_index_zero_node);
3133	}
3134	else
3135	se->expr = gfc_index_one_node;
3136	}
3137
3138
3139	type = gfc_typenode_for_spec (&expr->ts);
3140	se->expr = convert (type, se->expr);
3141	}
3142
3143
3144	static void
3145	conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
3146	{
3147	gfc_actual_arglist *arg;
3148	gfc_actual_arglist *arg2;
3149	gfc_se argse;
3150	tree bound, resbound, resbound2, desc, cond, tmp;
3151	tree type;
3152	int corank;
3153
3154	gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
3155	|| expr->value.function.isym->id == GFC_ISYM_UCOBOUND
3156	|| expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
3157
3158	arg = expr->value.function.actual;
3159	arg2 = arg->next;
3160
3161	gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
3162	corank = gfc_get_corank (arg->expr);
3163
3164	gfc_init_se (&argse, NULL);
3165	argse.want_coarray = 1;
3166
3167	gfc_conv_expr_descriptor (&argse, arg->expr);
3168	gfc_add_block_to_block (&se->pre, &argse.pre);
3169	gfc_add_block_to_block (&se->post, &argse.post);
3170	desc = argse.expr;
3171
3172	if (se->ss)
3173	{
3174	/* Create an implicit second parameter from the loop variable. */
3175	gcc_assert (!arg2->expr);
3176	gcc_assert (corank > 0);
3177	gcc_assert (se->loop->dimen == 1);
3178	gcc_assert (se->ss->info->expr == expr);
3179
3180	bound = se->loop->loopvar[0];
3181	bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3182	bound, gfc_rank_cst[arg->expr->rank]);
3183	gfc_advance_se_ss_chain (se);
3184	}
3185	else
3186	{
3187	/* use the passed argument. */
3188	gcc_assert (arg2->expr);
3189	gfc_init_se (&argse, NULL);
3190	gfc_conv_expr_type (se: &argse, arg2->expr, gfc_array_index_type);
3191	gfc_add_block_to_block (&se->pre, &argse.pre);
3192	bound = argse.expr;
3193
3194	if (INTEGER_CST_P (bound))
3195	{
3196	if (wi::ltu_p (x: wi::to_wide (t: bound), y: 1)
3197	|| wi::gtu_p (x: wi::to_wide (t: bound),
3198	GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
3199	gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3200	"dimension index", expr->value.function.isym->name,
3201	&expr->where);
3202	}
3203	else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3204	{
3205	bound = gfc_evaluate_now (bound, &se->pre);
3206	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3207	bound, build_int_cst (TREE_TYPE (bound), 1));
3208	tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
3209	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3210	bound, tmp);
3211	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3212	logical_type_node, cond, tmp);
3213	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3214	gfc_msg_fault);
3215	}
3216
3217
3218	/* Subtract 1 to get to zero based and add dimensions. */
3219	switch (arg->expr->rank)
3220	{
3221	case 0:
3222	bound = fold_build2_loc (input_location, MINUS_EXPR,
3223	gfc_array_index_type, bound,
3224	gfc_index_one_node);
3225	case 1:
3226	break;
3227	default:
3228	bound = fold_build2_loc (input_location, PLUS_EXPR,
3229	gfc_array_index_type, bound,
3230	gfc_rank_cst[arg->expr->rank - 1]);
3231	}
3232	}
3233
3234	resbound = gfc_conv_descriptor_lbound_get (desc, bound);
3235
3236	/* Handle UCOBOUND with special handling of the last codimension. */
3237	if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
3238	{
3239	/* Last codimension: For -fcoarray=single just return
3240	the lcobound - otherwise add
3241	ceiling (real (num_images ()) / real (size)) - 1
3242	= (num_images () + size - 1) / size - 1
3243	= (num_images - 1) / size(),
3244	where size is the product of the extent of all but the last
3245	codimension. */
3246
3247	if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
3248	{
3249	tree cosize;
3250
3251	cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
3252	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3253	2, integer_zero_node,
3254	build_int_cst (integer_type_node, -1));
3255	tmp = fold_build2_loc (input_location, MINUS_EXPR,
3256	gfc_array_index_type,
3257	fold_convert (gfc_array_index_type, tmp),
3258	build_int_cst (gfc_array_index_type, 1));
3259	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
3260	gfc_array_index_type, tmp,
3261	fold_convert (gfc_array_index_type, cosize));
3262	resbound = fold_build2_loc (input_location, PLUS_EXPR,
3263	gfc_array_index_type, resbound, tmp);
3264	}
3265	else if (flag_coarray != GFC_FCOARRAY_SINGLE)
3266	{
3267	/* ubound = lbound + num_images() - 1. */
3268	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3269	2, integer_zero_node,
3270	build_int_cst (integer_type_node, -1));
3271	tmp = fold_build2_loc (input_location, MINUS_EXPR,
3272	gfc_array_index_type,
3273	fold_convert (gfc_array_index_type, tmp),
3274	build_int_cst (gfc_array_index_type, 1));
3275	resbound = fold_build2_loc (input_location, PLUS_EXPR,
3276	gfc_array_index_type, resbound, tmp);
3277	}
3278
3279	if (corank > 1)
3280	{
3281	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3282	bound,
3283	build_int_cst (TREE_TYPE (bound),
3284	arg->expr->rank + corank - 1));
3285
3286	resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
3287	se->expr = fold_build3_loc (input_location, COND_EXPR,
3288	gfc_array_index_type, cond,
3289	resbound, resbound2);
3290	}
3291	else
3292	se->expr = resbound;
3293	}
3294	else
3295	se->expr = resbound;
3296
3297	type = gfc_typenode_for_spec (&expr->ts);
3298	se->expr = convert (type, se->expr);
3299	}
3300
3301
3302	static void
3303	conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
3304	{
3305	gfc_actual_arglist *array_arg;
3306	gfc_actual_arglist *dim_arg;
3307	gfc_se argse;
3308	tree desc, tmp;
3309
3310	array_arg = expr->value.function.actual;
3311	dim_arg = array_arg->next;
3312
3313	gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
3314
3315	gfc_init_se (&argse, NULL);
3316	gfc_conv_expr_descriptor (&argse, array_arg->expr);
3317	gfc_add_block_to_block (&se->pre, &argse.pre);
3318	gfc_add_block_to_block (&se->post, &argse.post);
3319	desc = argse.expr;
3320
3321	gcc_assert (dim_arg->expr);
3322	gfc_init_se (&argse, NULL);
3323	gfc_conv_expr_type (se: &argse, dim_arg->expr, gfc_array_index_type);
3324	gfc_add_block_to_block (&se->pre, &argse.pre);
3325	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3326	argse.expr, gfc_index_one_node);
3327	se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
3328	}
3329
3330	static void
3331	gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
3332	{
3333	tree arg, cabs;
3334
3335	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
3336
3337	switch (expr->value.function.actual->expr->ts.type)
3338	{
3339	case BT_INTEGER:
3340	case BT_REAL:
3341	se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
3342	arg);
3343	break;
3344
3345	case BT_COMPLEX:
3346	cabs = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_CABS, kind: expr->ts.kind);
3347	se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3348	break;
3349
3350	default:
3351	gcc_unreachable ();
3352	}
3353	}
3354
3355
3356	/* Create a complex value from one or two real components. */
3357
3358	static void
3359	gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3360	{
3361	tree real;
3362	tree imag;
3363	tree type;
3364	tree *args;
3365	unsigned int num_args;
3366
3367	num_args = gfc_intrinsic_argument_list_length (expr);
3368	args = XALLOCAVEC (tree, num_args);
3369
3370	type = gfc_typenode_for_spec (&expr->ts);
3371	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
3372	real = convert (TREE_TYPE (type), args[0]);
3373	if (both)
3374	imag = convert (TREE_TYPE (type), args[1]);
3375	else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3376	{
3377	imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3378	TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3379	imag = convert (TREE_TYPE (type), imag);
3380	}
3381	else
3382	imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3383
3384	se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3385	}
3386
3387
3388	/* Remainder function MOD(A, P) = A - INT(A / P) * P
3389	MODULO(A, P) = A - FLOOR (A / P) * P
3390
3391	The obvious algorithms above are numerically instable for large
3392	arguments, hence these intrinsics are instead implemented via calls
3393	to the fmod family of functions. It is the responsibility of the
3394	user to ensure that the second argument is non-zero. */
3395
3396	static void
3397	gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3398	{
3399	tree type;
3400	tree tmp;
3401	tree test;
3402	tree test2;
3403	tree fmod;
3404	tree zero;
3405	tree args[2];
3406
3407	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3408
3409	switch (expr->ts.type)
3410	{
3411	case BT_INTEGER:
3412	/* Integer case is easy, we've got a builtin op. */
3413	type = TREE_TYPE (args[0]);
3414
3415	if (modulo)
3416	se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3417	args[0], args[1]);
3418	else
3419	se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3420	args[0], args[1]);
3421	break;
3422
3423	case BT_REAL:
3424	fmod = NULL_TREE;
3425	/* Check if we have a builtin fmod. */
3426	fmod = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FMOD, kind: expr->ts.kind);
3427
3428	/* The builtin should always be available. */
3429	gcc_assert (fmod != NULL_TREE);
3430
3431	tmp = build_addr (fmod);
3432	se->expr = build_call_array_loc (input_location,
3433	TREE_TYPE (TREE_TYPE (fmod)),
3434	tmp, 2, args);
3435	if (modulo == 0)
3436	return;
3437
3438	type = TREE_TYPE (args[0]);
3439
3440	args[0] = gfc_evaluate_now (args[0], &se->pre);
3441	args[1] = gfc_evaluate_now (args[1], &se->pre);
3442
3443	/* Definition:
3444	modulo = arg - floor (arg/arg2) * arg2
3445
3446	In order to calculate the result accurately, we use the fmod
3447	function as follows.
3448
3449	res = fmod (arg, arg2);
3450	if (res)
3451	{
3452	if ((arg < 0) xor (arg2 < 0))
3453	res += arg2;
3454	}
3455	else
3456	res = copysign (0., arg2);
3457
3458	=> As two nested ternary exprs:
3459
3460	res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3461	: copysign (0., arg2);
3462
3463	*/
3464
3465	zero = gfc_build_const (type, integer_zero_node);
3466	tmp = gfc_evaluate_now (se->expr, &se->pre);
3467	if (!flag_signed_zeros)
3468	{
3469	test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3470	args[0], zero);
3471	test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3472	args[1], zero);
3473	test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3474	logical_type_node, test, test2);
3475	test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3476	tmp, zero);
3477	test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3478	logical_type_node, test, test2);
3479	test = gfc_evaluate_now (test, &se->pre);
3480	se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3481	fold_build2_loc (input_location,
3482	PLUS_EXPR,
3483	type, tmp, args[1]),
3484	tmp);
3485	}
3486	else
3487	{
3488	tree expr1, copysign, cscall;
3489	copysign = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_COPYSIGN,
3490	kind: expr->ts.kind);
3491	test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3492	args[0], zero);
3493	test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3494	args[1], zero);
3495	test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3496	logical_type_node, test, test2);
3497	expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3498	fold_build2_loc (input_location,
3499	PLUS_EXPR,
3500	type, tmp, args[1]),
3501	tmp);
3502	test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3503	tmp, zero);
3504	cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3505	args[1]);
3506	se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3507	expr1, cscall);
3508	}
3509	return;
3510
3511	default:
3512	gcc_unreachable ();
3513	}
3514	}
3515
3516	/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3517	DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3518	where the right shifts are logical (i.e. 0's are shifted in).
3519	Because SHIFT_EXPR's want shifts strictly smaller than the integral
3520	type width, we have to special-case both S == 0 and S == BITSIZE(J):
3521	DSHIFTL(I,J,0) = I
3522	DSHIFTL(I,J,BITSIZE) = J
3523	DSHIFTR(I,J,0) = J
3524	DSHIFTR(I,J,BITSIZE) = I. */
3525
3526	static void
3527	gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3528	{
3529	tree type, utype, stype, arg1, arg2, shift, res, left, right;
3530	tree args[3], cond, tmp;
3531	int bitsize;
3532
3533	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
3534
3535	gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3536	type = TREE_TYPE (args[0]);
3537	bitsize = TYPE_PRECISION (type);
3538	utype = unsigned_type_for (type);
3539	stype = TREE_TYPE (args[2]);
3540
3541	arg1 = gfc_evaluate_now (args[0], &se->pre);
3542	arg2 = gfc_evaluate_now (args[1], &se->pre);
3543	shift = gfc_evaluate_now (args[2], &se->pre);
3544
3545	/* The generic case. */
3546	tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3547	build_int_cst (stype, bitsize), shift);
3548	left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3549	arg1, dshiftl ? shift : tmp);
3550
3551	right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3552	fold_convert (utype, arg2), dshiftl ? tmp : shift);
3553	right = fold_convert (type, right);
3554
3555	res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3556
3557	/* Special cases. */
3558	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3559	build_int_cst (stype, 0));
3560	res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3561	dshiftl ? arg1 : arg2, res);
3562
3563	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3564	build_int_cst (stype, bitsize));
3565	res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3566	dshiftl ? arg2 : arg1, res);
3567
3568	se->expr = res;
3569	}
3570
3571
3572	/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3573
3574	static void
3575	gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3576	{
3577	tree val;
3578	tree tmp;
3579	tree type;
3580	tree zero;
3581	tree args[2];
3582
3583	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3584	type = TREE_TYPE (args[0]);
3585
3586	val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3587	val = gfc_evaluate_now (val, &se->pre);
3588
3589	zero = gfc_build_const (type, integer_zero_node);
3590	tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3591	se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3592	}
3593
3594
3595	/* SIGN(A, B) is absolute value of A times sign of B.
3596	The real value versions use library functions to ensure the correct
3597	handling of negative zero. Integer case implemented as:
3598	SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3599	*/
3600
3601	static void
3602	gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3603	{
3604	tree tmp;
3605	tree type;
3606	tree args[2];
3607
3608	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3609	if (expr->ts.type == BT_REAL)
3610	{
3611	tree abs;
3612
3613	tmp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_COPYSIGN, kind: expr->ts.kind);
3614	abs = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FABS, kind: expr->ts.kind);
3615
3616	/* We explicitly have to ignore the minus sign. We do so by using
3617	result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3618	if (!flag_sign_zero
3619	&& MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3620	{
3621	tree cond, zero;
3622	zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3623	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3624	args[1], zero);
3625	se->expr = fold_build3_loc (input_location, COND_EXPR,
3626	TREE_TYPE (args[0]), cond,
3627	build_call_expr_loc (input_location, abs, 1,
3628	args[0]),
3629	build_call_expr_loc (input_location, tmp, 2,
3630	args[0], args[1]));
3631	}
3632	else
3633	se->expr = build_call_expr_loc (input_location, tmp, 2,
3634	args[0], args[1]);
3635	return;
3636	}
3637
3638	/* Having excluded floating point types, we know we are now dealing
3639	with signed integer types. */
3640	type = TREE_TYPE (args[0]);
3641
3642	/* Args[0] is used multiple times below. */
3643	args[0] = gfc_evaluate_now (args[0], &se->pre);
3644
3645	/* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3646	the signs of A and B are the same, and of all ones if they differ. */
3647	tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3648	tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3649	build_int_cst (type, TYPE_PRECISION (type) - 1));
3650	tmp = gfc_evaluate_now (tmp, &se->pre);
3651
3652	/* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3653	is all ones (i.e. -1). */
3654	se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3655	fold_build2_loc (input_location, PLUS_EXPR,
3656	type, args[0], tmp), tmp);
3657	}
3658
3659
3660	/* Test for the presence of an optional argument. */
3661
3662	static void
3663	gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3664	{
3665	gfc_expr *arg;
3666
3667	arg = expr->value.function.actual->expr;
3668	gcc_assert (arg->expr_type == EXPR_VARIABLE);
3669	se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3670	se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3671	}
3672
3673
3674	/* Calculate the double precision product of two single precision values. */
3675
3676	static void
3677	gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3678	{
3679	tree type;
3680	tree args[2];
3681
3682	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
3683
3684	/* Convert the args to double precision before multiplying. */
3685	type = gfc_typenode_for_spec (&expr->ts);
3686	args[0] = convert (type, args[0]);
3687	args[1] = convert (type, args[1]);
3688	se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3689	args[1]);
3690	}
3691
3692
3693	/* Return a length one character string containing an ascii character. */
3694
3695	static void
3696	gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3697	{
3698	tree arg[2];
3699	tree var;
3700	tree type;
3701	unsigned int num_args;
3702
3703	num_args = gfc_intrinsic_argument_list_length (expr);
3704	gfc_conv_intrinsic_function_args (se, expr, argarray: arg, nargs: num_args);
3705
3706	type = gfc_get_char_type (expr->ts.kind);
3707	var = gfc_create_var (type, "char");
3708
3709	arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3710	gfc_add_modify (&se->pre, var, arg[0]);
3711	se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3712	se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3713	}
3714
3715
3716	static void
3717	gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3718	{
3719	tree var;
3720	tree len;
3721	tree tmp;
3722	tree cond;
3723	tree fndecl;
3724	tree *args;
3725	unsigned int num_args;
3726
3727	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3728	args = XALLOCAVEC (tree, num_args);
3729
3730	var = gfc_create_var (pchar_type_node, "pstr");
3731	len = gfc_create_var (gfc_charlen_type_node, "len");
3732
3733	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
3734	args[0] = gfc_build_addr_expr (NULL_TREE, var);
3735	args[1] = gfc_build_addr_expr (NULL_TREE, len);
3736
3737	fndecl = build_addr (gfor_fndecl_ctime);
3738	tmp = build_call_array_loc (input_location,
3739	TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3740	fndecl, num_args, args);
3741	gfc_add_expr_to_block (&se->pre, tmp);
3742
3743	/* Free the temporary afterwards, if necessary. */
3744	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3745	len, build_int_cst (TREE_TYPE (len), 0));
3746	tmp = gfc_call_free (var);
3747	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3748	gfc_add_expr_to_block (&se->post, tmp);
3749
3750	se->expr = var;
3751	se->string_length = len;
3752	}
3753
3754
3755	static void
3756	gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3757	{
3758	tree var;
3759	tree len;
3760	tree tmp;
3761	tree cond;
3762	tree fndecl;
3763	tree *args;
3764	unsigned int num_args;
3765
3766	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3767	args = XALLOCAVEC (tree, num_args);
3768
3769	var = gfc_create_var (pchar_type_node, "pstr");
3770	len = gfc_create_var (gfc_charlen_type_node, "len");
3771
3772	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
3773	args[0] = gfc_build_addr_expr (NULL_TREE, var);
3774	args[1] = gfc_build_addr_expr (NULL_TREE, len);
3775
3776	fndecl = build_addr (gfor_fndecl_fdate);
3777	tmp = build_call_array_loc (input_location,
3778	TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3779	fndecl, num_args, args);
3780	gfc_add_expr_to_block (&se->pre, tmp);
3781
3782	/* Free the temporary afterwards, if necessary. */
3783	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3784	len, build_int_cst (TREE_TYPE (len), 0));
3785	tmp = gfc_call_free (var);
3786	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3787	gfc_add_expr_to_block (&se->post, tmp);
3788
3789	se->expr = var;
3790	se->string_length = len;
3791	}
3792
3793
3794	/* Generate a direct call to free() for the FREE subroutine. */
3795
3796	static tree
3797	conv_intrinsic_free (gfc_code *code)
3798	{
3799	stmtblock_t block;
3800	gfc_se argse;
3801	tree arg, call;
3802
3803	gfc_init_se (&argse, NULL);
3804	gfc_conv_expr (se: &argse, expr: code->ext.actual->expr);
3805	arg = fold_convert (ptr_type_node, argse.expr);
3806
3807	gfc_init_block (&block);
3808	call = build_call_expr_loc (input_location,
3809	builtin_decl_explicit (fncode: BUILT_IN_FREE), 1, arg);
3810	gfc_add_expr_to_block (&block, call);
3811	return gfc_finish_block (&block);
3812	}
3813
3814
3815	/* Call the RANDOM_INIT library subroutine with a hidden argument for
3816	handling seeding on coarray images. */
3817
3818	static tree
3819	conv_intrinsic_random_init (gfc_code *code)
3820	{
3821	stmtblock_t block;
3822	gfc_se se;
3823	tree arg1, arg2, tmp;
3824	/* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3825	tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3826	? logical_type_node
3827	: gfc_get_logical_type (4);
3828
3829	/* Make the function call. */
3830	gfc_init_block (&block);
3831	gfc_init_se (&se, NULL);
3832
3833	/* Convert REPEATABLE to the desired LOGICAL entity. */
3834	gfc_conv_expr (se: &se, expr: code->ext.actual->expr);
3835	gfc_add_block_to_block (&block, &se.pre);
3836	arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3837	gfc_add_block_to_block (&block, &se.post);
3838
3839	/* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3840	gfc_conv_expr (se: &se, expr: code->ext.actual->next->expr);
3841	gfc_add_block_to_block (&block, &se.pre);
3842	arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3843	gfc_add_block_to_block (&block, &se.post);
3844
3845	if (flag_coarray == GFC_FCOARRAY_LIB)
3846	{
3847	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3848	2, arg1, arg2);
3849	}
3850	else
3851	{
3852	/* The ABI for libgfortran needs to be maintained, so a hidden
3853	argument must be include if code is compiled with -fcoarray=single
3854	or without the option. Set to 0. */
3855	tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3856	tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3857	3, arg1, arg2, arg3);
3858	}
3859
3860	gfc_add_expr_to_block (&block, tmp);
3861
3862	return gfc_finish_block (&block);
3863	}
3864
3865
3866	/* Call the SYSTEM_CLOCK library functions, handling the type and kind
3867	conversions. */
3868
3869	static tree
3870	conv_intrinsic_system_clock (gfc_code *code)
3871	{
3872	stmtblock_t block;
3873	gfc_se count_se, count_rate_se, count_max_se;
3874	tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3875	tree tmp;
3876	int least;
3877
3878	gfc_expr *count = code->ext.actual->expr;
3879	gfc_expr *count_rate = code->ext.actual->next->expr;
3880	gfc_expr *count_max = code->ext.actual->next->next->expr;
3881
3882	/* Evaluate our arguments. */
3883	if (count)
3884	{
3885	gfc_init_se (&count_se, NULL);
3886	gfc_conv_expr (se: &count_se, expr: count);
3887	}
3888
3889	if (count_rate)
3890	{
3891	gfc_init_se (&count_rate_se, NULL);
3892	gfc_conv_expr (se: &count_rate_se, expr: count_rate);
3893	}
3894
3895	if (count_max)
3896	{
3897	gfc_init_se (&count_max_se, NULL);
3898	gfc_conv_expr (se: &count_max_se, expr: count_max);
3899	}
3900
3901	/* Find the smallest kind found of the arguments. */
3902	least = 16;
3903	least = (count && count->ts.kind < least) ? count->ts.kind : least;
3904	least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3905	: least;
3906	least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3907	: least;
3908
3909	/* Prepare temporary variables. */
3910
3911	if (count)
3912	{
3913	if (least >= 8)
3914	arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3915	else if (least == 4)
3916	arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3917	else if (count->ts.kind == 1)
3918	arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3919	count->ts.kind);
3920	else
3921	arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3922	count->ts.kind);
3923	}
3924
3925	if (count_rate)
3926	{
3927	if (least >= 8)
3928	arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3929	else if (least == 4)
3930	arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3931	else
3932	arg2 = integer_zero_node;
3933	}
3934
3935	if (count_max)
3936	{
3937	if (least >= 8)
3938	arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3939	else if (least == 4)
3940	arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3941	else
3942	arg3 = integer_zero_node;
3943	}
3944
3945	/* Make the function call. */
3946	gfc_init_block (&block);
3947
3948	if (least <= 2)
3949	{
3950	if (least == 1)
3951	{
3952	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3953	: null_pointer_node;
3954	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3955	: null_pointer_node;
3956	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3957	: null_pointer_node;
3958	}
3959
3960	if (least == 2)
3961	{
3962	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3963	: null_pointer_node;
3964	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3965	: null_pointer_node;
3966	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3967	: null_pointer_node;
3968	}
3969	}
3970	else
3971	{
3972	if (least == 4)
3973	{
3974	tmp = build_call_expr_loc (input_location,
3975	gfor_fndecl_system_clock4, 3,
3976	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3977	: null_pointer_node,
3978	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3979	: null_pointer_node,
3980	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3981	: null_pointer_node);
3982	gfc_add_expr_to_block (&block, tmp);
3983	}
3984	/* Handle kind>=8, 10, or 16 arguments */
3985	if (least >= 8)
3986	{
3987	tmp = build_call_expr_loc (input_location,
3988	gfor_fndecl_system_clock8, 3,
3989	arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3990	: null_pointer_node,
3991	arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3992	: null_pointer_node,
3993	arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3994	: null_pointer_node);
3995	gfc_add_expr_to_block (&block, tmp);
3996	}
3997	}
3998
3999	/* And store values back if needed. */
4000	if (arg1 && arg1 != count_se.expr)
4001	gfc_add_modify (&block, count_se.expr,
4002	fold_convert (TREE_TYPE (count_se.expr), arg1));
4003	if (arg2 && arg2 != count_rate_se.expr)
4004	gfc_add_modify (&block, count_rate_se.expr,
4005	fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
4006	if (arg3 && arg3 != count_max_se.expr)
4007	gfc_add_modify (&block, count_max_se.expr,
4008	fold_convert (TREE_TYPE (count_max_se.expr), arg3));
4009
4010	return gfc_finish_block (&block);
4011	}
4012
4013
4014	/* Return a character string containing the tty name. */
4015
4016	static void
4017	gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
4018	{
4019	tree var;
4020	tree len;
4021	tree tmp;
4022	tree cond;
4023	tree fndecl;
4024	tree *args;
4025	unsigned int num_args;
4026
4027	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4028	args = XALLOCAVEC (tree, num_args);
4029
4030	var = gfc_create_var (pchar_type_node, "pstr");
4031	len = gfc_create_var (gfc_charlen_type_node, "len");
4032
4033	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
4034	args[0] = gfc_build_addr_expr (NULL_TREE, var);
4035	args[1] = gfc_build_addr_expr (NULL_TREE, len);
4036
4037	fndecl = build_addr (gfor_fndecl_ttynam);
4038	tmp = build_call_array_loc (input_location,
4039	TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
4040	fndecl, num_args, args);
4041	gfc_add_expr_to_block (&se->pre, tmp);
4042
4043	/* Free the temporary afterwards, if necessary. */
4044	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4045	len, build_int_cst (TREE_TYPE (len), 0));
4046	tmp = gfc_call_free (var);
4047	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4048	gfc_add_expr_to_block (&se->post, tmp);
4049
4050	se->expr = var;
4051	se->string_length = len;
4052	}
4053
4054
4055	/* Get the minimum/maximum value of all the parameters.
4056	minmax (a1, a2, a3, ...)
4057	{
4058	mvar = a1;
4059	mvar = COMP (mvar, a2)
4060	mvar = COMP (mvar, a3)
4061	...
4062	return mvar;
4063	}
4064	Where COMP is MIN/MAX_EXPR for integral types or when we don't
4065	care about NaNs, or IFN_FMIN/MAX when the target has support for
4066	fast NaN-honouring min/max. When neither holds expand a sequence
4067	of explicit comparisons. */
4068
4069	/* TODO: Mismatching types can occur when specific names are used.
4070	These should be handled during resolution. */
4071	static void
4072	gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
4073	{
4074	tree tmp;
4075	tree mvar;
4076	tree val;
4077	tree *args;
4078	tree type;
4079	tree argtype;
4080	gfc_actual_arglist *argexpr;
4081	unsigned int i, nargs;
4082
4083	nargs = gfc_intrinsic_argument_list_length (expr);
4084	args = XALLOCAVEC (tree, nargs);
4085
4086	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
4087	type = gfc_typenode_for_spec (&expr->ts);
4088
4089	/* Only evaluate the argument once. */
4090	if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
4091	args[0] = gfc_evaluate_now (args[0], &se->pre);
4092
4093	/* Determine suitable type of temporary, as a GNU extension allows
4094	different argument kinds. */
4095	argtype = TREE_TYPE (args[0]);
4096	argexpr = expr->value.function.actual;
4097	for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4098	{
4099	tree tmptype = TREE_TYPE (args[i]);
4100	if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
4101	argtype = tmptype;
4102	}
4103	mvar = gfc_create_var (argtype, "M");
4104	gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
4105
4106	argexpr = expr->value.function.actual;
4107	for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4108	{
4109	tree cond = NULL_TREE;
4110	val = args[i];
4111
4112	/* Handle absent optional arguments by ignoring the comparison. */
4113	if (argexpr->expr->expr_type == EXPR_VARIABLE
4114	&& argexpr->expr->symtree->n.sym->attr.optional
4115	&& INDIRECT_REF_P (val))
4116	{
4117	cond = fold_build2_loc (input_location,
4118	NE_EXPR, logical_type_node,
4119	TREE_OPERAND (val, 0),
4120	build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
4121	}
4122	else if (!VAR_P (val) && !TREE_CONSTANT (val))
4123	/* Only evaluate the argument once. */
4124	val = gfc_evaluate_now (val, &se->pre);
4125
4126	tree calc;
4127	/* For floating point types, the question is what MAX(a, NaN) or
4128	MIN(a, NaN) should return (where "a" is a normal number).
4129	There are valid use case for returning either one, but the
4130	Fortran standard doesn't specify which one should be chosen.
4131	Also, there is no consensus among other tested compilers. In
4132	short, it's a mess. So lets just do whatever is fastest. */
4133	tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
4134	calc = fold_build2_loc (input_location, code, argtype,
4135	convert (argtype, val), mvar);
4136	tmp = build2_v (MODIFY_EXPR, mvar, calc);
4137
4138	if (cond != NULL_TREE)
4139	tmp = build3_v (COND_EXPR, cond, tmp,
4140	build_empty_stmt (input_location));
4141	gfc_add_expr_to_block (&se->pre, tmp);
4142	}
4143	se->expr = convert (type, mvar);
4144	}
4145
4146
4147	/* Generate library calls for MIN and MAX intrinsics for character
4148	variables. */
4149	static void
4150	gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
4151	{
4152	tree *args;
4153	tree var, len, fndecl, tmp, cond, function;
4154	unsigned int nargs;
4155
4156	nargs = gfc_intrinsic_argument_list_length (expr);
4157	args = XALLOCAVEC (tree, nargs + 4);
4158	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[4], nargs);
4159
4160	/* Create the result variables. */
4161	len = gfc_create_var (gfc_charlen_type_node, "len");
4162	args[0] = gfc_build_addr_expr (NULL_TREE, len);
4163	var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4164	args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
4165	args[2] = build_int_cst (integer_type_node, op);
4166	args[3] = build_int_cst (integer_type_node, nargs / 2);
4167
4168	if (expr->ts.kind == 1)
4169	function = gfor_fndecl_string_minmax;
4170	else if (expr->ts.kind == 4)
4171	function = gfor_fndecl_string_minmax_char4;
4172	else
4173	gcc_unreachable ();
4174
4175	/* Make the function call. */
4176	fndecl = build_addr (function);
4177	tmp = build_call_array_loc (input_location,
4178	TREE_TYPE (TREE_TYPE (function)), fndecl,
4179	nargs + 4, args);
4180	gfc_add_expr_to_block (&se->pre, tmp);
4181
4182	/* Free the temporary afterwards, if necessary. */
4183	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4184	len, build_int_cst (TREE_TYPE (len), 0));
4185	tmp = gfc_call_free (var);
4186	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4187	gfc_add_expr_to_block (&se->post, tmp);
4188
4189	se->expr = var;
4190	se->string_length = len;
4191	}
4192
4193
4194	/* Create a symbol node for this intrinsic. The symbol from the frontend
4195	has the generic name. */
4196
4197	static gfc_symbol *
4198	gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
4199	{
4200	gfc_symbol *sym;
4201
4202	/* TODO: Add symbols for intrinsic function to the global namespace. */
4203	gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
4204	sym = gfc_new_symbol (expr->value.function.name, NULL);
4205
4206	sym->ts = expr->ts;
4207	sym->attr.external = 1;
4208	sym->attr.function = 1;
4209	sym->attr.always_explicit = 1;
4210	sym->attr.proc = PROC_INTRINSIC;
4211	sym->attr.flavor = FL_PROCEDURE;
4212	sym->result = sym;
4213	if (expr->rank > 0)
4214	{
4215	sym->attr.dimension = 1;
4216	sym->as = gfc_get_array_spec ();
4217	sym->as->type = AS_ASSUMED_SHAPE;
4218	sym->as->rank = expr->rank;
4219	}
4220
4221	gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4222	ignore_optional ? expr->value.function.actual
4223	: NULL);
4224
4225	return sym;
4226	}
4227
4228	/* Remove empty actual arguments. */
4229
4230	static void
4231	remove_empty_actual_arguments (gfc_actual_arglist **ap)
4232	{
4233	while (*ap)
4234	{
4235	if ((*ap)->expr == NULL)
4236	{
4237	gfc_actual_arglist *r = *ap;
4238	*ap = r->next;
4239	r->next = NULL;
4240	gfc_free_actual_arglist (r);
4241	}
4242	else
4243	ap = &((*ap)->next);
4244	}
4245	}
4246
4247	#define MAX_SPEC_ARG 12
4248
4249	/* Make up an fn spec that's right for intrinsic functions that we
4250	want to call. */
4251
4252	static char *
4253	intrinsic_fnspec (gfc_expr *expr)
4254	{
4255	static char fnspec_buf[MAX_SPEC_ARG*2+1];
4256	char *fp;
4257	int i;
4258	int num_char_args;
4259
4260	#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4261
4262	/* Set the fndecl. */
4263	fp = fnspec_buf;
4264	/* Function return value. FIXME: Check if the second letter could
4265	be something other than a space, for further optimization. */
4266	ADD_CHAR ('.');
4267	if (expr->rank == 0)
4268	{
4269	if (expr->ts.type == BT_CHARACTER)
4270	{
4271	ADD_CHAR ('w'); /* Address of character. */
4272	ADD_CHAR ('.'); /* Length of character. */
4273	}
4274	}
4275	else
4276	ADD_CHAR ('w'); /* Return value is a descriptor. */
4277
4278	num_char_args = 0;
4279	for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
4280	{
4281	if (a->expr == NULL)
4282	continue;
4283
4284	if (a->name && strcmp (s1: a->name,s2: "%VAL") == 0)
4285	ADD_CHAR ('.');
4286	else
4287	{
4288	if (a->expr->rank > 0)
4289	ADD_CHAR ('r');
4290	else
4291	ADD_CHAR ('R');
4292	}
4293	num_char_args += a->expr->ts.type == BT_CHARACTER;
4294	gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
4295	}
4296
4297	for (i = 0; i < num_char_args; i++)
4298	ADD_CHAR ('.');
4299
4300	*fp = '\0';
4301	return fnspec_buf;
4302	}
4303
4304	#undef MAX_SPEC_ARG
4305	#undef ADD_CHAR
4306
4307	/* Generate the right symbol for the specific intrinsic function and
4308	modify the expr accordingly. This assumes that absent optional
4309	arguments should be removed. */
4310
4311	gfc_symbol *
4312	specific_intrinsic_symbol (gfc_expr *expr)
4313	{
4314	gfc_symbol *sym;
4315
4316	sym = gfc_find_intrinsic_symbol (expr);
4317	if (sym == NULL)
4318	{
4319	sym = gfc_get_intrinsic_function_symbol (expr);
4320	sym->ts = expr->ts;
4321	if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
4322	sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
4323
4324	gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4325	expr->value.function.actual, copy_type: true);
4326	sym->backend_decl
4327	= gfc_get_extern_function_decl (sym, args: expr->value.function.actual,
4328	fnspec: intrinsic_fnspec (expr));
4329	}
4330
4331	remove_empty_actual_arguments (ap: &(expr->value.function.actual));
4332
4333	return sym;
4334	}
4335
4336	/* Generate a call to an external intrinsic function. FIXME: So far,
4337	this only works for functions which are called with well-defined
4338	types; CSHIFT and friends will come later. */
4339
4340	static void
4341	gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
4342	{
4343	gfc_symbol *sym;
4344	vec<tree, va_gc> *append_args;
4345	bool specific_symbol;
4346
4347	gcc_assert (!se->ss || se->ss->info->expr == expr);
4348
4349	if (se->ss)
4350	gcc_assert (expr->rank > 0);
4351	else
4352	gcc_assert (expr->rank == 0);
4353
4354	switch (expr->value.function.isym->id)
4355	{
4356	case GFC_ISYM_ANY:
4357	case GFC_ISYM_ALL:
4358	case GFC_ISYM_FINDLOC:
4359	case GFC_ISYM_MAXLOC:
4360	case GFC_ISYM_MINLOC:
4361	case GFC_ISYM_MAXVAL:
4362	case GFC_ISYM_MINVAL:
4363	case GFC_ISYM_NORM2:
4364	case GFC_ISYM_PRODUCT:
4365	case GFC_ISYM_SUM:
4366	specific_symbol = true;
4367	break;
4368	default:
4369	specific_symbol = false;
4370	}
4371
4372	if (specific_symbol)
4373	{
4374	/* Need to copy here because specific_intrinsic_symbol modifies
4375	expr to omit the absent optional arguments. */
4376	expr = gfc_copy_expr (expr);
4377	sym = specific_intrinsic_symbol (expr);
4378	}
4379	else
4380	sym = gfc_get_symbol_for_expr (expr, ignore_optional: se->ignore_optional);
4381
4382	/* Calls to libgfortran_matmul need to be appended special arguments,
4383	to be able to call the BLAS ?gemm functions if required and possible. */
4384	append_args = NULL;
4385	if (expr->value.function.isym->id == GFC_ISYM_MATMUL
4386	&& !expr->external_blas
4387	&& sym->ts.type != BT_LOGICAL)
4388	{
4389	tree cint = gfc_get_int_type (gfc_c_int_kind);
4390
4391	if (flag_external_blas
4392	&& (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
4393	&& (sym->ts.kind == 4 || sym->ts.kind == 8))
4394	{
4395	tree gemm_fndecl;
4396
4397	if (sym->ts.type == BT_REAL)
4398	{
4399	if (sym->ts.kind == 4)
4400	gemm_fndecl = gfor_fndecl_sgemm;
4401	else
4402	gemm_fndecl = gfor_fndecl_dgemm;
4403	}
4404	else
4405	{
4406	if (sym->ts.kind == 4)
4407	gemm_fndecl = gfor_fndecl_cgemm;
4408	else
4409	gemm_fndecl = gfor_fndecl_zgemm;
4410	}
4411
4412	vec_alloc (v&: append_args, nelems: 3);
4413	append_args->quick_push (obj: build_int_cst (cint, 1));
4414	append_args->quick_push (obj: build_int_cst (cint,
4415	flag_blas_matmul_limit));
4416	append_args->quick_push (obj: gfc_build_addr_expr (NULL_TREE,
4417	gemm_fndecl));
4418	}
4419	else
4420	{
4421	vec_alloc (v&: append_args, nelems: 3);
4422	append_args->quick_push (obj: build_int_cst (cint, 0));
4423	append_args->quick_push (obj: build_int_cst (cint, 0));
4424	append_args->quick_push (null_pointer_node);
4425	}
4426	}
4427
4428	gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4429	append_args);
4430
4431	if (specific_symbol)
4432	gfc_free_expr (expr);
4433	else
4434	gfc_free_symbol (sym);
4435	}
4436
4437	/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4438	Implemented as
4439	any(a)
4440	{
4441	forall (i=...)
4442	if (a[i] != 0)
4443	return 1
4444	end forall
4445	return 0
4446	}
4447	all(a)
4448	{
4449	forall (i=...)
4450	if (a[i] == 0)
4451	return 0
4452	end forall
4453	return 1
4454	}
4455	*/
4456	static void
4457	gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4458	{
4459	tree resvar;
4460	stmtblock_t block;
4461	stmtblock_t body;
4462	tree type;
4463	tree tmp;
4464	tree found;
4465	gfc_loopinfo loop;
4466	gfc_actual_arglist *actual;
4467	gfc_ss *arrayss;
4468	gfc_se arrayse;
4469	tree exit_label;
4470
4471	if (se->ss)
4472	{
4473	gfc_conv_intrinsic_funcall (se, expr);
4474	return;
4475	}
4476
4477	actual = expr->value.function.actual;
4478	type = gfc_typenode_for_spec (&expr->ts);
4479	/* Initialize the result. */
4480	resvar = gfc_create_var (type, "test");
4481	if (op == EQ_EXPR)
4482	tmp = convert (type, boolean_true_node);
4483	else
4484	tmp = convert (type, boolean_false_node);
4485	gfc_add_modify (&se->pre, resvar, tmp);
4486
4487	/* Walk the arguments. */
4488	arrayss = gfc_walk_expr (actual->expr);
4489	gcc_assert (arrayss != gfc_ss_terminator);
4490
4491	/* Initialize the scalarizer. */
4492	gfc_init_loopinfo (&loop);
4493	exit_label = gfc_build_label_decl (NULL_TREE);
4494	TREE_USED (exit_label) = 1;
4495	gfc_add_ss_to_loop (&loop, arrayss);
4496
4497	/* Initialize the loop. */
4498	gfc_conv_ss_startstride (&loop);
4499	gfc_conv_loop_setup (&loop, &expr->where);
4500
4501	gfc_mark_ss_chain_used (arrayss, 1);
4502	/* Generate the loop body. */
4503	gfc_start_scalarized_body (&loop, &body);
4504
4505	/* If the condition matches then set the return value. */
4506	gfc_start_block (&block);
4507	if (op == EQ_EXPR)
4508	tmp = convert (type, boolean_false_node);
4509	else
4510	tmp = convert (type, boolean_true_node);
4511	gfc_add_modify (&block, resvar, tmp);
4512
4513	/* And break out of the loop. */
4514	tmp = build1_v (GOTO_EXPR, exit_label);
4515	gfc_add_expr_to_block (&block, tmp);
4516
4517	found = gfc_finish_block (&block);
4518
4519	/* Check this element. */
4520	gfc_init_se (&arrayse, NULL);
4521	gfc_copy_loopinfo_to_se (&arrayse, &loop);
4522	arrayse.ss = arrayss;
4523	gfc_conv_expr_val (se: &arrayse, expr: actual->expr);
4524
4525	gfc_add_block_to_block (&body, &arrayse.pre);
4526	tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4527	build_int_cst (TREE_TYPE (arrayse.expr), 0));
4528	tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4529	gfc_add_expr_to_block (&body, tmp);
4530	gfc_add_block_to_block (&body, &arrayse.post);
4531
4532	gfc_trans_scalarizing_loops (&loop, &body);
4533
4534	/* Add the exit label. */
4535	tmp = build1_v (LABEL_EXPR, exit_label);
4536	gfc_add_expr_to_block (&loop.pre, tmp);
4537
4538	gfc_add_block_to_block (&se->pre, &loop.pre);
4539	gfc_add_block_to_block (&se->pre, &loop.post);
4540	gfc_cleanup_loop (&loop);
4541
4542	se->expr = resvar;
4543	}
4544
4545
4546	/* Generate the constant 180 / pi, which is used in the conversion
4547	of acosd(), asind(), atand(), atan2d(). */
4548
4549	static tree
4550	rad2deg (int kind)
4551	{
4552	tree retval;
4553	mpfr_t pi, t0;
4554
4555	gfc_set_model_kind (kind);
4556	mpfr_init (pi);
4557	mpfr_init (t0);
4558	mpfr_set_si (t0, 180, GFC_RND_MODE);
4559	mpfr_const_pi (pi, GFC_RND_MODE);
4560	mpfr_div (t0, t0, pi, GFC_RND_MODE);
4561	retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4562	mpfr_clear (t0);
4563	mpfr_clear (pi);
4564	return retval;
4565	}
4566
4567
4568	static gfc_intrinsic_map_t *
4569	gfc_lookup_intrinsic (gfc_isym_id id)
4570	{
4571	gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4572	for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4573	if (id == m->id)
4574	break;
4575	gcc_assert (id == m->id);
4576	return m;
4577	}
4578
4579
4580	/* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4581	ASIND(x) is translated into ASIN(x) * 180 / pi.
4582	ATAND(x) is translated into ATAN(x) * 180 / pi. */
4583
4584	static void
4585	gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4586	{
4587	tree arg;
4588	tree atrigd;
4589	tree type;
4590	gfc_intrinsic_map_t *m;
4591
4592	type = gfc_typenode_for_spec (&expr->ts);
4593
4594	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
4595
4596	switch (id)
4597	{
4598	case GFC_ISYM_ACOSD:
4599	m = gfc_lookup_intrinsic (id: GFC_ISYM_ACOS);
4600	break;
4601	case GFC_ISYM_ASIND:
4602	m = gfc_lookup_intrinsic (id: GFC_ISYM_ASIN);
4603	break;
4604	case GFC_ISYM_ATAND:
4605	m = gfc_lookup_intrinsic (id: GFC_ISYM_ATAN);
4606	break;
4607	default:
4608	gcc_unreachable ();
4609	}
4610	atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4611	atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4612
4613	se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4614	fold_convert (type, rad2deg (expr->ts.kind)));
4615	}
4616
4617
4618	/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4619	COS(X) / SIN(X) for COMPLEX argument. */
4620
4621	static void
4622	gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4623	{
4624	gfc_intrinsic_map_t *m;
4625	tree arg;
4626	tree type;
4627
4628	type = gfc_typenode_for_spec (&expr->ts);
4629	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
4630
4631	if (expr->ts.type == BT_REAL)
4632	{
4633	tree tan;
4634	tree tmp;
4635	mpfr_t pio2;
4636
4637	/* Create pi/2. */
4638	gfc_set_model_kind (expr->ts.kind);
4639	mpfr_init (pio2);
4640	mpfr_const_pi (pio2, GFC_RND_MODE);
4641	mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4642	tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4643	mpfr_clear (pio2);
4644
4645	/* Find tan builtin function. */
4646	m = gfc_lookup_intrinsic (id: GFC_ISYM_TAN);
4647	tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4648	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4649	tan = build_call_expr_loc (input_location, tan, 1, tmp);
4650	se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4651	}
4652	else
4653	{
4654	tree sin;
4655	tree cos;
4656
4657	/* Find cos builtin function. */
4658	m = gfc_lookup_intrinsic (id: GFC_ISYM_COS);
4659	cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4660	cos = build_call_expr_loc (input_location, cos, 1, arg);
4661
4662	/* Find sin builtin function. */
4663	m = gfc_lookup_intrinsic (id: GFC_ISYM_SIN);
4664	sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4665	sin = build_call_expr_loc (input_location, sin, 1, arg);
4666
4667	/* Divide cos by sin. */
4668	se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4669	}
4670	}
4671
4672
4673	/* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4674
4675	static void
4676	gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4677	{
4678	tree arg;
4679	tree type;
4680	tree ninety_tree;
4681	mpfr_t ninety;
4682
4683	type = gfc_typenode_for_spec (&expr->ts);
4684	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
4685
4686	gfc_set_model_kind (expr->ts.kind);
4687
4688	/* Build the tree for x + 90. */
4689	mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4690	ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4691	arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4692	mpfr_clear (ninety);
4693
4694	/* Find tand. */
4695	gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (id: GFC_ISYM_TAND);
4696	tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4697	tand = build_call_expr_loc (input_location, tand, 1, arg);
4698
4699	se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4700	}
4701
4702
4703	/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4704
4705	static void
4706	gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4707	{
4708	tree args[2];
4709	tree atan2d;
4710	tree type;
4711
4712	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
4713	type = TREE_TYPE (args[0]);
4714
4715	gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (id: GFC_ISYM_ATAN2);
4716	atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4717	atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4718
4719	se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4720	rad2deg (kind: expr->ts.kind));
4721	}
4722
4723
4724	/* COUNT(A) = Number of true elements in A. */
4725	static void
4726	gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4727	{
4728	tree resvar;
4729	tree type;
4730	stmtblock_t body;
4731	tree tmp;
4732	gfc_loopinfo loop;
4733	gfc_actual_arglist *actual;
4734	gfc_ss *arrayss;
4735	gfc_se arrayse;
4736
4737	if (se->ss)
4738	{
4739	gfc_conv_intrinsic_funcall (se, expr);
4740	return;
4741	}
4742
4743	actual = expr->value.function.actual;
4744
4745	type = gfc_typenode_for_spec (&expr->ts);
4746	/* Initialize the result. */
4747	resvar = gfc_create_var (type, "count");
4748	gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4749
4750	/* Walk the arguments. */
4751	arrayss = gfc_walk_expr (actual->expr);
4752	gcc_assert (arrayss != gfc_ss_terminator);
4753
4754	/* Initialize the scalarizer. */
4755	gfc_init_loopinfo (&loop);
4756	gfc_add_ss_to_loop (&loop, arrayss);
4757
4758	/* Initialize the loop. */
4759	gfc_conv_ss_startstride (&loop);
4760	gfc_conv_loop_setup (&loop, &expr->where);
4761
4762	gfc_mark_ss_chain_used (arrayss, 1);
4763	/* Generate the loop body. */
4764	gfc_start_scalarized_body (&loop, &body);
4765
4766	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4767	resvar, build_int_cst (TREE_TYPE (resvar), 1));
4768	tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4769
4770	gfc_init_se (&arrayse, NULL);
4771	gfc_copy_loopinfo_to_se (&arrayse, &loop);
4772	arrayse.ss = arrayss;
4773	gfc_conv_expr_val (se: &arrayse, expr: actual->expr);
4774	tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4775	build_empty_stmt (input_location));
4776
4777	gfc_add_block_to_block (&body, &arrayse.pre);
4778	gfc_add_expr_to_block (&body, tmp);
4779	gfc_add_block_to_block (&body, &arrayse.post);
4780
4781	gfc_trans_scalarizing_loops (&loop, &body);
4782
4783	gfc_add_block_to_block (&se->pre, &loop.pre);
4784	gfc_add_block_to_block (&se->pre, &loop.post);
4785	gfc_cleanup_loop (&loop);
4786
4787	se->expr = resvar;
4788	}
4789
4790
4791	/* Update given gfc_se to have ss component pointing to the nested gfc_ss
4792	struct and return the corresponding loopinfo. */
4793
4794	static gfc_loopinfo *
4795	enter_nested_loop (gfc_se *se)
4796	{
4797	se->ss = se->ss->nested_ss;
4798	gcc_assert (se->ss == se->ss->loop->ss);
4799
4800	return se->ss->loop;
4801	}
4802
4803	/* Build the condition for a mask, which may be optional. */
4804
4805	static tree
4806	conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4807	bool optional_mask)
4808	{
4809	tree present;
4810	tree type;
4811
4812	if (optional_mask)
4813	{
4814	type = TREE_TYPE (maskse->expr);
4815	present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4816	present = convert (type, present);
4817	present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4818	present);
4819	return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4820	type, present, maskse->expr);
4821	}
4822	else
4823	return maskse->expr;
4824	}
4825
4826	/* Inline implementation of the sum and product intrinsics. */
4827	static void
4828	gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4829	bool norm2)
4830	{
4831	tree resvar;
4832	tree scale = NULL_TREE;
4833	tree type;
4834	stmtblock_t body;
4835	stmtblock_t block;
4836	tree tmp;
4837	gfc_loopinfo loop, *ploop;
4838	gfc_actual_arglist *arg_array, *arg_mask;
4839	gfc_ss *arrayss = NULL;
4840	gfc_ss *maskss = NULL;
4841	gfc_se arrayse;
4842	gfc_se maskse;
4843	gfc_se *parent_se;
4844	gfc_expr *arrayexpr;
4845	gfc_expr *maskexpr;
4846	bool optional_mask;
4847
4848	if (expr->rank > 0)
4849	{
4850	gcc_assert (gfc_inline_intrinsic_function_p (expr));
4851	parent_se = se;
4852	}
4853	else
4854	parent_se = NULL;
4855
4856	type = gfc_typenode_for_spec (&expr->ts);
4857	/* Initialize the result. */
4858	resvar = gfc_create_var (type, "val");
4859	if (norm2)
4860	{
4861	/* result = 0.0;
4862	scale = 1.0. */
4863	scale = gfc_create_var (type, "scale");
4864	gfc_add_modify (&se->pre, scale,
4865	gfc_build_const (type, integer_one_node));
4866	tmp = gfc_build_const (type, integer_zero_node);
4867	}
4868	else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4869	tmp = gfc_build_const (type, integer_zero_node);
4870	else if (op == NE_EXPR)
4871	/* PARITY. */
4872	tmp = convert (type, boolean_false_node);
4873	else if (op == BIT_AND_EXPR)
4874	tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4875	type, integer_one_node));
4876	else
4877	tmp = gfc_build_const (type, integer_one_node);
4878
4879	gfc_add_modify (&se->pre, resvar, tmp);
4880
4881	arg_array = expr->value.function.actual;
4882
4883	arrayexpr = arg_array->expr;
4884
4885	if (op == NE_EXPR || norm2)
4886	{
4887	/* PARITY and NORM2. */
4888	maskexpr = NULL;
4889	optional_mask = false;
4890	}
4891	else
4892	{
4893	arg_mask = arg_array->next->next;
4894	gcc_assert (arg_mask != NULL);
4895	maskexpr = arg_mask->expr;
4896	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4897	&& maskexpr->symtree->n.sym->attr.dummy
4898	&& maskexpr->symtree->n.sym->attr.optional;
4899	}
4900
4901	if (expr->rank == 0)
4902	{
4903	/* Walk the arguments. */
4904	arrayss = gfc_walk_expr (arrayexpr);
4905	gcc_assert (arrayss != gfc_ss_terminator);
4906
4907	if (maskexpr && maskexpr->rank > 0)
4908	{
4909	maskss = gfc_walk_expr (maskexpr);
4910	gcc_assert (maskss != gfc_ss_terminator);
4911	}
4912	else
4913	maskss = NULL;
4914
4915	/* Initialize the scalarizer. */
4916	gfc_init_loopinfo (&loop);
4917
4918	/* We add the mask first because the number of iterations is
4919	taken from the last ss, and this breaks if an absent
4920	optional argument is used for mask. */
4921
4922	if (maskexpr && maskexpr->rank > 0)
4923	gfc_add_ss_to_loop (&loop, maskss);
4924	gfc_add_ss_to_loop (&loop, arrayss);
4925
4926	/* Initialize the loop. */
4927	gfc_conv_ss_startstride (&loop);
4928	gfc_conv_loop_setup (&loop, &expr->where);
4929
4930	if (maskexpr && maskexpr->rank > 0)
4931	gfc_mark_ss_chain_used (maskss, 1);
4932	gfc_mark_ss_chain_used (arrayss, 1);
4933
4934	ploop = &loop;
4935	}
4936	else
4937	/* All the work has been done in the parent loops. */
4938	ploop = enter_nested_loop (se);
4939
4940	gcc_assert (ploop);
4941
4942	/* Generate the loop body. */
4943	gfc_start_scalarized_body (ploop, &body);
4944
4945	/* If we have a mask, only add this element if the mask is set. */
4946	if (maskexpr && maskexpr->rank > 0)
4947	{
4948	gfc_init_se (&maskse, parent_se);
4949	gfc_copy_loopinfo_to_se (&maskse, ploop);
4950	if (expr->rank == 0)
4951	maskse.ss = maskss;
4952	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
4953	gfc_add_block_to_block (&body, &maskse.pre);
4954
4955	gfc_start_block (&block);
4956	}
4957	else
4958	gfc_init_block (&block);
4959
4960	/* Do the actual summation/product. */
4961	gfc_init_se (&arrayse, parent_se);
4962	gfc_copy_loopinfo_to_se (&arrayse, ploop);
4963	if (expr->rank == 0)
4964	arrayse.ss = arrayss;
4965	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
4966	gfc_add_block_to_block (&block, &arrayse.pre);
4967
4968	if (norm2)
4969	{
4970	/* if (x (i) != 0.0)
4971	{
4972	absX = abs(x(i))
4973	if (absX > scale)
4974	{
4975	val = scale/absX;
4976	result = 1.0 + result * val * val;
4977	scale = absX;
4978	}
4979	else
4980	{
4981	val = absX/scale;
4982	result += val * val;
4983	}
4984	} */
4985	tree res1, res2, cond, absX, val;
4986	stmtblock_t ifblock1, ifblock2, ifblock3;
4987
4988	gfc_init_block (&ifblock1);
4989
4990	absX = gfc_create_var (type, "absX");
4991	gfc_add_modify (&ifblock1, absX,
4992	fold_build1_loc (input_location, ABS_EXPR, type,
4993	arrayse.expr));
4994	val = gfc_create_var (type, "val");
4995	gfc_add_expr_to_block (&ifblock1, val);
4996
4997	gfc_init_block (&ifblock2);
4998	gfc_add_modify (&ifblock2, val,
4999	fold_build2_loc (input_location, RDIV_EXPR, type, scale,
5000	absX));
5001	res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5002	res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
5003	res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
5004	gfc_build_const (type, integer_one_node));
5005	gfc_add_modify (&ifblock2, resvar, res1);
5006	gfc_add_modify (&ifblock2, scale, absX);
5007	res1 = gfc_finish_block (&ifblock2);
5008
5009	gfc_init_block (&ifblock3);
5010	gfc_add_modify (&ifblock3, val,
5011	fold_build2_loc (input_location, RDIV_EXPR, type, absX,
5012	scale));
5013	res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5014	res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
5015	gfc_add_modify (&ifblock3, resvar, res2);
5016	res2 = gfc_finish_block (&ifblock3);
5017
5018	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5019	absX, scale);
5020	tmp = build3_v (COND_EXPR, cond, res1, res2);
5021	gfc_add_expr_to_block (&ifblock1, tmp);
5022	tmp = gfc_finish_block (&ifblock1);
5023
5024	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
5025	arrayse.expr,
5026	gfc_build_const (type, integer_zero_node));
5027
5028	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5029	gfc_add_expr_to_block (&block, tmp);
5030	}
5031	else
5032	{
5033	tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
5034	gfc_add_modify (&block, resvar, tmp);
5035	}
5036
5037	gfc_add_block_to_block (&block, &arrayse.post);
5038
5039	if (maskexpr && maskexpr->rank > 0)
5040	{
5041	/* We enclose the above in if (mask) {...} . If the mask is an
5042	optional argument, generate
5043	IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5044	tree ifmask;
5045	tmp = gfc_finish_block (&block);
5046	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5047	tmp = build3_v (COND_EXPR, ifmask, tmp,
5048	build_empty_stmt (input_location));
5049	}
5050	else
5051	tmp = gfc_finish_block (&block);
5052	gfc_add_expr_to_block (&body, tmp);
5053
5054	gfc_trans_scalarizing_loops (ploop, &body);
5055
5056	/* For a scalar mask, enclose the loop in an if statement. */
5057	if (maskexpr && maskexpr->rank == 0)
5058	{
5059	gfc_init_block (&block);
5060	gfc_add_block_to_block (&block, &ploop->pre);
5061	gfc_add_block_to_block (&block, &ploop->post);
5062	tmp = gfc_finish_block (&block);
5063
5064	if (expr->rank > 0)
5065	{
5066	tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
5067	build_empty_stmt (input_location));
5068	gfc_advance_se_ss_chain (se);
5069	}
5070	else
5071	{
5072	tree ifmask;
5073
5074	gcc_assert (expr->rank == 0);
5075	gfc_init_se (&maskse, NULL);
5076	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5077	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5078	tmp = build3_v (COND_EXPR, ifmask, tmp,
5079	build_empty_stmt (input_location));
5080	}
5081
5082	gfc_add_expr_to_block (&block, tmp);
5083	gfc_add_block_to_block (&se->pre, &block);
5084	gcc_assert (se->post.head == NULL);
5085	}
5086	else
5087	{
5088	gfc_add_block_to_block (&se->pre, &ploop->pre);
5089	gfc_add_block_to_block (&se->pre, &ploop->post);
5090	}
5091
5092	if (expr->rank == 0)
5093	gfc_cleanup_loop (ploop);
5094
5095	if (norm2)
5096	{
5097	/* result = scale * sqrt(result). */
5098	tree sqrt;
5099	sqrt = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SQRT, kind: expr->ts.kind);
5100	resvar = build_call_expr_loc (input_location,
5101	sqrt, 1, resvar);
5102	resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
5103	}
5104
5105	se->expr = resvar;
5106	}
5107
5108
5109	/* Inline implementation of the dot_product intrinsic. This function
5110	is based on gfc_conv_intrinsic_arith (the previous function). */
5111	static void
5112	gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
5113	{
5114	tree resvar;
5115	tree type;
5116	stmtblock_t body;
5117	stmtblock_t block;
5118	tree tmp;
5119	gfc_loopinfo loop;
5120	gfc_actual_arglist *actual;
5121	gfc_ss *arrayss1, *arrayss2;
5122	gfc_se arrayse1, arrayse2;
5123	gfc_expr *arrayexpr1, *arrayexpr2;
5124
5125	type = gfc_typenode_for_spec (&expr->ts);
5126
5127	/* Initialize the result. */
5128	resvar = gfc_create_var (type, "val");
5129	if (expr->ts.type == BT_LOGICAL)
5130	tmp = build_int_cst (type, 0);
5131	else
5132	tmp = gfc_build_const (type, integer_zero_node);
5133
5134	gfc_add_modify (&se->pre, resvar, tmp);
5135
5136	/* Walk argument #1. */
5137	actual = expr->value.function.actual;
5138	arrayexpr1 = actual->expr;
5139	arrayss1 = gfc_walk_expr (arrayexpr1);
5140	gcc_assert (arrayss1 != gfc_ss_terminator);
5141
5142	/* Walk argument #2. */
5143	actual = actual->next;
5144	arrayexpr2 = actual->expr;
5145	arrayss2 = gfc_walk_expr (arrayexpr2);
5146	gcc_assert (arrayss2 != gfc_ss_terminator);
5147
5148	/* Initialize the scalarizer. */
5149	gfc_init_loopinfo (&loop);
5150	gfc_add_ss_to_loop (&loop, arrayss1);
5151	gfc_add_ss_to_loop (&loop, arrayss2);
5152
5153	/* Initialize the loop. */
5154	gfc_conv_ss_startstride (&loop);
5155	gfc_conv_loop_setup (&loop, &expr->where);
5156
5157	gfc_mark_ss_chain_used (arrayss1, 1);
5158	gfc_mark_ss_chain_used (arrayss2, 1);
5159
5160	/* Generate the loop body. */
5161	gfc_start_scalarized_body (&loop, &body);
5162	gfc_init_block (&block);
5163
5164	/* Make the tree expression for [conjg(]array1[)]. */
5165	gfc_init_se (&arrayse1, NULL);
5166	gfc_copy_loopinfo_to_se (&arrayse1, &loop);
5167	arrayse1.ss = arrayss1;
5168	gfc_conv_expr_val (se: &arrayse1, expr: arrayexpr1);
5169	if (expr->ts.type == BT_COMPLEX)
5170	arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
5171	arrayse1.expr);
5172	gfc_add_block_to_block (&block, &arrayse1.pre);
5173
5174	/* Make the tree expression for array2. */
5175	gfc_init_se (&arrayse2, NULL);
5176	gfc_copy_loopinfo_to_se (&arrayse2, &loop);
5177	arrayse2.ss = arrayss2;
5178	gfc_conv_expr_val (se: &arrayse2, expr: arrayexpr2);
5179	gfc_add_block_to_block (&block, &arrayse2.pre);
5180
5181	/* Do the actual product and sum. */
5182	if (expr->ts.type == BT_LOGICAL)
5183	{
5184	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
5185	arrayse1.expr, arrayse2.expr);
5186	tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
5187	}
5188	else
5189	{
5190	tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
5191	arrayse2.expr);
5192	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
5193	}
5194	gfc_add_modify (&block, resvar, tmp);
5195
5196	/* Finish up the loop block and the loop. */
5197	tmp = gfc_finish_block (&block);
5198	gfc_add_expr_to_block (&body, tmp);
5199
5200	gfc_trans_scalarizing_loops (&loop, &body);
5201	gfc_add_block_to_block (&se->pre, &loop.pre);
5202	gfc_add_block_to_block (&se->pre, &loop.post);
5203	gfc_cleanup_loop (&loop);
5204
5205	se->expr = resvar;
5206	}
5207
5208
5209	/* Remove unneeded kind= argument from actual argument list when the
5210	result conversion is dealt with in a different place. */
5211
5212	static void
5213	strip_kind_from_actual (gfc_actual_arglist * actual)
5214	{
5215	for (gfc_actual_arglist *a = actual; a; a = a->next)
5216	{
5217	if (a && a->name && strcmp (s1: a->name, s2: "kind") == 0)
5218	{
5219	gfc_free_expr (a->expr);
5220	a->expr = NULL;
5221	}
5222	}
5223	}
5224
5225	/* Emit code for minloc or maxloc intrinsic. There are many different cases
5226	we need to handle. For performance reasons we sometimes create two
5227	loops instead of one, where the second one is much simpler.
5228	Examples for minloc intrinsic:
5229	1) Result is an array, a call is generated
5230	2) Array mask is used and NaNs need to be supported:
5231	limit = Infinity;
5232	pos = 0;
5233	S = from;
5234	while (S <= to) {
5235	if (mask[S]) {
5236	if (pos == 0) pos = S + (1 - from);
5237	if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5238	}
5239	S++;
5240	}
5241	goto lab2;
5242	lab1:;
5243	while (S <= to) {
5244	if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5245	S++;
5246	}
5247	lab2:;
5248	3) NaNs need to be supported, but it is known at compile time or cheaply
5249	at runtime whether array is nonempty or not:
5250	limit = Infinity;
5251	pos = 0;
5252	S = from;
5253	while (S <= to) {
5254	if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5255	S++;
5256	}
5257	if (from <= to) pos = 1;
5258	goto lab2;
5259	lab1:;
5260	while (S <= to) {
5261	if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5262	S++;
5263	}
5264	lab2:;
5265	4) NaNs aren't supported, array mask is used:
5266	limit = infinities_supported ? Infinity : huge (limit);
5267	pos = 0;
5268	S = from;
5269	while (S <= to) {
5270	if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5271	S++;
5272	}
5273	goto lab2;
5274	lab1:;
5275	while (S <= to) {
5276	if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5277	S++;
5278	}
5279	lab2:;
5280	5) Same without array mask:
5281	limit = infinities_supported ? Infinity : huge (limit);
5282	pos = (from <= to) ? 1 : 0;
5283	S = from;
5284	while (S <= to) {
5285	if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5286	S++;
5287	}
5288	For 3) and 5), if mask is scalar, this all goes into a conditional,
5289	setting pos = 0; in the else branch.
5290
5291	Since we now also support the BACK argument, instead of using
5292	if (a[S] < limit), we now use
5293
5294	if (back)
5295	cond = a[S] <= limit;
5296	else
5297	cond = a[S] < limit;
5298	if (cond) {
5299	....
5300
5301	The optimizer is smart enough to move the condition out of the loop.
5302	The are now marked as unlikely to for further speedup. */
5303
5304	static void
5305	gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5306	{
5307	stmtblock_t body;
5308	stmtblock_t block;
5309	stmtblock_t ifblock;
5310	stmtblock_t elseblock;
5311	tree limit;
5312	tree type;
5313	tree tmp;
5314	tree cond;
5315	tree elsetmp;
5316	tree ifbody;
5317	tree offset;
5318	tree nonempty;
5319	tree lab1, lab2;
5320	tree b_if, b_else;
5321	gfc_loopinfo loop;
5322	gfc_actual_arglist *actual;
5323	gfc_ss *arrayss;
5324	gfc_ss *maskss;
5325	gfc_se arrayse;
5326	gfc_se maskse;
5327	gfc_expr *arrayexpr;
5328	gfc_expr *maskexpr;
5329	gfc_expr *backexpr;
5330	gfc_se backse;
5331	tree pos;
5332	int n;
5333	bool optional_mask;
5334
5335	actual = expr->value.function.actual;
5336
5337	/* The last argument, BACK, is passed by value. Ensure that
5338	by setting its name to %VAL. */
5339	for (gfc_actual_arglist *a = actual; a; a = a->next)
5340	{
5341	if (a->next == NULL)
5342	a->name = "%VAL";
5343	}
5344
5345	if (se->ss)
5346	{
5347	gfc_conv_intrinsic_funcall (se, expr);
5348	return;
5349	}
5350
5351	arrayexpr = actual->expr;
5352
5353	/* Special case for character maxloc. Remove unneeded actual
5354	arguments, then call a library function. */
5355
5356	if (arrayexpr->ts.type == BT_CHARACTER)
5357	{
5358	gfc_actual_arglist *a;
5359	a = actual;
5360	strip_kind_from_actual (actual: a);
5361	while (a)
5362	{
5363	if (a->name && strcmp (s1: a->name, s2: "dim") == 0)
5364	{
5365	gfc_free_expr (a->expr);
5366	a->expr = NULL;
5367	}
5368	a = a->next;
5369	}
5370	gfc_conv_intrinsic_funcall (se, expr);
5371	return;
5372	}
5373
5374	/* Initialize the result. */
5375	pos = gfc_create_var (gfc_array_index_type, "pos");
5376	offset = gfc_create_var (gfc_array_index_type, "offset");
5377	type = gfc_typenode_for_spec (&expr->ts);
5378
5379	/* Walk the arguments. */
5380	arrayss = gfc_walk_expr (arrayexpr);
5381	gcc_assert (arrayss != gfc_ss_terminator);
5382
5383	actual = actual->next->next;
5384	gcc_assert (actual);
5385	maskexpr = actual->expr;
5386	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5387	&& maskexpr->symtree->n.sym->attr.dummy
5388	&& maskexpr->symtree->n.sym->attr.optional;
5389	backexpr = actual->next->next->expr;
5390	nonempty = NULL;
5391	if (maskexpr && maskexpr->rank != 0)
5392	{
5393	maskss = gfc_walk_expr (maskexpr);
5394	gcc_assert (maskss != gfc_ss_terminator);
5395	}
5396	else
5397	{
5398	mpz_t asize;
5399	if (gfc_array_size (arrayexpr, &asize))
5400	{
5401	nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5402	mpz_clear (asize);
5403	nonempty = fold_build2_loc (input_location, GT_EXPR,
5404	logical_type_node, nonempty,
5405	gfc_index_zero_node);
5406	}
5407	maskss = NULL;
5408	}
5409
5410	limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5411	switch (arrayexpr->ts.type)
5412	{
5413	case BT_REAL:
5414	tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5415	break;
5416
5417	case BT_INTEGER:
5418	n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5419	tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5420	arrayexpr->ts.kind);
5421	break;
5422
5423	default:
5424	gcc_unreachable ();
5425	}
5426
5427	/* We start with the most negative possible value for MAXLOC, and the most
5428	positive possible value for MINLOC. The most negative possible value is
5429	-HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5430	possible value is HUGE in both cases. */
5431	if (op == GT_EXPR)
5432	tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5433	if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5434	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5435	build_int_cst (TREE_TYPE (tmp), 1));
5436
5437	gfc_add_modify (&se->pre, limit, tmp);
5438
5439	/* Initialize the scalarizer. */
5440	gfc_init_loopinfo (&loop);
5441
5442	/* We add the mask first because the number of iterations is taken
5443	from the last ss, and this breaks if an absent optional argument
5444	is used for mask. */
5445
5446	if (maskss)
5447	gfc_add_ss_to_loop (&loop, maskss);
5448
5449	gfc_add_ss_to_loop (&loop, arrayss);
5450
5451	/* Initialize the loop. */
5452	gfc_conv_ss_startstride (&loop);
5453
5454	/* The code generated can have more than one loop in sequence (see the
5455	comment at the function header). This doesn't work well with the
5456	scalarizer, which changes arrays' offset when the scalarization loops
5457	are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5458	are currently inlined in the scalar case only (for which loop is of rank
5459	one). As there is no dependency to care about in that case, there is no
5460	temporary, so that we can use the scalarizer temporary code to handle
5461	multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5462	with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5463	to restore offset.
5464	TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5465	should eventually go away. We could either create two loops properly,
5466	or find another way to save/restore the array offsets between the two
5467	loops (without conflicting with temporary management), or use a single
5468	loop minmaxloc implementation. See PR 31067. */
5469	loop.temp_dim = loop.dimen;
5470	gfc_conv_loop_setup (&loop, &expr->where);
5471
5472	gcc_assert (loop.dimen == 1);
5473	if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
5474	nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5475	loop.from[0], loop.to[0]);
5476
5477	lab1 = NULL;
5478	lab2 = NULL;
5479	/* Initialize the position to zero, following Fortran 2003. We are free
5480	to do this because Fortran 95 allows the result of an entirely false
5481	mask to be processor dependent. If we know at compile time the array
5482	is non-empty and no MASK is used, we can initialize to 1 to simplify
5483	the inner loop. */
5484	if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5485	gfc_add_modify (&loop.pre, pos,
5486	fold_build3_loc (input_location, COND_EXPR,
5487	gfc_array_index_type,
5488	nonempty, gfc_index_one_node,
5489	gfc_index_zero_node));
5490	else
5491	{
5492	gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
5493	lab1 = gfc_build_label_decl (NULL_TREE);
5494	TREE_USED (lab1) = 1;
5495	lab2 = gfc_build_label_decl (NULL_TREE);
5496	TREE_USED (lab2) = 1;
5497	}
5498
5499	/* An offset must be added to the loop
5500	counter to obtain the required position. */
5501	gcc_assert (loop.from[0]);
5502
5503	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5504	gfc_index_one_node, loop.from[0]);
5505	gfc_add_modify (&loop.pre, offset, tmp);
5506
5507	gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5508	if (maskss)
5509	gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5510	/* Generate the loop body. */
5511	gfc_start_scalarized_body (&loop, &body);
5512
5513	/* If we have a mask, only check this element if the mask is set. */
5514	if (maskss)
5515	{
5516	gfc_init_se (&maskse, NULL);
5517	gfc_copy_loopinfo_to_se (&maskse, &loop);
5518	maskse.ss = maskss;
5519	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5520	gfc_add_block_to_block (&body, &maskse.pre);
5521
5522	gfc_start_block (&block);
5523	}
5524	else
5525	gfc_init_block (&block);
5526
5527	/* Compare with the current limit. */
5528	gfc_init_se (&arrayse, NULL);
5529	gfc_copy_loopinfo_to_se (&arrayse, &loop);
5530	arrayse.ss = arrayss;
5531	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
5532	gfc_add_block_to_block (&block, &arrayse.pre);
5533
5534	gfc_init_se (&backse, NULL);
5535	gfc_conv_expr_val (se: &backse, expr: backexpr);
5536	gfc_add_block_to_block (&block, &backse.pre);
5537
5538	/* We do the following if this is a more extreme value. */
5539	gfc_start_block (&ifblock);
5540
5541	/* Assign the value to the limit... */
5542	gfc_add_modify (&ifblock, limit, arrayse.expr);
5543
5544	if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5545	{
5546	stmtblock_t ifblock2;
5547	tree ifbody2;
5548
5549	gfc_start_block (&ifblock2);
5550	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5551	loop.loopvar[0], offset);
5552	gfc_add_modify (&ifblock2, pos, tmp);
5553	ifbody2 = gfc_finish_block (&ifblock2);
5554	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
5555	gfc_index_zero_node);
5556	tmp = build3_v (COND_EXPR, cond, ifbody2,
5557	build_empty_stmt (input_location));
5558	gfc_add_expr_to_block (&block, tmp);
5559	}
5560
5561	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5562	loop.loopvar[0], offset);
5563	gfc_add_modify (&ifblock, pos, tmp);
5564
5565	if (lab1)
5566	gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5567
5568	ifbody = gfc_finish_block (&ifblock);
5569
5570	if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5571	{
5572	if (lab1)
5573	cond = fold_build2_loc (input_location,
5574	op == GT_EXPR ? GE_EXPR : LE_EXPR,
5575	logical_type_node, arrayse.expr, limit);
5576	else
5577	{
5578	tree ifbody2, elsebody2;
5579
5580	/* We switch to > or >= depending on the value of the BACK argument. */
5581	cond = gfc_create_var (logical_type_node, "cond");
5582
5583	gfc_start_block (&ifblock);
5584	b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5585	logical_type_node, arrayse.expr, limit);
5586
5587	gfc_add_modify (&ifblock, cond, b_if);
5588	ifbody2 = gfc_finish_block (&ifblock);
5589
5590	gfc_start_block (&elseblock);
5591	b_else = fold_build2_loc (input_location, op, logical_type_node,
5592	arrayse.expr, limit);
5593
5594	gfc_add_modify (&elseblock, cond, b_else);
5595	elsebody2 = gfc_finish_block (&elseblock);
5596
5597	tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5598	backse.expr, ifbody2, elsebody2);
5599
5600	gfc_add_expr_to_block (&block, tmp);
5601	}
5602
5603	cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5604	ifbody = build3_v (COND_EXPR, cond, ifbody,
5605	build_empty_stmt (input_location));
5606	}
5607	gfc_add_expr_to_block (&block, ifbody);
5608
5609	if (maskss)
5610	{
5611	/* We enclose the above in if (mask) {...}. If the mask is an
5612	optional argument, generate IF (.NOT. PRESENT(MASK)
5613	.OR. MASK(I)). */
5614
5615	tree ifmask;
5616	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5617	tmp = gfc_finish_block (&block);
5618	tmp = build3_v (COND_EXPR, ifmask, tmp,
5619	build_empty_stmt (input_location));
5620	}
5621	else
5622	tmp = gfc_finish_block (&block);
5623	gfc_add_expr_to_block (&body, tmp);
5624
5625	if (lab1)
5626	{
5627	gfc_trans_scalarized_loop_boundary (&loop, &body);
5628
5629	if (HONOR_NANS (DECL_MODE (limit)))
5630	{
5631	if (nonempty != NULL)
5632	{
5633	ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
5634	tmp = build3_v (COND_EXPR, nonempty, ifbody,
5635	build_empty_stmt (input_location));
5636	gfc_add_expr_to_block (&loop.code[0], tmp);
5637	}
5638	}
5639
5640	gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
5641	gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
5642
5643	/* If we have a mask, only check this element if the mask is set. */
5644	if (maskss)
5645	{
5646	gfc_init_se (&maskse, NULL);
5647	gfc_copy_loopinfo_to_se (&maskse, &loop);
5648	maskse.ss = maskss;
5649	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5650	gfc_add_block_to_block (&body, &maskse.pre);
5651
5652	gfc_start_block (&block);
5653	}
5654	else
5655	gfc_init_block (&block);
5656
5657	/* Compare with the current limit. */
5658	gfc_init_se (&arrayse, NULL);
5659	gfc_copy_loopinfo_to_se (&arrayse, &loop);
5660	arrayse.ss = arrayss;
5661	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
5662	gfc_add_block_to_block (&block, &arrayse.pre);
5663
5664	/* We do the following if this is a more extreme value. */
5665	gfc_start_block (&ifblock);
5666
5667	/* Assign the value to the limit... */
5668	gfc_add_modify (&ifblock, limit, arrayse.expr);
5669
5670	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5671	loop.loopvar[0], offset);
5672	gfc_add_modify (&ifblock, pos, tmp);
5673
5674	ifbody = gfc_finish_block (&ifblock);
5675
5676	/* We switch to > or >= depending on the value of the BACK argument. */
5677	{
5678	tree ifbody2, elsebody2;
5679
5680	cond = gfc_create_var (logical_type_node, "cond");
5681
5682	gfc_start_block (&ifblock);
5683	b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5684	logical_type_node, arrayse.expr, limit);
5685
5686	gfc_add_modify (&ifblock, cond, b_if);
5687	ifbody2 = gfc_finish_block (&ifblock);
5688
5689	gfc_start_block (&elseblock);
5690	b_else = fold_build2_loc (input_location, op, logical_type_node,
5691	arrayse.expr, limit);
5692
5693	gfc_add_modify (&elseblock, cond, b_else);
5694	elsebody2 = gfc_finish_block (&elseblock);
5695
5696	tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5697	backse.expr, ifbody2, elsebody2);
5698	}
5699
5700	gfc_add_expr_to_block (&block, tmp);
5701	cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5702	tmp = build3_v (COND_EXPR, cond, ifbody,
5703	build_empty_stmt (input_location));
5704
5705	gfc_add_expr_to_block (&block, tmp);
5706
5707	if (maskss)
5708	{
5709	/* We enclose the above in if (mask) {...}. If the mask is
5710	an optional argument, generate IF (.NOT. PRESENT(MASK)
5711	.OR. MASK(I)).*/
5712
5713	tree ifmask;
5714	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5715	tmp = gfc_finish_block (&block);
5716	tmp = build3_v (COND_EXPR, ifmask, tmp,
5717	build_empty_stmt (input_location));
5718	}
5719	else
5720	tmp = gfc_finish_block (&block);
5721	gfc_add_expr_to_block (&body, tmp);
5722	/* Avoid initializing loopvar[0] again, it should be left where
5723	it finished by the first loop. */
5724	loop.from[0] = loop.loopvar[0];
5725	}
5726
5727	gfc_trans_scalarizing_loops (&loop, &body);
5728
5729	if (lab2)
5730	gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
5731
5732	/* For a scalar mask, enclose the loop in an if statement. */
5733	if (maskexpr && maskss == NULL)
5734	{
5735	tree ifmask;
5736
5737	gfc_init_se (&maskse, NULL);
5738	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5739	gfc_init_block (&block);
5740	gfc_add_block_to_block (&block, &loop.pre);
5741	gfc_add_block_to_block (&block, &loop.post);
5742	tmp = gfc_finish_block (&block);
5743
5744	/* For the else part of the scalar mask, just initialize
5745	the pos variable the same way as above. */
5746
5747	gfc_init_block (&elseblock);
5748	gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
5749	elsetmp = gfc_finish_block (&elseblock);
5750	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5751	tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5752	gfc_add_expr_to_block (&block, tmp);
5753	gfc_add_block_to_block (&se->pre, &block);
5754	}
5755	else
5756	{
5757	gfc_add_block_to_block (&se->pre, &loop.pre);
5758	gfc_add_block_to_block (&se->pre, &loop.post);
5759	}
5760	gfc_cleanup_loop (&loop);
5761
5762	se->expr = convert (type, pos);
5763	}
5764
5765	/* Emit code for findloc. */
5766
5767	static void
5768	gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5769	{
5770	gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5771	*kind_arg, *back_arg;
5772	gfc_expr *value_expr;
5773	int ikind;
5774	tree resvar;
5775	stmtblock_t block;
5776	stmtblock_t body;
5777	stmtblock_t loopblock;
5778	tree type;
5779	tree tmp;
5780	tree found;
5781	tree forward_branch = NULL_TREE;
5782	tree back_branch;
5783	gfc_loopinfo loop;
5784	gfc_ss *arrayss;
5785	gfc_ss *maskss;
5786	gfc_se arrayse;
5787	gfc_se valuese;
5788	gfc_se maskse;
5789	gfc_se backse;
5790	tree exit_label;
5791	gfc_expr *maskexpr;
5792	tree offset;
5793	int i;
5794	bool optional_mask;
5795
5796	array_arg = expr->value.function.actual;
5797	value_arg = array_arg->next;
5798	dim_arg = value_arg->next;
5799	mask_arg = dim_arg->next;
5800	kind_arg = mask_arg->next;
5801	back_arg = kind_arg->next;
5802
5803	/* Remove kind and set ikind. */
5804	if (kind_arg->expr)
5805	{
5806	ikind = mpz_get_si (kind_arg->expr->value.integer);
5807	gfc_free_expr (kind_arg->expr);
5808	kind_arg->expr = NULL;
5809	}
5810	else
5811	ikind = gfc_default_integer_kind;
5812
5813	value_expr = value_arg->expr;
5814
5815	/* Unless it's a string, pass VALUE by value. */
5816	if (value_expr->ts.type != BT_CHARACTER)
5817	value_arg->name = "%VAL";
5818
5819	/* Pass BACK argument by value. */
5820	back_arg->name = "%VAL";
5821
5822	/* Call the library if we have a character function or if
5823	rank > 0. */
5824	if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5825	{
5826	se->ignore_optional = 1;
5827	if (expr->rank == 0)
5828	{
5829	/* Remove dim argument. */
5830	gfc_free_expr (dim_arg->expr);
5831	dim_arg->expr = NULL;
5832	}
5833	gfc_conv_intrinsic_funcall (se, expr);
5834	return;
5835	}
5836
5837	type = gfc_get_int_type (ikind);
5838
5839	/* Initialize the result. */
5840	resvar = gfc_create_var (gfc_array_index_type, "pos");
5841	gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5842	offset = gfc_create_var (gfc_array_index_type, "offset");
5843
5844	maskexpr = mask_arg->expr;
5845	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5846	&& maskexpr->symtree->n.sym->attr.dummy
5847	&& maskexpr->symtree->n.sym->attr.optional;
5848
5849	/* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5850
5851	for (i = 0 ; i < 2; i++)
5852	{
5853	/* Walk the arguments. */
5854	arrayss = gfc_walk_expr (array_arg->expr);
5855	gcc_assert (arrayss != gfc_ss_terminator);
5856
5857	if (maskexpr && maskexpr->rank != 0)
5858	{
5859	maskss = gfc_walk_expr (maskexpr);
5860	gcc_assert (maskss != gfc_ss_terminator);
5861	}
5862	else
5863	maskss = NULL;
5864
5865	/* Initialize the scalarizer. */
5866	gfc_init_loopinfo (&loop);
5867	exit_label = gfc_build_label_decl (NULL_TREE);
5868	TREE_USED (exit_label) = 1;
5869
5870	/* We add the mask first because the number of iterations is
5871	taken from the last ss, and this breaks if an absent
5872	optional argument is used for mask. */
5873
5874	if (maskss)
5875	gfc_add_ss_to_loop (&loop, maskss);
5876	gfc_add_ss_to_loop (&loop, arrayss);
5877
5878	/* Initialize the loop. */
5879	gfc_conv_ss_startstride (&loop);
5880	gfc_conv_loop_setup (&loop, &expr->where);
5881
5882	/* Calculate the offset. */
5883	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5884	gfc_index_one_node, loop.from[0]);
5885	gfc_add_modify (&loop.pre, offset, tmp);
5886
5887	gfc_mark_ss_chain_used (arrayss, 1);
5888	if (maskss)
5889	gfc_mark_ss_chain_used (maskss, 1);
5890
5891	/* The first loop is for BACK=.true. */
5892	if (i == 0)
5893	loop.reverse[0] = GFC_REVERSE_SET;
5894
5895	/* Generate the loop body. */
5896	gfc_start_scalarized_body (&loop, &body);
5897
5898	/* If we have an array mask, only add the element if it is
5899	set. */
5900	if (maskss)
5901	{
5902	gfc_init_se (&maskse, NULL);
5903	gfc_copy_loopinfo_to_se (&maskse, &loop);
5904	maskse.ss = maskss;
5905	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5906	gfc_add_block_to_block (&body, &maskse.pre);
5907	}
5908
5909	/* If the condition matches then set the return value. */
5910	gfc_start_block (&block);
5911
5912	/* Add the offset. */
5913	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5914	TREE_TYPE (resvar),
5915	loop.loopvar[0], offset);
5916	gfc_add_modify (&block, resvar, tmp);
5917	/* And break out of the loop. */
5918	tmp = build1_v (GOTO_EXPR, exit_label);
5919	gfc_add_expr_to_block (&block, tmp);
5920
5921	found = gfc_finish_block (&block);
5922
5923	/* Check this element. */
5924	gfc_init_se (&arrayse, NULL);
5925	gfc_copy_loopinfo_to_se (&arrayse, &loop);
5926	arrayse.ss = arrayss;
5927	gfc_conv_expr_val (se: &arrayse, expr: array_arg->expr);
5928	gfc_add_block_to_block (&body, &arrayse.pre);
5929
5930	gfc_init_se (&valuese, NULL);
5931	gfc_conv_expr_val (se: &valuese, expr: value_arg->expr);
5932	gfc_add_block_to_block (&body, &valuese.pre);
5933
5934	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5935	arrayse.expr, valuese.expr);
5936
5937	tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5938	if (maskss)
5939	{
5940	/* We enclose the above in if (mask) {...}. If the mask is
5941	an optional argument, generate IF (.NOT. PRESENT(MASK)
5942	.OR. MASK(I)). */
5943
5944	tree ifmask;
5945	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5946	tmp = build3_v (COND_EXPR, ifmask, tmp,
5947	build_empty_stmt (input_location));
5948	}
5949
5950	gfc_add_expr_to_block (&body, tmp);
5951	gfc_add_block_to_block (&body, &arrayse.post);
5952
5953	gfc_trans_scalarizing_loops (&loop, &body);
5954
5955	/* Add the exit label. */
5956	tmp = build1_v (LABEL_EXPR, exit_label);
5957	gfc_add_expr_to_block (&loop.pre, tmp);
5958	gfc_start_block (&loopblock);
5959	gfc_add_block_to_block (&loopblock, &loop.pre);
5960	gfc_add_block_to_block (&loopblock, &loop.post);
5961	if (i == 0)
5962	forward_branch = gfc_finish_block (&loopblock);
5963	else
5964	back_branch = gfc_finish_block (&loopblock);
5965
5966	gfc_cleanup_loop (&loop);
5967	}
5968
5969	/* Enclose the two loops in an IF statement. */
5970
5971	gfc_init_se (&backse, NULL);
5972	gfc_conv_expr_val (se: &backse, expr: back_arg->expr);
5973	gfc_add_block_to_block (&se->pre, &backse.pre);
5974	tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5975
5976	/* For a scalar mask, enclose the loop in an if statement. */
5977	if (maskexpr && maskss == NULL)
5978	{
5979	tree ifmask;
5980	tree if_stmt;
5981
5982	gfc_init_se (&maskse, NULL);
5983	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
5984	gfc_init_block (&block);
5985	gfc_add_expr_to_block (&block, maskse.expr);
5986	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
5987	if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5988	build_empty_stmt (input_location));
5989	gfc_add_expr_to_block (&block, if_stmt);
5990	tmp = gfc_finish_block (&block);
5991	}
5992
5993	gfc_add_expr_to_block (&se->pre, tmp);
5994	se->expr = convert (type, resvar);
5995
5996	}
5997
5998	/* Emit code for minval or maxval intrinsic. There are many different cases
5999	we need to handle. For performance reasons we sometimes create two
6000	loops instead of one, where the second one is much simpler.
6001	Examples for minval intrinsic:
6002	1) Result is an array, a call is generated
6003	2) Array mask is used and NaNs need to be supported, rank 1:
6004	limit = Infinity;
6005	nonempty = false;
6006	S = from;
6007	while (S <= to) {
6008	if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
6009	S++;
6010	}
6011	limit = nonempty ? NaN : huge (limit);
6012	lab:
6013	while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6014	3) NaNs need to be supported, but it is known at compile time or cheaply
6015	at runtime whether array is nonempty or not, rank 1:
6016	limit = Infinity;
6017	S = from;
6018	while (S <= to) { if (a[S] <= limit) goto lab; S++; }
6019	limit = (from <= to) ? NaN : huge (limit);
6020	lab:
6021	while (S <= to) { limit = min (a[S], limit); S++; }
6022	4) Array mask is used and NaNs need to be supported, rank > 1:
6023	limit = Infinity;
6024	nonempty = false;
6025	fast = false;
6026	S1 = from1;
6027	while (S1 <= to1) {
6028	S2 = from2;
6029	while (S2 <= to2) {
6030	if (mask[S1][S2]) {
6031	if (fast) limit = min (a[S1][S2], limit);
6032	else {
6033	nonempty = true;
6034	if (a[S1][S2] <= limit) {
6035	limit = a[S1][S2];
6036	fast = true;
6037	}
6038	}
6039	}
6040	S2++;
6041	}
6042	S1++;
6043	}
6044	if (!fast)
6045	limit = nonempty ? NaN : huge (limit);
6046	5) NaNs need to be supported, but it is known at compile time or cheaply
6047	at runtime whether array is nonempty or not, rank > 1:
6048	limit = Infinity;
6049	fast = false;
6050	S1 = from1;
6051	while (S1 <= to1) {
6052	S2 = from2;
6053	while (S2 <= to2) {
6054	if (fast) limit = min (a[S1][S2], limit);
6055	else {
6056	if (a[S1][S2] <= limit) {
6057	limit = a[S1][S2];
6058	fast = true;
6059	}
6060	}
6061	S2++;
6062	}
6063	S1++;
6064	}
6065	if (!fast)
6066	limit = (nonempty_array) ? NaN : huge (limit);
6067	6) NaNs aren't supported, but infinities are. Array mask is used:
6068	limit = Infinity;
6069	nonempty = false;
6070	S = from;
6071	while (S <= to) {
6072	if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6073	S++;
6074	}
6075	limit = nonempty ? limit : huge (limit);
6076	7) Same without array mask:
6077	limit = Infinity;
6078	S = from;
6079	while (S <= to) { limit = min (a[S], limit); S++; }
6080	limit = (from <= to) ? limit : huge (limit);
6081	8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6082	limit = huge (limit);
6083	S = from;
6084	while (S <= to) { limit = min (a[S], limit); S++); }
6085	(or
6086	while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6087	with array mask instead).
6088	For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6089	setting limit = huge (limit); in the else branch. */
6090
6091	static void
6092	gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6093	{
6094	tree limit;
6095	tree type;
6096	tree tmp;
6097	tree ifbody;
6098	tree nonempty;
6099	tree nonempty_var;
6100	tree lab;
6101	tree fast;
6102	tree huge_cst = NULL, nan_cst = NULL;
6103	stmtblock_t body;
6104	stmtblock_t block, block2;
6105	gfc_loopinfo loop;
6106	gfc_actual_arglist *actual;
6107	gfc_ss *arrayss;
6108	gfc_ss *maskss;
6109	gfc_se arrayse;
6110	gfc_se maskse;
6111	gfc_expr *arrayexpr;
6112	gfc_expr *maskexpr;
6113	int n;
6114	bool optional_mask;
6115
6116	if (se->ss)
6117	{
6118	gfc_conv_intrinsic_funcall (se, expr);
6119	return;
6120	}
6121
6122	actual = expr->value.function.actual;
6123	arrayexpr = actual->expr;
6124
6125	if (arrayexpr->ts.type == BT_CHARACTER)
6126	{
6127	gfc_actual_arglist *dim = actual->next;
6128	if (expr->rank == 0 && dim->expr != 0)
6129	{
6130	gfc_free_expr (dim->expr);
6131	dim->expr = NULL;
6132	}
6133	gfc_conv_intrinsic_funcall (se, expr);
6134	return;
6135	}
6136
6137	type = gfc_typenode_for_spec (&expr->ts);
6138	/* Initialize the result. */
6139	limit = gfc_create_var (type, "limit");
6140	n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6141	switch (expr->ts.type)
6142	{
6143	case BT_REAL:
6144	huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6145	expr->ts.kind, 0);
6146	if (HONOR_INFINITIES (DECL_MODE (limit)))
6147	{
6148	REAL_VALUE_TYPE real;
6149	real_inf (&real);
6150	tmp = build_real (type, real);
6151	}
6152	else
6153	tmp = huge_cst;
6154	if (HONOR_NANS (DECL_MODE (limit)))
6155	nan_cst = gfc_build_nan (type, "");
6156	break;
6157
6158	case BT_INTEGER:
6159	tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6160	break;
6161
6162	default:
6163	gcc_unreachable ();
6164	}
6165
6166	/* We start with the most negative possible value for MAXVAL, and the most
6167	positive possible value for MINVAL. The most negative possible value is
6168	-HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6169	possible value is HUGE in both cases. */
6170	if (op == GT_EXPR)
6171	{
6172	tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6173	if (huge_cst)
6174	huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6175	TREE_TYPE (huge_cst), huge_cst);
6176	}
6177
6178	if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6179	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6180	tmp, build_int_cst (type, 1));
6181
6182	gfc_add_modify (&se->pre, limit, tmp);
6183
6184	/* Walk the arguments. */
6185	arrayss = gfc_walk_expr (arrayexpr);
6186	gcc_assert (arrayss != gfc_ss_terminator);
6187
6188	actual = actual->next->next;
6189	gcc_assert (actual);
6190	maskexpr = actual->expr;
6191	optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6192	&& maskexpr->symtree->n.sym->attr.dummy
6193	&& maskexpr->symtree->n.sym->attr.optional;
6194	nonempty = NULL;
6195	if (maskexpr && maskexpr->rank != 0)
6196	{
6197	maskss = gfc_walk_expr (maskexpr);
6198	gcc_assert (maskss != gfc_ss_terminator);
6199	}
6200	else
6201	{
6202	mpz_t asize;
6203	if (gfc_array_size (arrayexpr, &asize))
6204	{
6205	nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6206	mpz_clear (asize);
6207	nonempty = fold_build2_loc (input_location, GT_EXPR,
6208	logical_type_node, nonempty,
6209	gfc_index_zero_node);
6210	}
6211	maskss = NULL;
6212	}
6213
6214	/* Initialize the scalarizer. */
6215	gfc_init_loopinfo (&loop);
6216
6217	/* We add the mask first because the number of iterations is taken
6218	from the last ss, and this breaks if an absent optional argument
6219	is used for mask. */
6220
6221	if (maskss)
6222	gfc_add_ss_to_loop (&loop, maskss);
6223	gfc_add_ss_to_loop (&loop, arrayss);
6224
6225	/* Initialize the loop. */
6226	gfc_conv_ss_startstride (&loop);
6227
6228	/* The code generated can have more than one loop in sequence (see the
6229	comment at the function header). This doesn't work well with the
6230	scalarizer, which changes arrays' offset when the scalarization loops
6231	are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6232	are currently inlined in the scalar case only. As there is no dependency
6233	to care about in that case, there is no temporary, so that we can use the
6234	scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6235	here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6236	gfc_trans_scalarized_loop_boundary even later to restore offset.
6237	TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6238	should eventually go away. We could either create two loops properly,
6239	or find another way to save/restore the array offsets between the two
6240	loops (without conflicting with temporary management), or use a single
6241	loop minmaxval implementation. See PR 31067. */
6242	loop.temp_dim = loop.dimen;
6243	gfc_conv_loop_setup (&loop, &expr->where);
6244
6245	if (nonempty == NULL && maskss == NULL
6246	&& loop.dimen == 1 && loop.from[0] && loop.to[0])
6247	nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6248	loop.from[0], loop.to[0]);
6249	nonempty_var = NULL;
6250	if (nonempty == NULL
6251	&& (HONOR_INFINITIES (DECL_MODE (limit))
6252	|| HONOR_NANS (DECL_MODE (limit))))
6253	{
6254	nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6255	gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6256	nonempty = nonempty_var;
6257	}
6258	lab = NULL;
6259	fast = NULL;
6260	if (HONOR_NANS (DECL_MODE (limit)))
6261	{
6262	if (loop.dimen == 1)
6263	{
6264	lab = gfc_build_label_decl (NULL_TREE);
6265	TREE_USED (lab) = 1;
6266	}
6267	else
6268	{
6269	fast = gfc_create_var (logical_type_node, "fast");
6270	gfc_add_modify (&se->pre, fast, logical_false_node);
6271	}
6272	}
6273
6274	gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6275	if (maskss)
6276	gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6277	/* Generate the loop body. */
6278	gfc_start_scalarized_body (&loop, &body);
6279
6280	/* If we have a mask, only add this element if the mask is set. */
6281	if (maskss)
6282	{
6283	gfc_init_se (&maskse, NULL);
6284	gfc_copy_loopinfo_to_se (&maskse, &loop);
6285	maskse.ss = maskss;
6286	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
6287	gfc_add_block_to_block (&body, &maskse.pre);
6288
6289	gfc_start_block (&block);
6290	}
6291	else
6292	gfc_init_block (&block);
6293
6294	/* Compare with the current limit. */
6295	gfc_init_se (&arrayse, NULL);
6296	gfc_copy_loopinfo_to_se (&arrayse, &loop);
6297	arrayse.ss = arrayss;
6298	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
6299	gfc_add_block_to_block (&block, &arrayse.pre);
6300
6301	gfc_init_block (&block2);
6302
6303	if (nonempty_var)
6304	gfc_add_modify (&block2, nonempty_var, logical_true_node);
6305
6306	if (HONOR_NANS (DECL_MODE (limit)))
6307	{
6308	tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6309	logical_type_node, arrayse.expr, limit);
6310	if (lab)
6311	ifbody = build1_v (GOTO_EXPR, lab);
6312	else
6313	{
6314	stmtblock_t ifblock;
6315
6316	gfc_init_block (&ifblock);
6317	gfc_add_modify (&ifblock, limit, arrayse.expr);
6318	gfc_add_modify (&ifblock, fast, logical_true_node);
6319	ifbody = gfc_finish_block (&ifblock);
6320	}
6321	tmp = build3_v (COND_EXPR, tmp, ifbody,
6322	build_empty_stmt (input_location));
6323	gfc_add_expr_to_block (&block2, tmp);
6324	}
6325	else
6326	{
6327	/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6328	signed zeros. */
6329	tmp = fold_build2_loc (input_location,
6330	op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6331	type, arrayse.expr, limit);
6332	gfc_add_modify (&block2, limit, tmp);
6333	}
6334
6335	if (fast)
6336	{
6337	tree elsebody = gfc_finish_block (&block2);
6338
6339	/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6340	signed zeros. */
6341	if (HONOR_NANS (DECL_MODE (limit)))
6342	{
6343	tmp = fold_build2_loc (input_location, op, logical_type_node,
6344	arrayse.expr, limit);
6345	ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6346	ifbody = build3_v (COND_EXPR, tmp, ifbody,
6347	build_empty_stmt (input_location));
6348	}
6349	else
6350	{
6351	tmp = fold_build2_loc (input_location,
6352	op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6353	type, arrayse.expr, limit);
6354	ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6355	}
6356	tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6357	gfc_add_expr_to_block (&block, tmp);
6358	}
6359	else
6360	gfc_add_block_to_block (&block, &block2);
6361
6362	gfc_add_block_to_block (&block, &arrayse.post);
6363
6364	tmp = gfc_finish_block (&block);
6365	if (maskss)
6366	{
6367	/* We enclose the above in if (mask) {...}. If the mask is an
6368	optional argument, generate IF (.NOT. PRESENT(MASK)
6369	.OR. MASK(I)). */
6370	tree ifmask;
6371	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
6372	tmp = build3_v (COND_EXPR, ifmask, tmp,
6373	build_empty_stmt (input_location));
6374	}
6375	gfc_add_expr_to_block (&body, tmp);
6376
6377	if (lab)
6378	{
6379	gfc_trans_scalarized_loop_boundary (&loop, &body);
6380
6381	tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6382	nan_cst, huge_cst);
6383	gfc_add_modify (&loop.code[0], limit, tmp);
6384	gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6385
6386	/* If we have a mask, only add this element if the mask is set. */
6387	if (maskss)
6388	{
6389	gfc_init_se (&maskse, NULL);
6390	gfc_copy_loopinfo_to_se (&maskse, &loop);
6391	maskse.ss = maskss;
6392	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
6393	gfc_add_block_to_block (&body, &maskse.pre);
6394
6395	gfc_start_block (&block);
6396	}
6397	else
6398	gfc_init_block (&block);
6399
6400	/* Compare with the current limit. */
6401	gfc_init_se (&arrayse, NULL);
6402	gfc_copy_loopinfo_to_se (&arrayse, &loop);
6403	arrayse.ss = arrayss;
6404	gfc_conv_expr_val (se: &arrayse, expr: arrayexpr);
6405	gfc_add_block_to_block (&block, &arrayse.pre);
6406
6407	/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6408	signed zeros. */
6409	if (HONOR_NANS (DECL_MODE (limit)))
6410	{
6411	tmp = fold_build2_loc (input_location, op, logical_type_node,
6412	arrayse.expr, limit);
6413	ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6414	tmp = build3_v (COND_EXPR, tmp, ifbody,
6415	build_empty_stmt (input_location));
6416	gfc_add_expr_to_block (&block, tmp);
6417	}
6418	else
6419	{
6420	tmp = fold_build2_loc (input_location,
6421	op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6422	type, arrayse.expr, limit);
6423	gfc_add_modify (&block, limit, tmp);
6424	}
6425
6426	gfc_add_block_to_block (&block, &arrayse.post);
6427
6428	tmp = gfc_finish_block (&block);
6429	if (maskss)
6430	/* We enclose the above in if (mask) {...}. */
6431	{
6432	tree ifmask;
6433	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
6434	tmp = build3_v (COND_EXPR, ifmask, tmp,
6435	build_empty_stmt (input_location));
6436	}
6437
6438	gfc_add_expr_to_block (&body, tmp);
6439	/* Avoid initializing loopvar[0] again, it should be left where
6440	it finished by the first loop. */
6441	loop.from[0] = loop.loopvar[0];
6442	}
6443	gfc_trans_scalarizing_loops (&loop, &body);
6444
6445	if (fast)
6446	{
6447	tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6448	nan_cst, huge_cst);
6449	ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6450	tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6451	ifbody);
6452	gfc_add_expr_to_block (&loop.pre, tmp);
6453	}
6454	else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6455	{
6456	tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6457	huge_cst);
6458	gfc_add_modify (&loop.pre, limit, tmp);
6459	}
6460
6461	/* For a scalar mask, enclose the loop in an if statement. */
6462	if (maskexpr && maskss == NULL)
6463	{
6464	tree else_stmt;
6465	tree ifmask;
6466
6467	gfc_init_se (&maskse, NULL);
6468	gfc_conv_expr_val (se: &maskse, expr: maskexpr);
6469	gfc_init_block (&block);
6470	gfc_add_block_to_block (&block, &loop.pre);
6471	gfc_add_block_to_block (&block, &loop.post);
6472	tmp = gfc_finish_block (&block);
6473
6474	if (HONOR_INFINITIES (DECL_MODE (limit)))
6475	else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6476	else
6477	else_stmt = build_empty_stmt (input_location);
6478
6479	ifmask = conv_mask_condition (maskse: &maskse, maskexpr, optional_mask);
6480	tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6481	gfc_add_expr_to_block (&block, tmp);
6482	gfc_add_block_to_block (&se->pre, &block);
6483	}
6484	else
6485	{
6486	gfc_add_block_to_block (&se->pre, &loop.pre);
6487	gfc_add_block_to_block (&se->pre, &loop.post);
6488	}
6489
6490	gfc_cleanup_loop (&loop);
6491
6492	se->expr = limit;
6493	}
6494
6495	/* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6496	static void
6497	gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6498	{
6499	tree args[2];
6500	tree type;
6501	tree tmp;
6502
6503	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6504	type = TREE_TYPE (args[0]);
6505
6506	/* Optionally generate code for runtime argument check. */
6507	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6508	{
6509	tree below = fold_build2_loc (input_location, LT_EXPR,
6510	logical_type_node, args[1],
6511	build_int_cst (TREE_TYPE (args[1]), 0));
6512	tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6513	tree above = fold_build2_loc (input_location, GE_EXPR,
6514	logical_type_node, args[1], nbits);
6515	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6516	logical_type_node, below, above);
6517	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6518	"POS argument (%ld) out of range 0:%ld "
6519	"in intrinsic BTEST",
6520	fold_convert (long_integer_type_node, args[1]),
6521	fold_convert (long_integer_type_node, nbits));
6522	}
6523
6524	tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6525	build_int_cst (type, 1), args[1]);
6526	tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6527	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6528	build_int_cst (type, 0));
6529	type = gfc_typenode_for_spec (&expr->ts);
6530	se->expr = convert (type, tmp);
6531	}
6532
6533
6534	/* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6535	static void
6536	gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6537	{
6538	tree args[2];
6539
6540	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6541
6542	/* Convert both arguments to the unsigned type of the same size. */
6543	args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6544	args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6545
6546	/* If they have unequal type size, convert to the larger one. */
6547	if (TYPE_PRECISION (TREE_TYPE (args[0]))
6548	> TYPE_PRECISION (TREE_TYPE (args[1])))
6549	args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6550	else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6551	> TYPE_PRECISION (TREE_TYPE (args[0])))
6552	args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6553
6554	/* Now, we compare them. */
6555	se->expr = fold_build2_loc (input_location, op, logical_type_node,
6556	args[0], args[1]);
6557	}
6558
6559
6560	/* Generate code to perform the specified operation. */
6561	static void
6562	gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6563	{
6564	tree args[2];
6565
6566	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6567	se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6568	args[0], args[1]);
6569	}
6570
6571	/* Bitwise not. */
6572	static void
6573	gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6574	{
6575	tree arg;
6576
6577	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
6578	se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6579	TREE_TYPE (arg), arg);
6580	}
6581
6582	/* Set or clear a single bit. */
6583	static void
6584	gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6585	{
6586	tree args[2];
6587	tree type;
6588	tree tmp;
6589	enum tree_code op;
6590
6591	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6592	type = TREE_TYPE (args[0]);
6593
6594	/* Optionally generate code for runtime argument check. */
6595	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6596	{
6597	tree below = fold_build2_loc (input_location, LT_EXPR,
6598	logical_type_node, args[1],
6599	build_int_cst (TREE_TYPE (args[1]), 0));
6600	tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6601	tree above = fold_build2_loc (input_location, GE_EXPR,
6602	logical_type_node, args[1], nbits);
6603	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6604	logical_type_node, below, above);
6605	size_t len_name = strlen (s: expr->value.function.isym->name);
6606	char *name = XALLOCAVEC (char, len_name + 1);
6607	for (size_t i = 0; i < len_name; i++)
6608	name[i] = TOUPPER (expr->value.function.isym->name[i]);
6609	name[len_name] = '\0';
6610	tree iname = gfc_build_addr_expr (pchar_type_node,
6611	gfc_build_cstring_const (name));
6612	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6613	"POS argument (%ld) out of range 0:%ld "
6614	"in intrinsic %s",
6615	fold_convert (long_integer_type_node, args[1]),
6616	fold_convert (long_integer_type_node, nbits),
6617	iname);
6618	}
6619
6620	tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6621	build_int_cst (type, 1), args[1]);
6622	if (set)
6623	op = BIT_IOR_EXPR;
6624	else
6625	{
6626	op = BIT_AND_EXPR;
6627	tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6628	}
6629	se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6630	}
6631
6632	/* Extract a sequence of bits.
6633	IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6634	static void
6635	gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6636	{
6637	tree args[3];
6638	tree type;
6639	tree tmp;
6640	tree mask;
6641	tree num_bits, cond;
6642
6643	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
6644	type = TREE_TYPE (args[0]);
6645
6646	/* Optionally generate code for runtime argument check. */
6647	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6648	{
6649	tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6650	tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6651	tree nbits = build_int_cst (long_integer_type_node,
6652	TYPE_PRECISION (type));
6653	tree below = fold_build2_loc (input_location, LT_EXPR,
6654	logical_type_node, args[1],
6655	build_int_cst (TREE_TYPE (args[1]), 0));
6656	tree above = fold_build2_loc (input_location, GT_EXPR,
6657	logical_type_node, tmp1, nbits);
6658	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6659	logical_type_node, below, above);
6660	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6661	"POS argument (%ld) out of range 0:%ld "
6662	"in intrinsic IBITS", tmp1, nbits);
6663	below = fold_build2_loc (input_location, LT_EXPR,
6664	logical_type_node, args[2],
6665	build_int_cst (TREE_TYPE (args[2]), 0));
6666	above = fold_build2_loc (input_location, GT_EXPR,
6667	logical_type_node, tmp2, nbits);
6668	scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6669	logical_type_node, below, above);
6670	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6671	"LEN argument (%ld) out of range 0:%ld "
6672	"in intrinsic IBITS", tmp2, nbits);
6673	above = fold_build2_loc (input_location, PLUS_EXPR,
6674	long_integer_type_node, tmp1, tmp2);
6675	scond = fold_build2_loc (input_location, GT_EXPR,
6676	logical_type_node, above, nbits);
6677	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6678	"POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6679	"in intrinsic IBITS", tmp1, tmp2, nbits);
6680	}
6681
6682	/* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6683	gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6684	special case. See also gfc_conv_intrinsic_ishft (). */
6685	num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6686
6687	mask = build_int_cst (type, -1);
6688	mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6689	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6690	num_bits);
6691	mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6692	build_int_cst (type, 0), mask);
6693	mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6694
6695	tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6696
6697	se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6698	}
6699
6700	static void
6701	gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6702	bool arithmetic)
6703	{
6704	tree args[2], type, num_bits, cond;
6705	tree bigshift;
6706
6707	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6708
6709	args[0] = gfc_evaluate_now (args[0], &se->pre);
6710	args[1] = gfc_evaluate_now (args[1], &se->pre);
6711	type = TREE_TYPE (args[0]);
6712
6713	if (!arithmetic)
6714	args[0] = fold_convert (unsigned_type_for (type), args[0]);
6715	else
6716	gcc_assert (right_shift);
6717
6718	se->expr = fold_build2_loc (input_location,
6719	right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
6720	TREE_TYPE (args[0]), args[0], args[1]);
6721
6722	if (!arithmetic)
6723	se->expr = fold_convert (type, se->expr);
6724
6725	if (!arithmetic)
6726	bigshift = build_int_cst (type, 0);
6727	else
6728	{
6729	tree nonneg = fold_build2_loc (input_location, GE_EXPR,
6730	logical_type_node, args[0],
6731	build_int_cst (TREE_TYPE (args[0]), 0));
6732	bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
6733	build_int_cst (type, 0),
6734	build_int_cst (type, -1));
6735	}
6736
6737	/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6738	gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6739	special case. */
6740	num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6741
6742	/* Optionally generate code for runtime argument check. */
6743	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6744	{
6745	tree below = fold_build2_loc (input_location, LT_EXPR,
6746	logical_type_node, args[1],
6747	build_int_cst (TREE_TYPE (args[1]), 0));
6748	tree above = fold_build2_loc (input_location, GT_EXPR,
6749	logical_type_node, args[1], num_bits);
6750	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6751	logical_type_node, below, above);
6752	size_t len_name = strlen (s: expr->value.function.isym->name);
6753	char *name = XALLOCAVEC (char, len_name + 1);
6754	for (size_t i = 0; i < len_name; i++)
6755	name[i] = TOUPPER (expr->value.function.isym->name[i]);
6756	name[len_name] = '\0';
6757	tree iname = gfc_build_addr_expr (pchar_type_node,
6758	gfc_build_cstring_const (name));
6759	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6760	"SHIFT argument (%ld) out of range 0:%ld "
6761	"in intrinsic %s",
6762	fold_convert (long_integer_type_node, args[1]),
6763	fold_convert (long_integer_type_node, num_bits),
6764	iname);
6765	}
6766
6767	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6768	args[1], num_bits);
6769
6770	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6771	bigshift, se->expr);
6772	}
6773
6774	/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6775	? 0
6776	: ((shift >= 0) ? i << shift : i >> -shift)
6777	where all shifts are logical shifts. */
6778	static void
6779	gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
6780	{
6781	tree args[2];
6782	tree type;
6783	tree utype;
6784	tree tmp;
6785	tree width;
6786	tree num_bits;
6787	tree cond;
6788	tree lshift;
6789	tree rshift;
6790
6791	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
6792
6793	args[0] = gfc_evaluate_now (args[0], &se->pre);
6794	args[1] = gfc_evaluate_now (args[1], &se->pre);
6795
6796	type = TREE_TYPE (args[0]);
6797	utype = unsigned_type_for (type);
6798
6799	width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
6800	args[1]);
6801
6802	/* Left shift if positive. */
6803	lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
6804
6805	/* Right shift if negative.
6806	We convert to an unsigned type because we want a logical shift.
6807	The standard doesn't define the case of shifting negative
6808	numbers, and we try to be compatible with other compilers, most
6809	notably g77, here. */
6810	rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
6811	utype, convert (utype, args[0]), width));
6812
6813	tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
6814	build_int_cst (TREE_TYPE (args[1]), 0));
6815	tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
6816
6817	/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6818	gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6819	special case. */
6820	num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6821
6822	/* Optionally generate code for runtime argument check. */
6823	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6824	{
6825	tree outside = fold_build2_loc (input_location, GT_EXPR,
6826	logical_type_node, width, num_bits);
6827	gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
6828	"SHIFT argument (%ld) out of range -%ld:%ld "
6829	"in intrinsic ISHFT",
6830	fold_convert (long_integer_type_node, args[1]),
6831	fold_convert (long_integer_type_node, num_bits),
6832	fold_convert (long_integer_type_node, num_bits));
6833	}
6834
6835	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
6836	num_bits);
6837	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6838	build_int_cst (type, 0), tmp);
6839	}
6840
6841
6842	/* Circular shift. AKA rotate or barrel shift. */
6843
6844	static void
6845	gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
6846	{
6847	tree *args;
6848	tree type;
6849	tree tmp;
6850	tree lrot;
6851	tree rrot;
6852	tree zero;
6853	tree nbits;
6854	unsigned int num_args;
6855
6856	num_args = gfc_intrinsic_argument_list_length (expr);
6857	args = XALLOCAVEC (tree, num_args);
6858
6859	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
6860
6861	type = TREE_TYPE (args[0]);
6862	nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
6863
6864	if (num_args == 3)
6865	{
6866	/* Use a library function for the 3 parameter version. */
6867	tree int4type = gfc_get_int_type (4);
6868
6869	/* We convert the first argument to at least 4 bytes, and
6870	convert back afterwards. This removes the need for library
6871	functions for all argument sizes, and function will be
6872	aligned to at least 32 bits, so there's no loss. */
6873	if (expr->ts.kind < 4)
6874	args[0] = convert (int4type, args[0]);
6875
6876	/* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6877	need loads of library functions. They cannot have values >
6878	BIT_SIZE (I) so the conversion is safe. */
6879	args[1] = convert (int4type, args[1]);
6880	args[2] = convert (int4type, args[2]);
6881
6882	/* Optionally generate code for runtime argument check. */
6883	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6884	{
6885	tree size = fold_convert (long_integer_type_node, args[2]);
6886	tree below = fold_build2_loc (input_location, LE_EXPR,
6887	logical_type_node, size,
6888	build_int_cst (TREE_TYPE (args[1]), 0));
6889	tree above = fold_build2_loc (input_location, GT_EXPR,
6890	logical_type_node, size, nbits);
6891	tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6892	logical_type_node, below, above);
6893	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6894	"SIZE argument (%ld) out of range 1:%ld "
6895	"in intrinsic ISHFTC", size, nbits);
6896	tree width = fold_convert (long_integer_type_node, args[1]);
6897	width = fold_build1_loc (input_location, ABS_EXPR,
6898	long_integer_type_node, width);
6899	scond = fold_build2_loc (input_location, GT_EXPR,
6900	logical_type_node, width, size);
6901	gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6902	"SHIFT argument (%ld) out of range -%ld:%ld "
6903	"in intrinsic ISHFTC",
6904	fold_convert (long_integer_type_node, args[1]),
6905	size, size);
6906	}
6907
6908	switch (expr->ts.kind)
6909	{
6910	case 1:
6911	case 2:
6912	case 4:
6913	tmp = gfor_fndecl_math_ishftc4;
6914	break;
6915	case 8:
6916	tmp = gfor_fndecl_math_ishftc8;
6917	break;
6918	case 16:
6919	tmp = gfor_fndecl_math_ishftc16;
6920	break;
6921	default:
6922	gcc_unreachable ();
6923	}
6924	se->expr = build_call_expr_loc (input_location,
6925	tmp, 3, args[0], args[1], args[2]);
6926	/* Convert the result back to the original type, if we extended
6927	the first argument's width above. */
6928	if (expr->ts.kind < 4)
6929	se->expr = convert (type, se->expr);
6930
6931	return;
6932	}
6933
6934	/* Evaluate arguments only once. */
6935	args[0] = gfc_evaluate_now (args[0], &se->pre);
6936	args[1] = gfc_evaluate_now (args[1], &se->pre);
6937
6938	/* Optionally generate code for runtime argument check. */
6939	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6940	{
6941	tree width = fold_convert (long_integer_type_node, args[1]);
6942	width = fold_build1_loc (input_location, ABS_EXPR,
6943	long_integer_type_node, width);
6944	tree outside = fold_build2_loc (input_location, GT_EXPR,
6945	logical_type_node, width, nbits);
6946	gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
6947	"SHIFT argument (%ld) out of range -%ld:%ld "
6948	"in intrinsic ISHFTC",
6949	fold_convert (long_integer_type_node, args[1]),
6950	nbits, nbits);
6951	}
6952
6953	/* Rotate left if positive. */
6954	lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
6955
6956	/* Rotate right if negative. */
6957	tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
6958	args[1]);
6959	rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
6960
6961	zero = build_int_cst (TREE_TYPE (args[1]), 0);
6962	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
6963	zero);
6964	rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
6965
6966	/* Do nothing if shift == 0. */
6967	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
6968	zero);
6969	se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
6970	rrot);
6971	}
6972
6973
6974	/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6975	: __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6976
6977	The conditional expression is necessary because the result of LEADZ(0)
6978	is defined, but the result of __builtin_clz(0) is undefined for most
6979	targets.
6980
6981	For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6982	difference in bit size between the argument of LEADZ and the C int. */
6983
6984	static void
6985	gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
6986	{
6987	tree arg;
6988	tree arg_type;
6989	tree cond;
6990	tree result_type;
6991	tree leadz;
6992	tree bit_size;
6993	tree tmp;
6994	tree func;
6995	int s, argsize;
6996
6997	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
6998	argsize = TYPE_PRECISION (TREE_TYPE (arg));
6999
7000	/* Which variant of __builtin_clz* should we call? */
7001	if (argsize <= INT_TYPE_SIZE)
7002	{
7003	arg_type = unsigned_type_node;
7004	func = builtin_decl_explicit (fncode: BUILT_IN_CLZ);
7005	}
7006	else if (argsize <= LONG_TYPE_SIZE)
7007	{
7008	arg_type = long_unsigned_type_node;
7009	func = builtin_decl_explicit (fncode: BUILT_IN_CLZL);
7010	}
7011	else if (argsize <= LONG_LONG_TYPE_SIZE)
7012	{
7013	arg_type = long_long_unsigned_type_node;
7014	func = builtin_decl_explicit (fncode: BUILT_IN_CLZLL);
7015	}
7016	else
7017	{
7018	gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7019	arg_type = gfc_build_uint_type (argsize);
7020	func = NULL_TREE;
7021	}
7022
7023	/* Convert the actual argument twice: first, to the unsigned type of the
7024	same size; then, to the proper argument type for the built-in
7025	function. But the return type is of the default INTEGER kind. */
7026	arg = fold_convert (gfc_build_uint_type (argsize), arg);
7027	arg = fold_convert (arg_type, arg);
7028	arg = gfc_evaluate_now (arg, &se->pre);
7029	result_type = gfc_get_int_type (gfc_default_integer_kind);
7030
7031	/* Compute LEADZ for the case i .ne. 0. */
7032	if (func)
7033	{
7034	s = TYPE_PRECISION (arg_type) - argsize;
7035	tmp = fold_convert (result_type,
7036	build_call_expr_loc (input_location, func,
7037	1, arg));
7038	leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7039	tmp, build_int_cst (result_type, s));
7040	}
7041	else
7042	{
7043	/* We end up here if the argument type is larger than 'long long'.
7044	We generate this code:
7045
7046	if (x & (ULL_MAX << ULL_SIZE) != 0)
7047	return clzll ((unsigned long long) (x >> ULLSIZE));
7048	else
7049	return ULL_SIZE + clzll ((unsigned long long) x);
7050	where ULL_MAX is the largest value that a ULL_MAX can hold
7051	(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7052	is the bit-size of the long long type (64 in this example). */
7053	tree ullsize, ullmax, tmp1, tmp2, btmp;
7054
7055	ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7056	ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7057	long_long_unsigned_type_node,
7058	build_int_cst (long_long_unsigned_type_node,
7059	0));
7060
7061	cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7062	fold_convert (arg_type, ullmax), ullsize);
7063	cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7064	arg, cond);
7065	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7066	cond, build_int_cst (arg_type, 0));
7067
7068	tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7069	arg, ullsize);
7070	tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7071	btmp = builtin_decl_explicit (fncode: BUILT_IN_CLZLL);
7072	tmp1 = fold_convert (result_type,
7073	build_call_expr_loc (input_location, btmp, 1, tmp1));
7074
7075	tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7076	btmp = builtin_decl_explicit (fncode: BUILT_IN_CLZLL);
7077	tmp2 = fold_convert (result_type,
7078	build_call_expr_loc (input_location, btmp, 1, tmp2));
7079	tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7080	tmp2, ullsize);
7081
7082	leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7083	cond, tmp1, tmp2);
7084	}
7085
7086	/* Build BIT_SIZE. */
7087	bit_size = build_int_cst (result_type, argsize);
7088
7089	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7090	arg, build_int_cst (arg_type, 0));
7091	se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7092	bit_size, leadz);
7093	}
7094
7095
7096	/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7097
7098	The conditional expression is necessary because the result of TRAILZ(0)
7099	is defined, but the result of __builtin_ctz(0) is undefined for most
7100	targets. */
7101
7102	static void
7103	gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7104	{
7105	tree arg;
7106	tree arg_type;
7107	tree cond;
7108	tree result_type;
7109	tree trailz;
7110	tree bit_size;
7111	tree func;
7112	int argsize;
7113
7114	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7115	argsize = TYPE_PRECISION (TREE_TYPE (arg));
7116
7117	/* Which variant of __builtin_ctz* should we call? */
7118	if (argsize <= INT_TYPE_SIZE)
7119	{
7120	arg_type = unsigned_type_node;
7121	func = builtin_decl_explicit (fncode: BUILT_IN_CTZ);
7122	}
7123	else if (argsize <= LONG_TYPE_SIZE)
7124	{
7125	arg_type = long_unsigned_type_node;
7126	func = builtin_decl_explicit (fncode: BUILT_IN_CTZL);
7127	}
7128	else if (argsize <= LONG_LONG_TYPE_SIZE)
7129	{
7130	arg_type = long_long_unsigned_type_node;
7131	func = builtin_decl_explicit (fncode: BUILT_IN_CTZLL);
7132	}
7133	else
7134	{
7135	gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7136	arg_type = gfc_build_uint_type (argsize);
7137	func = NULL_TREE;
7138	}
7139
7140	/* Convert the actual argument twice: first, to the unsigned type of the
7141	same size; then, to the proper argument type for the built-in
7142	function. But the return type is of the default INTEGER kind. */
7143	arg = fold_convert (gfc_build_uint_type (argsize), arg);
7144	arg = fold_convert (arg_type, arg);
7145	arg = gfc_evaluate_now (arg, &se->pre);
7146	result_type = gfc_get_int_type (gfc_default_integer_kind);
7147
7148	/* Compute TRAILZ for the case i .ne. 0. */
7149	if (func)
7150	trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7151	func, 1, arg));
7152	else
7153	{
7154	/* We end up here if the argument type is larger than 'long long'.
7155	We generate this code:
7156
7157	if ((x & ULL_MAX) == 0)
7158	return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7159	else
7160	return ctzll ((unsigned long long) x);
7161
7162	where ULL_MAX is the largest value that a ULL_MAX can hold
7163	(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7164	is the bit-size of the long long type (64 in this example). */
7165	tree ullsize, ullmax, tmp1, tmp2, btmp;
7166
7167	ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7168	ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7169	long_long_unsigned_type_node,
7170	build_int_cst (long_long_unsigned_type_node, 0));
7171
7172	cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7173	fold_convert (arg_type, ullmax));
7174	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7175	build_int_cst (arg_type, 0));
7176
7177	tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7178	arg, ullsize);
7179	tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7180	btmp = builtin_decl_explicit (fncode: BUILT_IN_CTZLL);
7181	tmp1 = fold_convert (result_type,
7182	build_call_expr_loc (input_location, btmp, 1, tmp1));
7183	tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7184	tmp1, ullsize);
7185
7186	tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7187	btmp = builtin_decl_explicit (fncode: BUILT_IN_CTZLL);
7188	tmp2 = fold_convert (result_type,
7189	build_call_expr_loc (input_location, btmp, 1, tmp2));
7190
7191	trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7192	cond, tmp1, tmp2);
7193	}
7194
7195	/* Build BIT_SIZE. */
7196	bit_size = build_int_cst (result_type, argsize);
7197
7198	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7199	arg, build_int_cst (arg_type, 0));
7200	se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7201	bit_size, trailz);
7202	}
7203
7204	/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7205	for types larger than "long long", we call the long long built-in for
7206	the lower and higher bits and combine the result. */
7207
7208	static void
7209	gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7210	{
7211	tree arg;
7212	tree arg_type;
7213	tree result_type;
7214	tree func;
7215	int argsize;
7216
7217	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7218	argsize = TYPE_PRECISION (TREE_TYPE (arg));
7219	result_type = gfc_get_int_type (gfc_default_integer_kind);
7220
7221	/* Which variant of the builtin should we call? */
7222	if (argsize <= INT_TYPE_SIZE)
7223	{
7224	arg_type = unsigned_type_node;
7225	func = builtin_decl_explicit (fncode: parity
7226	? BUILT_IN_PARITY
7227	: BUILT_IN_POPCOUNT);
7228	}
7229	else if (argsize <= LONG_TYPE_SIZE)
7230	{
7231	arg_type = long_unsigned_type_node;
7232	func = builtin_decl_explicit (fncode: parity
7233	? BUILT_IN_PARITYL
7234	: BUILT_IN_POPCOUNTL);
7235	}
7236	else if (argsize <= LONG_LONG_TYPE_SIZE)
7237	{
7238	arg_type = long_long_unsigned_type_node;
7239	func = builtin_decl_explicit (fncode: parity
7240	? BUILT_IN_PARITYLL
7241	: BUILT_IN_POPCOUNTLL);
7242	}
7243	else
7244	{
7245	/* Our argument type is larger than 'long long', which mean none
7246	of the POPCOUNT builtins covers it. We thus call the 'long long'
7247	variant multiple times, and add the results. */
7248	tree utype, arg2, call1, call2;
7249
7250	/* For now, we only cover the case where argsize is twice as large
7251	as 'long long'. */
7252	gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7253
7254	func = builtin_decl_explicit (fncode: parity
7255	? BUILT_IN_PARITYLL
7256	: BUILT_IN_POPCOUNTLL);
7257
7258	/* Convert it to an integer, and store into a variable. */
7259	utype = gfc_build_uint_type (argsize);
7260	arg = fold_convert (utype, arg);
7261	arg = gfc_evaluate_now (arg, &se->pre);
7262
7263	/* Call the builtin twice. */
7264	call1 = build_call_expr_loc (input_location, func, 1,
7265	fold_convert (long_long_unsigned_type_node,
7266	arg));
7267
7268	arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7269	build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7270	call2 = build_call_expr_loc (input_location, func, 1,
7271	fold_convert (long_long_unsigned_type_node,
7272	arg2));
7273
7274	/* Combine the results. */
7275	if (parity)
7276	se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7277	integer_type_node, call1, call2);
7278	else
7279	se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7280	integer_type_node, call1, call2);
7281
7282	se->expr = convert (result_type, se->expr);
7283	return;
7284	}
7285
7286	/* Convert the actual argument twice: first, to the unsigned type of the
7287	same size; then, to the proper argument type for the built-in
7288	function. */
7289	arg = fold_convert (gfc_build_uint_type (argsize), arg);
7290	arg = fold_convert (arg_type, arg);
7291
7292	se->expr = fold_convert (result_type,
7293	build_call_expr_loc (input_location, func, 1, arg));
7294	}
7295
7296
7297	/* Process an intrinsic with unspecified argument-types that has an optional
7298	argument (which could be of type character), e.g. EOSHIFT. For those, we
7299	need to append the string length of the optional argument if it is not
7300	present and the type is really character.
7301	primary specifies the position (starting at 1) of the non-optional argument
7302	specifying the type and optional gives the position of the optional
7303	argument in the arglist. */
7304
7305	static void
7306	conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7307	unsigned primary, unsigned optional)
7308	{
7309	gfc_actual_arglist* prim_arg;
7310	gfc_actual_arglist* opt_arg;
7311	unsigned cur_pos;
7312	gfc_actual_arglist* arg;
7313	gfc_symbol* sym;
7314	vec<tree, va_gc> *append_args;
7315
7316	/* Find the two arguments given as position. */
7317	cur_pos = 0;
7318	prim_arg = NULL;
7319	opt_arg = NULL;
7320	for (arg = expr->value.function.actual; arg; arg = arg->next)
7321	{
7322	++cur_pos;
7323
7324	if (cur_pos == primary)
7325	prim_arg = arg;
7326	if (cur_pos == optional)
7327	opt_arg = arg;
7328
7329	if (cur_pos >= primary && cur_pos >= optional)
7330	break;
7331	}
7332	gcc_assert (prim_arg);
7333	gcc_assert (prim_arg->expr);
7334	gcc_assert (opt_arg);
7335
7336	/* If we do have type CHARACTER and the optional argument is really absent,
7337	append a dummy 0 as string length. */
7338	append_args = NULL;
7339	if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7340	{
7341	tree dummy;
7342
7343	dummy = build_int_cst (gfc_charlen_type_node, 0);
7344	vec_alloc (v&: append_args, nelems: 1);
7345	append_args->quick_push (obj: dummy);
7346	}
7347
7348	/* Build the call itself. */
7349	gcc_assert (!se->ignore_optional);
7350	sym = gfc_get_symbol_for_expr (expr, ignore_optional: false);
7351	gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7352	append_args);
7353	gfc_free_symbol (sym);
7354	}
7355
7356	/* The length of a character string. */
7357	static void
7358	gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7359	{
7360	tree len;
7361	tree type;
7362	tree decl;
7363	gfc_symbol *sym;
7364	gfc_se argse;
7365	gfc_expr *arg;
7366
7367	gcc_assert (!se->ss);
7368
7369	arg = expr->value.function.actual->expr;
7370
7371	type = gfc_typenode_for_spec (&expr->ts);
7372	switch (arg->expr_type)
7373	{
7374	case EXPR_CONSTANT:
7375	len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7376	break;
7377
7378	case EXPR_ARRAY:
7379	/* Obtain the string length from the function used by
7380	trans-array.cc(gfc_trans_array_constructor). */
7381	len = NULL_TREE;
7382	get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7383	break;
7384
7385	case EXPR_VARIABLE:
7386	if (arg->ref == NULL
7387	|| (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7388	{
7389	/* This doesn't catch all cases.
7390	See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7391	and the surrounding thread. */
7392	sym = arg->symtree->n.sym;
7393	decl = gfc_get_symbol_decl (sym);
7394	if (decl == current_function_decl && sym->attr.function
7395	&& (sym->result == sym))
7396	decl = gfc_get_fake_result_decl (sym, 0);
7397
7398	len = sym->ts.u.cl->backend_decl;
7399	gcc_assert (len);
7400	break;
7401	}
7402
7403	/* Fall through. */
7404
7405	default:
7406	gfc_init_se (&argse, se);
7407	if (arg->rank == 0)
7408	gfc_conv_expr (se: &argse, expr: arg);
7409	else
7410	gfc_conv_expr_descriptor (&argse, arg);
7411	gfc_add_block_to_block (&se->pre, &argse.pre);
7412	gfc_add_block_to_block (&se->post, &argse.post);
7413	len = argse.string_length;
7414	break;
7415	}
7416	se->expr = convert (type, len);
7417	}
7418
7419	/* The length of a character string not including trailing blanks. */
7420	static void
7421	gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7422	{
7423	int kind = expr->value.function.actual->expr->ts.kind;
7424	tree args[2], type, fndecl;
7425
7426	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7427	type = gfc_typenode_for_spec (&expr->ts);
7428
7429	if (kind == 1)
7430	fndecl = gfor_fndecl_string_len_trim;
7431	else if (kind == 4)
7432	fndecl = gfor_fndecl_string_len_trim_char4;
7433	else
7434	gcc_unreachable ();
7435
7436	se->expr = build_call_expr_loc (input_location,
7437	fndecl, 2, args[0], args[1]);
7438	se->expr = convert (type, se->expr);
7439	}
7440
7441
7442	/* Returns the starting position of a substring within a string. */
7443
7444	static void
7445	gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7446	tree function)
7447	{
7448	tree logical4_type_node = gfc_get_logical_type (4);
7449	tree type;
7450	tree fndecl;
7451	tree *args;
7452	unsigned int num_args;
7453
7454	args = XALLOCAVEC (tree, 5);
7455
7456	/* Get number of arguments; characters count double due to the
7457	string length argument. Kind= is not passed to the library
7458	and thus ignored. */
7459	if (expr->value.function.actual->next->next->expr == NULL)
7460	num_args = 4;
7461	else
7462	num_args = 5;
7463
7464	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
7465	type = gfc_typenode_for_spec (&expr->ts);
7466
7467	if (num_args == 4)
7468	args[4] = build_int_cst (logical4_type_node, 0);
7469	else
7470	args[4] = convert (logical4_type_node, args[4]);
7471
7472	fndecl = build_addr (function);
7473	se->expr = build_call_array_loc (input_location,
7474	TREE_TYPE (TREE_TYPE (function)), fndecl,
7475	5, args);
7476	se->expr = convert (type, se->expr);
7477
7478	}
7479
7480	/* The ascii value for a single character. */
7481	static void
7482	gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7483	{
7484	tree args[3], type, pchartype;
7485	int nargs;
7486
7487	nargs = gfc_intrinsic_argument_list_length (expr);
7488	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs);
7489	gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7490	pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7491	args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7492	type = gfc_typenode_for_spec (&expr->ts);
7493
7494	se->expr = build_fold_indirect_ref_loc (input_location,
7495	args[1]);
7496	se->expr = convert (type, se->expr);
7497	}
7498
7499
7500	/* Intrinsic ISNAN calls __builtin_isnan. */
7501
7502	static void
7503	gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7504	{
7505	tree arg;
7506
7507	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7508	se->expr = build_call_expr_loc (input_location,
7509	builtin_decl_explicit (fncode: BUILT_IN_ISNAN),
7510	1, arg);
7511	STRIP_TYPE_NOPS (se->expr);
7512	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7513	}
7514
7515
7516	/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7517	their argument against a constant integer value. */
7518
7519	static void
7520	gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7521	{
7522	tree arg;
7523
7524	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7525	se->expr = fold_build2_loc (input_location, EQ_EXPR,
7526	gfc_typenode_for_spec (&expr->ts),
7527	arg, build_int_cst (TREE_TYPE (arg), value));
7528	}
7529
7530
7531
7532	/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7533
7534	static void
7535	gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7536	{
7537	tree tsource;
7538	tree fsource;
7539	tree mask;
7540	tree type;
7541	tree len, len2;
7542	tree *args;
7543	unsigned int num_args;
7544
7545	num_args = gfc_intrinsic_argument_list_length (expr);
7546	args = XALLOCAVEC (tree, num_args);
7547
7548	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
7549	if (expr->ts.type != BT_CHARACTER)
7550	{
7551	tsource = args[0];
7552	fsource = args[1];
7553	mask = args[2];
7554	}
7555	else
7556	{
7557	/* We do the same as in the non-character case, but the argument
7558	list is different because of the string length arguments. We
7559	also have to set the string length for the result. */
7560	len = args[0];
7561	tsource = args[1];
7562	len2 = args[2];
7563	fsource = args[3];
7564	mask = args[4];
7565
7566	gfc_trans_same_strlen_check (intr_name: "MERGE intrinsic", where: &expr->where, a: len, b: len2,
7567	target: &se->pre);
7568	se->string_length = len;
7569	}
7570	tsource = gfc_evaluate_now (tsource, &se->pre);
7571	fsource = gfc_evaluate_now (fsource, &se->pre);
7572	mask = gfc_evaluate_now (mask, &se->pre);
7573	type = TREE_TYPE (tsource);
7574	se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7575	fold_convert (type, fsource));
7576	}
7577
7578
7579	/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7580
7581	static void
7582	gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7583	{
7584	tree args[3], mask, type;
7585
7586	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
7587	mask = gfc_evaluate_now (args[2], &se->pre);
7588
7589	type = TREE_TYPE (args[0]);
7590	gcc_assert (TREE_TYPE (args[1]) == type);
7591	gcc_assert (TREE_TYPE (mask) == type);
7592
7593	args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7594	args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7595	fold_build1_loc (input_location, BIT_NOT_EXPR,
7596	type, mask));
7597	se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7598	args[0], args[1]);
7599	}
7600
7601
7602	/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7603	MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7604
7605	static void
7606	gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7607	{
7608	tree arg, allones, type, utype, res, cond, bitsize;
7609	int i;
7610
7611	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7612	arg = gfc_evaluate_now (arg, &se->pre);
7613
7614	type = gfc_get_int_type (expr->ts.kind);
7615	utype = unsigned_type_for (type);
7616
7617	i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7618	bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7619
7620	allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7621	build_int_cst (utype, 0));
7622
7623	if (left)
7624	{
7625	/* Left-justified mask. */
7626	res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7627	bitsize, arg);
7628	res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7629	fold_convert (utype, res));
7630
7631	/* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7632	smaller than type width. */
7633	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7634	build_int_cst (TREE_TYPE (arg), 0));
7635	res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7636	build_int_cst (utype, 0), res);
7637	}
7638	else
7639	{
7640	/* Right-justified mask. */
7641	res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7642	fold_convert (utype, arg));
7643	res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7644
7645	/* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7646	strictly smaller than type width. */
7647	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7648	arg, bitsize);
7649	res = fold_build3_loc (input_location, COND_EXPR, utype,
7650	cond, allones, res);
7651	}
7652
7653	se->expr = fold_convert (type, res);
7654	}
7655
7656
7657	/* FRACTION (s) is translated into:
7658	isfinite (s) ? frexp (s, &dummy_int) : NaN */
7659	static void
7660	gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7661	{
7662	tree arg, type, tmp, res, frexp, cond;
7663
7664	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
7665
7666	type = gfc_typenode_for_spec (&expr->ts);
7667	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7668	arg = gfc_evaluate_now (arg, &se->pre);
7669
7670	cond = build_call_expr_loc (input_location,
7671	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
7672	1, arg);
7673
7674	tmp = gfc_create_var (integer_type_node, NULL);
7675	res = build_call_expr_loc (input_location, frexp, 2,
7676	fold_convert (type, arg),
7677	gfc_build_addr_expr (NULL_TREE, tmp));
7678	res = fold_convert (type, res);
7679
7680	se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7681	cond, res, gfc_build_nan (type, ""));
7682	}
7683
7684
7685	/* NEAREST (s, dir) is translated into
7686	tmp = copysign (HUGE_VAL, dir);
7687	return nextafter (s, tmp);
7688	*/
7689	static void
7690	gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7691	{
7692	tree args[2], type, tmp, nextafter, copysign, huge_val;
7693
7694	nextafter = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_NEXTAFTER, kind: expr->ts.kind);
7695	copysign = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_COPYSIGN, kind: expr->ts.kind);
7696
7697	type = gfc_typenode_for_spec (&expr->ts);
7698	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7699
7700	huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
7701	tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
7702	fold_convert (type, args[1]));
7703	se->expr = build_call_expr_loc (input_location, nextafter, 2,
7704	fold_convert (type, args[0]), tmp);
7705	se->expr = fold_convert (type, se->expr);
7706	}
7707
7708
7709	/* SPACING (s) is translated into
7710	int e;
7711	if (!isfinite (s))
7712	res = NaN;
7713	else if (s == 0)
7714	res = tiny;
7715	else
7716	{
7717	frexp (s, &e);
7718	e = e - prec;
7719	e = MAX_EXPR (e, emin);
7720	res = scalbn (1., e);
7721	}
7722	return res;
7723
7724	where prec is the precision of s, gfc_real_kinds[k].digits,
7725	emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7726	and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7727
7728	static void
7729	gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
7730	{
7731	tree arg, type, prec, emin, tiny, res, e;
7732	tree cond, nan, tmp, frexp, scalbn;
7733	int k;
7734	stmtblock_t block;
7735
7736	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7737	prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
7738	emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
7739	tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
7740
7741	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
7742	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
7743
7744	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7745	arg = gfc_evaluate_now (arg, &se->pre);
7746
7747	type = gfc_typenode_for_spec (&expr->ts);
7748	e = gfc_create_var (integer_type_node, NULL);
7749	res = gfc_create_var (type, NULL);
7750
7751
7752	/* Build the block for s /= 0. */
7753	gfc_start_block (&block);
7754	tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7755	gfc_build_addr_expr (NULL_TREE, e));
7756	gfc_add_expr_to_block (&block, tmp);
7757
7758	tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
7759	prec);
7760	gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
7761	integer_type_node, tmp, emin));
7762
7763	tmp = build_call_expr_loc (input_location, scalbn, 2,
7764	build_real_from_int_cst (type, integer_one_node), e);
7765	gfc_add_modify (&block, res, tmp);
7766
7767	/* Finish by building the IF statement for value zero. */
7768	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7769	build_real_from_int_cst (type, integer_zero_node));
7770	tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
7771	gfc_finish_block (&block));
7772
7773	/* And deal with infinities and NaNs. */
7774	cond = build_call_expr_loc (input_location,
7775	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
7776	1, arg);
7777	nan = gfc_build_nan (type, "");
7778	tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
7779
7780	gfc_add_expr_to_block (&se->pre, tmp);
7781	se->expr = res;
7782	}
7783
7784
7785	/* RRSPACING (s) is translated into
7786	int e;
7787	real x;
7788	x = fabs (s);
7789	if (isfinite (x))
7790	{
7791	if (x != 0)
7792	{
7793	frexp (s, &e);
7794	x = scalbn (x, precision - e);
7795	}
7796	}
7797	else
7798	x = NaN;
7799	return x;
7800
7801	where precision is gfc_real_kinds[k].digits. */
7802
7803	static void
7804	gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
7805	{
7806	tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
7807	int prec, k;
7808	stmtblock_t block;
7809
7810	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7811	prec = gfc_real_kinds[k].digits;
7812
7813	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
7814	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
7815	fabs = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FABS, kind: expr->ts.kind);
7816
7817	type = gfc_typenode_for_spec (&expr->ts);
7818	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
7819	arg = gfc_evaluate_now (arg, &se->pre);
7820
7821	e = gfc_create_var (integer_type_node, NULL);
7822	x = gfc_create_var (type, NULL);
7823	gfc_add_modify (&se->pre, x,
7824	build_call_expr_loc (input_location, fabs, 1, arg));
7825
7826
7827	gfc_start_block (&block);
7828	tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7829	gfc_build_addr_expr (NULL_TREE, e));
7830	gfc_add_expr_to_block (&block, tmp);
7831
7832	tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
7833	build_int_cst (integer_type_node, prec), e);
7834	tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
7835	gfc_add_modify (&block, x, tmp);
7836	stmt = gfc_finish_block (&block);
7837
7838	/* if (x != 0) */
7839	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
7840	build_real_from_int_cst (type, integer_zero_node));
7841	tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
7842
7843	/* And deal with infinities and NaNs. */
7844	cond = build_call_expr_loc (input_location,
7845	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
7846	1, x);
7847	nan = gfc_build_nan (type, "");
7848	tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
7849
7850	gfc_add_expr_to_block (&se->pre, tmp);
7851	se->expr = fold_convert (type, x);
7852	}
7853
7854
7855	/* SCALE (s, i) is translated into scalbn (s, i). */
7856	static void
7857	gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
7858	{
7859	tree args[2], type, scalbn;
7860
7861	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
7862
7863	type = gfc_typenode_for_spec (&expr->ts);
7864	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7865	se->expr = build_call_expr_loc (input_location, scalbn, 2,
7866	fold_convert (type, args[0]),
7867	fold_convert (integer_type_node, args[1]));
7868	se->expr = fold_convert (type, se->expr);
7869	}
7870
7871
7872	/* SET_EXPONENT (s, i) is translated into
7873	isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7874	static void
7875	gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
7876	{
7877	tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
7878
7879	frexp = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FREXP, kind: expr->ts.kind);
7880	scalbn = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_SCALBN, kind: expr->ts.kind);
7881
7882	type = gfc_typenode_for_spec (&expr->ts);
7883	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
7884	args[0] = gfc_evaluate_now (args[0], &se->pre);
7885
7886	tmp = gfc_create_var (integer_type_node, NULL);
7887	tmp = build_call_expr_loc (input_location, frexp, 2,
7888	fold_convert (type, args[0]),
7889	gfc_build_addr_expr (NULL_TREE, tmp));
7890	res = build_call_expr_loc (input_location, scalbn, 2, tmp,
7891	fold_convert (integer_type_node, args[1]));
7892	res = fold_convert (type, res);
7893
7894	/* Call to isfinite */
7895	cond = build_call_expr_loc (input_location,
7896	builtin_decl_explicit (fncode: BUILT_IN_ISFINITE),
7897	1, args[0]);
7898	nan = gfc_build_nan (type, "");
7899
7900	se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7901	res, nan);
7902	}
7903
7904
7905	static void
7906	gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
7907	{
7908	gfc_actual_arglist *actual;
7909	tree arg1;
7910	tree type;
7911	tree size;
7912	gfc_se argse;
7913	gfc_expr *e;
7914	gfc_symbol *sym = NULL;
7915
7916	gfc_init_se (&argse, NULL);
7917	actual = expr->value.function.actual;
7918
7919	if (actual->expr->ts.type == BT_CLASS)
7920	gfc_add_class_array_ref (actual->expr);
7921
7922	e = actual->expr;
7923
7924	/* These are emerging from the interface mapping, when a class valued
7925	function appears as the rhs in a realloc on assign statement, where
7926	the size of the result is that of one of the actual arguments. */
7927	if (e->expr_type == EXPR_VARIABLE
7928	&& e->symtree->n.sym->ns == NULL /* This is distinctive! */
7929	&& e->symtree->n.sym->ts.type == BT_CLASS
7930	&& e->ref && e->ref->type == REF_COMPONENT
7931	&& strcmp (s1: e->ref->u.c.component->name, s2: "_data") == 0)
7932	sym = e->symtree->n.sym;
7933
7934	if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
7935	&& e
7936	&& (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
7937	{
7938	symbol_attribute attr;
7939	char *msg;
7940	tree temp;
7941	tree cond;
7942
7943	if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
7944	{
7945	attr = CLASS_DATA (e->symtree->n.sym)->attr;
7946	attr.pointer = attr.class_pointer;
7947	}
7948	else
7949	attr = gfc_expr_attr (e);
7950
7951	if (attr.allocatable)
7952	msg = xasprintf ("Allocatable argument '%s' is not allocated",
7953	e->symtree->n.sym->name);
7954	else if (attr.pointer)
7955	msg = xasprintf ("Pointer argument '%s' is not associated",
7956	e->symtree->n.sym->name);
7957	else
7958	goto end_arg_check;
7959
7960	if (sym)
7961	{
7962	temp = gfc_class_data_get (sym->backend_decl);
7963	temp = gfc_conv_descriptor_data_get (temp);
7964	}
7965	else
7966	{
7967	argse.descriptor_only = 1;
7968	gfc_conv_expr_descriptor (&argse, actual->expr);
7969	temp = gfc_conv_descriptor_data_get (argse.expr);
7970	}
7971
7972	cond = fold_build2_loc (input_location, EQ_EXPR,
7973	logical_type_node, temp,
7974	fold_convert (TREE_TYPE (temp),
7975	null_pointer_node));
7976	gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
7977
7978	free (ptr: msg);
7979	}
7980	end_arg_check:
7981
7982	argse.data_not_needed = 1;
7983	if (gfc_is_class_array_function (e))
7984	{
7985	/* For functions that return a class array conv_expr_descriptor is not
7986	able to get the descriptor right. Therefore this special case. */
7987	gfc_conv_expr_reference (se: &argse, expr: e);
7988	argse.expr = gfc_class_data_get (argse.expr);
7989	}
7990	else if (sym && sym->backend_decl)
7991	{
7992	gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
7993	argse.expr = gfc_class_data_get (sym->backend_decl);
7994	}
7995	else
7996	gfc_conv_expr_descriptor (&argse, actual->expr);
7997	gfc_add_block_to_block (&se->pre, &argse.pre);
7998	gfc_add_block_to_block (&se->post, &argse.post);
7999	arg1 = argse.expr;
8000
8001	actual = actual->next;
8002	if (actual->expr)
8003	{
8004	stmtblock_t block;
8005	gfc_init_block (&block);
8006	gfc_init_se (&argse, NULL);
8007	gfc_conv_expr_type (se: &argse, actual->expr,
8008	gfc_array_index_type);
8009	gfc_add_block_to_block (&block, &argse.pre);
8010	tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8011	argse.expr, gfc_index_one_node);
8012	size = gfc_tree_array_size (&block, arg1, e, tmp);
8013
8014	/* Unusually, for an intrinsic, size does not exclude
8015	an optional arg2, so we must test for it. */
8016	if (actual->expr->expr_type == EXPR_VARIABLE
8017	&& actual->expr->symtree->n.sym->attr.dummy
8018	&& actual->expr->symtree->n.sym->attr.optional)
8019	{
8020	tree cond;
8021	stmtblock_t block2;
8022	gfc_init_block (&block2);
8023	gfc_init_se (&argse, NULL);
8024	argse.want_pointer = 1;
8025	argse.data_not_needed = 1;
8026	gfc_conv_expr (se: &argse, expr: actual->expr);
8027	gfc_add_block_to_block (&se->pre, &argse.pre);
8028	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8029	argse.expr, null_pointer_node);
8030	cond = gfc_evaluate_now (cond, &se->pre);
8031	/* 'block2' contains the arg2 absent case, 'block' the arg2 present
8032	case; size_var can be used in both blocks. */
8033	tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8034	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8035	TREE_TYPE (size_var), size_var, size);
8036	gfc_add_expr_to_block (&block, tmp);
8037	size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8038	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8039	TREE_TYPE (size_var), size_var, size);
8040	gfc_add_expr_to_block (&block2, tmp);
8041	tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8042	gfc_finish_block (&block2));
8043	gfc_add_expr_to_block (&se->pre, tmp);
8044	size = size_var;
8045	}
8046	else
8047	gfc_add_block_to_block (&se->pre, &block);
8048	}
8049	else
8050	size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8051	type = gfc_typenode_for_spec (&expr->ts);
8052	se->expr = convert (type, size);
8053	}
8054
8055
8056	/* Helper function to compute the size of a character variable,
8057	excluding the terminating null characters. The result has
8058	gfc_array_index_type type. */
8059
8060	tree
8061	size_of_string_in_bytes (int kind, tree string_length)
8062	{
8063	tree bytesize;
8064	int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8065
8066	bytesize = build_int_cst (gfc_array_index_type,
8067	gfc_character_kinds[i].bit_size / 8);
8068
8069	return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8070	bytesize,
8071	fold_convert (gfc_array_index_type, string_length));
8072	}
8073
8074
8075	static void
8076	gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8077	{
8078	gfc_expr *arg;
8079	gfc_se argse;
8080	tree source_bytes;
8081	tree tmp;
8082	tree lower;
8083	tree upper;
8084	tree byte_size;
8085	tree field;
8086	int n;
8087
8088	gfc_init_se (&argse, NULL);
8089	arg = expr->value.function.actual->expr;
8090
8091	if (arg->rank || arg->ts.type == BT_ASSUMED)
8092	gfc_conv_expr_descriptor (&argse, arg);
8093	else
8094	gfc_conv_expr_reference (se: &argse, expr: arg);
8095
8096	if (arg->ts.type == BT_ASSUMED)
8097	{
8098	/* This only works if an array descriptor has been passed; thus, extract
8099	the size from the descriptor. */
8100	gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8101	== TYPE_PRECISION (size_type_node));
8102	tmp = arg->symtree->n.sym->backend_decl;
8103	tmp = DECL_LANG_SPECIFIC (tmp)
8104	&& GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8105	? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8106	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8107	tmp = build_fold_indirect_ref_loc (input_location, tmp);
8108
8109	tmp = gfc_conv_descriptor_dtype (tmp);
8110	field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8111	GFC_DTYPE_ELEM_LEN);
8112	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8113	tmp, field, NULL_TREE);
8114
8115	byte_size = fold_convert (gfc_array_index_type, tmp);
8116	}
8117	else if (arg->ts.type == BT_CLASS)
8118	{
8119	/* Conv_expr_descriptor returns a component_ref to _data component of the
8120	class object. The class object may be a non-pointer object, e.g.
8121	located on the stack, or a memory location pointed to, e.g. a
8122	parameter, i.e., an indirect_ref. */
8123	if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8124	&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8125	byte_size
8126	= gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8127	else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8128	byte_size = gfc_class_vtab_size_get (argse.expr);
8129	else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8130	&& TREE_CODE (argse.expr) == COMPONENT_REF)
8131	byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8132	else if (arg->rank > 0
8133	|| (arg->rank == 0
8134	&& arg->ref && arg->ref->type == REF_COMPONENT))
8135	/* The scalarizer added an additional temp. To get the class' vptr
8136	one has to look at the original backend_decl. */
8137	byte_size = gfc_class_vtab_size_get (
8138	GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8139	else
8140	gcc_unreachable ();
8141	}
8142	else
8143	{
8144	if (arg->ts.type == BT_CHARACTER)
8145	byte_size = size_of_string_in_bytes (kind: arg->ts.kind, string_length: argse.string_length);
8146	else
8147	{
8148	if (arg->rank == 0)
8149	byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8150	argse.expr));
8151	else
8152	byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8153	byte_size = fold_convert (gfc_array_index_type,
8154	size_in_bytes (byte_size));
8155	}
8156	}
8157
8158	if (arg->rank == 0)
8159	se->expr = byte_size;
8160	else
8161	{
8162	source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8163	gfc_add_modify (&argse.pre, source_bytes, byte_size);
8164
8165	if (arg->rank == -1)
8166	{
8167	tree cond, loop_var, exit_label;
8168	stmtblock_t body;
8169
8170	tmp = fold_convert (gfc_array_index_type,
8171	gfc_conv_descriptor_rank (argse.expr));
8172	loop_var = gfc_create_var (gfc_array_index_type, "i");
8173	gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8174	exit_label = gfc_build_label_decl (NULL_TREE);
8175
8176	/* Create loop:
8177	for (;;)
8178	{
8179	if (i >= rank)
8180	goto exit;
8181	source_bytes = source_bytes * array.dim[i].extent;
8182	i = i + 1;
8183	}
8184	exit: */
8185	gfc_start_block (&body);
8186	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8187	loop_var, tmp);
8188	tmp = build1_v (GOTO_EXPR, exit_label);
8189	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8190	cond, tmp, build_empty_stmt (input_location));
8191	gfc_add_expr_to_block (&body, tmp);
8192
8193	lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8194	upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8195	tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8196	tmp = fold_build2_loc (input_location, MULT_EXPR,
8197	gfc_array_index_type, tmp, source_bytes);
8198	gfc_add_modify (&body, source_bytes, tmp);
8199
8200	tmp = fold_build2_loc (input_location, PLUS_EXPR,
8201	gfc_array_index_type, loop_var,
8202	gfc_index_one_node);
8203	gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8204
8205	tmp = gfc_finish_block (&body);
8206
8207	tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8208	tmp);
8209	gfc_add_expr_to_block (&argse.pre, tmp);
8210
8211	tmp = build1_v (LABEL_EXPR, exit_label);
8212	gfc_add_expr_to_block (&argse.pre, tmp);
8213	}
8214	else
8215	{
8216	/* Obtain the size of the array in bytes. */
8217	for (n = 0; n < arg->rank; n++)
8218	{
8219	tree idx;
8220	idx = gfc_rank_cst[n];
8221	lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8222	upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8223	tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8224	tmp = fold_build2_loc (input_location, MULT_EXPR,
8225	gfc_array_index_type, tmp, source_bytes);
8226	gfc_add_modify (&argse.pre, source_bytes, tmp);
8227	}
8228	}
8229	se->expr = source_bytes;
8230	}
8231
8232	gfc_add_block_to_block (&se->pre, &argse.pre);
8233	}
8234
8235
8236	static void
8237	gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8238	{
8239	gfc_expr *arg;
8240	gfc_se argse;
8241	tree type, result_type, tmp;
8242
8243	arg = expr->value.function.actual->expr;
8244
8245	gfc_init_se (&argse, NULL);
8246	result_type = gfc_get_int_type (expr->ts.kind);
8247
8248	if (arg->rank == 0)
8249	{
8250	if (arg->ts.type == BT_CLASS)
8251	{
8252	gfc_add_vptr_component (arg);
8253	gfc_add_size_component (arg);
8254	gfc_conv_expr (se: &argse, expr: arg);
8255	tmp = fold_convert (result_type, argse.expr);
8256	goto done;
8257	}
8258
8259	gfc_conv_expr_reference (se: &argse, expr: arg);
8260	type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8261	argse.expr));
8262	}
8263	else
8264	{
8265	argse.want_pointer = 0;
8266	gfc_conv_expr_descriptor (&argse, arg);
8267	if (arg->ts.type == BT_CLASS)
8268	{
8269	if (arg->rank > 0)
8270	tmp = gfc_class_vtab_size_get (
8271	GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8272	else
8273	tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8274	tmp = fold_convert (result_type, tmp);
8275	goto done;
8276	}
8277	type = gfc_get_element_type (TREE_TYPE (argse.expr));
8278	}
8279
8280	/* Obtain the argument's word length. */
8281	if (arg->ts.type == BT_CHARACTER)
8282	tmp = size_of_string_in_bytes (kind: arg->ts.kind, string_length: argse.string_length);
8283	else
8284	tmp = size_in_bytes (t: type);
8285	tmp = fold_convert (result_type, tmp);
8286
8287	done:
8288	se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8289	build_int_cst (result_type, BITS_PER_UNIT));
8290	gfc_add_block_to_block (&se->pre, &argse.pre);
8291	}
8292
8293
8294	/* Intrinsic string comparison functions. */
8295
8296	static void
8297	gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8298	{
8299	tree args[4];
8300
8301	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 4);
8302
8303	se->expr
8304	= gfc_build_compare_string (args[0], args[1], args[2], args[3],
8305	expr->value.function.actual->expr->ts.kind,
8306	op);
8307	se->expr = fold_build2_loc (input_location, op,
8308	gfc_typenode_for_spec (&expr->ts), se->expr,
8309	build_int_cst (TREE_TYPE (se->expr), 0));
8310	}
8311
8312	/* Generate a call to the adjustl/adjustr library function. */
8313	static void
8314	gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8315	{
8316	tree args[3];
8317	tree len;
8318	tree type;
8319	tree var;
8320	tree tmp;
8321
8322	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[1], nargs: 2);
8323	len = args[1];
8324
8325	type = TREE_TYPE (args[2]);
8326	var = gfc_conv_string_tmp (se, type, len);
8327	args[0] = var;
8328
8329	tmp = build_call_expr_loc (input_location,
8330	fndecl, 3, args[0], args[1], args[2]);
8331	gfc_add_expr_to_block (&se->pre, tmp);
8332	se->expr = var;
8333	se->string_length = len;
8334	}
8335
8336
8337	/* Generate code for the TRANSFER intrinsic:
8338	For scalar results:
8339	DEST = TRANSFER (SOURCE, MOLD)
8340	where:
8341	typeof<DEST> = typeof<MOLD>
8342	and:
8343	MOLD is scalar.
8344
8345	For array results:
8346	DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8347	where:
8348	typeof<DEST> = typeof<MOLD>
8349	and:
8350	N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8351	sizeof (DEST(0) * SIZE). */
8352	static void
8353	gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8354	{
8355	tree tmp;
8356	tree tmpdecl;
8357	tree ptr;
8358	tree extent;
8359	tree source;
8360	tree source_type;
8361	tree source_bytes;
8362	tree mold_type;
8363	tree dest_word_len;
8364	tree size_words;
8365	tree size_bytes;
8366	tree upper;
8367	tree lower;
8368	tree stmt;
8369	tree class_ref = NULL_TREE;
8370	gfc_actual_arglist *arg;
8371	gfc_se argse;
8372	gfc_array_info *info;
8373	stmtblock_t block;
8374	int n;
8375	bool scalar_mold;
8376	gfc_expr *source_expr, *mold_expr, *class_expr;
8377
8378	info = NULL;
8379	if (se->loop)
8380	info = &se->ss->info->data.array;
8381
8382	/* Convert SOURCE. The output from this stage is:-
8383	source_bytes = length of the source in bytes
8384	source = pointer to the source data. */
8385	arg = expr->value.function.actual;
8386	source_expr = arg->expr;
8387
8388	/* Ensure double transfer through LOGICAL preserves all
8389	the needed bits. */
8390	if (arg->expr->expr_type == EXPR_FUNCTION
8391	&& arg->expr->value.function.esym == NULL
8392	&& arg->expr->value.function.isym != NULL
8393	&& arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8394	&& arg->expr->ts.type == BT_LOGICAL
8395	&& expr->ts.type != arg->expr->ts.type)
8396	arg->expr->value.function.name = "__transfer_in_transfer";
8397
8398	gfc_init_se (&argse, NULL);
8399
8400	source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8401
8402	/* Obtain the pointer to source and the length of source in bytes. */
8403	if (arg->expr->rank == 0)
8404	{
8405	gfc_conv_expr_reference (se: &argse, expr: arg->expr);
8406	if (arg->expr->ts.type == BT_CLASS)
8407	{
8408	tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8409	if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8410	source = gfc_class_data_get (tmp);
8411	else
8412	{
8413	/* Array elements are evaluated as a reference to the data.
8414	To obtain the vptr for the element size, the argument
8415	expression must be stripped to the class reference and
8416	re-evaluated. The pre and post blocks are not needed. */
8417	gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8418	source = argse.expr;
8419	class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8420	gfc_init_se (&argse, NULL);
8421	gfc_conv_expr (se: &argse, expr: class_expr);
8422	class_ref = argse.expr;
8423	}
8424	}
8425	else
8426	source = argse.expr;
8427
8428	/* Obtain the source word length. */
8429	switch (arg->expr->ts.type)
8430	{
8431	case BT_CHARACTER:
8432	tmp = size_of_string_in_bytes (kind: arg->expr->ts.kind,
8433	string_length: argse.string_length);
8434	break;
8435	case BT_CLASS:
8436	if (class_ref != NULL_TREE)
8437	tmp = gfc_class_vtab_size_get (class_ref);
8438	else
8439	tmp = gfc_class_vtab_size_get (argse.expr);
8440	break;
8441	default:
8442	source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8443	source));
8444	tmp = fold_convert (gfc_array_index_type,
8445	size_in_bytes (source_type));
8446	break;
8447	}
8448	}
8449	else
8450	{
8451	argse.want_pointer = 0;
8452	gfc_conv_expr_descriptor (&argse, arg->expr);
8453	source = gfc_conv_descriptor_data_get (argse.expr);
8454	source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8455
8456	/* Repack the source if not simply contiguous. */
8457	if (!gfc_is_simply_contiguous (arg->expr, false, true))
8458	{
8459	tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8460
8461	if (warn_array_temporaries)
8462	gfc_warning (opt: OPT_Warray_temporaries,
8463	"Creating array temporary at %L", &expr->where);
8464
8465	source = build_call_expr_loc (input_location,
8466	gfor_fndecl_in_pack, 1, tmp);
8467	source = gfc_evaluate_now (source, &argse.pre);
8468
8469	/* Free the temporary. */
8470	gfc_start_block (&block);
8471	tmp = gfc_call_free (source);
8472	gfc_add_expr_to_block (&block, tmp);
8473	stmt = gfc_finish_block (&block);
8474
8475	/* Clean up if it was repacked. */
8476	gfc_init_block (&block);
8477	tmp = gfc_conv_array_data (argse.expr);
8478	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8479	source, tmp);
8480	tmp = build3_v (COND_EXPR, tmp, stmt,
8481	build_empty_stmt (input_location));
8482	gfc_add_expr_to_block (&block, tmp);
8483	gfc_add_block_to_block (&block, &se->post);
8484	gfc_init_block (&se->post);
8485	gfc_add_block_to_block (&se->post, &block);
8486	}
8487
8488	/* Obtain the source word length. */
8489	if (arg->expr->ts.type == BT_CHARACTER)
8490	tmp = size_of_string_in_bytes (kind: arg->expr->ts.kind,
8491	string_length: argse.string_length);
8492	else
8493	tmp = fold_convert (gfc_array_index_type,
8494	size_in_bytes (source_type));
8495
8496	/* Obtain the size of the array in bytes. */
8497	extent = gfc_create_var (gfc_array_index_type, NULL);
8498	for (n = 0; n < arg->expr->rank; n++)
8499	{
8500	tree idx;
8501	idx = gfc_rank_cst[n];
8502	gfc_add_modify (&argse.pre, source_bytes, tmp);
8503	lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8504	upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8505	tmp = fold_build2_loc (input_location, MINUS_EXPR,
8506	gfc_array_index_type, upper, lower);
8507	gfc_add_modify (&argse.pre, extent, tmp);
8508	tmp = fold_build2_loc (input_location, PLUS_EXPR,
8509	gfc_array_index_type, extent,
8510	gfc_index_one_node);
8511	tmp = fold_build2_loc (input_location, MULT_EXPR,
8512	gfc_array_index_type, tmp, source_bytes);
8513	}
8514	}
8515
8516	gfc_add_modify (&argse.pre, source_bytes, tmp);
8517	gfc_add_block_to_block (&se->pre, &argse.pre);
8518	gfc_add_block_to_block (&se->post, &argse.post);
8519
8520	/* Now convert MOLD. The outputs are:
8521	mold_type = the TREE type of MOLD
8522	dest_word_len = destination word length in bytes. */
8523	arg = arg->next;
8524	mold_expr = arg->expr;
8525
8526	gfc_init_se (&argse, NULL);
8527
8528	scalar_mold = arg->expr->rank == 0;
8529
8530	if (arg->expr->rank == 0)
8531	{
8532	gfc_conv_expr_reference (se: &argse, expr: arg->expr);
8533	mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8534	argse.expr));
8535	}
8536	else
8537	{
8538	gfc_init_se (&argse, NULL);
8539	argse.want_pointer = 0;
8540	gfc_conv_expr_descriptor (&argse, arg->expr);
8541	mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8542	}
8543
8544	gfc_add_block_to_block (&se->pre, &argse.pre);
8545	gfc_add_block_to_block (&se->post, &argse.post);
8546
8547	if (strcmp (s1: expr->value.function.name, s2: "__transfer_in_transfer") == 0)
8548	{
8549	/* If this TRANSFER is nested in another TRANSFER, use a type
8550	that preserves all bits. */
8551	if (arg->expr->ts.type == BT_LOGICAL)
8552	mold_type = gfc_get_int_type (arg->expr->ts.kind);
8553	}
8554
8555	/* Obtain the destination word length. */
8556	switch (arg->expr->ts.type)
8557	{
8558	case BT_CHARACTER:
8559	tmp = size_of_string_in_bytes (kind: arg->expr->ts.kind, string_length: argse.string_length);
8560	mold_type = gfc_get_character_type_len (arg->expr->ts.kind,
8561	argse.string_length);
8562	break;
8563	case BT_CLASS:
8564	tmp = gfc_class_vtab_size_get (argse.expr);
8565	break;
8566	default:
8567	tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8568	break;
8569	}
8570	dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8571	gfc_add_modify (&se->pre, dest_word_len, tmp);
8572
8573	/* Finally convert SIZE, if it is present. */
8574	arg = arg->next;
8575	size_words = gfc_create_var (gfc_array_index_type, NULL);
8576
8577	if (arg->expr)
8578	{
8579	gfc_init_se (&argse, NULL);
8580	gfc_conv_expr_reference (se: &argse, expr: arg->expr);
8581	tmp = convert (gfc_array_index_type,
8582	build_fold_indirect_ref_loc (input_location,
8583	argse.expr));
8584	gfc_add_block_to_block (&se->pre, &argse.pre);
8585	gfc_add_block_to_block (&se->post, &argse.post);
8586	}
8587	else
8588	tmp = NULL_TREE;
8589
8590	/* Separate array and scalar results. */
8591	if (scalar_mold && tmp == NULL_TREE)
8592	goto scalar_transfer;
8593
8594	size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8595	if (tmp != NULL_TREE)
8596	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8597	tmp, dest_word_len);
8598	else
8599	tmp = source_bytes;
8600
8601	gfc_add_modify (&se->pre, size_bytes, tmp);
8602	gfc_add_modify (&se->pre, size_words,
8603	fold_build2_loc (input_location, CEIL_DIV_EXPR,
8604	gfc_array_index_type,
8605	size_bytes, dest_word_len));
8606
8607	/* Evaluate the bounds of the result. If the loop range exists, we have
8608	to check if it is too large. If so, we modify loop->to be consistent
8609	with min(size, size(source)). Otherwise, size is made consistent with
8610	the loop range, so that the right number of bytes is transferred.*/
8611	n = se->loop->order[0];
8612	if (se->loop->to[n] != NULL_TREE)
8613	{
8614	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8615	se->loop->to[n], se->loop->from[n]);
8616	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8617	tmp, gfc_index_one_node);
8618	tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8619	tmp, size_words);
8620	gfc_add_modify (&se->pre, size_words, tmp);
8621	gfc_add_modify (&se->pre, size_bytes,
8622	fold_build2_loc (input_location, MULT_EXPR,
8623	gfc_array_index_type,
8624	size_words, dest_word_len));
8625	upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8626	size_words, se->loop->from[n]);
8627	upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8628	upper, gfc_index_one_node);
8629	}
8630	else
8631	{
8632	upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8633	size_words, gfc_index_one_node);
8634	se->loop->from[n] = gfc_index_zero_node;
8635	}
8636
8637	se->loop->to[n] = upper;
8638
8639	/* Build a destination descriptor, using the pointer, source, as the
8640	data field. */
8641	gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
8642	NULL_TREE, false, true, false, &expr->where);
8643
8644	/* Cast the pointer to the result. */
8645	tmp = gfc_conv_descriptor_data_get (info->descriptor);
8646	tmp = fold_convert (pvoid_type_node, tmp);
8647
8648	/* Use memcpy to do the transfer. */
8649	tmp
8650	= build_call_expr_loc (input_location,
8651	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3, tmp,
8652	fold_convert (pvoid_type_node, source),
8653	fold_convert (size_type_node,
8654	fold_build2_loc (input_location,
8655	MIN_EXPR,
8656	gfc_array_index_type,
8657	size_bytes,
8658	source_bytes)));
8659	gfc_add_expr_to_block (&se->pre, tmp);
8660
8661	se->expr = info->descriptor;
8662	if (expr->ts.type == BT_CHARACTER)
8663	{
8664	tmp = fold_convert (gfc_charlen_type_node,
8665	TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
8666	se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
8667	gfc_charlen_type_node,
8668	dest_word_len, tmp);
8669	}
8670
8671	return;
8672
8673	/* Deal with scalar results. */
8674	scalar_transfer:
8675	extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8676	dest_word_len, source_bytes);
8677	extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8678	extent, gfc_index_zero_node);
8679
8680	if (expr->ts.type == BT_CHARACTER)
8681	{
8682	tree direct, indirect, free;
8683
8684	ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
8685	tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
8686	"transfer");
8687
8688	/* If source is longer than the destination, use a pointer to
8689	the source directly. */
8690	gfc_init_block (&block);
8691	gfc_add_modify (&block, tmpdecl, ptr);
8692	direct = gfc_finish_block (&block);
8693
8694	/* Otherwise, allocate a string with the length of the destination
8695	and copy the source into it. */
8696	gfc_init_block (&block);
8697	tmp = gfc_get_pchar_type (expr->ts.kind);
8698	tmp = gfc_call_malloc (&block, tmp, dest_word_len);
8699	gfc_add_modify (&block, tmpdecl,
8700	fold_convert (TREE_TYPE (ptr), tmp));
8701	tmp = build_call_expr_loc (input_location,
8702	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3,
8703	fold_convert (pvoid_type_node, tmpdecl),
8704	fold_convert (pvoid_type_node, ptr),
8705	fold_convert (size_type_node, extent));
8706	gfc_add_expr_to_block (&block, tmp);
8707	indirect = gfc_finish_block (&block);
8708
8709	/* Wrap it up with the condition. */
8710	tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
8711	dest_word_len, source_bytes);
8712	tmp = build3_v (COND_EXPR, tmp, direct, indirect);
8713	gfc_add_expr_to_block (&se->pre, tmp);
8714
8715	/* Free the temporary string, if necessary. */
8716	free = gfc_call_free (tmpdecl);
8717	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8718	dest_word_len, source_bytes);
8719	tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
8720	gfc_add_expr_to_block (&se->post, tmp);
8721
8722	se->expr = tmpdecl;
8723	tmp = fold_convert (gfc_charlen_type_node,
8724	TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
8725	se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
8726	gfc_charlen_type_node,
8727	dest_word_len, tmp);
8728	}
8729	else
8730	{
8731	tmpdecl = gfc_create_var (mold_type, "transfer");
8732
8733	ptr = convert (build_pointer_type (mold_type), source);
8734
8735	/* For CLASS results, allocate the needed memory first. */
8736	if (mold_expr->ts.type == BT_CLASS)
8737	{
8738	tree cdata;
8739	cdata = gfc_class_data_get (tmpdecl);
8740	tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
8741	gfc_add_modify (&se->pre, cdata, tmp);
8742	}
8743
8744	/* Use memcpy to do the transfer. */
8745	if (mold_expr->ts.type == BT_CLASS)
8746	tmp = gfc_class_data_get (tmpdecl);
8747	else
8748	tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
8749
8750	tmp = build_call_expr_loc (input_location,
8751	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3,
8752	fold_convert (pvoid_type_node, tmp),
8753	fold_convert (pvoid_type_node, ptr),
8754	fold_convert (size_type_node, extent));
8755	gfc_add_expr_to_block (&se->pre, tmp);
8756
8757	/* For CLASS results, set the _vptr. */
8758	if (mold_expr->ts.type == BT_CLASS)
8759	{
8760	tree vptr;
8761	gfc_symbol *vtab;
8762	vptr = gfc_class_vptr_get (tmpdecl);
8763	vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
8764	gcc_assert (vtab);
8765	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
8766	gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
8767	}
8768
8769	se->expr = tmpdecl;
8770	}
8771	}
8772
8773
8774	/* Generate a call to caf_is_present. */
8775
8776	static tree
8777	trans_caf_is_present (gfc_se *se, gfc_expr *expr)
8778	{
8779	tree caf_reference, caf_decl, token, image_index;
8780
8781	/* Compile the reference chain. */
8782	caf_reference = conv_expr_ref_to_caf_ref (block: &se->pre, expr);
8783	gcc_assert (caf_reference != NULL_TREE);
8784
8785	caf_decl = gfc_get_tree_for_caf_expr (expr);
8786	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
8787	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
8788	image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
8789	gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
8790	expr);
8791
8792	return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
8793	3, token, image_index, caf_reference);
8794	}
8795
8796
8797	/* Test whether this ref-chain refs this image only. */
8798
8799	static bool
8800	caf_this_image_ref (gfc_ref *ref)
8801	{
8802	for ( ; ref; ref = ref->next)
8803	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
8804	return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
8805
8806	return false;
8807	}
8808
8809
8810	/* Generate code for the ALLOCATED intrinsic.
8811	Generate inline code that directly check the address of the argument. */
8812
8813	static void
8814	gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
8815	{
8816	gfc_se arg1se;
8817	tree tmp;
8818	bool coindexed_caf_comp = false;
8819	gfc_expr *e = expr->value.function.actual->expr;
8820
8821	gfc_init_se (&arg1se, NULL);
8822	if (e->ts.type == BT_CLASS)
8823	{
8824	/* Make sure that class array expressions have both a _data
8825	component reference and an array reference.... */
8826	if (CLASS_DATA (e)->attr.dimension)
8827	gfc_add_class_array_ref (e);
8828	/* .... whilst scalars only need the _data component. */
8829	else
8830	gfc_add_data_component (e);
8831	}
8832
8833	/* When 'e' references an allocatable component in a coarray, then call
8834	the caf-library function caf_is_present (). */
8835	if (flag_coarray == GFC_FCOARRAY_LIB && e->expr_type == EXPR_FUNCTION
8836	&& e->value.function.isym
8837	&& e->value.function.isym->id == GFC_ISYM_CAF_GET)
8838	{
8839	e = e->value.function.actual->expr;
8840	if (gfc_expr_attr (e).codimension)
8841	{
8842	/* Last partref is the coindexed coarray. As coarrays are collectively
8843	(de)allocated, the allocation status must be the same as the one of
8844	the local allocation. Convert to local access. */
8845	for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8846	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
8847	{
8848	for (int i = ref->u.ar.dimen;
8849	i < ref->u.ar.dimen + ref->u.ar.codimen; ++i)
8850	ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
8851	break;
8852	}
8853	}
8854	else if (!caf_this_image_ref (ref: e->ref))
8855	coindexed_caf_comp = true;
8856	}
8857	if (coindexed_caf_comp)
8858	tmp = trans_caf_is_present (se, expr: e);
8859	else
8860	{
8861	if (e->rank == 0)
8862	{
8863	/* Allocatable scalar. */
8864	arg1se.want_pointer = 1;
8865	gfc_conv_expr (se: &arg1se, expr: e);
8866	tmp = arg1se.expr;
8867	}
8868	else
8869	{
8870	/* Allocatable array. */
8871	arg1se.descriptor_only = 1;
8872	gfc_conv_expr_descriptor (&arg1se, e);
8873	tmp = gfc_conv_descriptor_data_get (arg1se.expr);
8874	}
8875
8876	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
8877	fold_convert (TREE_TYPE (tmp), null_pointer_node));
8878	}
8879
8880	/* Components of pointer array references sometimes come back with a pre block. */
8881	if (arg1se.pre.head)
8882	gfc_add_block_to_block (&se->pre, &arg1se.pre);
8883
8884	se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
8885	}
8886
8887
8888	/* Generate code for the ASSOCIATED intrinsic.
8889	If both POINTER and TARGET are arrays, generate a call to library function
8890	_gfor_associated, and pass descriptors of POINTER and TARGET to it.
8891	In other cases, generate inline code that directly compare the address of
8892	POINTER with the address of TARGET. */
8893
8894	static void
8895	gfc_conv_associated (gfc_se *se, gfc_expr *expr)
8896	{
8897	gfc_actual_arglist *arg1;
8898	gfc_actual_arglist *arg2;
8899	gfc_se arg1se;
8900	gfc_se arg2se;
8901	tree tmp2;
8902	tree tmp;
8903	tree nonzero_arraylen = NULL_TREE;
8904	gfc_ss *ss;
8905	bool scalar;
8906
8907	gfc_init_se (&arg1se, NULL);
8908	gfc_init_se (&arg2se, NULL);
8909	arg1 = expr->value.function.actual;
8910	arg2 = arg1->next;
8911
8912	/* Check whether the expression is a scalar or not; we cannot use
8913	arg1->expr->rank as it can be nonzero for proc pointers. */
8914	ss = gfc_walk_expr (arg1->expr);
8915	scalar = ss == gfc_ss_terminator;
8916	if (!scalar)
8917	gfc_free_ss_chain (ss);
8918
8919	if (!arg2->expr)
8920	{
8921	/* No optional target. */
8922	if (scalar)
8923	{
8924	/* A pointer to a scalar. */
8925	arg1se.want_pointer = 1;
8926	gfc_conv_expr (se: &arg1se, expr: arg1->expr);
8927	if (arg1->expr->symtree->n.sym->attr.proc_pointer
8928	&& arg1->expr->symtree->n.sym->attr.dummy)
8929	arg1se.expr = build_fold_indirect_ref_loc (input_location,
8930	arg1se.expr);
8931	if (arg1->expr->ts.type == BT_CLASS)
8932	{
8933	tmp2 = gfc_class_data_get (arg1se.expr);
8934	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8935	tmp2 = gfc_conv_descriptor_data_get (tmp2);
8936	}
8937	else
8938	tmp2 = arg1se.expr;
8939	}
8940	else
8941	{
8942	/* A pointer to an array. */
8943	gfc_conv_expr_descriptor (&arg1se, arg1->expr);
8944	tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
8945	}
8946	gfc_add_block_to_block (&se->pre, &arg1se.pre);
8947	gfc_add_block_to_block (&se->post, &arg1se.post);
8948	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
8949	fold_convert (TREE_TYPE (tmp2), null_pointer_node));
8950	se->expr = tmp;
8951	}
8952	else
8953	{
8954	/* An optional target. */
8955	if (arg2->expr->ts.type == BT_CLASS
8956	&& arg2->expr->expr_type != EXPR_FUNCTION)
8957	gfc_add_data_component (arg2->expr);
8958
8959	if (scalar)
8960	{
8961	/* A pointer to a scalar. */
8962	arg1se.want_pointer = 1;
8963	gfc_conv_expr (se: &arg1se, expr: arg1->expr);
8964	if (arg1->expr->symtree->n.sym->attr.proc_pointer
8965	&& arg1->expr->symtree->n.sym->attr.dummy)
8966	arg1se.expr = build_fold_indirect_ref_loc (input_location,
8967	arg1se.expr);
8968	if (arg1->expr->ts.type == BT_CLASS)
8969	arg1se.expr = gfc_class_data_get (arg1se.expr);
8970
8971	arg2se.want_pointer = 1;
8972	gfc_conv_expr (se: &arg2se, expr: arg2->expr);
8973	if (arg2->expr->symtree->n.sym->attr.proc_pointer
8974	&& arg2->expr->symtree->n.sym->attr.dummy)
8975	arg2se.expr = build_fold_indirect_ref_loc (input_location,
8976	arg2se.expr);
8977	if (arg2->expr->ts.type == BT_CLASS)
8978	{
8979	arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
8980	arg2se.expr = gfc_class_data_get (arg2se.expr);
8981	}
8982	gfc_add_block_to_block (&se->pre, &arg1se.pre);
8983	gfc_add_block_to_block (&se->post, &arg1se.post);
8984	gfc_add_block_to_block (&se->pre, &arg2se.pre);
8985	gfc_add_block_to_block (&se->post, &arg2se.post);
8986	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8987	arg1se.expr, arg2se.expr);
8988	tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8989	arg1se.expr, null_pointer_node);
8990	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8991	logical_type_node, tmp, tmp2);
8992	}
8993	else
8994	{
8995	/* An array pointer of zero length is not associated if target is
8996	present. */
8997	arg1se.descriptor_only = 1;
8998	gfc_conv_expr_lhs (se: &arg1se, expr: arg1->expr);
8999	if (arg1->expr->rank == -1)
9000	{
9001	tmp = gfc_conv_descriptor_rank (arg1se.expr);
9002	tmp = fold_build2_loc (input_location, MINUS_EXPR,
9003	TREE_TYPE (tmp), tmp,
9004	build_int_cst (TREE_TYPE (tmp), 1));
9005	}
9006	else
9007	tmp = gfc_rank_cst[arg1->expr->rank - 1];
9008	tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9009	if (arg2->expr->rank != 0)
9010	nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9011	logical_type_node, tmp,
9012	build_int_cst (TREE_TYPE (tmp), 0));
9013
9014	/* A pointer to an array, call library function _gfor_associated. */
9015	arg1se.want_pointer = 1;
9016	gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9017	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9018	gfc_add_block_to_block (&se->post, &arg1se.post);
9019
9020	arg2se.want_pointer = 1;
9021	arg2se.force_no_tmp = 1;
9022	if (arg2->expr->rank != 0)
9023	gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9024	else
9025	{
9026	gfc_conv_expr (se: &arg2se, expr: arg2->expr);
9027	arg2se.expr
9028	= gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9029	gfc_expr_attr (arg2->expr));
9030	arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9031	}
9032	gfc_add_block_to_block (&se->pre, &arg2se.pre);
9033	gfc_add_block_to_block (&se->post, &arg2se.post);
9034	se->expr = build_call_expr_loc (input_location,
9035	gfor_fndecl_associated, 2,
9036	arg1se.expr, arg2se.expr);
9037	se->expr = convert (logical_type_node, se->expr);
9038	if (arg2->expr->rank != 0)
9039	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9040	logical_type_node, se->expr,
9041	nonzero_arraylen);
9042	}
9043
9044	/* If target is present zero character length pointers cannot
9045	be associated. */
9046	if (arg1->expr->ts.type == BT_CHARACTER)
9047	{
9048	tmp = arg1se.string_length;
9049	tmp = fold_build2_loc (input_location, NE_EXPR,
9050	logical_type_node, tmp,
9051	build_zero_cst (TREE_TYPE (tmp)));
9052	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9053	logical_type_node, se->expr, tmp);
9054	}
9055	}
9056
9057	se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9058	}
9059
9060
9061	/* Generate code for the SAME_TYPE_AS intrinsic.
9062	Generate inline code that directly checks the vindices. */
9063
9064	static void
9065	gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9066	{
9067	gfc_expr *a, *b;
9068	gfc_se se1, se2;
9069	tree tmp;
9070	tree conda = NULL_TREE, condb = NULL_TREE;
9071
9072	gfc_init_se (&se1, NULL);
9073	gfc_init_se (&se2, NULL);
9074
9075	a = expr->value.function.actual->expr;
9076	b = expr->value.function.actual->next->expr;
9077
9078	bool unlimited_poly_a = UNLIMITED_POLY (a);
9079	bool unlimited_poly_b = UNLIMITED_POLY (b);
9080	if (unlimited_poly_a)
9081	{
9082	se1.want_pointer = 1;
9083	gfc_add_vptr_component (a);
9084	}
9085	else if (a->ts.type == BT_CLASS)
9086	{
9087	gfc_add_vptr_component (a);
9088	gfc_add_hash_component (a);
9089	}
9090	else if (a->ts.type == BT_DERIVED)
9091	a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9092	a->ts.u.derived->hash_value);
9093
9094	if (unlimited_poly_b)
9095	{
9096	se2.want_pointer = 1;
9097	gfc_add_vptr_component (b);
9098	}
9099	else if (b->ts.type == BT_CLASS)
9100	{
9101	gfc_add_vptr_component (b);
9102	gfc_add_hash_component (b);
9103	}
9104	else if (b->ts.type == BT_DERIVED)
9105	b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9106	b->ts.u.derived->hash_value);
9107
9108	gfc_conv_expr (se: &se1, expr: a);
9109	gfc_conv_expr (se: &se2, expr: b);
9110
9111	if (unlimited_poly_a)
9112	{
9113	conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9114	se1.expr,
9115	build_int_cst (TREE_TYPE (se1.expr), 0));
9116	se1.expr = gfc_vptr_hash_get (se1.expr);
9117	}
9118
9119	if (unlimited_poly_b)
9120	{
9121	condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9122	se2.expr,
9123	build_int_cst (TREE_TYPE (se2.expr), 0));
9124	se2.expr = gfc_vptr_hash_get (se2.expr);
9125	}
9126
9127	tmp = fold_build2_loc (input_location, EQ_EXPR,
9128	logical_type_node, se1.expr,
9129	fold_convert (TREE_TYPE (se1.expr), se2.expr));
9130
9131	if (conda)
9132	tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9133	logical_type_node, conda, tmp);
9134
9135	if (condb)
9136	tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9137	logical_type_node, condb, tmp);
9138
9139	se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9140	}
9141
9142
9143	/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9144
9145	static void
9146	gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9147	{
9148	tree args[2];
9149
9150	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 2);
9151	se->expr = build_call_expr_loc (input_location,
9152	gfor_fndecl_sc_kind, 2, args[0], args[1]);
9153	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9154	}
9155
9156
9157	/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9158
9159	static void
9160	gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9161	{
9162	tree arg, type;
9163
9164	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
9165
9166	/* The argument to SELECTED_INT_KIND is INTEGER(4). */
9167	type = gfc_get_int_type (4);
9168	arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9169
9170	/* Convert it to the required type. */
9171	type = gfc_typenode_for_spec (&expr->ts);
9172	se->expr = build_call_expr_loc (input_location,
9173	gfor_fndecl_si_kind, 1, arg);
9174	se->expr = fold_convert (type, se->expr);
9175	}
9176
9177
9178	/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9179
9180	static void
9181	gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9182	{
9183	gfc_actual_arglist *actual;
9184	tree type;
9185	gfc_se argse;
9186	vec<tree, va_gc> *args = NULL;
9187
9188	for (actual = expr->value.function.actual; actual; actual = actual->next)
9189	{
9190	gfc_init_se (&argse, se);
9191
9192	/* Pass a NULL pointer for an absent arg. */
9193	if (actual->expr == NULL)
9194	argse.expr = null_pointer_node;
9195	else
9196	{
9197	gfc_typespec ts;
9198	gfc_clear_ts (&ts);
9199
9200	if (actual->expr->ts.kind != gfc_c_int_kind)
9201	{
9202	/* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9203	ts.type = BT_INTEGER;
9204	ts.kind = gfc_c_int_kind;
9205	gfc_convert_type (actual->expr, &ts, 2);
9206	}
9207	gfc_conv_expr_reference (se: &argse, expr: actual->expr);
9208	}
9209
9210	gfc_add_block_to_block (&se->pre, &argse.pre);
9211	gfc_add_block_to_block (&se->post, &argse.post);
9212	vec_safe_push (v&: args, obj: argse.expr);
9213	}
9214
9215	/* Convert it to the required type. */
9216	type = gfc_typenode_for_spec (&expr->ts);
9217	se->expr = build_call_expr_loc_vec (input_location,
9218	gfor_fndecl_sr_kind, args);
9219	se->expr = fold_convert (type, se->expr);
9220	}
9221
9222
9223	/* Generate code for TRIM (A) intrinsic function. */
9224
9225	static void
9226	gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9227	{
9228	tree var;
9229	tree len;
9230	tree addr;
9231	tree tmp;
9232	tree cond;
9233	tree fndecl;
9234	tree function;
9235	tree *args;
9236	unsigned int num_args;
9237
9238	num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9239	args = XALLOCAVEC (tree, num_args);
9240
9241	var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9242	addr = gfc_build_addr_expr (ppvoid_type_node, var);
9243	len = gfc_create_var (gfc_charlen_type_node, "len");
9244
9245	gfc_conv_intrinsic_function_args (se, expr, argarray: &args[2], nargs: num_args - 2);
9246	args[0] = gfc_build_addr_expr (NULL_TREE, len);
9247	args[1] = addr;
9248
9249	if (expr->ts.kind == 1)
9250	function = gfor_fndecl_string_trim;
9251	else if (expr->ts.kind == 4)
9252	function = gfor_fndecl_string_trim_char4;
9253	else
9254	gcc_unreachable ();
9255
9256	fndecl = build_addr (function);
9257	tmp = build_call_array_loc (input_location,
9258	TREE_TYPE (TREE_TYPE (function)), fndecl,
9259	num_args, args);
9260	gfc_add_expr_to_block (&se->pre, tmp);
9261
9262	/* Free the temporary afterwards, if necessary. */
9263	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9264	len, build_int_cst (TREE_TYPE (len), 0));
9265	tmp = gfc_call_free (var);
9266	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9267	gfc_add_expr_to_block (&se->post, tmp);
9268
9269	se->expr = var;
9270	se->string_length = len;
9271	}
9272
9273
9274	/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9275
9276	static void
9277	gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9278	{
9279	tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9280	tree type, cond, tmp, count, exit_label, n, max, largest;
9281	tree size;
9282	stmtblock_t block, body;
9283	int i;
9284
9285	/* We store in charsize the size of a character. */
9286	i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9287	size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9288
9289	/* Get the arguments. */
9290	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: 3);
9291	slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9292	src = args[1];
9293	ncopies = gfc_evaluate_now (args[2], &se->pre);
9294	ncopies_type = TREE_TYPE (ncopies);
9295
9296	/* Check that NCOPIES is not negative. */
9297	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9298	build_int_cst (ncopies_type, 0));
9299	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9300	"Argument NCOPIES of REPEAT intrinsic is negative "
9301	"(its value is %ld)",
9302	fold_convert (long_integer_type_node, ncopies));
9303
9304	/* If the source length is zero, any non negative value of NCOPIES
9305	is valid, and nothing happens. */
9306	n = gfc_create_var (ncopies_type, "ncopies");
9307	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9308	size_zero_node);
9309	tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9310	build_int_cst (ncopies_type, 0), ncopies);
9311	gfc_add_modify (&se->pre, n, tmp);
9312	ncopies = n;
9313
9314	/* Check that ncopies is not too large: ncopies should be less than
9315	(or equal to) MAX / slen, where MAX is the maximal integer of
9316	the gfc_charlen_type_node type. If slen == 0, we need a special
9317	case to avoid the division by zero. */
9318	max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9319	fold_convert (sizetype,
9320	TYPE_MAX_VALUE (gfc_charlen_type_node)),
9321	slen);
9322	largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9323	? sizetype : ncopies_type;
9324	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9325	fold_convert (largest, ncopies),
9326	fold_convert (largest, max));
9327	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9328	size_zero_node);
9329	cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9330	logical_false_node, cond);
9331	gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9332	"Argument NCOPIES of REPEAT intrinsic is too large");
9333
9334	/* Compute the destination length. */
9335	dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9336	fold_convert (gfc_charlen_type_node, slen),
9337	fold_convert (gfc_charlen_type_node, ncopies));
9338	type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9339	dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9340
9341	/* Generate the code to do the repeat operation:
9342	for (i = 0; i < ncopies; i++)
9343	memmove (dest + (i * slen * size), src, slen*size); */
9344	gfc_start_block (&block);
9345	count = gfc_create_var (sizetype, "count");
9346	gfc_add_modify (&block, count, size_zero_node);
9347	exit_label = gfc_build_label_decl (NULL_TREE);
9348
9349	/* Start the loop body. */
9350	gfc_start_block (&body);
9351
9352	/* Exit the loop if count >= ncopies. */
9353	cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9354	fold_convert (sizetype, ncopies));
9355	tmp = build1_v (GOTO_EXPR, exit_label);
9356	TREE_USED (exit_label) = 1;
9357	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9358	build_empty_stmt (input_location));
9359	gfc_add_expr_to_block (&body, tmp);
9360
9361	/* Call memmove (dest + (i*slen*size), src, slen*size). */
9362	tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9363	count);
9364	tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9365	size);
9366	tmp = fold_build_pointer_plus_loc (loc: input_location,
9367	fold_convert (pvoid_type_node, dest), off: tmp);
9368	tmp = build_call_expr_loc (input_location,
9369	builtin_decl_explicit (fncode: BUILT_IN_MEMMOVE),
9370	3, tmp, src,
9371	fold_build2_loc (input_location, MULT_EXPR,
9372	size_type_node, slen, size));
9373	gfc_add_expr_to_block (&body, tmp);
9374
9375	/* Increment count. */
9376	tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9377	count, size_one_node);
9378	gfc_add_modify (&body, count, tmp);
9379
9380	/* Build the loop. */
9381	tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9382	gfc_add_expr_to_block (&block, tmp);
9383
9384	/* Add the exit label. */
9385	tmp = build1_v (LABEL_EXPR, exit_label);
9386	gfc_add_expr_to_block (&block, tmp);
9387
9388	/* Finish the block. */
9389	tmp = gfc_finish_block (&block);
9390	gfc_add_expr_to_block (&se->pre, tmp);
9391
9392	/* Set the result value. */
9393	se->expr = dest;
9394	se->string_length = dlen;
9395	}
9396
9397
9398	/* Generate code for the IARGC intrinsic. */
9399
9400	static void
9401	gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9402	{
9403	tree tmp;
9404	tree fndecl;
9405	tree type;
9406
9407	/* Call the library function. This always returns an INTEGER(4). */
9408	fndecl = gfor_fndecl_iargc;
9409	tmp = build_call_expr_loc (input_location,
9410	fndecl, 0);
9411
9412	/* Convert it to the required type. */
9413	type = gfc_typenode_for_spec (&expr->ts);
9414	tmp = fold_convert (type, tmp);
9415
9416	se->expr = tmp;
9417	}
9418
9419
9420	/* Generate code for the KILL intrinsic. */
9421
9422	static void
9423	conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9424	{
9425	tree *args;
9426	tree int4_type_node = gfc_get_int_type (4);
9427	tree pid;
9428	tree sig;
9429	tree tmp;
9430	unsigned int num_args;
9431
9432	num_args = gfc_intrinsic_argument_list_length (expr);
9433	args = XALLOCAVEC (tree, num_args);
9434	gfc_conv_intrinsic_function_args (se, expr, argarray: args, nargs: num_args);
9435
9436	/* Convert PID to a INTEGER(4) entity. */
9437	pid = convert (int4_type_node, args[0]);
9438
9439	/* Convert SIG to a INTEGER(4) entity. */
9440	sig = convert (int4_type_node, args[1]);
9441
9442	tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9443
9444	se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9445	}
9446
9447
9448	static tree
9449	conv_intrinsic_kill_sub (gfc_code *code)
9450	{
9451	stmtblock_t block;
9452	gfc_se se, se_stat;
9453	tree int4_type_node = gfc_get_int_type (4);
9454	tree pid;
9455	tree sig;
9456	tree statp;
9457	tree tmp;
9458
9459	/* Make the function call. */
9460	gfc_init_block (&block);
9461	gfc_init_se (&se, NULL);
9462
9463	/* Convert PID to a INTEGER(4) entity. */
9464	gfc_conv_expr (se: &se, expr: code->ext.actual->expr);
9465	gfc_add_block_to_block (&block, &se.pre);
9466	pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9467	gfc_add_block_to_block (&block, &se.post);
9468
9469	/* Convert SIG to a INTEGER(4) entity. */
9470	gfc_conv_expr (se: &se, expr: code->ext.actual->next->expr);
9471	gfc_add_block_to_block (&block, &se.pre);
9472	sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9473	gfc_add_block_to_block (&block, &se.post);
9474
9475	/* Deal with an optional STATUS. */
9476	if (code->ext.actual->next->next->expr)
9477	{
9478	gfc_init_se (&se_stat, NULL);
9479	gfc_conv_expr (se: &se_stat, expr: code->ext.actual->next->next->expr);
9480	statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9481	}
9482	else
9483	statp = NULL_TREE;
9484
9485	tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9486	statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9487
9488	gfc_add_expr_to_block (&block, tmp);
9489
9490	if (statp && statp != se_stat.expr)
9491	gfc_add_modify (&block, se_stat.expr,
9492	fold_convert (TREE_TYPE (se_stat.expr), statp));
9493
9494	return gfc_finish_block (&block);
9495	}
9496
9497
9498
9499	/* The loc intrinsic returns the address of its argument as
9500	gfc_index_integer_kind integer. */
9501
9502	static void
9503	gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9504	{
9505	tree temp_var;
9506	gfc_expr *arg_expr;
9507
9508	gcc_assert (!se->ss);
9509
9510	arg_expr = expr->value.function.actual->expr;
9511	if (arg_expr->rank == 0)
9512	{
9513	if (arg_expr->ts.type == BT_CLASS)
9514	gfc_add_data_component (arg_expr);
9515	gfc_conv_expr_reference (se, expr: arg_expr);
9516	}
9517	else
9518	gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9519	se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9520
9521	/* Create a temporary variable for loc return value. Without this,
9522	we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9523	temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9524	gfc_add_modify (&se->pre, temp_var, se->expr);
9525	se->expr = temp_var;
9526	}
9527
9528
9529	/* The following routine generates code for the intrinsic
9530	functions from the ISO_C_BINDING module:
9531	* C_LOC
9532	* C_FUNLOC
9533	* C_ASSOCIATED */
9534
9535	static void
9536	conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9537	{
9538	gfc_actual_arglist *arg = expr->value.function.actual;
9539
9540	if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9541	{
9542	if (arg->expr->rank == 0)
9543	gfc_conv_expr_reference (se, expr: arg->expr);
9544	else if (gfc_is_simply_contiguous (arg->expr, false, false))
9545	gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9546	else
9547	{
9548	gfc_conv_expr_descriptor (se, arg->expr);
9549	se->expr = gfc_conv_descriptor_data_get (se->expr);
9550	}
9551
9552	/* TODO -- the following two lines shouldn't be necessary, but if
9553	they're removed, a bug is exposed later in the code path.
9554	This workaround was thus introduced, but will have to be
9555	removed; please see PR 35150 for details about the issue. */
9556	se->expr = convert (pvoid_type_node, se->expr);
9557	se->expr = gfc_evaluate_now (se->expr, &se->pre);
9558	}
9559	else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9560	gfc_conv_expr_reference (se, expr: arg->expr);
9561	else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9562	{
9563	gfc_se arg1se;
9564	gfc_se arg2se;
9565
9566	/* Build the addr_expr for the first argument. The argument is
9567	already an *address* so we don't need to set want_pointer in
9568	the gfc_se. */
9569	gfc_init_se (&arg1se, NULL);
9570	gfc_conv_expr (se: &arg1se, expr: arg->expr);
9571	gfc_add_block_to_block (&se->pre, &arg1se.pre);
9572	gfc_add_block_to_block (&se->post, &arg1se.post);
9573
9574	/* See if we were given two arguments. */
9575	if (arg->next->expr == NULL)
9576	/* Only given one arg so generate a null and do a
9577	not-equal comparison against the first arg. */
9578	se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9579	arg1se.expr,
9580	fold_convert (TREE_TYPE (arg1se.expr),
9581	null_pointer_node));
9582	else
9583	{
9584	tree eq_expr;
9585	tree not_null_expr;
9586
9587	/* Given two arguments so build the arg2se from second arg. */
9588	gfc_init_se (&arg2se, NULL);
9589	gfc_conv_expr (se: &arg2se, expr: arg->next->expr);
9590	gfc_add_block_to_block (&se->pre, &arg2se.pre);
9591	gfc_add_block_to_block (&se->post, &arg2se.post);
9592
9593	/* Generate test to compare that the two args are equal. */
9594	eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9595	arg1se.expr, arg2se.expr);
9596	/* Generate test to ensure that the first arg is not null. */
9597	not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9598	logical_type_node,
9599	arg1se.expr, null_pointer_node);
9600
9601	/* Finally, the generated test must check that both arg1 is not
9602	NULL and that it is equal to the second arg. */
9603	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9604	logical_type_node,
9605	not_null_expr, eq_expr);
9606	}
9607	}
9608	else
9609	gcc_unreachable ();
9610	}
9611
9612
9613	/* The following routine generates code for the intrinsic
9614	subroutines from the ISO_C_BINDING module:
9615	* C_F_POINTER
9616	* C_F_PROCPOINTER. */
9617
9618	static tree
9619	conv_isocbinding_subroutine (gfc_code *code)
9620	{
9621	gfc_se se;
9622	gfc_se cptrse;
9623	gfc_se fptrse;
9624	gfc_se shapese;
9625	gfc_ss *shape_ss;
9626	tree desc, dim, tmp, stride, offset;
9627	stmtblock_t body, block;
9628	gfc_loopinfo loop;
9629	gfc_actual_arglist *arg = code->ext.actual;
9630
9631	gfc_init_se (&se, NULL);
9632	gfc_init_se (&cptrse, NULL);
9633	gfc_conv_expr (se: &cptrse, expr: arg->expr);
9634	gfc_add_block_to_block (&se.pre, &cptrse.pre);
9635	gfc_add_block_to_block (&se.post, &cptrse.post);
9636
9637	gfc_init_se (&fptrse, NULL);
9638	if (arg->next->expr->rank == 0)
9639	{
9640	fptrse.want_pointer = 1;
9641	gfc_conv_expr (se: &fptrse, expr: arg->next->expr);
9642	gfc_add_block_to_block (&se.pre, &fptrse.pre);
9643	gfc_add_block_to_block (&se.post, &fptrse.post);
9644	if (arg->next->expr->symtree->n.sym->attr.proc_pointer
9645	&& arg->next->expr->symtree->n.sym->attr.dummy)
9646	fptrse.expr = build_fold_indirect_ref_loc (input_location,
9647	fptrse.expr);
9648	se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
9649	TREE_TYPE (fptrse.expr),
9650	fptrse.expr,
9651	fold_convert (TREE_TYPE (fptrse.expr),
9652	cptrse.expr));
9653	gfc_add_expr_to_block (&se.pre, se.expr);
9654	gfc_add_block_to_block (&se.pre, &se.post);
9655	return gfc_finish_block (&se.pre);
9656	}
9657
9658	gfc_start_block (&block);
9659
9660	/* Get the descriptor of the Fortran pointer. */
9661	fptrse.descriptor_only = 1;
9662	gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
9663	gfc_add_block_to_block (&block, &fptrse.pre);
9664	desc = fptrse.expr;
9665
9666	/* Set the span field. */
9667	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9668	tmp = fold_convert (gfc_array_index_type, tmp);
9669	gfc_conv_descriptor_span_set (&block, desc, tmp);
9670
9671	/* Set data value, dtype, and offset. */
9672	tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
9673	gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
9674	gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
9675	gfc_get_dtype (TREE_TYPE (desc)));
9676
9677	/* Start scalarization of the bounds, using the shape argument. */
9678
9679	shape_ss = gfc_walk_expr (arg->next->next->expr);
9680	gcc_assert (shape_ss != gfc_ss_terminator);
9681	gfc_init_se (&shapese, NULL);
9682
9683	gfc_init_loopinfo (&loop);
9684	gfc_add_ss_to_loop (&loop, shape_ss);
9685	gfc_conv_ss_startstride (&loop);
9686	gfc_conv_loop_setup (&loop, &arg->next->expr->where);
9687	gfc_mark_ss_chain_used (shape_ss, 1);
9688
9689	gfc_copy_loopinfo_to_se (&shapese, &loop);
9690	shapese.ss = shape_ss;
9691
9692	stride = gfc_create_var (gfc_array_index_type, "stride");
9693	offset = gfc_create_var (gfc_array_index_type, "offset");
9694	gfc_add_modify (&block, stride, gfc_index_one_node);
9695	gfc_add_modify (&block, offset, gfc_index_zero_node);
9696
9697	/* Loop body. */
9698	gfc_start_scalarized_body (&loop, &body);
9699
9700	dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9701	loop.loopvar[0], loop.from[0]);
9702
9703	/* Set bounds and stride. */
9704	gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
9705	gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
9706
9707	gfc_conv_expr (se: &shapese, expr: arg->next->next->expr);
9708	gfc_add_block_to_block (&body, &shapese.pre);
9709	gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
9710	gfc_add_block_to_block (&body, &shapese.post);
9711
9712	/* Calculate offset. */
9713	gfc_add_modify (&body, offset,
9714	fold_build2_loc (input_location, PLUS_EXPR,
9715	gfc_array_index_type, offset, stride));
9716	/* Update stride. */
9717	gfc_add_modify (&body, stride,
9718	fold_build2_loc (input_location, MULT_EXPR,
9719	gfc_array_index_type, stride,
9720	fold_convert (gfc_array_index_type,
9721	shapese.expr)));
9722	/* Finish scalarization loop. */
9723	gfc_trans_scalarizing_loops (&loop, &body);
9724	gfc_add_block_to_block (&block, &loop.pre);
9725	gfc_add_block_to_block (&block, &loop.post);
9726	gfc_add_block_to_block (&block, &fptrse.post);
9727	gfc_cleanup_loop (&loop);
9728
9729	gfc_add_modify (&block, offset,
9730	fold_build1_loc (input_location, NEGATE_EXPR,
9731	gfc_array_index_type, offset));
9732	gfc_conv_descriptor_offset_set (&block, desc, offset);
9733
9734	gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
9735	gfc_add_block_to_block (&se.pre, &se.post);
9736	return gfc_finish_block (&se.pre);
9737	}
9738
9739
9740	/* Save and restore floating-point state. */
9741
9742	tree
9743	gfc_save_fp_state (stmtblock_t *block)
9744	{
9745	tree type, fpstate, tmp;
9746
9747	type = build_array_type (char_type_node,
9748	build_range_type (size_type_node, size_zero_node,
9749	size_int (GFC_FPE_STATE_BUFFER_SIZE)));
9750	fpstate = gfc_create_var (type, "fpstate");
9751	fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
9752
9753	tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
9754	1, fpstate);
9755	gfc_add_expr_to_block (block, tmp);
9756
9757	return fpstate;
9758	}
9759
9760
9761	void
9762	gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
9763	{
9764	tree tmp;
9765
9766	tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
9767	1, fpstate);
9768	gfc_add_expr_to_block (block, tmp);
9769	}
9770
9771
9772	/* Generate code for arguments of IEEE functions. */
9773
9774	static void
9775	conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
9776	int nargs)
9777	{
9778	gfc_actual_arglist *actual;
9779	gfc_expr *e;
9780	gfc_se argse;
9781	int arg;
9782
9783	actual = expr->value.function.actual;
9784	for (arg = 0; arg < nargs; arg++, actual = actual->next)
9785	{
9786	gcc_assert (actual);
9787	e = actual->expr;
9788
9789	gfc_init_se (&argse, se);
9790	gfc_conv_expr_val (se: &argse, expr: e);
9791
9792	gfc_add_block_to_block (&se->pre, &argse.pre);
9793	gfc_add_block_to_block (&se->post, &argse.post);
9794	argarray[arg] = argse.expr;
9795	}
9796	}
9797
9798
9799	/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
9800	and IEEE_UNORDERED, which translate directly to GCC type-generic
9801	built-ins. */
9802
9803	static void
9804	conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
9805	enum built_in_function code, int nargs)
9806	{
9807	tree args[2];
9808	gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
9809
9810	conv_ieee_function_args (se, expr, argarray: args, nargs);
9811	se->expr = build_call_expr_loc_array (input_location,
9812	builtin_decl_explicit (fncode: code),
9813	nargs, args);
9814	STRIP_TYPE_NOPS (se->expr);
9815	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9816	}
9817
9818
9819	/* Generate code for intrinsics IEEE_SIGNBIT. */
9820
9821	static void
9822	conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
9823	{
9824	tree arg, signbit;
9825
9826	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
9827	signbit = build_call_expr_loc (input_location,
9828	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT),
9829	1, arg);
9830	signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9831	signbit, integer_zero_node);
9832	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
9833	}
9834
9835
9836	/* Generate code for IEEE_IS_NORMAL intrinsic:
9837	IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9838
9839	static void
9840	conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
9841	{
9842	tree arg, isnormal, iszero;
9843
9844	/* Convert arg, evaluate it only once. */
9845	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
9846	arg = gfc_evaluate_now (arg, &se->pre);
9847
9848	isnormal = build_call_expr_loc (input_location,
9849	builtin_decl_explicit (fncode: BUILT_IN_ISNORMAL),
9850	1, arg);
9851	iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
9852	build_real_from_int_cst (TREE_TYPE (arg),
9853	integer_zero_node));
9854	se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9855	logical_type_node, isnormal, iszero);
9856	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9857	}
9858
9859
9860	/* Generate code for IEEE_IS_NEGATIVE intrinsic:
9861	IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9862
9863	static void
9864	conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
9865	{
9866	tree arg, signbit, isnan;
9867
9868	/* Convert arg, evaluate it only once. */
9869	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
9870	arg = gfc_evaluate_now (arg, &se->pre);
9871
9872	isnan = build_call_expr_loc (input_location,
9873	builtin_decl_explicit (fncode: BUILT_IN_ISNAN),
9874	1, arg);
9875	STRIP_TYPE_NOPS (isnan);
9876
9877	signbit = build_call_expr_loc (input_location,
9878	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT),
9879	1, arg);
9880	signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9881	signbit, integer_zero_node);
9882
9883	se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9884	logical_type_node, signbit,
9885	fold_build1_loc (input_location, TRUTH_NOT_EXPR,
9886	TREE_TYPE(isnan), isnan));
9887
9888	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9889	}
9890
9891
9892	/* Generate code for IEEE_LOGB and IEEE_RINT. */
9893
9894	static void
9895	conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
9896	enum built_in_function code)
9897	{
9898	tree arg, decl, call, fpstate;
9899	int argprec;
9900
9901	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
9902	argprec = TYPE_PRECISION (TREE_TYPE (arg));
9903	decl = builtin_decl_for_precision (base_built_in: code, precision: argprec);
9904
9905	/* Save floating-point state. */
9906	fpstate = gfc_save_fp_state (block: &se->pre);
9907
9908	/* Make the function call. */
9909	call = build_call_expr_loc (input_location, decl, 1, arg);
9910	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
9911
9912	/* Restore floating-point state. */
9913	gfc_restore_fp_state (block: &se->post, fpstate);
9914	}
9915
9916
9917	/* Generate code for IEEE_REM. */
9918
9919	static void
9920	conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
9921	{
9922	tree args[2], decl, call, fpstate;
9923	int argprec;
9924
9925	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
9926
9927	/* If arguments have unequal size, convert them to the larger. */
9928	if (TYPE_PRECISION (TREE_TYPE (args[0]))
9929	> TYPE_PRECISION (TREE_TYPE (args[1])))
9930	args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9931	else if (TYPE_PRECISION (TREE_TYPE (args[1]))
9932	> TYPE_PRECISION (TREE_TYPE (args[0])))
9933	args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
9934
9935	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9936	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_REMAINDER, precision: argprec);
9937
9938	/* Save floating-point state. */
9939	fpstate = gfc_save_fp_state (block: &se->pre);
9940
9941	/* Make the function call. */
9942	call = build_call_expr_loc_array (input_location, decl, 2, args);
9943	se->expr = fold_convert (TREE_TYPE (args[0]), call);
9944
9945	/* Restore floating-point state. */
9946	gfc_restore_fp_state (block: &se->post, fpstate);
9947	}
9948
9949
9950	/* Generate code for IEEE_NEXT_AFTER. */
9951
9952	static void
9953	conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
9954	{
9955	tree args[2], decl, call, fpstate;
9956	int argprec;
9957
9958	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
9959
9960	/* Result has the characteristics of first argument. */
9961	args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9962	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9963	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_NEXTAFTER, precision: argprec);
9964
9965	/* Save floating-point state. */
9966	fpstate = gfc_save_fp_state (block: &se->pre);
9967
9968	/* Make the function call. */
9969	call = build_call_expr_loc_array (input_location, decl, 2, args);
9970	se->expr = fold_convert (TREE_TYPE (args[0]), call);
9971
9972	/* Restore floating-point state. */
9973	gfc_restore_fp_state (block: &se->post, fpstate);
9974	}
9975
9976
9977	/* Generate code for IEEE_SCALB. */
9978
9979	static void
9980	conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
9981	{
9982	tree args[2], decl, call, huge, type;
9983	int argprec, n;
9984
9985	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
9986
9987	/* Result has the characteristics of first argument. */
9988	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9989	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_SCALBN, precision: argprec);
9990
9991	if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
9992	{
9993	/* We need to fold the integer into the range of a C int. */
9994	args[1] = gfc_evaluate_now (args[1], &se->pre);
9995	type = TREE_TYPE (args[1]);
9996
9997	n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
9998	huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
9999	gfc_c_int_kind);
10000	huge = fold_convert (type, huge);
10001	args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10002	huge);
10003	args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10004	fold_build1_loc (input_location, NEGATE_EXPR,
10005	type, huge));
10006	}
10007
10008	args[1] = fold_convert (integer_type_node, args[1]);
10009
10010	/* Make the function call. */
10011	call = build_call_expr_loc_array (input_location, decl, 2, args);
10012	se->expr = fold_convert (TREE_TYPE (args[0]), call);
10013	}
10014
10015
10016	/* Generate code for IEEE_COPY_SIGN. */
10017
10018	static void
10019	conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10020	{
10021	tree args[2], decl, sign;
10022	int argprec;
10023
10024	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10025
10026	/* Get the sign of the second argument. */
10027	sign = build_call_expr_loc (input_location,
10028	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT),
10029	1, args[1]);
10030	sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10031	sign, integer_zero_node);
10032
10033	/* Create a value of one, with the right sign. */
10034	sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10035	sign,
10036	fold_build1_loc (input_location, NEGATE_EXPR,
10037	integer_type_node,
10038	integer_one_node),
10039	integer_one_node);
10040	args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10041
10042	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10043	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_COPYSIGN, precision: argprec);
10044
10045	se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10046	}
10047
10048
10049	/* Generate code for IEEE_CLASS. */
10050
10051	static void
10052	conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10053	{
10054	tree arg, c, t1, t2, t3, t4;
10055
10056	/* Convert arg, evaluate it only once. */
10057	conv_ieee_function_args (se, expr, argarray: &arg, nargs: 1);
10058	arg = gfc_evaluate_now (arg, &se->pre);
10059
10060	c = build_call_expr_loc (input_location,
10061	builtin_decl_explicit (fncode: BUILT_IN_FPCLASSIFY), 6,
10062	build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10063	build_int_cst (integer_type_node,
10064	IEEE_POSITIVE_INF),
10065	build_int_cst (integer_type_node,
10066	IEEE_POSITIVE_NORMAL),
10067	build_int_cst (integer_type_node,
10068	IEEE_POSITIVE_DENORMAL),
10069	build_int_cst (integer_type_node,
10070	IEEE_POSITIVE_ZERO),
10071	arg);
10072	c = gfc_evaluate_now (c, &se->pre);
10073	t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10074	c, build_int_cst (integer_type_node,
10075	IEEE_QUIET_NAN));
10076	t2 = build_call_expr_loc (input_location,
10077	builtin_decl_explicit (fncode: BUILT_IN_ISSIGNALING), 1,
10078	arg);
10079	t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10080	t2, build_zero_cst (TREE_TYPE (t2)));
10081	t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10082	logical_type_node, t1, t2);
10083	t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10084	c, build_int_cst (integer_type_node,
10085	IEEE_POSITIVE_ZERO));
10086	t4 = build_call_expr_loc (input_location,
10087	builtin_decl_explicit (fncode: BUILT_IN_SIGNBIT), 1,
10088	arg);
10089	t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10090	t4, build_zero_cst (TREE_TYPE (t4)));
10091	t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10092	logical_type_node, t3, t4);
10093	int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10094	gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10095	gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10096	gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10097	gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10098	gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10099	t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10100	build_int_cst (TREE_TYPE (c), s), c);
10101	t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10102	t3, t4, c);
10103	t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10104	build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10105	t3);
10106	tree type = gfc_typenode_for_spec (&expr->ts);
10107	/* Perform a quick sanity check that the return type is
10108	IEEE_CLASS_TYPE derived type defined in
10109	libgfortran/ieee/ieee_arithmetic.F90
10110	Primarily check that it is a derived type with a single
10111	member in it. */
10112	gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10113	tree field = NULL_TREE;
10114	for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10115	if (TREE_CODE (f) == FIELD_DECL)
10116	{
10117	gcc_assert (field == NULL_TREE);
10118	field = f;
10119	}
10120	gcc_assert (field);
10121	t1 = fold_convert (TREE_TYPE (field), t1);
10122	se->expr = build_constructor_single (type, field, t1);
10123	}
10124
10125
10126	/* Generate code for IEEE_VALUE. */
10127
10128	static void
10129	conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10130	{
10131	tree args[2], arg, ret, tmp;
10132	stmtblock_t body;
10133
10134	/* Convert args, evaluate the second one only once. */
10135	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10136	arg = gfc_evaluate_now (args[1], &se->pre);
10137
10138	tree type = TREE_TYPE (arg);
10139	/* Perform a quick sanity check that the second argument's type is
10140	IEEE_CLASS_TYPE derived type defined in
10141	libgfortran/ieee/ieee_arithmetic.F90
10142	Primarily check that it is a derived type with a single
10143	member in it. */
10144	gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10145	tree field = NULL_TREE;
10146	for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10147	if (TREE_CODE (f) == FIELD_DECL)
10148	{
10149	gcc_assert (field == NULL_TREE);
10150	field = f;
10151	}
10152	gcc_assert (field);
10153	arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10154	arg, field, NULL_TREE);
10155	arg = gfc_evaluate_now (arg, &se->pre);
10156
10157	type = gfc_typenode_for_spec (&expr->ts);
10158	gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10159	ret = gfc_create_var (type, NULL);
10160
10161	gfc_init_block (&body);
10162
10163	tree end_label = gfc_build_label_decl (NULL_TREE);
10164	for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10165	{
10166	tree label = gfc_build_label_decl (NULL_TREE);
10167	tree low = build_int_cst (TREE_TYPE (arg), c);
10168	tmp = build_case_label (low, low, label);
10169	gfc_add_expr_to_block (&body, tmp);
10170
10171	REAL_VALUE_TYPE real;
10172	int k;
10173	switch (c)
10174	{
10175	case IEEE_SIGNALING_NAN:
10176	real_nan (&real, "", 0, TYPE_MODE (type));
10177	break;
10178	case IEEE_QUIET_NAN:
10179	real_nan (&real, "", 1, TYPE_MODE (type));
10180	break;
10181	case IEEE_NEGATIVE_INF:
10182	real_inf (&real);
10183	real = real_value_negate (&real);
10184	break;
10185	case IEEE_NEGATIVE_NORMAL:
10186	real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10187	break;
10188	case IEEE_NEGATIVE_DENORMAL:
10189	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10190	real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10191	type, GFC_RND_MODE);
10192	real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10193	real = real_value_negate (&real);
10194	break;
10195	case IEEE_NEGATIVE_ZERO:
10196	real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10197	real = real_value_negate (&real);
10198	break;
10199	case IEEE_POSITIVE_ZERO:
10200	/* Make this also the default: label. The other possibility
10201	would be to add a separate default: label followed by
10202	__builtin_unreachable (). */
10203	label = gfc_build_label_decl (NULL_TREE);
10204	tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10205	gfc_add_expr_to_block (&body, tmp);
10206	real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10207	break;
10208	case IEEE_POSITIVE_DENORMAL:
10209	k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10210	real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10211	type, GFC_RND_MODE);
10212	real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10213	break;
10214	case IEEE_POSITIVE_NORMAL:
10215	real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10216	break;
10217	case IEEE_POSITIVE_INF:
10218	real_inf (&real);
10219	break;
10220	default:
10221	gcc_unreachable ();
10222	}
10223
10224	tree val = build_real (type, real);
10225	gfc_add_modify (&body, ret, val);
10226
10227	tmp = build1_v (GOTO_EXPR, end_label);
10228	gfc_add_expr_to_block (&body, tmp);
10229	}
10230
10231	tmp = gfc_finish_block (&body);
10232	tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10233	gfc_add_expr_to_block (&se->pre, tmp);
10234
10235	tmp = build1_v (LABEL_EXPR, end_label);
10236	gfc_add_expr_to_block (&se->pre, tmp);
10237
10238	se->expr = ret;
10239	}
10240
10241
10242	/* Generate code for IEEE_FMA. */
10243
10244	static void
10245	conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10246	{
10247	tree args[3], decl, call;
10248	int argprec;
10249
10250	conv_ieee_function_args (se, expr, argarray: args, nargs: 3);
10251
10252	/* All three arguments should have the same type. */
10253	gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10254	gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10255
10256	/* Call the type-generic FMA built-in. */
10257	argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10258	decl = builtin_decl_for_precision (base_built_in: BUILT_IN_FMA, precision: argprec);
10259	call = build_call_expr_loc_array (input_location, decl, 3, args);
10260
10261	/* Convert to the final type. */
10262	se->expr = fold_convert (TREE_TYPE (args[0]), call);
10263	}
10264
10265
10266	/* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10267
10268	static void
10269	conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10270	const char *name)
10271	{
10272	tree args[2], func;
10273	built_in_function fn;
10274
10275	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10276	gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10277	args[0] = gfc_evaluate_now (args[0], &se->pre);
10278	args[1] = gfc_evaluate_now (args[1], &se->pre);
10279
10280	if (startswith (str: name, prefix: "mag"))
10281	{
10282	/* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10283	fminmag() and fmaxmag(), which do not exist as built-ins.
10284
10285	Following glibc, we emit this:
10286
10287	fminmag (x, y) {
10288	ax = ABS (x);
10289	ay = ABS (y);
10290	if (isless (ax, ay))
10291	return x;
10292	else if (isgreater (ax, ay))
10293	return y;
10294	else if (ax == ay)
10295	return x < y ? x : y;
10296	else if (issignaling (x) || issignaling (y))
10297	return x + y;
10298	else
10299	return isnan (y) ? x : y;
10300	}
10301
10302	fmaxmag (x, y) {
10303	ax = ABS (x);
10304	ay = ABS (y);
10305	if (isgreater (ax, ay))
10306	return x;
10307	else if (isless (ax, ay))
10308	return y;
10309	else if (ax == ay)
10310	return x > y ? x : y;
10311	else if (issignaling (x) || issignaling (y))
10312	return x + y;
10313	else
10314	return isnan (y) ? x : y;
10315	}
10316
10317	*/
10318
10319	tree abs0, abs1, sig0, sig1;
10320	tree cond1, cond2, cond3, cond4, cond5;
10321	tree res;
10322	tree type = TREE_TYPE (args[0]);
10323
10324	func = gfc_builtin_decl_for_float_kind (double_built_in: BUILT_IN_FABS, kind: expr->ts.kind);
10325	abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10326	abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10327	abs0 = gfc_evaluate_now (abs0, &se->pre);
10328	abs1 = gfc_evaluate_now (abs1, &se->pre);
10329
10330	cond5 = build_call_expr_loc (input_location,
10331	builtin_decl_explicit (fncode: BUILT_IN_ISNAN),
10332	1, args[1]);
10333	res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10334	args[0], args[1]);
10335
10336	sig0 = build_call_expr_loc (input_location,
10337	builtin_decl_explicit (fncode: BUILT_IN_ISSIGNALING),
10338	1, args[0]);
10339	sig1 = build_call_expr_loc (input_location,
10340	builtin_decl_explicit (fncode: BUILT_IN_ISSIGNALING),
10341	1, args[1]);
10342	cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
10343	logical_type_node, sig0, sig1);
10344	res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
10345	fold_build2_loc (input_location, PLUS_EXPR,
10346	type, args[0], args[1]),
10347	res);
10348
10349	cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10350	abs0, abs1);
10351	res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
10352	fold_build2_loc (input_location,
10353	max ? MAX_EXPR : MIN_EXPR,
10354	type, args[0], args[1]),
10355	res);
10356
10357	func = builtin_decl_explicit (fncode: max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
10358	cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10359	res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
10360	args[1], res);
10361
10362	func = builtin_decl_explicit (fncode: max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
10363	cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10364	res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
10365	args[0], res);
10366
10367	se->expr = res;
10368	}
10369	else
10370	{
10371	/* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10372	fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
10373	func = gfc_builtin_decl_for_float_kind (double_built_in: fn, kind: expr->ts.kind);
10374	se->expr = build_call_expr_loc_array (input_location, func, 2, args);
10375	}
10376	}
10377
10378
10379	/* Generate code for comparison functions IEEE_QUIET_* and
10380	IEEE_SIGNALING_*. */
10381
10382	static void
10383	conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
10384	const char *name)
10385	{
10386	tree args[2];
10387	tree arg1, arg2, res;
10388
10389	/* Evaluate arguments only once. */
10390	conv_ieee_function_args (se, expr, argarray: args, nargs: 2);
10391	arg1 = gfc_evaluate_now (args[0], &se->pre);
10392	arg2 = gfc_evaluate_now (args[1], &se->pre);
10393
10394	if (startswith (str: name, prefix: "eq"))
10395	{
10396	if (signaling)
10397	res = build_call_expr_loc (input_location,
10398	builtin_decl_explicit (fncode: BUILT_IN_ISEQSIG),
10399	2, arg1, arg2);
10400	else
10401	res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10402	arg1, arg2);
10403	}
10404	else if (startswith (str: name, prefix: "ne"))
10405	{
10406	if (signaling)
10407	{
10408	res = build_call_expr_loc (input_location,
10409	builtin_decl_explicit (fncode: BUILT_IN_ISEQSIG),
10410	2, arg1, arg2);
10411	res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10412	logical_type_node, res);
10413	}
10414	else
10415	res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10416	arg1, arg2);
10417	}
10418	else if (startswith (str: name, prefix: "ge"))
10419	{
10420	if (signaling)
10421	res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10422	arg1, arg2);
10423	else
10424	res = build_call_expr_loc (input_location,
10425	builtin_decl_explicit (fncode: BUILT_IN_ISGREATEREQUAL),
10426	2, arg1, arg2);
10427	}
10428	else if (startswith (str: name, prefix: "gt"))
10429	{
10430	if (signaling)
10431	res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
10432	arg1, arg2);
10433	else
10434	res = build_call_expr_loc (input_location,
10435	builtin_decl_explicit (fncode: BUILT_IN_ISGREATER),
10436	2, arg1, arg2);
10437	}
10438	else if (startswith (str: name, prefix: "le"))
10439	{
10440	if (signaling)
10441	res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
10442	arg1, arg2);
10443	else
10444	res = build_call_expr_loc (input_location,
10445	builtin_decl_explicit (fncode: BUILT_IN_ISLESSEQUAL),
10446	2, arg1, arg2);
10447	}
10448	else if (startswith (str: name, prefix: "lt"))
10449	{
10450	if (signaling)
10451	res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10452	arg1, arg2);
10453	else
10454	res = build_call_expr_loc (input_location,
10455	builtin_decl_explicit (fncode: BUILT_IN_ISLESS),
10456	2, arg1, arg2);
10457	}
10458	else
10459	gcc_unreachable ();
10460
10461	se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
10462	}
10463
10464
10465	/* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10466	module. */
10467
10468	bool
10469	gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10470	{
10471	const char *name = expr->value.function.name;
10472
10473	if (startswith (str: name, prefix: "_gfortran_ieee_is_nan"))
10474	conv_intrinsic_ieee_builtin (se, expr, code: BUILT_IN_ISNAN, nargs: 1);
10475	else if (startswith (str: name, prefix: "_gfortran_ieee_is_finite"))
10476	conv_intrinsic_ieee_builtin (se, expr, code: BUILT_IN_ISFINITE, nargs: 1);
10477	else if (startswith (str: name, prefix: "_gfortran_ieee_unordered"))
10478	conv_intrinsic_ieee_builtin (se, expr, code: BUILT_IN_ISUNORDERED, nargs: 2);
10479	else if (startswith (str: name, prefix: "_gfortran_ieee_signbit"))
10480	conv_intrinsic_ieee_signbit (se, expr);
10481	else if (startswith (str: name, prefix: "_gfortran_ieee_is_normal"))
10482	conv_intrinsic_ieee_is_normal (se, expr);
10483	else if (startswith (str: name, prefix: "_gfortran_ieee_is_negative"))
10484	conv_intrinsic_ieee_is_negative (se, expr);
10485	else if (startswith (str: name, prefix: "_gfortran_ieee_copy_sign"))
10486	conv_intrinsic_ieee_copy_sign (se, expr);
10487	else if (startswith (str: name, prefix: "_gfortran_ieee_scalb"))
10488	conv_intrinsic_ieee_scalb (se, expr);
10489	else if (startswith (str: name, prefix: "_gfortran_ieee_next_after"))
10490	conv_intrinsic_ieee_next_after (se, expr);
10491	else if (startswith (str: name, prefix: "_gfortran_ieee_rem"))
10492	conv_intrinsic_ieee_rem (se, expr);
10493	else if (startswith (str: name, prefix: "_gfortran_ieee_logb"))
10494	conv_intrinsic_ieee_logb_rint (se, expr, code: BUILT_IN_LOGB);
10495	else if (startswith (str: name, prefix: "_gfortran_ieee_rint"))
10496	conv_intrinsic_ieee_logb_rint (se, expr, code: BUILT_IN_RINT);
10497	else if (startswith (str: name, prefix: "ieee_class_") && ISDIGIT (name[11]))
10498	conv_intrinsic_ieee_class (se, expr);
10499	else if (startswith (str: name, prefix: "ieee_value_") && ISDIGIT (name[11]))
10500	conv_intrinsic_ieee_value (se, expr);
10501	else if (startswith (str: name, prefix: "_gfortran_ieee_fma"))
10502	conv_intrinsic_ieee_fma (se, expr);
10503	else if (startswith (str: name, prefix: "_gfortran_ieee_min_num_"))
10504	conv_intrinsic_ieee_minmax (se, expr, max: 0, name: name + 23);
10505	else if (startswith (str: name, prefix: "_gfortran_ieee_max_num_"))
10506	conv_intrinsic_ieee_minmax (se, expr, max: 1, name: name + 23);
10507	else if (startswith (str: name, prefix: "_gfortran_ieee_quiet_"))
10508	conv_intrinsic_ieee_comparison (se, expr, signaling: 0, name: name + 21);
10509	else if (startswith (str: name, prefix: "_gfortran_ieee_signaling_"))
10510	conv_intrinsic_ieee_comparison (se, expr, signaling: 1, name: name + 25);
10511	else
10512	/* It is not among the functions we translate directly. We return
10513	false, so a library function call is emitted. */
10514	return false;
10515
10516	return true;
10517	}
10518
10519
10520	/* Generate a direct call to malloc() for the MALLOC intrinsic. */
10521
10522	static void
10523	gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
10524	{
10525	tree arg, res, restype;
10526
10527	gfc_conv_intrinsic_function_args (se, expr, argarray: &arg, nargs: 1);
10528	arg = fold_convert (size_type_node, arg);
10529	res = build_call_expr_loc (input_location,
10530	builtin_decl_explicit (fncode: BUILT_IN_MALLOC), 1, arg);
10531	restype = gfc_typenode_for_spec (&expr->ts);
10532	se->expr = fold_convert (restype, res);
10533	}
10534
10535
10536	/* Generate code for an intrinsic function. Some map directly to library
10537	calls, others get special handling. In some cases the name of the function
10538	used depends on the type specifiers. */
10539
10540	void
10541	gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
10542	{
10543	const char *name;
10544	int lib, kind;
10545	tree fndecl;
10546
10547	name = &expr->value.function.name[2];
10548
10549	if (expr->rank > 0)
10550	{
10551	lib = gfc_is_intrinsic_libcall (expr);
10552	if (lib != 0)
10553	{
10554	if (lib == 1)
10555	se->ignore_optional = 1;
10556
10557	switch (expr->value.function.isym->id)
10558	{
10559	case GFC_ISYM_EOSHIFT:
10560	case GFC_ISYM_PACK:
10561	case GFC_ISYM_RESHAPE:
10562	/* For all of those the first argument specifies the type and the
10563	third is optional. */
10564	conv_generic_with_optional_char_arg (se, expr, primary: 1, optional: 3);
10565	break;
10566
10567	case GFC_ISYM_FINDLOC:
10568	gfc_conv_intrinsic_findloc (se, expr);
10569	break;
10570
10571	case GFC_ISYM_MINLOC:
10572	gfc_conv_intrinsic_minmaxloc (se, expr, op: LT_EXPR);
10573	break;
10574
10575	case GFC_ISYM_MAXLOC:
10576	gfc_conv_intrinsic_minmaxloc (se, expr, op: GT_EXPR);
10577	break;
10578
10579	default:
10580	gfc_conv_intrinsic_funcall (se, expr);
10581	break;
10582	}
10583
10584	return;
10585	}
10586	}
10587
10588	switch (expr->value.function.isym->id)
10589	{
10590	case GFC_ISYM_NONE:
10591	gcc_unreachable ();
10592
10593	case GFC_ISYM_REPEAT:
10594	gfc_conv_intrinsic_repeat (se, expr);
10595	break;
10596
10597	case GFC_ISYM_TRIM:
10598	gfc_conv_intrinsic_trim (se, expr);
10599	break;
10600
10601	case GFC_ISYM_SC_KIND:
10602	gfc_conv_intrinsic_sc_kind (se, expr);
10603	break;
10604
10605	case GFC_ISYM_SI_KIND:
10606	gfc_conv_intrinsic_si_kind (se, expr);
10607	break;
10608
10609	case GFC_ISYM_SR_KIND:
10610	gfc_conv_intrinsic_sr_kind (se, expr);
10611	break;
10612
10613	case GFC_ISYM_EXPONENT:
10614	gfc_conv_intrinsic_exponent (se, expr);
10615	break;
10616
10617	case GFC_ISYM_SCAN:
10618	kind = expr->value.function.actual->expr->ts.kind;
10619	if (kind == 1)
10620	fndecl = gfor_fndecl_string_scan;
10621	else if (kind == 4)
10622	fndecl = gfor_fndecl_string_scan_char4;
10623	else
10624	gcc_unreachable ();
10625
10626	gfc_conv_intrinsic_index_scan_verify (se, expr, function: fndecl);
10627	break;
10628
10629	case GFC_ISYM_VERIFY:
10630	kind = expr->value.function.actual->expr->ts.kind;
10631	if (kind == 1)
10632	fndecl = gfor_fndecl_string_verify;
10633	else if (kind == 4)
10634	fndecl = gfor_fndecl_string_verify_char4;
10635	else
10636	gcc_unreachable ();
10637
10638	gfc_conv_intrinsic_index_scan_verify (se, expr, function: fndecl);
10639	break;
10640
10641	case GFC_ISYM_ALLOCATED:
10642	gfc_conv_allocated (se, expr);
10643	break;
10644
10645	case GFC_ISYM_ASSOCIATED:
10646	gfc_conv_associated(se, expr);
10647	break;
10648
10649	case GFC_ISYM_SAME_TYPE_AS:
10650	gfc_conv_same_type_as (se, expr);
10651	break;
10652
10653	case GFC_ISYM_ABS:
10654	gfc_conv_intrinsic_abs (se, expr);
10655	break;
10656
10657	case GFC_ISYM_ADJUSTL:
10658	if (expr->ts.kind == 1)
10659	fndecl = gfor_fndecl_adjustl;
10660	else if (expr->ts.kind == 4)
10661	fndecl = gfor_fndecl_adjustl_char4;
10662	else
10663	gcc_unreachable ();
10664
10665	gfc_conv_intrinsic_adjust (se, expr, fndecl);
10666	break;
10667
10668	case GFC_ISYM_ADJUSTR:
10669	if (expr->ts.kind == 1)
10670	fndecl = gfor_fndecl_adjustr;
10671	else if (expr->ts.kind == 4)
10672	fndecl = gfor_fndecl_adjustr_char4;
10673	else
10674	gcc_unreachable ();
10675
10676	gfc_conv_intrinsic_adjust (se, expr, fndecl);
10677	break;
10678
10679	case GFC_ISYM_AIMAG:
10680	gfc_conv_intrinsic_imagpart (se, expr);
10681	break;
10682
10683	case GFC_ISYM_AINT:
10684	gfc_conv_intrinsic_aint (se, expr, op: RND_TRUNC);
10685	break;
10686
10687	case GFC_ISYM_ALL:
10688	gfc_conv_intrinsic_anyall (se, expr, op: EQ_EXPR);
10689	break;
10690
10691	case GFC_ISYM_ANINT:
10692	gfc_conv_intrinsic_aint (se, expr, op: RND_ROUND);
10693	break;
10694
10695	case GFC_ISYM_AND:
10696	gfc_conv_intrinsic_bitop (se, expr, op: BIT_AND_EXPR);
10697	break;
10698
10699	case GFC_ISYM_ANY:
10700	gfc_conv_intrinsic_anyall (se, expr, op: NE_EXPR);
10701	break;
10702
10703	case GFC_ISYM_ACOSD:
10704	case GFC_ISYM_ASIND:
10705	case GFC_ISYM_ATAND:
10706	gfc_conv_intrinsic_atrigd (se, expr, id: expr->value.function.isym->id);
10707	break;
10708
10709	case GFC_ISYM_COTAN:
10710	gfc_conv_intrinsic_cotan (se, expr);
10711	break;
10712
10713	case GFC_ISYM_COTAND:
10714	gfc_conv_intrinsic_cotand (se, expr);
10715	break;
10716
10717	case GFC_ISYM_ATAN2D:
10718	gfc_conv_intrinsic_atan2d (se, expr);
10719	break;
10720
10721	case GFC_ISYM_BTEST:
10722	gfc_conv_intrinsic_btest (se, expr);
10723	break;
10724
10725	case GFC_ISYM_BGE:
10726	gfc_conv_intrinsic_bitcomp (se, expr, op: GE_EXPR);
10727	break;
10728
10729	case GFC_ISYM_BGT:
10730	gfc_conv_intrinsic_bitcomp (se, expr, op: GT_EXPR);
10731	break;
10732
10733	case GFC_ISYM_BLE:
10734	gfc_conv_intrinsic_bitcomp (se, expr, op: LE_EXPR);
10735	break;
10736
10737	case GFC_ISYM_BLT:
10738	gfc_conv_intrinsic_bitcomp (se, expr, op: LT_EXPR);
10739	break;
10740
10741	case GFC_ISYM_C_ASSOCIATED:
10742	case GFC_ISYM_C_FUNLOC:
10743	case GFC_ISYM_C_LOC:
10744	conv_isocbinding_function (se, expr);
10745	break;
10746
10747	case GFC_ISYM_ACHAR:
10748	case GFC_ISYM_CHAR:
10749	gfc_conv_intrinsic_char (se, expr);
10750	break;
10751
10752	case GFC_ISYM_CONVERSION:
10753	case GFC_ISYM_DBLE:
10754	case GFC_ISYM_DFLOAT:
10755	case GFC_ISYM_FLOAT:
10756	case GFC_ISYM_LOGICAL:
10757	case GFC_ISYM_REAL:
10758	case GFC_ISYM_REALPART:
10759	case GFC_ISYM_SNGL:
10760	gfc_conv_intrinsic_conversion (se, expr);
10761	break;
10762
10763	/* Integer conversions are handled separately to make sure we get the
10764	correct rounding mode. */
10765	case GFC_ISYM_INT:
10766	case GFC_ISYM_INT2:
10767	case GFC_ISYM_INT8:
10768	case GFC_ISYM_LONG:
10769	gfc_conv_intrinsic_int (se, expr, op: RND_TRUNC);
10770	break;
10771
10772	case GFC_ISYM_NINT:
10773	gfc_conv_intrinsic_int (se, expr, op: RND_ROUND);
10774	break;
10775
10776	case GFC_ISYM_CEILING:
10777	gfc_conv_intrinsic_int (se, expr, op: RND_CEIL);
10778	break;
10779
10780	case GFC_ISYM_FLOOR:
10781	gfc_conv_intrinsic_int (se, expr, op: RND_FLOOR);
10782	break;
10783
10784	case GFC_ISYM_MOD:
10785	gfc_conv_intrinsic_mod (se, expr, modulo: 0);
10786	break;
10787
10788	case GFC_ISYM_MODULO:
10789	gfc_conv_intrinsic_mod (se, expr, modulo: 1);
10790	break;
10791
10792	case GFC_ISYM_CAF_GET:
10793	gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
10794	may_realloc: false, NULL);
10795	break;
10796
10797	case GFC_ISYM_CMPLX:
10798	gfc_conv_intrinsic_cmplx (se, expr, both: name[5] == '1');
10799	break;
10800
10801	case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
10802	gfc_conv_intrinsic_iargc (se, expr);
10803	break;
10804
10805	case GFC_ISYM_COMPLEX:
10806	gfc_conv_intrinsic_cmplx (se, expr, both: 1);
10807	break;
10808
10809	case GFC_ISYM_CONJG:
10810	gfc_conv_intrinsic_conjg (se, expr);
10811	break;
10812
10813	case GFC_ISYM_COUNT:
10814	gfc_conv_intrinsic_count (se, expr);
10815	break;
10816
10817	case GFC_ISYM_CTIME:
10818	gfc_conv_intrinsic_ctime (se, expr);
10819	break;
10820
10821	case GFC_ISYM_DIM:
10822	gfc_conv_intrinsic_dim (se, expr);
10823	break;
10824
10825	case GFC_ISYM_DOT_PRODUCT:
10826	gfc_conv_intrinsic_dot_product (se, expr);
10827	break;
10828
10829	case GFC_ISYM_DPROD:
10830	gfc_conv_intrinsic_dprod (se, expr);
10831	break;
10832
10833	case GFC_ISYM_DSHIFTL:
10834	gfc_conv_intrinsic_dshift (se, expr, dshiftl: true);
10835	break;
10836
10837	case GFC_ISYM_DSHIFTR:
10838	gfc_conv_intrinsic_dshift (se, expr, dshiftl: false);
10839	break;
10840
10841	case GFC_ISYM_FDATE:
10842	gfc_conv_intrinsic_fdate (se, expr);
10843	break;
10844
10845	case GFC_ISYM_FRACTION:
10846	gfc_conv_intrinsic_fraction (se, expr);
10847	break;
10848
10849	case GFC_ISYM_IALL:
10850	gfc_conv_intrinsic_arith (se, expr, op: BIT_AND_EXPR, norm2: false);
10851	break;
10852
10853	case GFC_ISYM_IAND:
10854	gfc_conv_intrinsic_bitop (se, expr, op: BIT_AND_EXPR);
10855	break;
10856
10857	case GFC_ISYM_IANY:
10858	gfc_conv_intrinsic_arith (se, expr, op: BIT_IOR_EXPR, norm2: false);
10859	break;
10860
10861	case GFC_ISYM_IBCLR:
10862	gfc_conv_intrinsic_singlebitop (se, expr, set: 0);
10863	break;
10864
10865	case GFC_ISYM_IBITS:
10866	gfc_conv_intrinsic_ibits (se, expr);
10867	break;
10868
10869	case GFC_ISYM_IBSET:
10870	gfc_conv_intrinsic_singlebitop (se, expr, set: 1);
10871	break;
10872
10873	case GFC_ISYM_IACHAR:
10874	case GFC_ISYM_ICHAR:
10875	/* We assume ASCII character sequence. */
10876	gfc_conv_intrinsic_ichar (se, expr);
10877	break;
10878
10879	case GFC_ISYM_IARGC:
10880	gfc_conv_intrinsic_iargc (se, expr);
10881	break;
10882
10883	case GFC_ISYM_IEOR:
10884	gfc_conv_intrinsic_bitop (se, expr, op: BIT_XOR_EXPR);
10885	break;
10886
10887	case GFC_ISYM_INDEX:
10888	kind = expr->value.function.actual->expr->ts.kind;
10889	if (kind == 1)
10890	fndecl = gfor_fndecl_string_index;
10891	else if (kind == 4)
10892	fndecl = gfor_fndecl_string_index_char4;
10893	else
10894	gcc_unreachable ();
10895
10896	gfc_conv_intrinsic_index_scan_verify (se, expr, function: fndecl);
10897	break;
10898
10899	case GFC_ISYM_IOR:
10900	gfc_conv_intrinsic_bitop (se, expr, op: BIT_IOR_EXPR);
10901	break;
10902
10903	case GFC_ISYM_IPARITY:
10904	gfc_conv_intrinsic_arith (se, expr, op: BIT_XOR_EXPR, norm2: false);
10905	break;
10906
10907	case GFC_ISYM_IS_IOSTAT_END:
10908	gfc_conv_has_intvalue (se, expr, value: LIBERROR_END);
10909	break;
10910
10911	case GFC_ISYM_IS_IOSTAT_EOR:
10912	gfc_conv_has_intvalue (se, expr, value: LIBERROR_EOR);
10913	break;
10914
10915	case GFC_ISYM_IS_CONTIGUOUS:
10916	gfc_conv_intrinsic_is_contiguous (se, expr);
10917	break;
10918
10919	case GFC_ISYM_ISNAN:
10920	gfc_conv_intrinsic_isnan (se, expr);
10921	break;
10922
10923	case GFC_ISYM_KILL:
10924	conv_intrinsic_kill (se, expr);
10925	break;
10926
10927	case GFC_ISYM_LSHIFT:
10928	gfc_conv_intrinsic_shift (se, expr, right_shift: false, arithmetic: false);
10929	break;
10930
10931	case GFC_ISYM_RSHIFT:
10932	gfc_conv_intrinsic_shift (se, expr, right_shift: true, arithmetic: true);
10933	break;
10934
10935	case GFC_ISYM_SHIFTA:
10936	gfc_conv_intrinsic_shift (se, expr, right_shift: true, arithmetic: true);
10937	break;
10938
10939	case GFC_ISYM_SHIFTL:
10940	gfc_conv_intrinsic_shift (se, expr, right_shift: false, arithmetic: false);
10941	break;
10942
10943	case GFC_ISYM_SHIFTR:
10944	gfc_conv_intrinsic_shift (se, expr, right_shift: true, arithmetic: false);
10945	break;
10946
10947	case GFC_ISYM_ISHFT:
10948	gfc_conv_intrinsic_ishft (se, expr);
10949	break;
10950
10951	case GFC_ISYM_ISHFTC:
10952	gfc_conv_intrinsic_ishftc (se, expr);
10953	break;
10954
10955	case GFC_ISYM_LEADZ:
10956	gfc_conv_intrinsic_leadz (se, expr);
10957	break;
10958
10959	case GFC_ISYM_TRAILZ:
10960	gfc_conv_intrinsic_trailz (se, expr);
10961	break;
10962
10963	case GFC_ISYM_POPCNT:
10964	gfc_conv_intrinsic_popcnt_poppar (se, expr, parity: 0);
10965	break;
10966
10967	case GFC_ISYM_POPPAR:
10968	gfc_conv_intrinsic_popcnt_poppar (se, expr, parity: 1);
10969	break;
10970
10971	case GFC_ISYM_LBOUND:
10972	gfc_conv_intrinsic_bound (se, expr, op: GFC_ISYM_LBOUND);
10973	break;
10974
10975	case GFC_ISYM_LCOBOUND:
10976	conv_intrinsic_cobound (se, expr);
10977	break;
10978
10979	case GFC_ISYM_TRANSPOSE:
10980	/* The scalarizer has already been set up for reversed dimension access
10981	order ; now we just get the argument value normally. */
10982	gfc_conv_expr (se, expr: expr->value.function.actual->expr);
10983	break;
10984
10985	case GFC_ISYM_LEN:
10986	gfc_conv_intrinsic_len (se, expr);
10987	break;
10988
10989	case GFC_ISYM_LEN_TRIM:
10990	gfc_conv_intrinsic_len_trim (se, expr);
10991	break;
10992
10993	case GFC_ISYM_LGE:
10994	gfc_conv_intrinsic_strcmp (se, expr, op: GE_EXPR);
10995	break;
10996
10997	case GFC_ISYM_LGT:
10998	gfc_conv_intrinsic_strcmp (se, expr, op: GT_EXPR);
10999	break;
11000
11001	case GFC_ISYM_LLE:
11002	gfc_conv_intrinsic_strcmp (se, expr, op: LE_EXPR);
11003	break;
11004
11005	case GFC_ISYM_LLT:
11006	gfc_conv_intrinsic_strcmp (se, expr, op: LT_EXPR);
11007	break;
11008
11009	case GFC_ISYM_MALLOC:
11010	gfc_conv_intrinsic_malloc (se, expr);
11011	break;
11012
11013	case GFC_ISYM_MASKL:
11014	gfc_conv_intrinsic_mask (se, expr, left: 1);
11015	break;
11016
11017	case GFC_ISYM_MASKR:
11018	gfc_conv_intrinsic_mask (se, expr, left: 0);
11019	break;
11020
11021	case GFC_ISYM_MAX:
11022	if (expr->ts.type == BT_CHARACTER)
11023	gfc_conv_intrinsic_minmax_char (se, expr, op: 1);
11024	else
11025	gfc_conv_intrinsic_minmax (se, expr, op: GT_EXPR);
11026	break;
11027
11028	case GFC_ISYM_MAXLOC:
11029	gfc_conv_intrinsic_minmaxloc (se, expr, op: GT_EXPR);
11030	break;
11031
11032	case GFC_ISYM_FINDLOC:
11033	gfc_conv_intrinsic_findloc (se, expr);
11034	break;
11035
11036	case GFC_ISYM_MAXVAL:
11037	gfc_conv_intrinsic_minmaxval (se, expr, op: GT_EXPR);
11038	break;
11039
11040	case GFC_ISYM_MERGE:
11041	gfc_conv_intrinsic_merge (se, expr);
11042	break;
11043
11044	case GFC_ISYM_MERGE_BITS:
11045	gfc_conv_intrinsic_merge_bits (se, expr);
11046	break;
11047
11048	case GFC_ISYM_MIN:
11049	if (expr->ts.type == BT_CHARACTER)
11050	gfc_conv_intrinsic_minmax_char (se, expr, op: -1);
11051	else
11052	gfc_conv_intrinsic_minmax (se, expr, op: LT_EXPR);
11053	break;
11054
11055	case GFC_ISYM_MINLOC:
11056	gfc_conv_intrinsic_minmaxloc (se, expr, op: LT_EXPR);
11057	break;
11058
11059	case GFC_ISYM_MINVAL:
11060	gfc_conv_intrinsic_minmaxval (se, expr, op: LT_EXPR);
11061	break;
11062
11063	case GFC_ISYM_NEAREST:
11064	gfc_conv_intrinsic_nearest (se, expr);
11065	break;
11066
11067	case GFC_ISYM_NORM2:
11068	gfc_conv_intrinsic_arith (se, expr, op: PLUS_EXPR, norm2: true);
11069	break;
11070
11071	case GFC_ISYM_NOT:
11072	gfc_conv_intrinsic_not (se, expr);
11073	break;
11074
11075	case GFC_ISYM_OR:
11076	gfc_conv_intrinsic_bitop (se, expr, op: BIT_IOR_EXPR);
11077	break;
11078
11079	case GFC_ISYM_PARITY:
11080	gfc_conv_intrinsic_arith (se, expr, op: NE_EXPR, norm2: false);
11081	break;
11082
11083	case GFC_ISYM_PRESENT:
11084	gfc_conv_intrinsic_present (se, expr);
11085	break;
11086
11087	case GFC_ISYM_PRODUCT:
11088	gfc_conv_intrinsic_arith (se, expr, op: MULT_EXPR, norm2: false);
11089	break;
11090
11091	case GFC_ISYM_RANK:
11092	gfc_conv_intrinsic_rank (se, expr);
11093	break;
11094
11095	case GFC_ISYM_RRSPACING:
11096	gfc_conv_intrinsic_rrspacing (se, expr);
11097	break;
11098
11099	case GFC_ISYM_SET_EXPONENT:
11100	gfc_conv_intrinsic_set_exponent (se, expr);
11101	break;
11102
11103	case GFC_ISYM_SCALE:
11104	gfc_conv_intrinsic_scale (se, expr);
11105	break;
11106
11107	case GFC_ISYM_SHAPE:
11108	gfc_conv_intrinsic_bound (se, expr, op: GFC_ISYM_SHAPE);
11109	break;
11110
11111	case GFC_ISYM_SIGN:
11112	gfc_conv_intrinsic_sign (se, expr);
11113	break;
11114
11115	case GFC_ISYM_SIZE:
11116	gfc_conv_intrinsic_size (se, expr);
11117	break;
11118
11119	case GFC_ISYM_SIZEOF:
11120	case GFC_ISYM_C_SIZEOF:
11121	gfc_conv_intrinsic_sizeof (se, expr);
11122	break;
11123
11124	case GFC_ISYM_STORAGE_SIZE:
11125	gfc_conv_intrinsic_storage_size (se, expr);
11126	break;
11127
11128	case GFC_ISYM_SPACING:
11129	gfc_conv_intrinsic_spacing (se, expr);
11130	break;
11131
11132	case GFC_ISYM_STRIDE:
11133	conv_intrinsic_stride (se, expr);
11134	break;
11135
11136	case GFC_ISYM_SUM:
11137	gfc_conv_intrinsic_arith (se, expr, op: PLUS_EXPR, norm2: false);
11138	break;
11139
11140	case GFC_ISYM_TEAM_NUMBER:
11141	conv_intrinsic_team_number (se, expr);
11142	break;
11143
11144	case GFC_ISYM_TRANSFER:
11145	if (se->ss && se->ss->info->useflags)
11146	/* Access the previously obtained result. */
11147	gfc_conv_tmp_array_ref (se);
11148	else
11149	gfc_conv_intrinsic_transfer (se, expr);
11150	break;
11151
11152	case GFC_ISYM_TTYNAM:
11153	gfc_conv_intrinsic_ttynam (se, expr);
11154	break;
11155
11156	case GFC_ISYM_UBOUND:
11157	gfc_conv_intrinsic_bound (se, expr, op: GFC_ISYM_UBOUND);
11158	break;
11159
11160	case GFC_ISYM_UCOBOUND:
11161	conv_intrinsic_cobound (se, expr);
11162	break;
11163
11164	case GFC_ISYM_XOR:
11165	gfc_conv_intrinsic_bitop (se, expr, op: BIT_XOR_EXPR);
11166	break;
11167
11168	case GFC_ISYM_LOC:
11169	gfc_conv_intrinsic_loc (se, expr);
11170	break;
11171
11172	case GFC_ISYM_THIS_IMAGE:
11173	/* For num_images() == 1, handle as LCOBOUND. */
11174	if (expr->value.function.actual->expr
11175	&& flag_coarray == GFC_FCOARRAY_SINGLE)
11176	conv_intrinsic_cobound (se, expr);
11177	else
11178	trans_this_image (se, expr);
11179	break;
11180
11181	case GFC_ISYM_IMAGE_INDEX:
11182	trans_image_index (se, expr);
11183	break;
11184
11185	case GFC_ISYM_IMAGE_STATUS:
11186	conv_intrinsic_image_status (se, expr);
11187	break;
11188
11189	case GFC_ISYM_NUM_IMAGES:
11190	trans_num_images (se, expr);
11191	break;
11192
11193	case GFC_ISYM_ACCESS:
11194	case GFC_ISYM_CHDIR:
11195	case GFC_ISYM_CHMOD:
11196	case GFC_ISYM_DTIME:
11197	case GFC_ISYM_ETIME:
11198	case GFC_ISYM_EXTENDS_TYPE_OF:
11199	case GFC_ISYM_FGET:
11200	case GFC_ISYM_FGETC:
11201	case GFC_ISYM_FNUM:
11202	case GFC_ISYM_FPUT:
11203	case GFC_ISYM_FPUTC:
11204	case GFC_ISYM_FSTAT:
11205	case GFC_ISYM_FTELL:
11206	case GFC_ISYM_GETCWD:
11207	case GFC_ISYM_GETGID:
11208	case GFC_ISYM_GETPID:
11209	case GFC_ISYM_GETUID:
11210	case GFC_ISYM_HOSTNM:
11211	case GFC_ISYM_IERRNO:
11212	case GFC_ISYM_IRAND:
11213	case GFC_ISYM_ISATTY:
11214	case GFC_ISYM_JN2:
11215	case GFC_ISYM_LINK:
11216	case GFC_ISYM_LSTAT:
11217	case GFC_ISYM_MATMUL:
11218	case GFC_ISYM_MCLOCK:
11219	case GFC_ISYM_MCLOCK8:
11220	case GFC_ISYM_RAND:
11221	case GFC_ISYM_RENAME:
11222	case GFC_ISYM_SECOND:
11223	case GFC_ISYM_SECNDS:
11224	case GFC_ISYM_SIGNAL:
11225	case GFC_ISYM_STAT:
11226	case GFC_ISYM_SYMLNK:
11227	case GFC_ISYM_SYSTEM:
11228	case GFC_ISYM_TIME:
11229	case GFC_ISYM_TIME8:
11230	case GFC_ISYM_UMASK:
11231	case GFC_ISYM_UNLINK:
11232	case GFC_ISYM_YN2:
11233	gfc_conv_intrinsic_funcall (se, expr);
11234	break;
11235
11236	case GFC_ISYM_EOSHIFT:
11237	case GFC_ISYM_PACK:
11238	case GFC_ISYM_RESHAPE:
11239	/* For those, expr->rank should always be >0 and thus the if above the
11240	switch should have matched. */
11241	gcc_unreachable ();
11242	break;
11243
11244	default:
11245	gfc_conv_intrinsic_lib_function (se, expr);
11246	break;
11247	}
11248	}
11249
11250
11251	static gfc_ss *
11252	walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11253	{
11254	gfc_ss *arg_ss, *tmp_ss;
11255	gfc_actual_arglist *arg;
11256
11257	arg = expr->value.function.actual;
11258
11259	gcc_assert (arg->expr);
11260
11261	arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11262	gcc_assert (arg_ss != gfc_ss_terminator);
11263
11264	for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11265	{
11266	if (tmp_ss->info->type != GFC_SS_SCALAR
11267	&& tmp_ss->info->type != GFC_SS_REFERENCE)
11268	{
11269	gcc_assert (tmp_ss->dimen == 2);
11270
11271	/* We just invert dimensions. */
11272	std::swap (a&: tmp_ss->dim[0], b&: tmp_ss->dim[1]);
11273	}
11274
11275	/* Stop when tmp_ss points to the last valid element of the chain... */
11276	if (tmp_ss->next == gfc_ss_terminator)
11277	break;
11278	}
11279
11280	/* ... so that we can attach the rest of the chain to it. */
11281	tmp_ss->next = ss;
11282
11283	return arg_ss;
11284	}
11285
11286
11287	/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11288	This has the side effect of reversing the nested list, so there is no
11289	need to call gfc_reverse_ss on it (the given list is assumed not to be
11290	reversed yet). */
11291
11292	static gfc_ss *
11293	nest_loop_dimension (gfc_ss *ss, int dim)
11294	{
11295	int ss_dim, i;
11296	gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11297	gfc_loopinfo *new_loop;
11298
11299	gcc_assert (ss != gfc_ss_terminator);
11300
11301	for (; ss != gfc_ss_terminator; ss = ss->next)
11302	{
11303	new_ss = gfc_get_ss ();
11304	new_ss->next = prev_ss;
11305	new_ss->parent = ss;
11306	new_ss->info = ss->info;
11307	new_ss->info->refcount++;
11308	if (ss->dimen != 0)
11309	{
11310	gcc_assert (ss->info->type != GFC_SS_SCALAR
11311	&& ss->info->type != GFC_SS_REFERENCE);
11312
11313	new_ss->dimen = 1;
11314	new_ss->dim[0] = ss->dim[dim];
11315
11316	gcc_assert (dim < ss->dimen);
11317
11318	ss_dim = --ss->dimen;
11319	for (i = dim; i < ss_dim; i++)
11320	ss->dim[i] = ss->dim[i + 1];
11321
11322	ss->dim[ss_dim] = 0;
11323	}
11324	prev_ss = new_ss;
11325
11326	if (ss->nested_ss)
11327	{
11328	ss->nested_ss->parent = new_ss;
11329	new_ss->nested_ss = ss->nested_ss;
11330	}
11331	ss->nested_ss = new_ss;
11332	}
11333
11334	new_loop = gfc_get_loopinfo ();
11335	gfc_init_loopinfo (new_loop);
11336
11337	gcc_assert (prev_ss != NULL);
11338	gcc_assert (prev_ss != gfc_ss_terminator);
11339	gfc_add_ss_to_loop (new_loop, prev_ss);
11340	return new_ss->parent;
11341	}
11342
11343
11344	/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11345	is to be inlined. */
11346
11347	static gfc_ss *
11348	walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
11349	{
11350	gfc_ss *tmp_ss, *tail, *array_ss;
11351	gfc_actual_arglist *arg1, *arg2, *arg3;
11352	int sum_dim;
11353	bool scalar_mask = false;
11354
11355	/* The rank of the result will be determined later. */
11356	arg1 = expr->value.function.actual;
11357	arg2 = arg1->next;
11358	arg3 = arg2->next;
11359	gcc_assert (arg3 != NULL);
11360
11361	if (expr->rank == 0)
11362	return ss;
11363
11364	tmp_ss = gfc_ss_terminator;
11365
11366	if (arg3->expr)
11367	{
11368	gfc_ss *mask_ss;
11369
11370	mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
11371	if (mask_ss == tmp_ss)
11372	scalar_mask = 1;
11373
11374	tmp_ss = mask_ss;
11375	}
11376
11377	array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
11378	gcc_assert (array_ss != tmp_ss);
11379
11380	/* Odd thing: If the mask is scalar, it is used by the frontend after
11381	the array (to make an if around the nested loop). Thus it shall
11382	be after array_ss once the gfc_ss list is reversed. */
11383	if (scalar_mask)
11384	tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
11385	else
11386	tmp_ss = array_ss;
11387
11388	/* "Hide" the dimension on which we will sum in the first arg's scalarization
11389	chain. */
11390	sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
11391	tail = nest_loop_dimension (ss: tmp_ss, dim: sum_dim);
11392	tail->next = ss;
11393
11394	return tmp_ss;
11395	}
11396
11397
11398	static gfc_ss *
11399	walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
11400	{
11401
11402	switch (expr->value.function.isym->id)
11403	{
11404	case GFC_ISYM_PRODUCT:
11405	case GFC_ISYM_SUM:
11406	return walk_inline_intrinsic_arith (ss, expr);
11407
11408	case GFC_ISYM_TRANSPOSE:
11409	return walk_inline_intrinsic_transpose (ss, expr);
11410
11411	default:
11412	gcc_unreachable ();
11413	}
11414	gcc_unreachable ();
11415	}
11416
11417
11418	/* This generates code to execute before entering the scalarization loop.
11419	Currently does nothing. */
11420
11421	void
11422	gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
11423	{
11424	switch (ss->info->expr->value.function.isym->id)
11425	{
11426	case GFC_ISYM_UBOUND:
11427	case GFC_ISYM_LBOUND:
11428	case GFC_ISYM_UCOBOUND:
11429	case GFC_ISYM_LCOBOUND:
11430	case GFC_ISYM_THIS_IMAGE:
11431	case GFC_ISYM_SHAPE:
11432	break;
11433
11434	default:
11435	gcc_unreachable ();
11436	}
11437	}
11438
11439
11440	/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
11441	one parameter are expanded into code inside the scalarization loop. */
11442
11443	static gfc_ss *
11444	gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
11445	{
11446	if (expr->value.function.actual->expr->ts.type == BT_CLASS)
11447	gfc_add_class_array_ref (expr->value.function.actual->expr);
11448
11449	/* The two argument version returns a scalar. */
11450	if (expr->value.function.isym->id != GFC_ISYM_SHAPE
11451	&& expr->value.function.actual->next->expr)
11452	return ss;
11453
11454	return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11455	}
11456
11457
11458	/* Walk an intrinsic array libcall. */
11459
11460	static gfc_ss *
11461	gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
11462	{
11463	gcc_assert (expr->rank > 0);
11464	return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
11465	}
11466
11467
11468	/* Return whether the function call expression EXPR will be expanded
11469	inline by gfc_conv_intrinsic_function. */
11470
11471	bool
11472	gfc_inline_intrinsic_function_p (gfc_expr *expr)
11473	{
11474	gfc_actual_arglist *args, *dim_arg, *mask_arg;
11475	gfc_expr *maskexpr;
11476
11477	if (!expr->value.function.isym)
11478	return false;
11479
11480	switch (expr->value.function.isym->id)
11481	{
11482	case GFC_ISYM_PRODUCT:
11483	case GFC_ISYM_SUM:
11484	/* Disable inline expansion if code size matters. */
11485	if (optimize_size)
11486	return false;
11487
11488	args = expr->value.function.actual;
11489	dim_arg = args->next;
11490
11491	/* We need to be able to subset the SUM argument at compile-time. */
11492	if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
11493	return false;
11494
11495	/* FIXME: If MASK is optional for a more than two-dimensional
11496	argument, the scalarizer gets confused if the mask is
11497	absent. See PR 82995. For now, fall back to the library
11498	function. */
11499
11500	mask_arg = dim_arg->next;
11501	maskexpr = mask_arg->expr;
11502
11503	if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
11504	&& maskexpr->symtree->n.sym->attr.dummy
11505	&& maskexpr->symtree->n.sym->attr.optional)
11506	return false;
11507
11508	return true;
11509
11510	case GFC_ISYM_TRANSPOSE:
11511	return true;
11512
11513	default:
11514	return false;
11515	}
11516	}
11517
11518
11519	/* Returns nonzero if the specified intrinsic function call maps directly to
11520	an external library call. Should only be used for functions that return
11521	arrays. */
11522
11523	int
11524	gfc_is_intrinsic_libcall (gfc_expr * expr)
11525	{
11526	gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
11527	gcc_assert (expr->rank > 0);
11528
11529	if (gfc_inline_intrinsic_function_p (expr))
11530	return 0;
11531
11532	switch (expr->value.function.isym->id)
11533	{
11534	case GFC_ISYM_ALL:
11535	case GFC_ISYM_ANY:
11536	case GFC_ISYM_COUNT:
11537	case GFC_ISYM_FINDLOC:
11538	case GFC_ISYM_JN2:
11539	case GFC_ISYM_IANY:
11540	case GFC_ISYM_IALL:
11541	case GFC_ISYM_IPARITY:
11542	case GFC_ISYM_MATMUL:
11543	case GFC_ISYM_MAXLOC:
11544	case GFC_ISYM_MAXVAL:
11545	case GFC_ISYM_MINLOC:
11546	case GFC_ISYM_MINVAL:
11547	case GFC_ISYM_NORM2:
11548	case GFC_ISYM_PARITY:
11549	case GFC_ISYM_PRODUCT:
11550	case GFC_ISYM_SUM:
11551	case GFC_ISYM_SPREAD:
11552	case GFC_ISYM_YN2:
11553	/* Ignore absent optional parameters. */
11554	return 1;
11555
11556	case GFC_ISYM_CSHIFT:
11557	case GFC_ISYM_EOSHIFT:
11558	case GFC_ISYM_GET_TEAM:
11559	case GFC_ISYM_FAILED_IMAGES:
11560	case GFC_ISYM_STOPPED_IMAGES:
11561	case GFC_ISYM_PACK:
11562	case GFC_ISYM_RESHAPE:
11563	case GFC_ISYM_UNPACK:
11564	/* Pass absent optional parameters. */
11565	return 2;
11566
11567	default:
11568	return 0;
11569	}
11570	}
11571
11572	/* Walk an intrinsic function. */
11573	gfc_ss *
11574	gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
11575	gfc_intrinsic_sym * isym)
11576	{
11577	gcc_assert (isym);
11578
11579	if (isym->elemental)
11580	return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
11581	expr->value.function.isym,
11582	GFC_SS_SCALAR);
11583
11584	if (expr->rank == 0)
11585	return ss;
11586
11587	if (gfc_inline_intrinsic_function_p (expr))
11588	return walk_inline_intrinsic_function (ss, expr);
11589
11590	if (gfc_is_intrinsic_libcall (expr))
11591	return gfc_walk_intrinsic_libfunc (ss, expr);
11592
11593	/* Special cases. */
11594	switch (isym->id)
11595	{
11596	case GFC_ISYM_LBOUND:
11597	case GFC_ISYM_LCOBOUND:
11598	case GFC_ISYM_UBOUND:
11599	case GFC_ISYM_UCOBOUND:
11600	case GFC_ISYM_THIS_IMAGE:
11601	case GFC_ISYM_SHAPE:
11602	return gfc_walk_intrinsic_bound (ss, expr);
11603
11604	case GFC_ISYM_TRANSFER:
11605	case GFC_ISYM_CAF_GET:
11606	return gfc_walk_intrinsic_libfunc (ss, expr);
11607
11608	default:
11609	/* This probably meant someone forgot to add an intrinsic to the above
11610	list(s) when they implemented it, or something's gone horribly
11611	wrong. */
11612	gcc_unreachable ();
11613	}
11614	}
11615
11616	static tree
11617	conv_co_collective (gfc_code *code)
11618	{
11619	gfc_se argse;
11620	stmtblock_t block, post_block;
11621	tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
11622	gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
11623
11624	gfc_start_block (&block);
11625	gfc_init_block (&post_block);
11626
11627	if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
11628	{
11629	opr_expr = code->ext.actual->next->expr;
11630	image_idx_expr = code->ext.actual->next->next->expr;
11631	stat_expr = code->ext.actual->next->next->next->expr;
11632	errmsg_expr = code->ext.actual->next->next->next->next->expr;
11633	}
11634	else
11635	{
11636	opr_expr = NULL;
11637	image_idx_expr = code->ext.actual->next->expr;
11638	stat_expr = code->ext.actual->next->next->expr;
11639	errmsg_expr = code->ext.actual->next->next->next->expr;
11640	}
11641
11642	/* stat. */
11643	if (stat_expr)
11644	{
11645	gfc_init_se (&argse, NULL);
11646	gfc_conv_expr (se: &argse, expr: stat_expr);
11647	gfc_add_block_to_block (&block, &argse.pre);
11648	gfc_add_block_to_block (&post_block, &argse.post);
11649	stat = argse.expr;
11650	if (flag_coarray != GFC_FCOARRAY_SINGLE)
11651	stat = gfc_build_addr_expr (NULL_TREE, stat);
11652	}
11653	else if (flag_coarray == GFC_FCOARRAY_SINGLE)
11654	stat = NULL_TREE;
11655	else
11656	stat = null_pointer_node;
11657
11658	/* Early exit for GFC_FCOARRAY_SINGLE. */
11659	if (flag_coarray == GFC_FCOARRAY_SINGLE)
11660	{
11661	if (stat != NULL_TREE)
11662	{
11663	/* For optional stats, check the pointer is valid before zero'ing. */
11664	if (gfc_expr_attr (stat_expr).optional)
11665	{
11666	tree tmp;
11667	stmtblock_t ass_block;
11668	gfc_start_block (&ass_block);
11669	gfc_add_modify (&ass_block, stat,
11670	fold_convert (TREE_TYPE (stat),
11671	integer_zero_node));
11672	tmp = fold_build2 (NE_EXPR, logical_type_node,
11673	gfc_build_addr_expr (NULL_TREE, stat),
11674	null_pointer_node);
11675	tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
11676	gfc_finish_block (&ass_block),
11677	build_empty_stmt (input_location));
11678	gfc_add_expr_to_block (&block, tmp);
11679	}
11680	else
11681	gfc_add_modify (&block, stat,
11682	fold_convert (TREE_TYPE (stat), integer_zero_node));
11683	}
11684	return gfc_finish_block (&block);
11685	}
11686
11687	gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
11688	? code->ext.actual->expr->ts.u.derived : NULL;
11689
11690	/* Handle the array. */
11691	gfc_init_se (&argse, NULL);
11692	if (!derived || !derived->attr.alloc_comp
11693	|| code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
11694	{
11695	if (code->ext.actual->expr->rank == 0)
11696	{
11697	symbol_attribute attr;
11698	gfc_clear_attr (&attr);
11699	gfc_init_se (&argse, NULL);
11700	gfc_conv_expr (se: &argse, expr: code->ext.actual->expr);
11701	gfc_add_block_to_block (&block, &argse.pre);
11702	gfc_add_block_to_block (&post_block, &argse.post);
11703	array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
11704	array = gfc_build_addr_expr (NULL_TREE, array);
11705	}
11706	else
11707	{
11708	argse.want_pointer = 1;
11709	gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
11710	array = argse.expr;
11711	}
11712	}
11713
11714	gfc_add_block_to_block (&block, &argse.pre);
11715	gfc_add_block_to_block (&post_block, &argse.post);
11716
11717	if (code->ext.actual->expr->ts.type == BT_CHARACTER)
11718	strlen = argse.string_length;
11719	else
11720	strlen = integer_zero_node;
11721
11722	/* image_index. */
11723	if (image_idx_expr)
11724	{
11725	gfc_init_se (&argse, NULL);
11726	gfc_conv_expr (se: &argse, expr: image_idx_expr);
11727	gfc_add_block_to_block (&block, &argse.pre);
11728	gfc_add_block_to_block (&post_block, &argse.post);
11729	image_index = fold_convert (integer_type_node, argse.expr);
11730	}
11731	else
11732	image_index = integer_zero_node;
11733
11734	/* errmsg. */
11735	if (errmsg_expr)
11736	{
11737	gfc_init_se (&argse, NULL);
11738	gfc_conv_expr (se: &argse, expr: errmsg_expr);
11739	gfc_add_block_to_block (&block, &argse.pre);
11740	gfc_add_block_to_block (&post_block, &argse.post);
11741	errmsg = argse.expr;
11742	errmsg_len = fold_convert (size_type_node, argse.string_length);
11743	}
11744	else
11745	{
11746	errmsg = null_pointer_node;
11747	errmsg_len = build_zero_cst (size_type_node);
11748	}
11749
11750	/* Generate the function call. */
11751	switch (code->resolved_isym->id)
11752	{
11753	case GFC_ISYM_CO_BROADCAST:
11754	fndecl = gfor_fndecl_co_broadcast;
11755	break;
11756	case GFC_ISYM_CO_MAX:
11757	fndecl = gfor_fndecl_co_max;
11758	break;
11759	case GFC_ISYM_CO_MIN:
11760	fndecl = gfor_fndecl_co_min;
11761	break;
11762	case GFC_ISYM_CO_REDUCE:
11763	fndecl = gfor_fndecl_co_reduce;
11764	break;
11765	case GFC_ISYM_CO_SUM:
11766	fndecl = gfor_fndecl_co_sum;
11767	break;
11768	default:
11769	gcc_unreachable ();
11770	}
11771
11772	if (derived && derived->attr.alloc_comp
11773	&& code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
11774	/* The derived type has the attribute 'alloc_comp'. */
11775	{
11776	tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
11777	code->ext.actual->expr->rank,
11778	image_index, stat, errmsg, errmsg_len);
11779	gfc_add_expr_to_block (&block, tmp);
11780	}
11781	else
11782	{
11783	if (code->resolved_isym->id == GFC_ISYM_CO_SUM
11784	|| code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
11785	fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
11786	image_index, stat, errmsg, errmsg_len);
11787	else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
11788	fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
11789	image_index, stat, errmsg,
11790	strlen, errmsg_len);
11791	else
11792	{
11793	tree opr, opr_flags;
11794
11795	// FIXME: Handle TS29113's bind(C) strings with descriptor.
11796	int opr_flag_int;
11797	if (gfc_is_proc_ptr_comp (opr_expr))
11798	{
11799	gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
11800	opr_flag_int = sym->attr.dimension
11801	|| (sym->ts.type == BT_CHARACTER
11802	&& !sym->attr.is_bind_c)
11803	? GFC_CAF_BYREF : 0;
11804	opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
11805	&& !sym->attr.is_bind_c
11806	? GFC_CAF_HIDDENLEN : 0;
11807	opr_flag_int |= sym->formal->sym->attr.value
11808	? GFC_CAF_ARG_VALUE : 0;
11809	}
11810	else
11811	{
11812	opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
11813	? GFC_CAF_BYREF : 0;
11814	opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
11815	&& !opr_expr->symtree->n.sym->attr.is_bind_c
11816	? GFC_CAF_HIDDENLEN : 0;
11817	opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
11818	? GFC_CAF_ARG_VALUE : 0;
11819	}
11820	opr_flags = build_int_cst (integer_type_node, opr_flag_int);
11821	gfc_conv_expr (se: &argse, expr: opr_expr);
11822	opr = argse.expr;
11823	fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
11824	opr_flags, image_index, stat, errmsg,
11825	strlen, errmsg_len);
11826	}
11827	}
11828
11829	gfc_add_expr_to_block (&block, fndecl);
11830	gfc_add_block_to_block (&block, &post_block);
11831
11832	return gfc_finish_block (&block);
11833	}
11834
11835
11836	static tree
11837	conv_intrinsic_atomic_op (gfc_code *code)
11838	{
11839	gfc_se argse;
11840	tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
11841	stmtblock_t block, post_block;
11842	gfc_expr *atom_expr = code->ext.actual->expr;
11843	gfc_expr *stat_expr;
11844	built_in_function fn;
11845
11846	if (atom_expr->expr_type == EXPR_FUNCTION
11847	&& atom_expr->value.function.isym
11848	&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11849	atom_expr = atom_expr->value.function.actual->expr;
11850
11851	gfc_start_block (&block);
11852	gfc_init_block (&post_block);
11853
11854	gfc_init_se (&argse, NULL);
11855	argse.want_pointer = 1;
11856	gfc_conv_expr (se: &argse, expr: atom_expr);
11857	gfc_add_block_to_block (&block, &argse.pre);
11858	gfc_add_block_to_block (&post_block, &argse.post);
11859	atom = argse.expr;
11860
11861	gfc_init_se (&argse, NULL);
11862	if (flag_coarray == GFC_FCOARRAY_LIB
11863	&& code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
11864	argse.want_pointer = 1;
11865	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->expr);
11866	gfc_add_block_to_block (&block, &argse.pre);
11867	gfc_add_block_to_block (&post_block, &argse.post);
11868	value = argse.expr;
11869
11870	switch (code->resolved_isym->id)
11871	{
11872	case GFC_ISYM_ATOMIC_ADD:
11873	case GFC_ISYM_ATOMIC_AND:
11874	case GFC_ISYM_ATOMIC_DEF:
11875	case GFC_ISYM_ATOMIC_OR:
11876	case GFC_ISYM_ATOMIC_XOR:
11877	stat_expr = code->ext.actual->next->next->expr;
11878	if (flag_coarray == GFC_FCOARRAY_LIB)
11879	old = null_pointer_node;
11880	break;
11881	default:
11882	gfc_init_se (&argse, NULL);
11883	if (flag_coarray == GFC_FCOARRAY_LIB)
11884	argse.want_pointer = 1;
11885	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->next->expr);
11886	gfc_add_block_to_block (&block, &argse.pre);
11887	gfc_add_block_to_block (&post_block, &argse.post);
11888	old = argse.expr;
11889	stat_expr = code->ext.actual->next->next->next->expr;
11890	}
11891
11892	/* STAT= */
11893	if (stat_expr != NULL)
11894	{
11895	gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
11896	gfc_init_se (&argse, NULL);
11897	if (flag_coarray == GFC_FCOARRAY_LIB)
11898	argse.want_pointer = 1;
11899	gfc_conv_expr_val (se: &argse, expr: stat_expr);
11900	gfc_add_block_to_block (&block, &argse.pre);
11901	gfc_add_block_to_block (&post_block, &argse.post);
11902	stat = argse.expr;
11903	}
11904	else if (flag_coarray == GFC_FCOARRAY_LIB)
11905	stat = null_pointer_node;
11906
11907	if (flag_coarray == GFC_FCOARRAY_LIB)
11908	{
11909	tree image_index, caf_decl, offset, token;
11910	int op;
11911
11912	switch (code->resolved_isym->id)
11913	{
11914	case GFC_ISYM_ATOMIC_ADD:
11915	case GFC_ISYM_ATOMIC_FETCH_ADD:
11916	op = (int) GFC_CAF_ATOMIC_ADD;
11917	break;
11918	case GFC_ISYM_ATOMIC_AND:
11919	case GFC_ISYM_ATOMIC_FETCH_AND:
11920	op = (int) GFC_CAF_ATOMIC_AND;
11921	break;
11922	case GFC_ISYM_ATOMIC_OR:
11923	case GFC_ISYM_ATOMIC_FETCH_OR:
11924	op = (int) GFC_CAF_ATOMIC_OR;
11925	break;
11926	case GFC_ISYM_ATOMIC_XOR:
11927	case GFC_ISYM_ATOMIC_FETCH_XOR:
11928	op = (int) GFC_CAF_ATOMIC_XOR;
11929	break;
11930	case GFC_ISYM_ATOMIC_DEF:
11931	op = 0; /* Unused. */
11932	break;
11933	default:
11934	gcc_unreachable ();
11935	}
11936
11937	caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11938	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11939	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11940
11941	if (gfc_is_coindexed (atom_expr))
11942	image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11943	else
11944	image_index = integer_zero_node;
11945
11946	if (!POINTER_TYPE_P (TREE_TYPE (value)))
11947	{
11948	tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
11949	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
11950	value = gfc_build_addr_expr (NULL_TREE, tmp);
11951	}
11952
11953	gfc_init_se (&argse, NULL);
11954	gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11955	atom_expr);
11956
11957	gfc_add_block_to_block (&block, &argse.pre);
11958	if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
11959	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
11960	token, offset, image_index, value, stat,
11961	build_int_cst (integer_type_node,
11962	(int) atom_expr->ts.type),
11963	build_int_cst (integer_type_node,
11964	(int) atom_expr->ts.kind));
11965	else
11966	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
11967	build_int_cst (integer_type_node, op),
11968	token, offset, image_index, value, old, stat,
11969	build_int_cst (integer_type_node,
11970	(int) atom_expr->ts.type),
11971	build_int_cst (integer_type_node,
11972	(int) atom_expr->ts.kind));
11973
11974	gfc_add_expr_to_block (&block, tmp);
11975	gfc_add_block_to_block (&block, &argse.post);
11976	gfc_add_block_to_block (&block, &post_block);
11977	return gfc_finish_block (&block);
11978	}
11979
11980
11981	switch (code->resolved_isym->id)
11982	{
11983	case GFC_ISYM_ATOMIC_ADD:
11984	case GFC_ISYM_ATOMIC_FETCH_ADD:
11985	fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
11986	break;
11987	case GFC_ISYM_ATOMIC_AND:
11988	case GFC_ISYM_ATOMIC_FETCH_AND:
11989	fn = BUILT_IN_ATOMIC_FETCH_AND_N;
11990	break;
11991	case GFC_ISYM_ATOMIC_DEF:
11992	fn = BUILT_IN_ATOMIC_STORE_N;
11993	break;
11994	case GFC_ISYM_ATOMIC_OR:
11995	case GFC_ISYM_ATOMIC_FETCH_OR:
11996	fn = BUILT_IN_ATOMIC_FETCH_OR_N;
11997	break;
11998	case GFC_ISYM_ATOMIC_XOR:
11999	case GFC_ISYM_ATOMIC_FETCH_XOR:
12000	fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12001	break;
12002	default:
12003	gcc_unreachable ();
12004	}
12005
12006	tmp = TREE_TYPE (TREE_TYPE (atom));
12007	fn = (built_in_function) ((int) fn
12008	+ exact_log2 (x: tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12009	+ 1);
12010	tree itype = TREE_TYPE (TREE_TYPE (atom));
12011	tmp = builtin_decl_explicit (fncode: fn);
12012
12013	switch (code->resolved_isym->id)
12014	{
12015	case GFC_ISYM_ATOMIC_ADD:
12016	case GFC_ISYM_ATOMIC_AND:
12017	case GFC_ISYM_ATOMIC_DEF:
12018	case GFC_ISYM_ATOMIC_OR:
12019	case GFC_ISYM_ATOMIC_XOR:
12020	tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12021	fold_convert (itype, value),
12022	build_int_cst (NULL, MEMMODEL_RELAXED));
12023	gfc_add_expr_to_block (&block, tmp);
12024	break;
12025	default:
12026	tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12027	fold_convert (itype, value),
12028	build_int_cst (NULL, MEMMODEL_RELAXED));
12029	gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12030	break;
12031	}
12032
12033	if (stat != NULL_TREE)
12034	gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12035	gfc_add_block_to_block (&block, &post_block);
12036	return gfc_finish_block (&block);
12037	}
12038
12039
12040	static tree
12041	conv_intrinsic_atomic_ref (gfc_code *code)
12042	{
12043	gfc_se argse;
12044	tree tmp, atom, value, stat = NULL_TREE;
12045	stmtblock_t block, post_block;
12046	built_in_function fn;
12047	gfc_expr *atom_expr = code->ext.actual->next->expr;
12048
12049	if (atom_expr->expr_type == EXPR_FUNCTION
12050	&& atom_expr->value.function.isym
12051	&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12052	atom_expr = atom_expr->value.function.actual->expr;
12053
12054	gfc_start_block (&block);
12055	gfc_init_block (&post_block);
12056	gfc_init_se (&argse, NULL);
12057	argse.want_pointer = 1;
12058	gfc_conv_expr (se: &argse, expr: atom_expr);
12059	gfc_add_block_to_block (&block, &argse.pre);
12060	gfc_add_block_to_block (&post_block, &argse.post);
12061	atom = argse.expr;
12062
12063	gfc_init_se (&argse, NULL);
12064	if (flag_coarray == GFC_FCOARRAY_LIB
12065	&& code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12066	argse.want_pointer = 1;
12067	gfc_conv_expr (se: &argse, expr: code->ext.actual->expr);
12068	gfc_add_block_to_block (&block, &argse.pre);
12069	gfc_add_block_to_block (&post_block, &argse.post);
12070	value = argse.expr;
12071
12072	/* STAT= */
12073	if (code->ext.actual->next->next->expr != NULL)
12074	{
12075	gcc_assert (code->ext.actual->next->next->expr->expr_type
12076	== EXPR_VARIABLE);
12077	gfc_init_se (&argse, NULL);
12078	if (flag_coarray == GFC_FCOARRAY_LIB)
12079	argse.want_pointer = 1;
12080	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->next->next->expr);
12081	gfc_add_block_to_block (&block, &argse.pre);
12082	gfc_add_block_to_block (&post_block, &argse.post);
12083	stat = argse.expr;
12084	}
12085	else if (flag_coarray == GFC_FCOARRAY_LIB)
12086	stat = null_pointer_node;
12087
12088	if (flag_coarray == GFC_FCOARRAY_LIB)
12089	{
12090	tree image_index, caf_decl, offset, token;
12091	tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12092
12093	caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12094	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12095	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12096
12097	if (gfc_is_coindexed (atom_expr))
12098	image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12099	else
12100	image_index = integer_zero_node;
12101
12102	gfc_init_se (&argse, NULL);
12103	gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12104	atom_expr);
12105	gfc_add_block_to_block (&block, &argse.pre);
12106
12107	/* Different type, need type conversion. */
12108	if (!POINTER_TYPE_P (TREE_TYPE (value)))
12109	{
12110	vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12111	orig_value = value;
12112	value = gfc_build_addr_expr (NULL_TREE, vardecl);
12113	}
12114
12115	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12116	token, offset, image_index, value, stat,
12117	build_int_cst (integer_type_node,
12118	(int) atom_expr->ts.type),
12119	build_int_cst (integer_type_node,
12120	(int) atom_expr->ts.kind));
12121	gfc_add_expr_to_block (&block, tmp);
12122	if (vardecl != NULL_TREE)
12123	gfc_add_modify (&block, orig_value,
12124	fold_convert (TREE_TYPE (orig_value), vardecl));
12125	gfc_add_block_to_block (&block, &argse.post);
12126	gfc_add_block_to_block (&block, &post_block);
12127	return gfc_finish_block (&block);
12128	}
12129
12130	tmp = TREE_TYPE (TREE_TYPE (atom));
12131	fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12132	+ exact_log2 (x: tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12133	+ 1);
12134	tmp = builtin_decl_explicit (fncode: fn);
12135	tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12136	build_int_cst (integer_type_node,
12137	MEMMODEL_RELAXED));
12138	gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12139
12140	if (stat != NULL_TREE)
12141	gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12142	gfc_add_block_to_block (&block, &post_block);
12143	return gfc_finish_block (&block);
12144	}
12145
12146
12147	static tree
12148	conv_intrinsic_atomic_cas (gfc_code *code)
12149	{
12150	gfc_se argse;
12151	tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12152	stmtblock_t block, post_block;
12153	built_in_function fn;
12154	gfc_expr *atom_expr = code->ext.actual->expr;
12155
12156	if (atom_expr->expr_type == EXPR_FUNCTION
12157	&& atom_expr->value.function.isym
12158	&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12159	atom_expr = atom_expr->value.function.actual->expr;
12160
12161	gfc_init_block (&block);
12162	gfc_init_block (&post_block);
12163	gfc_init_se (&argse, NULL);
12164	argse.want_pointer = 1;
12165	gfc_conv_expr (se: &argse, expr: atom_expr);
12166	atom = argse.expr;
12167
12168	gfc_init_se (&argse, NULL);
12169	if (flag_coarray == GFC_FCOARRAY_LIB)
12170	argse.want_pointer = 1;
12171	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->expr);
12172	gfc_add_block_to_block (&block, &argse.pre);
12173	gfc_add_block_to_block (&post_block, &argse.post);
12174	old = argse.expr;
12175
12176	gfc_init_se (&argse, NULL);
12177	if (flag_coarray == GFC_FCOARRAY_LIB)
12178	argse.want_pointer = 1;
12179	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->next->expr);
12180	gfc_add_block_to_block (&block, &argse.pre);
12181	gfc_add_block_to_block (&post_block, &argse.post);
12182	comp = argse.expr;
12183
12184	gfc_init_se (&argse, NULL);
12185	if (flag_coarray == GFC_FCOARRAY_LIB
12186	&& code->ext.actual->next->next->next->expr->ts.kind
12187	== atom_expr->ts.kind)
12188	argse.want_pointer = 1;
12189	gfc_conv_expr (se: &argse, expr: code->ext.actual->next->next->next->expr);
12190	gfc_add_block_to_block (&block, &argse.pre);
12191	gfc_add_block_to_block (&post_block, &argse.post);
12192	new_val = argse.expr;
12193
12194	/* STAT= */
12195	if (code->ext.actual->next->next->next->next->expr != NULL)
12196	{
12197	gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
12198	== EXPR_VARIABLE);
12199	gfc_init_se (&argse, NULL);
12200	if (flag_coarray == GFC_FCOARRAY_LIB)
12201	argse.want_pointer = 1;
12202	gfc_conv_expr_val (se: &argse,
12203	expr: code->ext.actual->next->next->next->next->expr);
12204	gfc_add_block_to_block (&block, &argse.pre);
12205	gfc_add_block_to_block (&post_block, &argse.post);
12206	stat = argse.expr;
12207	}
12208	else if (flag_coarray == GFC_FCOARRAY_LIB)
12209	stat = null_pointer_node;
12210
12211	if (flag_coarray == GFC_FCOARRAY_LIB)
12212	{
12213	tree image_index, caf_decl, offset, token;
12214
12215	caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12216	if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12217	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12218
12219	if (gfc_is_coindexed (atom_expr))
12220	image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12221	else
12222	image_index = integer_zero_node;
12223
12224	if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
12225	{
12226	tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
12227	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
12228	new_val = gfc_build_addr_expr (NULL_TREE, tmp);
12229	}
12230
12231	/* Convert a constant to a pointer. */
12232	if (!POINTER_TYPE_P (TREE_TYPE (comp)))
12233	{
12234	tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
12235	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
12236	comp = gfc_build_addr_expr (NULL_TREE, tmp);
12237	}
12238
12239	gfc_init_se (&argse, NULL);
12240	gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12241	atom_expr);
12242	gfc_add_block_to_block (&block, &argse.pre);
12243
12244	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
12245	token, offset, image_index, old, comp, new_val,
12246	stat, build_int_cst (integer_type_node,
12247	(int) atom_expr->ts.type),
12248	build_int_cst (integer_type_node,
12249	(int) atom_expr->ts.kind));
12250	gfc_add_expr_to_block (&block, tmp);
12251	gfc_add_block_to_block (&block, &argse.post);
12252	gfc_add_block_to_block (&block, &post_block);
12253	return gfc_finish_block (&block);
12254	}
12255
12256	tmp = TREE_TYPE (TREE_TYPE (atom));
12257	fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12258	+ exact_log2 (x: tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12259	+ 1);
12260	tmp = builtin_decl_explicit (fncode: fn);
12261
12262	gfc_add_modify (&block, old, comp);
12263	tmp = build_call_expr_loc (input_location, tmp, 6, atom,
12264	gfc_build_addr_expr (NULL, old),
12265	fold_convert (TREE_TYPE (old), new_val),
12266	boolean_false_node,
12267	build_int_cst (NULL, MEMMODEL_RELAXED),
12268	build_int_cst (NULL, MEMMODEL_RELAXED));
12269	gfc_add_expr_to_block (&block, tmp);
12270
12271	if (stat != NULL_TREE)
12272	gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12273	gfc_add_block_to_block (&block, &post_block);
12274	return gfc_finish_block (&block);
12275	}
12276
12277	static tree
12278	conv_intrinsic_event_query (gfc_code *code)
12279	{
12280	gfc_se se, argse;
12281	tree stat = NULL_TREE, stat2 = NULL_TREE;
12282	tree count = NULL_TREE, count2 = NULL_TREE;
12283
12284	gfc_expr *event_expr = code->ext.actual->expr;
12285
12286	if (code->ext.actual->next->next->expr)
12287	{
12288	gcc_assert (code->ext.actual->next->next->expr->expr_type
12289	== EXPR_VARIABLE);
12290	gfc_init_se (&argse, NULL);
12291	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->next->next->expr);
12292	stat = argse.expr;
12293	}
12294	else if (flag_coarray == GFC_FCOARRAY_LIB)
12295	stat = null_pointer_node;
12296
12297	if (code->ext.actual->next->expr)
12298	{
12299	gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
12300	gfc_init_se (&argse, NULL);
12301	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->next->expr);
12302	count = argse.expr;
12303	}
12304
12305	gfc_start_block (&se.pre);
12306	if (flag_coarray == GFC_FCOARRAY_LIB)
12307	{
12308	tree tmp, token, image_index;
12309	tree index = build_zero_cst (gfc_array_index_type);
12310
12311	if (event_expr->expr_type == EXPR_FUNCTION
12312	&& event_expr->value.function.isym
12313	&& event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12314	event_expr = event_expr->value.function.actual->expr;
12315
12316	tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
12317
12318	if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
12319	|| event_expr->symtree->n.sym->ts.u.derived->from_intmod
12320	!= INTMOD_ISO_FORTRAN_ENV
12321	|| event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
12322	!= ISOFORTRAN_EVENT_TYPE)
12323	{
12324	gfc_error ("Sorry, the event component of derived type at %L is not "
12325	"yet supported", &event_expr->where);
12326	return NULL_TREE;
12327	}
12328
12329	if (gfc_is_coindexed (event_expr))
12330	{
12331	gfc_error ("The event variable at %L shall not be coindexed",
12332	&event_expr->where);
12333	return NULL_TREE;
12334	}
12335
12336	image_index = integer_zero_node;
12337
12338	gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
12339	event_expr);
12340
12341	/* For arrays, obtain the array index. */
12342	if (gfc_expr_attr (event_expr).dimension)
12343	{
12344	tree desc, tmp, extent, lbound, ubound;
12345	gfc_array_ref *ar, ar2;
12346	int i;
12347
12348	/* TODO: Extend this, once DT components are supported. */
12349	ar = &event_expr->ref->u.ar;
12350	ar2 = *ar;
12351	memset (s: ar, c: '\0', n: sizeof (*ar));
12352	ar->as = ar2.as;
12353	ar->type = AR_FULL;
12354
12355	gfc_init_se (&argse, NULL);
12356	argse.descriptor_only = 1;
12357	gfc_conv_expr_descriptor (&argse, event_expr);
12358	gfc_add_block_to_block (&se.pre, &argse.pre);
12359	desc = argse.expr;
12360	*ar = ar2;
12361
12362	extent = build_one_cst (gfc_array_index_type);
12363	for (i = 0; i < ar->dimen; i++)
12364	{
12365	gfc_init_se (&argse, NULL);
12366	gfc_conv_expr_type (se: &argse, ar->start[i], gfc_array_index_type);
12367	gfc_add_block_to_block (&argse.pre, &argse.pre);
12368	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
12369	tmp = fold_build2_loc (input_location, MINUS_EXPR,
12370	TREE_TYPE (lbound), argse.expr, lbound);
12371	tmp = fold_build2_loc (input_location, MULT_EXPR,
12372	TREE_TYPE (tmp), extent, tmp);
12373	index = fold_build2_loc (input_location, PLUS_EXPR,
12374	TREE_TYPE (tmp), index, tmp);
12375	if (i < ar->dimen - 1)
12376	{
12377	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
12378	tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
12379	extent = fold_build2_loc (input_location, MULT_EXPR,
12380	TREE_TYPE (tmp), extent, tmp);
12381	}
12382	}
12383	}
12384
12385	if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
12386	{
12387	count2 = count;
12388	count = gfc_create_var (integer_type_node, "count");
12389	}
12390
12391	if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
12392	{
12393	stat2 = stat;
12394	stat = gfc_create_var (integer_type_node, "stat");
12395	}
12396
12397	index = fold_convert (size_type_node, index);
12398	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
12399	token, index, image_index, count
12400	? gfc_build_addr_expr (NULL, count) : count,
12401	stat != null_pointer_node
12402	? gfc_build_addr_expr (NULL, stat) : stat);
12403	gfc_add_expr_to_block (&se.pre, tmp);
12404
12405	if (count2 != NULL_TREE)
12406	gfc_add_modify (&se.pre, count2,
12407	fold_convert (TREE_TYPE (count2), count));
12408
12409	if (stat2 != NULL_TREE)
12410	gfc_add_modify (&se.pre, stat2,
12411	fold_convert (TREE_TYPE (stat2), stat));
12412
12413	return gfc_finish_block (&se.pre);
12414	}
12415
12416	gfc_init_se (&argse, NULL);
12417	gfc_conv_expr_val (se: &argse, expr: code->ext.actual->expr);
12418	gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
12419
12420	if (stat != NULL_TREE)
12421	gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
12422
12423	return gfc_finish_block (&se.pre);
12424	}
12425
12426
12427	/* This is a peculiar case because of the need to do dependency checking.
12428	It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
12429	a special case and this function called instead of
12430	gfc_conv_procedure_call. */
12431	void
12432	gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
12433	gfc_loopinfo *loop)
12434	{
12435	gfc_actual_arglist *actual;
12436	gfc_se argse[5];
12437	gfc_expr *arg[5];
12438	gfc_ss *lss;
12439	int n;
12440
12441	tree from, frompos, len, to, topos;
12442	tree lenmask, oldbits, newbits, bitsize;
12443	tree type, utype, above, mask1, mask2;
12444
12445	if (loop)
12446	lss = loop->ss;
12447	else
12448	lss = gfc_ss_terminator;
12449
12450	actual = actual_args;
12451	for (n = 0; n < 5; n++, actual = actual->next)
12452	{
12453	arg[n] = actual->expr;
12454	gfc_init_se (&argse[n], NULL);
12455
12456	if (lss != gfc_ss_terminator)
12457	{
12458	gfc_copy_loopinfo_to_se (&argse[n], loop);
12459	/* Find the ss for the expression if it is there. */
12460	argse[n].ss = lss;
12461	gfc_mark_ss_chain_used (lss, 1);
12462	}
12463
12464	gfc_conv_expr (se: &argse[n], expr: arg[n]);
12465
12466	if (loop)
12467	lss = argse[n].ss;
12468	}
12469
12470	from = argse[0].expr;
12471	frompos = argse[1].expr;
12472	len = argse[2].expr;
12473	to = argse[3].expr;
12474	topos = argse[4].expr;
12475
12476	/* The type of the result (TO). */
12477	type = TREE_TYPE (to);
12478	bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
12479
12480	/* Optionally generate code for runtime argument check. */
12481	if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
12482	{
12483	tree nbits, below, ccond;
12484	tree fp = fold_convert (long_integer_type_node, frompos);
12485	tree ln = fold_convert (long_integer_type_node, len);
12486	tree tp = fold_convert (long_integer_type_node, topos);
12487	below = fold_build2_loc (input_location, LT_EXPR,
12488	logical_type_node, frompos,
12489	build_int_cst (TREE_TYPE (frompos), 0));
12490	above = fold_build2_loc (input_location, GT_EXPR,
12491	logical_type_node, frompos,
12492	fold_convert (TREE_TYPE (frompos), bitsize));
12493	ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12494	logical_type_node, below, above);
12495	gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
12496	&arg[1]->where,
12497	"FROMPOS argument (%ld) out of range 0:%d "
12498	"in intrinsic MVBITS", fp, bitsize);
12499	below = fold_build2_loc (input_location, LT_EXPR,
12500	logical_type_node, len,
12501	build_int_cst (TREE_TYPE (len), 0));
12502	above = fold_build2_loc (input_location, GT_EXPR,
12503	logical_type_node, len,
12504	fold_convert (TREE_TYPE (len), bitsize));
12505	ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12506	logical_type_node, below, above);
12507	gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
12508	&arg[2]->where,
12509	"LEN argument (%ld) out of range 0:%d "
12510	"in intrinsic MVBITS", ln, bitsize);
12511	below = fold_build2_loc (input_location, LT_EXPR,
12512	logical_type_node, topos,
12513	build_int_cst (TREE_TYPE (topos), 0));
12514	above = fold_build2_loc (input_location, GT_EXPR,
12515	logical_type_node, topos,
12516	fold_convert (TREE_TYPE (topos), bitsize));
12517	ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12518	logical_type_node, below, above);
12519	gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
12520	&arg[4]->where,
12521	"TOPOS argument (%ld) out of range 0:%d "
12522	"in intrinsic MVBITS", tp, bitsize);
12523
12524	/* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
12525	integers. Additions below cannot overflow. */
12526	nbits = fold_convert (long_integer_type_node, bitsize);
12527	above = fold_build2_loc (input_location, PLUS_EXPR,
12528	long_integer_type_node, fp, ln);
12529	ccond = fold_build2_loc (input_location, GT_EXPR,
12530	logical_type_node, above, nbits);
12531	gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
12532	&arg[1]->where,
12533	"FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12534	"in intrinsic MVBITS", fp, ln, bitsize);
12535	above = fold_build2_loc (input_location, PLUS_EXPR,
12536	long_integer_type_node, tp, ln);
12537	ccond = fold_build2_loc (input_location, GT_EXPR,
12538	logical_type_node, above, nbits);
12539	gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
12540	&arg[4]->where,
12541	"TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12542	"in intrinsic MVBITS", tp, ln, bitsize);
12543	}
12544
12545	for (n = 0; n < 5; n++)
12546	{
12547	gfc_add_block_to_block (&se->pre, &argse[n].pre);
12548	gfc_add_block_to_block (&se->post, &argse[n].post);
12549	}
12550
12551	/* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
12552	above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
12553	len, fold_convert (TREE_TYPE (len), bitsize));
12554	mask1 = build_int_cst (type, -1);
12555	mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12556	build_int_cst (type, 1), len);
12557	mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
12558	mask2, build_int_cst (type, 1));
12559	lenmask = fold_build3_loc (input_location, COND_EXPR, type,
12560	above, mask1, mask2);
12561
12562	/* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
12563	* For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
12564	* not strictly necessary; artificial bits from rshift will be masked. */
12565	utype = unsigned_type_for (type);
12566	newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
12567	fold_convert (utype, from), frompos);
12568	newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
12569	fold_convert (type, newbits), lenmask);
12570	newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12571	newbits, topos);
12572
12573	/* oldbits = TO & (~(lenmask << TOPOS)). */
12574	oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12575	lenmask, topos);
12576	oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
12577	oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
12578
12579	/* TO = newbits | oldbits. */
12580	se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
12581	oldbits, newbits);
12582
12583	/* Return the assignment. */
12584	se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
12585	void_type_node, to, se->expr);
12586	}
12587
12588
12589	static tree
12590	conv_intrinsic_move_alloc (gfc_code *code)
12591	{
12592	stmtblock_t block;
12593	gfc_expr *from_expr, *to_expr;
12594	gfc_expr *to_expr2, *from_expr2 = NULL;
12595	gfc_se from_se, to_se;
12596	tree tmp;
12597	bool coarray;
12598
12599	gfc_start_block (&block);
12600
12601	from_expr = code->ext.actual->expr;
12602	to_expr = code->ext.actual->next->expr;
12603
12604	gfc_init_se (&from_se, NULL);
12605	gfc_init_se (&to_se, NULL);
12606
12607	gcc_assert (from_expr->ts.type != BT_CLASS
12608	|| to_expr->ts.type == BT_CLASS);
12609	coarray = gfc_get_corank (from_expr) != 0;
12610
12611	if (from_expr->rank == 0 && !coarray)
12612	{
12613	if (from_expr->ts.type != BT_CLASS)
12614	from_expr2 = from_expr;
12615	else
12616	{
12617	from_expr2 = gfc_copy_expr (from_expr);
12618	gfc_add_data_component (from_expr2);
12619	}
12620
12621	if (to_expr->ts.type != BT_CLASS)
12622	to_expr2 = to_expr;
12623	else
12624	{
12625	to_expr2 = gfc_copy_expr (to_expr);
12626	gfc_add_data_component (to_expr2);
12627	}
12628
12629	from_se.want_pointer = 1;
12630	to_se.want_pointer = 1;
12631	gfc_conv_expr (se: &from_se, expr: from_expr2);
12632	gfc_conv_expr (se: &to_se, expr: to_expr2);
12633	gfc_add_block_to_block (&block, &from_se.pre);
12634	gfc_add_block_to_block (&block, &to_se.pre);
12635
12636	/* Deallocate "to". */
12637	tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12638	true, to_expr, to_expr->ts);
12639	gfc_add_expr_to_block (&block, tmp);
12640
12641	/* Assign (_data) pointers. */
12642	gfc_add_modify_loc (input_location, &block, to_se.expr,
12643	fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
12644
12645	/* Set "from" to NULL. */
12646	gfc_add_modify_loc (input_location, &block, from_se.expr,
12647	fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
12648
12649	gfc_add_block_to_block (&block, &from_se.post);
12650	gfc_add_block_to_block (&block, &to_se.post);
12651
12652	/* Set _vptr. */
12653	if (to_expr->ts.type == BT_CLASS)
12654	{
12655	gfc_symbol *vtab;
12656
12657	gfc_free_expr (to_expr2);
12658	gfc_init_se (&to_se, NULL);
12659	to_se.want_pointer = 1;
12660	gfc_add_vptr_component (to_expr);
12661	gfc_conv_expr (se: &to_se, expr: to_expr);
12662
12663	if (from_expr->ts.type == BT_CLASS)
12664	{
12665	if (UNLIMITED_POLY (from_expr))
12666	vtab = NULL;
12667	else
12668	{
12669	vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
12670	gcc_assert (vtab);
12671	}
12672
12673	gfc_free_expr (from_expr2);
12674	gfc_init_se (&from_se, NULL);
12675	from_se.want_pointer = 1;
12676	gfc_add_vptr_component (from_expr);
12677	gfc_conv_expr (se: &from_se, expr: from_expr);
12678	gfc_add_modify_loc (input_location, &block, to_se.expr,
12679	fold_convert (TREE_TYPE (to_se.expr),
12680	from_se.expr));
12681
12682	/* Reset _vptr component to declared type. */
12683	if (vtab == NULL)
12684	/* Unlimited polymorphic. */
12685	gfc_add_modify_loc (input_location, &block, from_se.expr,
12686	fold_convert (TREE_TYPE (from_se.expr),
12687	null_pointer_node));
12688	else
12689	{
12690	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12691	gfc_add_modify_loc (input_location, &block, from_se.expr,
12692	fold_convert (TREE_TYPE (from_se.expr), tmp));
12693	}
12694	}
12695	else
12696	{
12697	vtab = gfc_find_vtab (&from_expr->ts);
12698	gcc_assert (vtab);
12699	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12700	gfc_add_modify_loc (input_location, &block, to_se.expr,
12701	fold_convert (TREE_TYPE (to_se.expr), tmp));
12702	}
12703	}
12704
12705	if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
12706	{
12707	gfc_add_modify_loc (input_location, &block, to_se.string_length,
12708	fold_convert (TREE_TYPE (to_se.string_length),
12709	from_se.string_length));
12710	if (from_expr->ts.deferred)
12711	gfc_add_modify_loc (input_location, &block, from_se.string_length,
12712	build_int_cst (TREE_TYPE (from_se.string_length), 0));
12713	}
12714
12715	return gfc_finish_block (&block);
12716	}
12717
12718	/* Update _vptr component. */
12719	if (to_expr->ts.type == BT_CLASS)
12720	{
12721	gfc_symbol *vtab;
12722
12723	to_se.want_pointer = 1;
12724	to_expr2 = gfc_copy_expr (to_expr);
12725	gfc_add_vptr_component (to_expr2);
12726	gfc_conv_expr (se: &to_se, expr: to_expr2);
12727
12728	if (from_expr->ts.type == BT_CLASS)
12729	{
12730	if (UNLIMITED_POLY (from_expr))
12731	vtab = NULL;
12732	else
12733	{
12734	vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
12735	gcc_assert (vtab);
12736	}
12737
12738	from_se.want_pointer = 1;
12739	from_expr2 = gfc_copy_expr (from_expr);
12740	gfc_add_vptr_component (from_expr2);
12741	gfc_conv_expr (se: &from_se, expr: from_expr2);
12742	gfc_add_modify_loc (input_location, &block, to_se.expr,
12743	fold_convert (TREE_TYPE (to_se.expr),
12744	from_se.expr));
12745
12746	/* Reset _vptr component to declared type. */
12747	if (vtab == NULL)
12748	/* Unlimited polymorphic. */
12749	gfc_add_modify_loc (input_location, &block, from_se.expr,
12750	fold_convert (TREE_TYPE (from_se.expr),
12751	null_pointer_node));
12752	else
12753	{
12754	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12755	gfc_add_modify_loc (input_location, &block, from_se.expr,
12756	fold_convert (TREE_TYPE (from_se.expr), tmp));
12757	}
12758	}
12759	else
12760	{
12761	vtab = gfc_find_vtab (&from_expr->ts);
12762	gcc_assert (vtab);
12763	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12764	gfc_add_modify_loc (input_location, &block, to_se.expr,
12765	fold_convert (TREE_TYPE (to_se.expr), tmp));
12766	}
12767
12768	gfc_free_expr (to_expr2);
12769	gfc_init_se (&to_se, NULL);
12770
12771	if (from_expr->ts.type == BT_CLASS)
12772	{
12773	gfc_free_expr (from_expr2);
12774	gfc_init_se (&from_se, NULL);
12775	}
12776	}
12777
12778
12779	/* Deallocate "to". */
12780	if (from_expr->rank == 0)
12781	{
12782	to_se.want_coarray = 1;
12783	from_se.want_coarray = 1;
12784	}
12785	gfc_conv_expr_descriptor (&to_se, to_expr);
12786	gfc_conv_expr_descriptor (&from_se, from_expr);
12787
12788	/* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
12789	is an image control "statement", cf. IR F08/0040 in 12-006A. */
12790	if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
12791	{
12792	tree cond;
12793
12794	tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12795	NULL_TREE, NULL_TREE, true, to_expr,
12796	GFC_CAF_COARRAY_DEALLOCATE_ONLY);
12797	gfc_add_expr_to_block (&block, tmp);
12798
12799	tmp = gfc_conv_descriptor_data_get (to_se.expr);
12800	cond = fold_build2_loc (input_location, EQ_EXPR,
12801	logical_type_node, tmp,
12802	fold_convert (TREE_TYPE (tmp),
12803	null_pointer_node));
12804	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
12805	3, null_pointer_node, null_pointer_node,
12806	build_int_cst (integer_type_node, 0));
12807
12808	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
12809	tmp, build_empty_stmt (input_location));
12810	gfc_add_expr_to_block (&block, tmp);
12811	}
12812	else
12813	{
12814	if (to_expr->ts.type == BT_DERIVED
12815	&& to_expr->ts.u.derived->attr.alloc_comp)
12816	{
12817	tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
12818	to_se.expr, to_expr->rank);
12819	gfc_add_expr_to_block (&block, tmp);
12820	}
12821
12822	tmp = gfc_conv_descriptor_data_get (to_se.expr);
12823	tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
12824	NULL_TREE, true, to_expr,
12825	GFC_CAF_COARRAY_NOCOARRAY);
12826	gfc_add_expr_to_block (&block, tmp);
12827	}
12828
12829	/* Move the pointer and update the array descriptor data. */
12830	gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
12831
12832	/* Set "from" to NULL. */
12833	tmp = gfc_conv_descriptor_data_get (from_se.expr);
12834	gfc_add_modify_loc (input_location, &block, tmp,
12835	fold_convert (TREE_TYPE (tmp), null_pointer_node));
12836
12837
12838	if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
12839	{
12840	gfc_add_modify_loc (input_location, &block, to_se.string_length,
12841	fold_convert (TREE_TYPE (to_se.string_length),
12842	from_se.string_length));
12843	if (from_expr->ts.deferred)
12844	gfc_add_modify_loc (input_location, &block, from_se.string_length,
12845	build_int_cst (TREE_TYPE (from_se.string_length), 0));
12846	}
12847
12848	return gfc_finish_block (&block);
12849	}
12850
12851
12852	tree
12853	gfc_conv_intrinsic_subroutine (gfc_code *code)
12854	{
12855	tree res;
12856
12857	gcc_assert (code->resolved_isym);
12858
12859	switch (code->resolved_isym->id)
12860	{
12861	case GFC_ISYM_MOVE_ALLOC:
12862	res = conv_intrinsic_move_alloc (code);
12863	break;
12864
12865	case GFC_ISYM_ATOMIC_CAS:
12866	res = conv_intrinsic_atomic_cas (code);
12867	break;
12868
12869	case GFC_ISYM_ATOMIC_ADD:
12870	case GFC_ISYM_ATOMIC_AND:
12871	case GFC_ISYM_ATOMIC_DEF:
12872	case GFC_ISYM_ATOMIC_OR:
12873	case GFC_ISYM_ATOMIC_XOR:
12874	case GFC_ISYM_ATOMIC_FETCH_ADD:
12875	case GFC_ISYM_ATOMIC_FETCH_AND:
12876	case GFC_ISYM_ATOMIC_FETCH_OR:
12877	case GFC_ISYM_ATOMIC_FETCH_XOR:
12878	res = conv_intrinsic_atomic_op (code);
12879	break;
12880
12881	case GFC_ISYM_ATOMIC_REF:
12882	res = conv_intrinsic_atomic_ref (code);
12883	break;
12884
12885	case GFC_ISYM_EVENT_QUERY:
12886	res = conv_intrinsic_event_query (code);
12887	break;
12888
12889	case GFC_ISYM_C_F_POINTER:
12890	case GFC_ISYM_C_F_PROCPOINTER:
12891	res = conv_isocbinding_subroutine (code);
12892	break;
12893
12894	case GFC_ISYM_CAF_SEND:
12895	res = conv_caf_send (code);
12896	break;
12897
12898	case GFC_ISYM_CO_BROADCAST:
12899	case GFC_ISYM_CO_MIN:
12900	case GFC_ISYM_CO_MAX:
12901	case GFC_ISYM_CO_REDUCE:
12902	case GFC_ISYM_CO_SUM:
12903	res = conv_co_collective (code);
12904	break;
12905
12906	case GFC_ISYM_FREE:
12907	res = conv_intrinsic_free (code);
12908	break;
12909
12910	case GFC_ISYM_RANDOM_INIT:
12911	res = conv_intrinsic_random_init (code);
12912	break;
12913
12914	case GFC_ISYM_KILL:
12915	res = conv_intrinsic_kill_sub (code);
12916	break;
12917
12918	case GFC_ISYM_MVBITS:
12919	res = NULL_TREE;
12920	break;
12921
12922	case GFC_ISYM_SYSTEM_CLOCK:
12923	res = conv_intrinsic_system_clock (code);
12924	break;
12925
12926	default:
12927	res = NULL_TREE;
12928	break;
12929	}
12930
12931	return res;
12932	}
12933
12934	#include "gt-fortran-trans-intrinsic.h"
12935