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