1	/* Dependency analysis
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Paul Brook <paul@nowt.org>
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	/* dependency.cc -- Expression dependency analysis code. */
22	/* There's probably quite a bit of duplication in this file. We currently
23	have different dependency checking functions for different types
24	if dependencies. Ideally these would probably be merged. */
25
26	#include "config.h"
27	#include "system.h"
28	#include "coretypes.h"
29	#include "gfortran.h"
30	#include "dependency.h"
31	#include "constructor.h"
32	#include "arith.h"
33	#include "options.h"
34
35	/* static declarations */
36	/* Enums */
37	enum range {LHS, RHS, MID};
38
39	/* Dependency types. These must be in reverse order of priority. */
40	enum gfc_dependency
41	{
42	GFC_DEP_ERROR,
43	GFC_DEP_EQUAL, /* Identical Ranges. */
44	GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */
45	GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */
46	GFC_DEP_OVERLAP, /* May overlap in some other way. */
47	GFC_DEP_NODEP /* Distinct ranges. */
48	};
49
50	/* Macros */
51	#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
52
53	/* Forward declarations */
54
55	static gfc_dependency check_section_vs_section (gfc_array_ref *,
56	gfc_array_ref *, int);
57
58	/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
59	def if the value could not be determined. */
60
61	int
62	gfc_expr_is_one (gfc_expr *expr, int def)
63	{
64	gcc_assert (expr != NULL);
65
66	if (expr->expr_type != EXPR_CONSTANT)
67	return def;
68
69	if (expr->ts.type != BT_INTEGER)
70	return def;
71
72	return mpz_cmp_si (expr->value.integer, 1) == 0;
73	}
74
75	/* Check if two array references are known to be identical. Calls
76	gfc_dep_compare_expr if necessary for comparing array indices. */
77
78	static bool
79	identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
80	{
81	int i;
82
83	if (a1->type == AR_FULL && a2->type == AR_FULL)
84	return true;
85
86	if (a1->type == AR_SECTION && a2->type == AR_SECTION)
87	{
88	gcc_assert (a1->dimen == a2->dimen);
89
90	for ( i = 0; i < a1->dimen; i++)
91	{
92	/* TODO: Currently, we punt on an integer array as an index. */
93	if (a1->dimen_type[i] != DIMEN_RANGE
94	|| a2->dimen_type[i] != DIMEN_RANGE)
95	return false;
96
97	if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
98	return false;
99	}
100	return true;
101	}
102
103	if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
104	{
105	if (a1->dimen != a2->dimen)
106	gfc_internal_error ("identical_array_ref(): inconsistent dimensions");
107
108	for (i = 0; i < a1->dimen; i++)
109	{
110	if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
111	return false;
112	}
113	return true;
114	}
115	return false;
116	}
117
118
119
120	/* Return true for identical variables, checking for references if
121	necessary. Calls identical_array_ref for checking array sections. */
122
123	static bool
124	are_identical_variables (gfc_expr *e1, gfc_expr *e2)
125	{
126	gfc_ref *r1, *r2;
127
128	if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
129	{
130	/* Dummy arguments: Only check for equal names. */
131	if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
132	return false;
133	}
134	else
135	{
136	/* Check for equal symbols. */
137	if (e1->symtree->n.sym != e2->symtree->n.sym)
138	return false;
139	}
140
141	/* Volatile variables should never compare equal to themselves. */
142
143	if (e1->symtree->n.sym->attr.volatile_)
144	return false;
145
146	r1 = e1->ref;
147	r2 = e2->ref;
148
149	while (r1 != NULL || r2 != NULL)
150	{
151
152	/* Assume the variables are not equal if one has a reference and the
153	other doesn't.
154	TODO: Handle full references like comparing a(:) to a.
155	*/
156
157	if (r1 == NULL || r2 == NULL)
158	return false;
159
160	if (r1->type != r2->type)
161	return false;
162
163	switch (r1->type)
164	{
165
166	case REF_ARRAY:
167	if (!identical_array_ref (a1: &r1->u.ar, a2: &r2->u.ar))
168	return false;
169
170	break;
171
172	case REF_COMPONENT:
173	if (r1->u.c.component != r2->u.c.component)
174	return false;
175	break;
176
177	case REF_SUBSTRING:
178	if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0)
179	return false;
180
181	/* If both are NULL, the end length compares equal, because we
182	are looking at the same variable. This can only happen for
183	assumed- or deferred-length character arguments. */
184
185	if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
186	break;
187
188	if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
189	return false;
190
191	break;
192
193	case REF_INQUIRY:
194	if (r1->u.i != r2->u.i)
195	return false;
196	break;
197
198	default:
199	gfc_internal_error ("are_identical_variables: Bad type");
200	}
201	r1 = r1->next;
202	r2 = r2->next;
203	}
204	return true;
205	}
206
207	/* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
208	impure_ok is false, only return 0 for pure functions. */
209
210	int
211	gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
212	{
213
214	gfc_actual_arglist *args1;
215	gfc_actual_arglist *args2;
216
217	if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
218	return -2;
219
220	if ((e1->value.function.esym && e2->value.function.esym
221	&& e1->value.function.esym == e2->value.function.esym
222	&& (e1->value.function.esym->result->attr.pure || impure_ok))
223	|| (e1->value.function.isym && e2->value.function.isym
224	&& e1->value.function.isym == e2->value.function.isym
225	&& (e1->value.function.isym->pure || impure_ok)))
226	{
227	args1 = e1->value.function.actual;
228	args2 = e2->value.function.actual;
229
230	/* Compare the argument lists for equality. */
231	while (args1 && args2)
232	{
233	/* Bitwise xor, since C has no non-bitwise xor operator. */
234	if ((args1->expr == NULL) ^ (args2->expr == NULL))
235	return -2;
236
237	if (args1->expr != NULL && args2->expr != NULL)
238	{
239	gfc_expr *e1, *e2;
240	e1 = args1->expr;
241	e2 = args2->expr;
242
243	if (gfc_dep_compare_expr (e1, e2) != 0)
244	return -2;
245
246	/* Special case: String arguments which compare equal can have
247	different lengths, which makes them different in calls to
248	procedures. */
249
250	if (e1->expr_type == EXPR_CONSTANT
251	&& e1->ts.type == BT_CHARACTER
252	&& e2->expr_type == EXPR_CONSTANT
253	&& e2->ts.type == BT_CHARACTER
254	&& e1->value.character.length != e2->value.character.length)
255	return -2;
256	}
257
258	args1 = args1->next;
259	args2 = args2->next;
260	}
261	return (args1 || args2) ? -2 : 0;
262	}
263	else
264	return -2;
265	}
266
267	/* Helper function to look through parens, unary plus and widening
268	integer conversions. */
269
270	gfc_expr *
271	gfc_discard_nops (gfc_expr *e)
272	{
273	gfc_actual_arglist *arglist;
274
275	if (e == NULL)
276	return NULL;
277
278	while (true)
279	{
280	if (e->expr_type == EXPR_OP
281	&& (e->value.op.op == INTRINSIC_UPLUS
282	|| e->value.op.op == INTRINSIC_PARENTHESES))
283	{
284	e = e->value.op.op1;
285	continue;
286	}
287
288	if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
289	&& e->value.function.isym->id == GFC_ISYM_CONVERSION
290	&& e->ts.type == BT_INTEGER)
291	{
292	arglist = e->value.function.actual;
293	if (arglist->expr->ts.type == BT_INTEGER
294	&& e->ts.kind > arglist->expr->ts.kind)
295	{
296	e = arglist->expr;
297	continue;
298	}
299	}
300	break;
301	}
302
303	return e;
304	}
305
306
307	/* Compare two expressions. Return values:
308	* +1 if e1 > e2
309	* 0 if e1 == e2
310	* -1 if e1 < e2
311	* -2 if the relationship could not be determined
312	* -3 if e1 /= e2, but we cannot tell which one is larger.
313	REAL and COMPLEX constants are only compared for equality
314	or inequality; if they are unequal, -2 is returned in all cases. */
315
316	int
317	gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
318	{
319	int i;
320
321	if (e1 == NULL && e2 == NULL)
322	return 0;
323	else if (e1 == NULL || e2 == NULL)
324	return -2;
325
326	e1 = gfc_discard_nops (e: e1);
327	e2 = gfc_discard_nops (e: e2);
328
329	if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
330	{
331	/* Compare X+C vs. X, for INTEGER only. */
332	if (e1->value.op.op2->expr_type == EXPR_CONSTANT
333	&& e1->value.op.op2->ts.type == BT_INTEGER
334	&& gfc_dep_compare_expr (e1: e1->value.op.op1, e2) == 0)
335	return mpz_sgn (e1->value.op.op2->value.integer);
336
337	/* Compare P+Q vs. R+S. */
338	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
339	{
340	int l, r;
341
342	l = gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op1);
343	r = gfc_dep_compare_expr (e1: e1->value.op.op2, e2: e2->value.op.op2);
344	if (l == 0 && r == 0)
345	return 0;
346	if (l == 0 && r > -2)
347	return r;
348	if (l > -2 && r == 0)
349	return l;
350	if (l == 1 && r == 1)
351	return 1;
352	if (l == -1 && r == -1)
353	return -1;
354
355	l = gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op2);
356	r = gfc_dep_compare_expr (e1: e1->value.op.op2, e2: e2->value.op.op1);
357	if (l == 0 && r == 0)
358	return 0;
359	if (l == 0 && r > -2)
360	return r;
361	if (l > -2 && r == 0)
362	return l;
363	if (l == 1 && r == 1)
364	return 1;
365	if (l == -1 && r == -1)
366	return -1;
367	}
368	}
369
370	/* Compare X vs. X+C, for INTEGER only. */
371	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
372	{
373	if (e2->value.op.op2->expr_type == EXPR_CONSTANT
374	&& e2->value.op.op2->ts.type == BT_INTEGER
375	&& gfc_dep_compare_expr (e1, e2: e2->value.op.op1) == 0)
376	return -mpz_sgn (e2->value.op.op2->value.integer);
377	}
378
379	/* Compare X-C vs. X, for INTEGER only. */
380	if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
381	{
382	if (e1->value.op.op2->expr_type == EXPR_CONSTANT
383	&& e1->value.op.op2->ts.type == BT_INTEGER
384	&& gfc_dep_compare_expr (e1: e1->value.op.op1, e2) == 0)
385	return -mpz_sgn (e1->value.op.op2->value.integer);
386
387	/* Compare P-Q vs. R-S. */
388	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
389	{
390	int l, r;
391
392	l = gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op1);
393	r = gfc_dep_compare_expr (e1: e1->value.op.op2, e2: e2->value.op.op2);
394	if (l == 0 && r == 0)
395	return 0;
396	if (l > -2 && r == 0)
397	return l;
398	if (l == 0 && r > -2)
399	return -r;
400	if (l == 1 && r == -1)
401	return 1;
402	if (l == -1 && r == 1)
403	return -1;
404	}
405	}
406
407	/* Compare A // B vs. C // D. */
408
409	if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
410	&& e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
411	{
412	int l, r;
413
414	l = gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op1);
415	r = gfc_dep_compare_expr (e1: e1->value.op.op2, e2: e2->value.op.op2);
416
417	if (l != 0)
418	return l;
419
420	/* Left expressions of // compare equal, but
421	watch out for 'A ' // x vs. 'A' // x. */
422	gfc_expr *e1_left = e1->value.op.op1;
423	gfc_expr *e2_left = e2->value.op.op1;
424
425	if (e1_left->expr_type == EXPR_CONSTANT
426	&& e2_left->expr_type == EXPR_CONSTANT
427	&& e1_left->value.character.length
428	!= e2_left->value.character.length)
429	return -2;
430	else
431	return r;
432	}
433
434	/* Compare X vs. X-C, for INTEGER only. */
435	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
436	{
437	if (e2->value.op.op2->expr_type == EXPR_CONSTANT
438	&& e2->value.op.op2->ts.type == BT_INTEGER
439	&& gfc_dep_compare_expr (e1, e2: e2->value.op.op1) == 0)
440	return mpz_sgn (e2->value.op.op2->value.integer);
441	}
442
443	if (e1->expr_type != e2->expr_type)
444	return -3;
445
446	switch (e1->expr_type)
447	{
448	case EXPR_CONSTANT:
449	/* Compare strings for equality. */
450	if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
451	return gfc_compare_string (e1, e2);
452
453	/* Compare REAL and COMPLEX constants. Because of the
454	traps and pitfalls associated with comparing
455	a + 1.0 with a + 0.5, check for equality only. */
456	if (e2->expr_type == EXPR_CONSTANT)
457	{
458	if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
459	{
460	if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
461	return 0;
462	else
463	return -2;
464	}
465	else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
466	{
467	if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
468	return 0;
469	else
470	return -2;
471	}
472	}
473
474	if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
475	return -2;
476
477	/* For INTEGER, all cases where e2 is not constant should have
478	been filtered out above. */
479	gcc_assert (e2->expr_type == EXPR_CONSTANT);
480
481	i = mpz_cmp (e1->value.integer, e2->value.integer);
482	if (i == 0)
483	return 0;
484	else if (i < 0)
485	return -1;
486	return 1;
487
488	case EXPR_VARIABLE:
489	if (are_identical_variables (e1, e2))
490	return 0;
491	else
492	return -3;
493
494	case EXPR_OP:
495	/* Intrinsic operators are the same if their operands are the same. */
496	if (e1->value.op.op != e2->value.op.op)
497	return -2;
498	if (e1->value.op.op2 == 0)
499	{
500	i = gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op1);
501	return i == 0 ? 0 : -2;
502	}
503	if (gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op1) == 0
504	&& gfc_dep_compare_expr (e1: e1->value.op.op2, e2: e2->value.op.op2) == 0)
505	return 0;
506	else if (e1->value.op.op == INTRINSIC_TIMES
507	&& gfc_dep_compare_expr (e1: e1->value.op.op1, e2: e2->value.op.op2) == 0
508	&& gfc_dep_compare_expr (e1: e1->value.op.op2, e2: e2->value.op.op1) == 0)
509	/* Commutativity of multiplication; addition is handled above. */
510	return 0;
511
512	return -2;
513
514	case EXPR_FUNCTION:
515	return gfc_dep_compare_functions (e1, e2, impure_ok: false);
516
517	default:
518	return -2;
519	}
520	}
521
522
523	/* Return the difference between two expressions. Integer expressions of
524	the form
525
526	X + constant, X - constant and constant + X
527
528	are handled. Return true on success, false on failure. result is assumed
529	to be uninitialized on entry, and will be initialized on success.
530	*/
531
532	bool
533	gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
534	{
535	gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
536
537	if (e1 == NULL || e2 == NULL)
538	return false;
539
540	if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
541	return false;
542
543	e1 = gfc_discard_nops (e: e1);
544	e2 = gfc_discard_nops (e: e2);
545
546	/* Initialize tentatively, clear if we don't return anything. */
547	mpz_init (*result);
548
549	/* Case 1: c1 - c2 = c1 - c2, trivially. */
550
551	if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
552	{
553	mpz_sub (*result, e1->value.integer, e2->value.integer);
554	return true;
555	}
556
557	if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
558	{
559	e1_op1 = gfc_discard_nops (e: e1->value.op.op1);
560	e1_op2 = gfc_discard_nops (e: e1->value.op.op2);
561
562	/* Case 2: (X + c1) - X = c1. */
563	if (e1_op2->expr_type == EXPR_CONSTANT
564	&& gfc_dep_compare_expr (e1: e1_op1, e2) == 0)
565	{
566	mpz_set (*result, e1_op2->value.integer);
567	return true;
568	}
569
570	/* Case 3: (c1 + X) - X = c1. */
571	if (e1_op1->expr_type == EXPR_CONSTANT
572	&& gfc_dep_compare_expr (e1: e1_op2, e2) == 0)
573	{
574	mpz_set (*result, e1_op1->value.integer);
575	return true;
576	}
577
578	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
579	{
580	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
581	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
582
583	if (e1_op2->expr_type == EXPR_CONSTANT)
584	{
585	/* Case 4: X + c1 - (X + c2) = c1 - c2. */
586	if (e2_op2->expr_type == EXPR_CONSTANT
587	&& gfc_dep_compare_expr (e1: e1_op1, e2: e2_op1) == 0)
588	{
589	mpz_sub (*result, e1_op2->value.integer,
590	e2_op2->value.integer);
591	return true;
592	}
593	/* Case 5: X + c1 - (c2 + X) = c1 - c2. */
594	if (e2_op1->expr_type == EXPR_CONSTANT
595	&& gfc_dep_compare_expr (e1: e1_op1, e2: e2_op2) == 0)
596	{
597	mpz_sub (*result, e1_op2->value.integer,
598	e2_op1->value.integer);
599	return true;
600	}
601	}
602	else if (e1_op1->expr_type == EXPR_CONSTANT)
603	{
604	/* Case 6: c1 + X - (X + c2) = c1 - c2. */
605	if (e2_op2->expr_type == EXPR_CONSTANT
606	&& gfc_dep_compare_expr (e1: e1_op2, e2: e2_op1) == 0)
607	{
608	mpz_sub (*result, e1_op1->value.integer,
609	e2_op2->value.integer);
610	return true;
611	}
612	/* Case 7: c1 + X - (c2 + X) = c1 - c2. */
613	if (e2_op1->expr_type == EXPR_CONSTANT
614	&& gfc_dep_compare_expr (e1: e1_op2, e2: e2_op2) == 0)
615	{
616	mpz_sub (*result, e1_op1->value.integer,
617	e2_op1->value.integer);
618	return true;
619	}
620	}
621	}
622
623	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
624	{
625	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
626	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
627
628	if (e1_op2->expr_type == EXPR_CONSTANT)
629	{
630	/* Case 8: X + c1 - (X - c2) = c1 + c2. */
631	if (e2_op2->expr_type == EXPR_CONSTANT
632	&& gfc_dep_compare_expr (e1: e1_op1, e2: e2_op1) == 0)
633	{
634	mpz_add (*result, e1_op2->value.integer,
635	e2_op2->value.integer);
636	return true;
637	}
638	}
639	if (e1_op1->expr_type == EXPR_CONSTANT)
640	{
641	/* Case 9: c1 + X - (X - c2) = c1 + c2. */
642	if (e2_op2->expr_type == EXPR_CONSTANT
643	&& gfc_dep_compare_expr (e1: e1_op2, e2: e2_op1) == 0)
644	{
645	mpz_add (*result, e1_op1->value.integer,
646	e2_op2->value.integer);
647	return true;
648	}
649	}
650	}
651	}
652
653	if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
654	{
655	e1_op1 = gfc_discard_nops (e: e1->value.op.op1);
656	e1_op2 = gfc_discard_nops (e: e1->value.op.op2);
657
658	if (e1_op2->expr_type == EXPR_CONSTANT)
659	{
660	/* Case 10: (X - c1) - X = -c1 */
661
662	if (gfc_dep_compare_expr (e1: e1_op1, e2) == 0)
663	{
664	mpz_neg (gmp_w: *result, gmp_u: e1_op2->value.integer);
665	return true;
666	}
667
668	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
669	{
670	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
671	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
672
673	/* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
674	if (e2_op2->expr_type == EXPR_CONSTANT
675	&& gfc_dep_compare_expr (e1: e1_op1, e2: e2_op1) == 0)
676	{
677	mpz_add (*result, e1_op2->value.integer,
678	e2_op2->value.integer);
679	mpz_neg (gmp_w: *result, gmp_u: *result);
680	return true;
681	}
682
683	/* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */
684	if (e2_op1->expr_type == EXPR_CONSTANT
685	&& gfc_dep_compare_expr (e1: e1_op1, e2: e2_op2) == 0)
686	{
687	mpz_add (*result, e1_op2->value.integer,
688	e2_op1->value.integer);
689	mpz_neg (gmp_w: *result, gmp_u: *result);
690	return true;
691	}
692	}
693
694	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
695	{
696	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
697	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
698
699	/* Case 13: (X - c1) - (X - c2) = c2 - c1. */
700	if (e2_op2->expr_type == EXPR_CONSTANT
701	&& gfc_dep_compare_expr (e1: e1_op1, e2: e2_op1) == 0)
702	{
703	mpz_sub (*result, e2_op2->value.integer,
704	e1_op2->value.integer);
705	return true;
706	}
707	}
708	}
709	if (e1_op1->expr_type == EXPR_CONSTANT)
710	{
711	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
712	{
713	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
714	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
715
716	/* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
717	if (gfc_dep_compare_expr (e1: e1_op2, e2: e2_op2) == 0)
718	{
719	mpz_sub (*result, e1_op1->value.integer,
720	e2_op1->value.integer);
721	return true;
722	}
723	}
724
725	}
726	}
727
728	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
729	{
730	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
731	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
732
733	/* Case 15: X - (X + c2) = -c2. */
734	if (e2_op2->expr_type == EXPR_CONSTANT
735	&& gfc_dep_compare_expr (e1, e2: e2_op1) == 0)
736	{
737	mpz_neg (gmp_w: *result, gmp_u: e2_op2->value.integer);
738	return true;
739	}
740	/* Case 16: X - (c2 + X) = -c2. */
741	if (e2_op1->expr_type == EXPR_CONSTANT
742	&& gfc_dep_compare_expr (e1, e2: e2_op2) == 0)
743	{
744	mpz_neg (gmp_w: *result, gmp_u: e2_op1->value.integer);
745	return true;
746	}
747	}
748
749	if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
750	{
751	e2_op1 = gfc_discard_nops (e: e2->value.op.op1);
752	e2_op2 = gfc_discard_nops (e: e2->value.op.op2);
753
754	/* Case 17: X - (X - c2) = c2. */
755	if (e2_op2->expr_type == EXPR_CONSTANT
756	&& gfc_dep_compare_expr (e1, e2: e2_op1) == 0)
757	{
758	mpz_set (*result, e2_op2->value.integer);
759	return true;
760	}
761	}
762
763	if (gfc_dep_compare_expr (e1, e2) == 0)
764	{
765	/* Case 18: X - X = 0. */
766	mpz_set_si (*result, 0);
767	return true;
768	}
769
770	mpz_clear (*result);
771	return false;
772	}
773
774	/* Returns 1 if the two ranges are the same and 0 if they are not (or if the
775	results are indeterminate). 'n' is the dimension to compare. */
776
777	static int
778	is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
779	{
780	gfc_expr *e1;
781	gfc_expr *e2;
782	int i;
783
784	/* TODO: More sophisticated range comparison. */
785	gcc_assert (ar1 && ar2);
786
787	gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
788
789	e1 = ar1->stride[n];
790	e2 = ar2->stride[n];
791	/* Check for mismatching strides. A NULL stride means a stride of 1. */
792	if (e1 && !e2)
793	{
794	i = gfc_expr_is_one (expr: e1, def: -1);
795	if (i == -1 || i == 0)
796	return 0;
797	}
798	else if (e2 && !e1)
799	{
800	i = gfc_expr_is_one (expr: e2, def: -1);
801	if (i == -1 || i == 0)
802	return 0;
803	}
804	else if (e1 && e2)
805	{
806	i = gfc_dep_compare_expr (e1, e2);
807	if (i != 0)
808	return 0;
809	}
810	/* The strides match. */
811
812	/* Check the range start. */
813	e1 = ar1->start[n];
814	e2 = ar2->start[n];
815	if (e1 || e2)
816	{
817	/* Use the bound of the array if no bound is specified. */
818	if (ar1->as && !e1)
819	e1 = ar1->as->lower[n];
820
821	if (ar2->as && !e2)
822	e2 = ar2->as->lower[n];
823
824	/* Check we have values for both. */
825	if (!(e1 && e2))
826	return 0;
827
828	i = gfc_dep_compare_expr (e1, e2);
829	if (i != 0)
830	return 0;
831	}
832
833	/* Check the range end. */
834	e1 = ar1->end[n];
835	e2 = ar2->end[n];
836	if (e1 || e2)
837	{
838	/* Use the bound of the array if no bound is specified. */
839	if (ar1->as && !e1)
840	e1 = ar1->as->upper[n];
841
842	if (ar2->as && !e2)
843	e2 = ar2->as->upper[n];
844
845	/* Check we have values for both. */
846	if (!(e1 && e2))
847	return 0;
848
849	i = gfc_dep_compare_expr (e1, e2);
850	if (i != 0)
851	return 0;
852	}
853
854	return 1;
855	}
856
857
858	/* Some array-returning intrinsics can be implemented by reusing the
859	data from one of the array arguments. For example, TRANSPOSE does
860	not necessarily need to allocate new data: it can be implemented
861	by copying the original array's descriptor and simply swapping the
862	two dimension specifications.
863
864	If EXPR is a call to such an intrinsic, return the argument
865	whose data can be reused, otherwise return NULL. */
866
867	gfc_expr *
868	gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
869	{
870	if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
871	return NULL;
872
873	switch (expr->value.function.isym->id)
874	{
875	case GFC_ISYM_TRANSPOSE:
876	return expr->value.function.actual->expr;
877
878	default:
879	return NULL;
880	}
881	}
882
883
884	/* Return true if the result of reference REF can only be constructed
885	using a temporary array. */
886
887	bool
888	gfc_ref_needs_temporary_p (gfc_ref *ref)
889	{
890	int n;
891	bool subarray_p;
892
893	subarray_p = false;
894	for (; ref; ref = ref->next)
895	switch (ref->type)
896	{
897	case REF_ARRAY:
898	/* Vector dimensions are generally not monotonic and must be
899	handled using a temporary. */
900	if (ref->u.ar.type == AR_SECTION)
901	for (n = 0; n < ref->u.ar.dimen; n++)
902	if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
903	return true;
904
905	subarray_p = true;
906	break;
907
908	case REF_SUBSTRING:
909	/* Within an array reference, character substrings generally
910	need a temporary. Character array strides are expressed as
911	multiples of the element size (consistent with other array
912	types), not in characters. */
913	return subarray_p;
914
915	case REF_COMPONENT:
916	case REF_INQUIRY:
917	break;
918	}
919
920	return false;
921	}
922
923
924	static bool
925	gfc_is_data_pointer (gfc_expr *e)
926	{
927	gfc_ref *ref;
928
929	if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
930	return 0;
931
932	/* No subreference if it is a function */
933	gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
934
935	if (e->symtree->n.sym->attr.pointer)
936	return 1;
937
938	for (ref = e->ref; ref; ref = ref->next)
939	if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
940	return 1;
941
942	return 0;
943	}
944
945
946	/* Return true if array variable VAR could be passed to the same function
947	as argument EXPR without interfering with EXPR. INTENT is the intent
948	of VAR.
949
950	This is considerably less conservative than other dependencies
951	because many function arguments will already be copied into a
952	temporary. */
953
954	static int
955	gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
956	gfc_expr *expr, gfc_dep_check elemental)
957	{
958	gfc_expr *arg;
959
960	gcc_assert (var->expr_type == EXPR_VARIABLE);
961	gcc_assert (var->rank > 0);
962
963	switch (expr->expr_type)
964	{
965	case EXPR_VARIABLE:
966	/* In case of elemental subroutines, there is no dependency
967	between two same-range array references. */
968	if (gfc_ref_needs_temporary_p (ref: expr->ref)
969	|| gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
970	{
971	if (elemental == ELEM_DONT_CHECK_VARIABLE)
972	{
973	/* Too many false positive with pointers. */
974	if (!gfc_is_data_pointer (e: var) && !gfc_is_data_pointer (e: expr))
975	{
976	/* Elemental procedures forbid unspecified intents,
977	and we don't check dependencies for INTENT_IN args. */
978	gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
979
980	/* We are told not to check dependencies.
981	We do it, however, and issue a warning in case we find one.
982	If a dependency is found in the case
983	elemental == ELEM_CHECK_VARIABLE, we will generate
984	a temporary, so we don't need to bother the user. */
985
986	if (var->expr_type == EXPR_VARIABLE
987	&& expr->expr_type == EXPR_VARIABLE
988	&& strcmp(s1: var->symtree->name, s2: expr->symtree->name) == 0)
989	gfc_warning (opt: 0, "INTENT(%s) actual argument at %L might "
990	"interfere with actual argument at %L.",
991	intent == INTENT_OUT ? "OUT" : "INOUT",
992	&var->where, &expr->where);
993	}
994	return 0;
995	}
996	else
997	return 1;
998	}
999	return 0;
1000
1001	case EXPR_ARRAY:
1002	/* the scalarizer always generates a temporary for array constructors,
1003	so there is no dependency. */
1004	return 0;
1005
1006	case EXPR_FUNCTION:
1007	if (intent != INTENT_IN)
1008	{
1009	arg = gfc_get_noncopying_intrinsic_argument (expr);
1010	if (arg != NULL)
1011	return gfc_check_argument_var_dependency (var, intent, expr: arg,
1012	elemental: NOT_ELEMENTAL);
1013	}
1014
1015	if (elemental != NOT_ELEMENTAL)
1016	{
1017	if ((expr->value.function.esym
1018	&& expr->value.function.esym->attr.elemental)
1019	|| (expr->value.function.isym
1020	&& expr->value.function.isym->elemental))
1021	return gfc_check_fncall_dependency (var, intent, NULL,
1022	expr->value.function.actual,
1023	ELEM_CHECK_VARIABLE);
1024
1025	if (gfc_inline_intrinsic_function_p (expr))
1026	{
1027	/* The TRANSPOSE case should have been caught in the
1028	noncopying intrinsic case above. */
1029	gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
1030
1031	return gfc_check_fncall_dependency (var, intent, NULL,
1032	expr->value.function.actual,
1033	ELEM_CHECK_VARIABLE);
1034	}
1035	}
1036	return 0;
1037
1038	case EXPR_OP:
1039	/* In case of non-elemental procedures, there is no need to catch
1040	dependencies, as we will make a temporary anyway. */
1041	if (elemental)
1042	{
1043	/* If the actual arg EXPR is an expression, we need to catch
1044	a dependency between variables in EXPR and VAR,
1045	an intent((IN)OUT) variable. */
1046	if (expr->value.op.op1
1047	&& gfc_check_argument_var_dependency (var, intent,
1048	expr: expr->value.op.op1,
1049	elemental: ELEM_CHECK_VARIABLE))
1050	return 1;
1051	else if (expr->value.op.op2
1052	&& gfc_check_argument_var_dependency (var, intent,
1053	expr: expr->value.op.op2,
1054	elemental: ELEM_CHECK_VARIABLE))
1055	return 1;
1056	}
1057	return 0;
1058
1059	default:
1060	return 0;
1061	}
1062	}
1063
1064
1065	/* Like gfc_check_argument_var_dependency, but extended to any
1066	array expression OTHER, not just variables. */
1067
1068	static int
1069	gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
1070	gfc_expr *expr, gfc_dep_check elemental)
1071	{
1072	switch (other->expr_type)
1073	{
1074	case EXPR_VARIABLE:
1075	return gfc_check_argument_var_dependency (var: other, intent, expr, elemental);
1076
1077	case EXPR_FUNCTION:
1078	other = gfc_get_noncopying_intrinsic_argument (expr: other);
1079	if (other != NULL)
1080	return gfc_check_argument_dependency (other, intent: INTENT_IN, expr,
1081	elemental: NOT_ELEMENTAL);
1082
1083	return 0;
1084
1085	default:
1086	return 0;
1087	}
1088	}
1089
1090
1091	/* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
1092	FNSYM is the function being called, or NULL if not known. */
1093
1094	bool
1095	gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
1096	gfc_symbol *fnsym, gfc_actual_arglist *actual,
1097	gfc_dep_check elemental)
1098	{
1099	gfc_formal_arglist *formal;
1100	gfc_expr *expr;
1101
1102	formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
1103	for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
1104	{
1105	expr = actual->expr;
1106
1107	/* Skip args which are not present. */
1108	if (!expr)
1109	continue;
1110
1111	/* Skip other itself. */
1112	if (expr == other)
1113	continue;
1114
1115	/* Skip intent(in) arguments if OTHER itself is intent(in). */
1116	if (formal && intent == INTENT_IN
1117	&& formal->sym->attr.intent == INTENT_IN)
1118	continue;
1119
1120	if (gfc_check_argument_dependency (other, intent, expr, elemental))
1121	return 1;
1122	}
1123
1124	return 0;
1125	}
1126
1127
1128	/* Return 1 if e1 and e2 are equivalenced arrays, either
1129	directly or indirectly; i.e., equivalence (a,b) for a and b
1130	or equivalence (a,c),(b,c). This function uses the equiv_
1131	lists, generated in trans-common(add_equivalences), that are
1132	guaranteed to pick up indirect equivalences. We explicitly
1133	check for overlap using the offset and length of the equivalence.
1134	This function is symmetric.
1135	TODO: This function only checks whether the full top-level
1136	symbols overlap. An improved implementation could inspect
1137	e1->ref and e2->ref to determine whether the actually accessed
1138	portions of these variables/arrays potentially overlap. */
1139
1140	bool
1141	gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
1142	{
1143	gfc_equiv_list *l;
1144	gfc_equiv_info *s, *fl1, *fl2;
1145
1146	gcc_assert (e1->expr_type == EXPR_VARIABLE
1147	&& e2->expr_type == EXPR_VARIABLE);
1148
1149	if (!e1->symtree->n.sym->attr.in_equivalence
1150	|| !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
1151	return 0;
1152
1153	if (e1->symtree->n.sym->ns
1154	&& e1->symtree->n.sym->ns != gfc_current_ns)
1155	l = e1->symtree->n.sym->ns->equiv_lists;
1156	else
1157	l = gfc_current_ns->equiv_lists;
1158
1159	/* Go through the equiv_lists and return 1 if the variables
1160	e1 and e2 are members of the same group and satisfy the
1161	requirement on their relative offsets. */
1162	for (; l; l = l->next)
1163	{
1164	fl1 = NULL;
1165	fl2 = NULL;
1166	for (s = l->equiv; s; s = s->next)
1167	{
1168	if (s->sym == e1->symtree->n.sym)
1169	{
1170	fl1 = s;
1171	if (fl2)
1172	break;
1173	}
1174	if (s->sym == e2->symtree->n.sym)
1175	{
1176	fl2 = s;
1177	if (fl1)
1178	break;
1179	}
1180	}
1181
1182	if (s)
1183	{
1184	/* Can these lengths be zero? */
1185	if (fl1->length <= 0 || fl2->length <= 0)
1186	return 1;
1187	/* These can't overlap if [f11,fl1+length] is before
1188	[fl2,fl2+length], or [fl2,fl2+length] is before
1189	[fl1,fl1+length], otherwise they do overlap. */
1190	if (fl1->offset + fl1->length > fl2->offset
1191	&& fl2->offset + fl2->length > fl1->offset)
1192	return 1;
1193	}
1194	}
1195	return 0;
1196	}
1197
1198
1199	/* Return true if there is no possibility of aliasing because of a type
1200	mismatch between all the possible pointer references and the
1201	potential target. Note that this function is asymmetric in the
1202	arguments and so must be called twice with the arguments exchanged. */
1203
1204	static bool
1205	check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
1206	{
1207	gfc_component *cm1;
1208	gfc_symbol *sym1;
1209	gfc_symbol *sym2;
1210	gfc_ref *ref1;
1211	bool seen_component_ref;
1212
1213	if (expr1->expr_type != EXPR_VARIABLE
1214	|| expr2->expr_type != EXPR_VARIABLE)
1215	return false;
1216
1217	sym1 = expr1->symtree->n.sym;
1218	sym2 = expr2->symtree->n.sym;
1219
1220	/* Keep it simple for now. */
1221	if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
1222	return false;
1223
1224	if (sym1->attr.pointer)
1225	{
1226	if (gfc_compare_types (&sym1->ts, &sym2->ts))
1227	return false;
1228	}
1229
1230	/* This is a conservative check on the components of the derived type
1231	if no component references have been seen. Since we will not dig
1232	into the components of derived type components, we play it safe by
1233	returning false. First we check the reference chain and then, if
1234	no component references have been seen, the components. */
1235	seen_component_ref = false;
1236	if (sym1->ts.type == BT_DERIVED)
1237	{
1238	for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
1239	{
1240	if (ref1->type != REF_COMPONENT)
1241	continue;
1242
1243	if (ref1->u.c.component->ts.type == BT_DERIVED)
1244	return false;
1245
1246	if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
1247	&& gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
1248	return false;
1249
1250	seen_component_ref = true;
1251	}
1252	}
1253
1254	if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
1255	{
1256	for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
1257	{
1258	if (cm1->ts.type == BT_DERIVED)
1259	return false;
1260
1261	if ((sym2->attr.pointer || cm1->attr.pointer)
1262	&& gfc_compare_types (&cm1->ts, &sym2->ts))
1263	return false;
1264	}
1265	}
1266
1267	return true;
1268	}
1269
1270
1271	/* Return true if the statement body redefines the condition. Returns
1272	true if expr2 depends on expr1. expr1 should be a single term
1273	suitable for the lhs of an assignment. The IDENTICAL flag indicates
1274	whether array references to the same symbol with identical range
1275	references count as a dependency or not. Used for forall and where
1276	statements. Also used with functions returning arrays without a
1277	temporary. */
1278
1279	int
1280	gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1281	{
1282	gfc_actual_arglist *actual;
1283	gfc_constructor *c;
1284	int n;
1285
1286	/* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION
1287	and a reference to _F.caf_get, so skip the assert. */
1288	if (expr1->expr_type == EXPR_FUNCTION
1289	&& strcmp (s1: expr1->value.function.name, s2: "_F.caf_get") == 0)
1290	return 0;
1291
1292	if (expr1->expr_type != EXPR_VARIABLE)
1293	gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
1294
1295	/* Prevent NULL pointer dereference while recursively analyzing invalid
1296	expressions. */
1297	if (expr2 == NULL)
1298	return 0;
1299
1300	switch (expr2->expr_type)
1301	{
1302	case EXPR_OP:
1303	n = gfc_check_dependency (expr1, expr2: expr2->value.op.op1, identical);
1304	if (n)
1305	return n;
1306	if (expr2->value.op.op2)
1307	return gfc_check_dependency (expr1, expr2: expr2->value.op.op2, identical);
1308	return 0;
1309
1310	case EXPR_VARIABLE:
1311	/* The interesting cases are when the symbols don't match. */
1312	if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1313	{
1314	symbol_attribute attr1, attr2;
1315	gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1316	gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1317
1318	/* Return 1 if expr1 and expr2 are equivalenced arrays. */
1319	if (gfc_are_equivalenced_arrays (e1: expr1, e2: expr2))
1320	return 1;
1321
1322	/* Symbols can only alias if they have the same type. */
1323	if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1324	&& ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1325	{
1326	if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1327	return 0;
1328	}
1329
1330	/* We have to also include target-target as ptr%comp is not a
1331	pointer but it still alias with "dt%comp" for "ptr => dt". As
1332	subcomponents and array access to pointers retains the target
1333	attribute, that's sufficient. */
1334	attr1 = gfc_expr_attr (expr1);
1335	attr2 = gfc_expr_attr (expr2);
1336	if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target))
1337	{
1338	if (check_data_pointer_types (expr1, expr2)
1339	&& check_data_pointer_types (expr1: expr2, expr2: expr1))
1340	return 0;
1341
1342	return 1;
1343	}
1344	else
1345	{
1346	gfc_symbol *sym1 = expr1->symtree->n.sym;
1347	gfc_symbol *sym2 = expr2->symtree->n.sym;
1348	if (sym1->attr.target && sym2->attr.target
1349	&& ((sym1->attr.dummy && !sym1->attr.contiguous
1350	&& (!sym1->attr.dimension
1351	|| sym2->as->type == AS_ASSUMED_SHAPE))
1352	|| (sym2->attr.dummy && !sym2->attr.contiguous
1353	&& (!sym2->attr.dimension
1354	|| sym2->as->type == AS_ASSUMED_SHAPE))))
1355	return 1;
1356	}
1357
1358	/* Otherwise distinct symbols have no dependencies. */
1359	return 0;
1360	}
1361
1362	/* Identical and disjoint ranges return 0,
1363	overlapping ranges return 1. */
1364	if (expr1->ref && expr2->ref)
1365	return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical);
1366
1367	return 1;
1368
1369	case EXPR_FUNCTION:
1370	if (gfc_get_noncopying_intrinsic_argument (expr: expr2) != NULL)
1371	identical = 1;
1372
1373	/* Remember possible differences between elemental and
1374	transformational functions. All functions inside a FORALL
1375	will be pure. */
1376	for (actual = expr2->value.function.actual;
1377	actual; actual = actual->next)
1378	{
1379	if (!actual->expr)
1380	continue;
1381	n = gfc_check_dependency (expr1, expr2: actual->expr, identical);
1382	if (n)
1383	return n;
1384	}
1385	return 0;
1386
1387	case EXPR_CONSTANT:
1388	case EXPR_NULL:
1389	return 0;
1390
1391	case EXPR_ARRAY:
1392	/* Loop through the array constructor's elements. */
1393	for (c = gfc_constructor_first (base: expr2->value.constructor);
1394	c; c = gfc_constructor_next (ctor: c))
1395	{
1396	/* If this is an iterator, assume the worst. */
1397	if (c->iterator)
1398	return 1;
1399	/* Avoid recursion in the common case. */
1400	if (c->expr->expr_type == EXPR_CONSTANT)
1401	continue;
1402	if (gfc_check_dependency (expr1, expr2: c->expr, identical: 1))
1403	return 1;
1404	}
1405	return 0;
1406
1407	default:
1408	return 1;
1409	}
1410	}
1411
1412
1413	/* Determines overlapping for two array sections. */
1414
1415	static gfc_dependency
1416	check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1417	{
1418	gfc_expr *l_start;
1419	gfc_expr *l_end;
1420	gfc_expr *l_stride;
1421	gfc_expr *l_lower;
1422	gfc_expr *l_upper;
1423	int l_dir;
1424
1425	gfc_expr *r_start;
1426	gfc_expr *r_end;
1427	gfc_expr *r_stride;
1428	gfc_expr *r_lower;
1429	gfc_expr *r_upper;
1430	gfc_expr *one_expr;
1431	int r_dir;
1432	int stride_comparison;
1433	int start_comparison;
1434	mpz_t tmp;
1435
1436	/* If they are the same range, return without more ado. */
1437	if (is_same_range (ar1: l_ar, ar2: r_ar, n))
1438	return GFC_DEP_EQUAL;
1439
1440	l_start = l_ar->start[n];
1441	l_end = l_ar->end[n];
1442	l_stride = l_ar->stride[n];
1443
1444	r_start = r_ar->start[n];
1445	r_end = r_ar->end[n];
1446	r_stride = r_ar->stride[n];
1447
1448	/* If l_start is NULL take it from array specifier. */
1449	if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1450	l_start = l_ar->as->lower[n];
1451	/* If l_end is NULL take it from array specifier. */
1452	if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1453	l_end = l_ar->as->upper[n];
1454
1455	/* If r_start is NULL take it from array specifier. */
1456	if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1457	r_start = r_ar->as->lower[n];
1458	/* If r_end is NULL take it from array specifier. */
1459	if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1460	r_end = r_ar->as->upper[n];
1461
1462	/* Determine whether the l_stride is positive or negative. */
1463	if (!l_stride)
1464	l_dir = 1;
1465	else if (l_stride->expr_type == EXPR_CONSTANT
1466	&& l_stride->ts.type == BT_INTEGER)
1467	l_dir = mpz_sgn (l_stride->value.integer);
1468	else if (l_start && l_end)
1469	l_dir = gfc_dep_compare_expr (e1: l_end, e2: l_start);
1470	else
1471	l_dir = -2;
1472
1473	/* Determine whether the r_stride is positive or negative. */
1474	if (!r_stride)
1475	r_dir = 1;
1476	else if (r_stride->expr_type == EXPR_CONSTANT
1477	&& r_stride->ts.type == BT_INTEGER)
1478	r_dir = mpz_sgn (r_stride->value.integer);
1479	else if (r_start && r_end)
1480	r_dir = gfc_dep_compare_expr (e1: r_end, e2: r_start);
1481	else
1482	r_dir = -2;
1483
1484	/* The strides should never be zero. */
1485	if (l_dir == 0 || r_dir == 0)
1486	return GFC_DEP_OVERLAP;
1487
1488	/* Determine the relationship between the strides. Set stride_comparison to
1489	-2 if the dependency cannot be determined
1490	-1 if l_stride < r_stride
1491	0 if l_stride == r_stride
1492	1 if l_stride > r_stride
1493	as determined by gfc_dep_compare_expr. */
1494
1495	one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1496
1497	stride_comparison = gfc_dep_compare_expr (e1: l_stride ? l_stride : one_expr,
1498	e2: r_stride ? r_stride : one_expr);
1499
1500	if (l_start && r_start)
1501	start_comparison = gfc_dep_compare_expr (e1: l_start, e2: r_start);
1502	else
1503	start_comparison = -2;
1504
1505	gfc_free_expr (one_expr);
1506
1507	/* Determine LHS upper and lower bounds. */
1508	if (l_dir == 1)
1509	{
1510	l_lower = l_start;
1511	l_upper = l_end;
1512	}
1513	else if (l_dir == -1)
1514	{
1515	l_lower = l_end;
1516	l_upper = l_start;
1517	}
1518	else
1519	{
1520	l_lower = NULL;
1521	l_upper = NULL;
1522	}
1523
1524	/* Determine RHS upper and lower bounds. */
1525	if (r_dir == 1)
1526	{
1527	r_lower = r_start;
1528	r_upper = r_end;
1529	}
1530	else if (r_dir == -1)
1531	{
1532	r_lower = r_end;
1533	r_upper = r_start;
1534	}
1535	else
1536	{
1537	r_lower = NULL;
1538	r_upper = NULL;
1539	}
1540
1541	/* Check whether the ranges are disjoint. */
1542	if (l_upper && r_lower && gfc_dep_compare_expr (e1: l_upper, e2: r_lower) == -1)
1543	return GFC_DEP_NODEP;
1544	if (r_upper && l_lower && gfc_dep_compare_expr (e1: r_upper, e2: l_lower) == -1)
1545	return GFC_DEP_NODEP;
1546
1547	/* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1548	if (l_start && r_start && gfc_dep_compare_expr (e1: l_start, e2: r_start) == 0)
1549	{
1550	if (l_dir == 1 && r_dir == -1)
1551	return GFC_DEP_EQUAL;
1552	if (l_dir == -1 && r_dir == 1)
1553	return GFC_DEP_EQUAL;
1554	}
1555
1556	/* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1557	if (l_end && r_end && gfc_dep_compare_expr (e1: l_end, e2: r_end) == 0)
1558	{
1559	if (l_dir == 1 && r_dir == -1)
1560	return GFC_DEP_EQUAL;
1561	if (l_dir == -1 && r_dir == 1)
1562	return GFC_DEP_EQUAL;
1563	}
1564
1565	/* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1566	There is no dependency if the remainder of
1567	(l_start - r_start) / gcd(l_stride, r_stride) is
1568	nonzero.
1569	TODO:
1570	- Cases like a(1:4:2) = a(2:3) are still not handled.
1571	*/
1572
1573	#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1574	&& (a)->ts.type == BT_INTEGER)
1575
1576	if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
1577	&& gfc_dep_difference (e1: l_start, e2: r_start, result: &tmp))
1578	{
1579	mpz_t gcd;
1580	int result;
1581
1582	mpz_init (gcd);
1583	mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1584
1585	mpz_fdiv_r (tmp, tmp, gcd);
1586	result = mpz_cmp_si (tmp, 0L);
1587
1588	mpz_clear (gcd);
1589	mpz_clear (tmp);
1590
1591	if (result != 0)
1592	return GFC_DEP_NODEP;
1593	}
1594
1595	#undef IS_CONSTANT_INTEGER
1596
1597	/* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1598
1599	if (l_dir == 1 && r_dir == 1 &&
1600	(start_comparison == 0 || start_comparison == -1)
1601	&& (stride_comparison == 0 || stride_comparison == -1))
1602	return GFC_DEP_FORWARD;
1603
1604	/* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1605	x:y:-1 vs. x:y:-2. */
1606	if (l_dir == -1 && r_dir == -1 &&
1607	(start_comparison == 0 || start_comparison == 1)
1608	&& (stride_comparison == 0 || stride_comparison == 1))
1609	return GFC_DEP_FORWARD;
1610
1611	if (stride_comparison == 0 || stride_comparison == -1)
1612	{
1613	if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1614	{
1615
1616	/* Check for a(low:y:s) vs. a(z:x:s) or
1617	a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1618	of low, which is always at least a forward dependence. */
1619
1620	if (r_dir == 1
1621	&& gfc_dep_compare_expr (e1: l_start, e2: l_ar->as->lower[n]) == 0)
1622	return GFC_DEP_FORWARD;
1623	}
1624	}
1625
1626	if (stride_comparison == 0 || stride_comparison == 1)
1627	{
1628	if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1629	{
1630
1631	/* Check for a(high:y:-s) vs. a(z:x:-s) or
1632	a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1633	of high, which is always at least a forward dependence. */
1634
1635	if (r_dir == -1
1636	&& gfc_dep_compare_expr (e1: l_start, e2: l_ar->as->upper[n]) == 0)
1637	return GFC_DEP_FORWARD;
1638	}
1639	}
1640
1641
1642	if (stride_comparison == 0)
1643	{
1644	/* From here, check for backwards dependencies. */
1645	/* x+1:y vs. x:z. */
1646	if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1647	return GFC_DEP_BACKWARD;
1648
1649	/* x-1:y:-1 vs. x:z:-1. */
1650	if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1651	return GFC_DEP_BACKWARD;
1652	}
1653
1654	return GFC_DEP_OVERLAP;
1655	}
1656
1657
1658	/* Determines overlapping for a single element and a section. */
1659
1660	static gfc_dependency
1661	gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1662	{
1663	gfc_array_ref *ref;
1664	gfc_expr *elem;
1665	gfc_expr *start;
1666	gfc_expr *end;
1667	gfc_expr *stride;
1668	int s;
1669
1670	elem = lref->u.ar.start[n];
1671	if (!elem)
1672	return GFC_DEP_OVERLAP;
1673
1674	ref = &rref->u.ar;
1675	start = ref->start[n] ;
1676	end = ref->end[n] ;
1677	stride = ref->stride[n];
1678
1679	if (!start && IS_ARRAY_EXPLICIT (ref->as))
1680	start = ref->as->lower[n];
1681	if (!end && IS_ARRAY_EXPLICIT (ref->as))
1682	end = ref->as->upper[n];
1683
1684	/* Determine whether the stride is positive or negative. */
1685	if (!stride)
1686	s = 1;
1687	else if (stride->expr_type == EXPR_CONSTANT
1688	&& stride->ts.type == BT_INTEGER)
1689	s = mpz_sgn (stride->value.integer);
1690	else
1691	s = -2;
1692
1693	/* Stride should never be zero. */
1694	if (s == 0)
1695	return GFC_DEP_OVERLAP;
1696
1697	/* Positive strides. */
1698	if (s == 1)
1699	{
1700	/* Check for elem < lower. */
1701	if (start && gfc_dep_compare_expr (e1: elem, e2: start) == -1)
1702	return GFC_DEP_NODEP;
1703	/* Check for elem > upper. */
1704	if (end && gfc_dep_compare_expr (e1: elem, e2: end) == 1)
1705	return GFC_DEP_NODEP;
1706
1707	if (start && end)
1708	{
1709	s = gfc_dep_compare_expr (e1: start, e2: end);
1710	/* Check for an empty range. */
1711	if (s == 1)
1712	return GFC_DEP_NODEP;
1713	if (s == 0 && gfc_dep_compare_expr (e1: elem, e2: start) == 0)
1714	return GFC_DEP_EQUAL;
1715	}
1716	}
1717	/* Negative strides. */
1718	else if (s == -1)
1719	{
1720	/* Check for elem > upper. */
1721	if (end && gfc_dep_compare_expr (e1: elem, e2: start) == 1)
1722	return GFC_DEP_NODEP;
1723	/* Check for elem < lower. */
1724	if (start && gfc_dep_compare_expr (e1: elem, e2: end) == -1)
1725	return GFC_DEP_NODEP;
1726
1727	if (start && end)
1728	{
1729	s = gfc_dep_compare_expr (e1: start, e2: end);
1730	/* Check for an empty range. */
1731	if (s == -1)
1732	return GFC_DEP_NODEP;
1733	if (s == 0 && gfc_dep_compare_expr (e1: elem, e2: start) == 0)
1734	return GFC_DEP_EQUAL;
1735	}
1736	}
1737	/* Unknown strides. */
1738	else
1739	{
1740	if (!start || !end)
1741	return GFC_DEP_OVERLAP;
1742	s = gfc_dep_compare_expr (e1: start, e2: end);
1743	if (s <= -2)
1744	return GFC_DEP_OVERLAP;
1745	/* Assume positive stride. */
1746	if (s == -1)
1747	{
1748	/* Check for elem < lower. */
1749	if (gfc_dep_compare_expr (e1: elem, e2: start) == -1)
1750	return GFC_DEP_NODEP;
1751	/* Check for elem > upper. */
1752	if (gfc_dep_compare_expr (e1: elem, e2: end) == 1)
1753	return GFC_DEP_NODEP;
1754	}
1755	/* Assume negative stride. */
1756	else if (s == 1)
1757	{
1758	/* Check for elem > upper. */
1759	if (gfc_dep_compare_expr (e1: elem, e2: start) == 1)
1760	return GFC_DEP_NODEP;
1761	/* Check for elem < lower. */
1762	if (gfc_dep_compare_expr (e1: elem, e2: end) == -1)
1763	return GFC_DEP_NODEP;
1764	}
1765	/* Equal bounds. */
1766	else if (s == 0)
1767	{
1768	s = gfc_dep_compare_expr (e1: elem, e2: start);
1769	if (s == 0)
1770	return GFC_DEP_EQUAL;
1771	if (s == 1 || s == -1)
1772	return GFC_DEP_NODEP;
1773	}
1774	}
1775
1776	return GFC_DEP_OVERLAP;
1777	}
1778
1779
1780	/* Traverse expr, checking all EXPR_VARIABLE symbols for their
1781	forall_index attribute. Return true if any variable may be
1782	being used as a FORALL index. Its safe to pessimistically
1783	return true, and assume a dependency. */
1784
1785	static bool
1786	contains_forall_index_p (gfc_expr *expr)
1787	{
1788	gfc_actual_arglist *arg;
1789	gfc_constructor *c;
1790	gfc_ref *ref;
1791	int i;
1792
1793	if (!expr)
1794	return false;
1795
1796	switch (expr->expr_type)
1797	{
1798	case EXPR_VARIABLE:
1799	if (expr->symtree->n.sym->forall_index)
1800	return true;
1801	break;
1802
1803	case EXPR_OP:
1804	if (contains_forall_index_p (expr: expr->value.op.op1)
1805	|| contains_forall_index_p (expr: expr->value.op.op2))
1806	return true;
1807	break;
1808
1809	case EXPR_FUNCTION:
1810	for (arg = expr->value.function.actual; arg; arg = arg->next)
1811	if (contains_forall_index_p (expr: arg->expr))
1812	return true;
1813	break;
1814
1815	case EXPR_CONSTANT:
1816	case EXPR_NULL:
1817	case EXPR_SUBSTRING:
1818	break;
1819
1820	case EXPR_STRUCTURE:
1821	case EXPR_ARRAY:
1822	for (c = gfc_constructor_first (base: expr->value.constructor);
1823	c; gfc_constructor_next (ctor: c))
1824	if (contains_forall_index_p (expr: c->expr))
1825	return true;
1826	break;
1827
1828	default:
1829	gcc_unreachable ();
1830	}
1831
1832	for (ref = expr->ref; ref; ref = ref->next)
1833	switch (ref->type)
1834	{
1835	case REF_ARRAY:
1836	for (i = 0; i < ref->u.ar.dimen; i++)
1837	if (contains_forall_index_p (expr: ref->u.ar.start[i])
1838	|| contains_forall_index_p (expr: ref->u.ar.end[i])
1839	|| contains_forall_index_p (expr: ref->u.ar.stride[i]))
1840	return true;
1841	break;
1842
1843	case REF_COMPONENT:
1844	break;
1845
1846	case REF_SUBSTRING:
1847	if (contains_forall_index_p (expr: ref->u.ss.start)
1848	|| contains_forall_index_p (expr: ref->u.ss.end))
1849	return true;
1850	break;
1851
1852	default:
1853	gcc_unreachable ();
1854	}
1855
1856	return false;
1857	}
1858
1859	/* Determines overlapping for two single element array references. */
1860
1861	static gfc_dependency
1862	gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1863	{
1864	gfc_array_ref l_ar;
1865	gfc_array_ref r_ar;
1866	gfc_expr *l_start;
1867	gfc_expr *r_start;
1868	int i;
1869
1870	l_ar = lref->u.ar;
1871	r_ar = rref->u.ar;
1872	l_start = l_ar.start[n] ;
1873	r_start = r_ar.start[n] ;
1874	i = gfc_dep_compare_expr (e1: r_start, e2: l_start);
1875	if (i == 0)
1876	return GFC_DEP_EQUAL;
1877
1878	/* Treat two scalar variables as potentially equal. This allows
1879	us to prove that a(i,:) and a(j,:) have no dependency. See
1880	Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1881	Proceedings of the International Conference on Parallel and
1882	Distributed Processing Techniques and Applications (PDPTA2001),
1883	Las Vegas, Nevada, June 2001. */
1884	/* However, we need to be careful when either scalar expression
1885	contains a FORALL index, as these can potentially change value
1886	during the scalarization/traversal of this array reference. */
1887	if (contains_forall_index_p (expr: r_start) || contains_forall_index_p (expr: l_start))
1888	return GFC_DEP_OVERLAP;
1889
1890	if (i > -2)
1891	return GFC_DEP_NODEP;
1892
1893	return GFC_DEP_EQUAL;
1894	}
1895
1896	/* Callback function for checking if an expression depends on a
1897	dummy variable which is any other than INTENT(IN). */
1898
1899	static int
1900	callback_dummy_intent_not_in (gfc_expr **ep,
1901	int *walk_subtrees ATTRIBUTE_UNUSED,
1902	void *data ATTRIBUTE_UNUSED)
1903	{
1904	gfc_expr *e = *ep;
1905
1906	if (e->expr_type == EXPR_VARIABLE && e->symtree
1907	&& e->symtree->n.sym->attr.dummy)
1908	return e->symtree->n.sym->attr.intent != INTENT_IN;
1909	else
1910	return 0;
1911	}
1912
1913	/* Auxiliary function to check if subexpressions have dummy variables which
1914	are not intent(in).
1915	*/
1916
1917	static bool
1918	dummy_intent_not_in (gfc_expr **ep)
1919	{
1920	return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL);
1921	}
1922
1923	/* Determine if an array ref, usually an array section specifies the
1924	entire array. In addition, if the second, pointer argument is
1925	provided, the function will return true if the reference is
1926	contiguous; eg. (:, 1) gives true but (1,:) gives false.
1927	If one of the bounds depends on a dummy variable which is
1928	not INTENT(IN), also return false, because the user may
1929	have changed the variable. */
1930
1931	bool
1932	gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1933	{
1934	int i;
1935	int n;
1936	bool lbound_OK = true;
1937	bool ubound_OK = true;
1938
1939	if (contiguous)
1940	*contiguous = false;
1941
1942	if (ref->type != REF_ARRAY)
1943	return false;
1944
1945	if (ref->u.ar.type == AR_FULL)
1946	{
1947	if (contiguous)
1948	*contiguous = true;
1949	return true;
1950	}
1951
1952	if (ref->u.ar.type != AR_SECTION)
1953	return false;
1954	if (ref->next)
1955	return false;
1956
1957	for (i = 0; i < ref->u.ar.dimen; i++)
1958	{
1959	/* If we have a single element in the reference, for the reference
1960	to be full, we need to ascertain that the array has a single
1961	element in this dimension and that we actually reference the
1962	correct element. */
1963	if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1964	{
1965	/* This is unconditionally a contiguous reference if all the
1966	remaining dimensions are elements. */
1967	if (contiguous)
1968	{
1969	*contiguous = true;
1970	for (n = i + 1; n < ref->u.ar.dimen; n++)
1971	if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1972	*contiguous = false;
1973	}
1974
1975	if (!ref->u.ar.as
1976	|| !ref->u.ar.as->lower[i]
1977	|| !ref->u.ar.as->upper[i]
1978	|| gfc_dep_compare_expr (e1: ref->u.ar.as->lower[i],
1979	e2: ref->u.ar.as->upper[i])
1980	|| !ref->u.ar.start[i]
1981	|| gfc_dep_compare_expr (e1: ref->u.ar.start[i],
1982	e2: ref->u.ar.as->lower[i]))
1983	return false;
1984	else
1985	continue;
1986	}
1987
1988	/* Check the lower bound. */
1989	if (ref->u.ar.start[i]
1990	&& (!ref->u.ar.as
1991	|| !ref->u.ar.as->lower[i]
1992	|| gfc_dep_compare_expr (e1: ref->u.ar.start[i],
1993	e2: ref->u.ar.as->lower[i])
1994	|| dummy_intent_not_in (ep: &ref->u.ar.start[i])))
1995	lbound_OK = false;
1996	/* Check the upper bound. */
1997	if (ref->u.ar.end[i]
1998	&& (!ref->u.ar.as
1999	|| !ref->u.ar.as->upper[i]
2000	|| gfc_dep_compare_expr (e1: ref->u.ar.end[i],
2001	e2: ref->u.ar.as->upper[i])
2002	|| dummy_intent_not_in (ep: &ref->u.ar.end[i])))
2003	ubound_OK = false;
2004	/* Check the stride. */
2005	if (ref->u.ar.stride[i]
2006	&& !gfc_expr_is_one (expr: ref->u.ar.stride[i], def: 0))
2007	return false;
2008
2009	/* This is unconditionally a contiguous reference as long as all
2010	the subsequent dimensions are elements. */
2011	if (contiguous)
2012	{
2013	*contiguous = true;
2014	for (n = i + 1; n < ref->u.ar.dimen; n++)
2015	if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2016	*contiguous = false;
2017	}
2018
2019	if (!lbound_OK || !ubound_OK)
2020	return false;
2021	}
2022	return true;
2023	}
2024
2025
2026	/* Determine if a full array is the same as an array section with one
2027	variable limit. For this to be so, the strides must both be unity
2028	and one of either start == lower or end == upper must be true. */
2029
2030	static bool
2031	ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
2032	{
2033	int i;
2034	bool upper_or_lower;
2035
2036	if (full_ref->type != REF_ARRAY)
2037	return false;
2038	if (full_ref->u.ar.type != AR_FULL)
2039	return false;
2040	if (ref->type != REF_ARRAY)
2041	return false;
2042	if (ref->u.ar.type == AR_FULL)
2043	return true;
2044	if (ref->u.ar.type != AR_SECTION)
2045	return false;
2046
2047	for (i = 0; i < ref->u.ar.dimen; i++)
2048	{
2049	/* If we have a single element in the reference, we need to check
2050	that the array has a single element and that we actually reference
2051	the correct element. */
2052	if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
2053	{
2054	if (!full_ref->u.ar.as
2055	|| !full_ref->u.ar.as->lower[i]
2056	|| !full_ref->u.ar.as->upper[i]
2057	|| gfc_dep_compare_expr (e1: full_ref->u.ar.as->lower[i],
2058	e2: full_ref->u.ar.as->upper[i])
2059	|| !ref->u.ar.start[i]
2060	|| gfc_dep_compare_expr (e1: ref->u.ar.start[i],
2061	e2: full_ref->u.ar.as->lower[i]))
2062	return false;
2063	}
2064
2065	/* Check the strides. */
2066	if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (expr: full_ref->u.ar.stride[i], def: 0))
2067	return false;
2068	if (ref->u.ar.stride[i] && !gfc_expr_is_one (expr: ref->u.ar.stride[i], def: 0))
2069	return false;
2070
2071	upper_or_lower = false;
2072	/* Check the lower bound. */
2073	if (ref->u.ar.start[i]
2074	&& (ref->u.ar.as
2075	&& full_ref->u.ar.as->lower[i]
2076	&& gfc_dep_compare_expr (e1: ref->u.ar.start[i],
2077	e2: full_ref->u.ar.as->lower[i]) == 0))
2078	upper_or_lower = true;
2079	/* Check the upper bound. */
2080	if (ref->u.ar.end[i]
2081	&& (ref->u.ar.as
2082	&& full_ref->u.ar.as->upper[i]
2083	&& gfc_dep_compare_expr (e1: ref->u.ar.end[i],
2084	e2: full_ref->u.ar.as->upper[i]) == 0))
2085	upper_or_lower = true;
2086	if (!upper_or_lower)
2087	return false;
2088	}
2089	return true;
2090	}
2091
2092
2093	/* Finds if two array references are overlapping or not.
2094	Return value
2095	1 : array references are overlapping, or identical is true and
2096	there is some kind of overlap.
2097	0 : array references are identical or not overlapping. */
2098
2099	bool
2100	gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse,
2101	bool identical)
2102	{
2103	int n;
2104	int m;
2105	gfc_dependency fin_dep;
2106	gfc_dependency this_dep;
2107	bool same_component = false;
2108
2109	this_dep = GFC_DEP_ERROR;
2110	fin_dep = GFC_DEP_ERROR;
2111	/* Dependencies due to pointers should already have been identified.
2112	We only need to check for overlapping array references. */
2113
2114	while (lref && rref)
2115	{
2116	/* The refs might come in mixed, one with a _data component and one
2117	without. Look at their next reference in order to avoid an
2118	ICE. */
2119
2120	if (lref && lref->type == REF_COMPONENT && lref->u.c.component
2121	&& strcmp (s1: lref->u.c.component->name, s2: "_data") == 0)
2122	lref = lref->next;
2123
2124	if (rref && rref->type == REF_COMPONENT && rref->u.c.component
2125	&& strcmp (s1: rref->u.c.component->name, s2: "_data") == 0)
2126	rref = rref->next;
2127
2128	/* We're resolving from the same base symbol, so both refs should be
2129	the same type. We traverse the reference chain until we find ranges
2130	that are not equal. */
2131	gcc_assert (lref->type == rref->type);
2132	switch (lref->type)
2133	{
2134	case REF_COMPONENT:
2135	/* The two ranges can't overlap if they are from different
2136	components. */
2137	if (lref->u.c.component != rref->u.c.component)
2138	return 0;
2139
2140	same_component = true;
2141	break;
2142
2143	case REF_SUBSTRING:
2144	/* Substring overlaps are handled by the string assignment code
2145	if there is not an underlying dependency. */
2146	return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
2147
2148	case REF_ARRAY:
2149	/* Coarrays: If there is a coindex, either the image differs and there
2150	is no overlap or the image is the same - then the normal analysis
2151	applies. Hence, return early if either ref is coindexed and more
2152	than one image can exist. */
2153	if (flag_coarray != GFC_FCOARRAY_SINGLE
2154	&& ((lref->u.ar.codimen
2155	&& lref->u.ar.dimen_type[lref->u.ar.dimen]
2156	!= DIMEN_THIS_IMAGE)
2157	|| (rref->u.ar.codimen
2158	&& lref->u.ar.dimen_type[lref->u.ar.dimen]
2159	!= DIMEN_THIS_IMAGE)))
2160	return 1;
2161	if (lref->u.ar.dimen == 0 || rref->u.ar.dimen == 0)
2162	{
2163	/* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */
2164	if (lref->u.ar.dimen || rref->u.ar.dimen)
2165	return 1; /* Just to be sure. */
2166	fin_dep = GFC_DEP_EQUAL;
2167	break;
2168	}
2169
2170	if (ref_same_as_full_array (full_ref: lref, ref: rref))
2171	return identical;
2172
2173	if (ref_same_as_full_array (full_ref: rref, ref: lref))
2174	return identical;
2175
2176	if (lref->u.ar.dimen != rref->u.ar.dimen)
2177	{
2178	if (lref->u.ar.type == AR_FULL)
2179	fin_dep = gfc_full_array_ref_p (ref: rref, NULL) ? GFC_DEP_EQUAL
2180	: GFC_DEP_OVERLAP;
2181	else if (rref->u.ar.type == AR_FULL)
2182	fin_dep = gfc_full_array_ref_p (ref: lref, NULL) ? GFC_DEP_EQUAL
2183	: GFC_DEP_OVERLAP;
2184	else
2185	return 1;
2186	break;
2187	}
2188
2189	/* Index for the reverse array. */
2190	m = -1;
2191	for (n = 0; n < lref->u.ar.dimen; n++)
2192	{
2193	/* Handle dependency when either of array reference is vector
2194	subscript. There is no dependency if the vector indices
2195	are equal or if indices are known to be different in a
2196	different dimension. */
2197	if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2198	|| rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2199	{
2200	if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2201	&& rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2202	&& gfc_dep_compare_expr (e1: lref->u.ar.start[n],
2203	e2: rref->u.ar.start[n]) == 0)
2204	this_dep = GFC_DEP_EQUAL;
2205	else
2206	this_dep = GFC_DEP_OVERLAP;
2207
2208	goto update_fin_dep;
2209	}
2210
2211	if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2212	&& rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2213	this_dep = check_section_vs_section (l_ar: &lref->u.ar,
2214	r_ar: &rref->u.ar, n);
2215	else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2216	&& rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2217	this_dep = gfc_check_element_vs_section (lref, rref, n);
2218	else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2219	&& lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2220	this_dep = gfc_check_element_vs_section (lref: rref, rref: lref, n);
2221	else
2222	{
2223	gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2224	&& lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
2225	this_dep = gfc_check_element_vs_element (lref: rref, rref: lref, n);
2226	if (identical && this_dep == GFC_DEP_EQUAL)
2227	this_dep = GFC_DEP_OVERLAP;
2228	}
2229
2230	/* If any dimension doesn't overlap, we have no dependency. */
2231	if (this_dep == GFC_DEP_NODEP)
2232	return 0;
2233
2234	/* Now deal with the loop reversal logic: This only works on
2235	ranges and is activated by setting
2236	reverse[n] == GFC_ENABLE_REVERSE
2237	The ability to reverse or not is set by previous conditions
2238	in this dimension. If reversal is not activated, the
2239	value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2240
2241	/* Get the indexing right for the scalarizing loop. If this
2242	is an element, there is no corresponding loop. */
2243	if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2244	m++;
2245
2246	if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
2247	&& lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2248	{
2249	if (reverse)
2250	{
2251	/* Reverse if backward dependence and not inhibited. */
2252	if (reverse[m] == GFC_ENABLE_REVERSE
2253	&& this_dep == GFC_DEP_BACKWARD)
2254	reverse[m] = GFC_REVERSE_SET;
2255
2256	/* Forward if forward dependence and not inhibited. */
2257	if (reverse[m] == GFC_ENABLE_REVERSE
2258	&& this_dep == GFC_DEP_FORWARD)
2259	reverse[m] = GFC_FORWARD_SET;
2260
2261	/* Flag up overlap if dependence not compatible with
2262	the overall state of the expression. */
2263	if (reverse[m] == GFC_REVERSE_SET
2264	&& this_dep == GFC_DEP_FORWARD)
2265	{
2266	reverse[m] = GFC_INHIBIT_REVERSE;
2267	this_dep = GFC_DEP_OVERLAP;
2268	}
2269	else if (reverse[m] == GFC_FORWARD_SET
2270	&& this_dep == GFC_DEP_BACKWARD)
2271	{
2272	reverse[m] = GFC_INHIBIT_REVERSE;
2273	this_dep = GFC_DEP_OVERLAP;
2274	}
2275	}
2276
2277	/* If no intention of reversing or reversing is explicitly
2278	inhibited, convert backward dependence to overlap. */
2279	if ((!reverse && this_dep == GFC_DEP_BACKWARD)
2280	|| (reverse && reverse[m] == GFC_INHIBIT_REVERSE))
2281	this_dep = GFC_DEP_OVERLAP;
2282	}
2283
2284	/* Overlap codes are in order of priority. We only need to
2285	know the worst one.*/
2286
2287	update_fin_dep:
2288	if (identical && this_dep == GFC_DEP_EQUAL)
2289	this_dep = GFC_DEP_OVERLAP;
2290
2291	if (this_dep > fin_dep)
2292	fin_dep = this_dep;
2293	}
2294
2295	/* If this is an equal element, we have to keep going until we find
2296	the "real" array reference. */
2297	if (lref->u.ar.type == AR_ELEMENT
2298	&& rref->u.ar.type == AR_ELEMENT
2299	&& fin_dep == GFC_DEP_EQUAL)
2300	break;
2301
2302	/* Exactly matching and forward overlapping ranges don't cause a
2303	dependency. */
2304	if (fin_dep < GFC_DEP_BACKWARD && !identical)
2305	return 0;
2306
2307	/* Keep checking. We only have a dependency if
2308	subsequent references also overlap. */
2309	break;
2310
2311	case REF_INQUIRY:
2312	if (lref->u.i != rref->u.i)
2313	return 0;
2314
2315	break;
2316
2317	default:
2318	gcc_unreachable ();
2319	}
2320	lref = lref->next;
2321	rref = rref->next;
2322	}
2323
2324	/* Assume the worst if we nest to different depths. */
2325	if (lref || rref)
2326	return 1;
2327
2328	/* This can result from concatenation of assumed length string components. */
2329	if (same_component && fin_dep == GFC_DEP_ERROR)
2330	return 1;
2331
2332	/* If we haven't seen any array refs then something went wrong. */
2333	gcc_assert (fin_dep != GFC_DEP_ERROR);
2334
2335	if (identical && fin_dep != GFC_DEP_NODEP)
2336	return 1;
2337
2338	return fin_dep == GFC_DEP_OVERLAP;
2339	}
2340