1	/* OpenMP directive translation -- generate GCC trees from gfc_code.
2	Copyright (C) 2005-2023 Free Software Foundation, Inc.
3	Contributed by Jakub Jelinek <jakub@redhat.com>
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21
22	#include "config.h"
23	#include "system.h"
24	#include "coretypes.h"
25	#include "options.h"
26	#include "tree.h"
27	#include "gfortran.h"
28	#include "gimple-expr.h"
29	#include "trans.h"
30	#include "stringpool.h"
31	#include "fold-const.h"
32	#include "gimplify.h" /* For create_tmp_var_raw. */
33	#include "trans-stmt.h"
34	#include "trans-types.h"
35	#include "trans-array.h"
36	#include "trans-const.h"
37	#include "arith.h"
38	#include "constructor.h"
39	#include "gomp-constants.h"
40	#include "omp-general.h"
41	#include "omp-low.h"
42	#include "memmodel.h" /* For MEMMODEL_ enums. */
43
44	#undef GCC_DIAG_STYLE
45	#define GCC_DIAG_STYLE __gcc_tdiag__
46	#include "diagnostic-core.h"
47	#undef GCC_DIAG_STYLE
48	#define GCC_DIAG_STYLE __gcc_gfc__
49	#include "attribs.h"
50	#include "function.h"
51
52	int ompws_flags;
53
54	/* True if OpenMP should regard this DECL as being a scalar which has Fortran's
55	allocatable or pointer attribute. */
56
57	bool
58	gfc_omp_is_allocatable_or_ptr (const_tree decl)
59	{
60	return (DECL_P (decl)
61	&& (GFC_DECL_GET_SCALAR_POINTER (decl)
62	|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)));
63	}
64
65	/* True if the argument is an optional argument; except that false is also
66	returned for arguments with the value attribute (nonpointers) and for
67	assumed-shape variables (decl is a local variable containing arg->data).
68	Note that for 'procedure(), optional' the value false is used as that's
69	always a pointer and no additional indirection is used.
70	Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */
71
72	static bool
73	gfc_omp_is_optional_argument (const_tree decl)
74	{
75	/* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
76	return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl))
77	&& DECL_LANG_SPECIFIC (decl)
78	&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
79	&& !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
80	&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE
81	&& GFC_DECL_OPTIONAL_ARGUMENT (decl));
82	}
83
84	/* Check whether this DECL belongs to a Fortran optional argument.
85	With 'for_present_check' set to false, decls which are optional parameters
86	themselves are returned as tree - or a NULL_TREE otherwise. Those decls are
87	always pointers. With 'for_present_check' set to true, the decl for checking
88	whether an argument is present is returned; for arguments with value
89	attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is
90	unrelated to optional arguments, NULL_TREE is returned. */
91
92	tree
93	gfc_omp_check_optional_argument (tree decl, bool for_present_check)
94	{
95	if (!for_present_check)
96	return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE;
97
98	if (!DECL_LANG_SPECIFIC (decl))
99	return NULL_TREE;
100
101	tree orig_decl = decl;
102
103	/* For assumed-shape arrays, a local decl with arg->data is used. */
104	if (TREE_CODE (decl) != PARM_DECL
105	&& (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
106	|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl))))
107	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
108
109	/* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */
110	if (decl == NULL_TREE
111	|| (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL)
112	|| !DECL_LANG_SPECIFIC (decl)
113	|| !GFC_DECL_OPTIONAL_ARGUMENT (decl))
114	return NULL_TREE;
115
116	/* Scalars with VALUE attribute which are passed by value use a hidden
117	argument to denote the present status. They are passed as nonpointer type
118	with one exception: 'type(c_ptr), value' as 'void*'. */
119	/* Cf. trans-expr.cc's gfc_conv_expr_present. */
120	if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
121	|| VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
122	{
123	char name[GFC_MAX_SYMBOL_LEN + 2];
124	tree tree_name;
125
126	name[0] = '.';
127	strcpy (dest: &name[1], IDENTIFIER_POINTER (DECL_NAME (decl)));
128	tree_name = get_identifier (name);
129
130	/* Walk function argument list to find the hidden arg. */
131	decl = DECL_ARGUMENTS (DECL_CONTEXT (decl));
132	for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl))
133	if (DECL_NAME (decl) == tree_name
134	&& DECL_ARTIFICIAL (decl))
135	break;
136
137	gcc_assert (decl);
138	return decl;
139	}
140
141	return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
142	orig_decl, null_pointer_node);
143	}
144
145
146	/* Returns tree with NULL if it is not an array descriptor and with the tree to
147	access the 'data' component otherwise. With type_only = true, it returns the
148	TREE_TYPE without creating a new tree. */
149
150	tree
151	gfc_omp_array_data (tree decl, bool type_only)
152	{
153	tree type = TREE_TYPE (decl);
154
155	if (POINTER_TYPE_P (type))
156	type = TREE_TYPE (type);
157
158	if (!GFC_DESCRIPTOR_TYPE_P (type))
159	return NULL_TREE;
160
161	if (type_only)
162	return GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
163
164	if (POINTER_TYPE_P (TREE_TYPE (decl)))
165	decl = build_fold_indirect_ref (decl);
166
167	decl = gfc_conv_descriptor_data_get (decl);
168	STRIP_NOPS (decl);
169	return decl;
170	}
171
172	/* Return the byte-size of the passed array descriptor. */
173
174	tree
175	gfc_omp_array_size (tree decl, gimple_seq *pre_p)
176	{
177	stmtblock_t block;
178	if (POINTER_TYPE_P (TREE_TYPE (decl)))
179	decl = build_fold_indirect_ref (decl);
180	tree type = TREE_TYPE (decl);
181	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
182	bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
183	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
184	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT);
185	gfc_init_block (&block);
186	tree size = gfc_full_array_size (&block, decl,
187	GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)));
188	size = fold_convert (size_type_node, size);
189	tree elemsz = gfc_get_element_type (TREE_TYPE (decl));
190	if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz))
191	elemsz = gfc_conv_descriptor_elem_len (decl);
192	else
193	elemsz = TYPE_SIZE_UNIT (elemsz);
194	size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz);
195	if (!allocatable)
196	gimplify_and_add (gfc_finish_block (&block), pre_p);
197	else
198	{
199	tree var = create_tmp_var (size_type_node);
200	gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size));
201	tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
202	gfc_conv_descriptor_data_get (decl),
203	null_pointer_node);
204	tmp = build3_loc (loc: input_location, code: COND_EXPR, void_type_node, arg0: tmp,
205	arg1: gfc_finish_block (&block),
206	arg2: build2 (MODIFY_EXPR, sizetype, var, size_zero_node));
207	gimplify_and_add (tmp, pre_p);
208	size = var;
209	}
210	return size;
211	}
212
213
214	/* True if OpenMP should privatize what this DECL points to rather
215	than the DECL itself. */
216
217	bool
218	gfc_omp_privatize_by_reference (const_tree decl)
219	{
220	tree type = TREE_TYPE (decl);
221
222	if (TREE_CODE (type) == REFERENCE_TYPE
223	&& (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
224	return true;
225
226	if (TREE_CODE (type) == POINTER_TYPE
227	&& gfc_omp_is_optional_argument (decl))
228	return true;
229
230	if (TREE_CODE (type) == POINTER_TYPE)
231	{
232	while (TREE_CODE (decl) == COMPONENT_REF)
233	decl = TREE_OPERAND (decl, 1);
234
235	/* Array POINTER/ALLOCATABLE have aggregate types, all user variables
236	that have POINTER_TYPE type and aren't scalar pointers, scalar
237	allocatables, Cray pointees or C pointers are supposed to be
238	privatized by reference. */
239	if (GFC_DECL_GET_SCALAR_POINTER (decl)
240	|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
241	|| GFC_DECL_CRAY_POINTEE (decl)
242	|| GFC_DECL_ASSOCIATE_VAR_P (decl)
243	|| VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
244	return false;
245
246	if (!DECL_ARTIFICIAL (decl)
247	&& TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
248	return true;
249
250	/* Some arrays are expanded as DECL_ARTIFICIAL pointers
251	by the frontend. */
252	if (DECL_LANG_SPECIFIC (decl)
253	&& GFC_DECL_SAVED_DESCRIPTOR (decl))
254	return true;
255	}
256
257	return false;
258	}
259
260	/* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
261	of DECL is predetermined. */
262
263	enum omp_clause_default_kind
264	gfc_omp_predetermined_sharing (tree decl)
265	{
266	/* Associate names preserve the association established during ASSOCIATE.
267	As they are implemented either as pointers to the selector or array
268	descriptor and shouldn't really change in the ASSOCIATE region,
269	this decl can be either shared or firstprivate. If it is a pointer,
270	use firstprivate, as it is cheaper that way, otherwise make it shared. */
271	if (GFC_DECL_ASSOCIATE_VAR_P (decl))
272	{
273	if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
274	return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
275	else
276	return OMP_CLAUSE_DEFAULT_SHARED;
277	}
278
279	if (DECL_ARTIFICIAL (decl)
280	&& ! GFC_DECL_RESULT (decl)
281	&& ! (DECL_LANG_SPECIFIC (decl)
282	&& GFC_DECL_SAVED_DESCRIPTOR (decl)))
283	return OMP_CLAUSE_DEFAULT_SHARED;
284
285	/* Cray pointees shouldn't be listed in any clauses and should be
286	gimplified to dereference of the corresponding Cray pointer.
287	Make them all private, so that they are emitted in the debug
288	information. */
289	if (GFC_DECL_CRAY_POINTEE (decl))
290	return OMP_CLAUSE_DEFAULT_PRIVATE;
291
292	/* Assumed-size arrays are predetermined shared. */
293	if (TREE_CODE (decl) == PARM_DECL
294	&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
295	&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
296	&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
297	GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
298	== NULL)
299	return OMP_CLAUSE_DEFAULT_SHARED;
300
301	/* Dummy procedures aren't considered variables by OpenMP, thus are
302	disallowed in OpenMP clauses. They are represented as PARM_DECLs
303	in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
304	to avoid complaining about their uses with default(none). */
305	if (TREE_CODE (decl) == PARM_DECL
306	&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
307	&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
308	return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
309
310	/* COMMON and EQUIVALENCE decls are shared. They
311	are only referenced through DECL_VALUE_EXPR of the variables
312	contained in them. If those are privatized, they will not be
313	gimplified to the COMMON or EQUIVALENCE decls. */
314	if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
315	return OMP_CLAUSE_DEFAULT_SHARED;
316
317	if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
318	return OMP_CLAUSE_DEFAULT_SHARED;
319
320	/* These are either array or derived parameters, or vtables.
321	In the former cases, the OpenMP standard doesn't consider them to be
322	variables at all (they can't be redefined), but they can nevertheless appear
323	in parallel/task regions and for default(none) purposes treat them as shared.
324	For vtables likely the same handling is desirable. */
325	if (VAR_P (decl) && TREE_READONLY (decl)
326	&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
327	return OMP_CLAUSE_DEFAULT_SHARED;
328
329	return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
330	}
331
332
333	/* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
334	of DECL is predetermined. */
335
336	enum omp_clause_defaultmap_kind
337	gfc_omp_predetermined_mapping (tree decl)
338	{
339	if (DECL_ARTIFICIAL (decl)
340	&& ! GFC_DECL_RESULT (decl)
341	&& ! (DECL_LANG_SPECIFIC (decl)
342	&& GFC_DECL_SAVED_DESCRIPTOR (decl)))
343	return OMP_CLAUSE_DEFAULTMAP_TO;
344
345	/* These are either array or derived parameters, or vtables. */
346	if (VAR_P (decl) && TREE_READONLY (decl)
347	&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
348	return OMP_CLAUSE_DEFAULTMAP_TO;
349
350	return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
351	}
352
353
354	/* Return decl that should be used when reporting DEFAULT(NONE)
355	diagnostics. */
356
357	tree
358	gfc_omp_report_decl (tree decl)
359	{
360	if (DECL_ARTIFICIAL (decl)
361	&& DECL_LANG_SPECIFIC (decl)
362	&& GFC_DECL_SAVED_DESCRIPTOR (decl))
363	return GFC_DECL_SAVED_DESCRIPTOR (decl);
364
365	return decl;
366	}
367
368	/* Return true if TYPE has any allocatable components. */
369
370	static bool
371	gfc_has_alloc_comps (tree type, tree decl)
372	{
373	tree field, ftype;
374
375	if (POINTER_TYPE_P (type))
376	{
377	if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
378	type = TREE_TYPE (type);
379	else if (GFC_DECL_GET_SCALAR_POINTER (decl))
380	return false;
381	}
382
383	if (GFC_DESCRIPTOR_TYPE_P (type)
384	&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
385	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
386	return false;
387
388	if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
389	type = gfc_get_element_type (type);
390
391	if (TREE_CODE (type) != RECORD_TYPE)
392	return false;
393
394	for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
395	{
396	ftype = TREE_TYPE (field);
397	if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
398	return true;
399	if (GFC_DESCRIPTOR_TYPE_P (ftype)
400	&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
401	return true;
402	if (gfc_has_alloc_comps (type: ftype, decl: field))
403	return true;
404	}
405	return false;
406	}
407
408	/* Return true if TYPE is polymorphic but not with pointer attribute. */
409
410	static bool
411	gfc_is_polymorphic_nonptr (tree type)
412	{
413	if (POINTER_TYPE_P (type))
414	type = TREE_TYPE (type);
415	return GFC_CLASS_TYPE_P (type);
416	}
417
418	/* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
419	unlimited means also intrinsic types are handled and _len is used. */
420
421	static bool
422	gfc_is_unlimited_polymorphic_nonptr (tree type)
423	{
424	if (POINTER_TYPE_P (type))
425	type = TREE_TYPE (type);
426	if (!GFC_CLASS_TYPE_P (type))
427	return false;
428
429	tree field = TYPE_FIELDS (type); /* _data */
430	gcc_assert (field);
431	field = DECL_CHAIN (field); /* _vptr */
432	gcc_assert (field);
433	field = DECL_CHAIN (field);
434	if (!field)
435	return false;
436	gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0);
437	return true;
438	}
439
440	/* Return true if the DECL is for an allocatable array or scalar. */
441
442	bool
443	gfc_omp_allocatable_p (tree decl)
444	{
445	if (!DECL_P (decl))
446	return false;
447
448	if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
449	return true;
450
451	tree type = TREE_TYPE (decl);
452	if (gfc_omp_privatize_by_reference (decl))
453	type = TREE_TYPE (type);
454
455	if (GFC_DESCRIPTOR_TYPE_P (type)
456	&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
457	return true;
458
459	return false;
460	}
461
462
463	/* Return true if DECL in private clause needs
464	OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
465	bool
466	gfc_omp_private_outer_ref (tree decl)
467	{
468	tree type = TREE_TYPE (decl);
469
470	if (gfc_omp_privatize_by_reference (decl))
471	type = TREE_TYPE (type);
472
473	if (GFC_DESCRIPTOR_TYPE_P (type)
474	&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
475	return true;
476
477	if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
478	return true;
479
480	if (gfc_has_alloc_comps (type, decl))
481	return true;
482
483	return false;
484	}
485
486	/* Callback for gfc_omp_unshare_expr. */
487
488	static tree
489	gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
490	{
491	tree t = *tp;
492	enum tree_code code = TREE_CODE (t);
493
494	/* Stop at types, decls, constants like copy_tree_r. */
495	if (TREE_CODE_CLASS (code) == tcc_type
496	|| TREE_CODE_CLASS (code) == tcc_declaration
497	|| TREE_CODE_CLASS (code) == tcc_constant
498	|| code == BLOCK)
499	*walk_subtrees = 0;
500	else if (handled_component_p (t)
501	|| TREE_CODE (t) == MEM_REF)
502	{
503	*tp = unshare_expr (t);
504	*walk_subtrees = 0;
505	}
506
507	return NULL_TREE;
508	}
509
510	/* Unshare in expr anything that the FE which normally doesn't
511	care much about tree sharing (because during gimplification
512	everything is unshared) could cause problems with tree sharing
513	at omp-low.cc time. */
514
515	static tree
516	gfc_omp_unshare_expr (tree expr)
517	{
518	walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
519	return expr;
520	}
521
522	enum walk_alloc_comps
523	{
524	WALK_ALLOC_COMPS_DTOR,
525	WALK_ALLOC_COMPS_DEFAULT_CTOR,
526	WALK_ALLOC_COMPS_COPY_CTOR
527	};
528
529	/* Handle allocatable components in OpenMP clauses. */
530
531	static tree
532	gfc_walk_alloc_comps (tree decl, tree dest, tree var,
533	enum walk_alloc_comps kind)
534	{
535	stmtblock_t block, tmpblock;
536	tree type = TREE_TYPE (decl), then_b, tem, field;
537	gfc_init_block (&block);
538
539	if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
540	{
541	if (GFC_DESCRIPTOR_TYPE_P (type))
542	{
543	gfc_init_block (&tmpblock);
544	tem = gfc_full_array_size (&tmpblock, decl,
545	GFC_TYPE_ARRAY_RANK (type));
546	then_b = gfc_finish_block (&tmpblock);
547	gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (expr: then_b));
548	tem = gfc_omp_unshare_expr (expr: tem);
549	tem = fold_build2_loc (input_location, MINUS_EXPR,
550	gfc_array_index_type, tem,
551	gfc_index_one_node);
552	}
553	else
554	{
555	bool compute_nelts = false;
556	if (!TYPE_DOMAIN (type)
557	|| TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
558	|| TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
559	|| TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
560	compute_nelts = true;
561	else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
562	{
563	tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
564	if (lookup_attribute (attr_name: "omp dummy var", list: a))
565	compute_nelts = true;
566	}
567	if (compute_nelts)
568	{
569	tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
570	TYPE_SIZE_UNIT (type),
571	TYPE_SIZE_UNIT (TREE_TYPE (type)));
572	tem = size_binop (MINUS_EXPR, tem, size_one_node);
573	}
574	else
575	tem = array_type_nelts (type);
576	tem = fold_convert (gfc_array_index_type, tem);
577	}
578
579	tree nelems = gfc_evaluate_now (tem, &block);
580	tree index = gfc_create_var (gfc_array_index_type, "S");
581
582	gfc_init_block (&tmpblock);
583	tem = gfc_conv_array_data (decl);
584	tree declvar = build_fold_indirect_ref_loc (input_location, tem);
585	tree declvref = gfc_build_array_ref (declvar, index, NULL);
586	tree destvar, destvref = NULL_TREE;
587	if (dest)
588	{
589	tem = gfc_conv_array_data (dest);
590	destvar = build_fold_indirect_ref_loc (input_location, tem);
591	destvref = gfc_build_array_ref (destvar, index, NULL);
592	}
593	gfc_add_expr_to_block (&tmpblock,
594	gfc_walk_alloc_comps (decl: declvref, dest: destvref,
595	var, kind));
596
597	gfc_loopinfo loop;
598	gfc_init_loopinfo (&loop);
599	loop.dimen = 1;
600	loop.from[0] = gfc_index_zero_node;
601	loop.loopvar[0] = index;
602	loop.to[0] = nelems;
603	gfc_trans_scalarizing_loops (&loop, &tmpblock);
604	gfc_add_block_to_block (&block, &loop.pre);
605	return gfc_finish_block (&block);
606	}
607	else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
608	{
609	decl = build_fold_indirect_ref_loc (input_location, decl);
610	if (dest)
611	dest = build_fold_indirect_ref_loc (input_location, dest);
612	type = TREE_TYPE (decl);
613	}
614
615	gcc_assert (TREE_CODE (type) == RECORD_TYPE);
616	for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
617	{
618	tree ftype = TREE_TYPE (field);
619	tree declf, destf = NULL_TREE;
620	bool has_alloc_comps = gfc_has_alloc_comps (type: ftype, decl: field);
621	if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
622	|| GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
623	&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
624	&& !has_alloc_comps)
625	continue;
626	declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
627	decl, field, NULL_TREE);
628	if (dest)
629	destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
630	dest, field, NULL_TREE);
631
632	tem = NULL_TREE;
633	switch (kind)
634	{
635	case WALK_ALLOC_COMPS_DTOR:
636	break;
637	case WALK_ALLOC_COMPS_DEFAULT_CTOR:
638	if (GFC_DESCRIPTOR_TYPE_P (ftype)
639	&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
640	{
641	gfc_add_modify (&block, unshare_expr (destf),
642	unshare_expr (declf));
643	tem = gfc_duplicate_allocatable_nocopy
644	(destf, declf, ftype,
645	GFC_TYPE_ARRAY_RANK (ftype));
646	}
647	else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
648	tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
649	break;
650	case WALK_ALLOC_COMPS_COPY_CTOR:
651	if (GFC_DESCRIPTOR_TYPE_P (ftype)
652	&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
653	tem = gfc_duplicate_allocatable (destf, declf, ftype,
654	GFC_TYPE_ARRAY_RANK (ftype),
655	NULL_TREE);
656	else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
657	tem = gfc_duplicate_allocatable (destf, declf, ftype, 0,
658	NULL_TREE);
659	break;
660	}
661	if (tem)
662	gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (expr: tem));
663	if (has_alloc_comps)
664	{
665	gfc_init_block (&tmpblock);
666	gfc_add_expr_to_block (&tmpblock,
667	gfc_walk_alloc_comps (decl: declf, dest: destf,
668	var: field, kind));
669	then_b = gfc_finish_block (&tmpblock);
670	if (GFC_DESCRIPTOR_TYPE_P (ftype)
671	&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
672	tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
673	else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
674	tem = unshare_expr (declf);
675	else
676	tem = NULL_TREE;
677	if (tem)
678	{
679	tem = fold_convert (pvoid_type_node, tem);
680	tem = fold_build2_loc (input_location, NE_EXPR,
681	logical_type_node, tem,
682	null_pointer_node);
683	then_b = build3_loc (loc: input_location, code: COND_EXPR, void_type_node,
684	arg0: tem, arg1: then_b,
685	arg2: build_empty_stmt (input_location));
686	}
687	gfc_add_expr_to_block (&block, then_b);
688	}
689	if (kind == WALK_ALLOC_COMPS_DTOR)
690	{
691	if (GFC_DESCRIPTOR_TYPE_P (ftype)
692	&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
693	{
694	tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
695	tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE,
696	NULL_TREE, NULL_TREE, true,
697	NULL,
698	GFC_CAF_COARRAY_NOCOARRAY);
699	gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (expr: tem));
700	}
701	else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
702	{
703	tem = gfc_call_free (unshare_expr (declf));
704	gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (expr: tem));
705	}
706	}
707	}
708
709	return gfc_finish_block (&block);
710	}
711
712	/* Return code to initialize DECL with its default constructor, or
713	NULL if there's nothing to do. */
714
715	tree
716	gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
717	{
718	tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
719	stmtblock_t block, cond_block;
720
721	switch (OMP_CLAUSE_CODE (clause))
722	{
723	case OMP_CLAUSE__LOOPTEMP_:
724	case OMP_CLAUSE__REDUCTEMP_:
725	case OMP_CLAUSE__CONDTEMP_:
726	case OMP_CLAUSE__SCANTEMP_:
727	return NULL;
728	case OMP_CLAUSE_PRIVATE:
729	case OMP_CLAUSE_LASTPRIVATE:
730	case OMP_CLAUSE_LINEAR:
731	case OMP_CLAUSE_REDUCTION:
732	case OMP_CLAUSE_IN_REDUCTION:
733	case OMP_CLAUSE_TASK_REDUCTION:
734	break;
735	default:
736	gcc_unreachable ();
737	}
738
739	if ((! GFC_DESCRIPTOR_TYPE_P (type)
740	|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
741	&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
742	|| !POINTER_TYPE_P (type)))
743	{
744	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
745	{
746	gcc_assert (outer);
747	gfc_start_block (&block);
748	tree tem = gfc_walk_alloc_comps (decl: outer, dest: decl,
749	OMP_CLAUSE_DECL (clause),
750	kind: WALK_ALLOC_COMPS_DEFAULT_CTOR);
751	gfc_add_expr_to_block (&block, tem);
752	return gfc_finish_block (&block);
753	}
754	return NULL_TREE;
755	}
756
757	gcc_assert (outer != NULL_TREE);
758
759	/* Allocatable arrays and scalars in PRIVATE clauses need to be set to
760	"not currently allocated" allocation status if outer
761	array is "not currently allocated", otherwise should be allocated. */
762	gfc_start_block (&block);
763
764	gfc_init_block (&cond_block);
765
766	if (GFC_DESCRIPTOR_TYPE_P (type))
767	{
768	gfc_add_modify (&cond_block, decl, outer);
769	tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
770	size = gfc_conv_descriptor_ubound_get (decl, rank);
771	size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
772	size,
773	gfc_conv_descriptor_lbound_get (decl, rank));
774	size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
775	size, gfc_index_one_node);
776	if (GFC_TYPE_ARRAY_RANK (type) > 1)
777	size = fold_build2_loc (input_location, MULT_EXPR,
778	gfc_array_index_type, size,
779	gfc_conv_descriptor_stride_get (decl, rank));
780	tree esize = fold_convert (gfc_array_index_type,
781	TYPE_SIZE_UNIT (gfc_get_element_type (type)));
782	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
783	size, esize);
784	size = unshare_expr (size);
785	size = gfc_evaluate_now (fold_convert (size_type_node, size),
786	&cond_block);
787	}
788	else
789	size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
790	ptr = gfc_create_var (pvoid_type_node, NULL);
791	gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
792	if (GFC_DESCRIPTOR_TYPE_P (type))
793	gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
794	else
795	gfc_add_modify (&cond_block, unshare_expr (decl),
796	fold_convert (TREE_TYPE (decl), ptr));
797	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
798	{
799	tree tem = gfc_walk_alloc_comps (decl: outer, dest: decl,
800	OMP_CLAUSE_DECL (clause),
801	kind: WALK_ALLOC_COMPS_DEFAULT_CTOR);
802	gfc_add_expr_to_block (&cond_block, tem);
803	}
804	then_b = gfc_finish_block (&cond_block);
805
806	/* Reduction clause requires allocated ALLOCATABLE. */
807	if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION
808	&& OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION
809	&& OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_REDUCTION)
810	{
811	gfc_init_block (&cond_block);
812	if (GFC_DESCRIPTOR_TYPE_P (type))
813	gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
814	null_pointer_node);
815	else
816	gfc_add_modify (&cond_block, unshare_expr (decl),
817	build_zero_cst (TREE_TYPE (decl)));
818	else_b = gfc_finish_block (&cond_block);
819
820	tree tem = fold_convert (pvoid_type_node,
821	GFC_DESCRIPTOR_TYPE_P (type)
822	? gfc_conv_descriptor_data_get (outer) : outer);
823	tem = unshare_expr (tem);
824	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
825	tem, null_pointer_node);
826	gfc_add_expr_to_block (&block,
827	build3_loc (loc: input_location, code: COND_EXPR,
828	void_type_node, arg0: cond, arg1: then_b,
829	arg2: else_b));
830	/* Avoid -W*uninitialized warnings. */
831	if (DECL_P (decl))
832	suppress_warning (decl, OPT_Wuninitialized);
833	}
834	else
835	gfc_add_expr_to_block (&block, then_b);
836
837	return gfc_finish_block (&block);
838	}
839
840	/* Build and return code for a copy constructor from SRC to DEST. */
841
842	tree
843	gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
844	{
845	tree type = TREE_TYPE (dest), ptr, size, call;
846	tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
847	tree cond, then_b, else_b;
848	stmtblock_t block, cond_block;
849
850	gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
851	|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
852
853	/* Privatize pointer, only; cf. gfc_omp_predetermined_sharing. */
854	if (DECL_P (OMP_CLAUSE_DECL (clause))
855	&& GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
856	return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
857
858	if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
859	&& DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
860	&& GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
861	decl_type
862	= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
863
864	if (gfc_is_polymorphic_nonptr (type: decl_type))
865	{
866	if (POINTER_TYPE_P (decl_type))
867	decl_type = TREE_TYPE (decl_type);
868	decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
869	if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
870	fatal_error (input_location,
871	"Sorry, polymorphic arrays not yet supported for "
872	"firstprivate");
873	tree src_len;
874	tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */
875	tree src_data = gfc_class_data_get (unshare_expr (src));
876	tree dest_data = gfc_class_data_get (unshare_expr (dest));
877	bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type);
878
879	gfc_start_block (&block);
880	gfc_add_modify (&block, gfc_class_vptr_get (dest),
881	gfc_class_vptr_get (src));
882	gfc_init_block (&cond_block);
883
884	if (unlimited)
885	{
886	src_len = gfc_class_len_get (src);
887	gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len);
888	}
889
890	/* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
891	size = fold_convert (size_type_node, gfc_class_vtab_size_get (src));
892	if (unlimited)
893	{
894	cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
895	unshare_expr (src_len),
896	build_zero_cst (TREE_TYPE (src_len)));
897	cond = build3_loc (loc: input_location, code: COND_EXPR, size_type_node, arg0: cond,
898	fold_convert (size_type_node,
899	unshare_expr (src_len)),
900	arg2: build_int_cst (size_type_node, 1));
901	size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
902	size, cond);
903	}
904
905	/* Malloc memory + call class->_vpt->_copy. */
906	call = builtin_decl_explicit (fncode: BUILT_IN_MALLOC);
907	call = build_call_expr_loc (input_location, call, 1, size);
908	gfc_add_modify (&cond_block, dest_data,
909	fold_convert (TREE_TYPE (dest_data), call));
910	gfc_add_expr_to_block (&cond_block,
911	gfc_copy_class_to_class (src, dest, nelems,
912	unlimited));
913
914	gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF);
915	if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
916	{
917	gfc_add_block_to_block (&block, &cond_block);
918	}
919	else
920	{
921	/* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
922	cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
923	src_data, null_pointer_node);
924	gfc_add_expr_to_block (&block, build3_loc (loc: input_location, code: COND_EXPR,
925	void_type_node, arg0: cond,
926	arg1: gfc_finish_block (&cond_block),
927	arg2: fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
928	unshare_expr (dest_data), null_pointer_node)));
929	}
930	return gfc_finish_block (&block);
931	}
932
933	if ((! GFC_DESCRIPTOR_TYPE_P (type)
934	|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
935	&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
936	|| !POINTER_TYPE_P (type)))
937	{
938	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
939	{
940	gfc_start_block (&block);
941	gfc_add_modify (&block, dest, src);
942	tree tem = gfc_walk_alloc_comps (decl: src, dest, OMP_CLAUSE_DECL (clause),
943	kind: WALK_ALLOC_COMPS_COPY_CTOR);
944	gfc_add_expr_to_block (&block, tem);
945	return gfc_finish_block (&block);
946	}
947	else
948	return build2_v (MODIFY_EXPR, dest, src);
949	}
950
951	/* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
952	and copied from SRC. */
953	gfc_start_block (&block);
954
955	gfc_init_block (&cond_block);
956
957	gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src));
958	if (GFC_DESCRIPTOR_TYPE_P (type))
959	{
960	tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
961	size = gfc_conv_descriptor_ubound_get (dest, rank);
962	size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
963	size,
964	gfc_conv_descriptor_lbound_get (dest, rank));
965	size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
966	size, gfc_index_one_node);
967	if (GFC_TYPE_ARRAY_RANK (type) > 1)
968	size = fold_build2_loc (input_location, MULT_EXPR,
969	gfc_array_index_type, size,
970	gfc_conv_descriptor_stride_get (dest, rank));
971	tree esize = fold_convert (gfc_array_index_type,
972	TYPE_SIZE_UNIT (gfc_get_element_type (type)));
973	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
974	size, esize);
975	size = unshare_expr (size);
976	size = gfc_evaluate_now (fold_convert (size_type_node, size),
977	&cond_block);
978	}
979	else
980	size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
981	ptr = gfc_create_var (pvoid_type_node, NULL);
982	gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
983	if (GFC_DESCRIPTOR_TYPE_P (type))
984	gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
985	else
986	gfc_add_modify (&cond_block, unshare_expr (dest),
987	fold_convert (TREE_TYPE (dest), ptr));
988
989	tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
990	? gfc_conv_descriptor_data_get (src) : src;
991	srcptr = unshare_expr (srcptr);
992	srcptr = fold_convert (pvoid_type_node, srcptr);
993	call = build_call_expr_loc (input_location,
994	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3, ptr,
995	srcptr, size);
996	gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
997	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
998	{
999	tree tem = gfc_walk_alloc_comps (decl: src, dest,
1000	OMP_CLAUSE_DECL (clause),
1001	kind: WALK_ALLOC_COMPS_COPY_CTOR);
1002	gfc_add_expr_to_block (&cond_block, tem);
1003	}
1004	then_b = gfc_finish_block (&cond_block);
1005
1006	gfc_init_block (&cond_block);
1007	if (GFC_DESCRIPTOR_TYPE_P (type))
1008	gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
1009	null_pointer_node);
1010	else
1011	gfc_add_modify (&cond_block, unshare_expr (dest),
1012	build_zero_cst (TREE_TYPE (dest)));
1013	else_b = gfc_finish_block (&cond_block);
1014
1015	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1016	unshare_expr (srcptr), null_pointer_node);
1017	gfc_add_expr_to_block (&block,
1018	build3_loc (loc: input_location, code: COND_EXPR,
1019	void_type_node, arg0: cond, arg1: then_b, arg2: else_b));
1020	/* Avoid -W*uninitialized warnings. */
1021	if (DECL_P (dest))
1022	suppress_warning (dest, OPT_Wuninitialized);
1023
1024	return gfc_finish_block (&block);
1025	}
1026
1027	/* Similarly, except use an intrinsic or pointer assignment operator
1028	instead. */
1029
1030	tree
1031	gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
1032	{
1033	tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
1034	tree cond, then_b, else_b;
1035	stmtblock_t block, cond_block, cond_block2, inner_block;
1036
1037	if ((! GFC_DESCRIPTOR_TYPE_P (type)
1038	|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1039	&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1040	|| !POINTER_TYPE_P (type)))
1041	{
1042	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1043	{
1044	gfc_start_block (&block);
1045	/* First dealloc any allocatable components in DEST. */
1046	tree tem = gfc_walk_alloc_comps (decl: dest, NULL_TREE,
1047	OMP_CLAUSE_DECL (clause),
1048	kind: WALK_ALLOC_COMPS_DTOR);
1049	gfc_add_expr_to_block (&block, tem);
1050	/* Then copy over toplevel data. */
1051	gfc_add_modify (&block, dest, src);
1052	/* Finally allocate any allocatable components and copy. */
1053	tem = gfc_walk_alloc_comps (decl: src, dest, OMP_CLAUSE_DECL (clause),
1054	kind: WALK_ALLOC_COMPS_COPY_CTOR);
1055	gfc_add_expr_to_block (&block, tem);
1056	return gfc_finish_block (&block);
1057	}
1058	else
1059	return build2_v (MODIFY_EXPR, dest, src);
1060	}
1061
1062	gfc_start_block (&block);
1063
1064	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1065	{
1066	then_b = gfc_walk_alloc_comps (decl: dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
1067	kind: WALK_ALLOC_COMPS_DTOR);
1068	tree tem = fold_convert (pvoid_type_node,
1069	GFC_DESCRIPTOR_TYPE_P (type)
1070	? gfc_conv_descriptor_data_get (dest) : dest);
1071	tem = unshare_expr (tem);
1072	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1073	tem, null_pointer_node);
1074	tem = build3_loc (loc: input_location, code: COND_EXPR, void_type_node, arg0: cond,
1075	arg1: then_b, arg2: build_empty_stmt (input_location));
1076	gfc_add_expr_to_block (&block, tem);
1077	}
1078
1079	gfc_init_block (&cond_block);
1080
1081	if (GFC_DESCRIPTOR_TYPE_P (type))
1082	{
1083	tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1084	size = gfc_conv_descriptor_ubound_get (src, rank);
1085	size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1086	size,
1087	gfc_conv_descriptor_lbound_get (src, rank));
1088	size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1089	size, gfc_index_one_node);
1090	if (GFC_TYPE_ARRAY_RANK (type) > 1)
1091	size = fold_build2_loc (input_location, MULT_EXPR,
1092	gfc_array_index_type, size,
1093	gfc_conv_descriptor_stride_get (src, rank));
1094	tree esize = fold_convert (gfc_array_index_type,
1095	TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1096	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1097	size, esize);
1098	size = unshare_expr (size);
1099	size = gfc_evaluate_now (fold_convert (size_type_node, size),
1100	&cond_block);
1101	}
1102	else
1103	size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1104	ptr = gfc_create_var (pvoid_type_node, NULL);
1105
1106	tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
1107	? gfc_conv_descriptor_data_get (dest) : dest;
1108	destptr = unshare_expr (destptr);
1109	destptr = fold_convert (pvoid_type_node, destptr);
1110	gfc_add_modify (&cond_block, ptr, destptr);
1111
1112	nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
1113	destptr, null_pointer_node);
1114	cond = nonalloc;
1115	if (GFC_DESCRIPTOR_TYPE_P (type))
1116	{
1117	int i;
1118	for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
1119	{
1120	tree rank = gfc_rank_cst[i];
1121	tree tem = gfc_conv_descriptor_ubound_get (src, rank);
1122	tem = fold_build2_loc (input_location, MINUS_EXPR,
1123	gfc_array_index_type, tem,
1124	gfc_conv_descriptor_lbound_get (src, rank));
1125	tem = fold_build2_loc (input_location, PLUS_EXPR,
1126	gfc_array_index_type, tem,
1127	gfc_conv_descriptor_lbound_get (dest, rank));
1128	tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1129	tem, gfc_conv_descriptor_ubound_get (dest,
1130	rank));
1131	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1132	logical_type_node, cond, tem);
1133	}
1134	}
1135
1136	gfc_init_block (&cond_block2);
1137
1138	if (GFC_DESCRIPTOR_TYPE_P (type))
1139	{
1140	gfc_init_block (&inner_block);
1141	gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
1142	then_b = gfc_finish_block (&inner_block);
1143
1144	gfc_init_block (&inner_block);
1145	gfc_add_modify (&inner_block, ptr,
1146	gfc_call_realloc (&inner_block, ptr, size));
1147	else_b = gfc_finish_block (&inner_block);
1148
1149	gfc_add_expr_to_block (&cond_block2,
1150	build3_loc (loc: input_location, code: COND_EXPR,
1151	void_type_node,
1152	arg0: unshare_expr (nonalloc),
1153	arg1: then_b, arg2: else_b));
1154	gfc_add_modify (&cond_block2, dest, src);
1155	gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
1156	}
1157	else
1158	{
1159	gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
1160	gfc_add_modify (&cond_block2, unshare_expr (dest),
1161	fold_convert (type, ptr));
1162	}
1163	then_b = gfc_finish_block (&cond_block2);
1164	else_b = build_empty_stmt (input_location);
1165
1166	gfc_add_expr_to_block (&cond_block,
1167	build3_loc (loc: input_location, code: COND_EXPR,
1168	void_type_node, arg0: unshare_expr (cond),
1169	arg1: then_b, arg2: else_b));
1170
1171	tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
1172	? gfc_conv_descriptor_data_get (src) : src;
1173	srcptr = unshare_expr (srcptr);
1174	srcptr = fold_convert (pvoid_type_node, srcptr);
1175	call = build_call_expr_loc (input_location,
1176	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY), 3, ptr,
1177	srcptr, size);
1178	gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1179	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1180	{
1181	tree tem = gfc_walk_alloc_comps (decl: src, dest,
1182	OMP_CLAUSE_DECL (clause),
1183	kind: WALK_ALLOC_COMPS_COPY_CTOR);
1184	gfc_add_expr_to_block (&cond_block, tem);
1185	}
1186	then_b = gfc_finish_block (&cond_block);
1187
1188	if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
1189	{
1190	gfc_init_block (&cond_block);
1191	if (GFC_DESCRIPTOR_TYPE_P (type))
1192	{
1193	tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest));
1194	tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1195	NULL_TREE, NULL_TREE, true, NULL,
1196	GFC_CAF_COARRAY_NOCOARRAY);
1197	gfc_add_expr_to_block (&cond_block, tmp);
1198	}
1199	else
1200	{
1201	destptr = gfc_evaluate_now (destptr, &cond_block);
1202	gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
1203	gfc_add_modify (&cond_block, unshare_expr (dest),
1204	build_zero_cst (TREE_TYPE (dest)));
1205	}
1206	else_b = gfc_finish_block (&cond_block);
1207
1208	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1209	unshare_expr (srcptr), null_pointer_node);
1210	gfc_add_expr_to_block (&block,
1211	build3_loc (loc: input_location, code: COND_EXPR,
1212	void_type_node, arg0: cond,
1213	arg1: then_b, arg2: else_b));
1214	}
1215	else
1216	gfc_add_expr_to_block (&block, then_b);
1217
1218	return gfc_finish_block (&block);
1219	}
1220
1221	static void
1222	gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src,
1223	tree add, tree nelems)
1224	{
1225	stmtblock_t tmpblock;
1226	tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S");
1227	nelems = gfc_evaluate_now (nelems, block);
1228
1229	gfc_init_block (&tmpblock);
1230	if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE)
1231	{
1232	desta = gfc_build_array_ref (dest, index, NULL);
1233	srca = gfc_build_array_ref (src, index, NULL);
1234	}
1235	else
1236	{
1237	gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest)));
1238	tree idx = fold_build2 (MULT_EXPR, sizetype,
1239	fold_convert (sizetype, index),
1240	TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest))));
1241	desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
1242	TREE_TYPE (dest), dest,
1243	idx));
1244	srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR,
1245	TREE_TYPE (src), src,
1246	idx));
1247	}
1248	gfc_add_modify (&tmpblock, desta,
1249	fold_build2 (PLUS_EXPR, TREE_TYPE (desta),
1250	srca, add));
1251
1252	gfc_loopinfo loop;
1253	gfc_init_loopinfo (&loop);
1254	loop.dimen = 1;
1255	loop.from[0] = gfc_index_zero_node;
1256	loop.loopvar[0] = index;
1257	loop.to[0] = nelems;
1258	gfc_trans_scalarizing_loops (&loop, &tmpblock);
1259	gfc_add_block_to_block (block, &loop.pre);
1260	}
1261
1262	/* Build and return code for a constructor of DEST that initializes
1263	it to SRC plus ADD (ADD is scalar integer). */
1264
1265	tree
1266	gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add)
1267	{
1268	tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE;
1269	stmtblock_t block;
1270
1271	gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
1272
1273	gfc_start_block (&block);
1274	add = gfc_evaluate_now (add, &block);
1275
1276	if ((! GFC_DESCRIPTOR_TYPE_P (type)
1277	|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1278	&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1279	|| !POINTER_TYPE_P (type)))
1280	{
1281	bool compute_nelts = false;
1282	gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1283	if (!TYPE_DOMAIN (type)
1284	|| TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
1285	|| TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
1286	|| TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
1287	compute_nelts = true;
1288	else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
1289	{
1290	tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
1291	if (lookup_attribute (attr_name: "omp dummy var", list: a))
1292	compute_nelts = true;
1293	}
1294	if (compute_nelts)
1295	{
1296	nelems = fold_build2 (EXACT_DIV_EXPR, sizetype,
1297	TYPE_SIZE_UNIT (type),
1298	TYPE_SIZE_UNIT (TREE_TYPE (type)));
1299	nelems = size_binop (MINUS_EXPR, nelems, size_one_node);
1300	}
1301	else
1302	nelems = array_type_nelts (type);
1303	nelems = fold_convert (gfc_array_index_type, nelems);
1304
1305	gfc_omp_linear_clause_add_loop (block: &block, dest, src, add, nelems);
1306	return gfc_finish_block (&block);
1307	}
1308
1309	/* Allocatable arrays in LINEAR clauses need to be allocated
1310	and copied from SRC. */
1311	gfc_add_modify (&block, dest, src);
1312	if (GFC_DESCRIPTOR_TYPE_P (type))
1313	{
1314	tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1315	size = gfc_conv_descriptor_ubound_get (dest, rank);
1316	size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1317	size,
1318	gfc_conv_descriptor_lbound_get (dest, rank));
1319	size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1320	size, gfc_index_one_node);
1321	if (GFC_TYPE_ARRAY_RANK (type) > 1)
1322	size = fold_build2_loc (input_location, MULT_EXPR,
1323	gfc_array_index_type, size,
1324	gfc_conv_descriptor_stride_get (dest, rank));
1325	tree esize = fold_convert (gfc_array_index_type,
1326	TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1327	nelems = gfc_evaluate_now (unshare_expr (size), &block);
1328	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1329	nelems, unshare_expr (esize));
1330	size = gfc_evaluate_now (fold_convert (size_type_node, size),
1331	&block);
1332	nelems = fold_build2_loc (input_location, MINUS_EXPR,
1333	gfc_array_index_type, nelems,
1334	gfc_index_one_node);
1335	}
1336	else
1337	size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
1338	ptr = gfc_create_var (pvoid_type_node, NULL);
1339	gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
1340	if (GFC_DESCRIPTOR_TYPE_P (type))
1341	{
1342	gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr);
1343	tree etype = gfc_get_element_type (type);
1344	ptr = fold_convert (build_pointer_type (etype), ptr);
1345	tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src));
1346	srcptr = fold_convert (build_pointer_type (etype), srcptr);
1347	gfc_omp_linear_clause_add_loop (block: &block, dest: ptr, src: srcptr, add, nelems);
1348	}
1349	else
1350	{
1351	gfc_add_modify (&block, unshare_expr (dest),
1352	fold_convert (TREE_TYPE (dest), ptr));
1353	ptr = fold_convert (TREE_TYPE (dest), ptr);
1354	tree dstm = build_fold_indirect_ref (ptr);
1355	tree srcm = build_fold_indirect_ref (unshare_expr (src));
1356	gfc_add_modify (&block, dstm,
1357	fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add));
1358	}
1359	return gfc_finish_block (&block);
1360	}
1361
1362	/* Build and return code destructing DECL. Return NULL if nothing
1363	to be done. */
1364
1365	tree
1366	gfc_omp_clause_dtor (tree clause, tree decl)
1367	{
1368	tree type = TREE_TYPE (decl), tem;
1369	tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
1370
1371	/* Only pointer was privatized; cf. gfc_omp_clause_copy_ctor. */
1372	if (DECL_P (OMP_CLAUSE_DECL (clause))
1373	&& GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
1374	return NULL_TREE;
1375
1376	if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
1377	&& DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
1378	&& GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
1379	decl_type
1380	= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
1381	if (gfc_is_polymorphic_nonptr (type: decl_type))
1382	{
1383	if (POINTER_TYPE_P (decl_type))
1384	decl_type = TREE_TYPE (decl_type);
1385	decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
1386	if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
1387	fatal_error (input_location,
1388	"Sorry, polymorphic arrays not yet supported for "
1389	"firstprivate");
1390	stmtblock_t block, cond_block;
1391	gfc_start_block (&block);
1392	gfc_init_block (&cond_block);
1393	tree final = gfc_class_vtab_final_get (decl);
1394	tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl));
1395	gfc_se se;
1396	gfc_init_se (&se, NULL);
1397	symbol_attribute attr = {};
1398	tree data = gfc_class_data_get (decl);
1399	tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr);
1400
1401	/* Call class->_vpt->_finalize + free. */
1402	tree call = build_fold_indirect_ref (final);
1403	call = build_call_expr_loc (input_location, call, 3,
1404	gfc_build_addr_expr (NULL, desc),
1405	size, boolean_false_node);
1406	gfc_add_block_to_block (&cond_block, &se.pre);
1407	gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1408	gfc_add_block_to_block (&cond_block, &se.post);
1409	/* Create: if (_vtab && _final) <cond_block> */
1410	tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1411	gfc_class_vptr_get (decl),
1412	null_pointer_node);
1413	tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1414	final, null_pointer_node);
1415	cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1416	boolean_type_node, cond, cond2);
1417	gfc_add_expr_to_block (&block, build3_loc (loc: input_location, code: COND_EXPR,
1418	void_type_node, arg0: cond,
1419	arg1: gfc_finish_block (&cond_block), NULL_TREE));
1420	call = builtin_decl_explicit (fncode: BUILT_IN_FREE);
1421	call = build_call_expr_loc (input_location, call, 1, data);
1422	gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
1423	return gfc_finish_block (&block);
1424	}
1425
1426	if ((! GFC_DESCRIPTOR_TYPE_P (type)
1427	|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1428	&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1429	|| !POINTER_TYPE_P (type)))
1430	{
1431	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1432	return gfc_walk_alloc_comps (decl, NULL_TREE,
1433	OMP_CLAUSE_DECL (clause),
1434	kind: WALK_ALLOC_COMPS_DTOR);
1435	return NULL_TREE;
1436	}
1437
1438	if (GFC_DESCRIPTOR_TYPE_P (type))
1439	{
1440	/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1441	to be deallocated if they were allocated. */
1442	tem = gfc_conv_descriptor_data_get (decl);
1443	tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE,
1444	NULL_TREE, true, NULL,
1445	GFC_CAF_COARRAY_NOCOARRAY);
1446	}
1447	else
1448	tem = gfc_call_free (decl);
1449	tem = gfc_omp_unshare_expr (expr: tem);
1450
1451	if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
1452	{
1453	stmtblock_t block;
1454	tree then_b;
1455
1456	gfc_init_block (&block);
1457	gfc_add_expr_to_block (&block,
1458	gfc_walk_alloc_comps (decl, NULL_TREE,
1459	OMP_CLAUSE_DECL (clause),
1460	kind: WALK_ALLOC_COMPS_DTOR));
1461	gfc_add_expr_to_block (&block, tem);
1462	then_b = gfc_finish_block (&block);
1463
1464	tem = fold_convert (pvoid_type_node,
1465	GFC_DESCRIPTOR_TYPE_P (type)
1466	? gfc_conv_descriptor_data_get (decl) : decl);
1467	tem = unshare_expr (tem);
1468	tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1469	tem, null_pointer_node);
1470	tem = build3_loc (loc: input_location, code: COND_EXPR, void_type_node, arg0: cond,
1471	arg1: then_b, arg2: build_empty_stmt (input_location));
1472	}
1473	return tem;
1474	}
1475
1476	/* Build a conditional expression in BLOCK. If COND_VAL is not
1477	null, then the block THEN_B is executed, otherwise ELSE_VAL
1478	is assigned to VAL. */
1479
1480	static void
1481	gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val,
1482	tree then_b, tree else_val)
1483	{
1484	stmtblock_t cond_block;
1485	tree else_b = NULL_TREE;
1486	tree val_ty = TREE_TYPE (val);
1487
1488	if (else_val)
1489	{
1490	gfc_init_block (&cond_block);
1491	gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val));
1492	else_b = gfc_finish_block (&cond_block);
1493	}
1494	gfc_add_expr_to_block (block,
1495	build3_loc (loc: input_location, code: COND_EXPR, void_type_node,
1496	arg0: cond_val, arg1: then_b, arg2: else_b));
1497	}
1498
1499	/* Build a conditional expression in BLOCK, returning a temporary
1500	variable containing the result. If COND_VAL is not null, then
1501	THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
1502	is assigned.
1503	*/
1504
1505	static tree
1506	gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val,
1507	tree then_val, tree else_val)
1508	{
1509	tree val;
1510	tree val_ty = TREE_TYPE (then_val);
1511	stmtblock_t cond_block;
1512
1513	val = create_tmp_var (val_ty);
1514
1515	gfc_init_block (&cond_block);
1516	gfc_add_modify (&cond_block, val, then_val);
1517	tree then_b = gfc_finish_block (&cond_block);
1518
1519	gfc_build_cond_assign (block, val, cond_val, then_b, else_val);
1520
1521	return val;
1522	}
1523
1524	void
1525	gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
1526	{
1527	if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1528	return;
1529
1530	tree decl = OMP_CLAUSE_DECL (c);
1531
1532	/* Assumed-size arrays can't be mapped implicitly, they have to be
1533	mapped explicitly using array sections. */
1534	if (TREE_CODE (decl) == PARM_DECL
1535	&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
1536	&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
1537	&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
1538	GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
1539	== NULL)
1540	{
1541	error_at (OMP_CLAUSE_LOCATION (c),
1542	"implicit mapping of assumed size array %qD", decl);
1543	return;
1544	}
1545
1546	tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1547	tree present = gfc_omp_check_optional_argument (decl, for_present_check: true);
1548	if (POINTER_TYPE_P (TREE_TYPE (decl)))
1549	{
1550	if (!gfc_omp_privatize_by_reference (decl)
1551	&& !GFC_DECL_GET_SCALAR_POINTER (decl)
1552	&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1553	&& !GFC_DECL_CRAY_POINTEE (decl)
1554	&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
1555	return;
1556	tree orig_decl = decl;
1557
1558	c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1559	OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
1560	OMP_CLAUSE_DECL (c4) = decl;
1561	OMP_CLAUSE_SIZE (c4) = size_int (0);
1562	decl = build_fold_indirect_ref (decl);
1563	if (present
1564	&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1565	|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1566	{
1567	c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1568	OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
1569	OMP_CLAUSE_DECL (c2) = decl;
1570	OMP_CLAUSE_SIZE (c2) = size_int (0);
1571
1572	stmtblock_t block;
1573	gfc_start_block (&block);
1574	tree ptr = decl;
1575	ptr = gfc_build_cond_assign_expr (block: &block, cond_val: present, then_val: decl,
1576	null_pointer_node);
1577	gimplify_and_add (gfc_finish_block (&block), pre_p);
1578	ptr = build_fold_indirect_ref (ptr);
1579	OMP_CLAUSE_DECL (c) = ptr;
1580	OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
1581	}
1582	else
1583	{
1584	OMP_CLAUSE_DECL (c) = decl;
1585	OMP_CLAUSE_SIZE (c) = NULL_TREE;
1586	}
1587	if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1588	&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1589	|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
1590	{
1591	c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1592	OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
1593	OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
1594	OMP_CLAUSE_SIZE (c3) = size_int (0);
1595	decl = build_fold_indirect_ref (decl);
1596	OMP_CLAUSE_DECL (c) = decl;
1597	}
1598	}
1599	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
1600	{
1601	stmtblock_t block;
1602	gfc_start_block (&block);
1603	tree type = TREE_TYPE (decl);
1604	tree ptr = gfc_conv_descriptor_data_get (decl);
1605
1606	/* OpenMP: automatically map pointer targets with the pointer;
1607	hence, always update the descriptor/pointer itself.
1608	NOTE: This also remaps the pointer for allocatable arrays with
1609	'target' attribute which also don't have the 'restrict' qualifier. */
1610	bool always_modifier = false;
1611
1612	if (!openacc
1613	&& !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT))
1614	always_modifier = true;
1615
1616	if (present)
1617	ptr = gfc_build_cond_assign_expr (block: &block, cond_val: present, then_val: ptr,
1618	null_pointer_node);
1619	gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
1620	ptr = build_fold_indirect_ref (ptr);
1621	OMP_CLAUSE_DECL (c) = ptr;
1622	c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
1623	OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
1624	if (present)
1625	{
1626	ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0)));
1627	gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0));
1628
1629	OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr);
1630	}
1631	else
1632	OMP_CLAUSE_DECL (c2) = decl;
1633	OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type);
1634	c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1635	OMP_CLAUSE_SET_MAP_KIND (c3, always_modifier ? GOMP_MAP_ALWAYS_POINTER
1636	: GOMP_MAP_POINTER);
1637	if (present)
1638	{
1639	ptr = gfc_conv_descriptor_data_get (decl);
1640	ptr = gfc_build_addr_expr (NULL, ptr);
1641	ptr = gfc_build_cond_assign_expr (block: &block, cond_val: present,
1642	then_val: ptr, null_pointer_node);
1643	ptr = build_fold_indirect_ref (ptr);
1644	OMP_CLAUSE_DECL (c3) = ptr;
1645	}
1646	else
1647	OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
1648	OMP_CLAUSE_SIZE (c3) = size_int (0);
1649	tree size = create_tmp_var (gfc_array_index_type);
1650	tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
1651	elemsz = fold_convert (gfc_array_index_type, elemsz);
1652	if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
1653	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
1654	|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
1655	{
1656	stmtblock_t cond_block;
1657	tree tem, then_b, else_b, zero, cond;
1658
1659	gfc_init_block (&cond_block);
1660	tem = gfc_full_array_size (&cond_block, decl,
1661	GFC_TYPE_ARRAY_RANK (type));
1662	gfc_add_modify (&cond_block, size, tem);
1663	gfc_add_modify (&cond_block, size,
1664	fold_build2 (MULT_EXPR, gfc_array_index_type,
1665	size, elemsz));
1666	then_b = gfc_finish_block (&cond_block);
1667	gfc_init_block (&cond_block);
1668	zero = build_int_cst (gfc_array_index_type, 0);
1669	gfc_add_modify (&cond_block, size, zero);
1670	else_b = gfc_finish_block (&cond_block);
1671	tem = gfc_conv_descriptor_data_get (decl);
1672	tem = fold_convert (pvoid_type_node, tem);
1673	cond = fold_build2_loc (input_location, NE_EXPR,
1674	boolean_type_node, tem, null_pointer_node);
1675	if (present)
1676	{
1677	cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1678	boolean_type_node, present, cond);
1679	}
1680	gfc_add_expr_to_block (&block, build3_loc (loc: input_location, code: COND_EXPR,
1681	void_type_node, arg0: cond,
1682	arg1: then_b, arg2: else_b));
1683	}
1684	else if (present)
1685	{
1686	stmtblock_t cond_block;
1687	tree then_b;
1688
1689	gfc_init_block (&cond_block);
1690	gfc_add_modify (&cond_block, size,
1691	gfc_full_array_size (&cond_block, decl,
1692	GFC_TYPE_ARRAY_RANK (type)));
1693	gfc_add_modify (&cond_block, size,
1694	fold_build2 (MULT_EXPR, gfc_array_index_type,
1695	size, elemsz));
1696	then_b = gfc_finish_block (&cond_block);
1697
1698	gfc_build_cond_assign (block: &block, val: size, cond_val: present, then_b,
1699	else_val: build_int_cst (gfc_array_index_type, 0));
1700	}
1701	else
1702	{
1703	gfc_add_modify (&block, size,
1704	gfc_full_array_size (&block, decl,
1705	GFC_TYPE_ARRAY_RANK (type)));
1706	gfc_add_modify (&block, size,
1707	fold_build2 (MULT_EXPR, gfc_array_index_type,
1708	size, elemsz));
1709	}
1710	OMP_CLAUSE_SIZE (c) = size;
1711	tree stmt = gfc_finish_block (&block);
1712	gimplify_and_add (stmt, pre_p);
1713	}
1714	tree last = c;
1715	if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
1716	OMP_CLAUSE_SIZE (c)
1717	= DECL_P (decl) ? DECL_SIZE_UNIT (decl)
1718	: TYPE_SIZE_UNIT (TREE_TYPE (decl));
1719	if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
1720	NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
1721	OMP_CLAUSE_SIZE (c) = size_int (0);
1722	if (c2)
1723	{
1724	OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last);
1725	OMP_CLAUSE_CHAIN (last) = c2;
1726	last = c2;
1727	}
1728	if (c3)
1729	{
1730	OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last);
1731	OMP_CLAUSE_CHAIN (last) = c3;
1732	last = c3;
1733	}
1734	if (c4)
1735	{
1736	OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last);
1737	OMP_CLAUSE_CHAIN (last) = c4;
1738	}
1739	}
1740
1741
1742	/* Return true if DECL is a scalar variable (for the purpose of
1743	implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
1744	is true, allocatables and pointers are permitted. */
1745
1746	bool
1747	gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok)
1748	{
1749	tree type = TREE_TYPE (decl);
1750	if (TREE_CODE (type) == REFERENCE_TYPE)
1751	type = TREE_TYPE (type);
1752	if (TREE_CODE (type) == POINTER_TYPE)
1753	{
1754	if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1755	|| GFC_DECL_GET_SCALAR_POINTER (decl))
1756	{
1757	if (!ptr_alloc_ok)
1758	return false;
1759	type = TREE_TYPE (type);
1760	}
1761	if (GFC_ARRAY_TYPE_P (type)
1762	|| GFC_CLASS_TYPE_P (type))
1763	return false;
1764	}
1765	if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
1766	&& TYPE_STRING_FLAG (type))
1767	return false;
1768	if (INTEGRAL_TYPE_P (type)
1769	|| SCALAR_FLOAT_TYPE_P (type)
1770	|| COMPLEX_FLOAT_TYPE_P (type))
1771	return true;
1772	return false;
1773	}
1774
1775
1776	/* Return true if DECL is a scalar with target attribute but does not have the
1777	allocatable (or pointer) attribute (for the purpose of implicit mapping). */
1778
1779	bool
1780	gfc_omp_scalar_target_p (tree decl)
1781	{
1782	return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl)
1783	&& gfc_omp_scalar_p (decl, ptr_alloc_ok: false));
1784	}
1785
1786
1787	/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1788	disregarded in OpenMP construct, because it is going to be
1789	remapped during OpenMP lowering. SHARED is true if DECL
1790	is going to be shared, false if it is going to be privatized. */
1791
1792	bool
1793	gfc_omp_disregard_value_expr (tree decl, bool shared)
1794	{
1795	if (GFC_DECL_COMMON_OR_EQUIV (decl)
1796	&& DECL_HAS_VALUE_EXPR_P (decl))
1797	{
1798	tree value = DECL_VALUE_EXPR (decl);
1799
1800	if (TREE_CODE (value) == COMPONENT_REF
1801	&& VAR_P (TREE_OPERAND (value, 0))
1802	&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1803	{
1804	/* If variable in COMMON or EQUIVALENCE is privatized, return
1805	true, as just that variable is supposed to be privatized,
1806	not the whole COMMON or whole EQUIVALENCE.
1807	For shared variables in COMMON or EQUIVALENCE, let them be
1808	gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1809	from the same COMMON or EQUIVALENCE just one sharing of the
1810	whole COMMON or EQUIVALENCE is enough. */
1811	return ! shared;
1812	}
1813	}
1814
1815	if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
1816	return ! shared;
1817
1818	return false;
1819	}
1820
1821	/* Return true if DECL that is shared iff SHARED is true should
1822	be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1823	flag set. */
1824
1825	bool
1826	gfc_omp_private_debug_clause (tree decl, bool shared)
1827	{
1828	if (GFC_DECL_CRAY_POINTEE (decl))
1829	return true;
1830
1831	if (GFC_DECL_COMMON_OR_EQUIV (decl)
1832	&& DECL_HAS_VALUE_EXPR_P (decl))
1833	{
1834	tree value = DECL_VALUE_EXPR (decl);
1835
1836	if (TREE_CODE (value) == COMPONENT_REF
1837	&& VAR_P (TREE_OPERAND (value, 0))
1838	&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
1839	return shared;
1840	}
1841
1842	return false;
1843	}
1844
1845	/* Register language specific type size variables as potentially OpenMP
1846	firstprivate variables. */
1847
1848	void
1849	gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
1850	{
1851	if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
1852	{
1853	int r;
1854
1855	gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
1856	for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
1857	{
1858	omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
1859	omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
1860	omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
1861	}
1862	omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
1863	omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
1864	}
1865	}
1866
1867
1868	static inline tree
1869	gfc_trans_add_clause (tree node, tree tail)
1870	{
1871	OMP_CLAUSE_CHAIN (node) = tail;
1872	return node;
1873	}
1874
1875	static tree
1876	gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
1877	{
1878	if (declare_simd)
1879	{
1880	int cnt = 0;
1881	gfc_symbol *proc_sym;
1882	gfc_formal_arglist *f;
1883
1884	gcc_assert (sym->attr.dummy);
1885	proc_sym = sym->ns->proc_name;
1886	if (proc_sym->attr.entry_master)
1887	++cnt;
1888	if (gfc_return_by_reference (proc_sym))
1889	{
1890	++cnt;
1891	if (proc_sym->ts.type == BT_CHARACTER)
1892	++cnt;
1893	}
1894	for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
1895	if (f->sym == sym)
1896	break;
1897	else if (f->sym)
1898	++cnt;
1899	gcc_assert (f);
1900	return build_int_cst (integer_type_node, cnt);
1901	}
1902
1903	tree t = gfc_get_symbol_decl (sym);
1904	tree parent_decl;
1905	int parent_flag;
1906	bool return_value;
1907	bool alternate_entry;
1908	bool entry_master;
1909
1910	return_value = sym->attr.function && sym->result == sym;
1911	alternate_entry = sym->attr.function && sym->attr.entry
1912	&& sym->result == sym;
1913	entry_master = sym->attr.result
1914	&& sym->ns->proc_name->attr.entry_master
1915	&& !gfc_return_by_reference (sym->ns->proc_name);
1916	parent_decl = current_function_decl
1917	? DECL_CONTEXT (current_function_decl) : NULL_TREE;
1918
1919	if ((t == parent_decl && return_value)
1920	|| (sym->ns && sym->ns->proc_name
1921	&& sym->ns->proc_name->backend_decl == parent_decl
1922	&& (alternate_entry || entry_master)))
1923	parent_flag = 1;
1924	else
1925	parent_flag = 0;
1926
1927	/* Special case for assigning the return value of a function.
1928	Self recursive functions must have an explicit return value. */
1929	if (return_value && (t == current_function_decl || parent_flag))
1930	t = gfc_get_fake_result_decl (sym, parent_flag);
1931
1932	/* Similarly for alternate entry points. */
1933	else if (alternate_entry
1934	&& (sym->ns->proc_name->backend_decl == current_function_decl
1935	|| parent_flag))
1936	{
1937	gfc_entry_list *el = NULL;
1938
1939	for (el = sym->ns->entries; el; el = el->next)
1940	if (sym == el->sym)
1941	{
1942	t = gfc_get_fake_result_decl (sym, parent_flag);
1943	break;
1944	}
1945	}
1946
1947	else if (entry_master
1948	&& (sym->ns->proc_name->backend_decl == current_function_decl
1949	|| parent_flag))
1950	t = gfc_get_fake_result_decl (sym, parent_flag);
1951
1952	return t;
1953	}
1954
1955	static tree
1956	gfc_trans_omp_variable_list (enum omp_clause_code code,
1957	gfc_omp_namelist *namelist, tree list,
1958	bool declare_simd)
1959	{
1960	for (; namelist != NULL; namelist = namelist->next)
1961	if (namelist->sym->attr.referenced || declare_simd)
1962	{
1963	tree t = gfc_trans_omp_variable (sym: namelist->sym, declare_simd);
1964	if (t != error_mark_node)
1965	{
1966	tree node;
1967	node = build_omp_clause (input_location, code);
1968	OMP_CLAUSE_DECL (node) = t;
1969	list = gfc_trans_add_clause (node, tail: list);
1970
1971	if (code == OMP_CLAUSE_LASTPRIVATE
1972	&& namelist->u.lastprivate_conditional)
1973	OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1;
1974	}
1975	}
1976	return list;
1977	}
1978
1979	struct omp_udr_find_orig_data
1980	{
1981	gfc_omp_udr *omp_udr;
1982	bool omp_orig_seen;
1983	};
1984
1985	static int
1986	omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1987	void *data)
1988	{
1989	struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
1990	if ((*e)->expr_type == EXPR_VARIABLE
1991	&& (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
1992	cd->omp_orig_seen = true;
1993
1994	return 0;
1995	}
1996
1997	static void
1998	gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
1999	{
2000	gfc_symbol *sym = n->sym;
2001	gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
2002	gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
2003	gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
2004	gfc_symbol omp_var_copy[4];
2005	gfc_expr *e1, *e2, *e3, *e4;
2006	gfc_ref *ref;
2007	tree decl, backend_decl, stmt, type, outer_decl;
2008	locus old_loc = gfc_current_locus;
2009	const char *iname;
2010	bool t;
2011	gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL;
2012
2013	decl = OMP_CLAUSE_DECL (c);
2014	gfc_current_locus = where;
2015	type = TREE_TYPE (decl);
2016	outer_decl = create_tmp_var_raw (type);
2017	if (TREE_CODE (decl) == PARM_DECL
2018	&& TREE_CODE (type) == REFERENCE_TYPE
2019	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
2020	&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
2021	{
2022	decl = build_fold_indirect_ref (decl);
2023	type = TREE_TYPE (type);
2024	}
2025
2026	/* Create a fake symbol for init value. */
2027	memset (s: &init_val_sym, c: 0, n: sizeof (init_val_sym));
2028	init_val_sym.ns = sym->ns;
2029	init_val_sym.name = sym->name;
2030	init_val_sym.ts = sym->ts;
2031	init_val_sym.attr.referenced = 1;
2032	init_val_sym.declared_at = where;
2033	init_val_sym.attr.flavor = FL_VARIABLE;
2034	if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
2035	backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
2036	else if (udr->initializer_ns)
2037	backend_decl = NULL;
2038	else
2039	switch (sym->ts.type)
2040	{
2041	case BT_LOGICAL:
2042	case BT_INTEGER:
2043	case BT_REAL:
2044	case BT_COMPLEX:
2045	backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
2046	break;
2047	default:
2048	backend_decl = NULL_TREE;
2049	break;
2050	}
2051	init_val_sym.backend_decl = backend_decl;
2052
2053	/* Create a fake symbol for the outer array reference. */
2054	outer_sym = *sym;
2055	if (sym->as)
2056	outer_sym.as = gfc_copy_array_spec (sym->as);
2057	outer_sym.attr.dummy = 0;
2058	outer_sym.attr.result = 0;
2059	outer_sym.attr.flavor = FL_VARIABLE;
2060	outer_sym.backend_decl = outer_decl;
2061	if (decl != OMP_CLAUSE_DECL (c))
2062	outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
2063
2064	/* Create fake symtrees for it. */
2065	symtree1 = gfc_new_symtree (&root1, sym->name);
2066	symtree1->n.sym = sym;
2067	gcc_assert (symtree1 == root1);
2068
2069	symtree2 = gfc_new_symtree (&root2, sym->name);
2070	symtree2->n.sym = &init_val_sym;
2071	gcc_assert (symtree2 == root2);
2072
2073	symtree3 = gfc_new_symtree (&root3, sym->name);
2074	symtree3->n.sym = &outer_sym;
2075	gcc_assert (symtree3 == root3);
2076
2077	memset (s: omp_var_copy, c: 0, n: sizeof omp_var_copy);
2078	if (udr)
2079	{
2080	omp_var_copy[0] = *udr->omp_out;
2081	omp_var_copy[1] = *udr->omp_in;
2082	*udr->omp_out = outer_sym;
2083	*udr->omp_in = *sym;
2084	if (udr->initializer_ns)
2085	{
2086	omp_var_copy[2] = *udr->omp_priv;
2087	omp_var_copy[3] = *udr->omp_orig;
2088	*udr->omp_priv = *sym;
2089	*udr->omp_orig = outer_sym;
2090	}
2091	}
2092
2093	/* Create expressions. */
2094	e1 = gfc_get_expr ();
2095	e1->expr_type = EXPR_VARIABLE;
2096	e1->where = where;
2097	e1->symtree = symtree1;
2098	e1->ts = sym->ts;
2099	if (sym->attr.dimension)
2100	{
2101	e1->ref = ref = gfc_get_ref ();
2102	ref->type = REF_ARRAY;
2103	ref->u.ar.where = where;
2104	ref->u.ar.as = sym->as;
2105	ref->u.ar.type = AR_FULL;
2106	ref->u.ar.dimen = 0;
2107	}
2108	t = gfc_resolve_expr (e1);
2109	gcc_assert (t);
2110
2111	e2 = NULL;
2112	if (backend_decl != NULL_TREE)
2113	{
2114	e2 = gfc_get_expr ();
2115	e2->expr_type = EXPR_VARIABLE;
2116	e2->where = where;
2117	e2->symtree = symtree2;
2118	e2->ts = sym->ts;
2119	t = gfc_resolve_expr (e2);
2120	gcc_assert (t);
2121	}
2122	else if (udr->initializer_ns == NULL)
2123	{
2124	gcc_assert (sym->ts.type == BT_DERIVED);
2125	e2 = gfc_default_initializer (&sym->ts);
2126	gcc_assert (e2);
2127	t = gfc_resolve_expr (e2);
2128	gcc_assert (t);
2129	}
2130	else if (n->u2.udr->initializer->op == EXEC_ASSIGN)
2131	{
2132	e2 = gfc_copy_expr (n->u2.udr->initializer->expr2);
2133	t = gfc_resolve_expr (e2);
2134	gcc_assert (t);
2135	}
2136	if (udr && udr->initializer_ns)
2137	{
2138	struct omp_udr_find_orig_data cd;
2139	cd.omp_udr = udr;
2140	cd.omp_orig_seen = false;
2141	gfc_code_walker (&n->u2.udr->initializer,
2142	gfc_dummy_code_callback, omp_udr_find_orig, &cd);
2143	if (cd.omp_orig_seen)
2144	OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
2145	}
2146
2147	e3 = gfc_copy_expr (e1);
2148	e3->symtree = symtree3;
2149	t = gfc_resolve_expr (e3);
2150	gcc_assert (t);
2151
2152	iname = NULL;
2153	e4 = NULL;
2154	switch (OMP_CLAUSE_REDUCTION_CODE (c))
2155	{
2156	case PLUS_EXPR:
2157	case MINUS_EXPR:
2158	e4 = gfc_add (e3, e1);
2159	break;
2160	case MULT_EXPR:
2161	e4 = gfc_multiply (e3, e1);
2162	break;
2163	case TRUTH_ANDIF_EXPR:
2164	e4 = gfc_and (e3, e1);
2165	break;
2166	case TRUTH_ORIF_EXPR:
2167	e4 = gfc_or (e3, e1);
2168	break;
2169	case EQ_EXPR:
2170	e4 = gfc_eqv (e3, e1);
2171	break;
2172	case NE_EXPR:
2173	e4 = gfc_neqv (e3, e1);
2174	break;
2175	case MIN_EXPR:
2176	iname = "min";
2177	break;
2178	case MAX_EXPR:
2179	iname = "max";
2180	break;
2181	case BIT_AND_EXPR:
2182	iname = "iand";
2183	break;
2184	case BIT_IOR_EXPR:
2185	iname = "ior";
2186	break;
2187	case BIT_XOR_EXPR:
2188	iname = "ieor";
2189	break;
2190	case ERROR_MARK:
2191	if (n->u2.udr->combiner->op == EXEC_ASSIGN)
2192	{
2193	gfc_free_expr (e3);
2194	e3 = gfc_copy_expr (n->u2.udr->combiner->expr1);
2195	e4 = gfc_copy_expr (n->u2.udr->combiner->expr2);
2196	t = gfc_resolve_expr (e3);
2197	gcc_assert (t);
2198	t = gfc_resolve_expr (e4);
2199	gcc_assert (t);
2200	}
2201	break;
2202	default:
2203	gcc_unreachable ();
2204	}
2205	if (iname != NULL)
2206	{
2207	memset (s: &intrinsic_sym, c: 0, n: sizeof (intrinsic_sym));
2208	intrinsic_sym.ns = sym->ns;
2209	intrinsic_sym.name = iname;
2210	intrinsic_sym.ts = sym->ts;
2211	intrinsic_sym.attr.referenced = 1;
2212	intrinsic_sym.attr.intrinsic = 1;
2213	intrinsic_sym.attr.function = 1;
2214	intrinsic_sym.attr.implicit_type = 1;
2215	intrinsic_sym.result = &intrinsic_sym;
2216	intrinsic_sym.declared_at = where;
2217
2218	symtree4 = gfc_new_symtree (&root4, iname);
2219	symtree4->n.sym = &intrinsic_sym;
2220	gcc_assert (symtree4 == root4);
2221
2222	e4 = gfc_get_expr ();
2223	e4->expr_type = EXPR_FUNCTION;
2224	e4->where = where;
2225	e4->symtree = symtree4;
2226	e4->value.function.actual = gfc_get_actual_arglist ();
2227	e4->value.function.actual->expr = e3;
2228	e4->value.function.actual->next = gfc_get_actual_arglist ();
2229	e4->value.function.actual->next->expr = e1;
2230	}
2231	if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
2232	{
2233	/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
2234	e1 = gfc_copy_expr (e1);
2235	e3 = gfc_copy_expr (e3);
2236	t = gfc_resolve_expr (e4);
2237	gcc_assert (t);
2238	}
2239
2240	/* Create the init statement list. */
2241	pushlevel ();
2242	if (e2)
2243	stmt = gfc_trans_assignment (e1, e2, false, false);
2244	else
2245	stmt = gfc_trans_call (n->u2.udr->initializer, false,
2246	NULL_TREE, NULL_TREE, false);
2247	if (TREE_CODE (stmt) != BIND_EXPR)
2248	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
2249	else
2250	poplevel (0, 0);
2251	OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
2252
2253	/* Create the merge statement list. */
2254	pushlevel ();
2255	if (e4)
2256	stmt = gfc_trans_assignment (e3, e4, false, true);
2257	else
2258	stmt = gfc_trans_call (n->u2.udr->combiner, false,
2259	NULL_TREE, NULL_TREE, false);
2260	if (TREE_CODE (stmt) != BIND_EXPR)
2261	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
2262	else
2263	poplevel (0, 0);
2264	OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
2265
2266	/* And stick the placeholder VAR_DECL into the clause as well. */
2267	OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
2268
2269	gfc_current_locus = old_loc;
2270
2271	gfc_free_expr (e1);
2272	if (e2)
2273	gfc_free_expr (e2);
2274	gfc_free_expr (e3);
2275	if (e4)
2276	gfc_free_expr (e4);
2277	free (ptr: symtree1);
2278	free (ptr: symtree2);
2279	free (ptr: symtree3);
2280	free (ptr: symtree4);
2281	if (outer_sym.as)
2282	gfc_free_array_spec (outer_sym.as);
2283
2284	if (udr)
2285	{
2286	*udr->omp_out = omp_var_copy[0];
2287	*udr->omp_in = omp_var_copy[1];
2288	if (udr->initializer_ns)
2289	{
2290	*udr->omp_priv = omp_var_copy[2];
2291	*udr->omp_orig = omp_var_copy[3];
2292	}
2293	}
2294	}
2295
2296	static tree
2297	gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list,
2298	locus where, bool mark_addressable)
2299	{
2300	omp_clause_code clause = OMP_CLAUSE_REDUCTION;
2301	switch (kind)
2302	{
2303	case OMP_LIST_REDUCTION:
2304	case OMP_LIST_REDUCTION_INSCAN:
2305	case OMP_LIST_REDUCTION_TASK:
2306	break;
2307	case OMP_LIST_IN_REDUCTION:
2308	clause = OMP_CLAUSE_IN_REDUCTION;
2309	break;
2310	case OMP_LIST_TASK_REDUCTION:
2311	clause = OMP_CLAUSE_TASK_REDUCTION;
2312	break;
2313	default:
2314	gcc_unreachable ();
2315	}
2316	for (; namelist != NULL; namelist = namelist->next)
2317	if (namelist->sym->attr.referenced)
2318	{
2319	tree t = gfc_trans_omp_variable (sym: namelist->sym, declare_simd: false);
2320	if (t != error_mark_node)
2321	{
2322	tree node = build_omp_clause (gfc_get_location (&namelist->where),
2323	clause);
2324	OMP_CLAUSE_DECL (node) = t;
2325	if (mark_addressable)
2326	TREE_ADDRESSABLE (t) = 1;
2327	if (kind == OMP_LIST_REDUCTION_INSCAN)
2328	OMP_CLAUSE_REDUCTION_INSCAN (node) = 1;
2329	if (kind == OMP_LIST_REDUCTION_TASK)
2330	OMP_CLAUSE_REDUCTION_TASK (node) = 1;
2331	switch (namelist->u.reduction_op)
2332	{
2333	case OMP_REDUCTION_PLUS:
2334	OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
2335	break;
2336	case OMP_REDUCTION_MINUS:
2337	OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
2338	break;
2339	case OMP_REDUCTION_TIMES:
2340	OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
2341	break;
2342	case OMP_REDUCTION_AND:
2343	OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
2344	break;
2345	case OMP_REDUCTION_OR:
2346	OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
2347	break;
2348	case OMP_REDUCTION_EQV:
2349	OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
2350	break;
2351	case OMP_REDUCTION_NEQV:
2352	OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
2353	break;
2354	case OMP_REDUCTION_MAX:
2355	OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
2356	break;
2357	case OMP_REDUCTION_MIN:
2358	OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
2359	break;
2360	case OMP_REDUCTION_IAND:
2361	OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
2362	break;
2363	case OMP_REDUCTION_IOR:
2364	OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
2365	break;
2366	case OMP_REDUCTION_IEOR:
2367	OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
2368	break;
2369	case OMP_REDUCTION_USER:
2370	OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
2371	break;
2372	default:
2373	gcc_unreachable ();
2374	}
2375	if (namelist->sym->attr.dimension
2376	|| namelist->u.reduction_op == OMP_REDUCTION_USER
2377	|| namelist->sym->attr.allocatable)
2378	gfc_trans_omp_array_reduction_or_udr (c: node, n: namelist, where);
2379	list = gfc_trans_add_clause (node, tail: list);
2380	}
2381	}
2382	return list;
2383	}
2384
2385	static inline tree
2386	gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
2387	{
2388	gfc_se se;
2389	tree result;
2390
2391	gfc_init_se (&se, NULL );
2392	gfc_conv_expr (se: &se, expr);
2393	gfc_add_block_to_block (block, &se.pre);
2394	result = gfc_evaluate_now (se.expr, block);
2395	gfc_add_block_to_block (block, &se.post);
2396
2397	return result;
2398	}
2399
2400	static vec<tree, va_heap, vl_embed> *doacross_steps;
2401
2402
2403	/* Translate an array section or array element. */
2404
2405	static void
2406	gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
2407	gfc_omp_namelist *n, tree decl, bool element,
2408	gomp_map_kind ptr_kind, tree &node, tree &node2,
2409	tree &node3, tree &node4)
2410	{
2411	gfc_se se;
2412	tree ptr, ptr2;
2413	tree elemsz = NULL_TREE;
2414
2415	gfc_init_se (&se, NULL);
2416	if (element)
2417	{
2418	gfc_conv_expr_reference (se: &se, expr: n->expr);
2419	gfc_add_block_to_block (block, &se.pre);
2420	ptr = se.expr;
2421	}
2422	else
2423	{
2424	gfc_conv_expr_descriptor (&se, n->expr);
2425	ptr = gfc_conv_array_data (se.expr);
2426	}
2427	if (n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred)
2428	{
2429	gcc_assert (se.string_length);
2430	tree len = gfc_evaluate_now (se.string_length, block);
2431	elemsz = gfc_get_char_type (n->expr->ts.kind);
2432	elemsz = TYPE_SIZE_UNIT (elemsz);
2433	elemsz = fold_build2 (MULT_EXPR, size_type_node,
2434	fold_convert (size_type_node, len), elemsz);
2435	}
2436	if (element)
2437	{
2438	if (!elemsz)
2439	elemsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
2440	OMP_CLAUSE_SIZE (node) = elemsz;
2441	}
2442	else
2443	{
2444	tree type = TREE_TYPE (se.expr);
2445	gfc_add_block_to_block (block, &se.pre);
2446	OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr,
2447	GFC_TYPE_ARRAY_RANK (type));
2448	if (!elemsz)
2449	elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2450	elemsz = fold_convert (gfc_array_index_type, elemsz);
2451	OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
2452	OMP_CLAUSE_SIZE (node), elemsz);
2453	}
2454	gcc_assert (se.post.head == NULL_TREE);
2455	gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
2456	OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
2457	ptr = fold_convert (ptrdiff_type_node, ptr);
2458
2459	if (POINTER_TYPE_P (TREE_TYPE (decl))
2460	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
2461	&& ptr_kind == GOMP_MAP_POINTER
2462	&& op != EXEC_OMP_TARGET_EXIT_DATA
2463	&& OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_RELEASE
2464	&& OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_DELETE)
2465
2466	{
2467	node4 = build_omp_clause (input_location,
2468	OMP_CLAUSE_MAP);
2469	OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
2470	OMP_CLAUSE_DECL (node4) = decl;
2471	OMP_CLAUSE_SIZE (node4) = size_int (0);
2472	decl = build_fold_indirect_ref (decl);
2473	}
2474	else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER
2475	&& n->expr->ts.type == BT_CHARACTER
2476	&& n->expr->ts.deferred)
2477	{
2478	gomp_map_kind map_kind;
2479	if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE)
2480	map_kind = OMP_CLAUSE_MAP_KIND (node);
2481	else if (op == EXEC_OMP_TARGET_EXIT_DATA
2482	|| OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE)
2483	map_kind = GOMP_MAP_RELEASE;
2484	else
2485	map_kind = GOMP_MAP_TO;
2486	gcc_assert (se.string_length);
2487	node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2488	OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
2489	OMP_CLAUSE_DECL (node4) = se.string_length;
2490	OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node);
2491	}
2492	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2493	{
2494	tree desc_node;
2495	tree type = TREE_TYPE (decl);
2496	ptr2 = gfc_conv_descriptor_data_get (decl);
2497	desc_node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2498	OMP_CLAUSE_DECL (desc_node) = decl;
2499	OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type);
2500	if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE)
2501	{
2502	OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_DELETE);
2503	node2 = desc_node;
2504	}
2505	else if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE
2506	|| op == EXEC_OMP_TARGET_EXIT_DATA)
2507	{
2508	OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_RELEASE);
2509	node2 = desc_node;
2510	}
2511	else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER)
2512	{
2513	OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO);
2514	node2 = node;
2515	node = desc_node; /* Needs to come first. */
2516	}
2517	else
2518	{
2519	OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO_PSET);
2520	node2 = desc_node;
2521	}
2522	if (op == EXEC_OMP_TARGET_EXIT_DATA)
2523	return;
2524	node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
2525	OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
2526	OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (decl);
2527	/* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
2528	cast prevents gimplify.cc from recognising it as being part of the
2529	struct - and adding an 'alloc: for the 'desc.data' pointer, which
2530	would break as the 'desc' (the descriptor) is also mapped
2531	(see node4 above). */
2532	if (ptr_kind == GOMP_MAP_ATTACH_DETACH)
2533	STRIP_NOPS (OMP_CLAUSE_DECL (node3));
2534	}
2535	else
2536	{
2537	if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
2538	{
2539	tree offset;
2540	ptr2 = build_fold_addr_expr (decl);
2541	offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr,
2542	fold_convert (ptrdiff_type_node, ptr2));
2543	offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node,
2544	offset, fold_convert (ptrdiff_type_node, elemsz));
2545	offset = build4_loc (loc: input_location, code: ARRAY_REF,
2546	TREE_TYPE (TREE_TYPE (decl)),
2547	arg0: decl, arg1: offset, NULL_TREE, NULL_TREE);
2548	OMP_CLAUSE_DECL (node) = offset;
2549
2550	if (ptr_kind == GOMP_MAP_ALWAYS_POINTER)
2551	return;
2552	}
2553	else
2554	{
2555	gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2556	ptr2 = decl;
2557	}
2558	node3 = build_omp_clause (input_location,
2559	OMP_CLAUSE_MAP);
2560	OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
2561	OMP_CLAUSE_DECL (node3) = decl;
2562	}
2563	ptr2 = fold_convert (ptrdiff_type_node, ptr2);
2564	OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node,
2565	ptr, ptr2);
2566	}
2567
2568	static tree
2569	handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block)
2570	{
2571	tree list = NULL_TREE;
2572	for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
2573	{
2574	gfc_constructor *c;
2575	gfc_se se;
2576
2577	tree last = make_tree_vec (6);
2578	tree iter_var = gfc_get_symbol_decl (sym);
2579	tree type = TREE_TYPE (iter_var);
2580	TREE_VEC_ELT (last, 0) = iter_var;
2581	DECL_CHAIN (iter_var) = BLOCK_VARS (block);
2582	BLOCK_VARS (block) = iter_var;
2583
2584	/* begin */
2585	c = gfc_constructor_first (base: sym->value->value.constructor);
2586	gfc_init_se (&se, NULL);
2587	gfc_conv_expr (se: &se, expr: c->expr);
2588	gfc_add_block_to_block (iter_block, &se.pre);
2589	gfc_add_block_to_block (iter_block, &se.post);
2590	TREE_VEC_ELT (last, 1) = fold_convert (type,
2591	gfc_evaluate_now (se.expr,
2592	iter_block));
2593	/* end */
2594	c = gfc_constructor_next (ctor: c);
2595	gfc_init_se (&se, NULL);
2596	gfc_conv_expr (se: &se, expr: c->expr);
2597	gfc_add_block_to_block (iter_block, &se.pre);
2598	gfc_add_block_to_block (iter_block, &se.post);
2599	TREE_VEC_ELT (last, 2) = fold_convert (type,
2600	gfc_evaluate_now (se.expr,
2601	iter_block));
2602	/* step */
2603	c = gfc_constructor_next (ctor: c);
2604	tree step;
2605	if (c)
2606	{
2607	gfc_init_se (&se, NULL);
2608	gfc_conv_expr (se: &se, expr: c->expr);
2609	gfc_add_block_to_block (iter_block, &se.pre);
2610	gfc_add_block_to_block (iter_block, &se.post);
2611	gfc_conv_expr (se: &se, expr: c->expr);
2612	step = fold_convert (type,
2613	gfc_evaluate_now (se.expr,
2614	iter_block));
2615	}
2616	else
2617	step = build_int_cst (type, 1);
2618	TREE_VEC_ELT (last, 3) = step;
2619	/* orig_step */
2620	TREE_VEC_ELT (last, 4) = save_expr (step);
2621	TREE_CHAIN (last) = list;
2622	list = last;
2623	}
2624	return list;
2625	}
2626
2627	static tree
2628	gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
2629	locus where, bool declare_simd = false,
2630	bool openacc = false, gfc_exec_op op = EXEC_NOP)
2631	{
2632	tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
2633	tree iterator = NULL_TREE;
2634	tree tree_block = NULL_TREE;
2635	stmtblock_t iter_block;
2636	int list, ifc;
2637	enum omp_clause_code clause_code;
2638	gfc_omp_namelist *prev = NULL;
2639	gfc_se se;
2640
2641	if (clauses == NULL)
2642	return NULL_TREE;
2643
2644	for (list = 0; list < OMP_LIST_NUM; list++)
2645	{
2646	gfc_omp_namelist *n = clauses->lists[list];
2647
2648	if (n == NULL)
2649	continue;
2650	switch (list)
2651	{
2652	case OMP_LIST_REDUCTION:
2653	case OMP_LIST_REDUCTION_INSCAN:
2654	case OMP_LIST_REDUCTION_TASK:
2655	case OMP_LIST_IN_REDUCTION:
2656	case OMP_LIST_TASK_REDUCTION:
2657	/* An OpenACC async clause indicates the need to set reduction
2658	arguments addressable, to allow asynchronous copy-out. */
2659	omp_clauses = gfc_trans_omp_reduction_list (kind: list, namelist: n, list: omp_clauses,
2660	where, mark_addressable: clauses->async);
2661	break;
2662	case OMP_LIST_PRIVATE:
2663	clause_code = OMP_CLAUSE_PRIVATE;
2664	goto add_clause;
2665	case OMP_LIST_SHARED:
2666	clause_code = OMP_CLAUSE_SHARED;
2667	goto add_clause;
2668	case OMP_LIST_FIRSTPRIVATE:
2669	clause_code = OMP_CLAUSE_FIRSTPRIVATE;
2670	goto add_clause;
2671	case OMP_LIST_LASTPRIVATE:
2672	clause_code = OMP_CLAUSE_LASTPRIVATE;
2673	goto add_clause;
2674	case OMP_LIST_COPYIN:
2675	clause_code = OMP_CLAUSE_COPYIN;
2676	goto add_clause;
2677	case OMP_LIST_COPYPRIVATE:
2678	clause_code = OMP_CLAUSE_COPYPRIVATE;
2679	goto add_clause;
2680	case OMP_LIST_UNIFORM:
2681	clause_code = OMP_CLAUSE_UNIFORM;
2682	goto add_clause;
2683	case OMP_LIST_USE_DEVICE:
2684	case OMP_LIST_USE_DEVICE_PTR:
2685	clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
2686	goto add_clause;
2687	case OMP_LIST_USE_DEVICE_ADDR:
2688	clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
2689	goto add_clause;
2690	case OMP_LIST_IS_DEVICE_PTR:
2691	clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
2692	goto add_clause;
2693	case OMP_LIST_HAS_DEVICE_ADDR:
2694	clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR;
2695	goto add_clause;
2696	case OMP_LIST_NONTEMPORAL:
2697	clause_code = OMP_CLAUSE_NONTEMPORAL;
2698	goto add_clause;
2699	case OMP_LIST_SCAN_IN:
2700	clause_code = OMP_CLAUSE_INCLUSIVE;
2701	goto add_clause;
2702	case OMP_LIST_SCAN_EX:
2703	clause_code = OMP_CLAUSE_EXCLUSIVE;
2704	goto add_clause;
2705
2706	add_clause:
2707	omp_clauses
2708	= gfc_trans_omp_variable_list (code: clause_code, namelist: n, list: omp_clauses,
2709	declare_simd);
2710	break;
2711	case OMP_LIST_ALIGNED:
2712	for (; n != NULL; n = n->next)
2713	if (n->sym->attr.referenced || declare_simd)
2714	{
2715	tree t = gfc_trans_omp_variable (sym: n->sym, declare_simd);
2716	if (t != error_mark_node)
2717	{
2718	tree node = build_omp_clause (input_location,
2719	OMP_CLAUSE_ALIGNED);
2720	OMP_CLAUSE_DECL (node) = t;
2721	if (n->expr)
2722	{
2723	tree alignment_var;
2724
2725	if (declare_simd)
2726	alignment_var = gfc_conv_constant_to_tree (n->expr);
2727	else
2728	{
2729	gfc_init_se (&se, NULL);
2730	gfc_conv_expr (se: &se, expr: n->expr);
2731	gfc_add_block_to_block (block, &se.pre);
2732	alignment_var = gfc_evaluate_now (se.expr, block);
2733	gfc_add_block_to_block (block, &se.post);
2734	}
2735	OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
2736	}
2737	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
2738	}
2739	}
2740	break;
2741	case OMP_LIST_ALLOCATE:
2742	{
2743	tree allocator_ = NULL_TREE;
2744	gfc_expr *alloc_expr = NULL;
2745	for (; n != NULL; n = n->next)
2746	if (n->sym->attr.referenced)
2747	{
2748	tree t = gfc_trans_omp_variable (sym: n->sym, declare_simd: false);
2749	if (t != error_mark_node)
2750	{
2751	tree node = build_omp_clause (input_location,
2752	OMP_CLAUSE_ALLOCATE);
2753	OMP_CLAUSE_DECL (node) = t;
2754	if (n->u2.allocator)
2755	{
2756	if (alloc_expr != n->u2.allocator)
2757	{
2758	gfc_init_se (&se, NULL);
2759	gfc_conv_expr (se: &se, expr: n->u2.allocator);
2760	gfc_add_block_to_block (block, &se.pre);
2761	allocator_ = gfc_evaluate_now (se.expr, block);
2762	gfc_add_block_to_block (block, &se.post);
2763	}
2764	OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
2765	}
2766	alloc_expr = n->u2.allocator;
2767	if (n->u.align)
2768	{
2769	tree align_;
2770	gfc_init_se (&se, NULL);
2771	gfc_conv_expr (se: &se, expr: n->u.align);
2772	gcc_assert (CONSTANT_CLASS_P (se.expr)
2773	&& se.pre.head == NULL
2774	&& se.post.head == NULL);
2775	align_ = se.expr;
2776	OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
2777	}
2778	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
2779	}
2780	}
2781	else
2782	alloc_expr = n->u2.allocator;
2783	}
2784	break;
2785	case OMP_LIST_LINEAR:
2786	{
2787	gfc_expr *last_step_expr = NULL;
2788	tree last_step = NULL_TREE;
2789	bool last_step_parm = false;
2790
2791	for (; n != NULL; n = n->next)
2792	{
2793	if (n->expr)
2794	{
2795	last_step_expr = n->expr;
2796	last_step = NULL_TREE;
2797	last_step_parm = false;
2798	}
2799	if (n->sym->attr.referenced || declare_simd)
2800	{
2801	tree t = gfc_trans_omp_variable (sym: n->sym, declare_simd);
2802	if (t != error_mark_node)
2803	{
2804	tree node = build_omp_clause (input_location,
2805	OMP_CLAUSE_LINEAR);
2806	OMP_CLAUSE_DECL (node) = t;
2807	omp_clause_linear_kind kind;
2808	switch (n->u.linear.op)
2809	{
2810	case OMP_LINEAR_DEFAULT:
2811	kind = OMP_CLAUSE_LINEAR_DEFAULT;
2812	break;
2813	case OMP_LINEAR_REF:
2814	kind = OMP_CLAUSE_LINEAR_REF;
2815	break;
2816	case OMP_LINEAR_VAL:
2817	kind = OMP_CLAUSE_LINEAR_VAL;
2818	break;
2819	case OMP_LINEAR_UVAL:
2820	kind = OMP_CLAUSE_LINEAR_UVAL;
2821	break;
2822	default:
2823	gcc_unreachable ();
2824	}
2825	OMP_CLAUSE_LINEAR_KIND (node) = kind;
2826	OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node)
2827	= n->u.linear.old_modifier;
2828	if (last_step_expr && last_step == NULL_TREE)
2829	{
2830	if (!declare_simd)
2831	{
2832	gfc_init_se (&se, NULL);
2833	gfc_conv_expr (se: &se, expr: last_step_expr);
2834	gfc_add_block_to_block (block, &se.pre);
2835	last_step = gfc_evaluate_now (se.expr, block);
2836	gfc_add_block_to_block (block, &se.post);
2837	}
2838	else if (last_step_expr->expr_type == EXPR_VARIABLE)
2839	{
2840	gfc_symbol *s = last_step_expr->symtree->n.sym;
2841	last_step = gfc_trans_omp_variable (sym: s, declare_simd: true);
2842	last_step_parm = true;
2843	}
2844	else
2845	last_step
2846	= gfc_conv_constant_to_tree (last_step_expr);
2847	}
2848	if (last_step_parm)
2849	{
2850	OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1;
2851	OMP_CLAUSE_LINEAR_STEP (node) = last_step;
2852	}
2853	else
2854	{
2855	if (kind == OMP_CLAUSE_LINEAR_REF)
2856	{
2857	tree type;
2858	if (n->sym->attr.flavor == FL_PROCEDURE)
2859	{
2860	type = gfc_get_function_type (n->sym);
2861	type = build_pointer_type (type);
2862	}
2863	else
2864	type = gfc_sym_type (n->sym);
2865	if (POINTER_TYPE_P (type))
2866	type = TREE_TYPE (type);
2867	/* Otherwise to be determined what exactly
2868	should be done. */
2869	tree t = fold_convert (sizetype, last_step);
2870	t = size_binop (MULT_EXPR, t,
2871	TYPE_SIZE_UNIT (type));
2872	OMP_CLAUSE_LINEAR_STEP (node) = t;
2873	}
2874	else
2875	{
2876	tree type
2877	= gfc_typenode_for_spec (&n->sym->ts);
2878	OMP_CLAUSE_LINEAR_STEP (node)
2879	= fold_convert (type, last_step);
2880	}
2881	}
2882	if (n->sym->attr.dimension || n->sym->attr.allocatable)
2883	OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
2884	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
2885	}
2886	}
2887	}
2888	}
2889	break;
2890	case OMP_LIST_AFFINITY:
2891	case OMP_LIST_DEPEND:
2892	iterator = NULL_TREE;
2893	prev = NULL;
2894	prev_clauses = omp_clauses;
2895	for (; n != NULL; n = n->next)
2896	{
2897	if (iterator && prev->u2.ns != n->u2.ns)
2898	{
2899	BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
2900	TREE_VEC_ELT (iterator, 5) = tree_block;
2901	for (tree c = omp_clauses; c != prev_clauses;
2902	c = OMP_CLAUSE_CHAIN (c))
2903	OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
2904	OMP_CLAUSE_DECL (c));
2905	prev_clauses = omp_clauses;
2906	iterator = NULL_TREE;
2907	}
2908	if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
2909	{
2910	gfc_init_block (&iter_block);
2911	tree_block = make_node (BLOCK);
2912	TREE_USED (tree_block) = 1;
2913	BLOCK_VARS (tree_block) = NULL_TREE;
2914	iterator = handle_iterator (ns: n->u2.ns, iter_block: block,
2915	block: tree_block);
2916	}
2917	if (!iterator)
2918	gfc_init_block (&iter_block);
2919	prev = n;
2920	if (list == OMP_LIST_DEPEND
2921	&& (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
2922	|| n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST))
2923	{
2924	tree vec = NULL_TREE;
2925	unsigned int i;
2926	bool is_depend
2927	= n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST;
2928	for (i = 0; ; i++)
2929	{
2930	tree addend = integer_zero_node, t;
2931	bool neg = false;
2932	if (n->sym && n->expr)
2933	{
2934	addend = gfc_conv_constant_to_tree (n->expr);
2935	if (TREE_CODE (addend) == INTEGER_CST
2936	&& tree_int_cst_sgn (addend) == -1)
2937	{
2938	neg = true;
2939	addend = const_unop (NEGATE_EXPR,
2940	TREE_TYPE (addend), addend);
2941	}
2942	}
2943
2944	if (n->sym == NULL)
2945	t = null_pointer_node; /* "omp_cur_iteration - 1". */
2946	else
2947	t = gfc_trans_omp_variable (sym: n->sym, declare_simd: false);
2948	if (t != error_mark_node)
2949	{
2950	if (i < vec_safe_length (v: doacross_steps)
2951	&& !integer_zerop (addend)
2952	&& (*doacross_steps)[i])
2953	{
2954	tree step = (*doacross_steps)[i];
2955	addend = fold_convert (TREE_TYPE (step), addend);
2956	addend = build2 (TRUNC_DIV_EXPR,
2957	TREE_TYPE (step), addend, step);
2958	}
2959	vec = tree_cons (addend, t, vec);
2960	if (neg)
2961	OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1;
2962	}
2963	if (n->next == NULL
2964	|| n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
2965	break;
2966	n = n->next;
2967	}
2968	if (vec == NULL_TREE)
2969	continue;
2970
2971	tree node = build_omp_clause (input_location,
2972	OMP_CLAUSE_DOACROSS);
2973	OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK;
2974	OMP_CLAUSE_DOACROSS_DEPEND (node) = is_depend;
2975	OMP_CLAUSE_DECL (node) = nreverse (vec);
2976	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
2977	continue;
2978	}
2979
2980	if (n->sym && !n->sym->attr.referenced)
2981	continue;
2982
2983	tree node = build_omp_clause (input_location,
2984	list == OMP_LIST_DEPEND
2985	? OMP_CLAUSE_DEPEND
2986	: OMP_CLAUSE_AFFINITY);
2987	if (n->sym == NULL) /* omp_all_memory */
2988	OMP_CLAUSE_DECL (node) = null_pointer_node;
2989	else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
2990	{
2991	tree decl = gfc_trans_omp_variable (sym: n->sym, declare_simd: false);
2992	if (gfc_omp_privatize_by_reference (decl))
2993	decl = build_fold_indirect_ref (decl);
2994	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2995	{
2996	decl = gfc_conv_descriptor_data_get (decl);
2997	gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
2998	decl = build_fold_indirect_ref (decl);
2999	}
3000	else if (n->sym->attr.allocatable || n->sym->attr.pointer)
3001	decl = build_fold_indirect_ref (decl);
3002	else if (DECL_P (decl))
3003	TREE_ADDRESSABLE (decl) = 1;
3004	OMP_CLAUSE_DECL (node) = decl;
3005	}
3006	else
3007	{
3008	tree ptr;
3009	gfc_init_se (&se, NULL);
3010	if (n->expr->ref->u.ar.type == AR_ELEMENT)
3011	{
3012	gfc_conv_expr_reference (se: &se, expr: n->expr);
3013	ptr = se.expr;
3014	}
3015	else
3016	{
3017	gfc_conv_expr_descriptor (&se, n->expr);
3018	ptr = gfc_conv_array_data (se.expr);
3019	}
3020	gfc_add_block_to_block (&iter_block, &se.pre);
3021	gfc_add_block_to_block (&iter_block, &se.post);
3022	gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3023	OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
3024	}
3025	if (list == OMP_LIST_DEPEND)
3026	switch (n->u.depend_doacross_op)
3027	{
3028	case OMP_DEPEND_IN:
3029	OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
3030	break;
3031	case OMP_DEPEND_OUT:
3032	OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
3033	break;
3034	case OMP_DEPEND_INOUT:
3035	OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
3036	break;
3037	case OMP_DEPEND_INOUTSET:
3038	OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET;
3039	break;
3040	case OMP_DEPEND_MUTEXINOUTSET:
3041	OMP_CLAUSE_DEPEND_KIND (node)
3042	= OMP_CLAUSE_DEPEND_MUTEXINOUTSET;
3043	break;
3044	case OMP_DEPEND_DEPOBJ:
3045	OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ;
3046	break;
3047	default:
3048	gcc_unreachable ();
3049	}
3050	if (!iterator)
3051	gfc_add_block_to_block (block, &iter_block);
3052	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
3053	}
3054	if (iterator)
3055	{
3056	BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
3057	TREE_VEC_ELT (iterator, 5) = tree_block;
3058	for (tree c = omp_clauses; c != prev_clauses;
3059	c = OMP_CLAUSE_CHAIN (c))
3060	OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
3061	OMP_CLAUSE_DECL (c));
3062	}
3063	break;
3064	case OMP_LIST_MAP:
3065	for (; n != NULL; n = n->next)
3066	{
3067	if (!n->sym->attr.referenced)
3068	continue;
3069
3070	bool always_modifier = false;
3071	tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3072	tree node2 = NULL_TREE;
3073	tree node3 = NULL_TREE;
3074	tree node4 = NULL_TREE;
3075	tree node5 = NULL_TREE;
3076
3077	/* OpenMP: automatically map pointer targets with the pointer;
3078	hence, always update the descriptor/pointer itself. */
3079	if (!openacc
3080	&& ((n->expr == NULL && n->sym->attr.pointer)
3081	|| (n->expr && gfc_expr_attr (n->expr).pointer)))
3082	always_modifier = true;
3083
3084	switch (n->u.map_op)
3085	{
3086	case OMP_MAP_ALLOC:
3087	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
3088	break;
3089	case OMP_MAP_IF_PRESENT:
3090	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT);
3091	break;
3092	case OMP_MAP_ATTACH:
3093	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH);
3094	break;
3095	case OMP_MAP_TO:
3096	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
3097	break;
3098	case OMP_MAP_FROM:
3099	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
3100	break;
3101	case OMP_MAP_TOFROM:
3102	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
3103	break;
3104	case OMP_MAP_ALWAYS_TO:
3105	always_modifier = true;
3106	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
3107	break;
3108	case OMP_MAP_ALWAYS_FROM:
3109	always_modifier = true;
3110	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
3111	break;
3112	case OMP_MAP_ALWAYS_TOFROM:
3113	always_modifier = true;
3114	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
3115	break;
3116	case OMP_MAP_PRESENT_ALLOC:
3117	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC);
3118	break;
3119	case OMP_MAP_PRESENT_TO:
3120	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO);
3121	break;
3122	case OMP_MAP_PRESENT_FROM:
3123	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM);
3124	break;
3125	case OMP_MAP_PRESENT_TOFROM:
3126	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM);
3127	break;
3128	case OMP_MAP_ALWAYS_PRESENT_TO:
3129	always_modifier = true;
3130	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO);
3131	break;
3132	case OMP_MAP_ALWAYS_PRESENT_FROM:
3133	always_modifier = true;
3134	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM);
3135	break;
3136	case OMP_MAP_ALWAYS_PRESENT_TOFROM:
3137	always_modifier = true;
3138	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM);
3139	break;
3140	case OMP_MAP_RELEASE:
3141	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
3142	break;
3143	case OMP_MAP_DELETE:
3144	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
3145	break;
3146	case OMP_MAP_DETACH:
3147	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH);
3148	break;
3149	case OMP_MAP_FORCE_ALLOC:
3150	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
3151	break;
3152	case OMP_MAP_FORCE_TO:
3153	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
3154	break;
3155	case OMP_MAP_FORCE_FROM:
3156	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
3157	break;
3158	case OMP_MAP_FORCE_TOFROM:
3159	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
3160	break;
3161	case OMP_MAP_FORCE_PRESENT:
3162	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
3163	break;
3164	case OMP_MAP_FORCE_DEVICEPTR:
3165	OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
3166	break;
3167	default:
3168	gcc_unreachable ();
3169	}
3170
3171	tree decl = gfc_trans_omp_variable (sym: n->sym, declare_simd: false);
3172	if (DECL_P (decl))
3173	TREE_ADDRESSABLE (decl) = 1;
3174
3175	gfc_ref *lastref = NULL;
3176
3177	if (n->expr)
3178	for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
3179	if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
3180	lastref = ref;
3181
3182	bool allocatable = false, pointer = false;
3183
3184	if (lastref && lastref->type == REF_COMPONENT)
3185	{
3186	gfc_component *c = lastref->u.c.component;
3187
3188	if (c->ts.type == BT_CLASS)
3189	{
3190	pointer = CLASS_DATA (c)->attr.class_pointer;
3191	allocatable = CLASS_DATA (c)->attr.allocatable;
3192	}
3193	else
3194	{
3195	pointer = c->attr.pointer;
3196	allocatable = c->attr.allocatable;
3197	}
3198	}
3199
3200	if (n->expr == NULL
3201	|| (n->expr->ref->type == REF_ARRAY
3202	&& n->expr->ref->u.ar.type == AR_FULL))
3203	{
3204	gomp_map_kind map_kind;
3205	tree type = TREE_TYPE (decl);
3206	if (n->sym->ts.type == BT_CHARACTER
3207	&& n->sym->ts.deferred
3208	&& n->sym->attr.omp_declare_target
3209	&& (always_modifier || n->sym->attr.pointer)
3210	&& op != EXEC_OMP_TARGET_EXIT_DATA
3211	&& n->u.map_op != OMP_MAP_DELETE
3212	&& n->u.map_op != OMP_MAP_RELEASE)
3213	{
3214	gcc_assert (n->sym->ts.u.cl->backend_decl);
3215	node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3216	OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
3217	OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
3218	OMP_CLAUSE_SIZE (node5)
3219	= TYPE_SIZE_UNIT (gfc_charlen_type_node);
3220	}
3221
3222	tree present = gfc_omp_check_optional_argument (decl, for_present_check: true);
3223	if (openacc && n->sym->ts.type == BT_CLASS)
3224	{
3225	if (n->sym->attr.optional)
3226	sorry ("optional class parameter");
3227	tree ptr = gfc_class_data_get (decl);
3228	ptr = build_fold_indirect_ref (ptr);
3229	OMP_CLAUSE_DECL (node) = ptr;
3230	OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
3231	node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3232	OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
3233	OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
3234	OMP_CLAUSE_SIZE (node2) = size_int (0);
3235	goto finalize_map_clause;
3236	}
3237	else if (POINTER_TYPE_P (type)
3238	&& (gfc_omp_privatize_by_reference (decl)
3239	|| GFC_DECL_GET_SCALAR_POINTER (decl)
3240	|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
3241	|| GFC_DECL_CRAY_POINTEE (decl)
3242	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
3243	|| (n->sym->ts.type == BT_DERIVED
3244	&& (n->sym->ts.u.derived->ts.f90_type
3245	!= BT_VOID))))
3246	{
3247	tree orig_decl = decl;
3248
3249	/* For nonallocatable, nonpointer arrays, a temporary
3250	variable is generated, but this one is only defined if
3251	the variable is present; hence, we now set it to NULL
3252	to avoid accessing undefined variables. We cannot use
3253	a temporary variable here as otherwise the replacement
3254	of the variables in omp-low.cc will not work. */
3255	if (present && GFC_ARRAY_TYPE_P (type))
3256	{
3257	tree tmp = fold_build2_loc (input_location,
3258	MODIFY_EXPR,
3259	void_type_node, decl,
3260	null_pointer_node);
3261	tree cond = fold_build1_loc (input_location,
3262	TRUTH_NOT_EXPR,
3263	boolean_type_node,
3264	present);
3265	gfc_add_expr_to_block (block,
3266	build3_loc (loc: input_location,
3267	code: COND_EXPR,
3268	void_type_node,
3269	arg0: cond, arg1: tmp,
3270	NULL_TREE));
3271	}
3272	/* For descriptor types, the unmapping happens below. */
3273	if (op != EXEC_OMP_TARGET_EXIT_DATA
3274	|| !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3275	{
3276	enum gomp_map_kind gmk = GOMP_MAP_POINTER;
3277	if (op == EXEC_OMP_TARGET_EXIT_DATA
3278	&& n->u.map_op == OMP_MAP_DELETE)
3279	gmk = GOMP_MAP_DELETE;
3280	else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3281	gmk = GOMP_MAP_RELEASE;
3282	tree size;
3283	if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
3284	size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
3285	else
3286	size = size_int (0);
3287	node4 = build_omp_clause (input_location,
3288	OMP_CLAUSE_MAP);
3289	OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
3290	OMP_CLAUSE_DECL (node4) = decl;
3291	OMP_CLAUSE_SIZE (node4) = size;
3292	}
3293	decl = build_fold_indirect_ref (decl);
3294	if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
3295	|| gfc_omp_is_optional_argument (decl: orig_decl))
3296	&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
3297	|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
3298	{
3299	enum gomp_map_kind gmk;
3300	if (op == EXEC_OMP_TARGET_EXIT_DATA
3301	&& n->u.map_op == OMP_MAP_DELETE)
3302	gmk = GOMP_MAP_DELETE;
3303	else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3304	gmk = GOMP_MAP_RELEASE;
3305	else
3306	gmk = GOMP_MAP_POINTER;
3307	tree size;
3308	if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
3309	size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
3310	else
3311	size = size_int (0);
3312	node3 = build_omp_clause (input_location,
3313	OMP_CLAUSE_MAP);
3314	OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
3315	OMP_CLAUSE_DECL (node3) = decl;
3316	OMP_CLAUSE_SIZE (node3) = size;
3317	decl = build_fold_indirect_ref (decl);
3318	}
3319	}
3320	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3321	{
3322	tree type = TREE_TYPE (decl);
3323	tree ptr = gfc_conv_descriptor_data_get (decl);
3324	if (present)
3325	ptr = gfc_build_cond_assign_expr (block, cond_val: present, then_val: ptr,
3326	null_pointer_node);
3327	gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3328	ptr = build_fold_indirect_ref (ptr);
3329	OMP_CLAUSE_DECL (node) = ptr;
3330	node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3331	OMP_CLAUSE_DECL (node2) = decl;
3332	OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3333	if (n->u.map_op == OMP_MAP_DELETE)
3334	map_kind = GOMP_MAP_DELETE;
3335	else if (op == EXEC_OMP_TARGET_EXIT_DATA
3336	|| n->u.map_op == OMP_MAP_RELEASE)
3337	map_kind = GOMP_MAP_RELEASE;
3338	else
3339	map_kind = GOMP_MAP_TO_PSET;
3340	OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
3341
3342	if (op != EXEC_OMP_TARGET_EXIT_DATA
3343	&& n->u.map_op != OMP_MAP_DELETE
3344	&& n->u.map_op != OMP_MAP_RELEASE)
3345	{
3346	node3 = build_omp_clause (input_location,
3347	OMP_CLAUSE_MAP);
3348	if (present)
3349	{
3350	ptr = gfc_conv_descriptor_data_get (decl);
3351	ptr = gfc_build_addr_expr (NULL, ptr);
3352	ptr = gfc_build_cond_assign_expr (
3353	block, cond_val: present, then_val: ptr, null_pointer_node);
3354	ptr = build_fold_indirect_ref (ptr);
3355	OMP_CLAUSE_DECL (node3) = ptr;
3356	}
3357	else
3358	OMP_CLAUSE_DECL (node3)
3359	= gfc_conv_descriptor_data_get (decl);
3360	OMP_CLAUSE_SIZE (node3) = size_int (0);
3361
3362	if (n->u.map_op == OMP_MAP_ATTACH)
3363	{
3364	/* Standalone attach clauses used with arrays with
3365	descriptors must copy the descriptor to the
3366	target, else they won't have anything to
3367	perform the attachment onto (see OpenACC 2.6,
3368	"2.6.3. Data Structures with Pointers"). */
3369	OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH);
3370	/* We don't want to map PTR at all in this case,
3371	so delete its node and shuffle the others
3372	down. */
3373	node = node2;
3374	node2 = node3;
3375	node3 = NULL;
3376	goto finalize_map_clause;
3377	}
3378	else if (n->u.map_op == OMP_MAP_DETACH)
3379	{
3380	OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH);
3381	/* Similarly to above, we don't want to unmap PTR
3382	here. */
3383	node = node2;
3384	node2 = node3;
3385	node3 = NULL;
3386	goto finalize_map_clause;
3387	}
3388	else
3389	OMP_CLAUSE_SET_MAP_KIND (node3,
3390	always_modifier
3391	? GOMP_MAP_ALWAYS_POINTER
3392	: GOMP_MAP_POINTER);
3393	}
3394
3395	/* We have to check for n->sym->attr.dimension because
3396	of scalar coarrays. */
3397	if ((n->sym->attr.pointer || n->sym->attr.allocatable)
3398	&& n->sym->attr.dimension)
3399	{
3400	stmtblock_t cond_block;
3401	tree size
3402	= gfc_create_var (gfc_array_index_type, NULL);
3403	tree tem, then_b, else_b, zero, cond;
3404
3405	gfc_init_block (&cond_block);
3406	tem
3407	= gfc_full_array_size (&cond_block, decl,
3408	GFC_TYPE_ARRAY_RANK (type));
3409	tree elemsz;
3410	if (n->sym->ts.type == BT_CHARACTER
3411	&& n->sym->ts.deferred)
3412	{
3413	tree len = n->sym->ts.u.cl->backend_decl;
3414	len = fold_convert (size_type_node, len);
3415	elemsz = gfc_get_char_type (n->sym->ts.kind);
3416	elemsz = TYPE_SIZE_UNIT (elemsz);
3417	elemsz = fold_build2 (MULT_EXPR, size_type_node,
3418	len, elemsz);
3419	}
3420	else
3421	elemsz
3422	= TYPE_SIZE_UNIT (gfc_get_element_type (type));
3423	elemsz = fold_convert (gfc_array_index_type, elemsz);
3424	tem = fold_build2 (MULT_EXPR, gfc_array_index_type,
3425	tem, elemsz);
3426	gfc_add_modify (&cond_block, size, tem);
3427	then_b = gfc_finish_block (&cond_block);
3428	gfc_init_block (&cond_block);
3429	zero = build_int_cst (gfc_array_index_type, 0);
3430	gfc_add_modify (&cond_block, size, zero);
3431	else_b = gfc_finish_block (&cond_block);
3432	tem = gfc_conv_descriptor_data_get (decl);
3433	tem = fold_convert (pvoid_type_node, tem);
3434	cond = fold_build2_loc (input_location, NE_EXPR,
3435	boolean_type_node,
3436	tem, null_pointer_node);
3437	if (present)
3438	cond = fold_build2_loc (input_location,
3439	TRUTH_ANDIF_EXPR,
3440	boolean_type_node,
3441	present, cond);
3442	gfc_add_expr_to_block (block,
3443	build3_loc (loc: input_location,
3444	code: COND_EXPR,
3445	void_type_node,
3446	arg0: cond, arg1: then_b,
3447	arg2: else_b));
3448	OMP_CLAUSE_SIZE (node) = size;
3449	}
3450	else if (n->sym->attr.dimension)
3451	{
3452	stmtblock_t cond_block;
3453	gfc_init_block (&cond_block);
3454	tree size = gfc_full_array_size (&cond_block, decl,
3455	GFC_TYPE_ARRAY_RANK (type));
3456	tree elemsz
3457	= TYPE_SIZE_UNIT (gfc_get_element_type (type));
3458	elemsz = fold_convert (gfc_array_index_type, elemsz);
3459	size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3460	size, elemsz);
3461	size = gfc_evaluate_now (size, &cond_block);
3462	if (present)
3463	{
3464	tree var = gfc_create_var (gfc_array_index_type,
3465	NULL);
3466	gfc_add_modify (&cond_block, var, size);
3467	tree cond_body = gfc_finish_block (&cond_block);
3468	tree cond = build3_loc (loc: input_location, code: COND_EXPR,
3469	void_type_node, arg0: present,
3470	arg1: cond_body, NULL_TREE);
3471	gfc_add_expr_to_block (block, cond);
3472	OMP_CLAUSE_SIZE (node) = var;
3473	}
3474	else
3475	{
3476	gfc_add_block_to_block (block, &cond_block);
3477	OMP_CLAUSE_SIZE (node) = size;
3478	}
3479	}
3480	}
3481	else if (present
3482	&& INDIRECT_REF_P (decl)
3483	&& INDIRECT_REF_P (TREE_OPERAND (decl, 0)))
3484	{
3485	/* A single indirectref is handled by the middle end. */
3486	gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
3487	decl = TREE_OPERAND (decl, 0);
3488	decl = gfc_build_cond_assign_expr (block, cond_val: present, then_val: decl,
3489	null_pointer_node);
3490	OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl);
3491	}
3492	else
3493	OMP_CLAUSE_DECL (node) = decl;
3494
3495	if (!n->sym->attr.dimension
3496	&& n->sym->ts.type == BT_CHARACTER
3497	&& n->sym->ts.deferred)
3498	{
3499	if (!DECL_P (decl))
3500	{
3501	gcc_assert (TREE_CODE (decl) == INDIRECT_REF);
3502	decl = TREE_OPERAND (decl, 0);
3503	}
3504	tree cond = fold_build2_loc (input_location, NE_EXPR,
3505	boolean_type_node,
3506	decl, null_pointer_node);
3507	if (present)
3508	cond = fold_build2_loc (input_location,
3509	TRUTH_ANDIF_EXPR,
3510	boolean_type_node,
3511	present, cond);
3512	tree len = n->sym->ts.u.cl->backend_decl;
3513	len = fold_convert (size_type_node, len);
3514	tree size = gfc_get_char_type (n->sym->ts.kind);
3515	size = TYPE_SIZE_UNIT (size);
3516	size = fold_build2 (MULT_EXPR, size_type_node, len, size);
3517	size = build3_loc (loc: input_location,
3518	code: COND_EXPR,
3519	size_type_node,
3520	arg0: cond, arg1: size,
3521	size_zero_node);
3522	size = gfc_evaluate_now (size, block);
3523	OMP_CLAUSE_SIZE (node) = size;
3524	}
3525	}
3526	else if (n->expr
3527	&& n->expr->expr_type == EXPR_VARIABLE
3528	&& n->expr->ref->type == REF_ARRAY
3529	&& !n->expr->ref->next)
3530	{
3531	/* An array element or array section which is not part of a
3532	derived type, etc. */
3533	bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
3534	tree type = TREE_TYPE (decl);
3535	gomp_map_kind k = GOMP_MAP_POINTER;
3536	if (!openacc
3537	&& !GFC_DESCRIPTOR_TYPE_P (type)
3538	&& !(POINTER_TYPE_P (type)
3539	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))))
3540	k = GOMP_MAP_FIRSTPRIVATE_POINTER;
3541	gfc_trans_omp_array_section (block, op, n, decl, element, ptr_kind: k,
3542	node, node2, node3, node4);
3543	}
3544	else if (n->expr
3545	&& n->expr->expr_type == EXPR_VARIABLE
3546	&& (n->expr->ref->type == REF_COMPONENT
3547	|| n->expr->ref->type == REF_ARRAY)
3548	&& lastref
3549	&& lastref->type == REF_COMPONENT
3550	&& lastref->u.c.component->ts.type != BT_CLASS
3551	&& lastref->u.c.component->ts.type != BT_DERIVED
3552	&& !lastref->u.c.component->attr.dimension)
3553	{
3554	/* Derived type access with last component being a scalar. */
3555	gfc_init_se (&se, NULL);
3556
3557	gfc_conv_expr (se: &se, expr: n->expr);
3558	gfc_add_block_to_block (block, &se.pre);
3559	/* For BT_CHARACTER a pointer is returned. */
3560	OMP_CLAUSE_DECL (node)
3561	= POINTER_TYPE_P (TREE_TYPE (se.expr))
3562	? build_fold_indirect_ref (se.expr) : se.expr;
3563	gfc_add_block_to_block (block, &se.post);
3564	if (pointer || allocatable)
3565	{
3566	/* If it's a bare attach/detach clause, we just want
3567	to perform a single attach/detach operation, of the
3568	pointer itself, not of the pointed-to object. */
3569	if (openacc
3570	&& (n->u.map_op == OMP_MAP_ATTACH
3571	|| n->u.map_op == OMP_MAP_DETACH))
3572	{
3573	OMP_CLAUSE_DECL (node)
3574	= build_fold_addr_expr (OMP_CLAUSE_DECL (node));
3575	OMP_CLAUSE_SIZE (node) = size_zero_node;
3576	goto finalize_map_clause;
3577	}
3578
3579	node2 = build_omp_clause (input_location,
3580	OMP_CLAUSE_MAP);
3581	gomp_map_kind kind
3582	= (openacc ? GOMP_MAP_ATTACH_DETACH
3583	: GOMP_MAP_ALWAYS_POINTER);
3584	OMP_CLAUSE_SET_MAP_KIND (node2, kind);
3585	OMP_CLAUSE_DECL (node2)
3586	= POINTER_TYPE_P (TREE_TYPE (se.expr))
3587	? se.expr
3588	: gfc_build_addr_expr (NULL, se.expr);
3589	OMP_CLAUSE_SIZE (node2) = size_int (0);
3590	if (!openacc
3591	&& n->expr->ts.type == BT_CHARACTER
3592	&& n->expr->ts.deferred)
3593	{
3594	gcc_assert (se.string_length);
3595	tree tmp
3596	= gfc_get_char_type (n->expr->ts.kind);
3597	OMP_CLAUSE_SIZE (node)
3598	= fold_build2 (MULT_EXPR, size_type_node,
3599	fold_convert (size_type_node,
3600	se.string_length),
3601	TYPE_SIZE_UNIT (tmp));
3602	if (n->u.map_op == OMP_MAP_DELETE)
3603	kind = GOMP_MAP_DELETE;
3604	else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3605	kind = GOMP_MAP_RELEASE;
3606	else
3607	kind = GOMP_MAP_TO;
3608	node3 = build_omp_clause (input_location,
3609	OMP_CLAUSE_MAP);
3610	OMP_CLAUSE_SET_MAP_KIND (node3, kind);
3611	OMP_CLAUSE_DECL (node3) = se.string_length;
3612	OMP_CLAUSE_SIZE (node3)
3613	= TYPE_SIZE_UNIT (gfc_charlen_type_node);
3614	}
3615	}
3616	}
3617	else if (n->expr
3618	&& n->expr->expr_type == EXPR_VARIABLE
3619	&& (n->expr->ref->type == REF_COMPONENT
3620	|| n->expr->ref->type == REF_ARRAY))
3621	{
3622	gfc_init_se (&se, NULL);
3623	se.expr = gfc_maybe_dereference_var (n->sym, decl);
3624
3625	for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
3626	{
3627	if (ref->type == REF_COMPONENT)
3628	{
3629	if (ref->u.c.sym->attr.extension)
3630	conv_parent_component_references (se: &se, ref);
3631
3632	gfc_conv_component_ref (se: &se, ref);
3633	}
3634	else if (ref->type == REF_ARRAY)
3635	{
3636	if (ref->u.ar.type == AR_ELEMENT && ref->next)
3637	gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
3638	&n->expr->where);
3639	else
3640	gcc_assert (!ref->next);
3641	}
3642	else
3643	sorry ("unhandled expression type");
3644	}
3645
3646	tree inner = se.expr;
3647
3648	/* Last component is a derived type or class pointer. */
3649	if (lastref->type == REF_COMPONENT
3650	&& (lastref->u.c.component->ts.type == BT_DERIVED
3651	|| lastref->u.c.component->ts.type == BT_CLASS))
3652	{
3653	if (pointer || (openacc && allocatable))
3654	{
3655	/* If it's a bare attach/detach clause, we just want
3656	to perform a single attach/detach operation, of the
3657	pointer itself, not of the pointed-to object. */
3658	if (openacc
3659	&& (n->u.map_op == OMP_MAP_ATTACH
3660	|| n->u.map_op == OMP_MAP_DETACH))
3661	{
3662	OMP_CLAUSE_DECL (node)
3663	= build_fold_addr_expr (inner);
3664	OMP_CLAUSE_SIZE (node) = size_zero_node;
3665	goto finalize_map_clause;
3666	}
3667
3668	tree data, size;
3669
3670	if (lastref->u.c.component->ts.type == BT_CLASS)
3671	{
3672	data = gfc_class_data_get (inner);
3673	gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
3674	data = build_fold_indirect_ref (data);
3675	size = gfc_class_vtab_size_get (inner);
3676	}
3677	else /* BT_DERIVED. */
3678	{
3679	data = inner;
3680	size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
3681	}
3682
3683	OMP_CLAUSE_DECL (node) = data;
3684	OMP_CLAUSE_SIZE (node) = size;
3685	node2 = build_omp_clause (input_location,
3686	OMP_CLAUSE_MAP);
3687	OMP_CLAUSE_SET_MAP_KIND (node2,
3688	openacc
3689	? GOMP_MAP_ATTACH_DETACH
3690	: GOMP_MAP_ALWAYS_POINTER);
3691	OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
3692	OMP_CLAUSE_SIZE (node2) = size_int (0);
3693	}
3694	else
3695	{
3696	OMP_CLAUSE_DECL (node) = inner;
3697	OMP_CLAUSE_SIZE (node)
3698	= TYPE_SIZE_UNIT (TREE_TYPE (inner));
3699	}
3700	}
3701	else if (lastref->type == REF_ARRAY
3702	&& lastref->u.ar.type == AR_FULL)
3703	{
3704	/* Bare attach and detach clauses don't want any
3705	additional nodes. */
3706	if ((n->u.map_op == OMP_MAP_ATTACH
3707	|| n->u.map_op == OMP_MAP_DETACH)
3708	&& (POINTER_TYPE_P (TREE_TYPE (inner))
3709	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))))
3710	{
3711	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
3712	{
3713	tree ptr = gfc_conv_descriptor_data_get (inner);
3714	OMP_CLAUSE_DECL (node) = ptr;
3715	}
3716	else
3717	OMP_CLAUSE_DECL (node) = inner;
3718	OMP_CLAUSE_SIZE (node) = size_zero_node;
3719	goto finalize_map_clause;
3720	}
3721
3722	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
3723	{
3724	gomp_map_kind map_kind;
3725	tree desc_node;
3726	tree type = TREE_TYPE (inner);
3727	tree ptr = gfc_conv_descriptor_data_get (inner);
3728	ptr = build_fold_indirect_ref (ptr);
3729	OMP_CLAUSE_DECL (node) = ptr;
3730	int rank = GFC_TYPE_ARRAY_RANK (type);
3731	OMP_CLAUSE_SIZE (node)
3732	= gfc_full_array_size (block, inner, rank);
3733	tree elemsz
3734	= TYPE_SIZE_UNIT (gfc_get_element_type (type));
3735	map_kind = OMP_CLAUSE_MAP_KIND (node);
3736	if (GOMP_MAP_COPY_TO_P (map_kind)
3737	|| map_kind == GOMP_MAP_ALLOC)
3738	map_kind = ((GOMP_MAP_ALWAYS_P (map_kind)
3739	|| gfc_expr_attr (n->expr).pointer)
3740	? GOMP_MAP_ALWAYS_TO : GOMP_MAP_TO);
3741	else if (n->u.map_op == OMP_MAP_RELEASE
3742	|| n->u.map_op == OMP_MAP_DELETE)
3743	;
3744	else if (op == EXEC_OMP_TARGET_EXIT_DATA)
3745	map_kind = GOMP_MAP_RELEASE;
3746	else
3747	map_kind = GOMP_MAP_ALLOC;
3748	if (!openacc
3749	&& n->expr->ts.type == BT_CHARACTER
3750	&& n->expr->ts.deferred)
3751	{
3752	gcc_assert (se.string_length);
3753	tree len = fold_convert (size_type_node,
3754	se.string_length);
3755	elemsz = gfc_get_char_type (n->expr->ts.kind);
3756	elemsz = TYPE_SIZE_UNIT (elemsz);
3757	elemsz = fold_build2 (MULT_EXPR, size_type_node,
3758	len, elemsz);
3759	node4 = build_omp_clause (input_location,
3760	OMP_CLAUSE_MAP);
3761	OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
3762	OMP_CLAUSE_DECL (node4) = se.string_length;
3763	OMP_CLAUSE_SIZE (node4)
3764	= TYPE_SIZE_UNIT (gfc_charlen_type_node);
3765	}
3766	elemsz = fold_convert (gfc_array_index_type, elemsz);
3767	OMP_CLAUSE_SIZE (node)
3768	= fold_build2 (MULT_EXPR, gfc_array_index_type,
3769	OMP_CLAUSE_SIZE (node), elemsz);
3770	desc_node = build_omp_clause (input_location,
3771	OMP_CLAUSE_MAP);
3772	if (openacc)
3773	OMP_CLAUSE_SET_MAP_KIND (desc_node,
3774	GOMP_MAP_TO_PSET);
3775	else
3776	OMP_CLAUSE_SET_MAP_KIND (desc_node, map_kind);
3777	OMP_CLAUSE_DECL (desc_node) = inner;
3778	OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type);
3779	if (openacc)
3780	node2 = desc_node;
3781	else
3782	{
3783	node2 = node;
3784	node = desc_node; /* Put first. */
3785	}
3786	if (op == EXEC_OMP_TARGET_EXIT_DATA)
3787	goto finalize_map_clause;
3788	node3 = build_omp_clause (input_location,
3789	OMP_CLAUSE_MAP);
3790	OMP_CLAUSE_SET_MAP_KIND (node3,
3791	openacc
3792	? GOMP_MAP_ATTACH_DETACH
3793	: GOMP_MAP_ALWAYS_POINTER);
3794	OMP_CLAUSE_DECL (node3)
3795	= gfc_conv_descriptor_data_get (inner);
3796	/* Similar to gfc_trans_omp_array_section (details
3797	there), we add/keep the cast for OpenMP to prevent
3798	that an 'alloc:' gets added for node3 ('desc.data')
3799	as that is part of the whole descriptor (node3).
3800	TODO: Remove once the ME handles this properly. */
3801	if (!openacc)
3802	OMP_CLAUSE_DECL (node3)
3803	= fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)),
3804	OMP_CLAUSE_DECL (node3));
3805	else
3806	STRIP_NOPS (OMP_CLAUSE_DECL (node3));
3807	OMP_CLAUSE_SIZE (node3) = size_int (0);
3808	}
3809	else
3810	OMP_CLAUSE_DECL (node) = inner;
3811	}
3812	else if (lastref->type == REF_ARRAY)
3813	{
3814	/* An array element or section. */
3815	bool element = lastref->u.ar.type == AR_ELEMENT;
3816	gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH
3817	: GOMP_MAP_ALWAYS_POINTER);
3818	gfc_trans_omp_array_section (block, op, n, decl: inner, element,
3819	ptr_kind: kind, node, node2, node3,
3820	node4);
3821	}
3822	else
3823	gcc_unreachable ();
3824	}
3825	else
3826	sorry ("unhandled expression");
3827
3828	finalize_map_clause:
3829
3830	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
3831	if (node2)
3832	omp_clauses = gfc_trans_add_clause (node: node2, tail: omp_clauses);
3833	if (node3)
3834	omp_clauses = gfc_trans_add_clause (node: node3, tail: omp_clauses);
3835	if (node4)
3836	omp_clauses = gfc_trans_add_clause (node: node4, tail: omp_clauses);
3837	if (node5)
3838	omp_clauses = gfc_trans_add_clause (node: node5, tail: omp_clauses);
3839	}
3840	break;
3841	case OMP_LIST_TO:
3842	case OMP_LIST_FROM:
3843	case OMP_LIST_CACHE:
3844	for (; n != NULL; n = n->next)
3845	{
3846	if (!n->sym->attr.referenced)
3847	continue;
3848
3849	switch (list)
3850	{
3851	case OMP_LIST_TO:
3852	clause_code = OMP_CLAUSE_TO;
3853	break;
3854	case OMP_LIST_FROM:
3855	clause_code = OMP_CLAUSE_FROM;
3856	break;
3857	case OMP_LIST_CACHE:
3858	clause_code = OMP_CLAUSE__CACHE_;
3859	break;
3860	default:
3861	gcc_unreachable ();
3862	}
3863	tree node = build_omp_clause (input_location, clause_code);
3864	if (n->expr == NULL
3865	|| (n->expr->ref->type == REF_ARRAY
3866	&& n->expr->ref->u.ar.type == AR_FULL
3867	&& n->expr->ref->next == NULL))
3868	{
3869	tree decl = gfc_trans_omp_variable (sym: n->sym, declare_simd: false);
3870	if (gfc_omp_privatize_by_reference (decl))
3871	{
3872	if (gfc_omp_is_allocatable_or_ptr (decl))
3873	decl = build_fold_indirect_ref (decl);
3874	decl = build_fold_indirect_ref (decl);
3875	}
3876	else if (DECL_P (decl))
3877	TREE_ADDRESSABLE (decl) = 1;
3878	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3879	{
3880	tree type = TREE_TYPE (decl);
3881	tree ptr = gfc_conv_descriptor_data_get (decl);
3882	gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3883	ptr = build_fold_indirect_ref (ptr);
3884	OMP_CLAUSE_DECL (node) = ptr;
3885	OMP_CLAUSE_SIZE (node)
3886	= gfc_full_array_size (block, decl,
3887	GFC_TYPE_ARRAY_RANK (type));
3888	tree elemsz
3889	= TYPE_SIZE_UNIT (gfc_get_element_type (type));
3890	elemsz = fold_convert (gfc_array_index_type, elemsz);
3891	OMP_CLAUSE_SIZE (node)
3892	= fold_build2 (MULT_EXPR, gfc_array_index_type,
3893	OMP_CLAUSE_SIZE (node), elemsz);
3894	}
3895	else
3896	{
3897	OMP_CLAUSE_DECL (node) = decl;
3898	if (gfc_omp_is_allocatable_or_ptr (decl))
3899	OMP_CLAUSE_SIZE (node)
3900	= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl)));
3901	}
3902	}
3903	else
3904	{
3905	tree ptr;
3906	gfc_init_se (&se, NULL);
3907	if (n->expr->rank == 0)
3908	{
3909	gfc_conv_expr_reference (se: &se, expr: n->expr);
3910	ptr = se.expr;
3911	gfc_add_block_to_block (block, &se.pre);
3912	OMP_CLAUSE_SIZE (node)
3913	= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
3914	}
3915	else
3916	{
3917	gfc_conv_expr_descriptor (&se, n->expr);
3918	ptr = gfc_conv_array_data (se.expr);
3919	tree type = TREE_TYPE (se.expr);
3920	gfc_add_block_to_block (block, &se.pre);
3921	OMP_CLAUSE_SIZE (node)
3922	= gfc_full_array_size (block, se.expr,
3923	GFC_TYPE_ARRAY_RANK (type));
3924	tree elemsz
3925	= TYPE_SIZE_UNIT (gfc_get_element_type (type));
3926	elemsz = fold_convert (gfc_array_index_type, elemsz);
3927	OMP_CLAUSE_SIZE (node)
3928	= fold_build2 (MULT_EXPR, gfc_array_index_type,
3929	OMP_CLAUSE_SIZE (node), elemsz);
3930	}
3931	gfc_add_block_to_block (block, &se.post);
3932	gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3933	OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
3934	}
3935	if (n->u.present_modifier)
3936	OMP_CLAUSE_MOTION_PRESENT (node) = 1;
3937	omp_clauses = gfc_trans_add_clause (node, tail: omp_clauses);
3938	}
3939	break;
3940	case OMP_LIST_USES_ALLOCATORS:
3941	/* Ignore pre-defined allocators as no special treatment is needed. */
3942	for (; n != NULL; n = n->next)
3943	if (n->sym->attr.flavor == FL_VARIABLE)
3944	break;
3945	if (n != NULL)
3946	sorry_at (input_location, "%<uses_allocators%> clause with traits "
3947	"and memory spaces");
3948	break;
3949	default:
3950	break;
3951	}
3952	}
3953
3954	if (clauses->if_expr)
3955	{
3956	tree if_var;
3957
3958	gfc_init_se (&se, NULL);
3959	gfc_conv_expr (se: &se, expr: clauses->if_expr);
3960	gfc_add_block_to_block (block, &se.pre);
3961	if_var = gfc_evaluate_now (se.expr, block);
3962	gfc_add_block_to_block (block, &se.post);
3963
3964	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
3965	OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
3966	OMP_CLAUSE_IF_EXPR (c) = if_var;
3967	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
3968	}
3969
3970	for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
3971	if (clauses->if_exprs[ifc])
3972	{
3973	tree if_var;
3974
3975	gfc_init_se (&se, NULL);
3976	gfc_conv_expr (se: &se, expr: clauses->if_exprs[ifc]);
3977	gfc_add_block_to_block (block, &se.pre);
3978	if_var = gfc_evaluate_now (se.expr, block);
3979	gfc_add_block_to_block (block, &se.post);
3980
3981	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
3982	switch (ifc)
3983	{
3984	case OMP_IF_CANCEL:
3985	OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST;
3986	break;
3987	case OMP_IF_PARALLEL:
3988	OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
3989	break;
3990	case OMP_IF_SIMD:
3991	OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD;
3992	break;
3993	case OMP_IF_TASK:
3994	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
3995	break;
3996	case OMP_IF_TASKLOOP:
3997	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
3998	break;
3999	case OMP_IF_TARGET:
4000	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
4001	break;
4002	case OMP_IF_TARGET_DATA:
4003	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
4004	break;
4005	case OMP_IF_TARGET_UPDATE:
4006	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
4007	break;
4008	case OMP_IF_TARGET_ENTER_DATA:
4009	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
4010	break;
4011	case OMP_IF_TARGET_EXIT_DATA:
4012	OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
4013	break;
4014	default:
4015	gcc_unreachable ();
4016	}
4017	OMP_CLAUSE_IF_EXPR (c) = if_var;
4018	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4019	}
4020
4021	if (clauses->self_expr)
4022	{
4023	tree self_var;
4024
4025	gfc_init_se (&se, NULL);
4026	gfc_conv_expr (se: &se, expr: clauses->self_expr);
4027	gfc_add_block_to_block (block, &se.pre);
4028	self_var = gfc_evaluate_now (se.expr, block);
4029	gfc_add_block_to_block (block, &se.post);
4030
4031	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SELF);
4032	OMP_CLAUSE_SELF_EXPR (c) = self_var;
4033	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4034	}
4035
4036	if (clauses->final_expr)
4037	{
4038	tree final_var;
4039
4040	gfc_init_se (&se, NULL);
4041	gfc_conv_expr (se: &se, expr: clauses->final_expr);
4042	gfc_add_block_to_block (block, &se.pre);
4043	final_var = gfc_evaluate_now (se.expr, block);
4044	gfc_add_block_to_block (block, &se.post);
4045
4046	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL);
4047	OMP_CLAUSE_FINAL_EXPR (c) = final_var;
4048	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4049	}
4050
4051	if (clauses->num_threads)
4052	{
4053	tree num_threads;
4054
4055	gfc_init_se (&se, NULL);
4056	gfc_conv_expr (se: &se, expr: clauses->num_threads);
4057	gfc_add_block_to_block (block, &se.pre);
4058	num_threads = gfc_evaluate_now (se.expr, block);
4059	gfc_add_block_to_block (block, &se.post);
4060
4061	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS);
4062	OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
4063	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4064	}
4065
4066	chunk_size = NULL_TREE;
4067	if (clauses->chunk_size)
4068	{
4069	gfc_init_se (&se, NULL);
4070	gfc_conv_expr (se: &se, expr: clauses->chunk_size);
4071	gfc_add_block_to_block (block, &se.pre);
4072	chunk_size = gfc_evaluate_now (se.expr, block);
4073	gfc_add_block_to_block (block, &se.post);
4074	}
4075
4076	if (clauses->sched_kind != OMP_SCHED_NONE)
4077	{
4078	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE);
4079	OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
4080	switch (clauses->sched_kind)
4081	{
4082	case OMP_SCHED_STATIC:
4083	OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
4084	break;
4085	case OMP_SCHED_DYNAMIC:
4086	OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
4087	break;
4088	case OMP_SCHED_GUIDED:
4089	OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
4090	break;
4091	case OMP_SCHED_RUNTIME:
4092	OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
4093	break;
4094	case OMP_SCHED_AUTO:
4095	OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
4096	break;
4097	default:
4098	gcc_unreachable ();
4099	}
4100	if (clauses->sched_monotonic)
4101	OMP_CLAUSE_SCHEDULE_KIND (c)
4102	= (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
4103	| OMP_CLAUSE_SCHEDULE_MONOTONIC);
4104	else if (clauses->sched_nonmonotonic)
4105	OMP_CLAUSE_SCHEDULE_KIND (c)
4106	= (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
4107	| OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
4108	if (clauses->sched_simd)
4109	OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
4110	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4111	}
4112
4113	if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
4114	{
4115	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT);
4116	switch (clauses->default_sharing)
4117	{
4118	case OMP_DEFAULT_NONE:
4119	OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
4120	break;
4121	case OMP_DEFAULT_SHARED:
4122	OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
4123	break;
4124	case OMP_DEFAULT_PRIVATE:
4125	OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
4126	break;
4127	case OMP_DEFAULT_FIRSTPRIVATE:
4128	OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
4129	break;
4130	case OMP_DEFAULT_PRESENT:
4131	OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
4132	break;
4133	default:
4134	gcc_unreachable ();
4135	}
4136	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4137	}
4138
4139	if (clauses->nowait)
4140	{
4141	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT);
4142	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4143	}
4144
4145	if (clauses->ordered)
4146	{
4147	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED);
4148	OMP_CLAUSE_ORDERED_EXPR (c)
4149	= clauses->orderedc ? build_int_cst (integer_type_node,
4150	clauses->orderedc) : NULL_TREE;
4151	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4152	}
4153
4154	if (clauses->order_concurrent)
4155	{
4156	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER);
4157	OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained;
4158	OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible;
4159	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4160	}
4161
4162	if (clauses->untied)
4163	{
4164	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED);
4165	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4166	}
4167
4168	if (clauses->mergeable)
4169	{
4170	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE);
4171	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4172	}
4173
4174	if (clauses->collapse)
4175	{
4176	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE);
4177	OMP_CLAUSE_COLLAPSE_EXPR (c)
4178	= build_int_cst (integer_type_node, clauses->collapse);
4179	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4180	}
4181
4182	if (clauses->inbranch)
4183	{
4184	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH);
4185	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4186	}
4187
4188	if (clauses->notinbranch)
4189	{
4190	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH);
4191	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4192	}
4193
4194	switch (clauses->cancel)
4195	{
4196	case OMP_CANCEL_UNKNOWN:
4197	break;
4198	case OMP_CANCEL_PARALLEL:
4199	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL);
4200	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4201	break;
4202	case OMP_CANCEL_SECTIONS:
4203	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS);
4204	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4205	break;
4206	case OMP_CANCEL_DO:
4207	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR);
4208	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4209	break;
4210	case OMP_CANCEL_TASKGROUP:
4211	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP);
4212	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4213	break;
4214	}
4215
4216	if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
4217	{
4218	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND);
4219	switch (clauses->proc_bind)
4220	{
4221	case OMP_PROC_BIND_PRIMARY:
4222	OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY;
4223	break;
4224	case OMP_PROC_BIND_MASTER:
4225	OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
4226	break;
4227	case OMP_PROC_BIND_SPREAD:
4228	OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
4229	break;
4230	case OMP_PROC_BIND_CLOSE:
4231	OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
4232	break;
4233	default:
4234	gcc_unreachable ();
4235	}
4236	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4237	}
4238
4239	if (clauses->safelen_expr)
4240	{
4241	tree safelen_var;
4242
4243	gfc_init_se (&se, NULL);
4244	gfc_conv_expr (se: &se, expr: clauses->safelen_expr);
4245	gfc_add_block_to_block (block, &se.pre);
4246	safelen_var = gfc_evaluate_now (se.expr, block);
4247	gfc_add_block_to_block (block, &se.post);
4248
4249	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN);
4250	OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
4251	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4252	}
4253
4254	if (clauses->simdlen_expr)
4255	{
4256	if (declare_simd)
4257	{
4258	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
4259	OMP_CLAUSE_SIMDLEN_EXPR (c)
4260	= gfc_conv_constant_to_tree (clauses->simdlen_expr);
4261	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4262	}
4263	else
4264	{
4265	tree simdlen_var;
4266
4267	gfc_init_se (&se, NULL);
4268	gfc_conv_expr (se: &se, expr: clauses->simdlen_expr);
4269	gfc_add_block_to_block (block, &se.pre);
4270	simdlen_var = gfc_evaluate_now (se.expr, block);
4271	gfc_add_block_to_block (block, &se.post);
4272
4273	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
4274	OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var;
4275	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4276	}
4277	}
4278
4279	if (clauses->num_teams_upper)
4280	{
4281	tree num_teams_lower = NULL_TREE, num_teams_upper;
4282
4283	gfc_init_se (&se, NULL);
4284	gfc_conv_expr (se: &se, expr: clauses->num_teams_upper);
4285	gfc_add_block_to_block (block, &se.pre);
4286	num_teams_upper = gfc_evaluate_now (se.expr, block);
4287	gfc_add_block_to_block (block, &se.post);
4288
4289	if (clauses->num_teams_lower)
4290	{
4291	gfc_init_se (&se, NULL);
4292	gfc_conv_expr (se: &se, expr: clauses->num_teams_lower);
4293	gfc_add_block_to_block (block, &se.pre);
4294	num_teams_lower = gfc_evaluate_now (se.expr, block);
4295	gfc_add_block_to_block (block, &se.post);
4296	}
4297	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
4298	OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
4299	OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
4300	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4301	}
4302
4303	if (clauses->device)
4304	{
4305	tree device;
4306
4307	gfc_init_se (&se, NULL);
4308	gfc_conv_expr (se: &se, expr: clauses->device);
4309	gfc_add_block_to_block (block, &se.pre);
4310	device = gfc_evaluate_now (se.expr, block);
4311	gfc_add_block_to_block (block, &se.post);
4312
4313	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE);
4314	OMP_CLAUSE_DEVICE_ID (c) = device;
4315
4316	if (clauses->ancestor)
4317	OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1;
4318
4319	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4320	}
4321
4322	if (clauses->thread_limit)
4323	{
4324	tree thread_limit;
4325
4326	gfc_init_se (&se, NULL);
4327	gfc_conv_expr (se: &se, expr: clauses->thread_limit);
4328	gfc_add_block_to_block (block, &se.pre);
4329	thread_limit = gfc_evaluate_now (se.expr, block);
4330	gfc_add_block_to_block (block, &se.post);
4331
4332	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT);
4333	OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
4334	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4335	}
4336
4337	chunk_size = NULL_TREE;
4338	if (clauses->dist_chunk_size)
4339	{
4340	gfc_init_se (&se, NULL);
4341	gfc_conv_expr (se: &se, expr: clauses->dist_chunk_size);
4342	gfc_add_block_to_block (block, &se.pre);
4343	chunk_size = gfc_evaluate_now (se.expr, block);
4344	gfc_add_block_to_block (block, &se.post);
4345	}
4346
4347	if (clauses->dist_sched_kind != OMP_SCHED_NONE)
4348	{
4349	c = build_omp_clause (gfc_get_location (&where),
4350	OMP_CLAUSE_DIST_SCHEDULE);
4351	OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
4352	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4353	}
4354
4355	if (clauses->grainsize)
4356	{
4357	tree grainsize;
4358
4359	gfc_init_se (&se, NULL);
4360	gfc_conv_expr (se: &se, expr: clauses->grainsize);
4361	gfc_add_block_to_block (block, &se.pre);
4362	grainsize = gfc_evaluate_now (se.expr, block);
4363	gfc_add_block_to_block (block, &se.post);
4364
4365	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE);
4366	OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
4367	if (clauses->grainsize_strict)
4368	OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1;
4369	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4370	}
4371
4372	if (clauses->num_tasks)
4373	{
4374	tree num_tasks;
4375
4376	gfc_init_se (&se, NULL);
4377	gfc_conv_expr (se: &se, expr: clauses->num_tasks);
4378	gfc_add_block_to_block (block, &se.pre);
4379	num_tasks = gfc_evaluate_now (se.expr, block);
4380	gfc_add_block_to_block (block, &se.post);
4381
4382	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS);
4383	OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
4384	if (clauses->num_tasks_strict)
4385	OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1;
4386	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4387	}
4388
4389	if (clauses->priority)
4390	{
4391	tree priority;
4392
4393	gfc_init_se (&se, NULL);
4394	gfc_conv_expr (se: &se, expr: clauses->priority);
4395	gfc_add_block_to_block (block, &se.pre);
4396	priority = gfc_evaluate_now (se.expr, block);
4397	gfc_add_block_to_block (block, &se.post);
4398
4399	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY);
4400	OMP_CLAUSE_PRIORITY_EXPR (c) = priority;
4401	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4402	}
4403
4404	if (clauses->detach)
4405	{
4406	tree detach;
4407
4408	gfc_init_se (&se, NULL);
4409	gfc_conv_expr (se: &se, expr: clauses->detach);
4410	gfc_add_block_to_block (block, &se.pre);
4411	detach = se.expr;
4412	gfc_add_block_to_block (block, &se.post);
4413
4414	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH);
4415	TREE_ADDRESSABLE (detach) = 1;
4416	OMP_CLAUSE_DECL (c) = detach;
4417	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4418	}
4419
4420	if (clauses->filter)
4421	{
4422	tree filter;
4423
4424	gfc_init_se (&se, NULL);
4425	gfc_conv_expr (se: &se, expr: clauses->filter);
4426	gfc_add_block_to_block (block, &se.pre);
4427	filter = gfc_evaluate_now (se.expr, block);
4428	gfc_add_block_to_block (block, &se.post);
4429
4430	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER);
4431	OMP_CLAUSE_FILTER_EXPR (c) = filter;
4432	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4433	}
4434
4435	if (clauses->hint)
4436	{
4437	tree hint;
4438
4439	gfc_init_se (&se, NULL);
4440	gfc_conv_expr (se: &se, expr: clauses->hint);
4441	gfc_add_block_to_block (block, &se.pre);
4442	hint = gfc_evaluate_now (se.expr, block);
4443	gfc_add_block_to_block (block, &se.post);
4444
4445	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT);
4446	OMP_CLAUSE_HINT_EXPR (c) = hint;
4447	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4448	}
4449
4450	if (clauses->simd)
4451	{
4452	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD);
4453	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4454	}
4455	if (clauses->threads)
4456	{
4457	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS);
4458	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4459	}
4460	if (clauses->nogroup)
4461	{
4462	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP);
4463	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4464	}
4465
4466	for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
4467	{
4468	if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
4469	continue;
4470	enum omp_clause_defaultmap_kind behavior, category;
4471	switch ((gfc_omp_defaultmap_category) i)
4472	{
4473	case OMP_DEFAULTMAP_CAT_UNCATEGORIZED:
4474	category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
4475	break;
4476	case OMP_DEFAULTMAP_CAT_ALL:
4477	category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALL;
4478	break;
4479	case OMP_DEFAULTMAP_CAT_SCALAR:
4480	category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR;
4481	break;
4482	case OMP_DEFAULTMAP_CAT_AGGREGATE:
4483	category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE;
4484	break;
4485	case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
4486	category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE;
4487	break;
4488	case OMP_DEFAULTMAP_CAT_POINTER:
4489	category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER;
4490	break;
4491	default: gcc_unreachable ();
4492	}
4493	switch (clauses->defaultmap[i])
4494	{
4495	case OMP_DEFAULTMAP_ALLOC:
4496	behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC;
4497	break;
4498	case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break;
4499	case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break;
4500	case OMP_DEFAULTMAP_TOFROM:
4501	behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM;
4502	break;
4503	case OMP_DEFAULTMAP_FIRSTPRIVATE:
4504	behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
4505	break;
4506	case OMP_DEFAULTMAP_PRESENT:
4507	behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT;
4508	break;
4509	case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break;
4510	case OMP_DEFAULTMAP_DEFAULT:
4511	behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT;
4512	break;
4513	default: gcc_unreachable ();
4514	}
4515	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP);
4516	OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category);
4517	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4518	}
4519
4520	if (clauses->doacross_source)
4521	{
4522	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS);
4523	OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE;
4524	OMP_CLAUSE_DOACROSS_DEPEND (c) = clauses->depend_source;
4525	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4526	}
4527
4528	if (clauses->async)
4529	{
4530	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC);
4531	if (clauses->async_expr)
4532	OMP_CLAUSE_ASYNC_EXPR (c)
4533	= gfc_convert_expr_to_tree (block, expr: clauses->async_expr);
4534	else
4535	OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
4536	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4537	}
4538	if (clauses->seq)
4539	{
4540	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ);
4541	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4542	}
4543	if (clauses->par_auto)
4544	{
4545	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO);
4546	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4547	}
4548	if (clauses->if_present)
4549	{
4550	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT);
4551	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4552	}
4553	if (clauses->finalize)
4554	{
4555	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE);
4556	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4557	}
4558	if (clauses->independent)
4559	{
4560	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT);
4561	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4562	}
4563	if (clauses->wait_list)
4564	{
4565	gfc_expr_list *el;
4566
4567	for (el = clauses->wait_list; el; el = el->next)
4568	{
4569	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT);
4570	OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, expr: el->expr);
4571	OMP_CLAUSE_CHAIN (c) = omp_clauses;
4572	omp_clauses = c;
4573	}
4574	}
4575	if (clauses->num_gangs_expr)
4576	{
4577	tree num_gangs_var
4578	= gfc_convert_expr_to_tree (block, expr: clauses->num_gangs_expr);
4579	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS);
4580	OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
4581	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4582	}
4583	if (clauses->num_workers_expr)
4584	{
4585	tree num_workers_var
4586	= gfc_convert_expr_to_tree (block, expr: clauses->num_workers_expr);
4587	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS);
4588	OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
4589	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4590	}
4591	if (clauses->vector_length_expr)
4592	{
4593	tree vector_length_var
4594	= gfc_convert_expr_to_tree (block, expr: clauses->vector_length_expr);
4595	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH);
4596	OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
4597	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4598	}
4599	if (clauses->tile_list)
4600	{
4601	vec<tree, va_gc> *tvec;
4602	gfc_expr_list *el;
4603
4604	vec_alloc (v&: tvec, nelems: 4);
4605
4606	for (el = clauses->tile_list; el; el = el->next)
4607	vec_safe_push (v&: tvec, obj: gfc_convert_expr_to_tree (block, expr: el->expr));
4608
4609	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE);
4610	OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec);
4611	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4612	tvec->truncate (size: 0);
4613	}
4614	if (clauses->vector)
4615	{
4616	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR);
4617	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4618
4619	if (clauses->vector_expr)
4620	{
4621	tree vector_var
4622	= gfc_convert_expr_to_tree (block, expr: clauses->vector_expr);
4623	OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
4624
4625	/* TODO: We're not capturing location information for individual
4626	clauses. However, if we have an expression attached to the
4627	clause, that one provides better location information. */
4628	OMP_CLAUSE_LOCATION (c)
4629	= gfc_get_location (&clauses->vector_expr->where);
4630	}
4631	}
4632	if (clauses->worker)
4633	{
4634	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER);
4635	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4636
4637	if (clauses->worker_expr)
4638	{
4639	tree worker_var
4640	= gfc_convert_expr_to_tree (block, expr: clauses->worker_expr);
4641	OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
4642
4643	/* TODO: We're not capturing location information for individual
4644	clauses. However, if we have an expression attached to the
4645	clause, that one provides better location information. */
4646	OMP_CLAUSE_LOCATION (c)
4647	= gfc_get_location (&clauses->worker_expr->where);
4648	}
4649	}
4650	if (clauses->gang)
4651	{
4652	tree arg;
4653	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG);
4654	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4655
4656	if (clauses->gang_num_expr)
4657	{
4658	arg = gfc_convert_expr_to_tree (block, expr: clauses->gang_num_expr);
4659	OMP_CLAUSE_GANG_EXPR (c) = arg;
4660
4661	/* TODO: We're not capturing location information for individual
4662	clauses. However, if we have an expression attached to the
4663	clause, that one provides better location information. */
4664	OMP_CLAUSE_LOCATION (c)
4665	= gfc_get_location (&clauses->gang_num_expr->where);
4666	}
4667
4668	if (clauses->gang_static)
4669	{
4670	arg = clauses->gang_static_expr
4671	? gfc_convert_expr_to_tree (block, expr: clauses->gang_static_expr)
4672	: integer_minus_one_node;
4673	OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
4674	}
4675	}
4676	if (clauses->bind != OMP_BIND_UNSET)
4677	{
4678	c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND);
4679	omp_clauses = gfc_trans_add_clause (node: c, tail: omp_clauses);
4680	switch (clauses->bind)
4681	{
4682	case OMP_BIND_TEAMS:
4683	OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS;
4684	break;
4685	case OMP_BIND_PARALLEL:
4686	OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL;
4687	break;
4688	case OMP_BIND_THREAD:
4689	OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD;
4690	break;
4691	default:
4692	gcc_unreachable ();
4693	}
4694	}
4695	/* OpenACC 'nohost' clauses cannot appear here. */
4696	gcc_checking_assert (!clauses->nohost);
4697
4698	return nreverse (omp_clauses);
4699	}
4700
4701	/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
4702
4703	static tree
4704	gfc_trans_omp_code (gfc_code *code, bool force_empty)
4705	{
4706	tree stmt;
4707
4708	pushlevel ();
4709	stmt = gfc_trans_code (code);
4710	if (TREE_CODE (stmt) != BIND_EXPR)
4711	{
4712	if (!IS_EMPTY_STMT (stmt) || force_empty)
4713	{
4714	tree block = poplevel (1, 0);
4715	stmt = build3_v (BIND_EXPR, NULL, stmt, block);
4716	}
4717	else
4718	poplevel (0, 0);
4719	}
4720	else
4721	poplevel (0, 0);
4722	return stmt;
4723	}
4724
4725	/* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
4726	construct. */
4727
4728	static tree
4729	gfc_trans_oacc_construct (gfc_code *code)
4730	{
4731	stmtblock_t block;
4732	tree stmt, oacc_clauses;
4733	enum tree_code construct_code;
4734
4735	switch (code->op)
4736	{
4737	case EXEC_OACC_PARALLEL:
4738	construct_code = OACC_PARALLEL;
4739	break;
4740	case EXEC_OACC_KERNELS:
4741	construct_code = OACC_KERNELS;
4742	break;
4743	case EXEC_OACC_SERIAL:
4744	construct_code = OACC_SERIAL;
4745	break;
4746	case EXEC_OACC_DATA:
4747	construct_code = OACC_DATA;
4748	break;
4749	case EXEC_OACC_HOST_DATA:
4750	construct_code = OACC_HOST_DATA;
4751	break;
4752	default:
4753	gcc_unreachable ();
4754	}
4755
4756	gfc_start_block (&block);
4757	oacc_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
4758	where: code->loc, declare_simd: false, openacc: true);
4759	pushlevel ();
4760	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
4761	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
4762	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: construct_code,
4763	void_type_node, arg0: stmt, arg1: oacc_clauses);
4764	gfc_add_expr_to_block (&block, stmt);
4765	return gfc_finish_block (&block);
4766	}
4767
4768	/* update, enter_data, exit_data, cache. */
4769	static tree
4770	gfc_trans_oacc_executable_directive (gfc_code *code)
4771	{
4772	stmtblock_t block;
4773	tree stmt, oacc_clauses;
4774	enum tree_code construct_code;
4775
4776	switch (code->op)
4777	{
4778	case EXEC_OACC_UPDATE:
4779	construct_code = OACC_UPDATE;
4780	break;
4781	case EXEC_OACC_ENTER_DATA:
4782	construct_code = OACC_ENTER_DATA;
4783	break;
4784	case EXEC_OACC_EXIT_DATA:
4785	construct_code = OACC_EXIT_DATA;
4786	break;
4787	case EXEC_OACC_CACHE:
4788	construct_code = OACC_CACHE;
4789	break;
4790	default:
4791	gcc_unreachable ();
4792	}
4793
4794	gfc_start_block (&block);
4795	oacc_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
4796	where: code->loc, declare_simd: false, openacc: true);
4797	stmt = build1_loc (loc: input_location, code: construct_code, void_type_node,
4798	arg1: oacc_clauses);
4799	gfc_add_expr_to_block (&block, stmt);
4800	return gfc_finish_block (&block);
4801	}
4802
4803	static tree
4804	gfc_trans_oacc_wait_directive (gfc_code *code)
4805	{
4806	stmtblock_t block;
4807	tree stmt, t;
4808	vec<tree, va_gc> *args;
4809	int nparms = 0;
4810	gfc_expr_list *el;
4811	gfc_omp_clauses *clauses = code->ext.omp_clauses;
4812	location_t loc = input_location;
4813
4814	for (el = clauses->wait_list; el; el = el->next)
4815	nparms++;
4816
4817	vec_alloc (v&: args, nelems: nparms + 2);
4818	stmt = builtin_decl_explicit (fncode: BUILT_IN_GOACC_WAIT);
4819
4820	gfc_start_block (&block);
4821
4822	if (clauses->async_expr)
4823	t = gfc_convert_expr_to_tree (block: &block, expr: clauses->async_expr);
4824	else
4825	t = build_int_cst (integer_type_node, -2);
4826
4827	args->quick_push (obj: t);
4828	args->quick_push (obj: build_int_cst (integer_type_node, nparms));
4829
4830	for (el = clauses->wait_list; el; el = el->next)
4831	args->quick_push (obj: gfc_convert_expr_to_tree (block: &block, expr: el->expr));
4832
4833	stmt = build_call_expr_loc_vec (loc, stmt, args);
4834	gfc_add_expr_to_block (&block, stmt);
4835
4836	vec_free (v&: args);
4837
4838	return gfc_finish_block (&block);
4839	}
4840
4841	static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
4842	static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
4843
4844	static tree
4845	gfc_trans_omp_assume (gfc_code *code)
4846	{
4847	stmtblock_t block;
4848	gfc_init_block (&block);
4849	gfc_omp_assumptions *assume = code->ext.omp_clauses->assume;
4850	if (assume)
4851	for (gfc_expr_list *el = assume->holds; el; el = el->next)
4852	{
4853	location_t loc = gfc_get_location (&el->expr->where);
4854	gfc_se se;
4855	gfc_init_se (&se, NULL);
4856	gfc_conv_expr (se: &se, expr: el->expr);
4857	tree t;
4858	if (se.pre.head == NULL_TREE && se.post.head == NULL_TREE)
4859	t = se.expr;
4860	else
4861	{
4862	tree var = create_tmp_var_raw (boolean_type_node);
4863	DECL_CONTEXT (var) = current_function_decl;
4864	stmtblock_t block2;
4865	gfc_init_block (&block2);
4866	gfc_add_block_to_block (&block2, &se.pre);
4867	gfc_add_modify_loc (loc, &block2, var,
4868	fold_convert_loc (loc, boolean_type_node,
4869	se.expr));
4870	gfc_add_block_to_block (&block2, &se.post);
4871	t = gfc_finish_block (&block2);
4872	t = build4 (TARGET_EXPR, boolean_type_node, var, t, NULL, NULL);
4873	}
4874	t = build_call_expr_internal_loc (loc, IFN_ASSUME,
4875	void_type_node, 1, t);
4876	gfc_add_expr_to_block (&block, t);
4877	}
4878	gfc_add_expr_to_block (&block, gfc_trans_omp_code (code: code->block->next, force_empty: true));
4879	return gfc_finish_block (&block);
4880	}
4881
4882	static tree
4883	gfc_trans_omp_atomic (gfc_code *code)
4884	{
4885	gfc_code *atomic_code = code->block;
4886	gfc_se lse;
4887	gfc_se rse;
4888	gfc_se vse;
4889	gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
4890	gfc_symbol *var;
4891	stmtblock_t block;
4892	tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
4893	enum tree_code op = ERROR_MARK;
4894	enum tree_code aop = OMP_ATOMIC;
4895	bool var_on_left = false, else_branch = false;
4896	enum omp_memory_order mo, fail_mo;
4897	switch (atomic_code->ext.omp_clauses->memorder)
4898	{
4899	case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
4900	case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break;
4901	case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break;
4902	case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break;
4903	case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break;
4904	case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
4905	default: gcc_unreachable ();
4906	}
4907	switch (atomic_code->ext.omp_clauses->fail)
4908	{
4909	case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
4910	case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
4911	case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
4912	case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
4913	default: gcc_unreachable ();
4914	}
4915	mo = (omp_memory_order) (mo | fail_mo);
4916
4917	code = code->block->next;
4918	if (atomic_code->ext.omp_clauses->compare)
4919	{
4920	gfc_expr *comp_expr;
4921	if (code->op == EXEC_IF)
4922	{
4923	comp_expr = code->block->expr1;
4924	gcc_assert (code->block->next->op == EXEC_ASSIGN);
4925	expr1 = code->block->next->expr1;
4926	expr2 = code->block->next->expr2;
4927	if (code->block->block)
4928	{
4929	gcc_assert (atomic_code->ext.omp_clauses->capture
4930	&& code->block->block->next->op == EXEC_ASSIGN);
4931	else_branch = true;
4932	aop = OMP_ATOMIC_CAPTURE_OLD;
4933	capture_expr1 = code->block->block->next->expr1;
4934	capture_expr2 = code->block->block->next->expr2;
4935	}
4936	else if (atomic_code->ext.omp_clauses->capture)
4937	{
4938	gcc_assert (code->next->op == EXEC_ASSIGN);
4939	aop = OMP_ATOMIC_CAPTURE_NEW;
4940	capture_expr1 = code->next->expr1;
4941	capture_expr2 = code->next->expr2;
4942	}
4943	}
4944	else
4945	{
4946	gcc_assert (atomic_code->ext.omp_clauses->capture
4947	&& code->op == EXEC_ASSIGN
4948	&& code->next->op == EXEC_IF);
4949	aop = OMP_ATOMIC_CAPTURE_OLD;
4950	capture_expr1 = code->expr1;
4951	capture_expr2 = code->expr2;
4952	expr1 = code->next->block->next->expr1;
4953	expr2 = code->next->block->next->expr2;
4954	comp_expr = code->next->block->expr1;
4955	}
4956	gfc_init_se (&lse, NULL);
4957	gfc_conv_expr (se: &lse, expr: comp_expr->value.op.op2);
4958	gfc_add_block_to_block (&block, &lse.pre);
4959	compare = lse.expr;
4960	var = expr1->symtree->n.sym;
4961	}
4962	else
4963	{
4964	gcc_assert (code->op == EXEC_ASSIGN);
4965	expr1 = code->expr1;
4966	expr2 = code->expr2;
4967	if (atomic_code->ext.omp_clauses->capture
4968	&& (expr2->expr_type == EXPR_VARIABLE
4969	|| (expr2->expr_type == EXPR_FUNCTION
4970	&& expr2->value.function.isym
4971	&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION
4972	&& (expr2->value.function.actual->expr->expr_type
4973	== EXPR_VARIABLE))))
4974	{
4975	capture_expr1 = expr1;
4976	capture_expr2 = expr2;
4977	expr1 = code->next->expr1;
4978	expr2 = code->next->expr2;
4979	aop = OMP_ATOMIC_CAPTURE_OLD;
4980	}
4981	else if (atomic_code->ext.omp_clauses->capture)
4982	{
4983	aop = OMP_ATOMIC_CAPTURE_NEW;
4984	capture_expr1 = code->next->expr1;
4985	capture_expr2 = code->next->expr2;
4986	}
4987	var = expr1->symtree->n.sym;
4988	}
4989
4990	gfc_init_se (&lse, NULL);
4991	gfc_init_se (&rse, NULL);
4992	gfc_init_se (&vse, NULL);
4993	gfc_start_block (&block);
4994
4995	if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
4996	!= GFC_OMP_ATOMIC_WRITE)
4997	&& expr2->expr_type == EXPR_FUNCTION
4998	&& expr2->value.function.isym
4999	&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
5000	expr2 = expr2->value.function.actual->expr;
5001
5002	if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5003	== GFC_OMP_ATOMIC_READ)
5004	{
5005	gfc_conv_expr (se: &vse, expr: expr1);
5006	gfc_add_block_to_block (&block, &vse.pre);
5007
5008	gfc_conv_expr (se: &lse, expr: expr2);
5009	gfc_add_block_to_block (&block, &lse.pre);
5010	type = TREE_TYPE (lse.expr);
5011	lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
5012
5013	x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
5014	OMP_ATOMIC_MEMORY_ORDER (x) = mo;
5015	x = convert (TREE_TYPE (vse.expr), x);
5016	gfc_add_modify (&block, vse.expr, x);
5017
5018	gfc_add_block_to_block (&block, &lse.pre);
5019	gfc_add_block_to_block (&block, &rse.pre);
5020
5021	return gfc_finish_block (&block);
5022	}
5023
5024	if (capture_expr2
5025	&& capture_expr2->expr_type == EXPR_FUNCTION
5026	&& capture_expr2->value.function.isym
5027	&& capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
5028	capture_expr2 = capture_expr2->value.function.actual->expr;
5029	gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
5030
5031	if (aop == OMP_ATOMIC_CAPTURE_OLD)
5032	{
5033	gfc_conv_expr (se: &vse, expr: capture_expr1);
5034	gfc_add_block_to_block (&block, &vse.pre);
5035	gfc_conv_expr (se: &lse, expr: capture_expr2);
5036	gfc_add_block_to_block (&block, &lse.pre);
5037	gfc_init_se (&lse, NULL);
5038	}
5039
5040	gfc_conv_expr (se: &lse, expr: expr1);
5041	gfc_add_block_to_block (&block, &lse.pre);
5042	type = TREE_TYPE (lse.expr);
5043	lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
5044
5045	if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5046	== GFC_OMP_ATOMIC_WRITE)
5047	|| (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
5048	|| compare)
5049	{
5050	gfc_conv_expr (se: &rse, expr: expr2);
5051	gfc_add_block_to_block (&block, &rse.pre);
5052	}
5053	else if (expr2->expr_type == EXPR_OP)
5054	{
5055	gfc_expr *e;
5056	switch (expr2->value.op.op)
5057	{
5058	case INTRINSIC_PLUS:
5059	op = PLUS_EXPR;
5060	break;
5061	case INTRINSIC_TIMES:
5062	op = MULT_EXPR;
5063	break;
5064	case INTRINSIC_MINUS:
5065	op = MINUS_EXPR;
5066	break;
5067	case INTRINSIC_DIVIDE:
5068	if (expr2->ts.type == BT_INTEGER)
5069	op = TRUNC_DIV_EXPR;
5070	else
5071	op = RDIV_EXPR;
5072	break;
5073	case INTRINSIC_AND:
5074	op = TRUTH_ANDIF_EXPR;
5075	break;
5076	case INTRINSIC_OR:
5077	op = TRUTH_ORIF_EXPR;
5078	break;
5079	case INTRINSIC_EQV:
5080	op = EQ_EXPR;
5081	break;
5082	case INTRINSIC_NEQV:
5083	op = NE_EXPR;
5084	break;
5085	default:
5086	gcc_unreachable ();
5087	}
5088	e = expr2->value.op.op1;
5089	if (e->expr_type == EXPR_FUNCTION
5090	&& e->value.function.isym
5091	&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
5092	e = e->value.function.actual->expr;
5093	if (e->expr_type == EXPR_VARIABLE
5094	&& e->symtree != NULL
5095	&& e->symtree->n.sym == var)
5096	{
5097	expr2 = expr2->value.op.op2;
5098	var_on_left = true;
5099	}
5100	else
5101	{
5102	e = expr2->value.op.op2;
5103	if (e->expr_type == EXPR_FUNCTION
5104	&& e->value.function.isym
5105	&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
5106	e = e->value.function.actual->expr;
5107	gcc_assert (e->expr_type == EXPR_VARIABLE
5108	&& e->symtree != NULL
5109	&& e->symtree->n.sym == var);
5110	expr2 = expr2->value.op.op1;
5111	var_on_left = false;
5112	}
5113	gfc_conv_expr (se: &rse, expr: expr2);
5114	gfc_add_block_to_block (&block, &rse.pre);
5115	}
5116	else
5117	{
5118	gcc_assert (expr2->expr_type == EXPR_FUNCTION);
5119	switch (expr2->value.function.isym->id)
5120	{
5121	case GFC_ISYM_MIN:
5122	op = MIN_EXPR;
5123	break;
5124	case GFC_ISYM_MAX:
5125	op = MAX_EXPR;
5126	break;
5127	case GFC_ISYM_IAND:
5128	op = BIT_AND_EXPR;
5129	break;
5130	case GFC_ISYM_IOR:
5131	op = BIT_IOR_EXPR;
5132	break;
5133	case GFC_ISYM_IEOR:
5134	op = BIT_XOR_EXPR;
5135	break;
5136	default:
5137	gcc_unreachable ();
5138	}
5139	e = expr2->value.function.actual->expr;
5140	if (e->expr_type == EXPR_FUNCTION
5141	&& e->value.function.isym
5142	&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
5143	e = e->value.function.actual->expr;
5144	gcc_assert (e->expr_type == EXPR_VARIABLE
5145	&& e->symtree != NULL
5146	&& e->symtree->n.sym == var);
5147
5148	gfc_conv_expr (se: &rse, expr: expr2->value.function.actual->next->expr);
5149	gfc_add_block_to_block (&block, &rse.pre);
5150	if (expr2->value.function.actual->next->next != NULL)
5151	{
5152	tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
5153	gfc_actual_arglist *arg;
5154
5155	gfc_add_modify (&block, accum, rse.expr);
5156	for (arg = expr2->value.function.actual->next->next; arg;
5157	arg = arg->next)
5158	{
5159	gfc_init_block (&rse.pre);
5160	gfc_conv_expr (se: &rse, expr: arg->expr);
5161	gfc_add_block_to_block (&block, &rse.pre);
5162	x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
5163	accum, rse.expr);
5164	gfc_add_modify (&block, accum, x);
5165	}
5166
5167	rse.expr = accum;
5168	}
5169
5170	expr2 = expr2->value.function.actual->next->expr;
5171	}
5172
5173	lhsaddr = save_expr (lhsaddr);
5174	if (TREE_CODE (lhsaddr) != SAVE_EXPR
5175	&& (TREE_CODE (lhsaddr) != ADDR_EXPR
5176	|| !VAR_P (TREE_OPERAND (lhsaddr, 0))))
5177	{
5178	/* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
5179	it even after unsharing function body. */
5180	tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
5181	DECL_CONTEXT (var) = current_function_decl;
5182	lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
5183	NULL_TREE, NULL_TREE);
5184	}
5185
5186	if (compare)
5187	{
5188	tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
5189	DECL_CONTEXT (var) = current_function_decl;
5190	lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
5191	NULL);
5192	lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
5193	compare = convert (TREE_TYPE (lse.expr), compare);
5194	compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5195	lse.expr, compare);
5196	}
5197
5198	if (expr2->expr_type == EXPR_VARIABLE || compare)
5199	rhs = rse.expr;
5200	else
5201	rhs = gfc_evaluate_now (rse.expr, &block);
5202
5203	if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
5204	== GFC_OMP_ATOMIC_WRITE)
5205	|| (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
5206	|| compare)
5207	x = rhs;
5208	else
5209	{
5210	x = convert (TREE_TYPE (rhs),
5211	build_fold_indirect_ref_loc (input_location, lhsaddr));
5212	if (var_on_left)
5213	x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
5214	else
5215	x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
5216	}
5217
5218	if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
5219	&& TREE_CODE (type) != COMPLEX_TYPE)
5220	x = fold_build1_loc (input_location, REALPART_EXPR,
5221	TREE_TYPE (TREE_TYPE (rhs)), x);
5222
5223	gfc_add_block_to_block (&block, &lse.pre);
5224	gfc_add_block_to_block (&block, &rse.pre);
5225
5226	if (aop == OMP_ATOMIC_CAPTURE_NEW)
5227	{
5228	gfc_conv_expr (se: &vse, expr: capture_expr1);
5229	gfc_add_block_to_block (&block, &vse.pre);
5230	gfc_add_block_to_block (&block, &lse.pre);
5231	}
5232
5233	if (compare && else_branch)
5234	{
5235	tree var2 = create_tmp_var_raw (boolean_type_node);
5236	DECL_CONTEXT (var2) = current_function_decl;
5237	comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
5238	boolean_false_node, NULL, NULL);
5239	compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
5240	var2, compare);
5241	TREE_OPERAND (compare, 0) = comp_tgt;
5242	compare = omit_one_operand_loc (input_location, boolean_type_node,
5243	compare, comp_tgt);
5244	}
5245
5246	if (compare)
5247	x = build3_loc (loc: input_location, code: COND_EXPR, type, arg0: compare,
5248	arg1: convert (type, x), arg2: lse.expr);
5249
5250	if (aop == OMP_ATOMIC)
5251	{
5252	x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
5253	OMP_ATOMIC_MEMORY_ORDER (x) = mo;
5254	OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
5255	gfc_add_expr_to_block (&block, x);
5256	}
5257	else
5258	{
5259	x = build2 (aop, type, lhsaddr, convert (type, x));
5260	OMP_ATOMIC_MEMORY_ORDER (x) = mo;
5261	OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
5262	if (compare && else_branch)
5263	{
5264	tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
5265	DECL_CONTEXT (vtmp) = current_function_decl;
5266	x = fold_build2_loc (input_location, MODIFY_EXPR,
5267	TREE_TYPE (vtmp), vtmp, x);
5268	vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
5269	build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
5270	TREE_OPERAND (x, 0) = vtmp;
5271	tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
5272	x2 = fold_build2_loc (input_location, MODIFY_EXPR,
5273	TREE_TYPE (vse.expr), vse.expr, x2);
5274	x2 = build3_loc (loc: input_location, code: COND_EXPR, void_type_node, arg0: comp_tgt,
5275	void_node, arg2: x2);
5276	x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
5277	gfc_add_expr_to_block (&block, x);
5278	}
5279	else
5280	{
5281	x = convert (TREE_TYPE (vse.expr), x);
5282	gfc_add_modify (&block, vse.expr, x);
5283	}
5284	}
5285
5286	return gfc_finish_block (&block);
5287	}
5288
5289	static tree
5290	gfc_trans_omp_barrier (void)
5291	{
5292	tree decl = builtin_decl_explicit (fncode: BUILT_IN_GOMP_BARRIER);
5293	return build_call_expr_loc (input_location, decl, 0);
5294	}
5295
5296	static tree
5297	gfc_trans_omp_cancel (gfc_code *code)
5298	{
5299	int mask = 0;
5300	tree ifc = boolean_true_node;
5301	stmtblock_t block;
5302	switch (code->ext.omp_clauses->cancel)
5303	{
5304	case OMP_CANCEL_PARALLEL: mask = 1; break;
5305	case OMP_CANCEL_DO: mask = 2; break;
5306	case OMP_CANCEL_SECTIONS: mask = 4; break;
5307	case OMP_CANCEL_TASKGROUP: mask = 8; break;
5308	default: gcc_unreachable ();
5309	}
5310	gfc_start_block (&block);
5311	if (code->ext.omp_clauses->if_expr
5312	|| code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL])
5313	{
5314	gfc_se se;
5315	tree if_var;
5316
5317	gcc_assert ((code->ext.omp_clauses->if_expr == NULL)
5318	^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL));
5319	gfc_init_se (&se, NULL);
5320	gfc_conv_expr (se: &se, expr: code->ext.omp_clauses->if_expr != NULL
5321	? code->ext.omp_clauses->if_expr
5322	: code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]);
5323	gfc_add_block_to_block (&block, &se.pre);
5324	if_var = gfc_evaluate_now (se.expr, &block);
5325	gfc_add_block_to_block (&block, &se.post);
5326	tree type = TREE_TYPE (if_var);
5327	ifc = fold_build2_loc (input_location, NE_EXPR,
5328	boolean_type_node, if_var,
5329	build_zero_cst (type));
5330	}
5331	tree decl = builtin_decl_explicit (fncode: BUILT_IN_GOMP_CANCEL);
5332	tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
5333	ifc = fold_convert (c_bool_type, ifc);
5334	gfc_add_expr_to_block (&block,
5335	build_call_expr_loc (input_location, decl, 2,
5336	build_int_cst (integer_type_node,
5337	mask), ifc));
5338	return gfc_finish_block (&block);
5339	}
5340
5341	static tree
5342	gfc_trans_omp_cancellation_point (gfc_code *code)
5343	{
5344	int mask = 0;
5345	switch (code->ext.omp_clauses->cancel)
5346	{
5347	case OMP_CANCEL_PARALLEL: mask = 1; break;
5348	case OMP_CANCEL_DO: mask = 2; break;
5349	case OMP_CANCEL_SECTIONS: mask = 4; break;
5350	case OMP_CANCEL_TASKGROUP: mask = 8; break;
5351	default: gcc_unreachable ();
5352	}
5353	tree decl = builtin_decl_explicit (fncode: BUILT_IN_GOMP_CANCELLATION_POINT);
5354	return build_call_expr_loc (input_location, decl, 1,
5355	build_int_cst (integer_type_node, mask));
5356	}
5357
5358	static tree
5359	gfc_trans_omp_critical (gfc_code *code)
5360	{
5361	stmtblock_t block;
5362	tree stmt, name = NULL_TREE;
5363	if (code->ext.omp_clauses->critical_name != NULL)
5364	name = get_identifier (code->ext.omp_clauses->critical_name);
5365	gfc_start_block (&block);
5366	stmt = make_node (OMP_CRITICAL);
5367	SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
5368	TREE_TYPE (stmt) = void_type_node;
5369	OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next);
5370	OMP_CRITICAL_NAME (stmt) = name;
5371	OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (block: &block,
5372	clauses: code->ext.omp_clauses,
5373	where: code->loc);
5374	gfc_add_expr_to_block (&block, stmt);
5375	return gfc_finish_block (&block);
5376	}
5377
5378	typedef struct dovar_init_d {
5379	gfc_symbol *sym;
5380	tree var;
5381	tree init;
5382	bool non_unit_iter;
5383	} dovar_init;
5384
5385	static bool
5386	gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n,
5387	gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits,
5388	int simple, gfc_expr *curr_loop_var)
5389	{
5390	int i;
5391	for (i = 0; i < loop_n; i++)
5392	{
5393	gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE);
5394	if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr))
5395	break;
5396	code = code->block->next;
5397	}
5398	if (i >= loop_n)
5399	return false;
5400
5401	/* Canonical format: TREE_VEC with [var, multiplier, offset]. */
5402	gfc_symbol *var = code->ext.iterator->var->symtree->n.sym;
5403
5404	tree tree_var = NULL_TREE;
5405	tree a1 = integer_one_node;
5406	tree a2 = integer_zero_node;
5407
5408	if (!simple)
5409	{
5410	/* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
5411	sorry_at (gfc_get_location (&curr_loop_var->where),
5412	"non-rectangular loop nest with non-constant step for %qs",
5413	curr_loop_var->symtree->n.sym->name);
5414	return false;
5415	}
5416
5417	dovar_init *di;
5418	unsigned ix;
5419	FOR_EACH_VEC_ELT (*inits, ix, di)
5420	if (di->sym == var)
5421	{
5422	if (!di->non_unit_iter)
5423	{
5424	tree_var = di->init;
5425	gcc_assert (DECL_P (tree_var));
5426	break;
5427	}
5428	else
5429	{
5430	/* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
5431	sorry_at (gfc_get_location (&code->loc),
5432	"non-rectangular loop nest with non-constant step "
5433	"for %qs", var->name);
5434	inform (gfc_get_location (&expr->where), "Used here");
5435	return false;
5436	}
5437	}
5438	if (tree_var == NULL_TREE)
5439	tree_var = var->backend_decl;
5440
5441	if (expr->expr_type == EXPR_VARIABLE)
5442	gcc_assert (expr->symtree->n.sym == var);
5443	else if (expr->expr_type != EXPR_OP
5444	|| (expr->value.op.op != INTRINSIC_TIMES
5445	&& expr->value.op.op != INTRINSIC_PLUS
5446	&& expr->value.op.op != INTRINSIC_MINUS))
5447	gcc_unreachable ();
5448	else
5449	{
5450	gfc_se se;
5451	gfc_expr *et = NULL, *eo = NULL, *e = expr;
5452	if (expr->value.op.op != INTRINSIC_TIMES)
5453	{
5454	if (gfc_find_sym_in_expr (var, expr->value.op.op1))
5455	{
5456	e = expr->value.op.op1;
5457	eo = expr->value.op.op2;
5458	}
5459	else
5460	{
5461	eo = expr->value.op.op1;
5462	e = expr->value.op.op2;
5463	}
5464	}
5465	if (e->value.op.op == INTRINSIC_TIMES)
5466	{
5467	if (e->value.op.op1->expr_type == EXPR_VARIABLE
5468	&& e->value.op.op1->symtree->n.sym == var)
5469	et = e->value.op.op2;
5470	else
5471	{
5472	et = e->value.op.op1;
5473	gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE
5474	&& e->value.op.op2->symtree->n.sym == var);
5475	}
5476	}
5477	else
5478	gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var);
5479	if (et != NULL)
5480	{
5481	gfc_init_se (&se, NULL);
5482	gfc_conv_expr_val (se: &se, expr: et);
5483	gfc_add_block_to_block (pblock, &se.pre);
5484	a1 = se.expr;
5485	}
5486	if (eo != NULL)
5487	{
5488	gfc_init_se (&se, NULL);
5489	gfc_conv_expr_val (se: &se, expr: eo);
5490	gfc_add_block_to_block (pblock, &se.pre);
5491	a2 = se.expr;
5492	if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo)
5493	/* outer-var - a2. */
5494	a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2);
5495	else if (expr->value.op.op == INTRINSIC_MINUS)
5496	/* a2 - outer-var. */
5497	a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1);
5498	}
5499	a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock);
5500	a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock);
5501	}
5502
5503	gfc_init_se (sep, NULL);
5504	sep->expr = make_tree_vec (3);
5505	TREE_VEC_ELT (sep->expr, 0) = tree_var;
5506	TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1);
5507	TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2);
5508
5509	return true;
5510	}
5511
5512	static tree
5513	gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
5514	gfc_omp_clauses *do_clauses, tree par_clauses)
5515	{
5516	gfc_se se;
5517	tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
5518	tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses;
5519	stmtblock_t block;
5520	stmtblock_t body;
5521	gfc_omp_clauses *clauses = code->ext.omp_clauses;
5522	int i, collapse = clauses->collapse;
5523	vec<dovar_init> inits = vNULL;
5524	dovar_init *di;
5525	unsigned ix;
5526	vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
5527	gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list;
5528	gfc_code *orig_code = code;
5529
5530	/* Both collapsed and tiled loops are lowered the same way. In
5531	OpenACC, those clauses are not compatible, so prioritize the tile
5532	clause, if present. */
5533	if (tile)
5534	{
5535	collapse = 0;
5536	for (gfc_expr_list *el = tile; el; el = el->next)
5537	collapse++;
5538	}
5539
5540	doacross_steps = NULL;
5541	if (clauses->orderedc)
5542	collapse = clauses->orderedc;
5543	if (collapse <= 0)
5544	collapse = 1;
5545
5546	code = code->block->next;
5547	gcc_assert (code->op == EXEC_DO);
5548
5549	init = make_tree_vec (collapse);
5550	cond = make_tree_vec (collapse);
5551	incr = make_tree_vec (collapse);
5552	orig_decls = clauses->ordered ? make_tree_vec (collapse) : NULL_TREE;
5553
5554	if (pblock == NULL)
5555	{
5556	gfc_start_block (&block);
5557	pblock = &block;
5558	}
5559
5560	/* simd schedule modifier is only useful for composite do simd and other
5561	constructs including that, where gfc_trans_omp_do is only called
5562	on the simd construct and DO's clauses are translated elsewhere. */
5563	do_clauses->sched_simd = false;
5564
5565	omp_clauses = gfc_trans_omp_clauses (block: pblock, clauses: do_clauses, where: code->loc);
5566
5567	for (i = 0; i < collapse; i++)
5568	{
5569	int simple = 0;
5570	int dovar_found = 0;
5571	tree dovar_decl;
5572
5573	if (clauses)
5574	{
5575	gfc_omp_namelist *n = NULL;
5576	if (op == EXEC_OMP_SIMD && collapse == 1)
5577	for (n = clauses->lists[OMP_LIST_LINEAR];
5578	n != NULL; n = n->next)
5579	if (code->ext.iterator->var->symtree->n.sym == n->sym)
5580	{
5581	dovar_found = 3;
5582	break;
5583	}
5584	if (n == NULL && op != EXEC_OMP_DISTRIBUTE)
5585	for (n = clauses->lists[OMP_LIST_LASTPRIVATE];
5586	n != NULL; n = n->next)
5587	if (code->ext.iterator->var->symtree->n.sym == n->sym)
5588	{
5589	dovar_found = 2;
5590	break;
5591	}
5592	if (n == NULL)
5593	for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
5594	if (code->ext.iterator->var->symtree->n.sym == n->sym)
5595	{
5596	dovar_found = 1;
5597	break;
5598	}
5599	}
5600
5601	/* Evaluate all the expressions in the iterator. */
5602	gfc_init_se (&se, NULL);
5603	gfc_conv_expr_lhs (se: &se, expr: code->ext.iterator->var);
5604	gfc_add_block_to_block (pblock, &se.pre);
5605	local_dovar = dovar_decl = dovar = se.expr;
5606	type = TREE_TYPE (dovar);
5607	gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
5608
5609	gfc_init_se (&se, NULL);
5610	gfc_conv_expr_val (se: &se, expr: code->ext.iterator->step);
5611	gfc_add_block_to_block (pblock, &se.pre);
5612	step = gfc_evaluate_now (se.expr, pblock);
5613
5614	if (TREE_CODE (step) == INTEGER_CST)
5615	simple = tree_int_cst_sgn (step);
5616
5617	gfc_init_se (&se, NULL);
5618	if (!clauses->non_rectangular
5619	|| !gfc_nonrect_loop_expr (pblock, sep: &se, loop_n: i, code: orig_code->block->next,
5620	expr: code->ext.iterator->start, inits: &inits, simple,
5621	curr_loop_var: code->ext.iterator->var))
5622	{
5623	gfc_conv_expr_val (se: &se, expr: code->ext.iterator->start);
5624	gfc_add_block_to_block (pblock, &se.pre);
5625	if (!DECL_P (se.expr))
5626	se.expr = gfc_evaluate_now (se.expr, pblock);
5627	}
5628	from = se.expr;
5629
5630	gfc_init_se (&se, NULL);
5631	if (!clauses->non_rectangular
5632	|| !gfc_nonrect_loop_expr (pblock, sep: &se, loop_n: i, code: orig_code->block->next,
5633	expr: code->ext.iterator->end, inits: &inits, simple,
5634	curr_loop_var: code->ext.iterator->var))
5635	{
5636	gfc_conv_expr_val (se: &se, expr: code->ext.iterator->end);
5637	gfc_add_block_to_block (pblock, &se.pre);
5638	if (!DECL_P (se.expr))
5639	se.expr = gfc_evaluate_now (se.expr, pblock);
5640	}
5641	to = se.expr;
5642
5643	if (!DECL_P (dovar))
5644	dovar_decl
5645	= gfc_trans_omp_variable (sym: code->ext.iterator->var->symtree->n.sym,
5646	declare_simd: false);
5647	if (simple && !DECL_P (dovar))
5648	{
5649	const char *name = code->ext.iterator->var->symtree->n.sym->name;
5650	local_dovar = gfc_create_var (type, name);
5651	dovar_init e = {.sym: code->ext.iterator->var->symtree->n.sym,
5652	.var: dovar, .init: local_dovar, .non_unit_iter: false};
5653	inits.safe_push (obj: e);
5654	}
5655	/* Loop body. */
5656	if (simple)
5657	{
5658	TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from);
5659	/* The condition should not be folded. */
5660	TREE_VEC_ELT (cond, i) = build2_loc (loc: input_location, code: simple > 0
5661	? LE_EXPR : GE_EXPR,
5662	type: logical_type_node, arg0: local_dovar,
5663	arg1: to);
5664	TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
5665	type, local_dovar, step);
5666	TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
5667	MODIFY_EXPR,
5668	type, local_dovar,
5669	TREE_VEC_ELT (incr, i));
5670	if (orig_decls && !clauses->orderedc)
5671	orig_decls = NULL;
5672	else if (orig_decls)
5673	TREE_VEC_ELT (orig_decls, i) = dovar_decl;
5674	}
5675	else
5676	{
5677	/* STEP is not 1 or -1. Use:
5678	for (count = 0; count < (to + step - from) / step; count++)
5679	{
5680	dovar = from + count * step;
5681	body;
5682	cycle_label:;
5683	} */
5684	tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
5685	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
5686	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
5687	step);
5688	tmp = gfc_evaluate_now (tmp, pblock);
5689	local_dovar = gfc_create_var (type, "count");
5690	TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar,
5691	build_int_cst (type, 0));
5692	/* The condition should not be folded. */
5693	TREE_VEC_ELT (cond, i) = build2_loc (loc: input_location, code: LT_EXPR,
5694	type: logical_type_node,
5695	arg0: local_dovar, arg1: tmp);
5696	TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
5697	type, local_dovar,
5698	build_int_cst (type, 1));
5699	TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
5700	MODIFY_EXPR, type,
5701	local_dovar,
5702	TREE_VEC_ELT (incr, i));
5703
5704	/* Initialize DOVAR. */
5705	tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar,
5706	step);
5707	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
5708	dovar_init e = {.sym: code->ext.iterator->var->symtree->n.sym,
5709	.var: dovar, .init: tmp, .non_unit_iter: true};
5710	inits.safe_push (obj: e);
5711	if (clauses->orderedc)
5712	{
5713	if (doacross_steps == NULL)
5714	vec_safe_grow_cleared (v&: doacross_steps, len: clauses->orderedc, exact: true);
5715	(*doacross_steps)[i] = step;
5716	}
5717	if (orig_decls)
5718	TREE_VEC_ELT (orig_decls, i) = dovar_decl;
5719	}
5720
5721	if (dovar_found == 3
5722	&& op == EXEC_OMP_SIMD
5723	&& collapse == 1
5724	&& local_dovar != dovar)
5725	{
5726	for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
5727	if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
5728	&& OMP_CLAUSE_DECL (tmp) == dovar)
5729	{
5730	OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
5731	break;
5732	}
5733	}
5734	if (!dovar_found && op == EXEC_OMP_SIMD)
5735	{
5736	if (collapse == 1)
5737	{
5738	tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
5739	OMP_CLAUSE_LINEAR_STEP (tmp) = step;
5740	OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
5741	OMP_CLAUSE_DECL (tmp) = dovar_decl;
5742	omp_clauses = gfc_trans_add_clause (node: tmp, tail: omp_clauses);
5743	if (local_dovar != dovar)
5744	dovar_found = 3;
5745	}
5746	}
5747	else if (!dovar_found && local_dovar != dovar)
5748	{
5749	tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
5750	OMP_CLAUSE_DECL (tmp) = dovar_decl;
5751	omp_clauses = gfc_trans_add_clause (node: tmp, tail: omp_clauses);
5752	}
5753	if (dovar_found > 1)
5754	{
5755	tree c = NULL;
5756
5757	tmp = NULL;
5758	if (local_dovar != dovar)
5759	{
5760	/* If dovar is lastprivate, but different counter is used,
5761	dovar += step needs to be added to
5762	OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
5763	will have the value on entry of the last loop, rather
5764	than value after iterator increment. */
5765	if (clauses->orderedc)
5766	{
5767	if (clauses->collapse <= 1 || i >= clauses->collapse)
5768	tmp = local_dovar;
5769	else
5770	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5771	type, local_dovar,
5772	build_one_cst (type));
5773	tmp = fold_build2_loc (input_location, MULT_EXPR, type,
5774	tmp, step);
5775	tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
5776	from, tmp);
5777	}
5778	else
5779	tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
5780	dovar, step);
5781	tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
5782	dovar, tmp);
5783	for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
5784	if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
5785	&& OMP_CLAUSE_DECL (c) == dovar_decl)
5786	{
5787	OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
5788	break;
5789	}
5790	else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
5791	&& OMP_CLAUSE_DECL (c) == dovar_decl)
5792	{
5793	OMP_CLAUSE_LINEAR_STMT (c) = tmp;
5794	break;
5795	}
5796	}
5797	if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
5798	{
5799	for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
5800	if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
5801	&& OMP_CLAUSE_DECL (c) == dovar_decl)
5802	{
5803	tree l = build_omp_clause (input_location,
5804	OMP_CLAUSE_LASTPRIVATE);
5805	if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c))
5806	OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1;
5807	OMP_CLAUSE_DECL (l) = dovar_decl;
5808	OMP_CLAUSE_CHAIN (l) = omp_clauses;
5809	OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
5810	omp_clauses = l;
5811	OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
5812	break;
5813	}
5814	}
5815	gcc_assert (local_dovar == dovar || c != NULL);
5816	}
5817	if (local_dovar != dovar)
5818	{
5819	if (op != EXEC_OMP_SIMD || dovar_found == 1)
5820	tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
5821	else if (collapse == 1)
5822	{
5823	tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
5824	OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
5825	OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
5826	OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
5827	}
5828	else
5829	tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
5830	OMP_CLAUSE_DECL (tmp) = local_dovar;
5831	omp_clauses = gfc_trans_add_clause (node: tmp, tail: omp_clauses);
5832	}
5833
5834	if (i + 1 < collapse)
5835	code = code->block->next;
5836	}
5837
5838	if (pblock != &block)
5839	{
5840	pushlevel ();
5841	gfc_start_block (&block);
5842	}
5843
5844	gfc_start_block (&body);
5845
5846	FOR_EACH_VEC_ELT (inits, ix, di)
5847	gfc_add_modify (&body, di->var, di->init);
5848	inits.release ();
5849
5850	/* Cycle statement is implemented with a goto. Exit statement must not be
5851	present for this loop. */
5852	cycle_label = gfc_build_label_decl (NULL_TREE);
5853
5854	/* Put these labels where they can be found later. */
5855
5856	code->cycle_label = cycle_label;
5857	code->exit_label = NULL_TREE;
5858
5859	/* Main loop body. */
5860	if (clauses->lists[OMP_LIST_REDUCTION_INSCAN])
5861	{
5862	gfc_code *code1, *scan, *code2, *tmpcode;
5863	code1 = tmpcode = code->block->next;
5864	if (tmpcode && tmpcode->op != EXEC_OMP_SCAN)
5865	while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN)
5866	tmpcode = tmpcode->next;
5867	scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next;
5868	if (code1 != scan)
5869	tmpcode->next = NULL;
5870	code2 = scan->next;
5871	gcc_assert (scan->op == EXEC_OMP_SCAN);
5872	location_t loc = gfc_get_location (&scan->loc);
5873
5874	tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc);
5875	tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE);
5876	SET_EXPR_LOCATION (tmp, loc);
5877	gfc_add_expr_to_block (&body, tmp);
5878	input_location = loc;
5879	tree c = gfc_trans_omp_clauses (block: &body, clauses: scan->ext.omp_clauses, where: scan->loc);
5880	tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc);
5881	tmp = build2 (OMP_SCAN, void_type_node, tmp, c);
5882	SET_EXPR_LOCATION (tmp, loc);
5883	if (code1 != scan)
5884	tmpcode->next = scan;
5885	}
5886	else
5887	tmp = gfc_trans_omp_code (code: code->block->next, force_empty: true);
5888	gfc_add_expr_to_block (&body, tmp);
5889
5890	/* Label for cycle statements (if needed). */
5891	if (TREE_USED (cycle_label))
5892	{
5893	tmp = build1_v (LABEL_EXPR, cycle_label);
5894	gfc_add_expr_to_block (&body, tmp);
5895	}
5896
5897	/* End of loop body. */
5898	switch (op)
5899	{
5900	case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
5901	case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
5902	case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
5903	case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break;
5904	case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
5905	case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
5906	default: gcc_unreachable ();
5907	}
5908
5909	SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc));
5910	TREE_TYPE (stmt) = void_type_node;
5911	OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
5912	OMP_FOR_CLAUSES (stmt) = omp_clauses;
5913	OMP_FOR_INIT (stmt) = init;
5914	OMP_FOR_COND (stmt) = cond;
5915	OMP_FOR_INCR (stmt) = incr;
5916	if (orig_decls)
5917	OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
5918	OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular;
5919	gfc_add_expr_to_block (&block, stmt);
5920
5921	vec_free (v&: doacross_steps);
5922	doacross_steps = saved_doacross_steps;
5923
5924	return gfc_finish_block (&block);
5925	}
5926
5927	/* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
5928	construct. */
5929
5930	static tree
5931	gfc_trans_oacc_combined_directive (gfc_code *code)
5932	{
5933	stmtblock_t block, *pblock = NULL;
5934	gfc_omp_clauses construct_clauses, loop_clauses;
5935	tree stmt, oacc_clauses = NULL_TREE;
5936	enum tree_code construct_code;
5937	location_t loc = input_location;
5938
5939	switch (code->op)
5940	{
5941	case EXEC_OACC_PARALLEL_LOOP:
5942	construct_code = OACC_PARALLEL;
5943	break;
5944	case EXEC_OACC_KERNELS_LOOP:
5945	construct_code = OACC_KERNELS;
5946	break;
5947	case EXEC_OACC_SERIAL_LOOP:
5948	construct_code = OACC_SERIAL;
5949	break;
5950	default:
5951	gcc_unreachable ();
5952	}
5953
5954	gfc_start_block (&block);
5955
5956	memset (s: &loop_clauses, c: 0, n: sizeof (loop_clauses));
5957	if (code->ext.omp_clauses != NULL)
5958	{
5959	memcpy (dest: &construct_clauses, src: code->ext.omp_clauses,
5960	n: sizeof (construct_clauses));
5961	loop_clauses.collapse = construct_clauses.collapse;
5962	loop_clauses.gang = construct_clauses.gang;
5963	loop_clauses.gang_static = construct_clauses.gang_static;
5964	loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
5965	loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
5966	loop_clauses.vector = construct_clauses.vector;
5967	loop_clauses.vector_expr = construct_clauses.vector_expr;
5968	loop_clauses.worker = construct_clauses.worker;
5969	loop_clauses.worker_expr = construct_clauses.worker_expr;
5970	loop_clauses.seq = construct_clauses.seq;
5971	loop_clauses.par_auto = construct_clauses.par_auto;
5972	loop_clauses.independent = construct_clauses.independent;
5973	loop_clauses.tile_list = construct_clauses.tile_list;
5974	loop_clauses.lists[OMP_LIST_PRIVATE]
5975	= construct_clauses.lists[OMP_LIST_PRIVATE];
5976	loop_clauses.lists[OMP_LIST_REDUCTION]
5977	= construct_clauses.lists[OMP_LIST_REDUCTION];
5978	construct_clauses.gang = false;
5979	construct_clauses.gang_static = false;
5980	construct_clauses.gang_num_expr = NULL;
5981	construct_clauses.gang_static_expr = NULL;
5982	construct_clauses.vector = false;
5983	construct_clauses.vector_expr = NULL;
5984	construct_clauses.worker = false;
5985	construct_clauses.worker_expr = NULL;
5986	construct_clauses.seq = false;
5987	construct_clauses.par_auto = false;
5988	construct_clauses.independent = false;
5989	construct_clauses.independent = false;
5990	construct_clauses.tile_list = NULL;
5991	construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
5992	if (construct_code == OACC_KERNELS)
5993	construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
5994	oacc_clauses = gfc_trans_omp_clauses (block: &block, clauses: &construct_clauses,
5995	where: code->loc, declare_simd: false, openacc: true);
5996	}
5997	if (!loop_clauses.seq)
5998	pblock = &block;
5999	else
6000	pushlevel ();
6001	stmt = gfc_trans_omp_do (code, op: EXEC_OACC_LOOP, pblock, do_clauses: &loop_clauses, NULL);
6002	protected_set_expr_location (stmt, loc);
6003	if (TREE_CODE (stmt) != BIND_EXPR)
6004	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6005	else
6006	poplevel (0, 0);
6007	stmt = build2_loc (loc, code: construct_code, void_type_node, arg0: stmt, arg1: oacc_clauses);
6008	gfc_add_expr_to_block (&block, stmt);
6009	return gfc_finish_block (&block);
6010	}
6011
6012	static tree
6013	gfc_trans_omp_depobj (gfc_code *code)
6014	{
6015	stmtblock_t block;
6016	gfc_se se;
6017	gfc_init_se (&se, NULL);
6018	gfc_init_block (&block);
6019	gfc_conv_expr (se: &se, expr: code->ext.omp_clauses->depobj);
6020	gcc_assert (se.pre.head == NULL && se.post.head == NULL);
6021	tree depobj = se.expr;
6022	location_t loc = EXPR_LOCATION (depobj);
6023	if (!POINTER_TYPE_P (TREE_TYPE (depobj)))
6024	depobj = gfc_build_addr_expr (NULL, depobj);
6025	depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node,
6026	TYPE_MODE (ptr_type_node),
6027	true), depobj);
6028	gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND];
6029	if (n)
6030	{
6031	tree var;
6032	if (!n->sym) /* omp_all_memory. */
6033	var = null_pointer_node;
6034	else if (n->expr && n->expr->ref->u.ar.type != AR_FULL)
6035	{
6036	gfc_init_se (&se, NULL);
6037	if (n->expr->ref->u.ar.type == AR_ELEMENT)
6038	{
6039	gfc_conv_expr_reference (se: &se, expr: n->expr);
6040	var = se.expr;
6041	}
6042	else
6043	{
6044	gfc_conv_expr_descriptor (&se, n->expr);
6045	var = gfc_conv_array_data (se.expr);
6046	}
6047	gfc_add_block_to_block (&block, &se.pre);
6048	gfc_add_block_to_block (&block, &se.post);
6049	gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
6050	}
6051	else
6052	{
6053	var = gfc_get_symbol_decl (n->sym);
6054	if (POINTER_TYPE_P (TREE_TYPE (var))
6055	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var))))
6056	var = build_fold_indirect_ref (var);
6057	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var)))
6058	{
6059	var = gfc_conv_descriptor_data_get (var);
6060	gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
6061	}
6062	else if ((n->sym->attr.allocatable || n->sym->attr.pointer)
6063	&& n->sym->attr.dummy)
6064	var = build_fold_indirect_ref (var);
6065	else if (!POINTER_TYPE_P (TREE_TYPE (var))
6066	|| (n->sym->ts.f90_type == BT_VOID
6067	&& !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var)))
6068	&& !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var)))))
6069	{
6070	TREE_ADDRESSABLE (var) = 1;
6071	var = gfc_build_addr_expr (NULL, var);
6072	}
6073	}
6074	depobj = save_expr (depobj);
6075	tree r = build_fold_indirect_ref_loc (loc, depobj);
6076	gfc_add_expr_to_block (&block,
6077	build2 (MODIFY_EXPR, void_type_node, r, var));
6078	}
6079
6080	/* Only one may be set. */
6081	gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy)
6082	+ (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET))
6083	== 1);
6084	int k = -1; /* omp_clauses->destroy */
6085	if (!code->ext.omp_clauses->destroy)
6086	switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET
6087	? code->ext.omp_clauses->depobj_update : n->u.depend_doacross_op)
6088	{
6089	case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break;
6090	case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break;
6091	case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break;
6092	case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break;
6093	case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break;
6094	default: gcc_unreachable ();
6095	}
6096	tree t = build_int_cst (ptr_type_node, k);
6097	depobj = build2_loc (loc, code: POINTER_PLUS_EXPR, TREE_TYPE (depobj), arg0: depobj,
6098	TYPE_SIZE_UNIT (ptr_type_node));
6099	depobj = build_fold_indirect_ref_loc (loc, depobj);
6100	gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t));
6101
6102	return gfc_finish_block (&block);
6103	}
6104
6105	static tree
6106	gfc_trans_omp_error (gfc_code *code)
6107	{
6108	stmtblock_t block;
6109	gfc_se se;
6110	tree len, message;
6111	bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
6112	tree fndecl = builtin_decl_explicit (fncode: fatal ? BUILT_IN_GOMP_ERROR
6113	: BUILT_IN_GOMP_WARNING);
6114	gfc_start_block (&block);
6115	gfc_init_se (&se, NULL );
6116	if (!code->ext.omp_clauses->message)
6117	{
6118	message = null_pointer_node;
6119	len = build_int_cst (size_type_node, 0);
6120	}
6121	else
6122	{
6123	gfc_conv_expr (se: &se, expr: code->ext.omp_clauses->message);
6124	message = se.expr;
6125	if (!POINTER_TYPE_P (TREE_TYPE (message)))
6126	/* To ensure an ARRAY_TYPE is not passed as such. */
6127	message = gfc_build_addr_expr (NULL, message);
6128	len = se.string_length;
6129	}
6130	gfc_add_block_to_block (&block, &se.pre);
6131	gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
6132	2, message, len));
6133	gfc_add_block_to_block (&block, &se.post);
6134	return gfc_finish_block (&block);
6135	}
6136
6137	static tree
6138	gfc_trans_omp_flush (gfc_code *code)
6139	{
6140	tree call;
6141	if (!code->ext.omp_clauses
6142	|| code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET
6143	|| code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST)
6144	{
6145	call = builtin_decl_explicit (fncode: BUILT_IN_SYNC_SYNCHRONIZE);
6146	call = build_call_expr_loc (input_location, call, 0);
6147	}
6148	else
6149	{
6150	enum memmodel mo = MEMMODEL_LAST;
6151	switch (code->ext.omp_clauses->memorder)
6152	{
6153	case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break;
6154	case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break;
6155	case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break;
6156	default: gcc_unreachable (); break;
6157	}
6158	call = builtin_decl_explicit (fncode: BUILT_IN_ATOMIC_THREAD_FENCE);
6159	call = build_call_expr_loc (input_location, call, 1,
6160	build_int_cst (integer_type_node, mo));
6161	}
6162	return call;
6163	}
6164
6165	static tree
6166	gfc_trans_omp_master (gfc_code *code)
6167	{
6168	tree stmt = gfc_trans_code (code->block->next);
6169	if (IS_EMPTY_STMT (stmt))
6170	return stmt;
6171	return build1_v (OMP_MASTER, stmt);
6172	}
6173
6174	static tree
6175	gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses)
6176	{
6177	stmtblock_t block;
6178	tree body = gfc_trans_code (code->block->next);
6179	if (IS_EMPTY_STMT (body))
6180	return body;
6181	if (!clauses)
6182	clauses = code->ext.omp_clauses;
6183	gfc_start_block (&block);
6184	tree omp_clauses = gfc_trans_omp_clauses (block: &block, clauses, where: code->loc);
6185	tree stmt = make_node (OMP_MASKED);
6186	SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
6187	TREE_TYPE (stmt) = void_type_node;
6188	OMP_MASKED_BODY (stmt) = body;
6189	OMP_MASKED_CLAUSES (stmt) = omp_clauses;
6190	gfc_add_expr_to_block (&block, stmt);
6191	return gfc_finish_block (&block);
6192	}
6193
6194
6195	static tree
6196	gfc_trans_omp_ordered (gfc_code *code)
6197	{
6198	if (!flag_openmp)
6199	{
6200	if (!code->ext.omp_clauses->simd)
6201	return gfc_trans_code (code->block ? code->block->next : NULL);
6202	code->ext.omp_clauses->threads = 0;
6203	}
6204	tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses: code->ext.omp_clauses,
6205	where: code->loc);
6206	return build2_loc (loc: input_location, code: OMP_ORDERED, void_type_node,
6207	arg0: code->block ? gfc_trans_code (code->block->next)
6208	: NULL_TREE, arg1: omp_clauses);
6209	}
6210
6211	static tree
6212	gfc_trans_omp_parallel (gfc_code *code)
6213	{
6214	stmtblock_t block;
6215	tree stmt, omp_clauses;
6216
6217	gfc_start_block (&block);
6218	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
6219	where: code->loc);
6220	pushlevel ();
6221	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
6222	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6223	stmt = build2_loc (loc: input_location, code: OMP_PARALLEL, void_type_node, arg0: stmt,
6224	arg1: omp_clauses);
6225	gfc_add_expr_to_block (&block, stmt);
6226	return gfc_finish_block (&block);
6227	}
6228
6229	enum
6230	{
6231	GFC_OMP_SPLIT_SIMD,
6232	GFC_OMP_SPLIT_DO,
6233	GFC_OMP_SPLIT_PARALLEL,
6234	GFC_OMP_SPLIT_DISTRIBUTE,
6235	GFC_OMP_SPLIT_TEAMS,
6236	GFC_OMP_SPLIT_TARGET,
6237	GFC_OMP_SPLIT_TASKLOOP,
6238	GFC_OMP_SPLIT_MASKED,
6239	GFC_OMP_SPLIT_NUM
6240	};
6241
6242	enum
6243	{
6244	GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
6245	GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
6246	GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
6247	GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
6248	GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
6249	GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET),
6250	GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP),
6251	GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED)
6252	};
6253
6254	/* If a var is in lastprivate/firstprivate/reduction but not in a
6255	data mapping/sharing clause, add it to 'map(tofrom:' if is_target
6256	and to 'shared' otherwise. */
6257	static void
6258	gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out,
6259	gfc_omp_clauses *clauses_in,
6260	bool is_target, bool is_parallel_do)
6261	{
6262	int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED;
6263	gfc_omp_namelist *tail = NULL;
6264	for (int i = 0; i < 5; ++i)
6265	{
6266	gfc_omp_namelist *n;
6267	switch (i)
6268	{
6269	case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break;
6270	case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break;
6271	case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break;
6272	case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break;
6273	case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break;
6274	default: gcc_unreachable ();
6275	}
6276	for (; n != NULL; n = n->next)
6277	{
6278	gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL;
6279	for (int j = 0; j < 6; ++j)
6280	{
6281	gfc_omp_namelist **n2ref = NULL, *prev2 = NULL;
6282	switch (j)
6283	{
6284	case 0:
6285	n2ref = &clauses_out->lists[clauselist_to_add];
6286	break;
6287	case 1:
6288	n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
6289	break;
6290	case 2:
6291	if (is_target)
6292	n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE];
6293	else
6294	n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE];
6295	break;
6296	case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break;
6297	case 4:
6298	n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN];
6299	break;
6300	case 5:
6301	n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK];
6302	break;
6303	default: gcc_unreachable ();
6304	}
6305	for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next)
6306	if (n2->sym == n->sym)
6307	break;
6308	if (n2)
6309	{
6310	if (j == 0 /* clauselist_to_add */)
6311	break; /* Already present. */
6312	if (j == 1 /* OMP_LIST_FIRSTPRIVATE */)
6313	{
6314	n_firstp = prev2 ? &prev2->next : n2ref;
6315	continue;
6316	}
6317	if (j == 2 /* OMP_LIST_LASTPRIVATE */)
6318	{
6319	n_lastp = prev2 ? &prev2->next : n2ref;
6320	continue;
6321	}
6322	break;
6323	}
6324	}
6325	if (n_firstp && n_lastp)
6326	{
6327	/* For parallel do, GCC puts firstprivate/lastprivate
6328	on the parallel. */
6329	if (is_parallel_do)
6330	continue;
6331	*n_firstp = (*n_firstp)->next;
6332	if (!is_target)
6333	*n_lastp = (*n_lastp)->next;
6334	}
6335	else if (is_target && n_lastp)
6336	;
6337	else if (n2 || n_firstp || n_lastp)
6338	continue;
6339	if (clauses_out->lists[clauselist_to_add]
6340	&& (clauses_out->lists[clauselist_to_add]
6341	== clauses_in->lists[clauselist_to_add]))
6342	{
6343	gfc_omp_namelist *p = NULL;
6344	for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next)
6345	{
6346	if (p)
6347	{
6348	p->next = gfc_get_omp_namelist ();
6349	p = p->next;
6350	}
6351	else
6352	{
6353	p = gfc_get_omp_namelist ();
6354	clauses_out->lists[clauselist_to_add] = p;
6355	}
6356	*p = *n2;
6357	}
6358	}
6359	if (!tail)
6360	{
6361	tail = clauses_out->lists[clauselist_to_add];
6362	for (; tail && tail->next; tail = tail->next)
6363	;
6364	}
6365	n2 = gfc_get_omp_namelist ();
6366	n2->where = n->where;
6367	n2->sym = n->sym;
6368	if (is_target)
6369	n2->u.map_op = OMP_MAP_TOFROM;
6370	if (tail)
6371	{
6372	tail->next = n2;
6373	tail = n2;
6374	}
6375	else
6376	clauses_out->lists[clauselist_to_add] = n2;
6377	}
6378	}
6379	}
6380
6381	/* Kind of opposite to above, add firstprivate to CLAUSES_OUT if it is mapped
6382	in CLAUSES_IN's FIRSTPRIVATE list but not its MAP list. */
6383
6384	static void
6385	gfc_add_firstprivate_if_unmapped (gfc_omp_clauses *clauses_out,
6386	gfc_omp_clauses *clauses_in)
6387	{
6388	gfc_omp_namelist *n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE];
6389	gfc_omp_namelist **tail = NULL;
6390
6391	for (; n != NULL; n = n->next)
6392	{
6393	gfc_omp_namelist *n2 = clauses_out->lists[OMP_LIST_MAP];
6394	for (; n2 != NULL; n2 = n2->next)
6395	if (n->sym == n2->sym)
6396	break;
6397	if (n2 == NULL)
6398	{
6399	gfc_omp_namelist *dup = gfc_get_omp_namelist ();
6400	*dup = *n;
6401	dup->next = NULL;
6402	if (!tail)
6403	{
6404	tail = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
6405	while (*tail && (*tail)->next)
6406	tail = &(*tail)->next;
6407	}
6408	*tail = dup;
6409	tail = &(*tail)->next;
6410	}
6411	}
6412	}
6413
6414	static void
6415	gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa)
6416	{
6417	for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i)
6418	for (int j = 0; j < OMP_LIST_NUM; ++j)
6419	if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j])
6420	for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;)
6421	{
6422	gfc_omp_namelist *p = n;
6423	n = n->next;
6424	free (ptr: p);
6425	}
6426	}
6427
6428	static void
6429	gfc_split_omp_clauses (gfc_code *code,
6430	gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
6431	{
6432	int mask = 0, innermost = 0;
6433	bool is_loop = false;
6434	memset (s: clausesa, c: 0, n: GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
6435	switch (code->op)
6436	{
6437	case EXEC_OMP_DISTRIBUTE:
6438	innermost = GFC_OMP_SPLIT_DISTRIBUTE;
6439	break;
6440	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6441	mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6442	innermost = GFC_OMP_SPLIT_DO;
6443	break;
6444	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6445	mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
6446	| GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6447	innermost = GFC_OMP_SPLIT_SIMD;
6448	break;
6449	case EXEC_OMP_DISTRIBUTE_SIMD:
6450	mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
6451	innermost = GFC_OMP_SPLIT_SIMD;
6452	break;
6453	case EXEC_OMP_DO:
6454	case EXEC_OMP_LOOP:
6455	innermost = GFC_OMP_SPLIT_DO;
6456	break;
6457	case EXEC_OMP_DO_SIMD:
6458	mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6459	innermost = GFC_OMP_SPLIT_SIMD;
6460	break;
6461	case EXEC_OMP_PARALLEL:
6462	innermost = GFC_OMP_SPLIT_PARALLEL;
6463	break;
6464	case EXEC_OMP_PARALLEL_DO:
6465	case EXEC_OMP_PARALLEL_LOOP:
6466	mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6467	innermost = GFC_OMP_SPLIT_DO;
6468	break;
6469	case EXEC_OMP_PARALLEL_DO_SIMD:
6470	mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6471	innermost = GFC_OMP_SPLIT_SIMD;
6472	break;
6473	case EXEC_OMP_PARALLEL_MASKED:
6474	mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED;
6475	innermost = GFC_OMP_SPLIT_MASKED;
6476	break;
6477	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
6478	mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
6479	| GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
6480	innermost = GFC_OMP_SPLIT_TASKLOOP;
6481	break;
6482	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
6483	mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6484	innermost = GFC_OMP_SPLIT_TASKLOOP;
6485	break;
6486	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
6487	mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
6488	| GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
6489	innermost = GFC_OMP_SPLIT_SIMD;
6490	break;
6491	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
6492	mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6493	innermost = GFC_OMP_SPLIT_SIMD;
6494	break;
6495	case EXEC_OMP_SIMD:
6496	innermost = GFC_OMP_SPLIT_SIMD;
6497	break;
6498	case EXEC_OMP_TARGET:
6499	innermost = GFC_OMP_SPLIT_TARGET;
6500	break;
6501	case EXEC_OMP_TARGET_PARALLEL:
6502	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
6503	innermost = GFC_OMP_SPLIT_PARALLEL;
6504	break;
6505	case EXEC_OMP_TARGET_PARALLEL_DO:
6506	case EXEC_OMP_TARGET_PARALLEL_LOOP:
6507	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6508	innermost = GFC_OMP_SPLIT_DO;
6509	break;
6510	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6511	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
6512	| GFC_OMP_MASK_SIMD;
6513	innermost = GFC_OMP_SPLIT_SIMD;
6514	break;
6515	case EXEC_OMP_TARGET_SIMD:
6516	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
6517	innermost = GFC_OMP_SPLIT_SIMD;
6518	break;
6519	case EXEC_OMP_TARGET_TEAMS:
6520	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
6521	innermost = GFC_OMP_SPLIT_TEAMS;
6522	break;
6523	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6524	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
6525	| GFC_OMP_MASK_DISTRIBUTE;
6526	innermost = GFC_OMP_SPLIT_DISTRIBUTE;
6527	break;
6528	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6529	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6530	| GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6531	innermost = GFC_OMP_SPLIT_DO;
6532	break;
6533	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6534	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6535	| GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6536	innermost = GFC_OMP_SPLIT_SIMD;
6537	break;
6538	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6539	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
6540	| GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
6541	innermost = GFC_OMP_SPLIT_SIMD;
6542	break;
6543	case EXEC_OMP_TARGET_TEAMS_LOOP:
6544	mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
6545	innermost = GFC_OMP_SPLIT_DO;
6546	break;
6547	case EXEC_OMP_MASKED_TASKLOOP:
6548	mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP;
6549	innermost = GFC_OMP_SPLIT_TASKLOOP;
6550	break;
6551	case EXEC_OMP_MASTER_TASKLOOP:
6552	case EXEC_OMP_TASKLOOP:
6553	innermost = GFC_OMP_SPLIT_TASKLOOP;
6554	break;
6555	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
6556	mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6557	innermost = GFC_OMP_SPLIT_SIMD;
6558	break;
6559	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
6560	case EXEC_OMP_TASKLOOP_SIMD:
6561	mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
6562	innermost = GFC_OMP_SPLIT_SIMD;
6563	break;
6564	case EXEC_OMP_TEAMS:
6565	innermost = GFC_OMP_SPLIT_TEAMS;
6566	break;
6567	case EXEC_OMP_TEAMS_DISTRIBUTE:
6568	mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
6569	innermost = GFC_OMP_SPLIT_DISTRIBUTE;
6570	break;
6571	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6572	mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6573	| GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
6574	innermost = GFC_OMP_SPLIT_DO;
6575	break;
6576	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6577	mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
6578	| GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
6579	innermost = GFC_OMP_SPLIT_SIMD;
6580	break;
6581	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6582	mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
6583	innermost = GFC_OMP_SPLIT_SIMD;
6584	break;
6585	case EXEC_OMP_TEAMS_LOOP:
6586	mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
6587	innermost = GFC_OMP_SPLIT_DO;
6588	break;
6589	default:
6590	gcc_unreachable ();
6591	}
6592	if (mask == 0)
6593	{
6594	clausesa[innermost] = *code->ext.omp_clauses;
6595	return;
6596	}
6597	/* Loops are similar to DO but still a bit different. */
6598	switch (code->op)
6599	{
6600	case EXEC_OMP_LOOP:
6601	case EXEC_OMP_PARALLEL_LOOP:
6602	case EXEC_OMP_TEAMS_LOOP:
6603	case EXEC_OMP_TARGET_PARALLEL_LOOP:
6604	case EXEC_OMP_TARGET_TEAMS_LOOP:
6605	is_loop = true;
6606	default:
6607	break;
6608	}
6609	if (code->ext.omp_clauses != NULL)
6610	{
6611	if (mask & GFC_OMP_MASK_TARGET)
6612	{
6613	/* First the clauses that are unique to some constructs. */
6614	clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
6615	= code->ext.omp_clauses->lists[OMP_LIST_MAP];
6616	clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR]
6617	= code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
6618	clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_HAS_DEVICE_ADDR]
6619	= code->ext.omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
6620	clausesa[GFC_OMP_SPLIT_TARGET].device
6621	= code->ext.omp_clauses->device;
6622	clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
6623	= code->ext.omp_clauses->thread_limit;
6624	clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS]
6625	= code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS];
6626	for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
6627	clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
6628	= code->ext.omp_clauses->defaultmap[i];
6629	clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
6630	= code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
6631	/* And this is copied to all. */
6632	clausesa[GFC_OMP_SPLIT_TARGET].if_expr
6633	= code->ext.omp_clauses->if_expr;
6634	clausesa[GFC_OMP_SPLIT_TARGET].self_expr
6635	= code->ext.omp_clauses->self_expr;
6636	clausesa[GFC_OMP_SPLIT_TARGET].nowait
6637	= code->ext.omp_clauses->nowait;
6638	}
6639	if (mask & GFC_OMP_MASK_TEAMS)
6640	{
6641	/* First the clauses that are unique to some constructs. */
6642	clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
6643	= code->ext.omp_clauses->num_teams_lower;
6644	clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
6645	= code->ext.omp_clauses->num_teams_upper;
6646	clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
6647	= code->ext.omp_clauses->thread_limit;
6648	/* Shared and default clauses are allowed on parallel, teams
6649	and taskloop. */
6650	clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
6651	= code->ext.omp_clauses->lists[OMP_LIST_SHARED];
6652	clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
6653	= code->ext.omp_clauses->default_sharing;
6654	}
6655	if (mask & GFC_OMP_MASK_DISTRIBUTE)
6656	{
6657	/* First the clauses that are unique to some constructs. */
6658	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
6659	= code->ext.omp_clauses->dist_sched_kind;
6660	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
6661	= code->ext.omp_clauses->dist_chunk_size;
6662	/* Duplicate collapse. */
6663	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
6664	= code->ext.omp_clauses->collapse;
6665	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent
6666	= code->ext.omp_clauses->order_concurrent;
6667	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained
6668	= code->ext.omp_clauses->order_unconstrained;
6669	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible
6670	= code->ext.omp_clauses->order_reproducible;
6671	}
6672	if (mask & GFC_OMP_MASK_PARALLEL)
6673	{
6674	/* First the clauses that are unique to some constructs. */
6675	clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
6676	= code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
6677	clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
6678	= code->ext.omp_clauses->num_threads;
6679	clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
6680	= code->ext.omp_clauses->proc_bind;
6681	/* Shared and default clauses are allowed on parallel, teams
6682	and taskloop. */
6683	clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
6684	= code->ext.omp_clauses->lists[OMP_LIST_SHARED];
6685	clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
6686	= code->ext.omp_clauses->default_sharing;
6687	clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
6688	= code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
6689	/* And this is copied to all. */
6690	clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
6691	= code->ext.omp_clauses->if_expr;
6692	}
6693	if (mask & GFC_OMP_MASK_MASKED)
6694	clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter;
6695	if ((mask & GFC_OMP_MASK_DO) && !is_loop)
6696	{
6697	/* First the clauses that are unique to some constructs. */
6698	clausesa[GFC_OMP_SPLIT_DO].ordered
6699	= code->ext.omp_clauses->ordered;
6700	clausesa[GFC_OMP_SPLIT_DO].orderedc
6701	= code->ext.omp_clauses->orderedc;
6702	clausesa[GFC_OMP_SPLIT_DO].sched_kind
6703	= code->ext.omp_clauses->sched_kind;
6704	if (innermost == GFC_OMP_SPLIT_SIMD)
6705	clausesa[GFC_OMP_SPLIT_DO].sched_simd
6706	= code->ext.omp_clauses->sched_simd;
6707	clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
6708	= code->ext.omp_clauses->sched_monotonic;
6709	clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
6710	= code->ext.omp_clauses->sched_nonmonotonic;
6711	clausesa[GFC_OMP_SPLIT_DO].chunk_size
6712	= code->ext.omp_clauses->chunk_size;
6713	clausesa[GFC_OMP_SPLIT_DO].nowait
6714	= code->ext.omp_clauses->nowait;
6715	}
6716	if (mask & GFC_OMP_MASK_DO)
6717	{
6718	clausesa[GFC_OMP_SPLIT_DO].bind
6719	= code->ext.omp_clauses->bind;
6720	/* Duplicate collapse. */
6721	clausesa[GFC_OMP_SPLIT_DO].collapse
6722	= code->ext.omp_clauses->collapse;
6723	clausesa[GFC_OMP_SPLIT_DO].order_concurrent
6724	= code->ext.omp_clauses->order_concurrent;
6725	clausesa[GFC_OMP_SPLIT_DO].order_unconstrained
6726	= code->ext.omp_clauses->order_unconstrained;
6727	clausesa[GFC_OMP_SPLIT_DO].order_reproducible
6728	= code->ext.omp_clauses->order_reproducible;
6729	}
6730	if (mask & GFC_OMP_MASK_SIMD)
6731	{
6732	clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
6733	= code->ext.omp_clauses->safelen_expr;
6734	clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
6735	= code->ext.omp_clauses->simdlen_expr;
6736	clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
6737	= code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
6738	/* Duplicate collapse. */
6739	clausesa[GFC_OMP_SPLIT_SIMD].collapse
6740	= code->ext.omp_clauses->collapse;
6741	clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD]
6742	= code->ext.omp_clauses->if_exprs[OMP_IF_SIMD];
6743	clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent
6744	= code->ext.omp_clauses->order_concurrent;
6745	clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained
6746	= code->ext.omp_clauses->order_unconstrained;
6747	clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible
6748	= code->ext.omp_clauses->order_reproducible;
6749	/* And this is copied to all. */
6750	clausesa[GFC_OMP_SPLIT_SIMD].if_expr
6751	= code->ext.omp_clauses->if_expr;
6752	}
6753	if (mask & GFC_OMP_MASK_TASKLOOP)
6754	{
6755	/* First the clauses that are unique to some constructs. */
6756	clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
6757	= code->ext.omp_clauses->nogroup;
6758	clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
6759	= code->ext.omp_clauses->grainsize;
6760	clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict
6761	= code->ext.omp_clauses->grainsize_strict;
6762	clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
6763	= code->ext.omp_clauses->num_tasks;
6764	clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict
6765	= code->ext.omp_clauses->num_tasks_strict;
6766	clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
6767	= code->ext.omp_clauses->priority;
6768	clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
6769	= code->ext.omp_clauses->final_expr;
6770	clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
6771	= code->ext.omp_clauses->untied;
6772	clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
6773	= code->ext.omp_clauses->mergeable;
6774	clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
6775	= code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
6776	/* And this is copied to all. */
6777	clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
6778	= code->ext.omp_clauses->if_expr;
6779	/* Shared and default clauses are allowed on parallel, teams
6780	and taskloop. */
6781	clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
6782	= code->ext.omp_clauses->lists[OMP_LIST_SHARED];
6783	clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
6784	= code->ext.omp_clauses->default_sharing;
6785	/* Duplicate collapse. */
6786	clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
6787	= code->ext.omp_clauses->collapse;
6788	}
6789	/* Private clause is supported on all constructs but master/masked,
6790	it is enough to put it on the innermost one except for master/masked. For
6791	!$ omp parallel do put it on parallel though,
6792	as that's what we did for OpenMP 3.1. */
6793	clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop)
6794	|| code->op == EXEC_OMP_PARALLEL_MASTER
6795	|| code->op == EXEC_OMP_PARALLEL_MASKED)
6796	? (int) GFC_OMP_SPLIT_PARALLEL
6797	: innermost].lists[OMP_LIST_PRIVATE]
6798	= code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
6799	/* Firstprivate clause is supported on all constructs but
6800	simd and masked/master. Put it on the outermost of those and duplicate
6801	on parallel and teams. */
6802	if (mask & GFC_OMP_MASK_TARGET)
6803	gfc_add_firstprivate_if_unmapped (clauses_out: &clausesa[GFC_OMP_SPLIT_TARGET],
6804	clauses_in: code->ext.omp_clauses);
6805	if (mask & GFC_OMP_MASK_TEAMS)
6806	clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
6807	= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
6808	else if (mask & GFC_OMP_MASK_DISTRIBUTE)
6809	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
6810	= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
6811	if (mask & GFC_OMP_MASK_TASKLOOP)
6812	clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE]
6813	= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
6814	if ((mask & GFC_OMP_MASK_PARALLEL)
6815	&& !(mask & GFC_OMP_MASK_TASKLOOP))
6816	clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
6817	= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
6818	else if ((mask & GFC_OMP_MASK_DO) && !is_loop)
6819	clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
6820	= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
6821	/* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
6822	In parallel do{, simd} we actually want to put it on
6823	parallel rather than do. */
6824	if (mask & GFC_OMP_MASK_DISTRIBUTE)
6825	clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
6826	= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
6827	if (mask & GFC_OMP_MASK_TASKLOOP)
6828	clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE]
6829	= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
6830	if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop
6831	&& !(mask & GFC_OMP_MASK_TASKLOOP))
6832	clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
6833	= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
6834	else if (mask & GFC_OMP_MASK_DO)
6835	clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
6836	= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
6837	if (mask & GFC_OMP_MASK_SIMD)
6838	clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
6839	= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
6840	/* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop.
6841	Duplicate it on all of them, but
6842	- omit on do if parallel is present;
6843	- omit on task and parallel if loop is present;
6844	additionally, inscan applies to do/simd only. */
6845	for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++)
6846	{
6847	if (mask & GFC_OMP_MASK_TASKLOOP
6848	&& i != OMP_LIST_REDUCTION_INSCAN)
6849	clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i]
6850	= code->ext.omp_clauses->lists[i];
6851	if (mask & GFC_OMP_MASK_TEAMS
6852	&& i != OMP_LIST_REDUCTION_INSCAN
6853	&& !is_loop)
6854	clausesa[GFC_OMP_SPLIT_TEAMS].lists[i]
6855	= code->ext.omp_clauses->lists[i];
6856	if (mask & GFC_OMP_MASK_PARALLEL
6857	&& i != OMP_LIST_REDUCTION_INSCAN
6858	&& !(mask & GFC_OMP_MASK_TASKLOOP)
6859	&& !is_loop)
6860	clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
6861	= code->ext.omp_clauses->lists[i];
6862	else if (mask & GFC_OMP_MASK_DO)
6863	clausesa[GFC_OMP_SPLIT_DO].lists[i]
6864	= code->ext.omp_clauses->lists[i];
6865	if (mask & GFC_OMP_MASK_SIMD)
6866	clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
6867	= code->ext.omp_clauses->lists[i];
6868	}
6869	if (mask & GFC_OMP_MASK_TARGET)
6870	clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION]
6871	= code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
6872	if (mask & GFC_OMP_MASK_TASKLOOP)
6873	clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION]
6874	= code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
6875	/* Linear clause is supported on do and simd,
6876	put it on the innermost one. */
6877	clausesa[innermost].lists[OMP_LIST_LINEAR]
6878	= code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
6879	}
6880	/* Propagate firstprivate/lastprivate/reduction vars to
6881	shared (parallel, teams) and map-tofrom (target). */
6882	if (mask & GFC_OMP_MASK_TARGET)
6883	gfc_add_clause_implicitly (clauses_out: &clausesa[GFC_OMP_SPLIT_TARGET],
6884	clauses_in: code->ext.omp_clauses, is_target: true, is_parallel_do: false);
6885	if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL)
6886	gfc_add_clause_implicitly (clauses_out: &clausesa[GFC_OMP_SPLIT_PARALLEL],
6887	clauses_in: code->ext.omp_clauses, is_target: false,
6888	is_parallel_do: mask & GFC_OMP_MASK_DO);
6889	if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS)
6890	gfc_add_clause_implicitly (clauses_out: &clausesa[GFC_OMP_SPLIT_TEAMS],
6891	clauses_in: code->ext.omp_clauses, is_target: false, is_parallel_do: false);
6892	if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
6893	== (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
6894	&& !is_loop)
6895	clausesa[GFC_OMP_SPLIT_DO].nowait = true;
6896
6897	/* Distribute allocate clause to do, parallel, distribute, teams, target
6898	and taskloop. The code below iterates over variables in the
6899	allocate list and checks if that available is also in any
6900	privatization clause on those construct. If yes, then we add it
6901	to the list of 'allocate'ed variables for that construct. If a
6902	variable is found in none of them then we issue an error. */
6903
6904	if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE])
6905	{
6906	gfc_omp_namelist *alloc_nl, *priv_nl;
6907	gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM];
6908	for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
6909	alloc_nl; alloc_nl = alloc_nl->next)
6910	{
6911	bool found = false;
6912	for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++)
6913	{
6914	gfc_omp_namelist *p;
6915	int list;
6916	for (list = 0; list < OMP_LIST_NUM; list++)
6917	{
6918	switch (list)
6919	{
6920	case OMP_LIST_PRIVATE:
6921	case OMP_LIST_FIRSTPRIVATE:
6922	case OMP_LIST_LASTPRIVATE:
6923	case OMP_LIST_REDUCTION:
6924	case OMP_LIST_REDUCTION_INSCAN:
6925	case OMP_LIST_REDUCTION_TASK:
6926	case OMP_LIST_IN_REDUCTION:
6927	case OMP_LIST_TASK_REDUCTION:
6928	case OMP_LIST_LINEAR:
6929	for (priv_nl = clausesa[i].lists[list]; priv_nl;
6930	priv_nl = priv_nl->next)
6931	if (alloc_nl->sym == priv_nl->sym)
6932	{
6933	found = true;
6934	p = gfc_get_omp_namelist ();
6935	p->sym = alloc_nl->sym;
6936	p->expr = alloc_nl->expr;
6937	p->u.align = alloc_nl->u.align;
6938	p->u2.allocator = alloc_nl->u2.allocator;
6939	p->where = alloc_nl->where;
6940	if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
6941	{
6942	clausesa[i].lists[OMP_LIST_ALLOCATE] = p;
6943	tails[i] = p;
6944	}
6945	else
6946	{
6947	tails[i]->next = p;
6948	tails[i] = tails[i]->next;
6949	}
6950	}
6951	break;
6952	default:
6953	break;
6954	}
6955	}
6956	}
6957	if (!found)
6958	gfc_error ("%qs specified in 'allocate' clause at %L but not "
6959	"in an explicit privatization clause",
6960	alloc_nl->sym->name, &alloc_nl->where);
6961	}
6962	}
6963	}
6964
6965	static tree
6966	gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
6967	gfc_omp_clauses *clausesa, tree omp_clauses)
6968	{
6969	stmtblock_t block;
6970	gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
6971	tree stmt, body, omp_do_clauses = NULL_TREE;
6972	bool free_clausesa = false;
6973
6974	if (pblock == NULL)
6975	gfc_start_block (&block);
6976	else
6977	gfc_init_block (&block);
6978
6979	if (clausesa == NULL)
6980	{
6981	clausesa = clausesa_buf;
6982	gfc_split_omp_clauses (code, clausesa);
6983	free_clausesa = true;
6984	}
6985	if (flag_openmp)
6986	omp_do_clauses
6987	= gfc_trans_omp_clauses (block: &block, clauses: &clausesa[GFC_OMP_SPLIT_DO], where: code->loc);
6988	body = gfc_trans_omp_do (code, op: EXEC_OMP_SIMD, pblock: pblock ? pblock : &block,
6989	do_clauses: &clausesa[GFC_OMP_SPLIT_SIMD], par_clauses: omp_clauses);
6990	if (pblock == NULL)
6991	{
6992	if (TREE_CODE (body) != BIND_EXPR)
6993	body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
6994	else
6995	poplevel (0, 0);
6996	}
6997	else if (TREE_CODE (body) != BIND_EXPR)
6998	body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
6999	if (flag_openmp)
7000	{
7001	stmt = make_node (OMP_FOR);
7002	SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7003	TREE_TYPE (stmt) = void_type_node;
7004	OMP_FOR_BODY (stmt) = body;
7005	OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
7006	}
7007	else
7008	stmt = body;
7009	gfc_add_expr_to_block (&block, stmt);
7010	if (free_clausesa)
7011	gfc_free_split_omp_clauses (code, clausesa);
7012	return gfc_finish_block (&block);
7013	}
7014
7015	static tree
7016	gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock,
7017	gfc_omp_clauses *clausesa)
7018	{
7019	stmtblock_t block, *new_pblock = pblock;
7020	gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7021	tree stmt, omp_clauses = NULL_TREE;
7022	bool free_clausesa = false;
7023
7024	if (pblock == NULL)
7025	gfc_start_block (&block);
7026	else
7027	gfc_init_block (&block);
7028
7029	if (clausesa == NULL)
7030	{
7031	clausesa = clausesa_buf;
7032	gfc_split_omp_clauses (code, clausesa);
7033	free_clausesa = true;
7034	}
7035	omp_clauses
7036	= gfc_trans_omp_clauses (block: &block, clauses: &clausesa[GFC_OMP_SPLIT_PARALLEL],
7037	where: code->loc);
7038	if (pblock == NULL)
7039	{
7040	if (!clausesa[GFC_OMP_SPLIT_DO].ordered
7041	&& clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
7042	new_pblock = &block;
7043	else
7044	pushlevel ();
7045	}
7046	stmt = gfc_trans_omp_do (code, op: is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO,
7047	pblock: new_pblock, do_clauses: &clausesa[GFC_OMP_SPLIT_DO],
7048	par_clauses: omp_clauses);
7049	if (pblock == NULL)
7050	{
7051	if (TREE_CODE (stmt) != BIND_EXPR)
7052	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7053	else
7054	poplevel (0, 0);
7055	}
7056	else if (TREE_CODE (stmt) != BIND_EXPR)
7057	stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
7058	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_PARALLEL,
7059	void_type_node, arg0: stmt, arg1: omp_clauses);
7060	OMP_PARALLEL_COMBINED (stmt) = 1;
7061	gfc_add_expr_to_block (&block, stmt);
7062	if (free_clausesa)
7063	gfc_free_split_omp_clauses (code, clausesa);
7064	return gfc_finish_block (&block);
7065	}
7066
7067	static tree
7068	gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
7069	gfc_omp_clauses *clausesa)
7070	{
7071	stmtblock_t block;
7072	gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7073	tree stmt, omp_clauses = NULL_TREE;
7074	bool free_clausesa = false;
7075
7076	if (pblock == NULL)
7077	gfc_start_block (&block);
7078	else
7079	gfc_init_block (&block);
7080
7081	if (clausesa == NULL)
7082	{
7083	clausesa = clausesa_buf;
7084	gfc_split_omp_clauses (code, clausesa);
7085	free_clausesa = true;
7086	}
7087	if (flag_openmp)
7088	omp_clauses
7089	= gfc_trans_omp_clauses (block: &block, clauses: &clausesa[GFC_OMP_SPLIT_PARALLEL],
7090	where: code->loc);
7091	if (pblock == NULL)
7092	pushlevel ();
7093	stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
7094	if (pblock == NULL)
7095	{
7096	if (TREE_CODE (stmt) != BIND_EXPR)
7097	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7098	else
7099	poplevel (0, 0);
7100	}
7101	else if (TREE_CODE (stmt) != BIND_EXPR)
7102	stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
7103	if (flag_openmp)
7104	{
7105	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_PARALLEL,
7106	void_type_node, arg0: stmt, arg1: omp_clauses);
7107	OMP_PARALLEL_COMBINED (stmt) = 1;
7108	}
7109	gfc_add_expr_to_block (&block, stmt);
7110	if (free_clausesa)
7111	gfc_free_split_omp_clauses (code, clausesa);
7112	return gfc_finish_block (&block);
7113	}
7114
7115	static tree
7116	gfc_trans_omp_parallel_sections (gfc_code *code)
7117	{
7118	stmtblock_t block;
7119	gfc_omp_clauses section_clauses;
7120	tree stmt, omp_clauses;
7121
7122	memset (s: &section_clauses, c: 0, n: sizeof (section_clauses));
7123	section_clauses.nowait = true;
7124
7125	gfc_start_block (&block);
7126	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7127	where: code->loc);
7128	pushlevel ();
7129	stmt = gfc_trans_omp_sections (code, &section_clauses);
7130	if (TREE_CODE (stmt) != BIND_EXPR)
7131	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7132	else
7133	poplevel (0, 0);
7134	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_PARALLEL,
7135	void_type_node, arg0: stmt, arg1: omp_clauses);
7136	OMP_PARALLEL_COMBINED (stmt) = 1;
7137	gfc_add_expr_to_block (&block, stmt);
7138	return gfc_finish_block (&block);
7139	}
7140
7141	static tree
7142	gfc_trans_omp_parallel_workshare (gfc_code *code)
7143	{
7144	stmtblock_t block;
7145	gfc_omp_clauses workshare_clauses;
7146	tree stmt, omp_clauses;
7147
7148	memset (s: &workshare_clauses, c: 0, n: sizeof (workshare_clauses));
7149	workshare_clauses.nowait = true;
7150
7151	gfc_start_block (&block);
7152	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7153	where: code->loc);
7154	pushlevel ();
7155	stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
7156	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7157	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_PARALLEL,
7158	void_type_node, arg0: stmt, arg1: omp_clauses);
7159	OMP_PARALLEL_COMBINED (stmt) = 1;
7160	gfc_add_expr_to_block (&block, stmt);
7161	return gfc_finish_block (&block);
7162	}
7163
7164	static tree
7165	gfc_trans_omp_scope (gfc_code *code)
7166	{
7167	stmtblock_t block;
7168	tree body = gfc_trans_code (code->block->next);
7169	if (IS_EMPTY_STMT (body))
7170	return body;
7171	gfc_start_block (&block);
7172	tree omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7173	where: code->loc);
7174	tree stmt = make_node (OMP_SCOPE);
7175	SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7176	TREE_TYPE (stmt) = void_type_node;
7177	OMP_SCOPE_BODY (stmt) = body;
7178	OMP_SCOPE_CLAUSES (stmt) = omp_clauses;
7179	gfc_add_expr_to_block (&block, stmt);
7180	return gfc_finish_block (&block);
7181	}
7182
7183	static tree
7184	gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
7185	{
7186	stmtblock_t block, body;
7187	tree omp_clauses, stmt;
7188	bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
7189	location_t loc = gfc_get_location (&code->loc);
7190
7191	gfc_start_block (&block);
7192
7193	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses, where: code->loc);
7194
7195	gfc_init_block (&body);
7196	for (code = code->block; code; code = code->block)
7197	{
7198	/* Last section is special because of lastprivate, so even if it
7199	is empty, chain it in. */
7200	stmt = gfc_trans_omp_code (code: code->next,
7201	force_empty: has_lastprivate && code->block == NULL);
7202	if (! IS_EMPTY_STMT (stmt))
7203	{
7204	stmt = build1_v (OMP_SECTION, stmt);
7205	gfc_add_expr_to_block (&body, stmt);
7206	}
7207	}
7208	stmt = gfc_finish_block (&body);
7209
7210	stmt = build2_loc (loc, code: OMP_SECTIONS, void_type_node, arg0: stmt, arg1: omp_clauses);
7211	gfc_add_expr_to_block (&block, stmt);
7212
7213	return gfc_finish_block (&block);
7214	}
7215
7216	static tree
7217	gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
7218	{
7219	stmtblock_t block;
7220	gfc_start_block (&block);
7221	tree omp_clauses = gfc_trans_omp_clauses (block: &block, clauses, where: code->loc);
7222	tree stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7223	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_SINGLE, void_type_node,
7224	arg0: stmt, arg1: omp_clauses);
7225	gfc_add_expr_to_block (&block, stmt);
7226	return gfc_finish_block (&block);
7227	}
7228
7229	static tree
7230	gfc_trans_omp_task (gfc_code *code)
7231	{
7232	stmtblock_t block;
7233	tree stmt, omp_clauses;
7234
7235	gfc_start_block (&block);
7236	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7237	where: code->loc);
7238	pushlevel ();
7239	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7240	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7241	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_TASK, void_type_node,
7242	arg0: stmt, arg1: omp_clauses);
7243	gfc_add_expr_to_block (&block, stmt);
7244	return gfc_finish_block (&block);
7245	}
7246
7247	static tree
7248	gfc_trans_omp_taskgroup (gfc_code *code)
7249	{
7250	stmtblock_t block;
7251	gfc_start_block (&block);
7252	tree body = gfc_trans_code (code->block->next);
7253	tree stmt = make_node (OMP_TASKGROUP);
7254	SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7255	TREE_TYPE (stmt) = void_type_node;
7256	OMP_TASKGROUP_BODY (stmt) = body;
7257	OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (block: &block,
7258	clauses: code->ext.omp_clauses,
7259	where: code->loc);
7260	gfc_add_expr_to_block (&block, stmt);
7261	return gfc_finish_block (&block);
7262	}
7263
7264	static tree
7265	gfc_trans_omp_taskwait (gfc_code *code)
7266	{
7267	if (!code->ext.omp_clauses)
7268	{
7269	tree decl = builtin_decl_explicit (fncode: BUILT_IN_GOMP_TASKWAIT);
7270	return build_call_expr_loc (input_location, decl, 0);
7271	}
7272	stmtblock_t block;
7273	gfc_start_block (&block);
7274	tree stmt = make_node (OMP_TASK);
7275	SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7276	TREE_TYPE (stmt) = void_type_node;
7277	OMP_TASK_BODY (stmt) = NULL_TREE;
7278	OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (block: &block,
7279	clauses: code->ext.omp_clauses,
7280	where: code->loc);
7281	gfc_add_expr_to_block (&block, stmt);
7282	return gfc_finish_block (&block);
7283	}
7284
7285	static tree
7286	gfc_trans_omp_taskyield (void)
7287	{
7288	tree decl = builtin_decl_explicit (fncode: BUILT_IN_GOMP_TASKYIELD);
7289	return build_call_expr_loc (input_location, decl, 0);
7290	}
7291
7292	static tree
7293	gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
7294	{
7295	stmtblock_t block;
7296	gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7297	tree stmt, omp_clauses = NULL_TREE;
7298	bool free_clausesa = false;
7299
7300	gfc_start_block (&block);
7301	if (clausesa == NULL)
7302	{
7303	clausesa = clausesa_buf;
7304	gfc_split_omp_clauses (code, clausesa);
7305	free_clausesa = true;
7306	}
7307	if (flag_openmp)
7308	omp_clauses
7309	= gfc_trans_omp_clauses (block: &block, clauses: &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
7310	where: code->loc);
7311	switch (code->op)
7312	{
7313	case EXEC_OMP_DISTRIBUTE:
7314	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7315	case EXEC_OMP_TEAMS_DISTRIBUTE:
7316	/* This is handled in gfc_trans_omp_do. */
7317	gcc_unreachable ();
7318	break;
7319	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7320	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7321	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7322	stmt = gfc_trans_omp_parallel_do (code, is_loop: false, pblock: &block, clausesa);
7323	if (TREE_CODE (stmt) != BIND_EXPR)
7324	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7325	else
7326	poplevel (0, 0);
7327	break;
7328	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7329	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7330	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7331	stmt = gfc_trans_omp_parallel_do_simd (code, pblock: &block, clausesa);
7332	if (TREE_CODE (stmt) != BIND_EXPR)
7333	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7334	else
7335	poplevel (0, 0);
7336	break;
7337	case EXEC_OMP_DISTRIBUTE_SIMD:
7338	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7339	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7340	stmt = gfc_trans_omp_do (code, op: EXEC_OMP_SIMD, pblock: &block,
7341	do_clauses: &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
7342	if (TREE_CODE (stmt) != BIND_EXPR)
7343	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7344	else
7345	poplevel (0, 0);
7346	break;
7347	default:
7348	gcc_unreachable ();
7349	}
7350	if (flag_openmp)
7351	{
7352	tree distribute = make_node (OMP_DISTRIBUTE);
7353	SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc));
7354	TREE_TYPE (distribute) = void_type_node;
7355	OMP_FOR_BODY (distribute) = stmt;
7356	OMP_FOR_CLAUSES (distribute) = omp_clauses;
7357	stmt = distribute;
7358	}
7359	gfc_add_expr_to_block (&block, stmt);
7360	if (free_clausesa)
7361	gfc_free_split_omp_clauses (code, clausesa);
7362	return gfc_finish_block (&block);
7363	}
7364
7365	static tree
7366	gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
7367	tree omp_clauses)
7368	{
7369	stmtblock_t block;
7370	gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
7371	tree stmt;
7372	bool combined = true, free_clausesa = false;
7373
7374	gfc_start_block (&block);
7375	if (clausesa == NULL)
7376	{
7377	clausesa = clausesa_buf;
7378	gfc_split_omp_clauses (code, clausesa);
7379	free_clausesa = true;
7380	}
7381	if (flag_openmp)
7382	{
7383	omp_clauses
7384	= chainon (omp_clauses,
7385	gfc_trans_omp_clauses (block: &block,
7386	clauses: &clausesa[GFC_OMP_SPLIT_TEAMS],
7387	where: code->loc));
7388	pushlevel ();
7389	}
7390	switch (code->op)
7391	{
7392	case EXEC_OMP_TARGET_TEAMS:
7393	case EXEC_OMP_TEAMS:
7394	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7395	combined = false;
7396	break;
7397	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7398	case EXEC_OMP_TEAMS_DISTRIBUTE:
7399	stmt = gfc_trans_omp_do (code, op: EXEC_OMP_DISTRIBUTE, NULL,
7400	do_clauses: &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
7401	NULL);
7402	break;
7403	case EXEC_OMP_TARGET_TEAMS_LOOP:
7404	case EXEC_OMP_TEAMS_LOOP:
7405	stmt = gfc_trans_omp_do (code, op: EXEC_OMP_LOOP, NULL,
7406	do_clauses: &clausesa[GFC_OMP_SPLIT_DO],
7407	NULL);
7408	break;
7409	default:
7410	stmt = gfc_trans_omp_distribute (code, clausesa);
7411	break;
7412	}
7413	if (flag_openmp)
7414	{
7415	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7416	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_TEAMS,
7417	void_type_node, arg0: stmt, arg1: omp_clauses);
7418	if (combined)
7419	OMP_TEAMS_COMBINED (stmt) = 1;
7420	}
7421	gfc_add_expr_to_block (&block, stmt);
7422	if (free_clausesa)
7423	gfc_free_split_omp_clauses (code, clausesa);
7424	return gfc_finish_block (&block);
7425	}
7426
7427	static tree
7428	gfc_trans_omp_target (gfc_code *code)
7429	{
7430	stmtblock_t block;
7431	gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7432	tree stmt, omp_clauses = NULL_TREE;
7433
7434	gfc_start_block (&block);
7435	gfc_split_omp_clauses (code, clausesa);
7436	if (flag_openmp)
7437	omp_clauses
7438	= gfc_trans_omp_clauses (block: &block, clauses: &clausesa[GFC_OMP_SPLIT_TARGET],
7439	where: code->loc);
7440	switch (code->op)
7441	{
7442	case EXEC_OMP_TARGET:
7443	pushlevel ();
7444	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7445	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7446	break;
7447	case EXEC_OMP_TARGET_PARALLEL:
7448	{
7449	stmtblock_t iblock;
7450
7451	pushlevel ();
7452	gfc_start_block (&iblock);
7453	tree inner_clauses
7454	= gfc_trans_omp_clauses (block: &iblock, clauses: &clausesa[GFC_OMP_SPLIT_PARALLEL],
7455	where: code->loc);
7456	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7457	stmt = build2_loc (loc: input_location, code: OMP_PARALLEL, void_type_node, arg0: stmt,
7458	arg1: inner_clauses);
7459	gfc_add_expr_to_block (&iblock, stmt);
7460	stmt = gfc_finish_block (&iblock);
7461	if (TREE_CODE (stmt) != BIND_EXPR)
7462	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7463	else
7464	poplevel (0, 0);
7465	}
7466	break;
7467	case EXEC_OMP_TARGET_PARALLEL_DO:
7468	case EXEC_OMP_TARGET_PARALLEL_LOOP:
7469	stmt = gfc_trans_omp_parallel_do (code,
7470	is_loop: (code->op
7471	== EXEC_OMP_TARGET_PARALLEL_LOOP),
7472	pblock: &block, clausesa);
7473	if (TREE_CODE (stmt) != BIND_EXPR)
7474	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7475	else
7476	poplevel (0, 0);
7477	break;
7478	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7479	stmt = gfc_trans_omp_parallel_do_simd (code, pblock: &block, clausesa);
7480	if (TREE_CODE (stmt) != BIND_EXPR)
7481	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7482	else
7483	poplevel (0, 0);
7484	break;
7485	case EXEC_OMP_TARGET_SIMD:
7486	stmt = gfc_trans_omp_do (code, op: EXEC_OMP_SIMD, pblock: &block,
7487	do_clauses: &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
7488	if (TREE_CODE (stmt) != BIND_EXPR)
7489	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7490	else
7491	poplevel (0, 0);
7492	break;
7493	default:
7494	if (flag_openmp
7495	&& (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
7496	|| clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
7497	{
7498	gfc_omp_clauses clausesb;
7499	tree teams_clauses;
7500	/* For combined !$omp target teams, the num_teams and
7501	thread_limit clauses are evaluated before entering the
7502	target construct. */
7503	memset (s: &clausesb, c: '\0', n: sizeof (clausesb));
7504	clausesb.num_teams_lower
7505	= clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
7506	clausesb.num_teams_upper
7507	= clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
7508	clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
7509	clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
7510	clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
7511	clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
7512	teams_clauses
7513	= gfc_trans_omp_clauses (block: &block, clauses: &clausesb, where: code->loc);
7514	pushlevel ();
7515	stmt = gfc_trans_omp_teams (code, clausesa, omp_clauses: teams_clauses);
7516	}
7517	else
7518	{
7519	pushlevel ();
7520	stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
7521	}
7522	if (TREE_CODE (stmt) != BIND_EXPR)
7523	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7524	else
7525	poplevel (0, 0);
7526	break;
7527	}
7528	if (flag_openmp)
7529	{
7530	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_TARGET,
7531	void_type_node, arg0: stmt, arg1: omp_clauses);
7532	if (code->op != EXEC_OMP_TARGET)
7533	OMP_TARGET_COMBINED (stmt) = 1;
7534	cfun->has_omp_target = true;
7535	}
7536	gfc_add_expr_to_block (&block, stmt);
7537	gfc_free_split_omp_clauses (code, clausesa);
7538	return gfc_finish_block (&block);
7539	}
7540
7541	static tree
7542	gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op)
7543	{
7544	stmtblock_t block;
7545	gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7546	tree stmt, omp_clauses = NULL_TREE;
7547
7548	gfc_start_block (&block);
7549	gfc_split_omp_clauses (code, clausesa);
7550	if (flag_openmp)
7551	omp_clauses
7552	= gfc_trans_omp_clauses (block: &block, clauses: &clausesa[GFC_OMP_SPLIT_TASKLOOP],
7553	where: code->loc);
7554	switch (op)
7555	{
7556	case EXEC_OMP_TASKLOOP:
7557	/* This is handled in gfc_trans_omp_do. */
7558	gcc_unreachable ();
7559	break;
7560	case EXEC_OMP_TASKLOOP_SIMD:
7561	stmt = gfc_trans_omp_do (code, op: EXEC_OMP_SIMD, pblock: &block,
7562	do_clauses: &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
7563	if (TREE_CODE (stmt) != BIND_EXPR)
7564	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7565	else
7566	poplevel (0, 0);
7567	break;
7568	default:
7569	gcc_unreachable ();
7570	}
7571	if (flag_openmp)
7572	{
7573	tree taskloop = make_node (OMP_TASKLOOP);
7574	SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc));
7575	TREE_TYPE (taskloop) = void_type_node;
7576	OMP_FOR_BODY (taskloop) = stmt;
7577	OMP_FOR_CLAUSES (taskloop) = omp_clauses;
7578	stmt = taskloop;
7579	}
7580	gfc_add_expr_to_block (&block, stmt);
7581	gfc_free_split_omp_clauses (code, clausesa);
7582	return gfc_finish_block (&block);
7583	}
7584
7585	static tree
7586	gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op)
7587	{
7588	gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7589	stmtblock_t block;
7590	tree stmt;
7591
7592	if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
7593	&& code->op != EXEC_OMP_MASTER_TASKLOOP)
7594	gfc_split_omp_clauses (code, clausesa);
7595
7596	pushlevel ();
7597	if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD
7598	|| op == EXEC_OMP_MASTER_TASKLOOP_SIMD)
7599	stmt = gfc_trans_omp_taskloop (code, op: EXEC_OMP_TASKLOOP_SIMD);
7600	else
7601	{
7602	gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP
7603	|| op == EXEC_OMP_MASTER_TASKLOOP);
7604	stmt = gfc_trans_omp_do (code, op: EXEC_OMP_TASKLOOP, NULL,
7605	do_clauses: code->op != EXEC_OMP_MASTER_TASKLOOP
7606	? &clausesa[GFC_OMP_SPLIT_TASKLOOP]
7607	: code->ext.omp_clauses, NULL);
7608	}
7609	if (TREE_CODE (stmt) != BIND_EXPR)
7610	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7611	else
7612	poplevel (0, 0);
7613	gfc_start_block (&block);
7614	if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD)
7615	{
7616	tree clauses = gfc_trans_omp_clauses (block: &block,
7617	clauses: &clausesa[GFC_OMP_SPLIT_MASKED],
7618	where: code->loc);
7619	tree msk = make_node (OMP_MASKED);
7620	SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc));
7621	TREE_TYPE (msk) = void_type_node;
7622	OMP_MASKED_BODY (msk) = stmt;
7623	OMP_MASKED_CLAUSES (msk) = clauses;
7624	OMP_MASKED_COMBINED (msk) = 1;
7625	gfc_add_expr_to_block (&block, msk);
7626	}
7627	else
7628	{
7629	gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP
7630	|| op == EXEC_OMP_MASTER_TASKLOOP_SIMD);
7631	stmt = build1_v (OMP_MASTER, stmt);
7632	gfc_add_expr_to_block (&block, stmt);
7633	}
7634	if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
7635	&& code->op != EXEC_OMP_MASTER_TASKLOOP)
7636	gfc_free_split_omp_clauses (code, clausesa);
7637	return gfc_finish_block (&block);
7638	}
7639
7640	static tree
7641	gfc_trans_omp_parallel_master_masked (gfc_code *code)
7642	{
7643	stmtblock_t block;
7644	tree stmt, omp_clauses;
7645	gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
7646	bool parallel_combined = false;
7647
7648	if (code->op != EXEC_OMP_PARALLEL_MASTER)
7649	gfc_split_omp_clauses (code, clausesa);
7650
7651	gfc_start_block (&block);
7652	omp_clauses = gfc_trans_omp_clauses (block: &block,
7653	clauses: code->op == EXEC_OMP_PARALLEL_MASTER
7654	? code->ext.omp_clauses
7655	: &clausesa[GFC_OMP_SPLIT_PARALLEL],
7656	where: code->loc);
7657	pushlevel ();
7658	if (code->op == EXEC_OMP_PARALLEL_MASTER)
7659	stmt = gfc_trans_omp_master (code);
7660	else if (code->op == EXEC_OMP_PARALLEL_MASKED)
7661	stmt = gfc_trans_omp_masked (code, clauses: &clausesa[GFC_OMP_SPLIT_MASKED]);
7662	else
7663	{
7664	gfc_exec_op op;
7665	switch (code->op)
7666	{
7667	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7668	op = EXEC_OMP_MASKED_TASKLOOP;
7669	break;
7670	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7671	op = EXEC_OMP_MASKED_TASKLOOP_SIMD;
7672	break;
7673	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7674	op = EXEC_OMP_MASTER_TASKLOOP;
7675	break;
7676	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7677	op = EXEC_OMP_MASTER_TASKLOOP_SIMD;
7678	break;
7679	default:
7680	gcc_unreachable ();
7681	}
7682	stmt = gfc_trans_omp_master_masked_taskloop (code, op);
7683	parallel_combined = true;
7684	}
7685	if (TREE_CODE (stmt) != BIND_EXPR)
7686	stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7687	else
7688	poplevel (0, 0);
7689	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_PARALLEL,
7690	void_type_node, arg0: stmt, arg1: omp_clauses);
7691	/* masked does have just filter clause, but during gimplification
7692	isn't represented by a gimplification omp context, so for
7693	!$omp parallel masked don't set OMP_PARALLEL_COMBINED,
7694	so that
7695	!$omp parallel masked
7696	!$omp taskloop simd lastprivate (x)
7697	isn't confused with
7698	!$omp parallel masked taskloop simd lastprivate (x) */
7699	if (parallel_combined)
7700	OMP_PARALLEL_COMBINED (stmt) = 1;
7701	gfc_add_expr_to_block (&block, stmt);
7702	if (code->op != EXEC_OMP_PARALLEL_MASTER)
7703	gfc_free_split_omp_clauses (code, clausesa);
7704	return gfc_finish_block (&block);
7705	}
7706
7707	static tree
7708	gfc_trans_omp_target_data (gfc_code *code)
7709	{
7710	stmtblock_t block;
7711	tree stmt, omp_clauses;
7712
7713	gfc_start_block (&block);
7714	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7715	where: code->loc);
7716	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7717	stmt = build2_loc (loc: gfc_get_location (&code->loc), code: OMP_TARGET_DATA,
7718	void_type_node, arg0: stmt, arg1: omp_clauses);
7719	gfc_add_expr_to_block (&block, stmt);
7720	return gfc_finish_block (&block);
7721	}
7722
7723	static tree
7724	gfc_trans_omp_target_enter_data (gfc_code *code)
7725	{
7726	stmtblock_t block;
7727	tree stmt, omp_clauses;
7728
7729	gfc_start_block (&block);
7730	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7731	where: code->loc);
7732	stmt = build1_loc (loc: input_location, code: OMP_TARGET_ENTER_DATA, void_type_node,
7733	arg1: omp_clauses);
7734	gfc_add_expr_to_block (&block, stmt);
7735	return gfc_finish_block (&block);
7736	}
7737
7738	static tree
7739	gfc_trans_omp_target_exit_data (gfc_code *code)
7740	{
7741	stmtblock_t block;
7742	tree stmt, omp_clauses;
7743
7744	gfc_start_block (&block);
7745	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7746	where: code->loc, declare_simd: false, openacc: false, op: code->op);
7747	stmt = build1_loc (loc: input_location, code: OMP_TARGET_EXIT_DATA, void_type_node,
7748	arg1: omp_clauses);
7749	gfc_add_expr_to_block (&block, stmt);
7750	return gfc_finish_block (&block);
7751	}
7752
7753	static tree
7754	gfc_trans_omp_target_update (gfc_code *code)
7755	{
7756	stmtblock_t block;
7757	tree stmt, omp_clauses;
7758
7759	gfc_start_block (&block);
7760	omp_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.omp_clauses,
7761	where: code->loc);
7762	stmt = build1_loc (loc: input_location, code: OMP_TARGET_UPDATE, void_type_node,
7763	arg1: omp_clauses);
7764	gfc_add_expr_to_block (&block, stmt);
7765	return gfc_finish_block (&block);
7766	}
7767
7768	static tree
7769	gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
7770	{
7771	tree res, tmp, stmt;
7772	stmtblock_t block, *pblock = NULL;
7773	stmtblock_t singleblock;
7774	int saved_ompws_flags;
7775	bool singleblock_in_progress = false;
7776	/* True if previous gfc_code in workshare construct is not workshared. */
7777	bool prev_singleunit;
7778	location_t loc = gfc_get_location (&code->loc);
7779
7780	code = code->block->next;
7781
7782	pushlevel ();
7783
7784	gfc_start_block (&block);
7785	pblock = &block;
7786
7787	ompws_flags = OMPWS_WORKSHARE_FLAG;
7788	prev_singleunit = false;
7789
7790	/* Translate statements one by one to trees until we reach
7791	the end of the workshare construct. Adjacent gfc_codes that
7792	are a single unit of work are clustered and encapsulated in a
7793	single OMP_SINGLE construct. */
7794	for (; code; code = code->next)
7795	{
7796	if (code->here != 0)
7797	{
7798	res = gfc_trans_label_here (code);
7799	gfc_add_expr_to_block (pblock, res);
7800	}
7801
7802	/* No dependence analysis, use for clauses with wait.
7803	If this is the last gfc_code, use default omp_clauses. */
7804	if (code->next == NULL && clauses->nowait)
7805	ompws_flags |= OMPWS_NOWAIT;
7806
7807	/* By default, every gfc_code is a single unit of work. */
7808	ompws_flags |= OMPWS_CURR_SINGLEUNIT;
7809	ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
7810
7811	switch (code->op)
7812	{
7813	case EXEC_NOP:
7814	res = NULL_TREE;
7815	break;
7816
7817	case EXEC_ASSIGN:
7818	res = gfc_trans_assign (code);
7819	break;
7820
7821	case EXEC_POINTER_ASSIGN:
7822	res = gfc_trans_pointer_assign (code);
7823	break;
7824
7825	case EXEC_INIT_ASSIGN:
7826	res = gfc_trans_init_assign (code);
7827	break;
7828
7829	case EXEC_FORALL:
7830	res = gfc_trans_forall (code);
7831	break;
7832
7833	case EXEC_WHERE:
7834	res = gfc_trans_where (code);
7835	break;
7836
7837	case EXEC_OMP_ATOMIC:
7838	res = gfc_trans_omp_directive (code);
7839	break;
7840
7841	case EXEC_OMP_PARALLEL:
7842	case EXEC_OMP_PARALLEL_DO:
7843	case EXEC_OMP_PARALLEL_MASTER:
7844	case EXEC_OMP_PARALLEL_SECTIONS:
7845	case EXEC_OMP_PARALLEL_WORKSHARE:
7846	case EXEC_OMP_CRITICAL:
7847	saved_ompws_flags = ompws_flags;
7848	ompws_flags = 0;
7849	res = gfc_trans_omp_directive (code);
7850	ompws_flags = saved_ompws_flags;
7851	break;
7852
7853	case EXEC_BLOCK:
7854	res = gfc_trans_block_construct (code);
7855	break;
7856
7857	default:
7858	gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
7859	}
7860
7861	gfc_set_backend_locus (&code->loc);
7862
7863	if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
7864	{
7865	if (prev_singleunit)
7866	{
7867	if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
7868	/* Add current gfc_code to single block. */
7869	gfc_add_expr_to_block (&singleblock, res);
7870	else
7871	{
7872	/* Finish single block and add it to pblock. */
7873	tmp = gfc_finish_block (&singleblock);
7874	tmp = build2_loc (loc, code: OMP_SINGLE,
7875	void_type_node, arg0: tmp, NULL_TREE);
7876	gfc_add_expr_to_block (pblock, tmp);
7877	/* Add current gfc_code to pblock. */
7878	gfc_add_expr_to_block (pblock, res);
7879	singleblock_in_progress = false;
7880	}
7881	}
7882	else
7883	{
7884	if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
7885	{
7886	/* Start single block. */
7887	gfc_init_block (&singleblock);
7888	gfc_add_expr_to_block (&singleblock, res);
7889	singleblock_in_progress = true;
7890	loc = gfc_get_location (&code->loc);
7891	}
7892	else
7893	/* Add the new statement to the block. */
7894	gfc_add_expr_to_block (pblock, res);
7895	}
7896	prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
7897	}
7898	}
7899
7900	/* Finish remaining SINGLE block, if we were in the middle of one. */
7901	if (singleblock_in_progress)
7902	{
7903	/* Finish single block and add it to pblock. */
7904	tmp = gfc_finish_block (&singleblock);
7905	tmp = build2_loc (loc, code: OMP_SINGLE, void_type_node, arg0: tmp,
7906	arg1: clauses->nowait
7907	? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
7908	: NULL_TREE);
7909	gfc_add_expr_to_block (pblock, tmp);
7910	}
7911
7912	stmt = gfc_finish_block (pblock);
7913	if (TREE_CODE (stmt) != BIND_EXPR)
7914	{
7915	if (!IS_EMPTY_STMT (stmt))
7916	{
7917	tree bindblock = poplevel (1, 0);
7918	stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
7919	}
7920	else
7921	poplevel (0, 0);
7922	}
7923	else
7924	poplevel (0, 0);
7925
7926	if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
7927	stmt = gfc_trans_omp_barrier ();
7928
7929	ompws_flags = 0;
7930	return stmt;
7931	}
7932
7933	tree
7934	gfc_trans_oacc_declare (gfc_code *code)
7935	{
7936	stmtblock_t block;
7937	tree stmt, oacc_clauses;
7938	enum tree_code construct_code;
7939
7940	construct_code = OACC_DATA;
7941
7942	gfc_start_block (&block);
7943
7944	oacc_clauses = gfc_trans_omp_clauses (block: &block, clauses: code->ext.oacc_declare->clauses,
7945	where: code->loc, declare_simd: false, openacc: true);
7946	stmt = gfc_trans_omp_code (code: code->block->next, force_empty: true);
7947	stmt = build2_loc (loc: input_location, code: construct_code, void_type_node, arg0: stmt,
7948	arg1: oacc_clauses);
7949	gfc_add_expr_to_block (&block, stmt);
7950
7951	return gfc_finish_block (&block);
7952	}
7953
7954	tree
7955	gfc_trans_oacc_directive (gfc_code *code)
7956	{
7957	switch (code->op)
7958	{
7959	case EXEC_OACC_PARALLEL_LOOP:
7960	case EXEC_OACC_KERNELS_LOOP:
7961	case EXEC_OACC_SERIAL_LOOP:
7962	return gfc_trans_oacc_combined_directive (code);
7963	case EXEC_OACC_PARALLEL:
7964	case EXEC_OACC_KERNELS:
7965	case EXEC_OACC_SERIAL:
7966	case EXEC_OACC_DATA:
7967	case EXEC_OACC_HOST_DATA:
7968	return gfc_trans_oacc_construct (code);
7969	case EXEC_OACC_LOOP:
7970	return gfc_trans_omp_do (code, op: code->op, NULL, do_clauses: code->ext.omp_clauses,
7971	NULL);
7972	case EXEC_OACC_UPDATE:
7973	case EXEC_OACC_CACHE:
7974	case EXEC_OACC_ENTER_DATA:
7975	case EXEC_OACC_EXIT_DATA:
7976	return gfc_trans_oacc_executable_directive (code);
7977	case EXEC_OACC_WAIT:
7978	return gfc_trans_oacc_wait_directive (code);
7979	case EXEC_OACC_ATOMIC:
7980	return gfc_trans_omp_atomic (code);
7981	case EXEC_OACC_DECLARE:
7982	return gfc_trans_oacc_declare (code);
7983	default:
7984	gcc_unreachable ();
7985	}
7986	}
7987
7988	tree
7989	gfc_trans_omp_directive (gfc_code *code)
7990	{
7991	switch (code->op)
7992	{
7993	case EXEC_OMP_ALLOCATE:
7994	case EXEC_OMP_ALLOCATORS:
7995	sorry ("%<!$OMP %s%> not yet supported",
7996	code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS");
7997	return NULL_TREE;
7998	case EXEC_OMP_ASSUME:
7999	return gfc_trans_omp_assume (code);
8000	case EXEC_OMP_ATOMIC:
8001	return gfc_trans_omp_atomic (code);
8002	case EXEC_OMP_BARRIER:
8003	return gfc_trans_omp_barrier ();
8004	case EXEC_OMP_CANCEL:
8005	return gfc_trans_omp_cancel (code);
8006	case EXEC_OMP_CANCELLATION_POINT:
8007	return gfc_trans_omp_cancellation_point (code);
8008	case EXEC_OMP_CRITICAL:
8009	return gfc_trans_omp_critical (code);
8010	case EXEC_OMP_DEPOBJ:
8011	return gfc_trans_omp_depobj (code);
8012	case EXEC_OMP_DISTRIBUTE:
8013	case EXEC_OMP_DO:
8014	case EXEC_OMP_LOOP:
8015	case EXEC_OMP_SIMD:
8016	case EXEC_OMP_TASKLOOP:
8017	return gfc_trans_omp_do (code, op: code->op, NULL, do_clauses: code->ext.omp_clauses,
8018	NULL);
8019	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8020	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8021	case EXEC_OMP_DISTRIBUTE_SIMD:
8022	return gfc_trans_omp_distribute (code, NULL);
8023	case EXEC_OMP_DO_SIMD:
8024	return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
8025	case EXEC_OMP_ERROR:
8026	return gfc_trans_omp_error (code);
8027	case EXEC_OMP_FLUSH:
8028	return gfc_trans_omp_flush (code);
8029	case EXEC_OMP_MASKED:
8030	return gfc_trans_omp_masked (code, NULL);
8031	case EXEC_OMP_MASTER:
8032	return gfc_trans_omp_master (code);
8033	case EXEC_OMP_MASKED_TASKLOOP:
8034	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8035	case EXEC_OMP_MASTER_TASKLOOP:
8036	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8037	return gfc_trans_omp_master_masked_taskloop (code, op: code->op);
8038	case EXEC_OMP_ORDERED:
8039	return gfc_trans_omp_ordered (code);
8040	case EXEC_OMP_PARALLEL:
8041	return gfc_trans_omp_parallel (code);
8042	case EXEC_OMP_PARALLEL_DO:
8043	return gfc_trans_omp_parallel_do (code, is_loop: false, NULL, NULL);
8044	case EXEC_OMP_PARALLEL_LOOP:
8045	return gfc_trans_omp_parallel_do (code, is_loop: true, NULL, NULL);
8046	case EXEC_OMP_PARALLEL_DO_SIMD:
8047	return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
8048	case EXEC_OMP_PARALLEL_MASKED:
8049	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8050	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8051	case EXEC_OMP_PARALLEL_MASTER:
8052	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8053	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8054	return gfc_trans_omp_parallel_master_masked (code);
8055	case EXEC_OMP_PARALLEL_SECTIONS:
8056	return gfc_trans_omp_parallel_sections (code);
8057	case EXEC_OMP_PARALLEL_WORKSHARE:
8058	return gfc_trans_omp_parallel_workshare (code);
8059	case EXEC_OMP_SCOPE:
8060	return gfc_trans_omp_scope (code);
8061	case EXEC_OMP_SECTIONS:
8062	return gfc_trans_omp_sections (code, clauses: code->ext.omp_clauses);
8063	case EXEC_OMP_SINGLE:
8064	return gfc_trans_omp_single (code, clauses: code->ext.omp_clauses);
8065	case EXEC_OMP_TARGET:
8066	case EXEC_OMP_TARGET_PARALLEL:
8067	case EXEC_OMP_TARGET_PARALLEL_DO:
8068	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
8069	case EXEC_OMP_TARGET_PARALLEL_LOOP:
8070	case EXEC_OMP_TARGET_SIMD:
8071	case EXEC_OMP_TARGET_TEAMS:
8072	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8073	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8074	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8075	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8076	case EXEC_OMP_TARGET_TEAMS_LOOP:
8077	return gfc_trans_omp_target (code);
8078	case EXEC_OMP_TARGET_DATA:
8079	return gfc_trans_omp_target_data (code);
8080	case EXEC_OMP_TARGET_ENTER_DATA:
8081	return gfc_trans_omp_target_enter_data (code);
8082	case EXEC_OMP_TARGET_EXIT_DATA:
8083	return gfc_trans_omp_target_exit_data (code);
8084	case EXEC_OMP_TARGET_UPDATE:
8085	return gfc_trans_omp_target_update (code);
8086	case EXEC_OMP_TASK:
8087	return gfc_trans_omp_task (code);
8088	case EXEC_OMP_TASKGROUP:
8089	return gfc_trans_omp_taskgroup (code);
8090	case EXEC_OMP_TASKLOOP_SIMD:
8091	return gfc_trans_omp_taskloop (code, op: code->op);
8092	case EXEC_OMP_TASKWAIT:
8093	return gfc_trans_omp_taskwait (code);
8094	case EXEC_OMP_TASKYIELD:
8095	return gfc_trans_omp_taskyield ();
8096	case EXEC_OMP_TEAMS:
8097	case EXEC_OMP_TEAMS_DISTRIBUTE:
8098	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8099	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8100	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8101	case EXEC_OMP_TEAMS_LOOP:
8102	return gfc_trans_omp_teams (code, NULL, NULL_TREE);
8103	case EXEC_OMP_WORKSHARE:
8104	return gfc_trans_omp_workshare (code, clauses: code->ext.omp_clauses);
8105	default:
8106	gcc_unreachable ();
8107	}
8108	}
8109
8110	void
8111	gfc_trans_omp_declare_simd (gfc_namespace *ns)
8112	{
8113	if (ns->entries)
8114	return;
8115
8116	gfc_omp_declare_simd *ods;
8117	for (ods = ns->omp_declare_simd; ods; ods = ods->next)
8118	{
8119	tree c = gfc_trans_omp_clauses (NULL, clauses: ods->clauses, where: ods->where, declare_simd: true);
8120	tree fndecl = ns->proc_name->backend_decl;
8121	if (c != NULL_TREE)
8122	c = tree_cons (NULL_TREE, c, NULL_TREE);
8123	c = build_tree_list (get_identifier ("omp declare simd"), c);
8124	TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
8125	DECL_ATTRIBUTES (fndecl) = c;
8126	}
8127	}
8128
8129	void
8130	gfc_trans_omp_declare_variant (gfc_namespace *ns)
8131	{
8132	tree base_fn_decl = ns->proc_name->backend_decl;
8133	gfc_namespace *search_ns = ns;
8134	gfc_omp_declare_variant *next;
8135
8136	for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
8137	search_ns; odv = next)
8138	{
8139	/* Look in the parent namespace if there are no more directives in the
8140	current namespace. */
8141	if (!odv)
8142	{
8143	search_ns = search_ns->parent;
8144	if (search_ns)
8145	next = search_ns->omp_declare_variant;
8146	continue;
8147	}
8148
8149	next = odv->next;
8150
8151	if (odv->error_p)
8152	continue;
8153
8154	/* Check directive the first time it is encountered. */
8155	bool error_found = true;
8156
8157	if (odv->checked_p)
8158	error_found = false;
8159	if (odv->base_proc_symtree == NULL)
8160	{
8161	if (!search_ns->proc_name->attr.function
8162	&& !search_ns->proc_name->attr.subroutine)
8163	gfc_error ("The base name for 'declare variant' must be "
8164	"specified at %L ", &odv->where);
8165	else
8166	error_found = false;
8167	}
8168	else
8169	{
8170	if (!search_ns->contained
8171	&& strcmp (s1: odv->base_proc_symtree->name,
8172	s2: ns->proc_name->name))
8173	gfc_error ("The base name at %L does not match the name of the "
8174	"current procedure", &odv->where);
8175	else if (odv->base_proc_symtree->n.sym->attr.entry)
8176	gfc_error ("The base name at %L must not be an entry name",
8177	&odv->where);
8178	else if (odv->base_proc_symtree->n.sym->attr.generic)
8179	gfc_error ("The base name at %L must not be a generic name",
8180	&odv->where);
8181	else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
8182	gfc_error ("The base name at %L must not be a procedure pointer",
8183	&odv->where);
8184	else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
8185	gfc_error ("The base procedure at %L must have an explicit "
8186	"interface", &odv->where);
8187	else
8188	error_found = false;
8189	}
8190
8191	odv->checked_p = true;
8192	if (error_found)
8193	{
8194	odv->error_p = true;
8195	continue;
8196	}
8197
8198	/* Ignore directives that do not apply to the current procedure. */
8199	if ((odv->base_proc_symtree == NULL && search_ns != ns)
8200	|| (odv->base_proc_symtree != NULL
8201	&& strcmp (s1: odv->base_proc_symtree->name, s2: ns->proc_name->name)))
8202	continue;
8203
8204	tree set_selectors = NULL_TREE;
8205	gfc_omp_set_selector *oss;
8206
8207	for (oss = odv->set_selectors; oss; oss = oss->next)
8208	{
8209	tree selectors = NULL_TREE;
8210	gfc_omp_selector *os;
8211	for (os = oss->trait_selectors; os; os = os->next)
8212	{
8213	tree properties = NULL_TREE;
8214	gfc_omp_trait_property *otp;
8215
8216	for (otp = os->properties; otp; otp = otp->next)
8217	{
8218	switch (otp->property_kind)
8219	{
8220	case CTX_PROPERTY_USER:
8221	case CTX_PROPERTY_EXPR:
8222	{
8223	gfc_se se;
8224	gfc_init_se (&se, NULL);
8225	gfc_conv_expr (se: &se, expr: otp->expr);
8226	properties = tree_cons (NULL_TREE, se.expr,
8227	properties);
8228	}
8229	break;
8230	case CTX_PROPERTY_ID:
8231	properties = tree_cons (get_identifier (otp->name),
8232	NULL_TREE, properties);
8233	break;
8234	case CTX_PROPERTY_NAME_LIST:
8235	{
8236	tree prop = NULL_TREE, value = NULL_TREE;
8237	if (otp->is_name)
8238	prop = get_identifier (otp->name);
8239	else
8240	value = gfc_conv_constant_to_tree (otp->expr);
8241
8242	properties = tree_cons (prop, value, properties);
8243	}
8244	break;
8245	case CTX_PROPERTY_SIMD:
8246	properties = gfc_trans_omp_clauses (NULL, clauses: otp->clauses,
8247	where: odv->where, declare_simd: true);
8248	break;
8249	default:
8250	gcc_unreachable ();
8251	}
8252	}
8253
8254	if (os->score)
8255	{
8256	gfc_se se;
8257	gfc_init_se (&se, NULL);
8258	gfc_conv_expr (se: &se, expr: os->score);
8259	properties = tree_cons (get_identifier (" score"),
8260	se.expr, properties);
8261	}
8262
8263	selectors = tree_cons (get_identifier (os->trait_selector_name),
8264	properties, selectors);
8265	}
8266
8267	set_selectors
8268	= tree_cons (get_identifier (oss->trait_set_selector_name),
8269	selectors, set_selectors);
8270	}
8271
8272	const char *variant_proc_name = odv->variant_proc_symtree->name;
8273	gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
8274	if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
8275	{
8276	gfc_symtree *proc_st;
8277	gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
8278	variant_proc_sym = proc_st->n.sym;
8279	}
8280	if (variant_proc_sym == NULL)
8281	{
8282	gfc_error ("Cannot find symbol %qs", variant_proc_name);
8283	continue;
8284	}
8285	set_selectors = omp_check_context_selector
8286	(loc: gfc_get_location (&odv->where), ctx: set_selectors);
8287	if (set_selectors != error_mark_node)
8288	{
8289	if (!variant_proc_sym->attr.implicit_type
8290	&& !variant_proc_sym->attr.subroutine
8291	&& !variant_proc_sym->attr.function)
8292	{
8293	gfc_error ("variant %qs at %L is not a function or subroutine",
8294	variant_proc_name, &odv->where);
8295	variant_proc_sym = NULL;
8296	}
8297	else if (omp_get_context_selector (set_selectors, "construct",
8298	"simd") == NULL_TREE)
8299	{
8300	char err[256];
8301	if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
8302	variant_proc_sym->name, 0, 1,
8303	err, sizeof (err), NULL, NULL))
8304	{
8305	gfc_error ("variant %qs and base %qs at %L have "
8306	"incompatible types: %s",
8307	variant_proc_name, ns->proc_name->name,
8308	&odv->where, err);
8309	variant_proc_sym = NULL;
8310	}
8311	}
8312	if (variant_proc_sym != NULL)
8313	{
8314	gfc_set_sym_referenced (variant_proc_sym);
8315	tree construct = omp_get_context_selector (set_selectors,
8316	"construct", NULL);
8317	omp_mark_declare_variant (loc: gfc_get_location (&odv->where),
8318	variant: gfc_get_symbol_decl (variant_proc_sym),
8319	construct);
8320	if (omp_context_selector_matches (set_selectors))
8321	{
8322	tree id = get_identifier ("omp declare variant base");
8323	tree variant = gfc_get_symbol_decl (variant_proc_sym);
8324	DECL_ATTRIBUTES (base_fn_decl)
8325	= tree_cons (id, build_tree_list (variant, set_selectors),
8326	DECL_ATTRIBUTES (base_fn_decl));
8327	}
8328	}
8329	}
8330	}
8331	}
8332