1	/* Pass manager for Fortran front end.
2	Copyright (C) 2010-2023 Free Software Foundation, Inc.
3	Contributed by Thomas König.
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 "gfortran.h"
26	#include "dependency.h"
27	#include "constructor.h"
28	#include "intrinsic.h"
29
30	/* Forward declarations. */
31
32	static void strip_function_call (gfc_expr *);
33	static void optimize_namespace (gfc_namespace *);
34	static void optimize_assignment (gfc_code *);
35	static bool optimize_op (gfc_expr *);
36	static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
37	static bool optimize_trim (gfc_expr *);
38	static bool optimize_lexical_comparison (gfc_expr *);
39	static void optimize_minmaxloc (gfc_expr **);
40	static bool is_empty_string (gfc_expr *e);
41	static void doloop_warn (gfc_namespace *);
42	static int do_intent (gfc_expr **);
43	static int do_subscript (gfc_expr **);
44	static void optimize_reduction (gfc_namespace *);
45	static int callback_reduction (gfc_expr **, int *, void *);
46	static void realloc_strings (gfc_namespace *);
47	static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
48	static int matmul_to_var_expr (gfc_expr **, int *, void *);
49	static int matmul_to_var_code (gfc_code **, int *, void *);
50	static int inline_matmul_assign (gfc_code **, int *, void *);
51	static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
52	locus *, gfc_namespace *,
53	char *vname=NULL);
54	static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
55	bool *);
56	static int call_external_blas (gfc_code **, int *, void *);
57	static int matmul_temp_args (gfc_code **, int *,void *data);
58	static int index_interchange (gfc_code **, int*, void *);
59	static bool is_fe_temp (gfc_expr *e);
60
61	#ifdef CHECKING_P
62	static void check_locus (gfc_namespace *);
63	#endif
64
65	/* How deep we are inside an argument list. */
66
67	static int count_arglist;
68
69	/* Vector of gfc_expr ** we operate on. */
70
71	static vec<gfc_expr **> expr_array;
72
73	/* Pointer to the gfc_code we currently work on - to be able to insert
74	a block before the statement. */
75
76	static gfc_code **current_code;
77
78	/* Pointer to the block to be inserted, and the statement we are
79	changing within the block. */
80
81	static gfc_code *inserted_block, **changed_statement;
82
83	/* The namespace we are currently dealing with. */
84
85	static gfc_namespace *current_ns;
86
87	/* If we are within any forall loop. */
88
89	static int forall_level;
90
91	/* Keep track of whether we are within an OMP workshare. */
92
93	static bool in_omp_workshare;
94
95	/* Keep track of whether we are within an OMP atomic. */
96
97	static bool in_omp_atomic;
98
99	/* Keep track of whether we are within a WHERE statement. */
100
101	static bool in_where;
102
103	/* Keep track of iterators for array constructors. */
104
105	static int iterator_level;
106
107	/* Keep track of DO loop levels. */
108
109	typedef struct {
110	gfc_code *c;
111	int branch_level;
112	bool seen_goto;
113	} do_t;
114
115	static vec<do_t> doloop_list;
116	static int doloop_level;
117
118	/* Keep track of if and select case levels. */
119
120	static int if_level;
121	static int select_level;
122
123	/* Vector of gfc_expr * to keep track of DO loops. */
124
125	struct my_struct *evec;
126
127	/* Keep track of association lists. */
128
129	static bool in_assoc_list;
130
131	/* Counter for temporary variables. */
132
133	static int var_num = 1;
134
135	/* What sort of matrix we are dealing with when inlining MATMUL. */
136
137	enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };
138
139	/* Keep track of the number of expressions we have inserted so far
140	using create_var. */
141
142	int n_vars;
143
144	/* Entry point - run all passes for a namespace. */
145
146	void
147	gfc_run_passes (gfc_namespace *ns)
148	{
149
150	/* Warn about dubious DO loops where the index might
151	change. */
152
153	doloop_level = 0;
154	if_level = 0;
155	select_level = 0;
156	doloop_warn (ns);
157	doloop_list.release ();
158	int w, e;
159
160	#ifdef CHECKING_P
161	check_locus (ns);
162	#endif
163
164	gfc_get_errors (&w, &e);
165	if (e > 0)
166	return;
167
168	if (flag_frontend_optimize || flag_frontend_loop_interchange)
169	optimize_namespace (ns);
170
171	if (flag_frontend_optimize)
172	{
173	optimize_reduction (ns);
174	if (flag_dump_fortran_optimized)
175	gfc_dump_parse_tree (ns, stdout);
176
177	expr_array.release ();
178	}
179
180	if (flag_realloc_lhs)
181	realloc_strings (ns);
182	}
183
184	#ifdef CHECKING_P
185
186	/* Callback function: Warn if there is no location information in a
187	statement. */
188
189	static int
190	check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
191	void *data ATTRIBUTE_UNUSED)
192	{
193	current_code = c;
194	if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
195	gfc_warning_internal (opt: 0, "Inconsistent internal state: "
196	"No location in statement");
197
198	return 0;
199	}
200
201
202	/* Callback function: Warn if there is no location information in an
203	expression. */
204
205	static int
206	check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
207	void *data ATTRIBUTE_UNUSED)
208	{
209
210	if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
211	gfc_warning_internal (opt: 0, "Inconsistent internal state: "
212	"No location in expression near %L",
213	&((*current_code)->loc));
214	return 0;
215	}
216
217	/* Run check for missing location information. */
218
219	static void
220	check_locus (gfc_namespace *ns)
221	{
222	gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
223
224	for (ns = ns->contained; ns; ns = ns->sibling)
225	{
226	if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
227	check_locus (ns);
228	}
229	}
230
231	#endif
232
233	/* Callback for each gfc_code node invoked from check_realloc_strings.
234	For an allocatable LHS string which also appears as a variable on
235	the RHS, replace
236
237	a = a(x:y)
238
239	with
240
241	tmp = a(x:y)
242	a = tmp
243	*/
244
245	static int
246	realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
247	void *data ATTRIBUTE_UNUSED)
248	{
249	gfc_expr *expr1, *expr2;
250	gfc_code *co = *c;
251	gfc_expr *n;
252	gfc_ref *ref;
253	bool found_substr;
254
255	if (co->op != EXEC_ASSIGN)
256	return 0;
257
258	expr1 = co->expr1;
259	if (expr1->ts.type != BT_CHARACTER
260	|| !gfc_expr_attr(expr1).allocatable
261	|| !expr1->ts.deferred)
262	return 0;
263
264	if (is_fe_temp (e: expr1))
265	return 0;
266
267	expr2 = gfc_discard_nops (co->expr2);
268
269	if (expr2->expr_type == EXPR_VARIABLE)
270	{
271	found_substr = false;
272	for (ref = expr2->ref; ref; ref = ref->next)
273	{
274	if (ref->type == REF_SUBSTRING)
275	{
276	found_substr = true;
277	break;
278	}
279	}
280	if (!found_substr)
281	return 0;
282	}
283	else if (expr2->expr_type != EXPR_ARRAY
284	&& (expr2->expr_type != EXPR_OP
285	|| expr2->value.op.op != INTRINSIC_CONCAT))
286	return 0;
287
288	if (!gfc_check_dependency (expr1, expr2, true))
289	return 0;
290
291	/* gfc_check_dependency doesn't always pick up identical expressions.
292	However, eliminating the above sends the compiler into an infinite
293	loop on valid expressions. Without this check, the gimplifier emits
294	an ICE for a = a, where a is deferred character length. */
295	if (!gfc_dep_compare_expr (expr1, expr2))
296	return 0;
297
298	current_code = c;
299	inserted_block = NULL;
300	changed_statement = NULL;
301	n = create_var (expr2, vname: "realloc_string");
302	co->expr2 = n;
303	return 0;
304	}
305
306	/* Callback for each gfc_code node invoked through gfc_code_walker
307	from optimize_namespace. */
308
309	static int
310	optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
311	void *data ATTRIBUTE_UNUSED)
312	{
313
314	gfc_exec_op op;
315
316	op = (*c)->op;
317
318	if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
319	|| op == EXEC_CALL_PPC)
320	count_arglist = 1;
321	else
322	count_arglist = 0;
323
324	current_code = c;
325	inserted_block = NULL;
326	changed_statement = NULL;
327
328	if (op == EXEC_ASSIGN)
329	optimize_assignment (*c);
330	return 0;
331	}
332
333	/* Callback for each gfc_expr node invoked through gfc_code_walker
334	from optimize_namespace. */
335
336	static int
337	optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
338	void *data ATTRIBUTE_UNUSED)
339	{
340	bool function_expr;
341
342	if ((*e)->expr_type == EXPR_FUNCTION)
343	{
344	count_arglist ++;
345	function_expr = true;
346	}
347	else
348	function_expr = false;
349
350	if (optimize_trim (*e))
351	gfc_simplify_expr (*e, 0);
352
353	if (optimize_lexical_comparison (*e))
354	gfc_simplify_expr (*e, 0);
355
356	if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
357	gfc_simplify_expr (*e, 0);
358
359	if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
360	switch ((*e)->value.function.isym->id)
361	{
362	case GFC_ISYM_MINLOC:
363	case GFC_ISYM_MAXLOC:
364	optimize_minmaxloc (e);
365	break;
366	default:
367	break;
368	}
369
370	if (function_expr)
371	count_arglist --;
372
373	return 0;
374	}
375
376	/* Auxiliary function to handle the arguments to reduction intrinsics. If the
377	function is a scalar, just copy it; otherwise returns the new element, the
378	old one can be freed. */
379
380	static gfc_expr *
381	copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
382	{
383	gfc_expr *fcn, *e = c->expr;
384
385	fcn = gfc_copy_expr (e);
386	if (c->iterator)
387	{
388	gfc_constructor_base newbase;
389	gfc_expr *new_expr;
390	gfc_constructor *new_c;
391
392	newbase = NULL;
393	new_expr = gfc_get_expr ();
394	new_expr->expr_type = EXPR_ARRAY;
395	new_expr->ts = e->ts;
396	new_expr->where = e->where;
397	new_expr->rank = 1;
398	new_c = gfc_constructor_append_expr (base: &newbase, e: fcn, where: &(e->where));
399	new_c->iterator = c->iterator;
400	new_expr->value.constructor = newbase;
401	c->iterator = NULL;
402
403	fcn = new_expr;
404	}
405
406	if (fcn->rank != 0)
407	{
408	gfc_isym_id id = fn->value.function.isym->id;
409
410	if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
411	fcn = gfc_build_intrinsic_call (current_ns, id,
412	fn->value.function.isym->name,
413	fn->where, 3, fcn, NULL, NULL);
414	else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
415	fcn = gfc_build_intrinsic_call (current_ns, id,
416	fn->value.function.isym->name,
417	fn->where, 2, fcn, NULL);
418	else
419	gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
420
421	fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
422	}
423
424	return fcn;
425	}
426
427	/* Callback function for optimization of reductions to scalars. Transform ANY
428	([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
429	correspondingly. Handle only the simple cases without MASK and DIM. */
430
431	static int
432	callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
433	void *data ATTRIBUTE_UNUSED)
434	{
435	gfc_expr *fn, *arg;
436	gfc_intrinsic_op op;
437	gfc_isym_id id;
438	gfc_actual_arglist *a;
439	gfc_actual_arglist *dim;
440	gfc_constructor *c;
441	gfc_expr *res, *new_expr;
442	gfc_actual_arglist *mask;
443
444	fn = *e;
445
446	if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
447	|| fn->value.function.isym == NULL)
448	return 0;
449
450	id = fn->value.function.isym->id;
451
452	if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
453	&& id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
454	return 0;
455
456	a = fn->value.function.actual;
457
458	/* Don't handle MASK or DIM. */
459
460	dim = a->next;
461
462	if (dim->expr != NULL)
463	return 0;
464
465	if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
466	{
467	mask = dim->next;
468	if ( mask->expr != NULL)
469	return 0;
470	}
471
472	arg = a->expr;
473
474	if (arg->expr_type != EXPR_ARRAY)
475	return 0;
476
477	switch (id)
478	{
479	case GFC_ISYM_SUM:
480	op = INTRINSIC_PLUS;
481	break;
482
483	case GFC_ISYM_PRODUCT:
484	op = INTRINSIC_TIMES;
485	break;
486
487	case GFC_ISYM_ANY:
488	op = INTRINSIC_OR;
489	break;
490
491	case GFC_ISYM_ALL:
492	op = INTRINSIC_AND;
493	break;
494
495	default:
496	return 0;
497	}
498
499	c = gfc_constructor_first (base: arg->value.constructor);
500
501	/* Don't do any simplififcation if we have
502	- no element in the constructor or
503	- only have a single element in the array which contains an
504	iterator. */
505
506	if (c == NULL)
507	return 0;
508
509	res = copy_walk_reduction_arg (c, fn);
510
511	c = gfc_constructor_next (ctor: c);
512	while (c)
513	{
514	new_expr = gfc_get_expr ();
515	new_expr->ts = fn->ts;
516	new_expr->expr_type = EXPR_OP;
517	new_expr->rank = fn->rank;
518	new_expr->where = fn->where;
519	new_expr->value.op.op = op;
520	new_expr->value.op.op1 = res;
521	new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
522	res = new_expr;
523	c = gfc_constructor_next (ctor: c);
524	}
525
526	gfc_simplify_expr (res, 0);
527	*e = res;
528	gfc_free_expr (fn);
529
530	return 0;
531	}
532
533	/* Callback function for common function elimination, called from cfe_expr_0.
534	Put all eligible function expressions into expr_array. */
535
536	static int
537	cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
538	void *data ATTRIBUTE_UNUSED)
539	{
540
541	if ((*e)->expr_type != EXPR_FUNCTION)
542	return 0;
543
544	/* We don't do character functions with unknown charlens. */
545	if ((*e)->ts.type == BT_CHARACTER
546	&& ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
547	|| (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
548	return 0;
549
550	/* We don't do function elimination within FORALL statements, it can
551	lead to wrong-code in certain circumstances. */
552
553	if (forall_level > 0)
554	return 0;
555
556	/* Function elimination inside an iterator could lead to functions which
557	depend on iterator variables being moved outside. FIXME: We should check
558	if the functions do indeed depend on the iterator variable. */
559
560	if (iterator_level > 0)
561	return 0;
562
563	/* If we don't know the shape at compile time, we create an allocatable
564	temporary variable to hold the intermediate result, but only if
565	allocation on assignment is active. */
566
567	if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
568	return 0;
569
570	/* Skip the test for pure functions if -faggressive-function-elimination
571	is specified. */
572	if ((*e)->value.function.esym)
573	{
574	/* Don't create an array temporary for elemental functions. */
575	if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
576	return 0;
577
578	/* Only eliminate potentially impure functions if the
579	user specifically requested it. */
580	if (!flag_aggressive_function_elimination
581	&& !(*e)->value.function.esym->attr.pure
582	&& !(*e)->value.function.esym->attr.implicit_pure)
583	return 0;
584	}
585
586	if ((*e)->value.function.isym)
587	{
588	/* Conversions are handled on the fly by the middle end,
589	transpose during trans-* stages and TRANSFER by the middle end. */
590	if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
591	|| (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
592	|| gfc_inline_intrinsic_function_p (*e))
593	return 0;
594
595	/* Don't create an array temporary for elemental functions,
596	as this would be wasteful of memory.
597	FIXME: Create a scalar temporary during scalarization. */
598	if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
599	return 0;
600
601	if (!(*e)->value.function.isym->pure)
602	return 0;
603	}
604
605	expr_array.safe_push (obj: e);
606	return 0;
607	}
608
609	/* Auxiliary function to check if an expression is a temporary created by
610	create var. */
611
612	static bool
613	is_fe_temp (gfc_expr *e)
614	{
615	if (e->expr_type != EXPR_VARIABLE)
616	return false;
617
618	return e->symtree->n.sym->attr.fe_temp;
619	}
620
621	/* Determine the length of a string, if it can be evaluated as a constant
622	expression. Return a newly allocated gfc_expr or NULL on failure.
623	If the user specified a substring which is potentially longer than
624	the string itself, the string will be padded with spaces, which
625	is harmless. */
626
627	static gfc_expr *
628	constant_string_length (gfc_expr *e)
629	{
630
631	gfc_expr *length;
632	gfc_ref *ref;
633	gfc_expr *res;
634	mpz_t value;
635
636	if (e->ts.u.cl)
637	{
638	length = e->ts.u.cl->length;
639	if (length && length->expr_type == EXPR_CONSTANT)
640	return gfc_copy_expr(length);
641	}
642
643	/* See if there is a substring. If it has a constant length, return
644	that and NULL otherwise. */
645	for (ref = e->ref; ref; ref = ref->next)
646	{
647	if (ref->type == REF_SUBSTRING)
648	{
649	if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
650	{
651	res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
652	&e->where);
653
654	mpz_add_ui (res->value.integer, value, 1);
655	mpz_clear (value);
656	return res;
657	}
658	else
659	return NULL;
660	}
661	}
662
663	/* Return length of char symbol, if constant. */
664	if (e->symtree && e->symtree->n.sym->ts.u.cl
665	&& e->symtree->n.sym->ts.u.cl->length
666	&& e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
667	return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
668
669	return NULL;
670
671	}
672
673	/* Insert a block at the current position unless it has already
674	been inserted; in this case use the one already there. */
675
676	static gfc_namespace*
677	insert_block ()
678	{
679	gfc_namespace *ns;
680
681	/* If the block hasn't already been created, do so. */
682	if (inserted_block == NULL)
683	{
684	inserted_block = XCNEW (gfc_code);
685	inserted_block->op = EXEC_BLOCK;
686	inserted_block->loc = (*current_code)->loc;
687	ns = gfc_build_block_ns (current_ns);
688	inserted_block->ext.block.ns = ns;
689	inserted_block->ext.block.assoc = NULL;
690
691	ns->code = *current_code;
692
693	/* If the statement has a label, make sure it is transferred to
694	the newly created block. */
695
696	if ((*current_code)->here)
697	{
698	inserted_block->here = (*current_code)->here;
699	(*current_code)->here = NULL;
700	}
701
702	inserted_block->next = (*current_code)->next;
703	changed_statement = &(inserted_block->ext.block.ns->code);
704	(*current_code)->next = NULL;
705	/* Insert the BLOCK at the right position. */
706	*current_code = inserted_block;
707	ns->parent = current_ns;
708	}
709	else
710	ns = inserted_block->ext.block.ns;
711
712	return ns;
713	}
714
715
716	/* Insert a call to the intrinsic len. Use a different name for
717	the symbol tree so we don't run into trouble when the user has
718	renamed len for some reason. */
719
720	static gfc_expr*
721	get_len_call (gfc_expr *str)
722	{
723	gfc_expr *fcn;
724	gfc_actual_arglist *actual_arglist;
725
726	fcn = gfc_get_expr ();
727	fcn->expr_type = EXPR_FUNCTION;
728	fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
729	actual_arglist = gfc_get_actual_arglist ();
730	actual_arglist->expr = str;
731
732	fcn->value.function.actual = actual_arglist;
733	fcn->where = str->where;
734	fcn->ts.type = BT_INTEGER;
735	fcn->ts.kind = gfc_charlen_int_kind;
736
737	gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
738	fcn->symtree->n.sym->ts = fcn->ts;
739	fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
740	fcn->symtree->n.sym->attr.function = 1;
741	fcn->symtree->n.sym->attr.elemental = 1;
742	fcn->symtree->n.sym->attr.referenced = 1;
743	fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
744	gfc_commit_symbol (fcn->symtree->n.sym);
745
746	return fcn;
747	}
748
749
750	/* Returns a new expression (a variable) to be used in place of the old one,
751	with an optional assignment statement before the current statement to set
752	the value of the variable. Creates a new BLOCK for the statement if that
753	hasn't already been done and puts the statement, plus the newly created
754	variables, in that block. Special cases: If the expression is constant or
755	a temporary which has already been created, just copy it. */
756
757	static gfc_expr*
758	create_var (gfc_expr * e, const char *vname)
759	{
760	char name[GFC_MAX_SYMBOL_LEN +1];
761	gfc_symtree *symtree;
762	gfc_symbol *symbol;
763	gfc_expr *result;
764	gfc_code *n;
765	gfc_namespace *ns;
766	int i;
767	bool deferred;
768
769	if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
770	return gfc_copy_expr (e);
771
772	/* Creation of an array of unknown size requires realloc on assignment.
773	If that is not possible, just return NULL. */
774	if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
775	return NULL;
776
777	ns = insert_block ();
778
779	if (vname)
780	snprintf (s: name, GFC_MAX_SYMBOL_LEN, format: "__var_%d_%s", var_num++, vname);
781	else
782	snprintf (s: name, GFC_MAX_SYMBOL_LEN, format: "__var_%d", var_num++);
783
784	if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
785	gcc_unreachable ();
786
787	symbol = symtree->n.sym;
788	symbol->ts = e->ts;
789
790	if (e->rank > 0)
791	{
792	symbol->as = gfc_get_array_spec ();
793	symbol->as->rank = e->rank;
794
795	if (e->shape == NULL)
796	{
797	/* We don't know the shape at compile time, so we use an
798	allocatable. */
799	symbol->as->type = AS_DEFERRED;
800	symbol->attr.allocatable = 1;
801	}
802	else
803	{
804	symbol->as->type = AS_EXPLICIT;
805	/* Copy the shape. */
806	for (i=0; i<e->rank; i++)
807	{
808	gfc_expr *p, *q;
809
810	p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
811	&(e->where));
812	mpz_set_si (p->value.integer, 1);
813	symbol->as->lower[i] = p;
814
815	q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
816	&(e->where));
817	mpz_set (q->value.integer, e->shape[i]);
818	symbol->as->upper[i] = q;
819	}
820	}
821	}
822
823	deferred = 0;
824	if (e->ts.type == BT_CHARACTER)
825	{
826	gfc_expr *length;
827
828	symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
829	length = constant_string_length (e);
830	if (length)
831	symbol->ts.u.cl->length = length;
832	else if (e->expr_type == EXPR_VARIABLE
833	&& e->symtree->n.sym->ts.type == BT_CHARACTER
834	&& e->ts.u.cl->length)
835	symbol->ts.u.cl->length = get_len_call (str: gfc_copy_expr (e));
836	else
837	{
838	symbol->attr.allocatable = 1;
839	symbol->ts.u.cl->length = NULL;
840	symbol->ts.deferred = 1;
841	deferred = 1;
842	}
843	}
844
845	symbol->attr.flavor = FL_VARIABLE;
846	symbol->attr.referenced = 1;
847	symbol->attr.dimension = e->rank > 0;
848	symbol->attr.fe_temp = 1;
849	gfc_commit_symbol (symbol);
850
851	result = gfc_get_expr ();
852	result->expr_type = EXPR_VARIABLE;
853	result->ts = symbol->ts;
854	result->ts.deferred = deferred;
855	result->rank = e->rank;
856	result->shape = gfc_copy_shape (e->shape, e->rank);
857	result->symtree = symtree;
858	result->where = e->where;
859	if (e->rank > 0)
860	{
861	result->ref = gfc_get_ref ();
862	result->ref->type = REF_ARRAY;
863	result->ref->u.ar.type = AR_FULL;
864	result->ref->u.ar.where = e->where;
865	result->ref->u.ar.dimen = e->rank;
866	result->ref->u.ar.as = symbol->ts.type == BT_CLASS
867	? CLASS_DATA (symbol)->as : symbol->as;
868	if (warn_array_temporaries)
869	gfc_warning (opt: OPT_Warray_temporaries,
870	"Creating array temporary at %L", &(e->where));
871	}
872
873	/* Generate the new assignment. */
874	n = XCNEW (gfc_code);
875	n->op = EXEC_ASSIGN;
876	n->loc = (*current_code)->loc;
877	n->next = *changed_statement;
878	n->expr1 = gfc_copy_expr (result);
879	n->expr2 = e;
880	*changed_statement = n;
881	n_vars ++;
882
883	return result;
884	}
885
886	/* Warn about function elimination. */
887
888	static void
889	do_warn_function_elimination (gfc_expr *e)
890	{
891	const char *name;
892	if (e->expr_type == EXPR_FUNCTION
893	&& !gfc_pure_function (e, name: &name) && !gfc_implicit_pure_function (e))
894	{
895	if (name)
896	gfc_warning (opt: OPT_Wfunction_elimination,
897	"Removing call to impure function %qs at %L", name,
898	&(e->where));
899	else
900	gfc_warning (opt: OPT_Wfunction_elimination,
901	"Removing call to impure function at %L",
902	&(e->where));
903	}
904	}
905
906
907	/* Callback function for the code walker for doing common function
908	elimination. This builds up the list of functions in the expression
909	and goes through them to detect duplicates, which it then replaces
910	by variables. */
911
912	static int
913	cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
914	void *data ATTRIBUTE_UNUSED)
915	{
916	int i,j;
917	gfc_expr *newvar;
918	gfc_expr **ei, **ej;
919
920	/* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */
921
922	if (in_omp_workshare || in_omp_atomic || in_assoc_list)
923	{
924	*walk_subtrees = 0;
925	return 0;
926	}
927
928	expr_array.release ();
929
930	gfc_expr_walker (e, cfe_register_funcs, NULL);
931
932	/* Walk through all the functions. */
933
934	FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
935	{
936	/* Skip if the function has been replaced by a variable already. */
937	if ((*ei)->expr_type == EXPR_VARIABLE)
938	continue;
939
940	newvar = NULL;
941	for (j=0; j<i; j++)
942	{
943	ej = expr_array[j];
944	if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
945	{
946	if (newvar == NULL)
947	newvar = create_var (e: *ei, vname: "fcn");
948
949	if (warn_function_elimination)
950	do_warn_function_elimination (e: *ej);
951
952	free (ptr: *ej);
953	*ej = gfc_copy_expr (newvar);
954	}
955	}
956	if (newvar)
957	*ei = newvar;
958	}
959
960	/* We did all the necessary walking in this function. */
961	*walk_subtrees = 0;
962	return 0;
963	}
964
965	/* Callback function for common function elimination, called from
966	gfc_code_walker. This keeps track of the current code, in order
967	to insert statements as needed. */
968
969	static int
970	cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
971	{
972	current_code = c;
973	inserted_block = NULL;
974	changed_statement = NULL;
975
976	/* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
977	and allocation on assignment are prohibited inside WHERE, and finally
978	masking an expression would lead to wrong-code when replacing
979
980	WHERE (a>0)
981	b = sum(foo(a) + foo(a))
982	END WHERE
983
984	with
985
986	WHERE (a > 0)
987	tmp = foo(a)
988	b = sum(tmp + tmp)
989	END WHERE
990	*/
991
992	if ((*c)->op == EXEC_WHERE)
993	{
994	*walk_subtrees = 0;
995	return 0;
996	}
997
998
999	return 0;
1000	}
1001
1002	/* Dummy function for expression call back, for use when we
1003	really don't want to do any walking. */
1004
1005	static int
1006	dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
1007	void *data ATTRIBUTE_UNUSED)
1008	{
1009	*walk_subtrees = 0;
1010	return 0;
1011	}
1012
1013	/* Dummy function for code callback, for use when we really
1014	don't want to do anything. */
1015	int
1016	gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
1017	int *walk_subtrees ATTRIBUTE_UNUSED,
1018	void *data ATTRIBUTE_UNUSED)
1019	{
1020	return 0;
1021	}
1022
1023	/* Code callback function for converting
1024	do while(a)
1025	end do
1026	into the equivalent
1027	do
1028	if (.not. a) exit
1029	end do
1030	This is because common function elimination would otherwise place the
1031	temporary variables outside the loop. */
1032
1033	static int
1034	convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1035	void *data ATTRIBUTE_UNUSED)
1036	{
1037	gfc_code *co = *c;
1038	gfc_code *c_if1, *c_if2, *c_exit;
1039	gfc_code *loopblock;
1040	gfc_expr *e_not, *e_cond;
1041
1042	if (co->op != EXEC_DO_WHILE)
1043	return 0;
1044
1045	if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
1046	return 0;
1047
1048	e_cond = co->expr1;
1049
1050	/* Generate the condition of the if statement, which is .not. the original
1051	statement. */
1052	e_not = gfc_get_expr ();
1053	e_not->ts = e_cond->ts;
1054	e_not->where = e_cond->where;
1055	e_not->expr_type = EXPR_OP;
1056	e_not->value.op.op = INTRINSIC_NOT;
1057	e_not->value.op.op1 = e_cond;
1058
1059	/* Generate the EXIT statement. */
1060	c_exit = XCNEW (gfc_code);
1061	c_exit->op = EXEC_EXIT;
1062	c_exit->ext.which_construct = co;
1063	c_exit->loc = co->loc;
1064
1065	/* Generate the IF statement. */
1066	c_if2 = XCNEW (gfc_code);
1067	c_if2->op = EXEC_IF;
1068	c_if2->expr1 = e_not;
1069	c_if2->next = c_exit;
1070	c_if2->loc = co->loc;
1071
1072	/* ... plus the one to chain it to. */
1073	c_if1 = XCNEW (gfc_code);
1074	c_if1->op = EXEC_IF;
1075	c_if1->block = c_if2;
1076	c_if1->loc = co->loc;
1077
1078	/* Make the DO WHILE loop into a DO block by replacing the condition
1079	with a true constant. */
1080	co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
1081
1082	/* Hang the generated if statement into the loop body. */
1083
1084	loopblock = co->block->next;
1085	co->block->next = c_if1;
1086	c_if1->next = loopblock;
1087
1088	return 0;
1089	}
1090
1091	/* Code callback function for converting
1092	if (a) then
1093	...
1094	else if (b) then
1095	end if
1096
1097	into
1098	if (a) then
1099	else
1100	if (b) then
1101	end if
1102	end if
1103
1104	because otherwise common function elimination would place the BLOCKs
1105	into the wrong place. */
1106
1107	static int
1108	convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1109	void *data ATTRIBUTE_UNUSED)
1110	{
1111	gfc_code *co = *c;
1112	gfc_code *c_if1, *c_if2, *else_stmt;
1113
1114	if (co->op != EXEC_IF)
1115	return 0;
1116
1117	/* This loop starts out with the first ELSE statement. */
1118	else_stmt = co->block->block;
1119
1120	while (else_stmt != NULL)
1121	{
1122	gfc_code *next_else;
1123
1124	/* If there is no condition, we're done. */
1125	if (else_stmt->expr1 == NULL)
1126	break;
1127
1128	next_else = else_stmt->block;
1129
1130	/* Generate the new IF statement. */
1131	c_if2 = XCNEW (gfc_code);
1132	c_if2->op = EXEC_IF;
1133	c_if2->expr1 = else_stmt->expr1;
1134	c_if2->next = else_stmt->next;
1135	c_if2->loc = else_stmt->loc;
1136	c_if2->block = next_else;
1137
1138	/* ... plus the one to chain it to. */
1139	c_if1 = XCNEW (gfc_code);
1140	c_if1->op = EXEC_IF;
1141	c_if1->block = c_if2;
1142	c_if1->loc = else_stmt->loc;
1143
1144	/* Insert the new IF after the ELSE. */
1145	else_stmt->expr1 = NULL;
1146	else_stmt->next = c_if1;
1147	else_stmt->block = NULL;
1148
1149	else_stmt = next_else;
1150	}
1151	/* Don't walk subtrees. */
1152	return 0;
1153	}
1154
1155	/* Callback function to var_in_expr - return true if expr1 and
1156	expr2 are identical variables. */
1157	static int
1158	var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1159	void *data)
1160	{
1161	gfc_expr *expr1 = (gfc_expr *) data;
1162	gfc_expr *expr2 = *e;
1163
1164	if (expr2->expr_type != EXPR_VARIABLE)
1165	return 0;
1166
1167	return expr1->symtree->n.sym == expr2->symtree->n.sym;
1168	}
1169
1170	/* Return true if expr1 is found in expr2. */
1171
1172	static bool
1173	var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
1174	{
1175	gcc_assert (expr1->expr_type == EXPR_VARIABLE);
1176
1177	return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
1178	}
1179
1180	struct do_stack
1181	{
1182	struct do_stack *prev;
1183	gfc_iterator *iter;
1184	gfc_code *code;
1185	} *stack_top;
1186
1187	/* Recursively traverse the block of a WRITE or READ statement, and maybe
1188	optimize by replacing do loops with their analog array slices. For
1189	example:
1190
1191	write (*,*) (a(i), i=1,4)
1192
1193	is replaced with
1194
1195	write (*,*) a(1:4:1) . */
1196
1197	static bool
1198	traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
1199	{
1200	gfc_code *curr;
1201	gfc_expr *new_e, *expr, *start;
1202	gfc_ref *ref;
1203	struct do_stack ds_push;
1204	int i, future_rank = 0;
1205	gfc_iterator *iters[GFC_MAX_DIMENSIONS];
1206	gfc_expr *e;
1207
1208	/* Find the first transfer/do statement. */
1209	for (curr = code; curr; curr = curr->next)
1210	{
1211	if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
1212	break;
1213	}
1214
1215	/* Ensure it is the only transfer/do statement because cases like
1216
1217	write (*,*) (a(i), b(i), i=1,4)
1218
1219	cannot be optimized. */
1220
1221	if (!curr || curr->next)
1222	return false;
1223
1224	if (curr->op == EXEC_DO)
1225	{
1226	if (curr->ext.iterator->var->ref)
1227	return false;
1228	ds_push.prev = stack_top;
1229	ds_push.iter = curr->ext.iterator;
1230	ds_push.code = curr;
1231	stack_top = &ds_push;
1232	if (traverse_io_block (code: curr->block->next, has_reached, prev))
1233	{
1234	if (curr != stack_top->code && !*has_reached)
1235	{
1236	curr->block->next = NULL;
1237	gfc_free_statements (curr);
1238	}
1239	else
1240	*has_reached = true;
1241	return true;
1242	}
1243	return false;
1244	}
1245
1246	gcc_assert (curr->op == EXEC_TRANSFER);
1247
1248	e = curr->expr1;
1249	ref = e->ref;
1250	if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
1251	return false;
1252
1253	/* Find the iterators belonging to each variable and check conditions. */
1254	for (i = 0; i < ref->u.ar.dimen; i++)
1255	{
1256	if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
1257	|| ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1258	return false;
1259
1260	start = ref->u.ar.start[i];
1261	gfc_simplify_expr (start, 0);
1262	switch (start->expr_type)
1263	{
1264	case EXPR_VARIABLE:
1265
1266	/* write (*,*) (a(i), i=a%b,1) not handled yet. */
1267	if (start->ref)
1268	return false;
1269
1270	/* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1271	if (!stack_top || !stack_top->iter
1272	|| stack_top->iter->var->symtree != start->symtree)
1273	{
1274	/* Check for (a(i,i), i=1,3). */
1275	int j;
1276
1277	for (j=0; j<i; j++)
1278	if (iters[j] && iters[j]->var->symtree == start->symtree)
1279	return false;
1280
1281	iters[i] = NULL;
1282	}
1283	else
1284	{
1285	iters[i] = stack_top->iter;
1286	stack_top = stack_top->prev;
1287	future_rank++;
1288	}
1289	break;
1290	case EXPR_CONSTANT:
1291	iters[i] = NULL;
1292	break;
1293	case EXPR_OP:
1294	switch (start->value.op.op)
1295	{
1296	case INTRINSIC_PLUS:
1297	case INTRINSIC_TIMES:
1298	if (start->value.op.op1->expr_type != EXPR_VARIABLE)
1299	std::swap (a&: start->value.op.op1, b&: start->value.op.op2);
1300	gcc_fallthrough ();
1301	case INTRINSIC_MINUS:
1302	if (start->value.op.op1->expr_type!= EXPR_VARIABLE
1303	|| start->value.op.op2->expr_type != EXPR_CONSTANT
1304	|| start->value.op.op1->ref)
1305	return false;
1306	if (!stack_top || !stack_top->iter
1307	|| stack_top->iter->var->symtree
1308	!= start->value.op.op1->symtree)
1309	return false;
1310	iters[i] = stack_top->iter;
1311	stack_top = stack_top->prev;
1312	break;
1313	default:
1314	return false;
1315	}
1316	future_rank++;
1317	break;
1318	default:
1319	return false;
1320	}
1321	}
1322
1323	/* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1324	for (int i = 1; i < ref->u.ar.dimen; i++)
1325	{
1326	if (iters[i])
1327	{
1328	gfc_expr *var = iters[i]->var;
1329	for (int j = 0; j < i; j++)
1330	{
1331	if (iters[j]
1332	&& (var_in_expr (expr1: var, expr2: iters[j]->start)
1333	|| var_in_expr (expr1: var, expr2: iters[j]->end)
1334	|| var_in_expr (expr1: var, expr2: iters[j]->step)))
1335	return false;
1336	}
1337	}
1338	}
1339
1340	/* Create new expr. */
1341	new_e = gfc_copy_expr (curr->expr1);
1342	new_e->expr_type = EXPR_VARIABLE;
1343	new_e->rank = future_rank;
1344	if (curr->expr1->shape)
1345	new_e->shape = gfc_get_shape (new_e->rank);
1346
1347	/* Assign new starts, ends and strides if necessary. */
1348	for (i = 0; i < ref->u.ar.dimen; i++)
1349	{
1350	if (!iters[i])
1351	continue;
1352	start = ref->u.ar.start[i];
1353	switch (start->expr_type)
1354	{
1355	case EXPR_CONSTANT:
1356	gfc_internal_error ("bad expression");
1357	break;
1358	case EXPR_VARIABLE:
1359	new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
1360	new_e->ref->u.ar.type = AR_SECTION;
1361	gfc_free_expr (new_e->ref->u.ar.start[i]);
1362	new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
1363	new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
1364	new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
1365	break;
1366	case EXPR_OP:
1367	new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
1368	new_e->ref->u.ar.type = AR_SECTION;
1369	gfc_free_expr (new_e->ref->u.ar.start[i]);
1370	expr = gfc_copy_expr (start);
1371	expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
1372	new_e->ref->u.ar.start[i] = expr;
1373	gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
1374	expr = gfc_copy_expr (start);
1375	expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
1376	new_e->ref->u.ar.end[i] = expr;
1377	gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
1378	switch (start->value.op.op)
1379	{
1380	case INTRINSIC_MINUS:
1381	case INTRINSIC_PLUS:
1382	new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
1383	break;
1384	case INTRINSIC_TIMES:
1385	expr = gfc_copy_expr (start);
1386	expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
1387	new_e->ref->u.ar.stride[i] = expr;
1388	gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
1389	break;
1390	default:
1391	gfc_internal_error ("bad op");
1392	}
1393	break;
1394	default:
1395	gfc_internal_error ("bad expression");
1396	}
1397	}
1398	curr->expr1 = new_e;
1399
1400	/* Insert modified statement. Check whether the statement needs to be
1401	inserted at the lowest level. */
1402	if (!stack_top->iter)
1403	{
1404	if (prev)
1405	{
1406	curr->next = prev->next->next;
1407	prev->next = curr;
1408	}
1409	else
1410	{
1411	curr->next = stack_top->code->block->next->next->next;
1412	stack_top->code->block->next = curr;
1413	}
1414	}
1415	else
1416	stack_top->code->block->next = curr;
1417	return true;
1418	}
1419
1420	/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1421	tries to optimize its block. */
1422
1423	static int
1424	simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
1425	void *data ATTRIBUTE_UNUSED)
1426	{
1427	gfc_code **curr, *prev = NULL;
1428	struct do_stack write, first;
1429	bool b = false;
1430	*walk_subtrees = 1;
1431	if (!(*code)->block
1432	|| ((*code)->block->op != EXEC_WRITE
1433	&& (*code)->block->op != EXEC_READ))
1434	return 0;
1435
1436	*walk_subtrees = 0;
1437	write.prev = NULL;
1438	write.iter = NULL;
1439	write.code = *code;
1440
1441	for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
1442	{
1443	if ((*curr)->op == EXEC_DO)
1444	{
1445	first.prev = &write;
1446	first.iter = (*curr)->ext.iterator;
1447	first.code = *curr;
1448	stack_top = &first;
1449	traverse_io_block (code: (*curr)->block->next, has_reached: &b, prev);
1450	stack_top = NULL;
1451	}
1452	prev = *curr;
1453	}
1454	return 0;
1455	}
1456
1457	/* Optimize a namespace, including all contained namespaces.
1458	flag_frontend_optimize and flag_frontend_loop_interchange are
1459	handled separately. */
1460
1461	static void
1462	optimize_namespace (gfc_namespace *ns)
1463	{
1464	gfc_namespace *saved_ns = gfc_current_ns;
1465	current_ns = ns;
1466	gfc_current_ns = ns;
1467	forall_level = 0;
1468	iterator_level = 0;
1469	in_assoc_list = false;
1470	in_omp_workshare = false;
1471	in_omp_atomic = false;
1472
1473	if (flag_frontend_optimize)
1474	{
1475	gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
1476	gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
1477	gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
1478	gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
1479	gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
1480	if (flag_inline_matmul_limit != 0 || flag_external_blas)
1481	{
1482	bool found;
1483	do
1484	{
1485	found = false;
1486	gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
1487	(void *) &found);
1488	}
1489	while (found);
1490
1491	gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
1492	NULL);
1493	}
1494
1495	if (flag_external_blas)
1496	gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
1497	NULL);
1498
1499	if (flag_inline_matmul_limit != 0)
1500	gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
1501	NULL);
1502	}
1503
1504	if (flag_frontend_loop_interchange)
1505	gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
1506	NULL);
1507
1508	/* BLOCKs are handled in the expression walker below. */
1509	for (ns = ns->contained; ns; ns = ns->sibling)
1510	{
1511	if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1512	optimize_namespace (ns);
1513	}
1514	gfc_current_ns = saved_ns;
1515	}
1516
1517	/* Handle dependencies for allocatable strings which potentially redefine
1518	themselves in an assignment. */
1519
1520	static void
1521	realloc_strings (gfc_namespace *ns)
1522	{
1523	current_ns = ns;
1524	gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
1525
1526	for (ns = ns->contained; ns; ns = ns->sibling)
1527	{
1528	if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1529	realloc_strings (ns);
1530	}
1531
1532	}
1533
1534	static void
1535	optimize_reduction (gfc_namespace *ns)
1536	{
1537	current_ns = ns;
1538	gfc_code_walker (&ns->code, gfc_dummy_code_callback,
1539	callback_reduction, NULL);
1540
1541	/* BLOCKs are handled in the expression walker below. */
1542	for (ns = ns->contained; ns; ns = ns->sibling)
1543	{
1544	if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1545	optimize_reduction (ns);
1546	}
1547	}
1548
1549	/* Replace code like
1550	a = matmul(b,c) + d
1551	with
1552	a = matmul(b,c) ; a = a + d
1553	where the array function is not elemental and not allocatable
1554	and does not depend on the left-hand side.
1555	*/
1556
1557	static bool
1558	optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1559	{
1560	gfc_expr *e;
1561
1562	if (!*rhs)
1563	return false;
1564
1565	e = *rhs;
1566	if (e->expr_type == EXPR_OP)
1567	{
1568	switch (e->value.op.op)
1569	{
1570	/* Unary operators and exponentiation: Only look at a single
1571	operand. */
1572	case INTRINSIC_NOT:
1573	case INTRINSIC_UPLUS:
1574	case INTRINSIC_UMINUS:
1575	case INTRINSIC_PARENTHESES:
1576	case INTRINSIC_POWER:
1577	if (optimize_binop_array_assignment (c, rhs: &e->value.op.op1, seen_op))
1578	return true;
1579	break;
1580
1581	case INTRINSIC_CONCAT:
1582	/* Do not do string concatenations. */
1583	break;
1584
1585	default:
1586	/* Binary operators. */
1587	if (optimize_binop_array_assignment (c, rhs: &e->value.op.op1, seen_op: true))
1588	return true;
1589
1590	if (optimize_binop_array_assignment (c, rhs: &e->value.op.op2, seen_op: true))
1591	return true;
1592
1593	break;
1594	}
1595	}
1596	else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
1597	&& ! (e->value.function.esym
1598	&& (e->value.function.esym->attr.elemental
1599	|| e->value.function.esym->attr.allocatable
1600	|| e->value.function.esym->ts.type != c->expr1->ts.type
1601	|| e->value.function.esym->ts.kind != c->expr1->ts.kind))
1602	&& ! (e->value.function.isym
1603	&& (e->value.function.isym->elemental
1604	|| e->ts.type != c->expr1->ts.type
1605	|| e->ts.kind != c->expr1->ts.kind))
1606	&& ! gfc_inline_intrinsic_function_p (e))
1607	{
1608
1609	gfc_code *n;
1610	gfc_expr *new_expr;
1611
1612	/* Insert a new assignment statement after the current one. */
1613	n = XCNEW (gfc_code);
1614	n->op = EXEC_ASSIGN;
1615	n->loc = c->loc;
1616	n->next = c->next;
1617	c->next = n;
1618
1619	n->expr1 = gfc_copy_expr (c->expr1);
1620	n->expr2 = c->expr2;
1621	new_expr = gfc_copy_expr (c->expr1);
1622	c->expr2 = e;
1623	*rhs = new_expr;
1624
1625	return true;
1626
1627	}
1628
1629	/* Nothing to optimize. */
1630	return false;
1631	}
1632
1633	/* Remove unneeded TRIMs at the end of expressions. */
1634
1635	static bool
1636	remove_trim (gfc_expr *rhs)
1637	{
1638	bool ret;
1639
1640	ret = false;
1641	if (!rhs)
1642	return ret;
1643
1644	/* Check for a // b // trim(c). Looping is probably not
1645	necessary because the parser usually generates
1646	(// (// a b ) trim(c) ) , but better safe than sorry. */
1647
1648	while (rhs->expr_type == EXPR_OP
1649	&& rhs->value.op.op == INTRINSIC_CONCAT)
1650	rhs = rhs->value.op.op2;
1651
1652	while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
1653	&& rhs->value.function.isym->id == GFC_ISYM_TRIM)
1654	{
1655	strip_function_call (rhs);
1656	/* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1657	remove_trim (rhs);
1658	ret = true;
1659	}
1660
1661	return ret;
1662	}
1663
1664	/* Optimizations for an assignment. */
1665
1666	static void
1667	optimize_assignment (gfc_code * c)
1668	{
1669	gfc_expr *lhs, *rhs;
1670
1671	lhs = c->expr1;
1672	rhs = c->expr2;
1673
1674	if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
1675	{
1676	/* Optimize a = trim(b) to a = b. */
1677	remove_trim (rhs);
1678
1679	/* Replace a = ' ' by a = '' to optimize away a memcpy. */
1680	if (is_empty_string (e: rhs))
1681	rhs->value.character.length = 0;
1682	}
1683
1684	if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
1685	optimize_binop_array_assignment (c, rhs: &rhs, seen_op: false);
1686	}
1687
1688
1689	/* Remove an unneeded function call, modifying the expression.
1690	This replaces the function call with the value of its
1691	first argument. The rest of the argument list is freed. */
1692
1693	static void
1694	strip_function_call (gfc_expr *e)
1695	{
1696	gfc_expr *e1;
1697	gfc_actual_arglist *a;
1698
1699	a = e->value.function.actual;
1700
1701	/* We should have at least one argument. */
1702	gcc_assert (a->expr != NULL);
1703
1704	e1 = a->expr;
1705
1706	/* Free the remaining arglist, if any. */
1707	if (a->next)
1708	gfc_free_actual_arglist (a->next);
1709
1710	/* Graft the argument expression onto the original function. */
1711	*e = *e1;
1712	free (ptr: e1);
1713
1714	}
1715
1716	/* Optimization of lexical comparison functions. */
1717
1718	static bool
1719	optimize_lexical_comparison (gfc_expr *e)
1720	{
1721	if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1722	return false;
1723
1724	switch (e->value.function.isym->id)
1725	{
1726	case GFC_ISYM_LLE:
1727	return optimize_comparison (e, INTRINSIC_LE);
1728
1729	case GFC_ISYM_LGE:
1730	return optimize_comparison (e, INTRINSIC_GE);
1731
1732	case GFC_ISYM_LGT:
1733	return optimize_comparison (e, INTRINSIC_GT);
1734
1735	case GFC_ISYM_LLT:
1736	return optimize_comparison (e, INTRINSIC_LT);
1737
1738	default:
1739	break;
1740	}
1741	return false;
1742	}
1743
1744	/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1745	do CHARACTER because of possible pessimization involving character
1746	lengths. */
1747
1748	static bool
1749	combine_array_constructor (gfc_expr *e)
1750	{
1751
1752	gfc_expr *op1, *op2;
1753	gfc_expr *scalar;
1754	gfc_expr *new_expr;
1755	gfc_constructor *c, *new_c;
1756	gfc_constructor_base oldbase, newbase;
1757	bool scalar_first;
1758	int n_elem;
1759	bool all_const;
1760
1761	/* Array constructors have rank one. */
1762	if (e->rank != 1)
1763	return false;
1764
1765	/* Don't try to combine association lists, this makes no sense
1766	and leads to an ICE. */
1767	if (in_assoc_list)
1768	return false;
1769
1770	/* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1771	if (forall_level > 0)
1772	return false;
1773
1774	/* Inside an iterator, things can get hairy; we are likely to create
1775	an invalid temporary variable. */
1776	if (iterator_level > 0)
1777	return false;
1778
1779	/* WHERE also doesn't work. */
1780	if (in_where > 0)
1781	return false;
1782
1783	op1 = e->value.op.op1;
1784	op2 = e->value.op.op2;
1785
1786	if (!op1 || !op2)
1787	return false;
1788
1789	if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1790	scalar_first = false;
1791	else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1792	{
1793	scalar_first = true;
1794	op1 = e->value.op.op2;
1795	op2 = e->value.op.op1;
1796	}
1797	else
1798	return false;
1799
1800	if (op2->ts.type == BT_CHARACTER)
1801	return false;
1802
1803	/* This might be an expanded constructor with very many constant values. If
1804	we perform the operation here, we might end up with a long compile time
1805	and actually longer execution time, so a length bound is in order here.
1806	If the constructor constains something which is not a constant, it did
1807	not come from an expansion, so leave it alone. */
1808
1809	#define CONSTR_LEN_MAX 4
1810
1811	oldbase = op1->value.constructor;
1812
1813	n_elem = 0;
1814	all_const = true;
1815	for (c = gfc_constructor_first (base: oldbase); c; c = gfc_constructor_next(ctor: c))
1816	{
1817	if (c->expr->expr_type != EXPR_CONSTANT)
1818	{
1819	all_const = false;
1820	break;
1821	}
1822	n_elem += 1;
1823	}
1824
1825	if (all_const && n_elem > CONSTR_LEN_MAX)
1826	return false;
1827
1828	#undef CONSTR_LEN_MAX
1829
1830	newbase = NULL;
1831	e->expr_type = EXPR_ARRAY;
1832
1833	scalar = create_var (e: gfc_copy_expr (op2), vname: "constr");
1834
1835	for (c = gfc_constructor_first (base: oldbase); c;
1836	c = gfc_constructor_next (ctor: c))
1837	{
1838	new_expr = gfc_get_expr ();
1839	new_expr->ts = e->ts;
1840	new_expr->expr_type = EXPR_OP;
1841	new_expr->rank = c->expr->rank;
1842	new_expr->where = c->expr->where;
1843	new_expr->value.op.op = e->value.op.op;
1844
1845	if (scalar_first)
1846	{
1847	new_expr->value.op.op1 = gfc_copy_expr (scalar);
1848	new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1849	}
1850	else
1851	{
1852	new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1853	new_expr->value.op.op2 = gfc_copy_expr (scalar);
1854	}
1855
1856	new_c = gfc_constructor_append_expr (base: &newbase, e: new_expr, where: &(e->where));
1857	new_c->iterator = c->iterator;
1858	c->iterator = NULL;
1859	}
1860
1861	gfc_free_expr (op1);
1862	gfc_free_expr (op2);
1863	gfc_free_expr (scalar);
1864
1865	e->value.constructor = newbase;
1866	return true;
1867	}
1868
1869	/* Recursive optimization of operators. */
1870
1871	static bool
1872	optimize_op (gfc_expr *e)
1873	{
1874	bool changed;
1875
1876	gfc_intrinsic_op op = e->value.op.op;
1877
1878	changed = false;
1879
1880	/* Only use new-style comparisons. */
1881	switch(op)
1882	{
1883	case INTRINSIC_EQ_OS:
1884	op = INTRINSIC_EQ;
1885	break;
1886
1887	case INTRINSIC_GE_OS:
1888	op = INTRINSIC_GE;
1889	break;
1890
1891	case INTRINSIC_LE_OS:
1892	op = INTRINSIC_LE;
1893	break;
1894
1895	case INTRINSIC_NE_OS:
1896	op = INTRINSIC_NE;
1897	break;
1898
1899	case INTRINSIC_GT_OS:
1900	op = INTRINSIC_GT;
1901	break;
1902
1903	case INTRINSIC_LT_OS:
1904	op = INTRINSIC_LT;
1905	break;
1906
1907	default:
1908	break;
1909	}
1910
1911	switch (op)
1912	{
1913	case INTRINSIC_EQ:
1914	case INTRINSIC_GE:
1915	case INTRINSIC_LE:
1916	case INTRINSIC_NE:
1917	case INTRINSIC_GT:
1918	case INTRINSIC_LT:
1919	changed = optimize_comparison (e, op);
1920
1921	gcc_fallthrough ();
1922	/* Look at array constructors. */
1923	case INTRINSIC_PLUS:
1924	case INTRINSIC_MINUS:
1925	case INTRINSIC_TIMES:
1926	case INTRINSIC_DIVIDE:
1927	return combine_array_constructor (e) || changed;
1928
1929	default:
1930	break;
1931	}
1932
1933	return false;
1934	}
1935
1936
1937	/* Return true if a constant string contains only blanks. */
1938
1939	static bool
1940	is_empty_string (gfc_expr *e)
1941	{
1942	int i;
1943
1944	if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1945	return false;
1946
1947	for (i=0; i < e->value.character.length; i++)
1948	{
1949	if (e->value.character.string[i] != ' ')
1950	return false;
1951	}
1952
1953	return true;
1954	}
1955
1956
1957	/* Insert a call to the intrinsic len_trim. Use a different name for
1958	the symbol tree so we don't run into trouble when the user has
1959	renamed len_trim for some reason. */
1960
1961	static gfc_expr*
1962	get_len_trim_call (gfc_expr *str, int kind)
1963	{
1964	gfc_expr *fcn;
1965	gfc_actual_arglist *actual_arglist, *next;
1966
1967	fcn = gfc_get_expr ();
1968	fcn->expr_type = EXPR_FUNCTION;
1969	fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1970	actual_arglist = gfc_get_actual_arglist ();
1971	actual_arglist->expr = str;
1972	next = gfc_get_actual_arglist ();
1973	next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1974	actual_arglist->next = next;
1975
1976	fcn->value.function.actual = actual_arglist;
1977	fcn->where = str->where;
1978	fcn->ts.type = BT_INTEGER;
1979	fcn->ts.kind = gfc_charlen_int_kind;
1980
1981	gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1982	fcn->symtree->n.sym->ts = fcn->ts;
1983	fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1984	fcn->symtree->n.sym->attr.function = 1;
1985	fcn->symtree->n.sym->attr.elemental = 1;
1986	fcn->symtree->n.sym->attr.referenced = 1;
1987	fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1988	gfc_commit_symbol (fcn->symtree->n.sym);
1989
1990	return fcn;
1991	}
1992
1993
1994	/* Optimize expressions for equality. */
1995
1996	static bool
1997	optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
1998	{
1999	gfc_expr *op1, *op2;
2000	bool change;
2001	int eq;
2002	bool result;
2003	gfc_actual_arglist *firstarg, *secondarg;
2004
2005	if (e->expr_type == EXPR_OP)
2006	{
2007	firstarg = NULL;
2008	secondarg = NULL;
2009	op1 = e->value.op.op1;
2010	op2 = e->value.op.op2;
2011	}
2012	else if (e->expr_type == EXPR_FUNCTION)
2013	{
2014	/* One of the lexical comparison functions. */
2015	firstarg = e->value.function.actual;
2016	secondarg = firstarg->next;
2017	op1 = firstarg->expr;
2018	op2 = secondarg->expr;
2019	}
2020	else
2021	gcc_unreachable ();
2022
2023	/* Strip off unneeded TRIM calls from string comparisons. */
2024
2025	change = remove_trim (rhs: op1);
2026
2027	if (remove_trim (rhs: op2))
2028	change = true;
2029
2030	/* An expression of type EXPR_CONSTANT is only valid for scalars. */
2031	/* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2032	handles them well). However, there are also cases that need a non-scalar
2033	argument. For example the any intrinsic. See PR 45380. */
2034	if (e->rank > 0)
2035	return change;
2036
2037	/* Replace a == '' with len_trim(a) == 0 and a /= '' with
2038	len_trim(a) != 0 */
2039	if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2040	&& (op == INTRINSIC_EQ || op == INTRINSIC_NE))
2041	{
2042	bool empty_op1, empty_op2;
2043	empty_op1 = is_empty_string (e: op1);
2044	empty_op2 = is_empty_string (e: op2);
2045
2046	if (empty_op1 || empty_op2)
2047	{
2048	gfc_expr *fcn;
2049	gfc_expr *zero;
2050	gfc_expr *str;
2051
2052	/* This can only happen when an error for comparing
2053	characters of different kinds has already been issued. */
2054	if (empty_op1 && empty_op2)
2055	return false;
2056
2057	zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
2058	str = empty_op1 ? op2 : op1;
2059
2060	fcn = get_len_trim_call (str, kind: gfc_charlen_int_kind);
2061
2062
2063	if (empty_op1)
2064	gfc_free_expr (op1);
2065	else
2066	gfc_free_expr (op2);
2067
2068	op1 = fcn;
2069	op2 = zero;
2070	e->value.op.op1 = fcn;
2071	e->value.op.op2 = zero;
2072	}
2073	}
2074
2075
2076	/* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2077
2078	if (flag_finite_math_only
2079	|| (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
2080	&& op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
2081	{
2082	eq = gfc_dep_compare_expr (op1, op2);
2083	if (eq <= -2)
2084	{
2085	/* Replace A // B < A // C with B < C, and A // B < C // B
2086	with A < C. */
2087	if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2088	&& op1->expr_type == EXPR_OP
2089	&& op1->value.op.op == INTRINSIC_CONCAT
2090	&& op2->expr_type == EXPR_OP
2091	&& op2->value.op.op == INTRINSIC_CONCAT)
2092	{
2093	gfc_expr *op1_left = op1->value.op.op1;
2094	gfc_expr *op2_left = op2->value.op.op1;
2095	gfc_expr *op1_right = op1->value.op.op2;
2096	gfc_expr *op2_right = op2->value.op.op2;
2097
2098	if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
2099	{
2100	/* Watch out for 'A ' // x vs. 'A' // x. */
2101
2102	if (op1_left->expr_type == EXPR_CONSTANT
2103	&& op2_left->expr_type == EXPR_CONSTANT
2104	&& op1_left->value.character.length
2105	!= op2_left->value.character.length)
2106	return change;
2107	else
2108	{
2109	free (ptr: op1_left);
2110	free (ptr: op2_left);
2111	if (firstarg)
2112	{
2113	firstarg->expr = op1_right;
2114	secondarg->expr = op2_right;
2115	}
2116	else
2117	{
2118	e->value.op.op1 = op1_right;
2119	e->value.op.op2 = op2_right;
2120	}
2121	optimize_comparison (e, op);
2122	return true;
2123	}
2124	}
2125	if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
2126	{
2127	free (ptr: op1_right);
2128	free (ptr: op2_right);
2129	if (firstarg)
2130	{
2131	firstarg->expr = op1_left;
2132	secondarg->expr = op2_left;
2133	}
2134	else
2135	{
2136	e->value.op.op1 = op1_left;
2137	e->value.op.op2 = op2_left;
2138	}
2139
2140	optimize_comparison (e, op);
2141	return true;
2142	}
2143	}
2144	}
2145	else
2146	{
2147	/* eq can only be -1, 0 or 1 at this point. */
2148	switch (op)
2149	{
2150	case INTRINSIC_EQ:
2151	result = eq == 0;
2152	break;
2153
2154	case INTRINSIC_GE:
2155	result = eq >= 0;
2156	break;
2157
2158	case INTRINSIC_LE:
2159	result = eq <= 0;
2160	break;
2161
2162	case INTRINSIC_NE:
2163	result = eq != 0;
2164	break;
2165
2166	case INTRINSIC_GT:
2167	result = eq > 0;
2168	break;
2169
2170	case INTRINSIC_LT:
2171	result = eq < 0;
2172	break;
2173
2174	default:
2175	gfc_internal_error ("illegal OP in optimize_comparison");
2176	break;
2177	}
2178
2179	/* Replace the expression by a constant expression. The typespec
2180	and where remains the way it is. */
2181	free (ptr: op1);
2182	free (ptr: op2);
2183	e->expr_type = EXPR_CONSTANT;
2184	e->value.logical = result;
2185	return true;
2186	}
2187	}
2188
2189	return change;
2190	}
2191
2192	/* Optimize a trim function by replacing it with an equivalent substring
2193	involving a call to len_trim. This only works for expressions where
2194	variables are trimmed. Return true if anything was modified. */
2195
2196	static bool
2197	optimize_trim (gfc_expr *e)
2198	{
2199	gfc_expr *a;
2200	gfc_ref *ref;
2201	gfc_expr *fcn;
2202	gfc_ref **rr = NULL;
2203
2204	/* Don't do this optimization within an argument list, because
2205	otherwise aliasing issues may occur. */
2206
2207	if (count_arglist != 1)
2208	return false;
2209
2210	if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
2211	|| e->value.function.isym == NULL
2212	|| e->value.function.isym->id != GFC_ISYM_TRIM)
2213	return false;
2214
2215	a = e->value.function.actual->expr;
2216
2217	if (a->expr_type != EXPR_VARIABLE)
2218	return false;
2219
2220	/* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2221
2222	if (a->symtree->n.sym->attr.allocatable)
2223	return false;
2224
2225	/* Follow all references to find the correct place to put the newly
2226	created reference. FIXME: Also handle substring references and
2227	array references. Array references cause strange regressions at
2228	the moment. */
2229
2230	if (a->ref)
2231	{
2232	for (rr = &(a->ref); *rr; rr = &((*rr)->next))
2233	{
2234	if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
2235	return false;
2236	}
2237	}
2238
2239	strip_function_call (e);
2240
2241	if (e->ref == NULL)
2242	rr = &(e->ref);
2243
2244	/* Create the reference. */
2245
2246	ref = gfc_get_ref ();
2247	ref->type = REF_SUBSTRING;
2248
2249	/* Set the start of the reference. */
2250
2251	ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
2252
2253	/* Build the function call to len_trim(x, gfc_default_integer_kind). */
2254
2255	fcn = get_len_trim_call (str: gfc_copy_expr (e), kind: gfc_charlen_int_kind);
2256
2257	/* Set the end of the reference to the call to len_trim. */
2258
2259	ref->u.ss.end = fcn;
2260	gcc_assert (rr != NULL && *rr == NULL);
2261	*rr = ref;
2262	return true;
2263	}
2264
2265	/* Optimize minloc(b), where b is rank 1 array, into
2266	(/ minloc(b, dim=1) /), and similarly for maxloc,
2267	as the latter forms are expanded inline. */
2268
2269	static void
2270	optimize_minmaxloc (gfc_expr **e)
2271	{
2272	gfc_expr *fn = *e;
2273	gfc_actual_arglist *a;
2274	char *name, *p;
2275
2276	if (fn->rank != 1
2277	|| fn->value.function.actual == NULL
2278	|| fn->value.function.actual->expr == NULL
2279	|| fn->value.function.actual->expr->ts.type == BT_CHARACTER
2280	|| fn->value.function.actual->expr->rank != 1)
2281	return;
2282
2283	*e = gfc_get_array_expr (type: fn->ts.type, kind: fn->ts.kind, &fn->where);
2284	(*e)->shape = fn->shape;
2285	fn->rank = 0;
2286	fn->shape = NULL;
2287	gfc_constructor_append_expr (base: &(*e)->value.constructor, e: fn, where: &fn->where);
2288
2289	name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
2290	strcpy (dest: name, src: fn->value.function.name);
2291	p = strstr (haystack: name, needle: "loc0");
2292	p[3] = '1';
2293	fn->value.function.name = gfc_get_string ("%s", name);
2294	if (fn->value.function.actual->next)
2295	{
2296	a = fn->value.function.actual->next;
2297	gcc_assert (a->expr == NULL);
2298	}
2299	else
2300	{
2301	a = gfc_get_actual_arglist ();
2302	fn->value.function.actual->next = a;
2303	}
2304	a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2305	&fn->where);
2306	mpz_set_ui (a->expr->value.integer, 1);
2307	}
2308
2309	/* Data package to hand down for DO loop checks in a contained
2310	procedure. */
2311	typedef struct contained_info
2312	{
2313	gfc_symbol *do_var;
2314	gfc_symbol *procedure;
2315	locus where_do;
2316	} contained_info;
2317
2318	static enum gfc_exec_op last_io_op;
2319
2320	/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
2321	contained function call. */
2322
2323	static int
2324	doloop_contained_function_call (gfc_expr **e,
2325	int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
2326	{
2327	gfc_expr *expr = *e;
2328	gfc_formal_arglist *f;
2329	gfc_actual_arglist *a;
2330	gfc_symbol *sym, *do_var;
2331	contained_info *info;
2332
2333	if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
2334	|| expr->value.function.esym == NULL)
2335	return 0;
2336
2337	sym = expr->value.function.esym;
2338	f = gfc_sym_get_dummy_args (sym);
2339	if (f == NULL)
2340	return 0;
2341
2342	info = (contained_info *) data;
2343	do_var = info->do_var;
2344	a = expr->value.function.actual;
2345
2346	while (a && f)
2347	{
2348	if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
2349	{
2350	if (f->sym->attr.intent == INTENT_OUT)
2351	{
2352	gfc_error_now ("Index variable %qs set to undefined as "
2353	"INTENT(OUT) argument at %L in procedure %qs "
2354	"called from within DO loop at %L", do_var->name,
2355	&a->expr->where, info->procedure->name,
2356	&info->where_do);
2357	return 1;
2358	}
2359	else if (f->sym->attr.intent == INTENT_INOUT)
2360	{
2361	gfc_error_now ("Index variable %qs not definable as "
2362	"INTENT(INOUT) argument at %L in procedure %qs "
2363	"called from within DO loop at %L", do_var->name,
2364	&a->expr->where, info->procedure->name,
2365	&info->where_do);
2366	return 1;
2367	}
2368	}
2369	a = a->next;
2370	f = f->next;
2371	}
2372	return 0;
2373	}
2374
2375	/* Callback function that goes through the code in a contained
2376	procedure to make sure it does not change a variable in a DO
2377	loop. */
2378
2379	static int
2380	doloop_contained_procedure_code (gfc_code **c,
2381	int *walk_subtrees ATTRIBUTE_UNUSED,
2382	void *data)
2383	{
2384	gfc_code *co = *c;
2385	contained_info *info = (contained_info *) data;
2386	gfc_symbol *do_var = info->do_var;
2387	const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
2388	"called from within DO loop at %L");
2389	static enum gfc_exec_op saved_io_op;
2390
2391	switch (co->op)
2392	{
2393	case EXEC_ASSIGN:
2394	if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var)
2395	gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
2396	&info->where_do);
2397	break;
2398
2399	case EXEC_DO:
2400	if (co->ext.iterator && co->ext.iterator->var
2401	&& co->ext.iterator->var->symtree->n.sym == do_var)
2402	gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
2403	&info->where_do);
2404	break;
2405
2406	case EXEC_READ:
2407	case EXEC_WRITE:
2408	case EXEC_INQUIRE:
2409	case EXEC_IOLENGTH:
2410	saved_io_op = last_io_op;
2411	last_io_op = co->op;
2412	break;
2413
2414	case EXEC_OPEN:
2415	if (co->ext.open && co->ext.open->iostat
2416	&& co->ext.open->iostat->symtree->n.sym == do_var)
2417	gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
2418	info->procedure->name, &info->where_do);
2419	break;
2420
2421	case EXEC_CLOSE:
2422	if (co->ext.close && co->ext.close->iostat
2423	&& co->ext.close->iostat->symtree->n.sym == do_var)
2424	gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
2425	info->procedure->name, &info->where_do);
2426	break;
2427
2428	case EXEC_TRANSFER:
2429	switch (last_io_op)
2430	{
2431
2432	case EXEC_INQUIRE:
2433	#define CHECK_INQ(a) do { if (co->ext.inquire && \
2434	co->ext.inquire->a && \
2435	co->ext.inquire->a->symtree->n.sym == do_var) \
2436	gfc_error_now (errmsg, do_var->name, \
2437	&co->ext.inquire->a->where, \
2438	info->procedure->name, \
2439	&info->where_do); \
2440	} while (0)
2441
2442	CHECK_INQ(iostat);
2443	CHECK_INQ(number);
2444	CHECK_INQ(position);
2445	CHECK_INQ(recl);
2446	CHECK_INQ(position);
2447	CHECK_INQ(iolength);
2448	CHECK_INQ(strm_pos);
2449	break;
2450	#undef CHECK_INQ
2451
2452	case EXEC_READ:
2453	if (co->expr1 && co->expr1->symtree
2454	&& co->expr1->symtree->n.sym == do_var)
2455	gfc_error_now (errmsg, do_var->name, &co->expr1->where,
2456	info->procedure->name, &info->where_do);
2457
2458	/* Fallthrough. */
2459
2460	case EXEC_WRITE:
2461	if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree
2462	&& co->ext.dt->iostat->symtree->n.sym == do_var)
2463	gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
2464	info->procedure->name, &info->where_do);
2465	break;
2466
2467	case EXEC_IOLENGTH:
2468	if (co->expr1 && co->expr1->symtree
2469	&& co->expr1->symtree->n.sym == do_var)
2470	gfc_error_now (errmsg, do_var->name, &co->expr1->where,
2471	info->procedure->name, &info->where_do);
2472	break;
2473
2474	default:
2475	gcc_unreachable ();
2476	}
2477	break;
2478
2479	case EXEC_DT_END:
2480	last_io_op = saved_io_op;
2481	break;
2482
2483	case EXEC_CALL:
2484	gfc_formal_arglist *f;
2485	gfc_actual_arglist *a;
2486
2487	f = gfc_sym_get_dummy_args (co->resolved_sym);
2488	if (f == NULL)
2489	break;
2490	a = co->ext.actual;
2491	/* Slightly different error message here. If there is an error,
2492	return 1 to avoid an infinite loop. */
2493	while (a && f)
2494	{
2495	if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
2496	{
2497	if (f->sym->attr.intent == INTENT_OUT)
2498	{
2499	gfc_error_now ("Index variable %qs set to undefined as "
2500	"INTENT(OUT) argument at %L in subroutine %qs "
2501	"called from within DO loop at %L",
2502	do_var->name, &a->expr->where,
2503	info->procedure->name, &info->where_do);
2504	return 1;
2505	}
2506	else if (f->sym->attr.intent == INTENT_INOUT)
2507	{
2508	gfc_error_now ("Index variable %qs not definable as "
2509	"INTENT(INOUT) argument at %L in subroutine %qs "
2510	"called from within DO loop at %L", do_var->name,
2511	&a->expr->where, info->procedure->name,
2512	&info->where_do);
2513	return 1;
2514	}
2515	}
2516	a = a->next;
2517	f = f->next;
2518	}
2519	break;
2520	default:
2521	break;
2522	}
2523	return 0;
2524	}
2525
2526	/* Callback function for code checking that we do not pass a DO variable to an
2527	INTENT(OUT) or INTENT(INOUT) dummy variable. */
2528
2529	static int
2530	doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
2531	void *data ATTRIBUTE_UNUSED)
2532	{
2533	gfc_code *co;
2534	int i;
2535	gfc_formal_arglist *f;
2536	gfc_actual_arglist *a;
2537	gfc_code *cl;
2538	do_t loop, *lp;
2539	bool seen_goto;
2540
2541	co = *c;
2542
2543	/* If the doloop_list grew, we have to truncate it here. */
2544
2545	if ((unsigned) doloop_level < doloop_list.length())
2546	doloop_list.truncate (size: doloop_level);
2547
2548	seen_goto = false;
2549	switch (co->op)
2550	{
2551	case EXEC_DO:
2552
2553	if (co->ext.iterator && co->ext.iterator->var)
2554	loop.c = co;
2555	else
2556	loop.c = NULL;
2557
2558	loop.branch_level = if_level + select_level;
2559	loop.seen_goto = false;
2560	doloop_list.safe_push (obj: loop);
2561	break;
2562
2563	/* If anything could transfer control away from a suspicious
2564	subscript, make sure to set seen_goto in the current DO loop
2565	(if any). */
2566	case EXEC_GOTO:
2567	case EXEC_EXIT:
2568	case EXEC_STOP:
2569	case EXEC_ERROR_STOP:
2570	case EXEC_CYCLE:
2571	seen_goto = true;
2572	break;
2573
2574	case EXEC_OPEN:
2575	if (co->ext.open->err)
2576	seen_goto = true;
2577	break;
2578
2579	case EXEC_CLOSE:
2580	if (co->ext.close->err)
2581	seen_goto = true;
2582	break;
2583
2584	case EXEC_BACKSPACE:
2585	case EXEC_ENDFILE:
2586	case EXEC_REWIND:
2587	case EXEC_FLUSH:
2588
2589	if (co->ext.filepos->err)
2590	seen_goto = true;
2591	break;
2592
2593	case EXEC_INQUIRE:
2594	if (co->ext.filepos->err)
2595	seen_goto = true;
2596	break;
2597
2598	case EXEC_READ:
2599	case EXEC_WRITE:
2600	if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
2601	seen_goto = true;
2602	break;
2603
2604	case EXEC_WAIT:
2605	if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
2606	loop.seen_goto = true;
2607	break;
2608
2609	case EXEC_CALL:
2610	if (co->resolved_sym == NULL)
2611	break;
2612
2613	/* Test if somebody stealthily changes the DO variable from
2614	under us by changing it in a host-associated procedure. */
2615	if (co->resolved_sym->attr.contained)
2616	{
2617	FOR_EACH_VEC_ELT (doloop_list, i, lp)
2618	{
2619	gfc_symbol *sym = co->resolved_sym;
2620	contained_info info;
2621	gfc_namespace *ns;
2622
2623	cl = lp->c;
2624	info.do_var = cl->ext.iterator->var->symtree->n.sym;
2625	info.procedure = co->resolved_sym; /* sym? */
2626	info.where_do = co->loc;
2627	/* Look contained procedures under the namespace of the
2628	variable. */
2629	for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
2630	if (ns->proc_name && ns->proc_name == sym)
2631	gfc_code_walker (&ns->code, doloop_contained_procedure_code,
2632	doloop_contained_function_call, &info);
2633	}
2634	}
2635
2636	f = gfc_sym_get_dummy_args (co->resolved_sym);
2637
2638	/* Withot a formal arglist, there is only unknown INTENT,
2639	which we don't check for. */
2640	if (f == NULL)
2641	break;
2642
2643	a = co->ext.actual;
2644
2645	while (a && f)
2646	{
2647	FOR_EACH_VEC_ELT (doloop_list, i, lp)
2648	{
2649	gfc_symbol *do_sym;
2650	cl = lp->c;
2651
2652	if (cl == NULL)
2653	break;
2654
2655	do_sym = cl->ext.iterator->var->symtree->n.sym;
2656
2657	if (a->expr && a->expr->symtree && f->sym
2658	&& a->expr->symtree->n.sym == do_sym)
2659	{
2660	if (f->sym->attr.intent == INTENT_OUT)
2661	gfc_error_now ("Variable %qs at %L set to undefined "
2662	"value inside loop beginning at %L as "
2663	"INTENT(OUT) argument to subroutine %qs",
2664	do_sym->name, &a->expr->where,
2665	&(doloop_list[i].c->loc),
2666	co->symtree->n.sym->name);
2667	else if (f->sym->attr.intent == INTENT_INOUT)
2668	gfc_error_now ("Variable %qs at %L not definable inside "
2669	"loop beginning at %L as INTENT(INOUT) "
2670	"argument to subroutine %qs",
2671	do_sym->name, &a->expr->where,
2672	&(doloop_list[i].c->loc),
2673	co->symtree->n.sym->name);
2674	}
2675	}
2676	a = a->next;
2677	f = f->next;
2678	}
2679
2680	break;
2681
2682	default:
2683	break;
2684	}
2685	if (seen_goto && doloop_level > 0)
2686	doloop_list[doloop_level-1].seen_goto = true;
2687
2688	return 0;
2689	}
2690
2691	/* Callback function to warn about different things within DO loops. */
2692
2693	static int
2694	do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2695	void *data ATTRIBUTE_UNUSED)
2696	{
2697	do_t *last;
2698
2699	if (doloop_list.length () == 0)
2700	return 0;
2701
2702	if ((*e)->expr_type == EXPR_FUNCTION)
2703	do_intent (e);
2704
2705	last = &doloop_list.last();
2706	if (last->seen_goto && !warn_do_subscript)
2707	return 0;
2708
2709	if ((*e)->expr_type == EXPR_VARIABLE)
2710	do_subscript (e);
2711
2712	return 0;
2713	}
2714
2715	typedef struct
2716	{
2717	gfc_symbol *sym;
2718	mpz_t val;
2719	} insert_index_t;
2720
2721	/* Callback function - if the expression is the variable in data->sym,
2722	replace it with a constant from data->val. */
2723
2724	static int
2725	callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2726	void *data)
2727	{
2728	insert_index_t *d;
2729	gfc_expr *ex, *n;
2730
2731	ex = (*e);
2732	if (ex->expr_type != EXPR_VARIABLE)
2733	return 0;
2734
2735	d = (insert_index_t *) data;
2736	if (ex->symtree->n.sym != d->sym)
2737	return 0;
2738
2739	n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
2740	mpz_set (n->value.integer, d->val);
2741
2742	gfc_free_expr (ex);
2743	*e = n;
2744	return 0;
2745	}
2746
2747	/* In the expression e, replace occurrences of the variable sym with
2748	val. If this results in a constant expression, return true and
2749	return the value in ret. Return false if the expression already
2750	is a constant. Caller has to clear ret in that case. */
2751
2752	static bool
2753	insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
2754	{
2755	gfc_expr *n;
2756	insert_index_t data;
2757	bool rc;
2758
2759	if (e->expr_type == EXPR_CONSTANT)
2760	return false;
2761
2762	n = gfc_copy_expr (e);
2763	data.sym = sym;
2764	mpz_init_set (data.val, val);
2765	gfc_expr_walker (&n, callback_insert_index, (void *) &data);
2766
2767	/* Suppress errors here - we could get errors here such as an
2768	out of bounds access for arrays, see PR 90563. */
2769	gfc_push_suppress_errors ();
2770	gfc_simplify_expr (n, 0);
2771	gfc_pop_suppress_errors ();
2772
2773	if (n->expr_type == EXPR_CONSTANT)
2774	{
2775	rc = true;
2776	mpz_init_set (ret, n->value.integer);
2777	}
2778	else
2779	rc = false;
2780
2781	mpz_clear (data.val);
2782	gfc_free_expr (n);
2783	return rc;
2784
2785	}
2786
2787	/* Check array subscripts for possible out-of-bounds accesses in DO
2788	loops with constant bounds. */
2789
2790	static int
2791	do_subscript (gfc_expr **e)
2792	{
2793	gfc_expr *v;
2794	gfc_array_ref *ar;
2795	gfc_ref *ref;
2796	int i,j;
2797	gfc_code *dl;
2798	do_t *lp;
2799
2800	v = *e;
2801	/* Constants are already checked. */
2802	if (v->expr_type == EXPR_CONSTANT)
2803	return 0;
2804
2805	/* Wrong warnings will be generated in an associate list. */
2806	if (in_assoc_list)
2807	return 0;
2808
2809	/* We already warned about this. */
2810	if (v->do_not_warn)
2811	return 0;
2812
2813	v->do_not_warn = 1;
2814
2815	for (ref = v->ref; ref; ref = ref->next)
2816	{
2817	if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
2818	{
2819	ar = & ref->u.ar;
2820	FOR_EACH_VEC_ELT (doloop_list, j, lp)
2821	{
2822	gfc_symbol *do_sym;
2823	mpz_t do_start, do_step, do_end;
2824	bool have_do_start, have_do_end;
2825	bool error_not_proven;
2826	int warn;
2827	int sgn;
2828
2829	dl = lp->c;
2830	if (dl == NULL)
2831	break;
2832
2833	/* If we are within a branch, or a goto or equivalent
2834	was seen in the DO loop before, then we cannot prove that
2835	this expression is actually evaluated. Don't do anything
2836	unless we want to see it all. */
2837	error_not_proven = lp->seen_goto
2838	|| lp->branch_level < if_level + select_level;
2839
2840	if (error_not_proven && !warn_do_subscript)
2841	break;
2842
2843	if (error_not_proven)
2844	warn = OPT_Wdo_subscript;
2845	else
2846	warn = 0;
2847
2848	do_sym = dl->ext.iterator->var->symtree->n.sym;
2849	if (do_sym->ts.type != BT_INTEGER)
2850	continue;
2851
2852	/* If we do not know about the stepsize, the loop may be zero trip.
2853	Do not warn in this case. */
2854
2855	if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
2856	{
2857	sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
2858	/* This can happen, but then the error has been
2859	reported previously. */
2860	if (sgn == 0)
2861	continue;
2862
2863	mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
2864	}
2865
2866	else
2867	continue;
2868
2869	if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
2870	{
2871	have_do_start = true;
2872	mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
2873	}
2874	else
2875	have_do_start = false;
2876
2877	if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
2878	{
2879	have_do_end = true;
2880	mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
2881	}
2882	else
2883	have_do_end = false;
2884
2885	if (!have_do_start && !have_do_end)
2886	{
2887	mpz_clear (do_step);
2888	return 0;
2889	}
2890
2891	/* No warning inside a zero-trip loop. */
2892	if (have_do_start && have_do_end)
2893	{
2894	int cmp;
2895
2896	cmp = mpz_cmp (do_end, do_start);
2897	if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
2898	{
2899	mpz_clear (do_start);
2900	mpz_clear (do_end);
2901	mpz_clear (do_step);
2902	break;
2903	}
2904	}
2905
2906	/* May have to correct the end value if the step does not equal
2907	one. */
2908	if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
2909	{
2910	mpz_t diff, rem;
2911
2912	mpz_init (diff);
2913	mpz_init (rem);
2914	mpz_sub (diff, do_end, do_start);
2915	mpz_tdiv_r (rem, diff, do_step);
2916	mpz_sub (do_end, do_end, rem);
2917	mpz_clear (diff);
2918	mpz_clear (rem);
2919	}
2920
2921	for (i = 0; i< ar->dimen; i++)
2922	{
2923	mpz_t val;
2924	if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
2925	&& insert_index (e: ar->start[i], sym: do_sym, val: do_start, ret: val))
2926	{
2927	if (ar->as->lower[i]
2928	&& ar->as->lower[i]->expr_type == EXPR_CONSTANT
2929	&& ar->as->lower[i]->ts.type == BT_INTEGER
2930	&& mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2931	gfc_warning (opt: warn, "Array reference at %L out of bounds "
2932	"(%ld < %ld) in loop beginning at %L",
2933	&ar->start[i]->where, mpz_get_si (val),
2934	mpz_get_si (ar->as->lower[i]->value.integer),
2935	&doloop_list[j].c->loc);
2936
2937	if (ar->as->upper[i]
2938	&& ar->as->upper[i]->expr_type == EXPR_CONSTANT
2939	&& ar->as->upper[i]->ts.type == BT_INTEGER
2940	&& mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2941	gfc_warning (opt: warn, "Array reference at %L out of bounds "
2942	"(%ld > %ld) in loop beginning at %L",
2943	&ar->start[i]->where, mpz_get_si (val),
2944	mpz_get_si (ar->as->upper[i]->value.integer),
2945	&doloop_list[j].c->loc);
2946
2947	mpz_clear (val);
2948	}
2949
2950	if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
2951	&& insert_index (e: ar->start[i], sym: do_sym, val: do_end, ret: val))
2952	{
2953	if (ar->as->lower[i]
2954	&& ar->as->lower[i]->expr_type == EXPR_CONSTANT
2955	&& ar->as->lower[i]->ts.type == BT_INTEGER
2956	&& mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
2957	gfc_warning (opt: warn, "Array reference at %L out of bounds "
2958	"(%ld < %ld) in loop beginning at %L",
2959	&ar->start[i]->where, mpz_get_si (val),
2960	mpz_get_si (ar->as->lower[i]->value.integer),
2961	&doloop_list[j].c->loc);
2962
2963	if (ar->as->upper[i]
2964	&& ar->as->upper[i]->expr_type == EXPR_CONSTANT
2965	&& ar->as->upper[i]->ts.type == BT_INTEGER
2966	&& mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
2967	gfc_warning (opt: warn, "Array reference at %L out of bounds "
2968	"(%ld > %ld) in loop beginning at %L",
2969	&ar->start[i]->where, mpz_get_si (val),
2970	mpz_get_si (ar->as->upper[i]->value.integer),
2971	&doloop_list[j].c->loc);
2972
2973	mpz_clear (val);
2974	}
2975	}
2976
2977	if (have_do_start)
2978	mpz_clear (do_start);
2979	if (have_do_end)
2980	mpz_clear (do_end);
2981	mpz_clear (do_step);
2982	}
2983	}
2984	}
2985	return 0;
2986	}
2987	/* Function for functions checking that we do not pass a DO variable
2988	to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2989
2990	static int
2991	do_intent (gfc_expr **e)
2992	{
2993	gfc_formal_arglist *f;
2994	gfc_actual_arglist *a;
2995	gfc_expr *expr;
2996	gfc_code *dl;
2997	do_t *lp;
2998	int i;
2999	gfc_symbol *sym;
3000
3001	expr = *e;
3002	if (expr->expr_type != EXPR_FUNCTION)
3003	return 0;
3004
3005	/* Intrinsic functions don't modify their arguments. */
3006
3007	if (expr->value.function.isym)
3008	return 0;
3009
3010	sym = expr->value.function.esym;
3011	if (sym == NULL)
3012	return 0;
3013
3014	if (sym->attr.contained)
3015	{
3016	FOR_EACH_VEC_ELT (doloop_list, i, lp)
3017	{
3018	contained_info info;
3019	gfc_namespace *ns;
3020
3021	dl = lp->c;
3022	info.do_var = dl->ext.iterator->var->symtree->n.sym;
3023	info.procedure = sym;
3024	info.where_do = expr->where;
3025	/* Look contained procedures under the namespace of the
3026	variable. */
3027	for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
3028	if (ns->proc_name && ns->proc_name == sym)
3029	gfc_code_walker (&ns->code, doloop_contained_procedure_code,
3030	dummy_expr_callback, &info);
3031	}
3032	}
3033
3034	f = gfc_sym_get_dummy_args (sym);
3035
3036	/* Without a formal arglist, there is only unknown INTENT,
3037	which we don't check for. */
3038	if (f == NULL)
3039	return 0;
3040
3041	a = expr->value.function.actual;
3042
3043	while (a && f)
3044	{
3045	FOR_EACH_VEC_ELT (doloop_list, i, lp)
3046	{
3047	gfc_symbol *do_sym;
3048	dl = lp->c;
3049	if (dl == NULL)
3050	break;
3051
3052	do_sym = dl->ext.iterator->var->symtree->n.sym;
3053
3054	if (a->expr && a->expr->symtree
3055	&& a->expr->symtree->n.sym == do_sym
3056	&& f->sym)
3057	{
3058	if (f->sym->attr.intent == INTENT_OUT)
3059	gfc_error_now ("Variable %qs at %L set to undefined value "
3060	"inside loop beginning at %L as INTENT(OUT) "
3061	"argument to function %qs", do_sym->name,
3062	&a->expr->where, &doloop_list[i].c->loc,
3063	expr->symtree->n.sym->name);
3064	else if (f->sym->attr.intent == INTENT_INOUT)
3065	gfc_error_now ("Variable %qs at %L not definable inside loop"
3066	" beginning at %L as INTENT(INOUT) argument to"
3067	" function %qs", do_sym->name,
3068	&a->expr->where, &doloop_list[i].c->loc,
3069	expr->symtree->n.sym->name);
3070	}
3071	}
3072	a = a->next;
3073	f = f->next;
3074	}
3075
3076	return 0;
3077	}
3078
3079	static void
3080	doloop_warn (gfc_namespace *ns)
3081	{
3082	gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
3083
3084	for (ns = ns->contained; ns; ns = ns->sibling)
3085	{
3086	if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
3087	doloop_warn (ns);
3088	}
3089	}
3090
3091	/* This selction deals with inlining calls to MATMUL. */
3092
3093	/* Replace calls to matmul outside of straight assignments with a temporary
3094	variable so that later inlining will work. */
3095
3096	static int
3097	matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
3098	void *data)
3099	{
3100	gfc_expr *e, *n;
3101	bool *found = (bool *) data;
3102
3103	e = *ep;
3104
3105	if (e->expr_type != EXPR_FUNCTION
3106	|| e->value.function.isym == NULL
3107	|| e->value.function.isym->id != GFC_ISYM_MATMUL)
3108	return 0;
3109
3110	if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3111	|| in_omp_atomic || in_where || in_assoc_list)
3112	return 0;
3113
3114	/* Check if this is already in the form c = matmul(a,b). */
3115
3116	if ((*current_code)->expr2 == e)
3117	return 0;
3118
3119	n = create_var (e, vname: "matmul");
3120
3121	/* If create_var is unable to create a variable (for example if
3122	-fno-realloc-lhs is in force with a variable that does not have bounds
3123	known at compile-time), just return. */
3124
3125	if (n == NULL)
3126	return 0;
3127
3128	*ep = n;
3129	*found = true;
3130	return 0;
3131	}
3132
3133	/* Set current_code and associated variables so that matmul_to_var_expr can
3134	work. */
3135
3136	static int
3137	matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3138	void *data ATTRIBUTE_UNUSED)
3139	{
3140	if (current_code != c)
3141	{
3142	current_code = c;
3143	inserted_block = NULL;
3144	changed_statement = NULL;
3145	}
3146
3147	return 0;
3148	}
3149
3150
3151	/* Take a statement of the shape c = matmul(a,b) and create temporaries
3152	for a and b if there is a dependency between the arguments and the
3153	result variable or if a or b are the result of calculations that cannot
3154	be handled by the inliner. */
3155
3156	static int
3157	matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
3158	void *data ATTRIBUTE_UNUSED)
3159	{
3160	gfc_expr *expr1, *expr2;
3161	gfc_code *co;
3162	gfc_actual_arglist *a, *b;
3163	bool a_tmp, b_tmp;
3164	gfc_expr *matrix_a, *matrix_b;
3165	bool conjg_a, conjg_b, transpose_a, transpose_b;
3166
3167	co = *c;
3168
3169	if (co->op != EXEC_ASSIGN)
3170	return 0;
3171
3172	if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
3173	|| in_omp_atomic || in_where)
3174	return 0;
3175
3176	/* This has some duplication with inline_matmul_assign. This
3177	is because the creation of temporary variables could still fail,
3178	and inline_matmul_assign still needs to be able to handle these
3179	cases. */
3180	expr1 = co->expr1;
3181	expr2 = co->expr2;
3182
3183	if (expr2->expr_type != EXPR_FUNCTION
3184	|| expr2->value.function.isym == NULL
3185	|| expr2->value.function.isym->id != GFC_ISYM_MATMUL)
3186	return 0;
3187
3188	a_tmp = false;
3189	a = expr2->value.function.actual;
3190	matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
3191	if (matrix_a != NULL)
3192	{
3193	if (matrix_a->expr_type == EXPR_VARIABLE
3194	&& (gfc_check_dependency (matrix_a, expr1, true)
3195	|| gfc_has_dimen_vector_ref (e: matrix_a)))
3196	a_tmp = true;
3197	}
3198	else
3199	a_tmp = true;
3200
3201	b_tmp = false;
3202	b = a->next;
3203	matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
3204	if (matrix_b != NULL)
3205	{
3206	if (matrix_b->expr_type == EXPR_VARIABLE
3207	&& (gfc_check_dependency (matrix_b, expr1, true)
3208	|| gfc_has_dimen_vector_ref (e: matrix_b)))
3209	b_tmp = true;
3210	}
3211	else
3212	b_tmp = true;
3213
3214	if (!a_tmp && !b_tmp)
3215	return 0;
3216
3217	current_code = c;
3218	inserted_block = NULL;
3219	changed_statement = NULL;
3220	if (a_tmp)
3221	{
3222	gfc_expr *at;
3223	at = create_var (e: a->expr,vname: "mma");
3224	if (at)
3225	a->expr = at;
3226	}
3227	if (b_tmp)
3228	{
3229	gfc_expr *bt;
3230	bt = create_var (e: b->expr,vname: "mmb");
3231	if (bt)
3232	b->expr = bt;
3233	}
3234	return 0;
3235	}
3236
3237	/* Auxiliary function to build and simplify an array inquiry function.
3238	dim is zero-based. */
3239
3240	static gfc_expr *
3241	get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
3242	{
3243	gfc_expr *fcn;
3244	gfc_expr *dim_arg, *kind;
3245	const char *name;
3246	gfc_expr *ec;
3247
3248	switch (id)
3249	{
3250	case GFC_ISYM_LBOUND:
3251	name = "_gfortran_lbound";
3252	break;
3253
3254	case GFC_ISYM_UBOUND:
3255	name = "_gfortran_ubound";
3256	break;
3257
3258	case GFC_ISYM_SIZE:
3259	name = "_gfortran_size";
3260	break;
3261
3262	default:
3263	gcc_unreachable ();
3264	}
3265
3266	dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
3267	if (okind != 0)
3268	kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3269	okind);
3270	else
3271	kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3272	gfc_index_integer_kind);
3273
3274	ec = gfc_copy_expr (e);
3275
3276	/* No bounds checking, this will be done before the loops if -fcheck=bounds
3277	is in effect. */
3278	ec->no_bounds_check = 1;
3279	fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
3280	ec, dim_arg, kind);
3281	gfc_simplify_expr (fcn, 0);
3282	fcn->no_bounds_check = 1;
3283	return fcn;
3284	}
3285
3286	/* Builds a logical expression. */
3287
3288	static gfc_expr*
3289	build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3290	{
3291	gfc_typespec ts;
3292	gfc_expr *res;
3293
3294	ts.type = BT_LOGICAL;
3295	ts.kind = gfc_default_logical_kind;
3296	res = gfc_get_expr ();
3297	res->where = e1->where;
3298	res->expr_type = EXPR_OP;
3299	res->value.op.op = op;
3300	res->value.op.op1 = e1;
3301	res->value.op.op2 = e2;
3302	res->ts = ts;
3303
3304	return res;
3305	}
3306
3307
3308	/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3309	compatible typespecs. */
3310
3311	static gfc_expr *
3312	get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
3313	{
3314	gfc_expr *res;
3315
3316	res = gfc_get_expr ();
3317	res->ts = e1->ts;
3318	res->where = e1->where;
3319	res->expr_type = EXPR_OP;
3320	res->value.op.op = op;
3321	res->value.op.op1 = e1;
3322	res->value.op.op2 = e2;
3323	gfc_simplify_expr (res, 0);
3324	return res;
3325	}
3326
3327	/* Generate the IF statement for a runtime check if we want to do inlining or
3328	not - putting in the code for both branches and putting it into the syntax
3329	tree is the caller's responsibility. For fixed array sizes, this should be
3330	removed by DCE. Only called for rank-two matrices A and B. */
3331
3332	static gfc_code *
3333	inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
3334	{
3335	gfc_expr *inline_limit;
3336	gfc_code *if_1, *if_2, *else_2;
3337	gfc_expr *b2, *a2, *a1, *m1, *m2;
3338	gfc_typespec ts;
3339	gfc_expr *cond;
3340
3341	gcc_assert (rank_a == 1 || rank_a == 2);
3342
3343	/* Calculation is done in real to avoid integer overflow. */
3344
3345	inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
3346	&a->where);
3347	mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
3348
3349	/* Set the limit according to the rank. */
3350	mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
3351	GFC_RND_MODE);
3352
3353	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 1);
3354
3355	/* For a_rank = 1, must use one as the size of a along the second
3356	dimension as to avoid too much code duplication. */
3357
3358	if (rank_a == 2)
3359	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 2);
3360	else
3361	a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);
3362
3363	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2);
3364
3365	gfc_clear_ts (&ts);
3366	ts.type = BT_REAL;
3367	ts.kind = gfc_default_real_kind;
3368	gfc_convert_type_warn (a1, &ts, 2, 0);
3369	gfc_convert_type_warn (a2, &ts, 2, 0);
3370	gfc_convert_type_warn (b2, &ts, 2, 0);
3371
3372	m1 = get_operand (op: INTRINSIC_TIMES, e1: a1, e2: a2);
3373	m2 = get_operand (op: INTRINSIC_TIMES, e1: m1, e2: b2);
3374
3375	cond = build_logical_expr (op: INTRINSIC_LE, e1: m2, e2: inline_limit);
3376	gfc_simplify_expr (cond, 0);
3377
3378	else_2 = XCNEW (gfc_code);
3379	else_2->op = EXEC_IF;
3380	else_2->loc = a->where;
3381
3382	if_2 = XCNEW (gfc_code);
3383	if_2->op = EXEC_IF;
3384	if_2->expr1 = cond;
3385	if_2->loc = a->where;
3386	if_2->block = else_2;
3387
3388	if_1 = XCNEW (gfc_code);
3389	if_1->op = EXEC_IF;
3390	if_1->block = if_2;
3391	if_1->loc = a->where;
3392
3393	return if_1;
3394	}
3395
3396
3397	/* Insert code to issue a runtime error if the expressions are not equal. */
3398
3399	static gfc_code *
3400	runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
3401	{
3402	gfc_expr *cond;
3403	gfc_code *if_1, *if_2;
3404	gfc_code *c;
3405	gfc_actual_arglist *a1, *a2, *a3;
3406
3407	gcc_assert (e1->where.lb);
3408	/* Build the call to runtime_error. */
3409	c = XCNEW (gfc_code);
3410	c->op = EXEC_CALL;
3411	c->loc = e1->where;
3412
3413	/* Get a null-terminated message string. */
3414
3415	a1 = gfc_get_actual_arglist ();
3416	a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
3417	msg, len: strlen(s: msg)+1);
3418	c->ext.actual = a1;
3419
3420	/* Pass the value of the first expression. */
3421	a2 = gfc_get_actual_arglist ();
3422	a2->expr = gfc_copy_expr (e1);
3423	a1->next = a2;
3424
3425	/* Pass the value of the second expression. */
3426	a3 = gfc_get_actual_arglist ();
3427	a3->expr = gfc_copy_expr (e2);
3428	a2->next = a3;
3429
3430	gfc_check_fe_runtime_error (c->ext.actual);
3431	gfc_resolve_fe_runtime_error (c);
3432
3433	if_2 = XCNEW (gfc_code);
3434	if_2->op = EXEC_IF;
3435	if_2->loc = e1->where;
3436	if_2->next = c;
3437
3438	if_1 = XCNEW (gfc_code);
3439	if_1->op = EXEC_IF;
3440	if_1->block = if_2;
3441	if_1->loc = e1->where;
3442
3443	cond = build_logical_expr (op: INTRINSIC_NE, e1, e2);
3444	gfc_simplify_expr (cond, 0);
3445	if_2->expr1 = cond;
3446
3447	return if_1;
3448	}
3449
3450	/* Handle matrix reallocation. Caller is responsible to insert into
3451	the code tree.
3452
3453	For the two-dimensional case, build
3454
3455	if (allocated(c)) then
3456	if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3457	deallocate(c)
3458	allocate (c(size(a,1), size(b,2)))
3459	end if
3460	else
3461	allocate (c(size(a,1),size(b,2)))
3462	end if
3463
3464	and for the other cases correspondingly.
3465	*/
3466
3467	static gfc_code *
3468	matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
3469	enum matrix_case m_case)
3470	{
3471
3472	gfc_expr *allocated, *alloc_expr;
3473	gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
3474	gfc_code *else_alloc;
3475	gfc_code *deallocate, *allocate1, *allocate_else;
3476	gfc_array_ref *ar;
3477	gfc_expr *cond, *ne1, *ne2;
3478
3479	if (warn_realloc_lhs)
3480	gfc_warning (opt: OPT_Wrealloc_lhs,
3481	"Code for reallocating the allocatable array at %L will "
3482	"be added", &c->where);
3483
3484	alloc_expr = gfc_copy_expr (c);
3485
3486	ar = gfc_find_array_ref (alloc_expr);
3487	gcc_assert (ar && ar->type == AR_FULL);
3488
3489	/* c comes in as a full ref. Change it into a copy and make it into an
3490	element ref so it has the right form for ALLOCATE. In the same
3491	switch statement, also generate the size comparison for the secod IF
3492	statement. */
3493
3494	ar->type = AR_ELEMENT;
3495
3496	switch (m_case)
3497	{
3498	case A2B2:
3499	ar->start[0] = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 1);
3500	ar->start[1] = get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2);
3501	ne1 = build_logical_expr (op: INTRINSIC_NE,
3502	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 1),
3503	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 1));
3504	ne2 = build_logical_expr (op: INTRINSIC_NE,
3505	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 2),
3506	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2));
3507	cond = build_logical_expr (op: INTRINSIC_OR, e1: ne1, e2: ne2);
3508	break;
3509
3510	case A2B2T:
3511	ar->start[0] = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 1);
3512	ar->start[1] = get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 1);
3513
3514	ne1 = build_logical_expr (op: INTRINSIC_NE,
3515	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 1),
3516	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 1));
3517	ne2 = build_logical_expr (op: INTRINSIC_NE,
3518	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 2),
3519	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 1));
3520	cond = build_logical_expr (op: INTRINSIC_OR, e1: ne1, e2: ne2);
3521	break;
3522
3523	case A2TB2:
3524
3525	ar->start[0] = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 2);
3526	ar->start[1] = get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2);
3527
3528	ne1 = build_logical_expr (op: INTRINSIC_NE,
3529	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 1),
3530	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 2));
3531	ne2 = build_logical_expr (op: INTRINSIC_NE,
3532	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 2),
3533	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2));
3534	cond = build_logical_expr (op: INTRINSIC_OR, e1: ne1, e2: ne2);
3535	break;
3536
3537	case A2B1:
3538	ar->start[0] = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 1);
3539	cond = build_logical_expr (op: INTRINSIC_NE,
3540	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 1),
3541	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 2));
3542	break;
3543
3544	case A1B2:
3545	ar->start[0] = get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2);
3546	cond = build_logical_expr (op: INTRINSIC_NE,
3547	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 1),
3548	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 2));
3549	break;
3550
3551	case A2TB2T:
3552	/* This can only happen for BLAS, we do not handle that case in
3553	inline mamtul. */
3554	ar->start[0] = get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 2);
3555	ar->start[1] = get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 1);
3556
3557	ne1 = build_logical_expr (op: INTRINSIC_NE,
3558	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 1),
3559	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: a, dim: 2));
3560	ne2 = build_logical_expr (op: INTRINSIC_NE,
3561	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e: c, dim: 2),
3562	e2: get_array_inq_function (id: GFC_ISYM_SIZE, e: b, dim: 1));
3563
3564	cond = build_logical_expr (op: INTRINSIC_OR, e1: ne1, e2: ne2);
3565	break;
3566
3567	default:
3568	gcc_unreachable();
3569
3570	}
3571
3572	gfc_simplify_expr (cond, 0);
3573
3574	/* We need two identical allocate statements in two
3575	branches of the IF statement. */
3576
3577	allocate1 = XCNEW (gfc_code);
3578	allocate1->op = EXEC_ALLOCATE;
3579	allocate1->ext.alloc.list = gfc_get_alloc ();
3580	allocate1->loc = c->where;
3581	allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
3582
3583	allocate_else = XCNEW (gfc_code);
3584	allocate_else->op = EXEC_ALLOCATE;
3585	allocate_else->ext.alloc.list = gfc_get_alloc ();
3586	allocate_else->loc = c->where;
3587	allocate_else->ext.alloc.list->expr = alloc_expr;
3588
3589	allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
3590	"_gfortran_allocated", c->where,
3591	1, gfc_copy_expr (c));
3592
3593	deallocate = XCNEW (gfc_code);
3594	deallocate->op = EXEC_DEALLOCATE;
3595	deallocate->ext.alloc.list = gfc_get_alloc ();
3596	deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
3597	deallocate->next = allocate1;
3598	deallocate->loc = c->where;
3599
3600	if_size_2 = XCNEW (gfc_code);
3601	if_size_2->op = EXEC_IF;
3602	if_size_2->expr1 = cond;
3603	if_size_2->loc = c->where;
3604	if_size_2->next = deallocate;
3605
3606	if_size_1 = XCNEW (gfc_code);
3607	if_size_1->op = EXEC_IF;
3608	if_size_1->block = if_size_2;
3609	if_size_1->loc = c->where;
3610
3611	else_alloc = XCNEW (gfc_code);
3612	else_alloc->op = EXEC_IF;
3613	else_alloc->loc = c->where;
3614	else_alloc->next = allocate_else;
3615
3616	if_alloc_2 = XCNEW (gfc_code);
3617	if_alloc_2->op = EXEC_IF;
3618	if_alloc_2->expr1 = allocated;
3619	if_alloc_2->loc = c->where;
3620	if_alloc_2->next = if_size_1;
3621	if_alloc_2->block = else_alloc;
3622
3623	if_alloc_1 = XCNEW (gfc_code);
3624	if_alloc_1->op = EXEC_IF;
3625	if_alloc_1->block = if_alloc_2;
3626	if_alloc_1->loc = c->where;
3627
3628	return if_alloc_1;
3629	}
3630
3631	/* Callback function for has_function_or_op. */
3632
3633	static int
3634	is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
3635	void *data ATTRIBUTE_UNUSED)
3636	{
3637	if ((*e) == 0)
3638	return 0;
3639	else
3640	return (*e)->expr_type == EXPR_FUNCTION
3641	|| (*e)->expr_type == EXPR_OP;
3642	}
3643
3644	/* Returns true if the expression contains a function. */
3645
3646	static bool
3647	has_function_or_op (gfc_expr **e)
3648	{
3649	if (e == NULL)
3650	return false;
3651	else
3652	return gfc_expr_walker (e, is_function_or_op, NULL);
3653	}
3654
3655	/* Freeze (assign to a temporary variable) a single expression. */
3656
3657	static void
3658	freeze_expr (gfc_expr **ep)
3659	{
3660	gfc_expr *ne;
3661	if (has_function_or_op (e: ep))
3662	{
3663	ne = create_var (e: *ep, vname: "freeze");
3664	*ep = ne;
3665	}
3666	}
3667
3668	/* Go through an expression's references and assign them to temporary
3669	variables if they contain functions. This is usually done prior to
3670	front-end scalarization to avoid multiple invocations of functions. */
3671
3672	static void
3673	freeze_references (gfc_expr *e)
3674	{
3675	gfc_ref *r;
3676	gfc_array_ref *ar;
3677	int i;
3678
3679	for (r=e->ref; r; r=r->next)
3680	{
3681	if (r->type == REF_SUBSTRING)
3682	{
3683	if (r->u.ss.start != NULL)
3684	freeze_expr (ep: &r->u.ss.start);
3685
3686	if (r->u.ss.end != NULL)
3687	freeze_expr (ep: &r->u.ss.end);
3688	}
3689	else if (r->type == REF_ARRAY)
3690	{
3691	ar = &r->u.ar;
3692	switch (ar->type)
3693	{
3694	case AR_FULL:
3695	break;
3696
3697	case AR_SECTION:
3698	for (i=0; i<ar->dimen; i++)
3699	{
3700	if (ar->dimen_type[i] == DIMEN_RANGE)
3701	{
3702	freeze_expr (ep: &ar->start[i]);
3703	freeze_expr (ep: &ar->end[i]);
3704	freeze_expr (ep: &ar->stride[i]);
3705	}
3706	else if (ar->dimen_type[i] == DIMEN_ELEMENT)
3707	{
3708	freeze_expr (ep: &ar->start[i]);
3709	}
3710	}
3711	break;
3712
3713	case AR_ELEMENT:
3714	for (i=0; i<ar->dimen; i++)
3715	freeze_expr (ep: &ar->start[i]);
3716	break;
3717
3718	default:
3719	break;
3720	}
3721	}
3722	}
3723	}
3724
3725	/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3726
3727	static gfc_expr *
3728	convert_to_index_kind (gfc_expr *e)
3729	{
3730	gfc_expr *res;
3731
3732	gcc_assert (e != NULL);
3733
3734	res = gfc_copy_expr (e);
3735
3736	gcc_assert (e->ts.type == BT_INTEGER);
3737
3738	if (res->ts.kind != gfc_index_integer_kind)
3739	{
3740	gfc_typespec ts;
3741	gfc_clear_ts (&ts);
3742	ts.type = BT_INTEGER;
3743	ts.kind = gfc_index_integer_kind;
3744
3745	gfc_convert_type_warn (e, &ts, 2, 0);
3746	}
3747
3748	return res;
3749	}
3750
3751	/* Function to create a DO loop including creation of the
3752	iteration variable. gfc_expr are copied.*/
3753
3754	static gfc_code *
3755	create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
3756	gfc_namespace *ns, char *vname)
3757	{
3758
3759	char name[GFC_MAX_SYMBOL_LEN +1];
3760	gfc_symtree *symtree;
3761	gfc_symbol *symbol;
3762	gfc_expr *i;
3763	gfc_code *n, *n2;
3764
3765	/* Create an expression for the iteration variable. */
3766	if (vname)
3767	sprintf (s: name, format: "__var_%d_do_%s", var_num++, vname);
3768	else
3769	sprintf (s: name, format: "__var_%d_do", var_num++);
3770
3771
3772	if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
3773	gcc_unreachable ();
3774
3775	/* Create the loop variable. */
3776
3777	symbol = symtree->n.sym;
3778	symbol->ts.type = BT_INTEGER;
3779	symbol->ts.kind = gfc_index_integer_kind;
3780	symbol->attr.flavor = FL_VARIABLE;
3781	symbol->attr.referenced = 1;
3782	symbol->attr.dimension = 0;
3783	symbol->attr.fe_temp = 1;
3784	gfc_commit_symbol (symbol);
3785
3786	i = gfc_get_expr ();
3787	i->expr_type = EXPR_VARIABLE;
3788	i->ts = symbol->ts;
3789	i->rank = 0;
3790	i->where = *where;
3791	i->symtree = symtree;
3792
3793	/* ... and the nested DO statements. */
3794	n = XCNEW (gfc_code);
3795	n->op = EXEC_DO;
3796	n->loc = *where;
3797	n->ext.iterator = gfc_get_iterator ();
3798	n->ext.iterator->var = i;
3799	n->ext.iterator->start = convert_to_index_kind (e: start);
3800	n->ext.iterator->end = convert_to_index_kind (e: end);
3801	if (step)
3802	n->ext.iterator->step = convert_to_index_kind (e: step);
3803	else
3804	n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
3805	where, 1);
3806
3807	n2 = XCNEW (gfc_code);
3808	n2->op = EXEC_DO;
3809	n2->loc = *where;
3810	n2->next = NULL;
3811	n->block = n2;
3812	return n;
3813	}
3814
3815	/* Get the upper bound of the DO loops for matmul along a dimension. This
3816	is one-based. */
3817
3818	static gfc_expr*
3819	get_size_m1 (gfc_expr *e, int dimen)
3820	{
3821	mpz_t size;
3822	gfc_expr *res;
3823
3824	if (gfc_array_dimen_size (e, dimen - 1, &size))
3825	{
3826	res = gfc_get_constant_expr (BT_INTEGER,
3827	gfc_index_integer_kind, &e->where);
3828	mpz_sub_ui (res->value.integer, size, 1);
3829	mpz_clear (size);
3830	}
3831	else
3832	{
3833	res = get_operand (op: INTRINSIC_MINUS,
3834	e1: get_array_inq_function (id: GFC_ISYM_SIZE, e, dim: dimen),
3835	e2: gfc_get_int_expr (gfc_index_integer_kind,
3836	&e->where, 1));
3837	gfc_simplify_expr (res, 0);
3838	}
3839
3840	return res;
3841	}
3842
3843	/* Function to return a scalarized expression. It is assumed that indices are
3844	zero based to make generation of DO loops easier. A zero as index will
3845	access the first element along a dimension. Single element references will
3846	be skipped. A NULL as an expression will be replaced by a full reference.
3847	This assumes that the index loops have gfc_index_integer_kind, and that all
3848	references have been frozen. */
3849
3850	static gfc_expr*
3851	scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
3852	{
3853	gfc_array_ref *ar;
3854	int i;
3855	int rank;
3856	gfc_expr *e;
3857	int i_index;
3858	bool was_fullref;
3859
3860	e = gfc_copy_expr(e_in);
3861
3862	rank = e->rank;
3863
3864	ar = gfc_find_array_ref (e);
3865
3866	/* We scalarize count_index variables, reducing the rank by count_index. */
3867
3868	e->rank = rank - count_index;
3869
3870	was_fullref = ar->type == AR_FULL;
3871
3872	if (e->rank == 0)
3873	ar->type = AR_ELEMENT;
3874	else
3875	ar->type = AR_SECTION;
3876
3877	/* Loop over the indices. For each index, create the expression
3878	index * stride + lbound(e, dim). */
3879
3880	i_index = 0;
3881	for (i=0; i < ar->dimen; i++)
3882	{
3883	if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
3884	{
3885	if (index[i_index] != NULL)
3886	{
3887	gfc_expr *lbound, *nindex;
3888	gfc_expr *loopvar;
3889
3890	loopvar = gfc_copy_expr (index[i_index]);
3891
3892	if (ar->stride[i])
3893	{
3894	gfc_expr *tmp;
3895
3896	tmp = gfc_copy_expr(ar->stride[i]);
3897	if (tmp->ts.kind != gfc_index_integer_kind)
3898	{
3899	gfc_typespec ts;
3900	gfc_clear_ts (&ts);
3901	ts.type = BT_INTEGER;
3902	ts.kind = gfc_index_integer_kind;
3903	gfc_convert_type (tmp, &ts, 2);
3904	}
3905	nindex = get_operand (op: INTRINSIC_TIMES, e1: loopvar, e2: tmp);
3906	}
3907	else
3908	nindex = loopvar;
3909
3910	/* Calculate the lower bound of the expression. */
3911	if (ar->start[i])
3912	{
3913	lbound = gfc_copy_expr (ar->start[i]);
3914	if (lbound->ts.kind != gfc_index_integer_kind)
3915	{
3916	gfc_typespec ts;
3917	gfc_clear_ts (&ts);
3918	ts.type = BT_INTEGER;
3919	ts.kind = gfc_index_integer_kind;
3920	gfc_convert_type (lbound, &ts, 2);
3921
3922	}
3923	}
3924	else
3925	{
3926	gfc_expr *lbound_e;
3927	gfc_ref *ref;
3928
3929	lbound_e = gfc_copy_expr (e_in);
3930
3931	for (ref = lbound_e->ref; ref; ref = ref->next)
3932	if (ref->type == REF_ARRAY
3933	&& (ref->u.ar.type == AR_FULL
3934	|| ref->u.ar.type == AR_SECTION))
3935	break;
3936
3937	if (ref->next)
3938	{
3939	gfc_free_ref_list (ref->next);
3940	ref->next = NULL;
3941	}
3942
3943	if (!was_fullref)
3944	{
3945	/* Look at full individual sections, like a(:). The first index
3946	is the lbound of a full ref. */
3947	int j;
3948	gfc_array_ref *ar;
3949	int to;
3950
3951	ar = &ref->u.ar;
3952
3953	/* For assumed size, we need to keep around the final
3954	reference in order not to get an error on resolution
3955	below, and we cannot use AR_FULL. */
3956
3957	if (ar->as->type == AS_ASSUMED_SIZE)
3958	{
3959	ar->type = AR_SECTION;
3960	to = ar->dimen - 1;
3961	}
3962	else
3963	{
3964	to = ar->dimen;
3965	ar->type = AR_FULL;
3966	}
3967
3968	for (j = 0; j < to; j++)
3969	{
3970	gfc_free_expr (ar->start[j]);
3971	ar->start[j] = NULL;
3972	gfc_free_expr (ar->end[j]);
3973	ar->end[j] = NULL;
3974	gfc_free_expr (ar->stride[j]);
3975	ar->stride[j] = NULL;
3976	}
3977
3978	/* We have to get rid of the shape, if there is one. Do
3979	so by freeing it and calling gfc_resolve to rebuild
3980	it, if necessary. */
3981
3982	if (lbound_e->shape)
3983	gfc_free_shape (shape: &(lbound_e->shape), rank: lbound_e->rank);
3984
3985	lbound_e->rank = ar->dimen;
3986	gfc_resolve_expr (lbound_e);
3987	}
3988	lbound = get_array_inq_function (id: GFC_ISYM_LBOUND, e: lbound_e,
3989	dim: i + 1);
3990	gfc_free_expr (lbound_e);
3991	}
3992
3993	ar->dimen_type[i] = DIMEN_ELEMENT;
3994
3995	gfc_free_expr (ar->start[i]);
3996	ar->start[i] = get_operand (op: INTRINSIC_PLUS, e1: nindex, e2: lbound);
3997
3998	gfc_free_expr (ar->end[i]);
3999	ar->end[i] = NULL;
4000	gfc_free_expr (ar->stride[i]);
4001	ar->stride[i] = NULL;
4002	gfc_simplify_expr (ar->start[i], 0);
4003	}
4004	else if (was_fullref)
4005	{
4006	gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
4007	}
4008	i_index ++;
4009	}
4010	}
4011
4012	/* Bounds checking will be done before the loops if -fcheck=bounds
4013	is in effect. */
4014	e->no_bounds_check = 1;
4015	return e;
4016	}
4017
4018	/* Helper function to check for a dimen vector as subscript. */
4019
4020	bool
4021	gfc_has_dimen_vector_ref (gfc_expr *e)
4022	{
4023	gfc_array_ref *ar;
4024	int i;
4025
4026	ar = gfc_find_array_ref (e);
4027	gcc_assert (ar);
4028	if (ar->type == AR_FULL)
4029	return false;
4030
4031	for (i=0; i<ar->dimen; i++)
4032	if (ar->dimen_type[i] == DIMEN_VECTOR)
4033	return true;
4034
4035	return false;
4036	}
4037
4038	/* If handed an expression of the form
4039
4040	TRANSPOSE(CONJG(A))
4041
4042	check if A can be handled by matmul and return if there is an uneven number
4043	of CONJG calls. Return a pointer to the array when everything is OK, NULL
4044	otherwise. The caller has to check for the correct rank. */
4045
4046	static gfc_expr*
4047	check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
4048	{
4049	*conjg = false;
4050	*transpose = false;
4051
4052	do
4053	{
4054	if (e->expr_type == EXPR_VARIABLE)
4055	{
4056	gcc_assert (e->rank == 1 || e->rank == 2);
4057	return e;
4058	}
4059	else if (e->expr_type == EXPR_FUNCTION)
4060	{
4061	if (e->value.function.isym == NULL)
4062	return NULL;
4063
4064	if (e->value.function.isym->id == GFC_ISYM_CONJG)
4065	*conjg = !*conjg;
4066	else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
4067	*transpose = !*transpose;
4068	else return NULL;
4069	}
4070	else
4071	return NULL;
4072
4073	e = e->value.function.actual->expr;
4074	}
4075	while(1);
4076
4077	return NULL;
4078	}
4079
4080	/* Macros for unified error messages. */
4081
4082	#define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
4083	"dimension 1: is %ld, should be %ld")
4084
4085	#define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
4086	"(%ld/%ld)")
4087
4088	#define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
4089	"(%ld/%ld)")
4090
4091
4092	/* Inline assignments of the form c = matmul(a,b).
4093	Handle only the cases currently where b and c are rank-two arrays.
4094
4095	This basically translates the code to
4096
4097	BLOCK
4098	integer i,j,k
4099	c = 0
4100	do j=0, size(b,2)-1
4101	do k=0, size(a, 2)-1
4102	do i=0, size(a, 1)-1
4103	c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
4104	c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
4105	a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
4106	b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
4107	end do
4108	end do
4109	end do
4110	END BLOCK
4111
4112	*/
4113
4114	static int
4115	inline_matmul_assign (gfc_code **c, int *walk_subtrees,
4116	void *data ATTRIBUTE_UNUSED)
4117	{
4118	gfc_code *co = *c;
4119	gfc_expr *expr1, *expr2;
4120	gfc_expr *matrix_a, *matrix_b;
4121	gfc_actual_arglist *a, *b;
4122	gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
4123	gfc_expr *zero_e;
4124	gfc_expr *u1, *u2, *u3;
4125	gfc_expr *list[2];
4126	gfc_expr *ascalar, *bscalar, *cscalar;
4127	gfc_expr *mult;
4128	gfc_expr *var_1, *var_2, *var_3;
4129	gfc_expr *zero;
4130	gfc_namespace *ns;
4131	gfc_intrinsic_op op_times, op_plus;
4132	enum matrix_case m_case;
4133	int i;
4134	gfc_code *if_limit = NULL;
4135	gfc_code **next_code_point;
4136	bool conjg_a, conjg_b, transpose_a, transpose_b;
4137	bool realloc_c;
4138
4139	if (co->op != EXEC_ASSIGN)
4140	return 0;
4141
4142	if (in_where || in_assoc_list)
4143	return 0;
4144
4145	/* The BLOCKS generated for the temporary variables and FORALL don't
4146	mix. */
4147	if (forall_level > 0)
4148	return 0;
4149
4150	/* For now don't do anything in OpenMP workshare, it confuses
4151	its translation, which expects only the allowed statements in there.
4152	We should figure out how to parallelize this eventually. */
4153	if (in_omp_workshare || in_omp_atomic)
4154	return 0;
4155
4156	expr1 = co->expr1;
4157	expr2 = co->expr2;
4158	if (expr2->expr_type != EXPR_FUNCTION
4159	|| expr2->value.function.isym == NULL
4160	|| expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4161	return 0;
4162
4163	current_code = c;
4164	inserted_block = NULL;
4165	changed_statement = NULL;
4166
4167	a = expr2->value.function.actual;
4168	matrix_a = check_conjg_transpose_variable (e: a->expr, conjg: &conjg_a, transpose: &transpose_a);
4169	if (matrix_a == NULL)
4170	return 0;
4171
4172	b = a->next;
4173	matrix_b = check_conjg_transpose_variable (e: b->expr, conjg: &conjg_b, transpose: &transpose_b);
4174	if (matrix_b == NULL)
4175	return 0;
4176
4177	if (gfc_has_dimen_vector_ref (e: expr1) || gfc_has_dimen_vector_ref (e: matrix_a)
4178	|| gfc_has_dimen_vector_ref (e: matrix_b))
4179	return 0;
4180
4181	/* We do not handle data dependencies yet. */
4182	if (gfc_check_dependency (expr1, matrix_a, true)
4183	|| gfc_check_dependency (expr1, matrix_b, true))
4184	return 0;
4185
4186	m_case = none;
4187	if (matrix_a->rank == 2)
4188	{
4189	if (transpose_a)
4190	{
4191	if (matrix_b->rank == 2 && !transpose_b)
4192	m_case = A2TB2;
4193	}
4194	else
4195	{
4196	if (matrix_b->rank == 1)
4197	m_case = A2B1;
4198	else /* matrix_b->rank == 2 */
4199	{
4200	if (transpose_b)
4201	m_case = A2B2T;
4202	else
4203	m_case = A2B2;
4204	}
4205	}
4206	}
4207	else /* matrix_a->rank == 1 */
4208	{
4209	if (matrix_b->rank == 2)
4210	{
4211	if (!transpose_b)
4212	m_case = A1B2;
4213	}
4214	}
4215
4216	if (m_case == none)
4217	return 0;
4218
4219	/* We only handle assignment to numeric or logical variables. */
4220	switch(expr1->ts.type)
4221	{
4222	case BT_INTEGER:
4223	case BT_LOGICAL:
4224	case BT_REAL:
4225	case BT_COMPLEX:
4226	break;
4227
4228	default:
4229	return 0;
4230	}
4231
4232	ns = insert_block ();
4233
4234	/* Assign the type of the zero expression for initializing the resulting
4235	array, and the expression (+ and * for real, integer and complex;
4236	.and. and .or for logical. */
4237
4238	switch(expr1->ts.type)
4239	{
4240	case BT_INTEGER:
4241	zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
4242	op_times = INTRINSIC_TIMES;
4243	op_plus = INTRINSIC_PLUS;
4244	break;
4245
4246	case BT_LOGICAL:
4247	op_times = INTRINSIC_AND;
4248	op_plus = INTRINSIC_OR;
4249	zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
4250	0);
4251	break;
4252	case BT_REAL:
4253	zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
4254	&expr1->where);
4255	mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
4256	op_times = INTRINSIC_TIMES;
4257	op_plus = INTRINSIC_PLUS;
4258	break;
4259
4260	case BT_COMPLEX:
4261	zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
4262	&expr1->where);
4263	mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
4264	op_times = INTRINSIC_TIMES;
4265	op_plus = INTRINSIC_PLUS;
4266
4267	break;
4268
4269	default:
4270	gcc_unreachable();
4271	}
4272
4273	current_code = &ns->code;
4274
4275	/* Freeze the references, keeping track of how many temporary variables were
4276	created. */
4277	n_vars = 0;
4278	freeze_references (e: matrix_a);
4279	freeze_references (e: matrix_b);
4280	freeze_references (e: expr1);
4281
4282	if (n_vars == 0)
4283	next_code_point = current_code;
4284	else
4285	{
4286	next_code_point = &ns->code;
4287	for (i=0; i<n_vars; i++)
4288	next_code_point = &(*next_code_point)->next;
4289	}
4290
4291	/* Take care of the inline flag. If the limit check evaluates to a
4292	constant, dead code elimination will eliminate the unneeded branch. */
4293
4294	if (flag_inline_matmul_limit > 0
4295	&& (matrix_a->rank == 1 || matrix_a->rank == 2)
4296	&& matrix_b->rank == 2)
4297	{
4298	if_limit = inline_limit_check (a: matrix_a, b: matrix_b,
4299	flag_inline_matmul_limit,
4300	rank_a: matrix_a->rank);
4301
4302	/* Insert the original statement into the else branch. */
4303	if_limit->block->block->next = co;
4304	co->next = NULL;
4305
4306	/* ... and the new ones go into the original one. */
4307	*next_code_point = if_limit;
4308	next_code_point = &if_limit->block->next;
4309	}
4310
4311	zero_e->no_bounds_check = 1;
4312
4313	assign_zero = XCNEW (gfc_code);
4314	assign_zero->op = EXEC_ASSIGN;
4315	assign_zero->loc = co->loc;
4316	assign_zero->expr1 = gfc_copy_expr (expr1);
4317	assign_zero->expr1->no_bounds_check = 1;
4318	assign_zero->expr2 = zero_e;
4319
4320	realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4321
4322	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4323	{
4324	gfc_code *test;
4325	gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4326
4327	switch (m_case)
4328	{
4329	case A2B1:
4330
4331	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4332	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4333	test = runtime_error_ne (e1: b1, e2: a2, B_ERROR_1);
4334	*next_code_point = test;
4335	next_code_point = &test->next;
4336
4337	if (!realloc_c)
4338	{
4339	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4340	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4341	test = runtime_error_ne (e1: c1, e2: a1, C_ERROR_1);
4342	*next_code_point = test;
4343	next_code_point = &test->next;
4344	}
4345	break;
4346
4347	case A1B2:
4348
4349	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4350	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4351	test = runtime_error_ne (e1: b1, e2: a1, B_ERROR_1);
4352	*next_code_point = test;
4353	next_code_point = &test->next;
4354
4355	if (!realloc_c)
4356	{
4357	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4358	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4359	test = runtime_error_ne (e1: c1, e2: b2, C_ERROR_1);
4360	*next_code_point = test;
4361	next_code_point = &test->next;
4362	}
4363	break;
4364
4365	case A2B2:
4366
4367	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4368	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4369	test = runtime_error_ne (e1: b1, e2: a2, B_ERROR_1);
4370	*next_code_point = test;
4371	next_code_point = &test->next;
4372
4373	if (!realloc_c)
4374	{
4375	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4376	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4377	test = runtime_error_ne (e1: c1, e2: a1, C_ERROR_1);
4378	*next_code_point = test;
4379	next_code_point = &test->next;
4380
4381	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4382	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4383	test = runtime_error_ne (e1: c2, e2: b2, C_ERROR_2);
4384	*next_code_point = test;
4385	next_code_point = &test->next;
4386	}
4387	break;
4388
4389	case A2B2T:
4390
4391	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4392	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4393	/* matrix_b is transposed, hence dimension 1 for the error message. */
4394	test = runtime_error_ne (e1: b2, e2: a2, B_ERROR_1);
4395	*next_code_point = test;
4396	next_code_point = &test->next;
4397
4398	if (!realloc_c)
4399	{
4400	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4401	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4402	test = runtime_error_ne (e1: c1, e2: a1, C_ERROR_1);
4403	*next_code_point = test;
4404	next_code_point = &test->next;
4405
4406	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4407	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4408	test = runtime_error_ne (e1: c2, e2: b1, C_ERROR_2);
4409	*next_code_point = test;
4410	next_code_point = &test->next;
4411	}
4412	break;
4413
4414	case A2TB2:
4415
4416	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4417	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4418	test = runtime_error_ne (e1: b1, e2: a1, B_ERROR_1);
4419	*next_code_point = test;
4420	next_code_point = &test->next;
4421
4422	if (!realloc_c)
4423	{
4424	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4425	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4426	test = runtime_error_ne (e1: c1, e2: a2, C_ERROR_1);
4427	*next_code_point = test;
4428	next_code_point = &test->next;
4429
4430	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4431	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4432	test = runtime_error_ne (e1: c2, e2: b2, C_ERROR_2);
4433	*next_code_point = test;
4434	next_code_point = &test->next;
4435	}
4436	break;
4437
4438	default:
4439	gcc_unreachable ();
4440	}
4441	}
4442
4443	/* Handle the reallocation, if needed. */
4444
4445	if (realloc_c)
4446	{
4447	gfc_code *lhs_alloc;
4448
4449	lhs_alloc = matmul_lhs_realloc (c: expr1, a: matrix_a, b: matrix_b, m_case);
4450
4451	*next_code_point = lhs_alloc;
4452	next_code_point = &lhs_alloc->next;
4453
4454	}
4455
4456	*next_code_point = assign_zero;
4457
4458	zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
4459
4460	assign_matmul = XCNEW (gfc_code);
4461	assign_matmul->op = EXEC_ASSIGN;
4462	assign_matmul->loc = co->loc;
4463
4464	/* Get the bounds for the loops, create them and create the scalarized
4465	expressions. */
4466
4467	switch (m_case)
4468	{
4469	case A2B2:
4470
4471	u1 = get_size_m1 (e: matrix_b, dimen: 2);
4472	u2 = get_size_m1 (e: matrix_a, dimen: 2);
4473	u3 = get_size_m1 (e: matrix_a, dimen: 1);
4474
4475	do_1 = create_do_loop (start: gfc_copy_expr (zero), end: u1, NULL, where: &co->loc, ns);
4476	do_2 = create_do_loop (start: gfc_copy_expr (zero), end: u2, NULL, where: &co->loc, ns);
4477	do_3 = create_do_loop (start: gfc_copy_expr (zero), end: u3, NULL, where: &co->loc, ns);
4478
4479	do_1->block->next = do_2;
4480	do_2->block->next = do_3;
4481	do_3->block->next = assign_matmul;
4482
4483	var_1 = do_1->ext.iterator->var;
4484	var_2 = do_2->ext.iterator->var;
4485	var_3 = do_3->ext.iterator->var;
4486
4487	list[0] = var_3;
4488	list[1] = var_1;
4489	cscalar = scalarized_expr (e_in: co->expr1, index: list, count_index: 2);
4490
4491	list[0] = var_3;
4492	list[1] = var_2;
4493	ascalar = scalarized_expr (e_in: matrix_a, index: list, count_index: 2);
4494
4495	list[0] = var_2;
4496	list[1] = var_1;
4497	bscalar = scalarized_expr (e_in: matrix_b, index: list, count_index: 2);
4498
4499	break;
4500
4501	case A2B2T:
4502
4503	u1 = get_size_m1 (e: matrix_b, dimen: 1);
4504	u2 = get_size_m1 (e: matrix_a, dimen: 2);
4505	u3 = get_size_m1 (e: matrix_a, dimen: 1);
4506
4507	do_1 = create_do_loop (start: gfc_copy_expr (zero), end: u1, NULL, where: &co->loc, ns);
4508	do_2 = create_do_loop (start: gfc_copy_expr (zero), end: u2, NULL, where: &co->loc, ns);
4509	do_3 = create_do_loop (start: gfc_copy_expr (zero), end: u3, NULL, where: &co->loc, ns);
4510
4511	do_1->block->next = do_2;
4512	do_2->block->next = do_3;
4513	do_3->block->next = assign_matmul;
4514
4515	var_1 = do_1->ext.iterator->var;
4516	var_2 = do_2->ext.iterator->var;
4517	var_3 = do_3->ext.iterator->var;
4518
4519	list[0] = var_3;
4520	list[1] = var_1;
4521	cscalar = scalarized_expr (e_in: co->expr1, index: list, count_index: 2);
4522
4523	list[0] = var_3;
4524	list[1] = var_2;
4525	ascalar = scalarized_expr (e_in: matrix_a, index: list, count_index: 2);
4526
4527	list[0] = var_1;
4528	list[1] = var_2;
4529	bscalar = scalarized_expr (e_in: matrix_b, index: list, count_index: 2);
4530
4531	break;
4532
4533	case A2TB2:
4534
4535	u1 = get_size_m1 (e: matrix_a, dimen: 2);
4536	u2 = get_size_m1 (e: matrix_b, dimen: 2);
4537	u3 = get_size_m1 (e: matrix_a, dimen: 1);
4538
4539	do_1 = create_do_loop (start: gfc_copy_expr (zero), end: u1, NULL, where: &co->loc, ns);
4540	do_2 = create_do_loop (start: gfc_copy_expr (zero), end: u2, NULL, where: &co->loc, ns);
4541	do_3 = create_do_loop (start: gfc_copy_expr (zero), end: u3, NULL, where: &co->loc, ns);
4542
4543	do_1->block->next = do_2;
4544	do_2->block->next = do_3;
4545	do_3->block->next = assign_matmul;
4546
4547	var_1 = do_1->ext.iterator->var;
4548	var_2 = do_2->ext.iterator->var;
4549	var_3 = do_3->ext.iterator->var;
4550
4551	list[0] = var_1;
4552	list[1] = var_2;
4553	cscalar = scalarized_expr (e_in: co->expr1, index: list, count_index: 2);
4554
4555	list[0] = var_3;
4556	list[1] = var_1;
4557	ascalar = scalarized_expr (e_in: matrix_a, index: list, count_index: 2);
4558
4559	list[0] = var_3;
4560	list[1] = var_2;
4561	bscalar = scalarized_expr (e_in: matrix_b, index: list, count_index: 2);
4562
4563	break;
4564
4565	case A2B1:
4566	u1 = get_size_m1 (e: matrix_b, dimen: 1);
4567	u2 = get_size_m1 (e: matrix_a, dimen: 1);
4568
4569	do_1 = create_do_loop (start: gfc_copy_expr (zero), end: u1, NULL, where: &co->loc, ns);
4570	do_2 = create_do_loop (start: gfc_copy_expr (zero), end: u2, NULL, where: &co->loc, ns);
4571
4572	do_1->block->next = do_2;
4573	do_2->block->next = assign_matmul;
4574
4575	var_1 = do_1->ext.iterator->var;
4576	var_2 = do_2->ext.iterator->var;
4577
4578	list[0] = var_2;
4579	cscalar = scalarized_expr (e_in: co->expr1, index: list, count_index: 1);
4580
4581	list[0] = var_2;
4582	list[1] = var_1;
4583	ascalar = scalarized_expr (e_in: matrix_a, index: list, count_index: 2);
4584
4585	list[0] = var_1;
4586	bscalar = scalarized_expr (e_in: matrix_b, index: list, count_index: 1);
4587
4588	break;
4589
4590	case A1B2:
4591	u1 = get_size_m1 (e: matrix_b, dimen: 2);
4592	u2 = get_size_m1 (e: matrix_a, dimen: 1);
4593
4594	do_1 = create_do_loop (start: gfc_copy_expr (zero), end: u1, NULL, where: &co->loc, ns);
4595	do_2 = create_do_loop (start: gfc_copy_expr (zero), end: u2, NULL, where: &co->loc, ns);
4596
4597	do_1->block->next = do_2;
4598	do_2->block->next = assign_matmul;
4599
4600	var_1 = do_1->ext.iterator->var;
4601	var_2 = do_2->ext.iterator->var;
4602
4603	list[0] = var_1;
4604	cscalar = scalarized_expr (e_in: co->expr1, index: list, count_index: 1);
4605
4606	list[0] = var_2;
4607	ascalar = scalarized_expr (e_in: matrix_a, index: list, count_index: 1);
4608
4609	list[0] = var_2;
4610	list[1] = var_1;
4611	bscalar = scalarized_expr (e_in: matrix_b, index: list, count_index: 2);
4612
4613	break;
4614
4615	default:
4616	gcc_unreachable();
4617	}
4618
4619	/* Build the conjg call around the variables. Set the typespec manually
4620	because gfc_build_intrinsic_call sometimes gets this wrong. */
4621	if (conjg_a)
4622	{
4623	gfc_typespec ts;
4624	ts = matrix_a->ts;
4625	ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4626	matrix_a->where, 1, ascalar);
4627	ascalar->ts = ts;
4628	}
4629
4630	if (conjg_b)
4631	{
4632	gfc_typespec ts;
4633	ts = matrix_b->ts;
4634	bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
4635	matrix_b->where, 1, bscalar);
4636	bscalar->ts = ts;
4637	}
4638	/* First loop comes after the zero assignment. */
4639	assign_zero->next = do_1;
4640
4641	/* Build the assignment expression in the loop. */
4642	assign_matmul->expr1 = gfc_copy_expr (cscalar);
4643
4644	mult = get_operand (op: op_times, e1: ascalar, e2: bscalar);
4645	assign_matmul->expr2 = get_operand (op: op_plus, e1: cscalar, e2: mult);
4646
4647	/* If we don't want to keep the original statement around in
4648	the else branch, we can free it. */
4649
4650	if (if_limit == NULL)
4651	gfc_free_statements(co);
4652	else
4653	co->next = NULL;
4654
4655	gfc_free_expr (zero);
4656	*walk_subtrees = 0;
4657	return 0;
4658	}
4659
4660	/* Change matmul function calls in the form of
4661
4662	c = matmul(a,b)
4663
4664	to the corresponding call to a BLAS routine, if applicable. */
4665
4666	static int
4667	call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
4668	void *data ATTRIBUTE_UNUSED)
4669	{
4670	gfc_code *co, *co_next;
4671	gfc_expr *expr1, *expr2;
4672	gfc_expr *matrix_a, *matrix_b;
4673	gfc_code *if_limit = NULL;
4674	gfc_actual_arglist *a, *b;
4675	bool conjg_a, conjg_b, transpose_a, transpose_b;
4676	gfc_code *call;
4677	const char *blas_name;
4678	const char *transa, *transb;
4679	gfc_expr *c1, *c2, *b1;
4680	gfc_actual_arglist *actual, *next;
4681	bt type;
4682	int kind;
4683	enum matrix_case m_case;
4684	bool realloc_c;
4685	gfc_code **next_code_point;
4686
4687	/* Many of the tests for inline matmul also apply here. */
4688
4689	co = *c;
4690
4691	if (co->op != EXEC_ASSIGN)
4692	return 0;
4693
4694	if (in_where || in_assoc_list)
4695	return 0;
4696
4697	/* The BLOCKS generated for the temporary variables and FORALL don't
4698	mix. */
4699	if (forall_level > 0)
4700	return 0;
4701
4702	/* For now don't do anything in OpenMP workshare, it confuses
4703	its translation, which expects only the allowed statements in there. */
4704
4705	if (in_omp_workshare || in_omp_atomic)
4706	return 0;
4707
4708	expr1 = co->expr1;
4709	expr2 = co->expr2;
4710	if (expr2->expr_type != EXPR_FUNCTION
4711	|| expr2->value.function.isym == NULL
4712	|| expr2->value.function.isym->id != GFC_ISYM_MATMUL)
4713	return 0;
4714
4715	type = expr2->ts.type;
4716	kind = expr2->ts.kind;
4717
4718	/* Guard against recursion. */
4719
4720	if (expr2->external_blas)
4721	return 0;
4722
4723	if (type != expr1->ts.type || kind != expr1->ts.kind)
4724	return 0;
4725
4726	if (type == BT_REAL)
4727	{
4728	if (kind == 4)
4729	blas_name = "sgemm";
4730	else if (kind == 8)
4731	blas_name = "dgemm";
4732	else
4733	return 0;
4734	}
4735	else if (type == BT_COMPLEX)
4736	{
4737	if (kind == 4)
4738	blas_name = "cgemm";
4739	else if (kind == 8)
4740	blas_name = "zgemm";
4741	else
4742	return 0;
4743	}
4744	else
4745	return 0;
4746
4747	a = expr2->value.function.actual;
4748	if (a->expr->rank != 2)
4749	return 0;
4750
4751	b = a->next;
4752	if (b->expr->rank != 2)
4753	return 0;
4754
4755	matrix_a = check_conjg_transpose_variable (e: a->expr, conjg: &conjg_a, transpose: &transpose_a);
4756	if (matrix_a == NULL)
4757	return 0;
4758
4759	if (transpose_a)
4760	{
4761	if (conjg_a)
4762	transa = "C";
4763	else
4764	transa = "T";
4765	}
4766	else
4767	transa = "N";
4768
4769	matrix_b = check_conjg_transpose_variable (e: b->expr, conjg: &conjg_b, transpose: &transpose_b);
4770	if (matrix_b == NULL)
4771	return 0;
4772
4773	if (transpose_b)
4774	{
4775	if (conjg_b)
4776	transb = "C";
4777	else
4778	transb = "T";
4779	}
4780	else
4781	transb = "N";
4782
4783	if (transpose_a)
4784	{
4785	if (transpose_b)
4786	m_case = A2TB2T;
4787	else
4788	m_case = A2TB2;
4789	}
4790	else
4791	{
4792	if (transpose_b)
4793	m_case = A2B2T;
4794	else
4795	m_case = A2B2;
4796	}
4797
4798	current_code = c;
4799	inserted_block = NULL;
4800	changed_statement = NULL;
4801
4802	expr2->external_blas = 1;
4803
4804	/* We do not handle data dependencies yet. */
4805	if (gfc_check_dependency (expr1, matrix_a, true)
4806	|| gfc_check_dependency (expr1, matrix_b, true))
4807	return 0;
4808
4809	/* Generate the if statement and hang it into the tree. */
4810	if_limit = inline_limit_check (a: matrix_a, b: matrix_b, flag_blas_matmul_limit, rank_a: 2);
4811	co_next = co->next;
4812	(*current_code) = if_limit;
4813	co->next = NULL;
4814	if_limit->block->next = co;
4815
4816	call = XCNEW (gfc_code);
4817	call->loc = co->loc;
4818
4819	/* Bounds checking - a bit simpler than for inlining since we only
4820	have to take care of two-dimensional arrays here. */
4821
4822	realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
4823	next_code_point = &(if_limit->block->block->next);
4824
4825	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4826	{
4827	gfc_code *test;
4828	// gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4829	gfc_expr *c1, *a1, *c2, *b2, *a2;
4830	switch (m_case)
4831	{
4832	case A2B2:
4833	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4834	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4835	test = runtime_error_ne (e1: b1, e2: a2, B_ERROR_1);
4836	*next_code_point = test;
4837	next_code_point = &test->next;
4838
4839	if (!realloc_c)
4840	{
4841	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4842	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4843	test = runtime_error_ne (e1: c1, e2: a1, C_ERROR_1);
4844	*next_code_point = test;
4845	next_code_point = &test->next;
4846
4847	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4848	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4849	test = runtime_error_ne (e1: c2, e2: b2, C_ERROR_2);
4850	*next_code_point = test;
4851	next_code_point = &test->next;
4852	}
4853	break;
4854
4855	case A2B2T:
4856
4857	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4858	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4859	/* matrix_b is transposed, hence dimension 1 for the error message. */
4860	test = runtime_error_ne (e1: b2, e2: a2, B_ERROR_1);
4861	*next_code_point = test;
4862	next_code_point = &test->next;
4863
4864	if (!realloc_c)
4865	{
4866	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4867	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4868	test = runtime_error_ne (e1: c1, e2: a1, C_ERROR_1);
4869	*next_code_point = test;
4870	next_code_point = &test->next;
4871
4872	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4873	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4874	test = runtime_error_ne (e1: c2, e2: b1, C_ERROR_2);
4875	*next_code_point = test;
4876	next_code_point = &test->next;
4877	}
4878	break;
4879
4880	case A2TB2:
4881
4882	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4883	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4884	test = runtime_error_ne (e1: b1, e2: a1, B_ERROR_1);
4885	*next_code_point = test;
4886	next_code_point = &test->next;
4887
4888	if (!realloc_c)
4889	{
4890	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4891	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4892	test = runtime_error_ne (e1: c1, e2: a2, C_ERROR_1);
4893	*next_code_point = test;
4894	next_code_point = &test->next;
4895
4896	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4897	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4898	test = runtime_error_ne (e1: c2, e2: b2, C_ERROR_2);
4899	*next_code_point = test;
4900	next_code_point = &test->next;
4901	}
4902	break;
4903
4904	case A2TB2T:
4905	b2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 2);
4906	a1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 1);
4907	test = runtime_error_ne (e1: b2, e2: a1, B_ERROR_1);
4908	*next_code_point = test;
4909	next_code_point = &test->next;
4910
4911	if (!realloc_c)
4912	{
4913	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 1);
4914	a2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_a, dim: 2);
4915	test = runtime_error_ne (e1: c1, e2: a2, C_ERROR_1);
4916	*next_code_point = test;
4917	next_code_point = &test->next;
4918
4919	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: expr1, dim: 2);
4920	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: matrix_b, dim: 1);
4921	test = runtime_error_ne (e1: c2, e2: b1, C_ERROR_2);
4922	*next_code_point = test;
4923	next_code_point = &test->next;
4924	}
4925	break;
4926
4927	default:
4928	gcc_unreachable ();
4929	}
4930	}
4931
4932	/* Handle the reallocation, if needed. */
4933
4934	if (realloc_c)
4935	{
4936	gfc_code *lhs_alloc;
4937
4938	lhs_alloc = matmul_lhs_realloc (c: expr1, a: matrix_a, b: matrix_b, m_case);
4939	*next_code_point = lhs_alloc;
4940	next_code_point = &lhs_alloc->next;
4941	}
4942
4943	*next_code_point = call;
4944	if_limit->next = co_next;
4945
4946	/* Set up the BLAS call. */
4947
4948	call->op = EXEC_CALL;
4949
4950	gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
4951	call->symtree->n.sym->attr.subroutine = 1;
4952	call->symtree->n.sym->attr.procedure = 1;
4953	call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4954	call->resolved_sym = call->symtree->n.sym;
4955	gfc_commit_symbol (call->resolved_sym);
4956
4957	/* Argument TRANSA. */
4958	next = gfc_get_actual_arglist ();
4959	next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4960	transa, len: 1);
4961
4962	call->ext.actual = next;
4963
4964	/* Argument TRANSB. */
4965	actual = next;
4966	next = gfc_get_actual_arglist ();
4967	next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
4968	transb, len: 1);
4969	actual->next = next;
4970
4971	c1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: gfc_copy_expr (a->expr), dim: 1,
4972	gfc_integer_4_kind);
4973	c2 = get_array_inq_function (id: GFC_ISYM_SIZE, e: gfc_copy_expr (b->expr), dim: 2,
4974	gfc_integer_4_kind);
4975
4976	b1 = get_array_inq_function (id: GFC_ISYM_SIZE, e: gfc_copy_expr (b->expr), dim: 1,
4977	gfc_integer_4_kind);
4978
4979	/* Argument M. */
4980	actual = next;
4981	next = gfc_get_actual_arglist ();
4982	next->expr = c1;
4983	actual->next = next;
4984
4985	/* Argument N. */
4986	actual = next;
4987	next = gfc_get_actual_arglist ();
4988	next->expr = c2;
4989	actual->next = next;
4990
4991	/* Argument K. */
4992	actual = next;
4993	next = gfc_get_actual_arglist ();
4994	next->expr = b1;
4995	actual->next = next;
4996
4997	/* Argument ALPHA - set to one. */
4998	actual = next;
4999	next = gfc_get_actual_arglist ();
5000	next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5001	if (type == BT_REAL)
5002	mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
5003	else
5004	mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
5005	actual->next = next;
5006
5007	/* Argument A. */
5008	actual = next;
5009	next = gfc_get_actual_arglist ();
5010	next->expr = gfc_copy_expr (matrix_a);
5011	actual->next = next;
5012
5013	/* Argument LDA. */
5014	actual = next;
5015	next = gfc_get_actual_arglist ();
5016	next->expr = get_array_inq_function (id: GFC_ISYM_SIZE, e: gfc_copy_expr (matrix_a),
5017	dim: 1, gfc_integer_4_kind);
5018	actual->next = next;
5019
5020	/* Argument B. */
5021	actual = next;
5022	next = gfc_get_actual_arglist ();
5023	next->expr = gfc_copy_expr (matrix_b);
5024	actual->next = next;
5025
5026	/* Argument LDB. */
5027	actual = next;
5028	next = gfc_get_actual_arglist ();
5029	next->expr = get_array_inq_function (id: GFC_ISYM_SIZE, e: gfc_copy_expr (matrix_b),
5030	dim: 1, gfc_integer_4_kind);
5031	actual->next = next;
5032
5033	/* Argument BETA - set to zero. */
5034	actual = next;
5035	next = gfc_get_actual_arglist ();
5036	next->expr = gfc_get_constant_expr (type, kind, &co->loc);
5037	if (type == BT_REAL)
5038	mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
5039	else
5040	mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
5041	actual->next = next;
5042
5043	/* Argument C. */
5044
5045	actual = next;
5046	next = gfc_get_actual_arglist ();
5047	next->expr = gfc_copy_expr (expr1);
5048	actual->next = next;
5049
5050	/* Argument LDC. */
5051	actual = next;
5052	next = gfc_get_actual_arglist ();
5053	next->expr = get_array_inq_function (id: GFC_ISYM_SIZE, e: gfc_copy_expr (expr1),
5054	dim: 1, gfc_integer_4_kind);
5055	actual->next = next;
5056
5057	return 0;
5058	}
5059
5060
5061	/* Code for index interchange for loops which are grouped together in DO
5062	CONCURRENT or FORALL statements. This is currently only applied if the
5063	iterations are grouped together in a single statement.
5064
5065	For this transformation, it is assumed that memory access in strides is
5066	expensive, and that loops which access later indices (which access memory
5067	in bigger strides) should be moved to the first loops.
5068
5069	For this, a loop over all the statements is executed, counting the times
5070	that the loop iteration values are accessed in each index. The loop
5071	indices are then sorted to minimize access to later indices from inner
5072	loops. */
5073
5074	/* Type for holding index information. */
5075
5076	typedef struct {
5077	gfc_symbol *sym;
5078	gfc_forall_iterator *fa;
5079	int num;
5080	int n[GFC_MAX_DIMENSIONS];
5081	} ind_type;
5082
5083	/* Callback function to determine if an expression is the
5084	corresponding variable. */
5085
5086	static int
5087	has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
5088	{
5089	gfc_expr *expr = *e;
5090	gfc_symbol *sym;
5091
5092	if (expr->expr_type != EXPR_VARIABLE)
5093	return 0;
5094
5095	sym = (gfc_symbol *) data;
5096	return sym == expr->symtree->n.sym;
5097	}
5098
5099	/* Callback function to calculate the cost of a certain index. */
5100
5101	static int
5102	index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
5103	void *data)
5104	{
5105	ind_type *ind;
5106	gfc_expr *expr;
5107	gfc_array_ref *ar;
5108	gfc_ref *ref;
5109	int i,j;
5110
5111	expr = *e;
5112	if (expr->expr_type != EXPR_VARIABLE)
5113	return 0;
5114
5115	ar = NULL;
5116	for (ref = expr->ref; ref; ref = ref->next)
5117	{
5118	if (ref->type == REF_ARRAY)
5119	{
5120	ar = &ref->u.ar;
5121	break;
5122	}
5123	}
5124	if (ar == NULL || ar->type != AR_ELEMENT)
5125	return 0;
5126
5127	ind = (ind_type *) data;
5128	for (i = 0; i < ar->dimen; i++)
5129	{
5130	for (j=0; ind[j].sym != NULL; j++)
5131	{
5132	if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
5133	ind[j].n[i]++;
5134	}
5135	}
5136	return 0;
5137	}
5138
5139	/* Callback function for qsort, to sort the loop indices. */
5140
5141	static int
5142	loop_comp (const void *e1, const void *e2)
5143	{
5144	const ind_type *i1 = (const ind_type *) e1;
5145	const ind_type *i2 = (const ind_type *) e2;
5146	int i;
5147
5148	for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
5149	{
5150	if (i1->n[i] != i2->n[i])
5151	return i1->n[i] - i2->n[i];
5152	}
5153	/* All other things being equal, let's not change the ordering. */
5154	return i2->num - i1->num;
5155	}
5156
5157	/* Main function to do the index interchange. */
5158
5159	static int
5160	index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5161	void *data ATTRIBUTE_UNUSED)
5162	{
5163	gfc_code *co;
5164	co = *c;
5165	int n_iter;
5166	gfc_forall_iterator *fa;
5167	ind_type *ind;
5168	int i, j;
5169
5170	if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
5171	return 0;
5172
5173	n_iter = 0;
5174	for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5175	n_iter ++;
5176
5177	/* Nothing to reorder. */
5178	if (n_iter < 2)
5179	return 0;
5180
5181	ind = XALLOCAVEC (ind_type, n_iter + 1);
5182
5183	i = 0;
5184	for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5185	{
5186	ind[i].sym = fa->var->symtree->n.sym;
5187	ind[i].fa = fa;
5188	for (j=0; j<GFC_MAX_DIMENSIONS; j++)
5189	ind[i].n[j] = 0;
5190	ind[i].num = i;
5191	i++;
5192	}
5193	ind[n_iter].sym = NULL;
5194	ind[n_iter].fa = NULL;
5195
5196	gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
5197	qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
5198
5199	/* Do the actual index interchange. */
5200	co->ext.forall_iterator = fa = ind[0].fa;
5201	for (i=1; i<n_iter; i++)
5202	{
5203	fa->next = ind[i].fa;
5204	fa = fa->next;
5205	}
5206	fa->next = NULL;
5207
5208	if (flag_warn_frontend_loop_interchange)
5209	{
5210	for (i=1; i<n_iter; i++)
5211	{
5212	if (ind[i-1].num > ind[i].num)
5213	{
5214	gfc_warning (opt: OPT_Wfrontend_loop_interchange,
5215	"Interchanging loops at %L", &co->loc);
5216	break;
5217	}
5218	}
5219	}
5220
5221	return 0;
5222	}
5223
5224	#define WALK_SUBEXPR(NODE) \
5225	do \
5226	{ \
5227	result = gfc_expr_walker (&(NODE), exprfn, data); \
5228	if (result) \
5229	return result; \
5230	} \
5231	while (0)
5232	#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
5233
5234	/* Walk expression *E, calling EXPRFN on each expression in it. */
5235
5236	int
5237	gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
5238	{
5239	while (*e)
5240	{
5241	int walk_subtrees = 1;
5242	gfc_actual_arglist *a;
5243	gfc_ref *r;
5244	gfc_constructor *c;
5245
5246	int result = exprfn (e, &walk_subtrees, data);
5247	if (result)
5248	return result;
5249	if (walk_subtrees)
5250	switch ((*e)->expr_type)
5251	{
5252	case EXPR_OP:
5253	WALK_SUBEXPR ((*e)->value.op.op1);
5254	WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
5255	/* No fallthru because of the tail recursion above. */
5256	case EXPR_FUNCTION:
5257	for (a = (*e)->value.function.actual; a; a = a->next)
5258	WALK_SUBEXPR (a->expr);
5259	break;
5260	case EXPR_COMPCALL:
5261	case EXPR_PPC:
5262	WALK_SUBEXPR ((*e)->value.compcall.base_object);
5263	for (a = (*e)->value.compcall.actual; a; a = a->next)
5264	WALK_SUBEXPR (a->expr);
5265	break;
5266
5267	case EXPR_STRUCTURE:
5268	case EXPR_ARRAY:
5269	for (c = gfc_constructor_first (base: (*e)->value.constructor); c;
5270	c = gfc_constructor_next (ctor: c))
5271	{
5272	if (c->iterator == NULL)
5273	WALK_SUBEXPR (c->expr);
5274	else
5275	{
5276	iterator_level ++;
5277	WALK_SUBEXPR (c->expr);
5278	iterator_level --;
5279	WALK_SUBEXPR (c->iterator->var);
5280	WALK_SUBEXPR (c->iterator->start);
5281	WALK_SUBEXPR (c->iterator->end);
5282	WALK_SUBEXPR (c->iterator->step);
5283	}
5284	}
5285
5286	if ((*e)->expr_type != EXPR_ARRAY)
5287	break;
5288
5289	/* Fall through to the variable case in order to walk the
5290	reference. */
5291	gcc_fallthrough ();
5292
5293	case EXPR_SUBSTRING:
5294	case EXPR_VARIABLE:
5295	for (r = (*e)->ref; r; r = r->next)
5296	{
5297	gfc_array_ref *ar;
5298	int i;
5299
5300	switch (r->type)
5301	{
5302	case REF_ARRAY:
5303	ar = &r->u.ar;
5304	if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
5305	{
5306	for (i=0; i< ar->dimen; i++)
5307	{
5308	WALK_SUBEXPR (ar->start[i]);
5309	WALK_SUBEXPR (ar->end[i]);
5310	WALK_SUBEXPR (ar->stride[i]);
5311	}
5312	}
5313
5314	break;
5315
5316	case REF_SUBSTRING:
5317	WALK_SUBEXPR (r->u.ss.start);
5318	WALK_SUBEXPR (r->u.ss.end);
5319	break;
5320
5321	case REF_COMPONENT:
5322	case REF_INQUIRY:
5323	break;
5324	}
5325	}
5326
5327	default:
5328	break;
5329	}
5330	return 0;
5331	}
5332	return 0;
5333	}
5334
5335	#define WALK_SUBCODE(NODE) \
5336	do \
5337	{ \
5338	result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5339	if (result) \
5340	return result; \
5341	} \
5342	while (0)
5343
5344	/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5345	on each expression in it. If any of the hooks returns non-zero, that
5346	value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5347	no subcodes or subexpressions are traversed. */
5348
5349	int
5350	gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
5351	void *data)
5352	{
5353	for (; *c; c = &(*c)->next)
5354	{
5355	int walk_subtrees = 1;
5356	int result = codefn (c, &walk_subtrees, data);
5357	if (result)
5358	return result;
5359
5360	if (walk_subtrees)
5361	{
5362	gfc_code *b;
5363	gfc_actual_arglist *a;
5364	gfc_code *co;
5365	gfc_association_list *alist;
5366	bool saved_in_omp_workshare;
5367	bool saved_in_omp_atomic;
5368	bool saved_in_where;
5369
5370	/* There might be statement insertions before the current code,
5371	which must not affect the expression walker. */
5372
5373	co = *c;
5374	saved_in_omp_workshare = in_omp_workshare;
5375	saved_in_omp_atomic = in_omp_atomic;
5376	saved_in_where = in_where;
5377
5378	switch (co->op)
5379	{
5380
5381	case EXEC_BLOCK:
5382	WALK_SUBCODE (co->ext.block.ns->code);
5383	if (co->ext.block.assoc)
5384	{
5385	bool saved_in_assoc_list = in_assoc_list;
5386
5387	in_assoc_list = true;
5388	for (alist = co->ext.block.assoc; alist; alist = alist->next)
5389	WALK_SUBEXPR (alist->target);
5390
5391	in_assoc_list = saved_in_assoc_list;
5392	}
5393
5394	break;
5395
5396	case EXEC_DO:
5397	doloop_level ++;
5398	WALK_SUBEXPR (co->ext.iterator->var);
5399	WALK_SUBEXPR (co->ext.iterator->start);
5400	WALK_SUBEXPR (co->ext.iterator->end);
5401	WALK_SUBEXPR (co->ext.iterator->step);
5402	break;
5403
5404	case EXEC_IF:
5405	if_level ++;
5406	break;
5407
5408	case EXEC_WHERE:
5409	in_where = true;
5410	break;
5411
5412	case EXEC_CALL:
5413	case EXEC_ASSIGN_CALL:
5414	for (a = co->ext.actual; a; a = a->next)
5415	WALK_SUBEXPR (a->expr);
5416	break;
5417
5418	case EXEC_CALL_PPC:
5419	WALK_SUBEXPR (co->expr1);
5420	for (a = co->ext.actual; a; a = a->next)
5421	WALK_SUBEXPR (a->expr);
5422	break;
5423
5424	case EXEC_SELECT:
5425	WALK_SUBEXPR (co->expr1);
5426	select_level ++;
5427	for (b = co->block; b; b = b->block)
5428	{
5429	gfc_case *cp;
5430	for (cp = b->ext.block.case_list; cp; cp = cp->next)
5431	{
5432	WALK_SUBEXPR (cp->low);
5433	WALK_SUBEXPR (cp->high);
5434	}
5435	WALK_SUBCODE (b->next);
5436	}
5437	continue;
5438
5439	case EXEC_ALLOCATE:
5440	case EXEC_DEALLOCATE:
5441	{
5442	gfc_alloc *a;
5443	for (a = co->ext.alloc.list; a; a = a->next)
5444	WALK_SUBEXPR (a->expr);
5445	break;
5446	}
5447
5448	case EXEC_FORALL:
5449	case EXEC_DO_CONCURRENT:
5450	{
5451	gfc_forall_iterator *fa;
5452	for (fa = co->ext.forall_iterator; fa; fa = fa->next)
5453	{
5454	WALK_SUBEXPR (fa->var);
5455	WALK_SUBEXPR (fa->start);
5456	WALK_SUBEXPR (fa->end);
5457	WALK_SUBEXPR (fa->stride);
5458	}
5459	if (co->op == EXEC_FORALL)
5460	forall_level ++;
5461	break;
5462	}
5463
5464	case EXEC_OPEN:
5465	WALK_SUBEXPR (co->ext.open->unit);
5466	WALK_SUBEXPR (co->ext.open->file);
5467	WALK_SUBEXPR (co->ext.open->status);
5468	WALK_SUBEXPR (co->ext.open->access);
5469	WALK_SUBEXPR (co->ext.open->form);
5470	WALK_SUBEXPR (co->ext.open->recl);
5471	WALK_SUBEXPR (co->ext.open->blank);
5472	WALK_SUBEXPR (co->ext.open->position);
5473	WALK_SUBEXPR (co->ext.open->action);
5474	WALK_SUBEXPR (co->ext.open->delim);
5475	WALK_SUBEXPR (co->ext.open->pad);
5476	WALK_SUBEXPR (co->ext.open->iostat);
5477	WALK_SUBEXPR (co->ext.open->iomsg);
5478	WALK_SUBEXPR (co->ext.open->convert);
5479	WALK_SUBEXPR (co->ext.open->decimal);
5480	WALK_SUBEXPR (co->ext.open->encoding);
5481	WALK_SUBEXPR (co->ext.open->round);
5482	WALK_SUBEXPR (co->ext.open->sign);
5483	WALK_SUBEXPR (co->ext.open->asynchronous);
5484	WALK_SUBEXPR (co->ext.open->id);
5485	WALK_SUBEXPR (co->ext.open->newunit);
5486	WALK_SUBEXPR (co->ext.open->share);
5487	WALK_SUBEXPR (co->ext.open->cc);
5488	break;
5489
5490	case EXEC_CLOSE:
5491	WALK_SUBEXPR (co->ext.close->unit);
5492	WALK_SUBEXPR (co->ext.close->status);
5493	WALK_SUBEXPR (co->ext.close->iostat);
5494	WALK_SUBEXPR (co->ext.close->iomsg);
5495	break;
5496
5497	case EXEC_BACKSPACE:
5498	case EXEC_ENDFILE:
5499	case EXEC_REWIND:
5500	case EXEC_FLUSH:
5501	WALK_SUBEXPR (co->ext.filepos->unit);
5502	WALK_SUBEXPR (co->ext.filepos->iostat);
5503	WALK_SUBEXPR (co->ext.filepos->iomsg);
5504	break;
5505
5506	case EXEC_INQUIRE:
5507	WALK_SUBEXPR (co->ext.inquire->unit);
5508	WALK_SUBEXPR (co->ext.inquire->file);
5509	WALK_SUBEXPR (co->ext.inquire->iomsg);
5510	WALK_SUBEXPR (co->ext.inquire->iostat);
5511	WALK_SUBEXPR (co->ext.inquire->exist);
5512	WALK_SUBEXPR (co->ext.inquire->opened);
5513	WALK_SUBEXPR (co->ext.inquire->number);
5514	WALK_SUBEXPR (co->ext.inquire->named);
5515	WALK_SUBEXPR (co->ext.inquire->name);
5516	WALK_SUBEXPR (co->ext.inquire->access);
5517	WALK_SUBEXPR (co->ext.inquire->sequential);
5518	WALK_SUBEXPR (co->ext.inquire->direct);
5519	WALK_SUBEXPR (co->ext.inquire->form);
5520	WALK_SUBEXPR (co->ext.inquire->formatted);
5521	WALK_SUBEXPR (co->ext.inquire->unformatted);
5522	WALK_SUBEXPR (co->ext.inquire->recl);
5523	WALK_SUBEXPR (co->ext.inquire->nextrec);
5524	WALK_SUBEXPR (co->ext.inquire->blank);
5525	WALK_SUBEXPR (co->ext.inquire->position);
5526	WALK_SUBEXPR (co->ext.inquire->action);
5527	WALK_SUBEXPR (co->ext.inquire->read);
5528	WALK_SUBEXPR (co->ext.inquire->write);
5529	WALK_SUBEXPR (co->ext.inquire->readwrite);
5530	WALK_SUBEXPR (co->ext.inquire->delim);
5531	WALK_SUBEXPR (co->ext.inquire->encoding);
5532	WALK_SUBEXPR (co->ext.inquire->pad);
5533	WALK_SUBEXPR (co->ext.inquire->iolength);
5534	WALK_SUBEXPR (co->ext.inquire->convert);
5535	WALK_SUBEXPR (co->ext.inquire->strm_pos);
5536	WALK_SUBEXPR (co->ext.inquire->asynchronous);
5537	WALK_SUBEXPR (co->ext.inquire->decimal);
5538	WALK_SUBEXPR (co->ext.inquire->pending);
5539	WALK_SUBEXPR (co->ext.inquire->id);
5540	WALK_SUBEXPR (co->ext.inquire->sign);
5541	WALK_SUBEXPR (co->ext.inquire->size);
5542	WALK_SUBEXPR (co->ext.inquire->round);
5543	break;
5544
5545	case EXEC_WAIT:
5546	WALK_SUBEXPR (co->ext.wait->unit);
5547	WALK_SUBEXPR (co->ext.wait->iostat);
5548	WALK_SUBEXPR (co->ext.wait->iomsg);
5549	WALK_SUBEXPR (co->ext.wait->id);
5550	break;
5551
5552	case EXEC_READ:
5553	case EXEC_WRITE:
5554	WALK_SUBEXPR (co->ext.dt->io_unit);
5555	WALK_SUBEXPR (co->ext.dt->format_expr);
5556	WALK_SUBEXPR (co->ext.dt->rec);
5557	WALK_SUBEXPR (co->ext.dt->advance);
5558	WALK_SUBEXPR (co->ext.dt->iostat);
5559	WALK_SUBEXPR (co->ext.dt->size);
5560	WALK_SUBEXPR (co->ext.dt->iomsg);
5561	WALK_SUBEXPR (co->ext.dt->id);
5562	WALK_SUBEXPR (co->ext.dt->pos);
5563	WALK_SUBEXPR (co->ext.dt->asynchronous);
5564	WALK_SUBEXPR (co->ext.dt->blank);
5565	WALK_SUBEXPR (co->ext.dt->decimal);
5566	WALK_SUBEXPR (co->ext.dt->delim);
5567	WALK_SUBEXPR (co->ext.dt->pad);
5568	WALK_SUBEXPR (co->ext.dt->round);
5569	WALK_SUBEXPR (co->ext.dt->sign);
5570	WALK_SUBEXPR (co->ext.dt->extra_comma);
5571	break;
5572
5573	case EXEC_OACC_ATOMIC:
5574	case EXEC_OMP_ATOMIC:
5575	in_omp_atomic = true;
5576	break;
5577
5578	case EXEC_OMP_PARALLEL:
5579	case EXEC_OMP_PARALLEL_DO:
5580	case EXEC_OMP_PARALLEL_DO_SIMD:
5581	case EXEC_OMP_PARALLEL_LOOP:
5582	case EXEC_OMP_PARALLEL_MASKED:
5583	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
5584	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5585	case EXEC_OMP_PARALLEL_MASTER:
5586	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
5587	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5588	case EXEC_OMP_PARALLEL_SECTIONS:
5589
5590	in_omp_workshare = false;
5591
5592	/* This goto serves as a shortcut to avoid code
5593	duplication or a larger if or switch statement. */
5594	goto check_omp_clauses;
5595
5596	case EXEC_OMP_WORKSHARE:
5597	case EXEC_OMP_PARALLEL_WORKSHARE:
5598
5599	in_omp_workshare = true;
5600
5601	/* Fall through */
5602
5603	case EXEC_OMP_CRITICAL:
5604	case EXEC_OMP_DISTRIBUTE:
5605	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5606	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5607	case EXEC_OMP_DISTRIBUTE_SIMD:
5608	case EXEC_OMP_DO:
5609	case EXEC_OMP_DO_SIMD:
5610	case EXEC_OMP_LOOP:
5611	case EXEC_OMP_ORDERED:
5612	case EXEC_OMP_SECTIONS:
5613	case EXEC_OMP_SINGLE:
5614	case EXEC_OMP_END_SINGLE:
5615	case EXEC_OMP_SIMD:
5616	case EXEC_OMP_TASKLOOP:
5617	case EXEC_OMP_TASKLOOP_SIMD:
5618	case EXEC_OMP_TARGET:
5619	case EXEC_OMP_TARGET_DATA:
5620	case EXEC_OMP_TARGET_ENTER_DATA:
5621	case EXEC_OMP_TARGET_EXIT_DATA:
5622	case EXEC_OMP_TARGET_PARALLEL:
5623	case EXEC_OMP_TARGET_PARALLEL_DO:
5624	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5625	case EXEC_OMP_TARGET_PARALLEL_LOOP:
5626	case EXEC_OMP_TARGET_SIMD:
5627	case EXEC_OMP_TARGET_TEAMS:
5628	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5629	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5630	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5631	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5632	case EXEC_OMP_TARGET_TEAMS_LOOP:
5633	case EXEC_OMP_TARGET_UPDATE:
5634	case EXEC_OMP_TASK:
5635	case EXEC_OMP_TEAMS:
5636	case EXEC_OMP_TEAMS_DISTRIBUTE:
5637	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5638	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5639	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5640	case EXEC_OMP_TEAMS_LOOP:
5641
5642	/* Come to this label only from the
5643	EXEC_OMP_PARALLEL_* cases above. */
5644
5645	check_omp_clauses:
5646
5647	if (co->ext.omp_clauses)
5648	{
5649	gfc_omp_namelist *n;
5650	static int list_types[]
5651	= { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
5652	OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
5653	size_t idx;
5654	WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
5655	for (idx = 0; idx < OMP_IF_LAST; idx++)
5656	WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
5657	WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
5658	WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
5659	WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
5660	WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
5661	WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
5662	WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower);
5663	WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper);
5664	WALK_SUBEXPR (co->ext.omp_clauses->device);
5665	WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
5666	WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
5667	WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
5668	WALK_SUBEXPR (co->ext.omp_clauses->hint);
5669	WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
5670	WALK_SUBEXPR (co->ext.omp_clauses->priority);
5671	WALK_SUBEXPR (co->ext.omp_clauses->detach);
5672	for (idx = 0; idx < ARRAY_SIZE (list_types); idx++)
5673	for (n = co->ext.omp_clauses->lists[list_types[idx]];
5674	n; n = n->next)
5675	WALK_SUBEXPR (n->expr);
5676	}
5677	break;
5678	default:
5679	break;
5680	}
5681
5682	WALK_SUBEXPR (co->expr1);
5683	WALK_SUBEXPR (co->expr2);
5684	WALK_SUBEXPR (co->expr3);
5685	WALK_SUBEXPR (co->expr4);
5686	for (b = co->block; b; b = b->block)
5687	{
5688	WALK_SUBEXPR (b->expr1);
5689	WALK_SUBEXPR (b->expr2);
5690	WALK_SUBCODE (b->next);
5691	}
5692
5693	if (co->op == EXEC_FORALL)
5694	forall_level --;
5695
5696	if (co->op == EXEC_DO)
5697	doloop_level --;
5698
5699	if (co->op == EXEC_IF)
5700	if_level --;
5701
5702	if (co->op == EXEC_SELECT)
5703	select_level --;
5704
5705	in_omp_workshare = saved_in_omp_workshare;
5706	in_omp_atomic = saved_in_omp_atomic;
5707	in_where = saved_in_where;
5708	}
5709	}
5710	return 0;
5711	}
5712
5713	/* As a post-resolution step, check that all global symbols which are
5714	not declared in the source file match in their call signatures.
5715	We do this by looping over the code (and expressions). The first call
5716	we happen to find is assumed to be canonical. */
5717
5718
5719	/* Common tests for argument checking for both functions and subroutines. */
5720
5721	static int
5722	check_externals_procedure (gfc_symbol *sym, locus *loc,
5723	gfc_actual_arglist *actual)
5724	{
5725	gfc_gsymbol *gsym;
5726	gfc_symbol *def_sym = NULL;
5727
5728	if (sym == NULL || sym->attr.is_bind_c)
5729	return 0;
5730
5731	if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
5732	return 0;
5733
5734	if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
5735	return 0;
5736
5737	gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
5738	if (gsym == NULL)
5739	return 0;
5740
5741	if (gsym->ns)
5742	gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5743
5744	if (def_sym)
5745	{
5746	gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
5747	return 0;
5748	}
5749
5750	/* First time we have seen this procedure called. Let's create an
5751	"interface" from the call and put it into a new namespace. */
5752	gfc_namespace *save_ns;
5753	gfc_symbol *new_sym;
5754
5755	gsym->where = *loc;
5756	save_ns = gfc_current_ns;
5757	gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
5758	gsym->ns->proc_name = sym;
5759
5760	gfc_get_symbol (sym->name, gsym->ns, &new_sym);
5761	gcc_assert (new_sym);
5762	new_sym->attr = sym->attr;
5763	new_sym->attr.if_source = IFSRC_DECL;
5764	gfc_current_ns = gsym->ns;
5765
5766	gfc_get_formal_from_actual_arglist (new_sym, actual);
5767	new_sym->declared_at = *loc;
5768	gfc_current_ns = save_ns;
5769
5770	return 0;
5771
5772	}
5773
5774	/* Callback for calls of external routines. */
5775
5776	static int
5777	check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5778	void *data ATTRIBUTE_UNUSED)
5779	{
5780	gfc_code *co = *c;
5781	gfc_symbol *sym;
5782	locus *loc;
5783	gfc_actual_arglist *actual;
5784
5785	if (co->op != EXEC_CALL)
5786	return 0;
5787
5788	sym = co->resolved_sym;
5789	loc = &co->loc;
5790	actual = co->ext.actual;
5791
5792	return check_externals_procedure (sym, loc, actual);
5793
5794	}
5795
5796	/* Callback for external functions. */
5797
5798	static int
5799	check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
5800	void *data ATTRIBUTE_UNUSED)
5801	{
5802	gfc_expr *e = *ep;
5803	gfc_symbol *sym;
5804	locus *loc;
5805	gfc_actual_arglist *actual;
5806
5807	if (e->expr_type != EXPR_FUNCTION)
5808	return 0;
5809
5810	sym = e->value.function.esym;
5811	if (sym == NULL)
5812	return 0;
5813
5814	loc = &e->where;
5815	actual = e->value.function.actual;
5816
5817	return check_externals_procedure (sym, loc, actual);
5818	}
5819
5820	/* Function to check if any interface clashes with a global
5821	identifier, to be invoked via gfc_traverse_ns. */
5822
5823	static void
5824	check_against_globals (gfc_symbol *sym)
5825	{
5826	gfc_gsymbol *gsym;
5827	gfc_symbol *def_sym = NULL;
5828	const char *sym_name;
5829	char buf [200];
5830
5831	if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
5832	|| sym->attr.generic || sym->error)
5833	return;
5834
5835	if (sym->binding_label)
5836	sym_name = sym->binding_label;
5837	else
5838	sym_name = sym->name;
5839
5840	gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
5841	if (gsym && gsym->ns)
5842	gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
5843
5844	if (!def_sym || def_sym->error || def_sym->attr.generic)
5845	return;
5846
5847	buf[0] = 0;
5848	gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
5849	NULL, NULL, NULL);
5850	if (buf[0] != 0)
5851	{
5852	gfc_warning (opt: 0, "%s between %L and %L", buf, &def_sym->declared_at,
5853	&sym->declared_at);
5854	sym->error = 1;
5855	def_sym->error = 1;
5856	}
5857
5858	}
5859
5860	/* Do the code-walkling part for gfc_check_externals. */
5861
5862	static void
5863	gfc_check_externals0 (gfc_namespace *ns)
5864	{
5865	gfc_code_walker (c: &ns->code, codefn: check_externals_code, exprfn: check_externals_expr, NULL);
5866
5867	for (ns = ns->contained; ns; ns = ns->sibling)
5868	{
5869	if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
5870	gfc_check_externals0 (ns);
5871	}
5872
5873	}
5874
5875	/* Called routine. */
5876
5877	void
5878	gfc_check_externals (gfc_namespace *ns)
5879	{
5880	gfc_clear_error ();
5881
5882	/* Turn errors into warnings if the user indicated this. */
5883
5884	if (!pedantic && flag_allow_argument_mismatch)
5885	gfc_errors_to_warnings (true);
5886
5887	gfc_check_externals0 (ns);
5888	gfc_traverse_ns (ns, check_against_globals);
5889
5890	gfc_errors_to_warnings (false);
5891	}
5892
5893	/* Callback function. If there is a call to a subroutine which is
5894	neither pure nor implicit_pure, unset the implicit_pure flag for
5895	the caller and return -1. */
5896
5897	static int
5898	implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
5899	void *sym_data)
5900	{
5901	gfc_code *co = *c;
5902	gfc_symbol *caller_sym;
5903	symbol_attribute *a;
5904
5905	if (co->op != EXEC_CALL || co->resolved_sym == NULL)
5906	return 0;
5907
5908	a = &co->resolved_sym->attr;
5909	if (a->intrinsic || a->pure || a->implicit_pure)
5910	return 0;
5911
5912	caller_sym = (gfc_symbol *) sym_data;
5913	gfc_unset_implicit_pure (caller_sym);
5914	return 1;
5915	}
5916
5917	/* Callback function. If there is a call to a function which is
5918	neither pure nor implicit_pure, unset the implicit_pure flag for
5919	the caller and return 1. */
5920
5921	static int
5922	implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
5923	{
5924	gfc_expr *expr = *e;
5925	gfc_symbol *caller_sym;
5926	gfc_symbol *sym;
5927	symbol_attribute *a;
5928
5929	if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
5930	return 0;
5931
5932	sym = expr->symtree->n.sym;
5933	a = &sym->attr;
5934	if (a->pure || a->implicit_pure)
5935	return 0;
5936
5937	caller_sym = (gfc_symbol *) sym_data;
5938	gfc_unset_implicit_pure (caller_sym);
5939	return 1;
5940	}
5941
5942	/* Go through all procedures in the namespace and unset the
5943	implicit_pure attribute for any procedure that calls something not
5944	pure or implicit pure. */
5945
5946	bool
5947	gfc_fix_implicit_pure (gfc_namespace *ns)
5948	{
5949	bool changed = false;
5950	gfc_symbol *proc = ns->proc_name;
5951
5952	if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
5953	&& ns->code
5954	&& gfc_code_walker (c: &ns->code, codefn: implicit_pure_call, exprfn: implicit_pure_expr,
5955	data: (void *) ns->proc_name))
5956	changed = true;
5957
5958	for (ns = ns->contained; ns; ns = ns->sibling)
5959	{
5960	if (gfc_fix_implicit_pure (ns))
5961	changed = true;
5962	}
5963
5964	return changed;
5965	}
5966