Branch data Line data Source code
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 : 2988 : gfc_expr_is_one (gfc_expr *expr, int def)
63 : : {
64 : 2988 : gcc_assert (expr != NULL);
65 : :
66 : 2988 : if (expr->expr_type != EXPR_CONSTANT)
67 : : return def;
68 : :
69 : 2625 : if (expr->ts.type != BT_INTEGER)
70 : : return def;
71 : :
72 : 2625 : 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 : 1871 : identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
80 : : {
81 : 1871 : int i;
82 : :
83 : 1871 : if (a1->type == AR_FULL && a2->type == AR_FULL)
84 : : return true;
85 : :
86 : 475 : if (a1->type == AR_SECTION && a2->type == AR_SECTION)
87 : : {
88 : 83 : gcc_assert (a1->dimen == a2->dimen);
89 : :
90 : 161 : for ( i = 0; i < a1->dimen; i++)
91 : : {
92 : : /* TODO: Currently, we punt on an integer array as an index. */
93 : 119 : if (a1->dimen_type[i] != DIMEN_RANGE
94 : 101 : || a2->dimen_type[i] != DIMEN_RANGE)
95 : : return false;
96 : :
97 : 101 : if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
98 : : return false;
99 : : }
100 : : return true;
101 : : }
102 : :
103 : 392 : if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
104 : : {
105 : 368 : if (a1->dimen != a2->dimen)
106 : 0 : gfc_internal_error ("identical_array_ref(): inconsistent dimensions");
107 : :
108 : 517 : for (i = 0; i < a1->dimen; i++)
109 : : {
110 : 384 : 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 : 29672 : are_identical_variables (gfc_expr *e1, gfc_expr *e2)
125 : : {
126 : 29672 : gfc_ref *r1, *r2;
127 : :
128 : 29672 : if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
129 : : {
130 : : /* Dummy arguments: Only check for equal names. */
131 : 8027 : if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
132 : : return false;
133 : : }
134 : : else
135 : : {
136 : : /* Check for equal symbols. */
137 : 21645 : 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 : 10764 : if (e1->symtree->n.sym->attr.volatile_)
144 : : return false;
145 : :
146 : 10563 : r1 = e1->ref;
147 : 10563 : r2 = e2->ref;
148 : :
149 : 12420 : 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 : 2610 : if (r1 == NULL || r2 == NULL)
158 : : return false;
159 : :
160 : 2558 : if (r1->type != r2->type)
161 : : return false;
162 : :
163 : 2516 : switch (r1->type)
164 : : {
165 : :
166 : 1871 : case REF_ARRAY:
167 : 1871 : if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
168 : : return false;
169 : :
170 : : break;
171 : :
172 : 524 : case REF_COMPONENT:
173 : 524 : if (r1->u.c.component != r2->u.c.component)
174 : : return false;
175 : : break;
176 : :
177 : 121 : case REF_SUBSTRING:
178 : 121 : 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 : 71 : if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
186 : : break;
187 : :
188 : 70 : if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
189 : : return false;
190 : :
191 : : break;
192 : :
193 : 0 : case REF_INQUIRY:
194 : 0 : if (r1->u.i != r2->u.i)
195 : : return false;
196 : : break;
197 : :
198 : 0 : default:
199 : 0 : gfc_internal_error ("are_identical_variables: Bad type");
200 : : }
201 : 1857 : r1 = r1->next;
202 : 1857 : 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 : 28304 : gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
212 : : {
213 : :
214 : 28304 : gfc_actual_arglist *args1;
215 : 28304 : gfc_actual_arglist *args2;
216 : :
217 : 28304 : if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
218 : : return -2;
219 : :
220 : 27850 : if ((e1->value.function.esym && e2->value.function.esym
221 : 2765 : && e1->value.function.esym == e2->value.function.esym
222 : 558 : && (e1->value.function.esym->result->attr.pure || impure_ok))
223 : 27439 : || (e1->value.function.isym && e2->value.function.isym
224 : 23424 : && e1->value.function.isym == e2->value.function.isym
225 : 9555 : && (e1->value.function.isym->pure || impure_ok)))
226 : : {
227 : 9931 : args1 = e1->value.function.actual;
228 : 9931 : args2 = e2->value.function.actual;
229 : :
230 : : /* Compare the argument lists for equality. */
231 : 12595 : while (args1 && args2)
232 : : {
233 : : /* Bitwise xor, since C has no non-bitwise xor operator. */
234 : 11537 : if ((args1->expr == NULL) ^ (args2->expr == NULL))
235 : : return -2;
236 : :
237 : 11380 : if (args1->expr != NULL && args2->expr != NULL)
238 : : {
239 : 10707 : gfc_expr *e1, *e2;
240 : 10707 : e1 = args1->expr;
241 : 10707 : e2 = args2->expr;
242 : :
243 : 10707 : 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 : 1997 : if (e1->expr_type == EXPR_CONSTANT
251 : 259 : && e1->ts.type == BT_CHARACTER
252 : 7 : && e2->expr_type == EXPR_CONSTANT
253 : 7 : && e2->ts.type == BT_CHARACTER
254 : 7 : && e1->value.character.length != e2->value.character.length)
255 : : return -2;
256 : : }
257 : :
258 : 2664 : args1 = args1->next;
259 : 2664 : args2 = args2->next;
260 : : }
261 : 2116 : 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 : 441248 : gfc_discard_nops (gfc_expr *e)
272 : : {
273 : 441248 : gfc_actual_arglist *arglist;
274 : :
275 : 441248 : if (e == NULL)
276 : : return NULL;
277 : :
278 : 450607 : while (true)
279 : : {
280 : 450607 : if (e->expr_type == EXPR_OP
281 : 23767 : && (e->value.op.op == INTRINSIC_UPLUS
282 : 23767 : || e->value.op.op == INTRINSIC_PARENTHESES))
283 : : {
284 : 1227 : e = e->value.op.op1;
285 : 1227 : continue;
286 : : }
287 : :
288 : 449380 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
289 : 43354 : && e->value.function.isym->id == GFC_ISYM_CONVERSION
290 : 8921 : && e->ts.type == BT_INTEGER)
291 : : {
292 : 8842 : arglist = e->value.function.actual;
293 : 8842 : if (arglist->expr->ts.type == BT_INTEGER
294 : 8828 : && e->ts.kind > arglist->expr->ts.kind)
295 : : {
296 : 8132 : e = arglist->expr;
297 : 8132 : 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 : 173347 : gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
318 : : {
319 : 173347 : int i;
320 : :
321 : 173347 : if (e1 == NULL && e2 == NULL)
322 : : return 0;
323 : 173345 : else if (e1 == NULL || e2 == NULL)
324 : : return -2;
325 : :
326 : 173344 : e1 = gfc_discard_nops (e1);
327 : 173344 : e2 = gfc_discard_nops (e2);
328 : :
329 : 173344 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
330 : : {
331 : : /* Compare X+C vs. X, for INTEGER only. */
332 : 3989 : if (e1->value.op.op2->expr_type == EXPR_CONSTANT
333 : 1473 : && e1->value.op.op2->ts.type == BT_INTEGER
334 : 5446 : && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
335 : 202 : return mpz_sgn (e1->value.op.op2->value.integer);
336 : :
337 : : /* Compare P+Q vs. R+S. */
338 : 3787 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
339 : : {
340 : 845 : int l, r;
341 : :
342 : 845 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
343 : 845 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
344 : 845 : if (l == 0 && r == 0)
345 : : return 0;
346 : 289 : if (l == 0 && r > -2)
347 : : return r;
348 : 258 : if (l > -2 && r == 0)
349 : : return l;
350 : 257 : if (l == 1 && r == 1)
351 : : return 1;
352 : 257 : if (l == -1 && r == -1)
353 : : return -1;
354 : :
355 : 257 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
356 : 257 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
357 : 257 : if (l == 0 && r == 0)
358 : : return 0;
359 : 253 : if (l == 0 && r > -2)
360 : : return r;
361 : 253 : if (l > -2 && r == 0)
362 : : return l;
363 : 253 : if (l == 1 && r == 1)
364 : : return 1;
365 : 253 : if (l == -1 && r == -1)
366 : : return -1;
367 : : }
368 : : }
369 : :
370 : : /* Compare X vs. X+C, for INTEGER only. */
371 : 172550 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
372 : : {
373 : 3622 : if (e2->value.op.op2->expr_type == EXPR_CONSTANT
374 : 1988 : && e2->value.op.op2->ts.type == BT_INTEGER
375 : 5610 : && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
376 : 775 : return -mpz_sgn (e2->value.op.op2->value.integer);
377 : : }
378 : :
379 : : /* Compare X-C vs. X, for INTEGER only. */
380 : 171775 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
381 : : {
382 : 2136 : if (e1->value.op.op2->expr_type == EXPR_CONSTANT
383 : 1711 : && e1->value.op.op2->ts.type == BT_INTEGER
384 : 3835 : && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
385 : 80 : return -mpz_sgn (e1->value.op.op2->value.integer);
386 : :
387 : : /* Compare P-Q vs. R-S. */
388 : 2056 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
389 : : {
390 : 874 : int l, r;
391 : :
392 : 874 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
393 : 874 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
394 : 874 : if (l == 0 && r == 0)
395 : : return 0;
396 : 178 : if (l > -2 && r == 0)
397 : : return l;
398 : 177 : if (l == 0 && r > -2)
399 : 6 : return -r;
400 : 171 : if (l == 1 && r == -1)
401 : : return 1;
402 : 171 : if (l == -1 && r == 1)
403 : : return -1;
404 : : }
405 : : }
406 : :
407 : : /* Compare A // B vs. C // D. */
408 : :
409 : 170992 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
410 : 121 : && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
411 : : {
412 : 90 : int l, r;
413 : :
414 : 90 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
415 : 90 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
416 : :
417 : 90 : if (l != 0)
418 : : return l;
419 : :
420 : : /* Left expressions of // compare equal, but
421 : : watch out for 'A ' // x vs. 'A' // x. */
422 : 72 : gfc_expr *e1_left = e1->value.op.op1;
423 : 72 : gfc_expr *e2_left = e2->value.op.op1;
424 : :
425 : 72 : if (e1_left->expr_type == EXPR_CONSTANT
426 : 36 : && e2_left->expr_type == EXPR_CONSTANT
427 : 36 : && e1_left->value.character.length
428 : 36 : != 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 : 170902 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
436 : : {
437 : 3465 : if (e2->value.op.op2->expr_type == EXPR_CONSTANT
438 : 2631 : && e2->value.op.op2->ts.type == BT_INTEGER
439 : 6070 : && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
440 : 1973 : return mpz_sgn (e2->value.op.op2->value.integer);
441 : : }
442 : :
443 : 168929 : if (e1->expr_type != e2->expr_type)
444 : : return -3;
445 : :
446 : 62370 : switch (e1->expr_type)
447 : : {
448 : 27664 : case EXPR_CONSTANT:
449 : : /* Compare strings for equality. */
450 : 27664 : if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
451 : 122 : 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 : 27542 : if (e2->expr_type == EXPR_CONSTANT)
457 : : {
458 : 27542 : if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
459 : : {
460 : 34 : if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
461 : : return 0;
462 : : else
463 : : return -2;
464 : : }
465 : 27508 : else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
466 : : {
467 : 5 : if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
468 : : return 0;
469 : : else
470 : : return -2;
471 : : }
472 : : }
473 : :
474 : 27503 : 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 : 27488 : gcc_assert (e2->expr_type == EXPR_CONSTANT);
480 : :
481 : 27488 : i = mpz_cmp (e1->value.integer, e2->value.integer);
482 : 27488 : if (i == 0)
483 : : return 0;
484 : 15734 : else if (i < 0)
485 : : return -1;
486 : : return 1;
487 : :
488 : 29672 : case EXPR_VARIABLE:
489 : 29672 : if (are_identical_variables (e1, e2))
490 : : return 0;
491 : : else
492 : : return -3;
493 : :
494 : 1865 : case EXPR_OP:
495 : : /* Intrinsic operators are the same if their operands are the same. */
496 : 1865 : if (e1->value.op.op != e2->value.op.op)
497 : : return -2;
498 : 1572 : if (e1->value.op.op2 == 0)
499 : : {
500 : 29 : i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
501 : 58 : return i == 0 ? 0 : -2;
502 : : }
503 : 1543 : if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
504 : 1543 : && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
505 : : return 0;
506 : 1235 : else if (e1->value.op.op == INTRINSIC_TIMES
507 : 218 : && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
508 : 1381 : && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
509 : : /* Commutativity of multiplication; addition is handled above. */
510 : : return 0;
511 : :
512 : : return -2;
513 : :
514 : 2921 : case EXPR_FUNCTION:
515 : 2921 : return gfc_dep_compare_functions (e1, e2, 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 : 78426 : gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
534 : : {
535 : 78426 : gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
536 : :
537 : 78426 : if (e1 == NULL || e2 == NULL)
538 : : return false;
539 : :
540 : 44110 : if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
541 : : return false;
542 : :
543 : 44109 : e1 = gfc_discard_nops (e1);
544 : 44109 : e2 = gfc_discard_nops (e2);
545 : :
546 : : /* Initialize tentatively, clear if we don't return anything. */
547 : 44109 : mpz_init (*result);
548 : :
549 : : /* Case 1: c1 - c2 = c1 - c2, trivially. */
550 : :
551 : 44109 : if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
552 : : {
553 : 35213 : mpz_sub (*result, e1->value.integer, e2->value.integer);
554 : 35213 : return true;
555 : : }
556 : :
557 : 8896 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
558 : : {
559 : 831 : e1_op1 = gfc_discard_nops (e1->value.op.op1);
560 : 831 : e1_op2 = gfc_discard_nops (e1->value.op.op2);
561 : :
562 : : /* Case 2: (X + c1) - X = c1. */
563 : 831 : if (e1_op2->expr_type == EXPR_CONSTANT
564 : 831 : && gfc_dep_compare_expr (e1_op1, e2) == 0)
565 : : {
566 : 237 : mpz_set (*result, e1_op2->value.integer);
567 : 237 : return true;
568 : : }
569 : :
570 : : /* Case 3: (c1 + X) - X = c1. */
571 : 594 : if (e1_op1->expr_type == EXPR_CONSTANT
572 : 594 : && gfc_dep_compare_expr (e1_op2, e2) == 0)
573 : : {
574 : 6 : mpz_set (*result, e1_op1->value.integer);
575 : 6 : return true;
576 : : }
577 : :
578 : 588 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
579 : : {
580 : 251 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
581 : 251 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
582 : :
583 : 251 : if (e1_op2->expr_type == EXPR_CONSTANT)
584 : : {
585 : : /* Case 4: X + c1 - (X + c2) = c1 - c2. */
586 : 168 : if (e2_op2->expr_type == EXPR_CONSTANT
587 : 168 : && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
588 : : {
589 : 128 : mpz_sub (*result, e1_op2->value.integer,
590 : 128 : e2_op2->value.integer);
591 : 128 : return true;
592 : : }
593 : : /* Case 5: X + c1 - (c2 + X) = c1 - c2. */
594 : 40 : if (e2_op1->expr_type == EXPR_CONSTANT
595 : 40 : && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
596 : : {
597 : 6 : mpz_sub (*result, e1_op2->value.integer,
598 : 6 : e2_op1->value.integer);
599 : 6 : return true;
600 : : }
601 : : }
602 : 83 : else if (e1_op1->expr_type == EXPR_CONSTANT)
603 : : {
604 : : /* Case 6: c1 + X - (X + c2) = c1 - c2. */
605 : 12 : if (e2_op2->expr_type == EXPR_CONSTANT
606 : 12 : && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
607 : : {
608 : 6 : mpz_sub (*result, e1_op1->value.integer,
609 : 6 : e2_op2->value.integer);
610 : 6 : return true;
611 : : }
612 : : /* Case 7: c1 + X - (c2 + X) = c1 - c2. */
613 : 6 : if (e2_op1->expr_type == EXPR_CONSTANT
614 : 6 : && gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
615 : : {
616 : 6 : mpz_sub (*result, e1_op1->value.integer,
617 : 6 : e2_op1->value.integer);
618 : 6 : return true;
619 : : }
620 : : }
621 : : }
622 : :
623 : 442 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
624 : : {
625 : 20 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
626 : 20 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
627 : :
628 : 20 : if (e1_op2->expr_type == EXPR_CONSTANT)
629 : : {
630 : : /* Case 8: X + c1 - (X - c2) = c1 + c2. */
631 : 14 : if (e2_op2->expr_type == EXPR_CONSTANT
632 : 14 : && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
633 : : {
634 : 12 : mpz_add (*result, e1_op2->value.integer,
635 : 12 : e2_op2->value.integer);
636 : 12 : return true;
637 : : }
638 : : }
639 : 8 : if (e1_op1->expr_type == EXPR_CONSTANT)
640 : : {
641 : : /* Case 9: c1 + X - (X - c2) = c1 + c2. */
642 : 6 : if (e2_op2->expr_type == EXPR_CONSTANT
643 : 6 : && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
644 : : {
645 : 6 : mpz_add (*result, e1_op1->value.integer,
646 : 6 : e2_op2->value.integer);
647 : 6 : return true;
648 : : }
649 : : }
650 : : }
651 : : }
652 : :
653 : 8489 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
654 : : {
655 : 801 : e1_op1 = gfc_discard_nops (e1->value.op.op1);
656 : 801 : e1_op2 = gfc_discard_nops (e1->value.op.op2);
657 : :
658 : 801 : if (e1_op2->expr_type == EXPR_CONSTANT)
659 : : {
660 : : /* Case 10: (X - c1) - X = -c1 */
661 : :
662 : 757 : if (gfc_dep_compare_expr (e1_op1, e2) == 0)
663 : : {
664 : 6 : mpz_neg (*result, e1_op2->value.integer);
665 : 6 : return true;
666 : : }
667 : :
668 : 751 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
669 : : {
670 : 33 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
671 : 33 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
672 : :
673 : : /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
674 : 33 : if (e2_op2->expr_type == EXPR_CONSTANT
675 : 33 : && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
676 : : {
677 : 12 : mpz_add (*result, e1_op2->value.integer,
678 : 12 : e2_op2->value.integer);
679 : 12 : mpz_neg (*result, *result);
680 : 12 : return true;
681 : : }
682 : :
683 : : /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */
684 : 21 : if (e2_op1->expr_type == EXPR_CONSTANT
685 : 21 : && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
686 : : {
687 : 0 : mpz_add (*result, e1_op2->value.integer,
688 : 0 : e2_op1->value.integer);
689 : 0 : mpz_neg (*result, *result);
690 : 0 : return true;
691 : : }
692 : : }
693 : :
694 : 739 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
695 : : {
696 : 22 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
697 : 22 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
698 : :
699 : : /* Case 13: (X - c1) - (X - c2) = c2 - c1. */
700 : 22 : if (e2_op2->expr_type == EXPR_CONSTANT
701 : 22 : && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
702 : : {
703 : 6 : mpz_sub (*result, e2_op2->value.integer,
704 : 6 : e1_op2->value.integer);
705 : 6 : return true;
706 : : }
707 : : }
708 : : }
709 : 777 : if (e1_op1->expr_type == EXPR_CONSTANT)
710 : : {
711 : 8 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
712 : : {
713 : 6 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
714 : 6 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
715 : :
716 : : /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
717 : 6 : if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
718 : : {
719 : 6 : mpz_sub (*result, e1_op1->value.integer,
720 : 6 : e2_op1->value.integer);
721 : 6 : return true;
722 : : }
723 : : }
724 : :
725 : : }
726 : : }
727 : :
728 : 8459 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
729 : : {
730 : 251 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
731 : 251 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
732 : :
733 : : /* Case 15: X - (X + c2) = -c2. */
734 : 251 : if (e2_op2->expr_type == EXPR_CONSTANT
735 : 251 : && gfc_dep_compare_expr (e1, e2_op1) == 0)
736 : : {
737 : 12 : mpz_neg (*result, e2_op2->value.integer);
738 : 12 : return true;
739 : : }
740 : : /* Case 16: X - (c2 + X) = -c2. */
741 : 239 : if (e2_op1->expr_type == EXPR_CONSTANT
742 : 239 : && gfc_dep_compare_expr (e1, e2_op2) == 0)
743 : : {
744 : 6 : mpz_neg (*result, e2_op1->value.integer);
745 : 6 : return true;
746 : : }
747 : : }
748 : :
749 : 8441 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
750 : : {
751 : 118 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
752 : 118 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
753 : :
754 : : /* Case 17: X - (X - c2) = c2. */
755 : 118 : if (e2_op2->expr_type == EXPR_CONSTANT
756 : 118 : && gfc_dep_compare_expr (e1, e2_op1) == 0)
757 : : {
758 : 55 : mpz_set (*result, e2_op2->value.integer);
759 : 55 : return true;
760 : : }
761 : : }
762 : :
763 : 8386 : if (gfc_dep_compare_expr (e1, e2) == 0)
764 : : {
765 : : /* Case 18: X - X = 0. */
766 : 1560 : mpz_set_si (*result, 0);
767 : 1560 : return true;
768 : : }
769 : :
770 : 6826 : mpz_clear (*result);
771 : 6826 : 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 : 2162 : is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
779 : : {
780 : 2162 : gfc_expr *e1;
781 : 2162 : gfc_expr *e2;
782 : 2162 : int i;
783 : :
784 : : /* TODO: More sophisticated range comparison. */
785 : 2162 : gcc_assert (ar1 && ar2);
786 : :
787 : 2162 : gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
788 : :
789 : 2162 : e1 = ar1->stride[n];
790 : 2162 : e2 = ar2->stride[n];
791 : : /* Check for mismatching strides. A NULL stride means a stride of 1. */
792 : 2162 : if (e1 && !e2)
793 : : {
794 : 63 : i = gfc_expr_is_one (e1, -1);
795 : 63 : if (i == -1 || i == 0)
796 : : return 0;
797 : : }
798 : 2099 : else if (e2 && !e1)
799 : : {
800 : 201 : i = gfc_expr_is_one (e2, -1);
801 : 201 : if (i == -1 || i == 0)
802 : : return 0;
803 : : }
804 : 1898 : else if (e1 && e2)
805 : : {
806 : 238 : i = gfc_dep_compare_expr (e1, e2);
807 : 238 : if (i != 0)
808 : : return 0;
809 : : }
810 : : /* The strides match. */
811 : :
812 : : /* Check the range start. */
813 : 1793 : e1 = ar1->start[n];
814 : 1793 : e2 = ar2->start[n];
815 : 1793 : if (e1 || e2)
816 : : {
817 : : /* Use the bound of the array if no bound is specified. */
818 : 1005 : if (ar1->as && !e1)
819 : 35 : e1 = ar1->as->lower[n];
820 : :
821 : 1005 : if (ar2->as && !e2)
822 : 34 : e2 = ar2->as->lower[n];
823 : :
824 : : /* Check we have values for both. */
825 : 1005 : if (!(e1 && e2))
826 : : return 0;
827 : :
828 : 969 : i = gfc_dep_compare_expr (e1, e2);
829 : 969 : if (i != 0)
830 : : return 0;
831 : : }
832 : :
833 : : /* Check the range end. */
834 : 1188 : e1 = ar1->end[n];
835 : 1188 : e2 = ar2->end[n];
836 : 1188 : if (e1 || e2)
837 : : {
838 : : /* Use the bound of the array if no bound is specified. */
839 : 442 : if (ar1->as && !e1)
840 : 11 : e1 = ar1->as->upper[n];
841 : :
842 : 442 : if (ar2->as && !e2)
843 : 0 : e2 = ar2->as->upper[n];
844 : :
845 : : /* Check we have values for both. */
846 : 442 : if (!(e1 && e2))
847 : : return 0;
848 : :
849 : 442 : i = gfc_dep_compare_expr (e1, e2);
850 : 442 : 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 : 223373 : gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
869 : : {
870 : 223373 : if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
871 : : return NULL;
872 : :
873 : 37392 : switch (expr->value.function.isym->id)
874 : : {
875 : 1729 : case GFC_ISYM_TRANSPOSE:
876 : 1729 : 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 : 122938 : gfc_ref_needs_temporary_p (gfc_ref *ref)
889 : : {
890 : 122938 : int n;
891 : 122938 : bool subarray_p;
892 : :
893 : 122938 : subarray_p = false;
894 : 263225 : for (; ref; ref = ref->next)
895 : 140749 : switch (ref->type)
896 : : {
897 : 123526 : case REF_ARRAY:
898 : : /* Vector dimensions are generally not monotonic and must be
899 : : handled using a temporary. */
900 : 123526 : if (ref->u.ar.type == AR_SECTION)
901 : 50616 : for (n = 0; n < ref->u.ar.dimen; n++)
902 : 30050 : 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 : 44 : gfc_is_data_pointer (gfc_expr *e)
926 : : {
927 : 44 : gfc_ref *ref;
928 : :
929 : 44 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
930 : : return 0;
931 : :
932 : : /* No subreference if it is a function */
933 : 44 : gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
934 : :
935 : 44 : if (e->symtree->n.sym->attr.pointer)
936 : : return 1;
937 : :
938 : 82 : for (ref = e->ref; ref; ref = ref->next)
939 : 42 : 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 : 10565 : gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
956 : : gfc_expr *expr, gfc_dep_check elemental)
957 : : {
958 : 10740 : gfc_expr *arg;
959 : :
960 : 10740 : gcc_assert (var->expr_type == EXPR_VARIABLE);
961 : 10740 : gcc_assert (var->rank > 0);
962 : :
963 : 10740 : switch (expr->expr_type)
964 : : {
965 : 6715 : case EXPR_VARIABLE:
966 : : /* In case of elemental subroutines, there is no dependency
967 : : between two same-range array references. */
968 : 6715 : if (gfc_ref_needs_temporary_p (expr->ref)
969 : 6715 : || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
970 : : {
971 : 617 : if (elemental == ELEM_DONT_CHECK_VARIABLE)
972 : : {
973 : : /* Too many false positive with pointers. */
974 : 24 : if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
975 : : {
976 : : /* Elemental procedures forbid unspecified intents,
977 : : and we don't check dependencies for INTENT_IN args. */
978 : 20 : 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 : 20 : if (var->expr_type == EXPR_VARIABLE
987 : 20 : && expr->expr_type == EXPR_VARIABLE
988 : 20 : && strcmp(var->symtree->name, expr->symtree->name) == 0)
989 : 18 : gfc_warning (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 : 24 : 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 : 807 : case EXPR_FUNCTION:
1007 : 807 : if (intent != INTENT_IN)
1008 : : {
1009 : 803 : arg = gfc_get_noncopying_intrinsic_argument (expr);
1010 : 803 : if (arg != NULL)
1011 : : return gfc_check_argument_var_dependency (var, intent, arg,
1012 : : NOT_ELEMENTAL);
1013 : : }
1014 : :
1015 : 632 : if (elemental != NOT_ELEMENTAL)
1016 : : {
1017 : 128 : if ((expr->value.function.esym
1018 : 82 : && expr->value.function.esym->attr.elemental)
1019 : 58 : || (expr->value.function.isym
1020 : 46 : && expr->value.function.isym->elemental))
1021 : 76 : return gfc_check_fncall_dependency (var, intent, NULL,
1022 : : expr->value.function.actual,
1023 : 76 : ELEM_CHECK_VARIABLE);
1024 : :
1025 : 52 : if (gfc_inline_intrinsic_function_p (expr))
1026 : : {
1027 : : /* The TRANSPOSE case should have been caught in the
1028 : : noncopying intrinsic case above. */
1029 : 24 : gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
1030 : :
1031 : 24 : return gfc_check_fncall_dependency (var, intent, NULL,
1032 : : expr->value.function.actual,
1033 : 24 : ELEM_CHECK_VARIABLE);
1034 : : }
1035 : : }
1036 : : return 0;
1037 : :
1038 : 96 : 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 : 96 : 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 : 42 : if (expr->value.op.op1
1047 : 42 : && gfc_check_argument_var_dependency (var, intent,
1048 : : expr->value.op.op1,
1049 : : ELEM_CHECK_VARIABLE))
1050 : : return 1;
1051 : 24 : else if (expr->value.op.op2
1052 : 24 : && gfc_check_argument_var_dependency (var, intent,
1053 : : expr->value.op.op2,
1054 : : 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 : 10511 : gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
1070 : : gfc_expr *expr, gfc_dep_check elemental)
1071 : : {
1072 : 10597 : switch (other->expr_type)
1073 : : {
1074 : 10511 : case EXPR_VARIABLE:
1075 : 10511 : return gfc_check_argument_var_dependency (other, intent, expr, elemental);
1076 : :
1077 : 86 : case EXPR_FUNCTION:
1078 : 86 : other = gfc_get_noncopying_intrinsic_argument (other);
1079 : 86 : if (other != NULL)
1080 : : return gfc_check_argument_dependency (other, INTENT_IN, expr,
1081 : : 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 : 5764 : 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 : 5764 : gfc_formal_arglist *formal;
1100 : 5764 : gfc_expr *expr;
1101 : :
1102 : 5764 : formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
1103 : 34380 : for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
1104 : : {
1105 : 14943 : expr = actual->expr;
1106 : :
1107 : : /* Skip args which are not present. */
1108 : 14943 : if (!expr)
1109 : 2771 : continue;
1110 : :
1111 : : /* Skip other itself. */
1112 : 12172 : if (expr == other)
1113 : 1423 : continue;
1114 : :
1115 : : /* Skip intent(in) arguments if OTHER itself is intent(in). */
1116 : 10749 : if (formal && intent == INTENT_IN
1117 : 270 : && formal->sym->attr.intent == INTENT_IN)
1118 : 238 : continue;
1119 : :
1120 : 10511 : 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 : 47007 : gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
1142 : : {
1143 : 47007 : gfc_equiv_list *l;
1144 : 47007 : gfc_equiv_info *s, *fl1, *fl2;
1145 : :
1146 : 47007 : gcc_assert (e1->expr_type == EXPR_VARIABLE
1147 : : && e2->expr_type == EXPR_VARIABLE);
1148 : :
1149 : 47007 : if (!e1->symtree->n.sym->attr.in_equivalence
1150 : 440 : || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
1151 : : return 0;
1152 : :
1153 : 240 : if (e1->symtree->n.sym->ns
1154 : 240 : && e1->symtree->n.sym->ns != gfc_current_ns)
1155 : 6 : l = e1->symtree->n.sym->ns->equiv_lists;
1156 : : else
1157 : 234 : 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 : 1788 : for (; l; l = l->next)
1163 : : {
1164 : 1702 : fl1 = NULL;
1165 : 1702 : fl2 = NULL;
1166 : 3551 : for (s = l->equiv; s; s = s->next)
1167 : : {
1168 : 2003 : if (s->sym == e1->symtree->n.sym)
1169 : : {
1170 : 163 : fl1 = s;
1171 : 163 : if (fl2)
1172 : : break;
1173 : : }
1174 : 1979 : if (s->sym == e2->symtree->n.sym)
1175 : : {
1176 : 163 : fl2 = s;
1177 : 163 : if (fl1)
1178 : : break;
1179 : : }
1180 : : }
1181 : :
1182 : 1702 : if (s)
1183 : : {
1184 : : /* Can these lengths be zero? */
1185 : 154 : 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 : 154 : if (fl1->offset + fl1->length > fl2->offset
1191 : 154 : && 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 : 461 : check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
1206 : : {
1207 : 461 : gfc_component *cm1;
1208 : 461 : gfc_symbol *sym1;
1209 : 461 : gfc_symbol *sym2;
1210 : 461 : gfc_ref *ref1;
1211 : 461 : bool seen_component_ref;
1212 : :
1213 : 461 : if (expr1->expr_type != EXPR_VARIABLE
1214 : 461 : || expr2->expr_type != EXPR_VARIABLE)
1215 : : return false;
1216 : :
1217 : 461 : sym1 = expr1->symtree->n.sym;
1218 : 461 : sym2 = expr2->symtree->n.sym;
1219 : :
1220 : : /* Keep it simple for now. */
1221 : 461 : if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
1222 : : return false;
1223 : :
1224 : 389 : if (sym1->attr.pointer)
1225 : : {
1226 : 227 : 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 : 186 : seen_component_ref = false;
1236 : 186 : if (sym1->ts.type == BT_DERIVED)
1237 : : {
1238 : 87 : for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
1239 : : {
1240 : 72 : if (ref1->type != REF_COMPONENT)
1241 : 26 : continue;
1242 : :
1243 : 46 : if (ref1->u.c.component->ts.type == BT_DERIVED)
1244 : : return false;
1245 : :
1246 : 21 : if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
1247 : 47 : && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
1248 : : return false;
1249 : :
1250 : : seen_component_ref = true;
1251 : : }
1252 : : }
1253 : :
1254 : 155 : if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
1255 : : {
1256 : 0 : for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
1257 : : {
1258 : 0 : if (cm1->ts.type == BT_DERIVED)
1259 : : return false;
1260 : :
1261 : 0 : if ((sym2->attr.pointer || cm1->attr.pointer)
1262 : 0 : && 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 : 99920 : gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1281 : : {
1282 : 99920 : gfc_actual_arglist *actual;
1283 : 99920 : gfc_constructor *c;
1284 : 99920 : 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 : 99920 : if (expr1->expr_type == EXPR_FUNCTION
1289 : 0 : && strcmp (expr1->value.function.name, "_F.caf_get") == 0)
1290 : : return 0;
1291 : :
1292 : 99920 : if (expr1->expr_type != EXPR_VARIABLE)
1293 : 0 : gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
1294 : :
1295 : : /* Prevent NULL pointer dereference while recursively analyzing invalid
1296 : : expressions. */
1297 : 99920 : if (expr2 == NULL)
1298 : : return 0;
1299 : :
1300 : 99919 : switch (expr2->expr_type)
1301 : : {
1302 : 8486 : case EXPR_OP:
1303 : 8486 : n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1304 : 8486 : if (n)
1305 : : return n;
1306 : 7321 : if (expr2->value.op.op2)
1307 : 6957 : return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1308 : : return 0;
1309 : :
1310 : 44513 : case EXPR_VARIABLE:
1311 : : /* The interesting cases are when the symbols don't match. */
1312 : 44513 : if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1313 : : {
1314 : 39199 : symbol_attribute attr1, attr2;
1315 : 39199 : gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1316 : 39199 : gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1317 : :
1318 : : /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1319 : 39199 : if (gfc_are_equivalenced_arrays (expr1, expr2))
1320 : : return 1;
1321 : :
1322 : : /* Symbols can only alias if they have the same type. */
1323 : 39123 : if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1324 : 39123 : && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1325 : : {
1326 : 33136 : 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 : 32532 : attr1 = gfc_expr_attr (expr1);
1335 : 32532 : attr2 = gfc_expr_attr (expr2);
1336 : 32532 : if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target))
1337 : : {
1338 : 362 : if (check_data_pointer_types (expr1, expr2)
1339 : 362 : && check_data_pointer_types (expr2, expr1))
1340 : : return 0;
1341 : :
1342 : 306 : return 1;
1343 : : }
1344 : : else
1345 : : {
1346 : 32170 : gfc_symbol *sym1 = expr1->symtree->n.sym;
1347 : 32170 : gfc_symbol *sym2 = expr2->symtree->n.sym;
1348 : 32170 : if (sym1->attr.target && sym2->attr.target
1349 : 0 : && ((sym1->attr.dummy && !sym1->attr.contiguous
1350 : 0 : && (!sym1->attr.dimension
1351 : 0 : || sym2->as->type == AS_ASSUMED_SHAPE))
1352 : 0 : || (sym2->attr.dummy && !sym2->attr.contiguous
1353 : 0 : && (!sym2->attr.dimension
1354 : 0 : || 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 : 5314 : if (expr1->ref && expr2->ref)
1365 : 5242 : return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical);
1366 : :
1367 : : return 1;
1368 : :
1369 : 13401 : case EXPR_FUNCTION:
1370 : 13401 : if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1371 : 404 : identical = 1;
1372 : :
1373 : : /* Remember possible differences between elemental and
1374 : : transformational functions. All functions inside a FORALL
1375 : : will be pure. */
1376 : 13401 : for (actual = expr2->value.function.actual;
1377 : 44104 : actual; actual = actual->next)
1378 : : {
1379 : 32081 : if (!actual->expr)
1380 : 6496 : continue;
1381 : 25585 : n = gfc_check_dependency (expr1, actual->expr, identical);
1382 : 25585 : if (n)
1383 : 1378 : return n;
1384 : : }
1385 : : return 0;
1386 : :
1387 : : case EXPR_CONSTANT:
1388 : : case EXPR_NULL:
1389 : : return 0;
1390 : :
1391 : 10454 : case EXPR_ARRAY:
1392 : : /* Loop through the array constructor's elements. */
1393 : 10454 : for (c = gfc_constructor_first (expr2->value.constructor);
1394 : 79718 : c; c = gfc_constructor_next (c))
1395 : : {
1396 : : /* If this is an iterator, assume the worst. */
1397 : 70224 : if (c->iterator)
1398 : : return 1;
1399 : : /* Avoid recursion in the common case. */
1400 : 69674 : if (c->expr->expr_type == EXPR_CONSTANT)
1401 : 67795 : continue;
1402 : 1879 : if (gfc_check_dependency (expr1, c->expr, 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 : 2162 : check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1417 : : {
1418 : 2162 : gfc_expr *l_start;
1419 : 2162 : gfc_expr *l_end;
1420 : 2162 : gfc_expr *l_stride;
1421 : 2162 : gfc_expr *l_lower;
1422 : 2162 : gfc_expr *l_upper;
1423 : 2162 : int l_dir;
1424 : :
1425 : 2162 : gfc_expr *r_start;
1426 : 2162 : gfc_expr *r_end;
1427 : 2162 : gfc_expr *r_stride;
1428 : 2162 : gfc_expr *r_lower;
1429 : 2162 : gfc_expr *r_upper;
1430 : 2162 : gfc_expr *one_expr;
1431 : 2162 : int r_dir;
1432 : 2162 : int stride_comparison;
1433 : 2162 : int start_comparison;
1434 : 2162 : mpz_t tmp;
1435 : :
1436 : : /* If they are the same range, return without more ado. */
1437 : 2162 : if (is_same_range (l_ar, r_ar, n))
1438 : : return GFC_DEP_EQUAL;
1439 : :
1440 : 1007 : l_start = l_ar->start[n];
1441 : 1007 : l_end = l_ar->end[n];
1442 : 1007 : l_stride = l_ar->stride[n];
1443 : :
1444 : 1007 : r_start = r_ar->start[n];
1445 : 1007 : r_end = r_ar->end[n];
1446 : 1007 : r_stride = r_ar->stride[n];
1447 : :
1448 : : /* If l_start is NULL take it from array specifier. */
1449 : 1007 : if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1450 : 122 : l_start = l_ar->as->lower[n];
1451 : : /* If l_end is NULL take it from array specifier. */
1452 : 1007 : if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1453 : 135 : l_end = l_ar->as->upper[n];
1454 : :
1455 : : /* If r_start is NULL take it from array specifier. */
1456 : 1007 : if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1457 : 40 : r_start = r_ar->as->lower[n];
1458 : : /* If r_end is NULL take it from array specifier. */
1459 : 1007 : if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1460 : 28 : r_end = r_ar->as->upper[n];
1461 : :
1462 : : /* Determine whether the l_stride is positive or negative. */
1463 : 1007 : if (!l_stride)
1464 : : l_dir = 1;
1465 : 295 : else if (l_stride->expr_type == EXPR_CONSTANT
1466 : 214 : && l_stride->ts.type == BT_INTEGER)
1467 : 214 : l_dir = mpz_sgn (l_stride->value.integer);
1468 : 81 : else if (l_start && l_end)
1469 : 81 : l_dir = gfc_dep_compare_expr (l_end, l_start);
1470 : : else
1471 : : l_dir = -2;
1472 : :
1473 : : /* Determine whether the r_stride is positive or negative. */
1474 : 1007 : if (!r_stride)
1475 : : r_dir = 1;
1476 : 433 : else if (r_stride->expr_type == EXPR_CONSTANT
1477 : 391 : && r_stride->ts.type == BT_INTEGER)
1478 : 391 : r_dir = mpz_sgn (r_stride->value.integer);
1479 : 42 : else if (r_start && r_end)
1480 : 42 : r_dir = gfc_dep_compare_expr (r_end, r_start);
1481 : : else
1482 : : r_dir = -2;
1483 : :
1484 : : /* The strides should never be zero. */
1485 : 1007 : 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 : 1007 : one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1496 : :
1497 : 2293 : stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1498 : : r_stride ? r_stride : one_expr);
1499 : :
1500 : 1007 : if (l_start && r_start)
1501 : 898 : start_comparison = gfc_dep_compare_expr (l_start, r_start);
1502 : : else
1503 : : start_comparison = -2;
1504 : :
1505 : 1007 : gfc_free_expr (one_expr);
1506 : :
1507 : : /* Determine LHS upper and lower bounds. */
1508 : 1007 : if (l_dir == 1)
1509 : : {
1510 : : l_lower = l_start;
1511 : : l_upper = l_end;
1512 : : }
1513 : 181 : else if (l_dir == -1)
1514 : : {
1515 : : l_lower = l_end;
1516 : : l_upper = l_start;
1517 : : }
1518 : : else
1519 : : {
1520 : 37 : l_lower = NULL;
1521 : 37 : l_upper = NULL;
1522 : : }
1523 : :
1524 : : /* Determine RHS upper and lower bounds. */
1525 : 1007 : if (r_dir == 1)
1526 : : {
1527 : : r_lower = r_start;
1528 : : r_upper = r_end;
1529 : : }
1530 : 305 : else if (r_dir == -1)
1531 : : {
1532 : : r_lower = r_end;
1533 : : r_upper = r_start;
1534 : : }
1535 : : else
1536 : : {
1537 : 20 : r_lower = NULL;
1538 : 20 : r_upper = NULL;
1539 : : }
1540 : :
1541 : : /* Check whether the ranges are disjoint. */
1542 : 1007 : if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1543 : : return GFC_DEP_NODEP;
1544 : 994 : if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, 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 : 910 : if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1549 : : {
1550 : 34 : if (l_dir == 1 && r_dir == -1)
1551 : : return GFC_DEP_EQUAL;
1552 : 21 : 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 : 895 : if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1558 : : {
1559 : 39 : if (l_dir == 1 && r_dir == -1)
1560 : : return GFC_DEP_EQUAL;
1561 : 39 : 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 : 252 : if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
1577 : 1022 : && gfc_dep_difference (l_start, r_start, &tmp))
1578 : : {
1579 : 153 : mpz_t gcd;
1580 : 153 : int result;
1581 : :
1582 : 153 : mpz_init (gcd);
1583 : 153 : mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1584 : :
1585 : 153 : mpz_fdiv_r (tmp, tmp, gcd);
1586 : 153 : result = mpz_cmp_si (tmp, 0L);
1587 : :
1588 : 153 : mpz_clear (gcd);
1589 : 153 : mpz_clear (tmp);
1590 : :
1591 : 153 : if (result != 0)
1592 : 29 : 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 : 838 : if (l_dir == 1 && r_dir == 1 &&
1600 : 506 : (start_comparison == 0 || start_comparison == -1)
1601 : 183 : && (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 : 657 : if (l_dir == -1 && r_dir == -1 &&
1607 : 87 : (start_comparison == 0 || start_comparison == 1)
1608 : 87 : && (stride_comparison == 0 || stride_comparison == 1))
1609 : : return GFC_DEP_FORWARD;
1610 : :
1611 : 611 : if (stride_comparison == 0 || stride_comparison == -1)
1612 : : {
1613 : 329 : 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 : 262 : if (r_dir == 1
1621 : 262 : && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1622 : : return GFC_DEP_FORWARD;
1623 : : }
1624 : : }
1625 : :
1626 : 609 : if (stride_comparison == 0 || stride_comparison == 1)
1627 : : {
1628 : 517 : 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 : 375 : if (r_dir == -1
1636 : 375 : && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1637 : : return GFC_DEP_FORWARD;
1638 : : }
1639 : : }
1640 : :
1641 : :
1642 : 515 : if (stride_comparison == 0)
1643 : : {
1644 : : /* From here, check for backwards dependencies. */
1645 : : /* x+1:y vs. x:z. */
1646 : 314 : 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 : 83 : 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 : 230 : gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1662 : : {
1663 : 230 : gfc_array_ref *ref;
1664 : 230 : gfc_expr *elem;
1665 : 230 : gfc_expr *start;
1666 : 230 : gfc_expr *end;
1667 : 230 : gfc_expr *stride;
1668 : 230 : int s;
1669 : :
1670 : 230 : elem = lref->u.ar.start[n];
1671 : 230 : if (!elem)
1672 : : return GFC_DEP_OVERLAP;
1673 : :
1674 : 230 : ref = &rref->u.ar;
1675 : 230 : start = ref->start[n] ;
1676 : 230 : end = ref->end[n] ;
1677 : 230 : stride = ref->stride[n];
1678 : :
1679 : 230 : if (!start && IS_ARRAY_EXPLICIT (ref->as))
1680 : 105 : start = ref->as->lower[n];
1681 : 230 : if (!end && IS_ARRAY_EXPLICIT (ref->as))
1682 : 105 : end = ref->as->upper[n];
1683 : :
1684 : : /* Determine whether the stride is positive or negative. */
1685 : 230 : if (!stride)
1686 : : s = 1;
1687 : 0 : else if (stride->expr_type == EXPR_CONSTANT
1688 : 0 : && stride->ts.type == BT_INTEGER)
1689 : 0 : s = mpz_sgn (stride->value.integer);
1690 : : else
1691 : : s = -2;
1692 : :
1693 : : /* Stride should never be zero. */
1694 : 0 : if (s == 0)
1695 : : return GFC_DEP_OVERLAP;
1696 : :
1697 : : /* Positive strides. */
1698 : 230 : if (s == 1)
1699 : : {
1700 : : /* Check for elem < lower. */
1701 : 230 : if (start && gfc_dep_compare_expr (elem, start) == -1)
1702 : : return GFC_DEP_NODEP;
1703 : : /* Check for elem > upper. */
1704 : 229 : if (end && gfc_dep_compare_expr (elem, end) == 1)
1705 : : return GFC_DEP_NODEP;
1706 : :
1707 : 229 : if (start && end)
1708 : : {
1709 : 155 : s = gfc_dep_compare_expr (start, end);
1710 : : /* Check for an empty range. */
1711 : 155 : if (s == 1)
1712 : : return GFC_DEP_NODEP;
1713 : 155 : if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1714 : : return GFC_DEP_EQUAL;
1715 : : }
1716 : : }
1717 : : /* Negative strides. */
1718 : 0 : else if (s == -1)
1719 : : {
1720 : : /* Check for elem > upper. */
1721 : 0 : if (end && gfc_dep_compare_expr (elem, start) == 1)
1722 : : return GFC_DEP_NODEP;
1723 : : /* Check for elem < lower. */
1724 : 0 : if (start && gfc_dep_compare_expr (elem, end) == -1)
1725 : : return GFC_DEP_NODEP;
1726 : :
1727 : 0 : if (start && end)
1728 : : {
1729 : 0 : s = gfc_dep_compare_expr (start, end);
1730 : : /* Check for an empty range. */
1731 : 0 : if (s == -1)
1732 : : return GFC_DEP_NODEP;
1733 : 0 : if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1734 : : return GFC_DEP_EQUAL;
1735 : : }
1736 : : }
1737 : : /* Unknown strides. */
1738 : : else
1739 : : {
1740 : 0 : if (!start || !end)
1741 : : return GFC_DEP_OVERLAP;
1742 : 0 : s = gfc_dep_compare_expr (start, end);
1743 : 0 : if (s <= -2)
1744 : : return GFC_DEP_OVERLAP;
1745 : : /* Assume positive stride. */
1746 : 0 : if (s == -1)
1747 : : {
1748 : : /* Check for elem < lower. */
1749 : 0 : if (gfc_dep_compare_expr (elem, start) == -1)
1750 : : return GFC_DEP_NODEP;
1751 : : /* Check for elem > upper. */
1752 : 0 : if (gfc_dep_compare_expr (elem, end) == 1)
1753 : : return GFC_DEP_NODEP;
1754 : : }
1755 : : /* Assume negative stride. */
1756 : 0 : else if (s == 1)
1757 : : {
1758 : : /* Check for elem > upper. */
1759 : 0 : if (gfc_dep_compare_expr (elem, start) == 1)
1760 : : return GFC_DEP_NODEP;
1761 : : /* Check for elem < lower. */
1762 : 0 : if (gfc_dep_compare_expr (elem, end) == -1)
1763 : : return GFC_DEP_NODEP;
1764 : : }
1765 : : /* Equal bounds. */
1766 : 0 : else if (s == 0)
1767 : : {
1768 : 0 : s = gfc_dep_compare_expr (elem, start);
1769 : 0 : if (s == 0)
1770 : : return GFC_DEP_EQUAL;
1771 : 0 : 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 : 6233 : contains_forall_index_p (gfc_expr *expr)
1787 : : {
1788 : 6233 : gfc_actual_arglist *arg;
1789 : 6233 : gfc_constructor *c;
1790 : 6233 : gfc_ref *ref;
1791 : 6233 : int i;
1792 : :
1793 : 6233 : if (!expr)
1794 : : return false;
1795 : :
1796 : 6233 : switch (expr->expr_type)
1797 : : {
1798 : 3128 : case EXPR_VARIABLE:
1799 : 3128 : if (expr->symtree->n.sym->forall_index)
1800 : : return true;
1801 : : break;
1802 : :
1803 : 1424 : case EXPR_OP:
1804 : 1424 : if (contains_forall_index_p (expr->value.op.op1)
1805 : 1424 : || contains_forall_index_p (expr->value.op.op2))
1806 : 7 : return true;
1807 : : break;
1808 : :
1809 : 0 : case EXPR_FUNCTION:
1810 : 0 : for (arg = expr->value.function.actual; arg; arg = arg->next)
1811 : 0 : if (contains_forall_index_p (arg->expr))
1812 : : return true;
1813 : : break;
1814 : :
1815 : : case EXPR_CONSTANT:
1816 : : case EXPR_NULL:
1817 : : case EXPR_SUBSTRING:
1818 : : break;
1819 : :
1820 : 0 : case EXPR_STRUCTURE:
1821 : 0 : case EXPR_ARRAY:
1822 : 0 : for (c = gfc_constructor_first (expr->value.constructor);
1823 : 0 : c; gfc_constructor_next (c))
1824 : 0 : if (contains_forall_index_p (c->expr))
1825 : : return true;
1826 : : break;
1827 : :
1828 : 0 : default:
1829 : 0 : gcc_unreachable ();
1830 : : }
1831 : :
1832 : 5993 : for (ref = expr->ref; ref; ref = ref->next)
1833 : 6 : switch (ref->type)
1834 : : {
1835 : : case REF_ARRAY:
1836 : 6 : for (i = 0; i < ref->u.ar.dimen; i++)
1837 : 6 : if (contains_forall_index_p (ref->u.ar.start[i])
1838 : 0 : || contains_forall_index_p (ref->u.ar.end[i])
1839 : 6 : || contains_forall_index_p (ref->u.ar.stride[i]))
1840 : 6 : return true;
1841 : : break;
1842 : :
1843 : : case REF_COMPONENT:
1844 : : break;
1845 : :
1846 : 0 : case REF_SUBSTRING:
1847 : 0 : if (contains_forall_index_p (ref->u.ss.start)
1848 : 0 : || contains_forall_index_p (ref->u.ss.end))
1849 : 0 : return true;
1850 : : break;
1851 : :
1852 : 0 : default:
1853 : 0 : gcc_unreachable ();
1854 : : }
1855 : :
1856 : : return false;
1857 : : }
1858 : :
1859 : : /* Determines overlapping for two single element array references. */
1860 : :
1861 : : static gfc_dependency
1862 : 2203 : gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1863 : : {
1864 : 2203 : gfc_array_ref l_ar;
1865 : 2203 : gfc_array_ref r_ar;
1866 : 2203 : gfc_expr *l_start;
1867 : 2203 : gfc_expr *r_start;
1868 : 2203 : int i;
1869 : :
1870 : 2203 : l_ar = lref->u.ar;
1871 : 2203 : r_ar = rref->u.ar;
1872 : 2203 : l_start = l_ar.start[n] ;
1873 : 2203 : r_start = r_ar.start[n] ;
1874 : 2203 : i = gfc_dep_compare_expr (r_start, l_start);
1875 : 2203 : 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 : 1806 : if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1888 : 233 : return GFC_DEP_OVERLAP;
1889 : :
1890 : 1573 : 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 : 4806 : callback_dummy_intent_not_in (gfc_expr **ep,
1901 : : int *walk_subtrees ATTRIBUTE_UNUSED,
1902 : : void *data ATTRIBUTE_UNUSED)
1903 : : {
1904 : 4806 : gfc_expr *e = *ep;
1905 : :
1906 : 4806 : if (e->expr_type == EXPR_VARIABLE && e->symtree
1907 : 177 : && e->symtree->n.sym->attr.dummy)
1908 : 159 : 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 : 4581 : dummy_intent_not_in (gfc_expr **ep)
1919 : : {
1920 : 0 : 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 : 161806 : gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1933 : : {
1934 : 161806 : int i;
1935 : 161806 : int n;
1936 : 161806 : bool lbound_OK = true;
1937 : 161806 : bool ubound_OK = true;
1938 : :
1939 : 161806 : if (contiguous)
1940 : 44315 : *contiguous = false;
1941 : :
1942 : 161806 : if (ref->type != REF_ARRAY)
1943 : : return false;
1944 : :
1945 : 161800 : if (ref->u.ar.type == AR_FULL)
1946 : : {
1947 : 116513 : if (contiguous)
1948 : 35045 : *contiguous = true;
1949 : 116513 : return true;
1950 : : }
1951 : :
1952 : 45287 : if (ref->u.ar.type != AR_SECTION)
1953 : : return false;
1954 : 30333 : if (ref->next)
1955 : : return false;
1956 : :
1957 : 56527 : 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 : 40912 : 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 : 3315 : if (contiguous)
1968 : : {
1969 : 223 : *contiguous = true;
1970 : 378 : for (n = i + 1; n < ref->u.ar.dimen; n++)
1971 : 155 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1972 : 145 : *contiguous = false;
1973 : : }
1974 : :
1975 : 3346 : if (!ref->u.ar.as
1976 : 3315 : || !ref->u.ar.as->lower[i]
1977 : 2816 : || !ref->u.ar.as->upper[i]
1978 : 2731 : || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1979 : : ref->u.ar.as->upper[i])
1980 : 31 : || !ref->u.ar.start[i]
1981 : 3346 : || gfc_dep_compare_expr (ref->u.ar.start[i],
1982 : 31 : ref->u.ar.as->lower[i]))
1983 : 3284 : return false;
1984 : : else
1985 : 31 : continue;
1986 : : }
1987 : :
1988 : : /* Check the lower bound. */
1989 : 37597 : if (ref->u.ar.start[i]
1990 : 37597 : && (!ref->u.ar.as
1991 : 10671 : || !ref->u.ar.as->lower[i]
1992 : 7406 : || gfc_dep_compare_expr (ref->u.ar.start[i],
1993 : : ref->u.ar.as->lower[i])
1994 : 3000 : || dummy_intent_not_in (&ref->u.ar.start[i])))
1995 : : lbound_OK = false;
1996 : : /* Check the upper bound. */
1997 : 37597 : if (ref->u.ar.end[i]
1998 : 37597 : && (!ref->u.ar.as
1999 : 10548 : || !ref->u.ar.as->upper[i]
2000 : 6982 : || gfc_dep_compare_expr (ref->u.ar.end[i],
2001 : : ref->u.ar.as->upper[i])
2002 : 1581 : || dummy_intent_not_in (&ref->u.ar.end[i])))
2003 : : ubound_OK = false;
2004 : : /* Check the stride. */
2005 : 37597 : if (ref->u.ar.stride[i]
2006 : 37597 : && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2007 : : return false;
2008 : :
2009 : : /* This is unconditionally a contiguous reference as long as all
2010 : : the subsequent dimensions are elements. */
2011 : 35061 : if (contiguous)
2012 : : {
2013 : 12965 : *contiguous = true;
2014 : 19223 : for (n = i + 1; n < ref->u.ar.dimen; n++)
2015 : 6258 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2016 : 6098 : *contiguous = false;
2017 : : }
2018 : :
2019 : 35061 : 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 : 11254 : ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
2032 : : {
2033 : 11254 : int i;
2034 : 11254 : bool upper_or_lower;
2035 : :
2036 : 11254 : if (full_ref->type != REF_ARRAY)
2037 : : return false;
2038 : 11254 : if (full_ref->u.ar.type != AR_FULL)
2039 : : return false;
2040 : 4184 : if (ref->type != REF_ARRAY)
2041 : : return false;
2042 : 4184 : if (ref->u.ar.type == AR_FULL)
2043 : : return true;
2044 : 486 : if (ref->u.ar.type != AR_SECTION)
2045 : : return false;
2046 : :
2047 : 445 : 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 : 413 : if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
2053 : : {
2054 : 13 : if (!full_ref->u.ar.as
2055 : 13 : || !full_ref->u.ar.as->lower[i]
2056 : 13 : || !full_ref->u.ar.as->upper[i]
2057 : 13 : || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
2058 : : full_ref->u.ar.as->upper[i])
2059 : 0 : || !ref->u.ar.start[i]
2060 : 13 : || gfc_dep_compare_expr (ref->u.ar.start[i],
2061 : 0 : full_ref->u.ar.as->lower[i]))
2062 : 13 : return false;
2063 : : }
2064 : :
2065 : : /* Check the strides. */
2066 : 400 : if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
2067 : : return false;
2068 : 400 : if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2069 : : return false;
2070 : :
2071 : 311 : upper_or_lower = false;
2072 : : /* Check the lower bound. */
2073 : 311 : if (ref->u.ar.start[i]
2074 : 311 : && (ref->u.ar.as
2075 : 136 : && full_ref->u.ar.as->lower[i]
2076 : 68 : && gfc_dep_compare_expr (ref->u.ar.start[i],
2077 : : full_ref->u.ar.as->lower[i]) == 0))
2078 : : upper_or_lower = true;
2079 : : /* Check the upper bound. */
2080 : 311 : if (ref->u.ar.end[i]
2081 : 311 : && (ref->u.ar.as
2082 : 85 : && full_ref->u.ar.as->upper[i]
2083 : 61 : && gfc_dep_compare_expr (ref->u.ar.end[i],
2084 : : full_ref->u.ar.as->upper[i]) == 0))
2085 : : upper_or_lower = true;
2086 : 306 : 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 : 7528 : gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse,
2101 : : bool identical)
2102 : : {
2103 : 7528 : int n;
2104 : 7528 : int m;
2105 : 7528 : gfc_dependency fin_dep;
2106 : 7528 : gfc_dependency this_dep;
2107 : 7528 : bool same_component = false;
2108 : :
2109 : 7528 : this_dep = GFC_DEP_ERROR;
2110 : 7528 : 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 : 9479 : 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 : 8061 : if (lref && lref->type == REF_COMPONENT && lref->u.c.component
2121 : 487 : && strcmp (lref->u.c.component->name, "_data") == 0)
2122 : 104 : lref = lref->next;
2123 : :
2124 : 8061 : if (rref && rref->type == REF_COMPONENT && rref->u.c.component
2125 : 449 : && strcmp (rref->u.c.component->name, "_data") == 0)
2126 : 66 : 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 : 8061 : gcc_assert (lref->type == rref->type);
2132 : 8061 : switch (lref->type)
2133 : : {
2134 : 383 : case REF_COMPONENT:
2135 : : /* The two ranges can't overlap if they are from different
2136 : : components. */
2137 : 383 : if (lref->u.c.component != rref->u.c.component)
2138 : : return 0;
2139 : :
2140 : : same_component = true;
2141 : : break;
2142 : :
2143 : 104 : case REF_SUBSTRING:
2144 : : /* Substring overlaps are handled by the string assignment code
2145 : : if there is not an underlying dependency. */
2146 : 104 : return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
2147 : :
2148 : 7556 : 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 : 7556 : if (flag_coarray != GFC_FCOARRAY_SINGLE
2154 : 7412 : && ((lref->u.ar.codimen
2155 : 138 : && lref->u.ar.dimen_type[lref->u.ar.dimen]
2156 : : != DIMEN_THIS_IMAGE)
2157 : 7412 : || (rref->u.ar.codimen
2158 : : && lref->u.ar.dimen_type[lref->u.ar.dimen]
2159 : : != DIMEN_THIS_IMAGE)))
2160 : : return 1;
2161 : 7500 : if (lref->u.ar.dimen == 0 || rref->u.ar.dimen == 0)
2162 : : {
2163 : : /* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */
2164 : 18 : 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 : 7482 : if (ref_same_as_full_array (lref, rref))
2171 : : return identical;
2172 : :
2173 : 3772 : if (ref_same_as_full_array (rref, lref))
2174 : : return identical;
2175 : :
2176 : 3752 : if (lref->u.ar.dimen != rref->u.ar.dimen)
2177 : : {
2178 : 0 : if (lref->u.ar.type == AR_FULL)
2179 : 0 : fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
2180 : : : GFC_DEP_OVERLAP;
2181 : 0 : else if (rref->u.ar.type == AR_FULL)
2182 : 0 : fin_dep = gfc_full_array_ref_p (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 : 6710 : 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 : 4611 : if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2198 : 4551 : || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2199 : : {
2200 : 117 : if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2201 : 60 : && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2202 : 177 : && gfc_dep_compare_expr (lref->u.ar.start[n],
2203 : : rref->u.ar.start[n]) == 0)
2204 : : this_dep = GFC_DEP_EQUAL;
2205 : : else
2206 : : this_dep = GFC_DEP_OVERLAP;
2207 : :
2208 : 117 : goto update_fin_dep;
2209 : : }
2210 : :
2211 : 4494 : if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2212 : 2209 : && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2213 : 2061 : this_dep = check_section_vs_section (&lref->u.ar,
2214 : : &rref->u.ar, n);
2215 : 2433 : else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2216 : 2285 : && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2217 : 82 : this_dep = gfc_check_element_vs_section (lref, rref, n);
2218 : 2351 : else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2219 : 2351 : && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2220 : 148 : this_dep = gfc_check_element_vs_section (rref, lref, n);
2221 : : else
2222 : : {
2223 : 2203 : gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2224 : : && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
2225 : 2203 : this_dep = gfc_check_element_vs_element (rref, lref, n);
2226 : 2203 : 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 : 4354 : 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 : 2841 : if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2244 : 2100 : m++;
2245 : :
2246 : 2841 : if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
2247 : 2035 : && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2248 : : {
2249 : 1953 : if (reverse)
2250 : : {
2251 : : /* Reverse if backward dependence and not inhibited. */
2252 : 746 : if (reverse[m] == GFC_ENABLE_REVERSE
2253 : 694 : && this_dep == GFC_DEP_BACKWARD)
2254 : 86 : reverse[m] = GFC_REVERSE_SET;
2255 : :
2256 : : /* Forward if forward dependence and not inhibited. */
2257 : 746 : if (reverse[m] == GFC_ENABLE_REVERSE
2258 : 608 : && this_dep == GFC_DEP_FORWARD)
2259 : 97 : reverse[m] = GFC_FORWARD_SET;
2260 : :
2261 : : /* Flag up overlap if dependence not compatible with
2262 : : the overall state of the expression. */
2263 : 746 : if (reverse[m] == GFC_REVERSE_SET
2264 : 108 : && this_dep == GFC_DEP_FORWARD)
2265 : : {
2266 : 16 : reverse[m] = GFC_INHIBIT_REVERSE;
2267 : 16 : this_dep = GFC_DEP_OVERLAP;
2268 : : }
2269 : 730 : else if (reverse[m] == GFC_FORWARD_SET
2270 : 103 : && this_dep == GFC_DEP_BACKWARD)
2271 : : {
2272 : 6 : reverse[m] = GFC_INHIBIT_REVERSE;
2273 : 6 : 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 : 1953 : if ((!reverse && this_dep == GFC_DEP_BACKWARD)
2280 : 1806 : || (reverse && reverse[m] == GFC_INHIBIT_REVERSE))
2281 : 2958 : 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 : 888 : update_fin_dep:
2288 : 2958 : if (identical && this_dep == GFC_DEP_EQUAL)
2289 : 540 : this_dep = GFC_DEP_OVERLAP;
2290 : :
2291 : 2958 : if (this_dep > fin_dep)
2292 : 2119 : 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 : 2099 : if (lref->u.ar.type == AR_ELEMENT
2298 : 222 : && rref->u.ar.type == AR_ELEMENT
2299 : 222 : && fin_dep == GFC_DEP_EQUAL)
2300 : : break;
2301 : :
2302 : : /* Exactly matching and forward overlapping ranges don't cause a
2303 : : dependency. */
2304 : 2024 : 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 : 18 : case REF_INQUIRY:
2312 : 18 : if (lref->u.i != rref->u.i)
2313 : : return 0;
2314 : :
2315 : : break;
2316 : :
2317 : 0 : default:
2318 : 0 : gcc_unreachable ();
2319 : : }
2320 : 1951 : lref = lref->next;
2321 : 1951 : rref = rref->next;
2322 : : }
2323 : :
2324 : : /* Assume the worst if we nest to different depths. */
2325 : 1418 : if (lref || rref)
2326 : : return 1;
2327 : :
2328 : : /* This can result from concatenation of assumed length string components. */
2329 : 1356 : 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 : 1344 : gcc_assert (fin_dep != GFC_DEP_ERROR);
2334 : :
2335 : 1344 : if (identical && fin_dep != GFC_DEP_NODEP)
2336 : : return 1;
2337 : :
2338 : 577 : return fin_dep == GFC_DEP_OVERLAP;
2339 : : }
|
