1	/* Code translation -- generate GCC trees from gfc_code.
2	Copyright (C) 2002-2023 Free Software Foundation, Inc.
3	Contributed by Paul Brook
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	#include "config.h"
22	#include "system.h"
23	#include "coretypes.h"
24	#include "options.h"
25	#include "tree.h"
26	#include "gfortran.h"
27	#include "gimple-expr.h" /* For create_tmp_var_raw. */
28	#include "trans.h"
29	#include "stringpool.h"
30	#include "fold-const.h"
31	#include "tree-iterator.h"
32	#include "trans-stmt.h"
33	#include "trans-array.h"
34	#include "trans-types.h"
35	#include "trans-const.h"
36
37	/* Naming convention for backend interface code:
38
39	gfc_trans_* translate gfc_code into STMT trees.
40
41	gfc_conv_* expression conversion
42
43	gfc_get_* get a backend tree representation of a decl or type */
44
45	static gfc_file *gfc_current_backend_file;
46
47	const char gfc_msg_fault[] = N_("Array reference out of bounds");
48
49
50	/* Return a location_t suitable for 'tree' for a gfortran locus. The way the
51	parser works in gfortran, loc->lb->location contains only the line number
52	and LOCATION_COLUMN is 0; hence, the column has to be added when generating
53	locations for 'tree'. Cf. error.cc's gfc_format_decoder. */
54
55	location_t
56	gfc_get_location (locus *loc)
57	{
58	return linemap_position_for_loc_and_offset (set: line_table, loc: loc->lb->location,
59	offset: loc->nextc - loc->lb->line);
60	}
61
62	/* Advance along TREE_CHAIN n times. */
63
64	tree
65	gfc_advance_chain (tree t, int n)
66	{
67	for (; n > 0; n--)
68	{
69	gcc_assert (t != NULL_TREE);
70	t = DECL_CHAIN (t);
71	}
72	return t;
73	}
74
75	static int num_var;
76
77	#define MAX_PREFIX_LEN 20
78
79	static tree
80	create_var_debug_raw (tree type, const char *prefix)
81	{
82	/* Space for prefix + "_" + 10-digit-number + \0. */
83	char name_buf[MAX_PREFIX_LEN + 1 + 10 + 1];
84	tree t;
85	int i;
86
87	if (prefix == NULL)
88	prefix = "gfc";
89	else
90	gcc_assert (strlen (prefix) <= MAX_PREFIX_LEN);
91
92	for (i = 0; prefix[i] != 0; i++)
93	name_buf[i] = gfc_wide_toupper (prefix[i]);
94
95	snprintf (s: name_buf + i, maxlen: sizeof (name_buf) - i, format: "_%d", num_var++);
96
97	t = build_decl (input_location, VAR_DECL, get_identifier (name_buf), type);
98
99	/* Not setting this causes some regressions. */
100	DECL_ARTIFICIAL (t) = 1;
101
102	/* We want debug info for it. */
103	DECL_IGNORED_P (t) = 0;
104	/* It should not be nameless. */
105	DECL_NAMELESS (t) = 0;
106
107	/* Make the variable writable. */
108	TREE_READONLY (t) = 0;
109
110	DECL_EXTERNAL (t) = 0;
111	TREE_STATIC (t) = 0;
112	TREE_USED (t) = 1;
113
114	return t;
115	}
116
117	/* Creates a variable declaration with a given TYPE. */
118
119	tree
120	gfc_create_var_np (tree type, const char *prefix)
121	{
122	tree t;
123
124	if (flag_debug_aux_vars)
125	return create_var_debug_raw (type, prefix);
126
127	t = create_tmp_var_raw (type, prefix);
128
129	/* No warnings for anonymous variables. */
130	if (prefix == NULL)
131	suppress_warning (t);
132
133	return t;
134	}
135
136
137	/* Like above, but also adds it to the current scope. */
138
139	tree
140	gfc_create_var (tree type, const char *prefix)
141	{
142	tree tmp;
143
144	tmp = gfc_create_var_np (type, prefix);
145
146	pushdecl (tmp);
147
148	return tmp;
149	}
150
151
152	/* If the expression is not constant, evaluate it now. We assign the
153	result of the expression to an artificially created variable VAR, and
154	return a pointer to the VAR_DECL node for this variable. */
155
156	tree
157	gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
158	{
159	tree var;
160
161	if (CONSTANT_CLASS_P (expr))
162	return expr;
163
164	var = gfc_create_var (TREE_TYPE (expr), NULL);
165	gfc_add_modify_loc (loc, pblock, var, expr);
166
167	return var;
168	}
169
170
171	tree
172	gfc_evaluate_now (tree expr, stmtblock_t * pblock)
173	{
174	return gfc_evaluate_now_loc (loc: input_location, expr, pblock);
175	}
176
177
178	/* Returns a fresh pointer variable pointing to the same data as EXPR, adding
179	in BLOCK the initialization code that makes it point to EXPR. */
180
181	tree
182	gfc_evaluate_data_ref_now (tree expr, stmtblock_t *block)
183	{
184	tree t = expr;
185
186	STRIP_NOPS (t);
187
188	/* If EXPR can be used as lhs of an assignment, we have to take the address
189	of EXPR. Otherwise, reassigning the pointer would retarget it to some
190	other data without EXPR being retargetted as well. */
191	bool lvalue_p = DECL_P (t) || REFERENCE_CLASS_P (t) || INDIRECT_REF_P (t);
192
193	tree value;
194	if (lvalue_p)
195	{
196	value = gfc_build_addr_expr (NULL_TREE, expr);
197	value = gfc_evaluate_now (expr: value, pblock: block);
198	return build_fold_indirect_ref_loc (input_location, value);
199	}
200	else
201	return gfc_evaluate_now (expr, pblock: block);
202	}
203
204
205	/* Like gfc_evaluate_now, but add the created variable to the
206	function scope. */
207
208	tree
209	gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock)
210	{
211	tree var;
212	var = gfc_create_var_np (TREE_TYPE (expr), NULL);
213	gfc_add_decl_to_function (var);
214	gfc_add_modify (pblock, var, expr);
215
216	return var;
217	}
218
219	/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
220	A MODIFY_EXPR is an assignment:
221	LHS <- RHS. */
222
223	void
224	gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
225	{
226	tree tmp;
227
228	tree t1, t2;
229	t1 = TREE_TYPE (rhs);
230	t2 = TREE_TYPE (lhs);
231	/* Make sure that the types of the rhs and the lhs are compatible
232	for scalar assignments. We should probably have something
233	similar for aggregates, but right now removing that check just
234	breaks everything. */
235	gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)
236	|| AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
237
238	tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
239	rhs);
240	gfc_add_expr_to_block (pblock, tmp);
241	}
242
243
244	void
245	gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
246	{
247	gfc_add_modify_loc (loc: input_location, pblock, lhs, rhs);
248	}
249
250
251	/* Create a new scope/binding level and initialize a block. Care must be
252	taken when translating expressions as any temporaries will be placed in
253	the innermost scope. */
254
255	void
256	gfc_start_block (stmtblock_t * block)
257	{
258	/* Start a new binding level. */
259	pushlevel ();
260	block->has_scope = 1;
261
262	/* The block is empty. */
263	block->head = NULL_TREE;
264	}
265
266
267	/* Initialize a block without creating a new scope. */
268
269	void
270	gfc_init_block (stmtblock_t * block)
271	{
272	block->head = NULL_TREE;
273	block->has_scope = 0;
274	}
275
276
277	/* Sometimes we create a scope but it turns out that we don't actually
278	need it. This function merges the scope of BLOCK with its parent.
279	Only variable decls will be merged, you still need to add the code. */
280
281	void
282	gfc_merge_block_scope (stmtblock_t * block)
283	{
284	tree decl;
285	tree next;
286
287	gcc_assert (block->has_scope);
288	block->has_scope = 0;
289
290	/* Remember the decls in this scope. */
291	decl = getdecls ();
292	poplevel (0, 0);
293
294	/* Add them to the parent scope. */
295	while (decl != NULL_TREE)
296	{
297	next = DECL_CHAIN (decl);
298	DECL_CHAIN (decl) = NULL_TREE;
299
300	pushdecl (decl);
301	decl = next;
302	}
303	}
304
305
306	/* Finish a scope containing a block of statements. */
307
308	tree
309	gfc_finish_block (stmtblock_t * stmtblock)
310	{
311	tree decl;
312	tree expr;
313	tree block;
314
315	expr = stmtblock->head;
316	if (!expr)
317	expr = build_empty_stmt (input_location);
318
319	stmtblock->head = NULL_TREE;
320
321	if (stmtblock->has_scope)
322	{
323	decl = getdecls ();
324
325	if (decl)
326	{
327	block = poplevel (1, 0);
328	expr = build3_v (BIND_EXPR, decl, expr, block);
329	}
330	else
331	poplevel (0, 0);
332	}
333
334	return expr;
335	}
336
337
338	/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
339	natural type is used. */
340
341	tree
342	gfc_build_addr_expr (tree type, tree t)
343	{
344	tree base_type = TREE_TYPE (t);
345	tree natural_type;
346
347	if (type && POINTER_TYPE_P (type)
348	&& TREE_CODE (base_type) == ARRAY_TYPE
349	&& TYPE_MAIN_VARIANT (TREE_TYPE (type))
350	== TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
351	{
352	tree min_val = size_zero_node;
353	tree type_domain = TYPE_DOMAIN (base_type);
354	if (type_domain && TYPE_MIN_VALUE (type_domain))
355	min_val = TYPE_MIN_VALUE (type_domain);
356	t = fold (build4_loc (loc: input_location, code: ARRAY_REF, TREE_TYPE (type),
357	arg0: t, arg1: min_val, NULL_TREE, NULL_TREE));
358	natural_type = type;
359	}
360	else
361	natural_type = build_pointer_type (base_type);
362
363	if (INDIRECT_REF_P (t))
364	{
365	if (!type)
366	type = natural_type;
367	t = TREE_OPERAND (t, 0);
368	natural_type = TREE_TYPE (t);
369	}
370	else
371	{
372	tree base = get_base_address (t);
373	if (base && DECL_P (base))
374	TREE_ADDRESSABLE (base) = 1;
375	t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
376	}
377
378	if (type && natural_type != type)
379	t = convert (type, t);
380
381	return t;
382	}
383
384
385	static tree
386	get_array_span (tree type, tree decl)
387	{
388	tree span;
389
390	/* Component references are guaranteed to have a reliable value for
391	'span'. Likewise indirect references since they emerge from the
392	conversion of a CFI descriptor or the hidden dummy descriptor. */
393	if (TREE_CODE (decl) == COMPONENT_REF
394	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
395	return gfc_conv_descriptor_span_get (decl);
396	else if (INDIRECT_REF_P (decl)
397	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
398	return gfc_conv_descriptor_span_get (decl);
399
400	/* Return the span for deferred character length array references. */
401	if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type))
402	{
403	if (TREE_CODE (decl) == PARM_DECL)
404	decl = build_fold_indirect_ref_loc (input_location, decl);
405	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
406	span = gfc_conv_descriptor_span_get (decl);
407	else
408	span = gfc_get_character_len_in_bytes (type);
409	span = (span && !integer_zerop (span))
410	? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE);
411	}
412	/* Likewise for class array or pointer array references. */
413	else if (TREE_CODE (decl) == FIELD_DECL
414	|| VAR_OR_FUNCTION_DECL_P (decl)
415	|| TREE_CODE (decl) == PARM_DECL)
416	{
417	if (GFC_DECL_CLASS (decl))
418	{
419	/* When a temporary is in place for the class array, then the
420	original class' declaration is stored in the saved
421	descriptor. */
422	if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
423	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
424	else
425	{
426	/* Allow for dummy arguments and other good things. */
427	if (POINTER_TYPE_P (TREE_TYPE (decl)))
428	decl = build_fold_indirect_ref_loc (input_location, decl);
429
430	/* Check if '_data' is an array descriptor. If it is not,
431	the array must be one of the components of the class
432	object, so return a null span. */
433	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
434	gfc_class_data_get (decl))))
435	return NULL_TREE;
436	}
437	span = gfc_class_vtab_size_get (decl);
438	/* For unlimited polymorphic entities then _len component needs
439	to be multiplied with the size. */
440	span = gfc_resize_class_size_with_len (NULL, decl, span);
441	}
442	else if (GFC_DECL_PTR_ARRAY_P (decl))
443	{
444	if (TREE_CODE (decl) == PARM_DECL)
445	decl = build_fold_indirect_ref_loc (input_location, decl);
446	span = gfc_conv_descriptor_span_get (decl);
447	}
448	else
449	span = NULL_TREE;
450	}
451	else
452	span = NULL_TREE;
453
454	return span;
455	}
456
457
458	tree
459	gfc_build_spanned_array_ref (tree base, tree offset, tree span)
460	{
461	tree type;
462	tree tmp;
463	type = TREE_TYPE (TREE_TYPE (base));
464	offset = fold_build2_loc (input_location, MULT_EXPR,
465	gfc_array_index_type,
466	offset, span);
467	tmp = gfc_build_addr_expr (type: pvoid_type_node, t: base);
468	tmp = fold_build_pointer_plus_loc (loc: input_location, ptr: tmp, off: offset);
469	tmp = fold_convert (build_pointer_type (type), tmp);
470	if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
471	|| !TYPE_STRING_FLAG (type))
472	tmp = build_fold_indirect_ref_loc (input_location, tmp);
473	return tmp;
474	}
475
476
477	/* Build an ARRAY_REF with its natural type.
478	NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative,
479	and thus that an ARRAY_REF can safely be generated. If it’s false, we
480	have to play it safe and use pointer arithmetic. */
481
482	tree
483	gfc_build_array_ref (tree base, tree offset, tree decl,
484	bool non_negative_offset, tree vptr)
485	{
486	tree type = TREE_TYPE (base);
487	tree span = NULL_TREE;
488
489	if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
490	{
491	gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
492
493	return fold_convert (TYPE_MAIN_VARIANT (type), base);
494	}
495
496	/* Scalar coarray, there is nothing to do. */
497	if (TREE_CODE (type) != ARRAY_TYPE)
498	{
499	gcc_assert (decl == NULL_TREE);
500	gcc_assert (integer_zerop (offset));
501	return base;
502	}
503
504	type = TREE_TYPE (type);
505
506	if (DECL_P (base))
507	TREE_ADDRESSABLE (base) = 1;
508
509	/* Strip NON_LVALUE_EXPR nodes. */
510	STRIP_TYPE_NOPS (offset);
511
512	/* If decl or vptr are non-null, pointer arithmetic for the array reference
513	is likely. Generate the 'span' for the array reference. */
514	if (vptr)
515	{
516	span = gfc_vptr_size_get (vptr);
517
518	/* Check if this is an unlimited polymorphic object carrying a character
519	payload. In this case, the 'len' field is non-zero. */
520	if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
521	span = gfc_resize_class_size_with_len (NULL, decl, span);
522	}
523	else if (decl)
524	span = get_array_span (type, decl);
525
526	/* If a non-null span has been generated reference the element with
527	pointer arithmetic. */
528	if (span != NULL_TREE)
529	return gfc_build_spanned_array_ref (base, offset, span);
530	/* Else use a straightforward array reference if possible. */
531	else if (non_negative_offset)
532	return build4_loc (loc: input_location, code: ARRAY_REF, type, arg0: base, arg1: offset,
533	NULL_TREE, NULL_TREE);
534	/* Otherwise use pointer arithmetic. */
535	else
536	{
537	gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE);
538	tree min = NULL_TREE;
539	if (TYPE_DOMAIN (TREE_TYPE (base))
540	&& !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)))))
541	min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)));
542
543	tree zero_based_index
544	= min ? fold_build2_loc (input_location, MINUS_EXPR,
545	gfc_array_index_type,
546	fold_convert (gfc_array_index_type, offset),
547	fold_convert (gfc_array_index_type, min))
548	: fold_convert (gfc_array_index_type, offset);
549
550	tree elt_size = fold_convert (gfc_array_index_type,
551	TYPE_SIZE_UNIT (type));
552
553	tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR,
554	gfc_array_index_type,
555	zero_based_index, elt_size);
556
557	tree base_addr = gfc_build_addr_expr (type: pvoid_type_node, t: base);
558
559	tree ptr = fold_build_pointer_plus_loc (loc: input_location, ptr: base_addr,
560	off: offset_bytes);
561	return build1_loc (loc: input_location, code: INDIRECT_REF, type,
562	fold_convert (build_pointer_type (type), ptr));
563	}
564	}
565
566
567	/* Generate a call to print a runtime error possibly including multiple
568	arguments and a locus. */
569
570	static tree
571	trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid,
572	va_list ap)
573	{
574	stmtblock_t block;
575	tree tmp;
576	tree arg, arg2;
577	tree *argarray;
578	tree fntype;
579	char *message;
580	const char *p;
581	int line, nargs, i;
582	location_t loc;
583
584	/* Compute the number of extra arguments from the format string. */
585	for (p = msgid, nargs = 0; *p; p++)
586	if (*p == '%')
587	{
588	p++;
589	if (*p != '%')
590	nargs++;
591	}
592
593	/* The code to generate the error. */
594	gfc_start_block (block: &block);
595
596	if (where)
597	{
598	line = LOCATION_LINE (where->lb->location);
599	message = xasprintf ("At line %d of file %s", line,
600	where->lb->file->filename);
601	}
602	else
603	message = xasprintf ("In file '%s', around line %d",
604	gfc_source_file, LOCATION_LINE (input_location) + 1);
605
606	arg = gfc_build_addr_expr (type: pchar_type_node,
607	t: gfc_build_localized_cstring_const (message));
608	free (ptr: message);
609
610	message = xasprintf ("%s", _(msgid));
611	arg2 = gfc_build_addr_expr (type: pchar_type_node,
612	t: gfc_build_localized_cstring_const (message));
613	free (ptr: message);
614
615	/* Build the argument array. */
616	argarray = XALLOCAVEC (tree, nargs + 2);
617	argarray[0] = arg;
618	argarray[1] = arg2;
619	for (i = 0; i < nargs; i++)
620	argarray[2 + i] = va_arg (ap, tree);
621
622	/* Build the function call to runtime_(warning,error)_at; because of the
623	variable number of arguments, we can't use build_call_expr_loc dinput_location,
624	irectly. */
625	fntype = TREE_TYPE (errorfunc);
626
627	loc = where ? gfc_get_location (loc: where) : input_location;
628	tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
629	fold_build1_loc (loc, ADDR_EXPR,
630	build_pointer_type (fntype),
631	errorfunc),
632	nargs + 2, argarray);
633	gfc_add_expr_to_block (&block, tmp);
634
635	return gfc_finish_block (stmtblock: &block);
636	}
637
638
639	tree
640	gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
641	{
642	va_list ap;
643	tree result;
644
645	va_start (ap, msgid);
646	result = trans_runtime_error_vararg (errorfunc: error
647	? gfor_fndecl_runtime_error_at
648	: gfor_fndecl_runtime_warning_at,
649	where, msgid, ap);
650	va_end (ap);
651	return result;
652	}
653
654
655	/* Generate a runtime error if COND is true. */
656
657	void
658	gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
659	locus * where, const char * msgid, ...)
660	{
661	va_list ap;
662	stmtblock_t block;
663	tree body;
664	tree tmp;
665	tree tmpvar = NULL;
666
667	if (integer_zerop (cond))
668	return;
669
670	if (once)
671	{
672	tmpvar = gfc_create_var (boolean_type_node, prefix: "print_warning");
673	TREE_STATIC (tmpvar) = 1;
674	DECL_INITIAL (tmpvar) = boolean_true_node;
675	gfc_add_expr_to_block (pblock, tmpvar);
676	}
677
678	gfc_start_block (block: &block);
679
680	/* For error, runtime_error_at already implies PRED_NORETURN. */
681	if (!error && once)
682	gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
683	NOT_TAKEN));
684
685	/* The code to generate the error. */
686	va_start (ap, msgid);
687	gfc_add_expr_to_block (&block,
688	trans_runtime_error_vararg
689	(errorfunc: error ? gfor_fndecl_runtime_error_at
690	: gfor_fndecl_runtime_warning_at,
691	where, msgid, ap));
692	va_end (ap);
693
694	if (once)
695	gfc_add_modify (pblock: &block, lhs: tmpvar, boolean_false_node);
696
697	body = gfc_finish_block (stmtblock: &block);
698
699	if (integer_onep (cond))
700	{
701	gfc_add_expr_to_block (pblock, body);
702	}
703	else
704	{
705	if (once)
706	cond = fold_build2_loc (gfc_get_location (loc: where), TRUTH_AND_EXPR,
707	boolean_type_node, tmpvar,
708	fold_convert (boolean_type_node, cond));
709
710	tmp = fold_build3_loc (gfc_get_location (loc: where), COND_EXPR, void_type_node,
711	cond, body,
712	build_empty_stmt (gfc_get_location (loc: where)));
713	gfc_add_expr_to_block (pblock, tmp);
714	}
715	}
716
717
718	static tree
719	trans_os_error_at (locus* where, const char* msgid, ...)
720	{
721	va_list ap;
722	tree result;
723
724	va_start (ap, msgid);
725	result = trans_runtime_error_vararg (errorfunc: gfor_fndecl_os_error_at,
726	where, msgid, ap);
727	va_end (ap);
728	return result;
729	}
730
731
732
733	/* Call malloc to allocate size bytes of memory, with special conditions:
734	+ if size == 0, return a malloced area of size 1,
735	+ if malloc returns NULL, issue a runtime error. */
736	tree
737	gfc_call_malloc (stmtblock_t * block, tree type, tree size)
738	{
739	tree tmp, malloc_result, null_result, res, malloc_tree;
740	stmtblock_t block2;
741
742	/* Create a variable to hold the result. */
743	res = gfc_create_var (type: prvoid_type_node, NULL);
744
745	/* Call malloc. */
746	gfc_start_block (block: &block2);
747
748	if (size == NULL_TREE)
749	size = build_int_cst (size_type_node, 1);
750
751	size = fold_convert (size_type_node, size);
752	size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
753	build_int_cst (size_type_node, 1));
754
755	malloc_tree = builtin_decl_explicit (fncode: BUILT_IN_MALLOC);
756	gfc_add_modify (pblock: &block2, lhs: res,
757	fold_convert (prvoid_type_node,
758	build_call_expr_loc (input_location,
759	malloc_tree, 1, size)));
760
761	/* Optionally check whether malloc was successful. */
762	if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
763	{
764	null_result = fold_build2_loc (input_location, EQ_EXPR,
765	logical_type_node, res,
766	build_int_cst (pvoid_type_node, 0));
767	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
768	null_result,
769	trans_os_error_at (NULL,
770	msgid: "Error allocating %lu bytes",
771	fold_convert
772	(long_unsigned_type_node,
773	size)),
774	build_empty_stmt (input_location));
775	gfc_add_expr_to_block (&block2, tmp);
776	}
777
778	malloc_result = gfc_finish_block (stmtblock: &block2);
779	gfc_add_expr_to_block (block, malloc_result);
780
781	if (type != NULL)
782	res = fold_convert (type, res);
783	return res;
784	}
785
786
787	/* Allocate memory, using an optional status argument.
788
789	This function follows the following pseudo-code:
790
791	void *
792	allocate (size_t size, integer_type stat)
793	{
794	void *newmem;
795
796	if (stat requested)
797	stat = 0;
798
799	newmem = malloc (MAX (size, 1));
800	if (newmem == NULL)
801	{
802	if (stat)
803	*stat = LIBERROR_NO_MEMORY;
804	else
805	runtime_error ("Allocation would exceed memory limit");
806	}
807	return newmem;
808	} */
809	void
810	gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
811	tree size, tree status)
812	{
813	tree tmp, error_cond;
814	stmtblock_t on_error;
815	tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
816
817	/* If successful and stat= is given, set status to 0. */
818	if (status != NULL_TREE)
819	gfc_add_expr_to_block (block,
820	fold_build2_loc (input_location, MODIFY_EXPR, status_type,
821	status, build_int_cst (status_type, 0)));
822
823	/* The allocation itself. */
824	size = fold_convert (size_type_node, size);
825	gfc_add_modify (pblock: block, lhs: pointer,
826	fold_convert (TREE_TYPE (pointer),
827	build_call_expr_loc (input_location,
828	builtin_decl_explicit (BUILT_IN_MALLOC), 1,
829	fold_build2_loc (input_location,
830	MAX_EXPR, size_type_node, size,
831	build_int_cst (size_type_node, 1)))));
832
833	/* What to do in case of error. */
834	gfc_start_block (block: &on_error);
835	if (status != NULL_TREE)
836	{
837	tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
838	build_int_cst (status_type, LIBERROR_NO_MEMORY));
839	gfc_add_expr_to_block (&on_error, tmp);
840	}
841	else
842	{
843	/* Here, os_error_at already implies PRED_NORETURN. */
844	tree lusize = fold_convert (long_unsigned_type_node, size);
845	tmp = trans_os_error_at (NULL, msgid: "Error allocating %lu bytes", lusize);
846	gfc_add_expr_to_block (&on_error, tmp);
847	}
848
849	error_cond = fold_build2_loc (input_location, EQ_EXPR,
850	logical_type_node, pointer,
851	build_int_cst (prvoid_type_node, 0));
852	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
853	gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
854	gfc_finish_block (stmtblock: &on_error),
855	build_empty_stmt (input_location));
856
857	gfc_add_expr_to_block (block, tmp);
858	}
859
860
861	/* Allocate memory, using an optional status argument.
862
863	This function follows the following pseudo-code:
864
865	void *
866	allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
867	{
868	void *newmem;
869
870	newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
871	return newmem;
872	} */
873	void
874	gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
875	tree token, tree status, tree errmsg, tree errlen,
876	gfc_coarray_regtype alloc_type)
877	{
878	tree tmp, pstat;
879
880	gcc_assert (token != NULL_TREE);
881
882	/* The allocation itself. */
883	if (status == NULL_TREE)
884	pstat = null_pointer_node;
885	else
886	pstat = gfc_build_addr_expr (NULL_TREE, t: status);
887
888	if (errmsg == NULL_TREE)
889	{
890	gcc_assert(errlen == NULL_TREE);
891	errmsg = null_pointer_node;
892	errlen = build_int_cst (integer_type_node, 0);
893	}
894
895	size = fold_convert (size_type_node, size);
896	tmp = build_call_expr_loc (input_location,
897	gfor_fndecl_caf_register, 7,
898	fold_build2_loc (input_location,
899	MAX_EXPR, size_type_node, size, size_one_node),
900	build_int_cst (integer_type_node, alloc_type),
901	token, gfc_build_addr_expr (type: pvoid_type_node, t: pointer),
902	pstat, errmsg, errlen);
903
904	gfc_add_expr_to_block (block, tmp);
905
906	/* It guarantees memory consistency within the same segment */
907	tmp = gfc_build_string_const (strlen (s: "memory")+1, "memory"),
908	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
909	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
910	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
911	ASM_VOLATILE_P (tmp) = 1;
912	gfc_add_expr_to_block (block, tmp);
913	}
914
915
916	/* Generate code for an ALLOCATE statement when the argument is an
917	allocatable variable. If the variable is currently allocated, it is an
918	error to allocate it again.
919
920	This function follows the following pseudo-code:
921
922	void *
923	allocate_allocatable (void *mem, size_t size, integer_type stat)
924	{
925	if (mem == NULL)
926	return allocate (size, stat);
927	else
928	{
929	if (stat)
930	stat = LIBERROR_ALLOCATION;
931	else
932	runtime_error ("Attempting to allocate already allocated variable");
933	}
934	}
935
936	expr must be set to the original expression being allocated for its locus
937	and variable name in case a runtime error has to be printed. */
938	void
939	gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
940	tree token, tree status, tree errmsg, tree errlen,
941	tree label_finish, gfc_expr* expr, int corank)
942	{
943	stmtblock_t alloc_block;
944	tree tmp, null_mem, alloc, error;
945	tree type = TREE_TYPE (mem);
946	symbol_attribute caf_attr;
947	bool need_assign = false, refs_comp = false;
948	gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
949
950	size = fold_convert (size_type_node, size);
951	null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
952	logical_type_node, mem,
953	build_int_cst (type, 0)),
954	PRED_FORTRAN_REALLOC);
955
956	/* If mem is NULL, we call gfc_allocate_using_malloc or
957	gfc_allocate_using_lib. */
958	gfc_start_block (block: &alloc_block);
959
960	if (flag_coarray == GFC_FCOARRAY_LIB)
961	caf_attr = gfc_caf_attr (expr, i: true, r: &refs_comp);
962
963	if (flag_coarray == GFC_FCOARRAY_LIB
964	&& (corank > 0 || caf_attr.codimension))
965	{
966	tree cond, sub_caf_tree;
967	gfc_se se;
968	bool compute_special_caf_types_size = false;
969
970	if (expr->ts.type == BT_DERIVED
971	&& expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
972	&& expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
973	{
974	compute_special_caf_types_size = true;
975	caf_alloc_type = GFC_CAF_LOCK_ALLOC;
976	}
977	else if (expr->ts.type == BT_DERIVED
978	&& expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
979	&& expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
980	{
981	compute_special_caf_types_size = true;
982	caf_alloc_type = GFC_CAF_EVENT_ALLOC;
983	}
984	else if (!caf_attr.coarray_comp && refs_comp)
985	/* Only allocatable components in a derived type coarray can be
986	allocate only. */
987	caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
988
989	gfc_init_se (&se, NULL);
990	sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
991	if (sub_caf_tree == NULL_TREE)
992	sub_caf_tree = token;
993
994	/* When mem is an array ref, then strip the .data-ref. */
995	if (TREE_CODE (mem) == COMPONENT_REF
996	&& !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
997	tmp = TREE_OPERAND (mem, 0);
998	else
999	tmp = mem;
1000
1001	if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
1002	&& TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
1003	&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1004	{
1005	symbol_attribute attr;
1006
1007	gfc_clear_attr (&attr);
1008	tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
1009	need_assign = true;
1010	}
1011	gfc_add_block_to_block (&alloc_block, &se.pre);
1012
1013	/* In the front end, we represent the lock variable as pointer. However,
1014	the FE only passes the pointer around and leaves the actual
1015	representation to the library. Hence, we have to convert back to the
1016	number of elements. */
1017	if (compute_special_caf_types_size)
1018	size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
1019	size, TYPE_SIZE_UNIT (ptr_type_node));
1020
1021	gfc_allocate_using_caf_lib (block: &alloc_block, pointer: tmp, size, token: sub_caf_tree,
1022	status, errmsg, errlen, alloc_type: caf_alloc_type);
1023	if (need_assign)
1024	gfc_add_modify (pblock: &alloc_block, lhs: mem, fold_convert (TREE_TYPE (mem),
1025	gfc_conv_descriptor_data_get (tmp)));
1026	if (status != NULL_TREE)
1027	{
1028	TREE_USED (label_finish) = 1;
1029	tmp = build1_v (GOTO_EXPR, label_finish);
1030	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1031	status, build_zero_cst (TREE_TYPE (status)));
1032	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1033	gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
1034	tmp, build_empty_stmt (input_location));
1035	gfc_add_expr_to_block (&alloc_block, tmp);
1036	}
1037	}
1038	else
1039	gfc_allocate_using_malloc (block: &alloc_block, pointer: mem, size, status);
1040
1041	alloc = gfc_finish_block (stmtblock: &alloc_block);
1042
1043	/* If mem is not NULL, we issue a runtime error or set the
1044	status variable. */
1045	if (expr)
1046	{
1047	tree varname;
1048
1049	gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
1050	varname = gfc_build_cstring_const (expr->symtree->name);
1051	varname = gfc_build_addr_expr (type: pchar_type_node, t: varname);
1052
1053	error = gfc_trans_runtime_error (error: true, where: &expr->where,
1054	msgid: "Attempting to allocate already"
1055	" allocated variable '%s'",
1056	varname);
1057	}
1058	else
1059	error = gfc_trans_runtime_error (error: true, NULL,
1060	msgid: "Attempting to allocate already allocated"
1061	" variable");
1062
1063	if (status != NULL_TREE)
1064	{
1065	tree status_type = TREE_TYPE (status);
1066
1067	error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1068	status, build_int_cst (status_type, LIBERROR_ALLOCATION));
1069	}
1070
1071	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
1072	error, alloc);
1073	gfc_add_expr_to_block (block, tmp);
1074	}
1075
1076
1077	/* Free a given variable. */
1078
1079	tree
1080	gfc_call_free (tree var)
1081	{
1082	return build_call_expr_loc (input_location,
1083	builtin_decl_explicit (fncode: BUILT_IN_FREE),
1084	1, fold_convert (pvoid_type_node, var));
1085	}
1086
1087
1088	/* Generate the data reference to the finalization procedure pointer associated
1089	with the expression passed as argument in EXPR. */
1090
1091	static void
1092	get_final_proc_ref (gfc_se *se, gfc_expr *expr, tree class_container)
1093	{
1094	gfc_expr *final_wrapper = NULL;
1095
1096	gcc_assert (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS);
1097
1098	bool using_class_container = false;
1099	if (expr->ts.type == BT_DERIVED)
1100	gfc_is_finalizable (expr->ts.u.derived, &final_wrapper);
1101	else if (class_container)
1102	{
1103	using_class_container = true;
1104	se->expr = gfc_class_vtab_final_get (class_container);
1105	}
1106	else
1107	{
1108	final_wrapper = gfc_copy_expr (expr);
1109	gfc_add_vptr_component (final_wrapper);
1110	gfc_add_final_component (final_wrapper);
1111	}
1112
1113	if (!using_class_container)
1114	{
1115	gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
1116
1117	gfc_conv_expr (se, expr: final_wrapper);
1118	}
1119
1120	if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
1121	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1122	}
1123
1124
1125	/* Generate the code to obtain the value of the element size of the expression
1126	passed as argument in EXPR. */
1127
1128	static void
1129	get_elem_size (gfc_se *se, gfc_expr *expr, tree class_container)
1130	{
1131	gcc_assert (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS);
1132
1133	if (expr->ts.type == BT_DERIVED)
1134	{
1135	se->expr = gfc_typenode_for_spec (&expr->ts);
1136	se->expr = TYPE_SIZE_UNIT (se->expr);
1137	se->expr = fold_convert (gfc_array_index_type, se->expr);
1138	}
1139	else if (class_container)
1140	se->expr = gfc_class_vtab_size_get (class_container);
1141	else
1142	{
1143	gfc_expr *class_size = gfc_copy_expr (expr);
1144	gfc_add_vptr_component (class_size);
1145	gfc_add_size_component (class_size);
1146
1147	gfc_conv_expr (se, expr: class_size);
1148	gcc_assert (se->post.head == NULL_TREE);
1149	}
1150	}
1151
1152
1153	/* Generate the data reference (array) descriptor corresponding to the
1154	expression passed as argument in VAR. */
1155
1156	static void
1157	get_var_descr (gfc_se *se, gfc_expr *var, tree class_container)
1158	{
1159	gfc_se tmp_se;
1160
1161	gcc_assert (var);
1162
1163	gfc_init_se (&tmp_se, NULL);
1164
1165	if (var->ts.type == BT_DERIVED)
1166	{
1167	tmp_se.want_pointer = 1;
1168	if (var->rank)
1169	{
1170	tmp_se.descriptor_only = 1;
1171	gfc_conv_expr_descriptor (&tmp_se, var);
1172	}
1173	else
1174	gfc_conv_expr (se: &tmp_se, expr: var);
1175	}
1176	else if (class_container)
1177	tmp_se.expr = gfc_class_data_get (class_container);
1178	else
1179	{
1180	gfc_expr *array_expr;
1181
1182	array_expr = gfc_copy_expr (var);
1183
1184	tmp_se.want_pointer = 1;
1185	if (array_expr->rank)
1186	{
1187	gfc_add_class_array_ref (array_expr);
1188	tmp_se.descriptor_only = 1;
1189	gfc_conv_expr_descriptor (&tmp_se, array_expr);
1190	}
1191	else
1192	{
1193	gfc_add_data_component (array_expr);
1194	gfc_conv_expr (se: &tmp_se, expr: array_expr);
1195	gcc_assert (tmp_se.post.head == NULL_TREE);
1196	}
1197	gfc_free_expr (array_expr);
1198	}
1199
1200	if (var->rank == 0)
1201	{
1202	if (var->ts.type == BT_DERIVED
1203	|| !gfc_is_coarray (var))
1204	{
1205	/* No copy back needed, hence set attr's allocatable/pointer
1206	to zero. */
1207	symbol_attribute attr;
1208	gfc_clear_attr (&attr);
1209	tmp_se.expr = gfc_conv_scalar_to_descriptor (&tmp_se, tmp_se.expr,
1210	attr);
1211	}
1212	gcc_assert (tmp_se.post.head == NULL_TREE);
1213	}
1214
1215	if (!POINTER_TYPE_P (TREE_TYPE (tmp_se.expr)))
1216	tmp_se.expr = gfc_build_addr_expr (NULL, t: tmp_se.expr);
1217
1218	gfc_add_block_to_block (&se->pre, &tmp_se.pre);
1219	gfc_add_block_to_block (&se->post, &tmp_se.post);
1220	se->expr = tmp_se.expr;
1221	}
1222
1223
1224	static void
1225	get_vptr (gfc_se *se, gfc_expr *expr, tree class_container)
1226	{
1227	if (class_container)
1228	se->expr = gfc_class_vptr_get (class_container);
1229	else
1230	{
1231	gfc_expr *vptr_expr = gfc_copy_expr (expr);
1232	gfc_add_vptr_component (vptr_expr);
1233
1234	gfc_se tmp_se;
1235	gfc_init_se (&tmp_se, NULL);
1236	tmp_se.want_pointer = 1;
1237	gfc_conv_expr (se: &tmp_se, expr: vptr_expr);
1238	gfc_free_expr (vptr_expr);
1239
1240	gfc_add_block_to_block (&se->pre, &tmp_se.pre);
1241	gfc_add_block_to_block (&se->post, &tmp_se.post);
1242	se->expr = tmp_se.expr;
1243	}
1244	}
1245
1246
1247	bool
1248	gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
1249	bool fini_coarray)
1250	{
1251	gfc_se se;
1252	stmtblock_t block2;
1253	tree final_fndecl, size, array, tmp, cond;
1254	symbol_attribute attr;
1255	gfc_expr *final_expr = NULL;
1256
1257	if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
1258	return false;
1259
1260	gfc_init_block (block: &block2);
1261
1262	if (comp->ts.type == BT_DERIVED)
1263	{
1264	if (comp->attr.pointer)
1265	return false;
1266
1267	gfc_is_finalizable (comp->ts.u.derived, &final_expr);
1268	if (!final_expr)
1269	return false;
1270
1271	gfc_init_se (&se, NULL);
1272	gfc_conv_expr (se: &se, expr: final_expr);
1273	final_fndecl = se.expr;
1274	size = gfc_typenode_for_spec (&comp->ts);
1275	size = TYPE_SIZE_UNIT (size);
1276	size = fold_convert (gfc_array_index_type, size);
1277
1278	array = decl;
1279	}
1280	else /* comp->ts.type == BT_CLASS. */
1281	{
1282	if (CLASS_DATA (comp)->attr.class_pointer)
1283	return false;
1284
1285	gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1286	final_fndecl = gfc_class_vtab_final_get (decl);
1287	size = gfc_class_vtab_size_get (decl);
1288	array = gfc_class_data_get (decl);
1289	}
1290
1291	if (comp->attr.allocatable
1292	|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1293	{
1294	tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1295	? gfc_conv_descriptor_data_get (array) : array;
1296	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1297	tmp, fold_convert (TREE_TYPE (tmp),
1298	null_pointer_node));
1299	}
1300	else
1301	cond = logical_true_node;
1302
1303	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1304	{
1305	gfc_clear_attr (&attr);
1306	gfc_init_se (&se, NULL);
1307	array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1308	gfc_add_block_to_block (&block2, &se.pre);
1309	gcc_assert (se.post.head == NULL_TREE);
1310	}
1311
1312	if (!POINTER_TYPE_P (TREE_TYPE (array)))
1313	array = gfc_build_addr_expr (NULL, t: array);
1314
1315	if (!final_expr)
1316	{
1317	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1318	final_fndecl,
1319	fold_convert (TREE_TYPE (final_fndecl),
1320	null_pointer_node));
1321	cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1322	logical_type_node, cond, tmp);
1323	}
1324
1325	if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1326	final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1327
1328	tmp = build_call_expr_loc (input_location,
1329	final_fndecl, 3, array,
1330	size, fini_coarray ? boolean_true_node
1331	: boolean_false_node);
1332	gfc_add_expr_to_block (&block2, tmp);
1333	tmp = gfc_finish_block (stmtblock: &block2);
1334
1335	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1336	build_empty_stmt (input_location));
1337	gfc_add_expr_to_block (block, tmp);
1338
1339	return true;
1340	}
1341
1342
1343	/* Add a call to the finalizer, using the passed *expr. Returns
1344	true when a finalizer call has been inserted. */
1345
1346	bool
1347	gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2,
1348	tree class_container)
1349	{
1350	tree tmp;
1351	gfc_ref *ref;
1352	gfc_expr *expr;
1353
1354	if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1355	return false;
1356
1357	/* Finalization of these temporaries is made by explicit calls in
1358	resolve.cc(generate_component_assignments). */
1359	if (expr2->expr_type == EXPR_VARIABLE
1360	&& expr2->symtree->n.sym->name[0] == '_'
1361	&& expr2->ts.type == BT_DERIVED
1362	&& expr2->ts.u.derived->attr.defined_assign_comp)
1363	return false;
1364
1365	if (expr2->ts.type == BT_DERIVED
1366	&& !gfc_is_finalizable (expr2->ts.u.derived, NULL))
1367	return false;
1368
1369	/* If we have a class array, we need go back to the class
1370	container. */
1371	expr = gfc_copy_expr (expr2);
1372
1373	if (expr->ref && expr->ref->next && !expr->ref->next->next
1374	&& expr->ref->next->type == REF_ARRAY
1375	&& expr->ref->type == REF_COMPONENT
1376	&& strcmp (s1: expr->ref->u.c.component->name, s2: "_data") == 0)
1377	{
1378	gfc_free_ref_list (expr->ref);
1379	expr->ref = NULL;
1380	}
1381	else
1382	for (ref = expr->ref; ref; ref = ref->next)
1383	if (ref->next && ref->next->next && !ref->next->next->next
1384	&& ref->next->next->type == REF_ARRAY
1385	&& ref->next->type == REF_COMPONENT
1386	&& strcmp (s1: ref->next->u.c.component->name, s2: "_data") == 0)
1387	{
1388	gfc_free_ref_list (ref->next);
1389	ref->next = NULL;
1390	}
1391
1392	if (expr->ts.type == BT_CLASS
1393	&& !expr2->rank
1394	&& !expr2->ref
1395	&& CLASS_DATA (expr2->symtree->n.sym)->as)
1396	expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1397
1398	stmtblock_t tmp_block;
1399	gfc_start_block (block: &tmp_block);
1400
1401	gfc_se final_se;
1402	gfc_init_se (&final_se, NULL);
1403	get_final_proc_ref (se: &final_se, expr, class_container);
1404	gfc_add_block_to_block (block, &final_se.pre);
1405
1406	gfc_se size_se;
1407	gfc_init_se (&size_se, NULL);
1408	get_elem_size (se: &size_se, expr, class_container);
1409	gfc_add_block_to_block (&tmp_block, &size_se.pre);
1410
1411	gfc_se desc_se;
1412	gfc_init_se (&desc_se, NULL);
1413	get_var_descr (se: &desc_se, var: expr, class_container);
1414	gfc_add_block_to_block (&tmp_block, &desc_se.pre);
1415
1416	tmp = build_call_expr_loc (input_location, final_se.expr, 3,
1417	desc_se.expr, size_se.expr,
1418	boolean_false_node);
1419
1420	gfc_add_expr_to_block (&tmp_block, tmp);
1421
1422	gfc_add_block_to_block (&tmp_block, &desc_se.post);
1423	gfc_add_block_to_block (&tmp_block, &size_se.post);
1424
1425	tmp = gfc_finish_block (stmtblock: &tmp_block);
1426
1427	if (expr->ts.type == BT_CLASS
1428	&& !gfc_is_finalizable (expr->ts.u.derived, NULL))
1429	{
1430	tree cond;
1431
1432	tree ptr = gfc_build_addr_expr (NULL_TREE, t: final_se.expr);
1433
1434	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1435	ptr, build_int_cst (TREE_TYPE (ptr), 0));
1436
1437	/* For CLASS(*) not only sym->_vtab->_final can be NULL
1438	but already sym->_vtab itself. */
1439	if (UNLIMITED_POLY (expr))
1440	{
1441	tree cond2;
1442	gfc_se vptr_se;
1443
1444	gfc_init_se (&vptr_se, NULL);
1445	get_vptr (se: &vptr_se, expr, class_container);
1446
1447	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1448	vptr_se.expr,
1449	build_int_cst (TREE_TYPE (vptr_se.expr), 0));
1450	cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1451	logical_type_node, cond2, cond);
1452	}
1453
1454	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1455	cond, tmp, build_empty_stmt (input_location));
1456	}
1457
1458	gfc_add_expr_to_block (block, tmp);
1459	gfc_add_block_to_block (block, &final_se.post);
1460
1461	return true;
1462	}
1463
1464
1465	/* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
1466	(10.2.1.3), if the variable is not an unallocated allocatable variable,
1467	it is finalized after evaluation of expr and before the definition of
1468	the variable. If the variable is an allocated allocatable variable, or
1469	has an allocated allocatable subobject, that would be deallocated by
1470	intrinsic assignment, the finalization occurs before the deallocation */
1471
1472	bool
1473	gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
1474	{
1475	symbol_attribute lhs_attr;
1476	tree final_expr;
1477	tree ptr;
1478	tree cond;
1479	gfc_se se;
1480	gfc_symbol *sym = expr1->symtree->n.sym;
1481	gfc_ref *ref = expr1->ref;
1482	stmtblock_t final_block;
1483	gfc_init_block (block: &final_block);
1484	gfc_expr *finalize_expr;
1485	bool class_array_ref;
1486
1487	/* We have to exclude vtable procedures (_copy and _final especially), uses
1488	of gfc_trans_assignment_1 in initialization and allocation before trying
1489	to build a final call. */
1490	if (!expr1->must_finalize
1491	|| sym->attr.artificial
1492	|| sym->ns->proc_name->attr.artificial
1493	|| init_flag)
1494	return false;
1495
1496	class_array_ref = ref && ref->type == REF_COMPONENT
1497	&& !strcmp (s1: ref->u.c.component->name, s2: "_data")
1498	&& ref->next && ref->next->type == REF_ARRAY
1499	&& !ref->next->next;
1500
1501	if (class_array_ref)
1502	{
1503	finalize_expr = gfc_lval_expr_from_sym (sym);
1504	finalize_expr->must_finalize = 1;
1505	ref = NULL;
1506	}
1507	else
1508	finalize_expr = gfc_copy_expr (expr1);
1509
1510	/* F2018 7.5.6.2: Only finalizable entities are finalized. */
1511	if (!(expr1->ts.type == BT_DERIVED
1512	&& gfc_is_finalizable (expr1->ts.u.derived, NULL))
1513	&& expr1->ts.type != BT_CLASS)
1514	return false;
1515
1516	if (!gfc_may_be_finalized (sym->ts))
1517	return false;
1518
1519	gfc_init_block (block: &final_block);
1520	bool finalizable = gfc_add_finalizer_call (block: &final_block, expr2: finalize_expr);
1521	gfc_free_expr (finalize_expr);
1522
1523	if (!finalizable)
1524	return false;
1525
1526	lhs_attr = gfc_expr_attr (expr1);
1527
1528	/* Check allocatable/pointer is allocated/associated. */
1529	if (lhs_attr.allocatable || lhs_attr.pointer)
1530	{
1531	if (expr1->ts.type == BT_CLASS)
1532	{
1533	ptr = gfc_get_class_from_gfc_expr (expr1);
1534	gcc_assert (ptr != NULL_TREE);
1535	ptr = gfc_class_data_get (ptr);
1536	if (lhs_attr.dimension)
1537	ptr = gfc_conv_descriptor_data_get (ptr);
1538	}
1539	else
1540	{
1541	gfc_init_se (&se, NULL);
1542	if (expr1->rank)
1543	{
1544	gfc_conv_expr_descriptor (&se, expr1);
1545	ptr = gfc_conv_descriptor_data_get (se.expr);
1546	}
1547	else
1548	{
1549	gfc_conv_expr (se: &se, expr: expr1);
1550	ptr = gfc_build_addr_expr (NULL_TREE, t: se.expr);
1551	}
1552	}
1553
1554	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1555	ptr, build_zero_cst (TREE_TYPE (ptr)));
1556	final_expr = build3_loc (loc: input_location, code: COND_EXPR, void_type_node,
1557	arg0: cond, arg1: gfc_finish_block (stmtblock: &final_block),
1558	arg2: build_empty_stmt (input_location));
1559	}
1560	else
1561	final_expr = gfc_finish_block (stmtblock: &final_block);
1562
1563	/* Check optional present. */
1564	if (sym->attr.optional)
1565	{
1566	cond = gfc_conv_expr_present (sym);
1567	final_expr = build3_loc (loc: input_location, code: COND_EXPR, void_type_node,
1568	arg0: cond, arg1: final_expr,
1569	arg2: build_empty_stmt (input_location));
1570	}
1571
1572	gfc_add_expr_to_block (&lse->finalblock, final_expr);
1573
1574	return true;
1575	}
1576
1577
1578	/* Finalize a TREE expression using the finalizer wrapper. The result is
1579	fixed in order to prevent repeated calls. */
1580
1581	void
1582	gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
1583	symbol_attribute attr, int rank)
1584	{
1585	tree vptr, final_fndecl, desc, tmp, size, is_final;
1586	tree data_ptr, data_null, cond;
1587	gfc_symbol *vtab;
1588	gfc_se post_se;
1589	bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
1590
1591	if (attr.pointer)
1592	return;
1593
1594	/* Derived type function results with components that have defined
1595	assignements are handled in resolve.cc(generate_component_assignments) */
1596	if (derived && (derived->attr.is_c_interop
1597	|| derived->attr.is_iso_c
1598	|| derived->attr.is_bind_c
1599	|| derived->attr.defined_assign_comp))
1600	return;
1601
1602	if (is_class)
1603	{
1604	if (!VAR_P (se->expr))
1605	{
1606	desc = gfc_evaluate_now (expr: se->expr, pblock: &se->pre);
1607	se->expr = desc;
1608	}
1609	desc = gfc_class_data_get (se->expr);
1610	vptr = gfc_class_vptr_get (se->expr);
1611	}
1612	else if (derived && gfc_is_finalizable (derived, NULL))
1613	{
1614	if (derived->attr.zero_comp && !rank)
1615	{
1616	/* Any attempt to assign zero length entities, causes the gimplifier
1617	all manner of problems. Instead, a variable is created to act as
1618	as the argument for the final call. */
1619	desc = gfc_create_var (TREE_TYPE (se->expr), prefix: "zero");
1620	}
1621	else if (se->direct_byref)
1622	{
1623	desc = gfc_evaluate_now (expr: se->expr, pblock: &se->finalblock);
1624	if (derived->attr.alloc_comp)
1625	{
1626	/* Need to copy allocated components and not finalize. */
1627	tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
1628	gfc_add_expr_to_block (&se->finalblock, tmp);
1629	}
1630	}
1631	else
1632	{
1633	desc = gfc_evaluate_now (expr: se->expr, pblock: &se->pre);
1634	se->expr = gfc_evaluate_now (expr: desc, pblock: &se->pre);
1635	if (derived->attr.alloc_comp)
1636	{
1637	/* Need to copy allocated components and not finalize. */
1638	tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
1639	gfc_add_expr_to_block (&se->pre, tmp);
1640	}
1641	}
1642
1643	vtab = gfc_find_derived_vtab (derived);
1644	if (vtab->backend_decl == NULL_TREE)
1645	vptr = gfc_get_symbol_decl (vtab);
1646	else
1647	vptr = vtab->backend_decl;
1648	vptr = gfc_build_addr_expr (NULL, t: vptr);
1649	}
1650	else
1651	return;
1652
1653	size = gfc_vptr_size_get (vptr);
1654	final_fndecl = gfc_vptr_final_get (vptr);
1655	is_final = fold_build2_loc (input_location, NE_EXPR,
1656	logical_type_node,
1657	final_fndecl,
1658	fold_convert (TREE_TYPE (final_fndecl),
1659	null_pointer_node));
1660
1661	final_fndecl = build_fold_indirect_ref_loc (input_location,
1662	final_fndecl);
1663	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
1664	{
1665	if (is_class)
1666	desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
1667	else
1668	{
1669	gfc_init_se (&post_se, NULL);
1670	desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
1671	gfc_add_expr_to_block (&se->pre, gfc_finish_block (stmtblock: &post_se.pre));
1672	}
1673	}
1674
1675	if (derived && derived->attr.zero_comp)
1676	{
1677	/* All the conditions below break down for zero length derived types. */
1678	tmp = build_call_expr_loc (input_location, final_fndecl, 3,
1679	gfc_build_addr_expr (NULL, t: desc),
1680	size, boolean_false_node);
1681	gfc_add_expr_to_block (&se->finalblock, tmp);
1682	return;
1683	}
1684
1685	if (!VAR_P (desc))
1686	{
1687	tmp = gfc_create_var (TREE_TYPE (desc), prefix: "res");
1688	if (se->direct_byref)
1689	gfc_add_modify (pblock: &se->finalblock, lhs: tmp, rhs: desc);
1690	else
1691	gfc_add_modify (pblock: &se->pre, lhs: tmp, rhs: desc);
1692	desc = tmp;
1693	}
1694
1695	data_ptr = gfc_conv_descriptor_data_get (desc);
1696	data_null = fold_convert (TREE_TYPE (data_ptr), null_pointer_node);
1697	cond = fold_build2_loc (input_location, NE_EXPR,
1698	logical_type_node, data_ptr, data_null);
1699	is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1700	logical_type_node, is_final, cond);
1701	tmp = build_call_expr_loc (input_location, final_fndecl, 3,
1702	gfc_build_addr_expr (NULL, t: desc),
1703	size, boolean_false_node);
1704	tmp = fold_build3_loc (input_location, COND_EXPR,
1705	void_type_node, is_final, tmp,
1706	build_empty_stmt (input_location));
1707
1708	if (is_class && se->ss && se->ss->loop)
1709	{
1710	gfc_add_expr_to_block (&se->loop->post, tmp);
1711	tmp = fold_build3_loc (input_location, COND_EXPR,
1712	void_type_node, cond,
1713	gfc_call_free (var: data_ptr),
1714	build_empty_stmt (input_location));
1715	gfc_add_expr_to_block (&se->loop->post, tmp);
1716	gfc_add_modify (pblock: &se->loop->post, lhs: data_ptr, rhs: data_null);
1717	}
1718	else
1719	{
1720	gfc_add_expr_to_block (&se->finalblock, tmp);
1721
1722	/* Let the scalarizer take care of freeing of temporary arrays. */
1723	if (attr.allocatable && !(se->loop && se->loop->temp_dim))
1724	{
1725	tmp = fold_build3_loc (input_location, COND_EXPR,
1726	void_type_node, cond,
1727	gfc_call_free (var: data_ptr),
1728	build_empty_stmt (input_location));
1729	gfc_add_expr_to_block (&se->finalblock, tmp);
1730	gfc_add_modify (pblock: &se->finalblock, lhs: data_ptr, rhs: data_null);
1731	}
1732	}
1733	}
1734
1735
1736	/* User-deallocate; we emit the code directly from the front-end, and the
1737	logic is the same as the previous library function:
1738
1739	void
1740	deallocate (void *pointer, GFC_INTEGER_4 * stat)
1741	{
1742	if (!pointer)
1743	{
1744	if (stat)
1745	*stat = 1;
1746	else
1747	runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1748	}
1749	else
1750	{
1751	free (pointer);
1752	if (stat)
1753	*stat = 0;
1754	}
1755	}
1756
1757	In this front-end version, status doesn't have to be GFC_INTEGER_4.
1758	Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1759	even when no status variable is passed to us (this is used for
1760	unconditional deallocation generated by the front-end at end of
1761	each procedure).
1762
1763	If a runtime-message is possible, `expr' must point to the original
1764	expression being deallocated for its locus and variable name.
1765
1766	For coarrays, "pointer" must be the array descriptor and not its
1767	"data" component.
1768
1769	COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1770	the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1771	analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1772	be deallocated. */
1773	tree
1774	gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1775	tree errlen, tree label_finish,
1776	bool can_fail, gfc_expr* expr,
1777	int coarray_dealloc_mode, tree class_container,
1778	tree add_when_allocated, tree caf_token)
1779	{
1780	stmtblock_t null, non_null;
1781	tree cond, tmp, error;
1782	tree status_type = NULL_TREE;
1783	tree token = NULL_TREE;
1784	gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1785
1786	if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
1787	{
1788	if (flag_coarray == GFC_FCOARRAY_LIB)
1789	{
1790	if (caf_token)
1791	token = caf_token;
1792	else
1793	{
1794	tree caf_type, caf_decl = pointer;
1795	pointer = gfc_conv_descriptor_data_get (caf_decl);
1796	caf_type = TREE_TYPE (caf_decl);
1797	STRIP_NOPS (pointer);
1798	if (GFC_DESCRIPTOR_TYPE_P (caf_type))
1799	token = gfc_conv_descriptor_token (caf_decl);
1800	else if (DECL_LANG_SPECIFIC (caf_decl)
1801	&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1802	token = GFC_DECL_TOKEN (caf_decl);
1803	else
1804	{
1805	gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1806	&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
1807	!= NULL_TREE);
1808	token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1809	}
1810	}
1811
1812	if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
1813	{
1814	bool comp_ref;
1815	if (expr && !gfc_caf_attr (expr, i: false, r: &comp_ref).coarray_comp
1816	&& comp_ref)
1817	caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1818	// else do a deregister as set by default.
1819	}
1820	else
1821	caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
1822	}
1823	else if (flag_coarray == GFC_FCOARRAY_SINGLE)
1824	pointer = gfc_conv_descriptor_data_get (pointer);
1825	}
1826	else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1827	pointer = gfc_conv_descriptor_data_get (pointer);
1828
1829	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1830	build_int_cst (TREE_TYPE (pointer), 0));
1831
1832	/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1833	we emit a runtime error. */
1834	gfc_start_block (block: &null);
1835	if (!can_fail)
1836	{
1837	tree varname;
1838
1839	gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1840
1841	varname = gfc_build_cstring_const (expr->symtree->name);
1842	varname = gfc_build_addr_expr (type: pchar_type_node, t: varname);
1843
1844	error = gfc_trans_runtime_error (error: true, where: &expr->where,
1845	msgid: "Attempt to DEALLOCATE unallocated '%s'",
1846	varname);
1847	}
1848	else
1849	error = build_empty_stmt (input_location);
1850
1851	if (status != NULL_TREE && !integer_zerop (status))
1852	{
1853	tree cond2;
1854
1855	status_type = TREE_TYPE (TREE_TYPE (status));
1856	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1857	status, build_int_cst (TREE_TYPE (status), 0));
1858	tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1859	fold_build1_loc (input_location, INDIRECT_REF,
1860	status_type, status),
1861	build_int_cst (status_type, 1));
1862	error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1863	cond2, tmp, error);
1864	}
1865
1866	gfc_add_expr_to_block (&null, error);
1867
1868	/* When POINTER is not NULL, we free it. */
1869	gfc_start_block (block: &non_null);
1870	if (add_when_allocated)
1871	gfc_add_expr_to_block (&non_null, add_when_allocated);
1872	gfc_add_finalizer_call (block: &non_null, expr2: expr, class_container);
1873	if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
1874	|| flag_coarray != GFC_FCOARRAY_LIB)
1875	{
1876	tmp = build_call_expr_loc (input_location,
1877	builtin_decl_explicit (fncode: BUILT_IN_FREE), 1,
1878	fold_convert (pvoid_type_node, pointer));
1879	gfc_add_expr_to_block (&non_null, tmp);
1880	gfc_add_modify (pblock: &non_null, lhs: pointer, rhs: build_int_cst (TREE_TYPE (pointer),
1881	0));
1882
1883	if (status != NULL_TREE && !integer_zerop (status))
1884	{
1885	/* We set STATUS to zero if it is present. */
1886	tree status_type = TREE_TYPE (TREE_TYPE (status));
1887	tree cond2;
1888
1889	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1890	status,
1891	build_int_cst (TREE_TYPE (status), 0));
1892	tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1893	fold_build1_loc (input_location, INDIRECT_REF,
1894	status_type, status),
1895	build_int_cst (status_type, 0));
1896	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1897	gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1898	tmp, build_empty_stmt (input_location));
1899	gfc_add_expr_to_block (&non_null, tmp);
1900	}
1901	}
1902	else
1903	{
1904	tree cond2, pstat = null_pointer_node;
1905
1906	if (errmsg == NULL_TREE)
1907	{
1908	gcc_assert (errlen == NULL_TREE);
1909	errmsg = null_pointer_node;
1910	errlen = build_zero_cst (integer_type_node);
1911	}
1912	else
1913	{
1914	gcc_assert (errlen != NULL_TREE);
1915	if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1916	errmsg = gfc_build_addr_expr (NULL_TREE, t: errmsg);
1917	}
1918
1919	if (status != NULL_TREE && !integer_zerop (status))
1920	{
1921	gcc_assert (status_type == integer_type_node);
1922	pstat = status;
1923	}
1924
1925	token = gfc_build_addr_expr (NULL_TREE, t: token);
1926	gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
1927	tmp = build_call_expr_loc (input_location,
1928	gfor_fndecl_caf_deregister, 5,
1929	token, build_int_cst (integer_type_node,
1930	caf_dereg_type),
1931	pstat, errmsg, errlen);
1932	gfc_add_expr_to_block (&non_null, tmp);
1933
1934	/* It guarantees memory consistency within the same segment */
1935	tmp = gfc_build_string_const (strlen (s: "memory")+1, "memory"),
1936	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
1937	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1938	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1939	ASM_VOLATILE_P (tmp) = 1;
1940	gfc_add_expr_to_block (&non_null, tmp);
1941
1942	if (status != NULL_TREE)
1943	{
1944	tree stat = build_fold_indirect_ref_loc (input_location, status);
1945	tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
1946	void_type_node, pointer,
1947	build_int_cst (TREE_TYPE (pointer),
1948	0));
1949
1950	TREE_USED (label_finish) = 1;
1951	tmp = build1_v (GOTO_EXPR, label_finish);
1952	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1953	stat, build_zero_cst (TREE_TYPE (stat)));
1954	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1955	gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1956	tmp, nullify);
1957	gfc_add_expr_to_block (&non_null, tmp);
1958	}
1959	else
1960	gfc_add_modify (pblock: &non_null, lhs: pointer, rhs: build_int_cst (TREE_TYPE (pointer),
1961	0));
1962	}
1963
1964	return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1965	gfc_finish_block (stmtblock: &null),
1966	gfc_finish_block (stmtblock: &non_null));
1967	}
1968
1969
1970	/* Generate code for deallocation of allocatable scalars (variables or
1971	components). Before the object itself is freed, any allocatable
1972	subcomponents are being deallocated. */
1973
1974	tree
1975	gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
1976	bool can_fail, gfc_expr* expr,
1977	gfc_typespec ts, tree class_container,
1978	bool coarray)
1979	{
1980	stmtblock_t null, non_null;
1981	tree cond, tmp, error;
1982	bool finalizable, comp_ref;
1983	gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1984
1985	if (coarray && expr && !gfc_caf_attr (expr, i: false, r: &comp_ref).coarray_comp
1986	&& comp_ref)
1987	caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1988
1989	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1990	build_int_cst (TREE_TYPE (pointer), 0));
1991
1992	/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1993	we emit a runtime error. */
1994	gfc_start_block (block: &null);
1995	if (!can_fail)
1996	{
1997	tree varname;
1998
1999	gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
2000
2001	varname = gfc_build_cstring_const (expr->symtree->name);
2002	varname = gfc_build_addr_expr (type: pchar_type_node, t: varname);
2003
2004	error = gfc_trans_runtime_error (error: true, where: &expr->where,
2005	msgid: "Attempt to DEALLOCATE unallocated '%s'",
2006	varname);
2007	}
2008	else
2009	error = build_empty_stmt (input_location);
2010
2011	if (status != NULL_TREE && !integer_zerop (status))
2012	{
2013	tree status_type = TREE_TYPE (TREE_TYPE (status));
2014	tree cond2;
2015
2016	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2017	status, build_int_cst (TREE_TYPE (status), 0));
2018	tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
2019	fold_build1_loc (input_location, INDIRECT_REF,
2020	status_type, status),
2021	build_int_cst (status_type, 1));
2022	error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2023	cond2, tmp, error);
2024	}
2025	gfc_add_expr_to_block (&null, error);
2026
2027	/* When POINTER is not NULL, we free it. */
2028	gfc_start_block (block: &non_null);
2029
2030	/* Free allocatable components. */
2031	finalizable = gfc_add_finalizer_call (block: &non_null, expr2: expr, class_container);
2032	if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
2033	{
2034	int caf_mode = coarray
2035	? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
2036	? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
2037	| GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
2038	| GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
2039	: 0;
2040	if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
2041	tmp = gfc_conv_descriptor_data_get (pointer);
2042	else
2043	tmp = build_fold_indirect_ref_loc (input_location, pointer);
2044	tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, cm: caf_mode);
2045	gfc_add_expr_to_block (&non_null, tmp);
2046	}
2047
2048	if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
2049	{
2050	tmp = build_call_expr_loc (input_location,
2051	builtin_decl_explicit (fncode: BUILT_IN_FREE), 1,
2052	fold_convert (pvoid_type_node, pointer));
2053	gfc_add_expr_to_block (&non_null, tmp);
2054
2055	if (status != NULL_TREE && !integer_zerop (status))
2056	{
2057	/* We set STATUS to zero if it is present. */
2058	tree status_type = TREE_TYPE (TREE_TYPE (status));
2059	tree cond2;
2060
2061	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2062	status,
2063	build_int_cst (TREE_TYPE (status), 0));
2064	tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
2065	fold_build1_loc (input_location, INDIRECT_REF,
2066	status_type, status),
2067	build_int_cst (status_type, 0));
2068	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2069	cond2, tmp, build_empty_stmt (input_location));
2070	gfc_add_expr_to_block (&non_null, tmp);
2071	}
2072	}
2073	else
2074	{
2075	tree token;
2076	tree pstat = null_pointer_node;
2077	gfc_se se;
2078
2079	gfc_init_se (&se, NULL);
2080	token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
2081	gcc_assert (token != NULL_TREE);
2082
2083	if (status != NULL_TREE && !integer_zerop (status))
2084	{
2085	gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
2086	pstat = status;
2087	}
2088
2089	tmp = build_call_expr_loc (input_location,
2090	gfor_fndecl_caf_deregister, 5,
2091	token, build_int_cst (integer_type_node,
2092	caf_dereg_type),
2093	pstat, null_pointer_node, integer_zero_node);
2094	gfc_add_expr_to_block (&non_null, tmp);
2095
2096	/* It guarantees memory consistency within the same segment. */
2097	tmp = gfc_build_string_const (strlen (s: "memory")+1, "memory");
2098	tmp = build5_loc (loc: input_location, code: ASM_EXPR, void_type_node,
2099	arg0: gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2100	arg3: tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2101	ASM_VOLATILE_P (tmp) = 1;
2102	gfc_add_expr_to_block (&non_null, tmp);
2103
2104	if (status != NULL_TREE)
2105	{
2106	tree stat = build_fold_indirect_ref_loc (input_location, status);
2107	tree cond2;
2108
2109	TREE_USED (label_finish) = 1;
2110	tmp = build1_v (GOTO_EXPR, label_finish);
2111	cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2112	stat, build_zero_cst (TREE_TYPE (stat)));
2113	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2114	gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
2115	tmp, build_empty_stmt (input_location));
2116	gfc_add_expr_to_block (&non_null, tmp);
2117	}
2118	}
2119
2120	return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
2121	gfc_finish_block (stmtblock: &null),
2122	gfc_finish_block (stmtblock: &non_null));
2123	}
2124
2125	/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
2126	following pseudo-code:
2127
2128	void *
2129	internal_realloc (void *mem, size_t size)
2130	{
2131	res = realloc (mem, size);
2132	if (!res && size != 0)
2133	_gfortran_os_error ("Allocation would exceed memory limit");
2134
2135	return res;
2136	} */
2137	tree
2138	gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
2139	{
2140	tree res, nonzero, null_result, tmp;
2141	tree type = TREE_TYPE (mem);
2142
2143	/* Only evaluate the size once. */
2144	size = save_expr (fold_convert (size_type_node, size));
2145
2146	/* Create a variable to hold the result. */
2147	res = gfc_create_var (type, NULL);
2148
2149	/* Call realloc and check the result. */
2150	tmp = build_call_expr_loc (input_location,
2151	builtin_decl_explicit (fncode: BUILT_IN_REALLOC), 2,
2152	fold_convert (pvoid_type_node, mem), size);
2153	gfc_add_modify (pblock: block, lhs: res, fold_convert (type, tmp));
2154	null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2155	res, build_int_cst (pvoid_type_node, 0));
2156	nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
2157	build_int_cst (size_type_node, 0));
2158	null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
2159	null_result, nonzero);
2160	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2161	null_result,
2162	trans_os_error_at (NULL,
2163	msgid: "Error reallocating to %lu bytes",
2164	fold_convert
2165	(long_unsigned_type_node, size)),
2166	build_empty_stmt (input_location));
2167	gfc_add_expr_to_block (block, tmp);
2168
2169	return res;
2170	}
2171
2172
2173	/* Add an expression to another one, either at the front or the back. */
2174
2175	static void
2176	add_expr_to_chain (tree* chain, tree expr, bool front)
2177	{
2178	if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
2179	return;
2180
2181	if (*chain)
2182	{
2183	if (TREE_CODE (*chain) != STATEMENT_LIST)
2184	{
2185	tree tmp;
2186
2187	tmp = *chain;
2188	*chain = NULL_TREE;
2189	append_to_statement_list (tmp, chain);
2190	}
2191
2192	if (front)
2193	{
2194	tree_stmt_iterator i;
2195
2196	i = tsi_start (t: *chain);
2197	tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
2198	}
2199	else
2200	append_to_statement_list (expr, chain);
2201	}
2202	else
2203	*chain = expr;
2204	}
2205
2206
2207	/* Add a statement at the end of a block. */
2208
2209	void
2210	gfc_add_expr_to_block (stmtblock_t * block, tree expr)
2211	{
2212	gcc_assert (block);
2213	add_expr_to_chain (chain: &block->head, expr, front: false);
2214	}
2215
2216
2217	/* Add a statement at the beginning of a block. */
2218
2219	void
2220	gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
2221	{
2222	gcc_assert (block);
2223	add_expr_to_chain (chain: &block->head, expr, front: true);
2224	}
2225
2226
2227	/* Add a block the end of a block. */
2228
2229	void
2230	gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
2231	{
2232	gcc_assert (append);
2233	gcc_assert (!append->has_scope);
2234
2235	gfc_add_expr_to_block (block, expr: append->head);
2236	append->head = NULL_TREE;
2237	}
2238
2239
2240	/* Save the current locus. The structure may not be complete, and should
2241	only be used with gfc_restore_backend_locus. */
2242
2243	void
2244	gfc_save_backend_locus (locus * loc)
2245	{
2246	loc->lb = XCNEW (gfc_linebuf);
2247	loc->lb->location = input_location;
2248	loc->lb->file = gfc_current_backend_file;
2249	}
2250
2251
2252	/* Set the current locus. */
2253
2254	void
2255	gfc_set_backend_locus (locus * loc)
2256	{
2257	gfc_current_backend_file = loc->lb->file;
2258	input_location = gfc_get_location (loc);
2259	}
2260
2261
2262	/* Restore the saved locus. Only used in conjunction with
2263	gfc_save_backend_locus, to free the memory when we are done. */
2264
2265	void
2266	gfc_restore_backend_locus (locus * loc)
2267	{
2268	/* This only restores the information captured by gfc_save_backend_locus,
2269	intentionally does not use gfc_get_location. */
2270	input_location = loc->lb->location;
2271	gfc_current_backend_file = loc->lb->file;
2272	free (ptr: loc->lb);
2273	}
2274
2275
2276	/* Translate an executable statement. The tree cond is used by gfc_trans_do.
2277	This static function is wrapped by gfc_trans_code_cond and
2278	gfc_trans_code. */
2279
2280	static tree
2281	trans_code (gfc_code * code, tree cond)
2282	{
2283	stmtblock_t block;
2284	tree res;
2285
2286	if (!code)
2287	return build_empty_stmt (input_location);
2288
2289	gfc_start_block (block: &block);
2290
2291	/* Translate statements one by one into GENERIC trees until we reach
2292	the end of this gfc_code branch. */
2293	for (; code; code = code->next)
2294	{
2295	if (code->here != 0)
2296	{
2297	res = gfc_trans_label_here (code);
2298	gfc_add_expr_to_block (block: &block, expr: res);
2299	}
2300
2301	gfc_current_locus = code->loc;
2302	gfc_set_backend_locus (loc: &code->loc);
2303
2304	switch (code->op)
2305	{
2306	case EXEC_NOP:
2307	case EXEC_END_BLOCK:
2308	case EXEC_END_NESTED_BLOCK:
2309	case EXEC_END_PROCEDURE:
2310	res = NULL_TREE;
2311	break;
2312
2313	case EXEC_ASSIGN:
2314	res = gfc_trans_assign (code);
2315	break;
2316
2317	case EXEC_LABEL_ASSIGN:
2318	res = gfc_trans_label_assign (code);
2319	break;
2320
2321	case EXEC_POINTER_ASSIGN:
2322	res = gfc_trans_pointer_assign (code);
2323	break;
2324
2325	case EXEC_INIT_ASSIGN:
2326	if (code->expr1->ts.type == BT_CLASS)
2327	res = gfc_trans_class_init_assign (code);
2328	else
2329	res = gfc_trans_init_assign (code);
2330	break;
2331
2332	case EXEC_CONTINUE:
2333	res = NULL_TREE;
2334	break;
2335
2336	case EXEC_CRITICAL:
2337	res = gfc_trans_critical (code);
2338	break;
2339
2340	case EXEC_CYCLE:
2341	res = gfc_trans_cycle (code);
2342	break;
2343
2344	case EXEC_EXIT:
2345	res = gfc_trans_exit (code);
2346	break;
2347
2348	case EXEC_GOTO:
2349	res = gfc_trans_goto (code);
2350	break;
2351
2352	case EXEC_ENTRY:
2353	res = gfc_trans_entry (code);
2354	break;
2355
2356	case EXEC_PAUSE:
2357	res = gfc_trans_pause (code);
2358	break;
2359
2360	case EXEC_STOP:
2361	case EXEC_ERROR_STOP:
2362	res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
2363	break;
2364
2365	case EXEC_CALL:
2366	/* For MVBITS we've got the special exception that we need a
2367	dependency check, too. */
2368	{
2369	bool is_mvbits = false;
2370
2371	if (code->resolved_isym)
2372	{
2373	res = gfc_conv_intrinsic_subroutine (code);
2374	if (res != NULL_TREE)
2375	break;
2376	}
2377
2378	if (code->resolved_isym
2379	&& code->resolved_isym->id == GFC_ISYM_MVBITS)
2380	is_mvbits = true;
2381
2382	res = gfc_trans_call (code, is_mvbits, NULL_TREE,
2383	NULL_TREE, false);
2384	}
2385	break;
2386
2387	case EXEC_CALL_PPC:
2388	res = gfc_trans_call (code, false, NULL_TREE,
2389	NULL_TREE, false);
2390	break;
2391
2392	case EXEC_ASSIGN_CALL:
2393	res = gfc_trans_call (code, true, NULL_TREE,
2394	NULL_TREE, false);
2395	break;
2396
2397	case EXEC_RETURN:
2398	res = gfc_trans_return (code);
2399	break;
2400
2401	case EXEC_IF:
2402	res = gfc_trans_if (code);
2403	break;
2404
2405	case EXEC_ARITHMETIC_IF:
2406	res = gfc_trans_arithmetic_if (code);
2407	break;
2408
2409	case EXEC_BLOCK:
2410	res = gfc_trans_block_construct (code);
2411	break;
2412
2413	case EXEC_DO:
2414	res = gfc_trans_do (code, cond);
2415	break;
2416
2417	case EXEC_DO_CONCURRENT:
2418	res = gfc_trans_do_concurrent (code);
2419	break;
2420
2421	case EXEC_DO_WHILE:
2422	res = gfc_trans_do_while (code);
2423	break;
2424
2425	case EXEC_SELECT:
2426	res = gfc_trans_select (code);
2427	break;
2428
2429	case EXEC_SELECT_TYPE:
2430	res = gfc_trans_select_type (code);
2431	break;
2432
2433	case EXEC_SELECT_RANK:
2434	res = gfc_trans_select_rank (code);
2435	break;
2436
2437	case EXEC_FLUSH:
2438	res = gfc_trans_flush (code);
2439	break;
2440
2441	case EXEC_SYNC_ALL:
2442	case EXEC_SYNC_IMAGES:
2443	case EXEC_SYNC_MEMORY:
2444	res = gfc_trans_sync (code, code->op);
2445	break;
2446
2447	case EXEC_LOCK:
2448	case EXEC_UNLOCK:
2449	res = gfc_trans_lock_unlock (code, code->op);
2450	break;
2451
2452	case EXEC_EVENT_POST:
2453	case EXEC_EVENT_WAIT:
2454	res = gfc_trans_event_post_wait (code, code->op);
2455	break;
2456
2457	case EXEC_FAIL_IMAGE:
2458	res = gfc_trans_fail_image (code);
2459	break;
2460
2461	case EXEC_FORALL:
2462	res = gfc_trans_forall (code);
2463	break;
2464
2465	case EXEC_FORM_TEAM:
2466	res = gfc_trans_form_team (code);
2467	break;
2468
2469	case EXEC_CHANGE_TEAM:
2470	res = gfc_trans_change_team (code);
2471	break;
2472
2473	case EXEC_END_TEAM:
2474	res = gfc_trans_end_team (code);
2475	break;
2476
2477	case EXEC_SYNC_TEAM:
2478	res = gfc_trans_sync_team (code);
2479	break;
2480
2481	case EXEC_WHERE:
2482	res = gfc_trans_where (code);
2483	break;
2484
2485	case EXEC_ALLOCATE:
2486	res = gfc_trans_allocate (code);
2487	break;
2488
2489	case EXEC_DEALLOCATE:
2490	res = gfc_trans_deallocate (code);
2491	break;
2492
2493	case EXEC_OPEN:
2494	res = gfc_trans_open (code);
2495	break;
2496
2497	case EXEC_CLOSE:
2498	res = gfc_trans_close (code);
2499	break;
2500
2501	case EXEC_READ:
2502	res = gfc_trans_read (code);
2503	break;
2504
2505	case EXEC_WRITE:
2506	res = gfc_trans_write (code);
2507	break;
2508
2509	case EXEC_IOLENGTH:
2510	res = gfc_trans_iolength (code);
2511	break;
2512
2513	case EXEC_BACKSPACE:
2514	res = gfc_trans_backspace (code);
2515	break;
2516
2517	case EXEC_ENDFILE:
2518	res = gfc_trans_endfile (code);
2519	break;
2520
2521	case EXEC_INQUIRE:
2522	res = gfc_trans_inquire (code);
2523	break;
2524
2525	case EXEC_WAIT:
2526	res = gfc_trans_wait (code);
2527	break;
2528
2529	case EXEC_REWIND:
2530	res = gfc_trans_rewind (code);
2531	break;
2532
2533	case EXEC_TRANSFER:
2534	res = gfc_trans_transfer (code);
2535	break;
2536
2537	case EXEC_DT_END:
2538	res = gfc_trans_dt_end (code);
2539	break;
2540
2541	case EXEC_OMP_ALLOCATE:
2542	case EXEC_OMP_ALLOCATORS:
2543	case EXEC_OMP_ASSUME:
2544	case EXEC_OMP_ATOMIC:
2545	case EXEC_OMP_BARRIER:
2546	case EXEC_OMP_CANCEL:
2547	case EXEC_OMP_CANCELLATION_POINT:
2548	case EXEC_OMP_CRITICAL:
2549	case EXEC_OMP_DEPOBJ:
2550	case EXEC_OMP_DISTRIBUTE:
2551	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2552	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2553	case EXEC_OMP_DISTRIBUTE_SIMD:
2554	case EXEC_OMP_DO:
2555	case EXEC_OMP_DO_SIMD:
2556	case EXEC_OMP_LOOP:
2557	case EXEC_OMP_ERROR:
2558	case EXEC_OMP_FLUSH:
2559	case EXEC_OMP_MASKED:
2560	case EXEC_OMP_MASKED_TASKLOOP:
2561	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
2562	case EXEC_OMP_MASTER:
2563	case EXEC_OMP_MASTER_TASKLOOP:
2564	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
2565	case EXEC_OMP_ORDERED:
2566	case EXEC_OMP_PARALLEL:
2567	case EXEC_OMP_PARALLEL_DO:
2568	case EXEC_OMP_PARALLEL_DO_SIMD:
2569	case EXEC_OMP_PARALLEL_LOOP:
2570	case EXEC_OMP_PARALLEL_MASKED:
2571	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2572	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2573	case EXEC_OMP_PARALLEL_MASTER:
2574	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2575	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2576	case EXEC_OMP_PARALLEL_SECTIONS:
2577	case EXEC_OMP_PARALLEL_WORKSHARE:
2578	case EXEC_OMP_SCOPE:
2579	case EXEC_OMP_SECTIONS:
2580	case EXEC_OMP_SIMD:
2581	case EXEC_OMP_SINGLE:
2582	case EXEC_OMP_TARGET:
2583	case EXEC_OMP_TARGET_DATA:
2584	case EXEC_OMP_TARGET_ENTER_DATA:
2585	case EXEC_OMP_TARGET_EXIT_DATA:
2586	case EXEC_OMP_TARGET_PARALLEL:
2587	case EXEC_OMP_TARGET_PARALLEL_DO:
2588	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2589	case EXEC_OMP_TARGET_PARALLEL_LOOP:
2590	case EXEC_OMP_TARGET_SIMD:
2591	case EXEC_OMP_TARGET_TEAMS:
2592	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2593	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2594	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2595	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2596	case EXEC_OMP_TARGET_TEAMS_LOOP:
2597	case EXEC_OMP_TARGET_UPDATE:
2598	case EXEC_OMP_TASK:
2599	case EXEC_OMP_TASKGROUP:
2600	case EXEC_OMP_TASKLOOP:
2601	case EXEC_OMP_TASKLOOP_SIMD:
2602	case EXEC_OMP_TASKWAIT:
2603	case EXEC_OMP_TASKYIELD:
2604	case EXEC_OMP_TEAMS:
2605	case EXEC_OMP_TEAMS_DISTRIBUTE:
2606	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2607	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2608	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2609	case EXEC_OMP_TEAMS_LOOP:
2610	case EXEC_OMP_WORKSHARE:
2611	res = gfc_trans_omp_directive (code);
2612	break;
2613
2614	case EXEC_OACC_CACHE:
2615	case EXEC_OACC_WAIT:
2616	case EXEC_OACC_UPDATE:
2617	case EXEC_OACC_LOOP:
2618	case EXEC_OACC_HOST_DATA:
2619	case EXEC_OACC_DATA:
2620	case EXEC_OACC_KERNELS:
2621	case EXEC_OACC_KERNELS_LOOP:
2622	case EXEC_OACC_PARALLEL:
2623	case EXEC_OACC_PARALLEL_LOOP:
2624	case EXEC_OACC_SERIAL:
2625	case EXEC_OACC_SERIAL_LOOP:
2626	case EXEC_OACC_ENTER_DATA:
2627	case EXEC_OACC_EXIT_DATA:
2628	case EXEC_OACC_ATOMIC:
2629	case EXEC_OACC_DECLARE:
2630	res = gfc_trans_oacc_directive (code);
2631	break;
2632
2633	default:
2634	gfc_internal_error ("gfc_trans_code(): Bad statement code");
2635	}
2636
2637	gfc_set_backend_locus (loc: &code->loc);
2638
2639	if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
2640	{
2641	if (TREE_CODE (res) != STATEMENT_LIST)
2642	SET_EXPR_LOCATION (res, input_location);
2643
2644	/* Add the new statement to the block. */
2645	gfc_add_expr_to_block (block: &block, expr: res);
2646	}
2647	}
2648
2649	/* Return the finished block. */
2650	return gfc_finish_block (stmtblock: &block);
2651	}
2652
2653
2654	/* Translate an executable statement with condition, cond. The condition is
2655	used by gfc_trans_do to test for IO result conditions inside implied
2656	DO loops of READ and WRITE statements. See build_dt in trans-io.cc. */
2657
2658	tree
2659	gfc_trans_code_cond (gfc_code * code, tree cond)
2660	{
2661	return trans_code (code, cond);
2662	}
2663
2664	/* Translate an executable statement without condition. */
2665
2666	tree
2667	gfc_trans_code (gfc_code * code)
2668	{
2669	return trans_code (code, NULL_TREE);
2670	}
2671
2672
2673	/* This function is called after a complete program unit has been parsed
2674	and resolved. */
2675
2676	void
2677	gfc_generate_code (gfc_namespace * ns)
2678	{
2679	ompws_flags = 0;
2680	if (ns->is_block_data)
2681	{
2682	gfc_generate_block_data (ns);
2683	return;
2684	}
2685
2686	gfc_generate_function_code (ns);
2687	}
2688
2689
2690	/* This function is called after a complete module has been parsed
2691	and resolved. */
2692
2693	void
2694	gfc_generate_module_code (gfc_namespace * ns)
2695	{
2696	gfc_namespace *n;
2697	struct module_htab_entry *entry;
2698
2699	gcc_assert (ns->proc_name->backend_decl == NULL);
2700	ns->proc_name->backend_decl
2701	= build_decl (gfc_get_location (loc: &ns->proc_name->declared_at),
2702	NAMESPACE_DECL, get_identifier (ns->proc_name->name),
2703	void_type_node);
2704	entry = gfc_find_module (ns->proc_name->name);
2705	if (entry->namespace_decl)
2706	/* Buggy sourcecode, using a module before defining it? */
2707	entry->decls->empty ();
2708	entry->namespace_decl = ns->proc_name->backend_decl;
2709
2710	gfc_generate_module_vars (ns);
2711
2712	/* We need to generate all module function prototypes first, to allow
2713	sibling calls. */
2714	for (n = ns->contained; n; n = n->sibling)
2715	{
2716	gfc_entry_list *el;
2717
2718	if (!n->proc_name)
2719	continue;
2720
2721	gfc_create_function_decl (n, false);
2722	DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
2723	gfc_module_add_decl (entry, n->proc_name->backend_decl);
2724	for (el = ns->entries; el; el = el->next)
2725	{
2726	DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
2727	gfc_module_add_decl (entry, el->sym->backend_decl);
2728	}
2729	}
2730
2731	for (n = ns->contained; n; n = n->sibling)
2732	{
2733	if (!n->proc_name)
2734	continue;
2735
2736	gfc_generate_function_code (n);
2737	}
2738	}
2739
2740
2741	/* Initialize an init/cleanup block with existing code. */
2742
2743	void
2744	gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2745	{
2746	gcc_assert (block);
2747
2748	block->init = NULL_TREE;
2749	block->code = code;
2750	block->cleanup = NULL_TREE;
2751	}
2752
2753
2754	/* Add a new pair of initializers/clean-up code. */
2755
2756	void
2757	gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2758	{
2759	gcc_assert (block);
2760
2761	/* The new pair of init/cleanup should be "wrapped around" the existing
2762	block of code, thus the initialization is added to the front and the
2763	cleanup to the back. */
2764	add_expr_to_chain (chain: &block->init, expr: init, front: true);
2765	add_expr_to_chain (chain: &block->cleanup, expr: cleanup, front: false);
2766	}
2767
2768
2769	/* Finish up a wrapped block by building a corresponding try-finally expr. */
2770
2771	tree
2772	gfc_finish_wrapped_block (gfc_wrapped_block* block)
2773	{
2774	tree result;
2775
2776	gcc_assert (block);
2777
2778	/* Build the final expression. For this, just add init and body together,
2779	and put clean-up with that into a TRY_FINALLY_EXPR. */
2780	result = block->init;
2781	add_expr_to_chain (chain: &result, expr: block->code, front: false);
2782	if (block->cleanup)
2783	result = build2_loc (loc: input_location, code: TRY_FINALLY_EXPR, void_type_node,
2784	arg0: result, arg1: block->cleanup);
2785
2786	/* Clear the block. */
2787	block->init = NULL_TREE;
2788	block->code = NULL_TREE;
2789	block->cleanup = NULL_TREE;
2790
2791	return result;
2792	}
2793
2794
2795	/* Helper function for marking a boolean expression tree as unlikely. */
2796
2797	tree
2798	gfc_unlikely (tree cond, enum br_predictor predictor)
2799	{
2800	tree tmp;
2801
2802	if (optimize)
2803	{
2804	cond = fold_convert (long_integer_type_node, cond);
2805	tmp = build_zero_cst (long_integer_type_node);
2806	cond = build_call_expr_loc (input_location,
2807	builtin_decl_explicit (fncode: BUILT_IN_EXPECT),
2808	3, cond, tmp,
2809	build_int_cst (integer_type_node,
2810	predictor));
2811	}
2812	return cond;
2813	}
2814
2815
2816	/* Helper function for marking a boolean expression tree as likely. */
2817
2818	tree
2819	gfc_likely (tree cond, enum br_predictor predictor)
2820	{
2821	tree tmp;
2822
2823	if (optimize)
2824	{
2825	cond = fold_convert (long_integer_type_node, cond);
2826	tmp = build_one_cst (long_integer_type_node);
2827	cond = build_call_expr_loc (input_location,
2828	builtin_decl_explicit (fncode: BUILT_IN_EXPECT),
2829	3, cond, tmp,
2830	build_int_cst (integer_type_node,
2831	predictor));
2832	}
2833	return cond;
2834	}
2835
2836
2837	/* Get the string length for a deferred character length component. */
2838
2839	bool
2840	gfc_deferred_strlen (gfc_component *c, tree *decl)
2841	{
2842	char name[GFC_MAX_SYMBOL_LEN+9];
2843	gfc_component *strlen;
2844	if (!(c->ts.type == BT_CHARACTER
2845	&& (c->ts.deferred || c->attr.pdt_string)))
2846	return false;
2847	sprintf (s: name, format: "_%s_length", c->name);
2848	for (strlen = c; strlen; strlen = strlen->next)
2849	if (strcmp (s1: strlen->name, s2: name) == 0)
2850	break;
2851	*decl = strlen ? strlen->backend_decl : NULL_TREE;
2852	return strlen != NULL;
2853	}
2854