2 Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* dependency.c -- Expression dependency analysis code. */
23 /* There's probably quite a bit of duplication in this file. We currently
24 have different dependency checking functions for different types
25 if dependencies. Ideally these would probably be merged. */
30 #include "dependency.h"
31 #include "constructor.h"
34 /* static declarations */
36 enum range {LHS, RHS, MID};
38 /* Dependency types. These must be in reverse order of priority. */
42 GFC_DEP_EQUAL, /* Identical Ranges. */
43 GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */
44 GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */
45 GFC_DEP_OVERLAP, /* May overlap in some other way. */
46 GFC_DEP_NODEP /* Distinct ranges. */
51 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
53 /* Forward declarations */
55 static gfc_dependency check_section_vs_section (gfc_array_ref *,
56 gfc_array_ref *, int);
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. */
62 gfc_expr_is_one (gfc_expr *expr, int def)
64 gcc_assert (expr != NULL);
66 if (expr->expr_type != EXPR_CONSTANT)
69 if (expr->ts.type != BT_INTEGER)
72 return mpz_cmp_si (expr->value.integer, 1) == 0;
75 /* Check if two array references are known to be identical. Calls
76 gfc_dep_compare_expr if necessary for comparing array indices. */
79 identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
83 if (a1->type == AR_FULL && a2->type == AR_FULL)
86 if (a1->type == AR_SECTION && a2->type == AR_SECTION)
88 gcc_assert (a1->dimen == a2->dimen);
90 for ( i = 0; i < a1->dimen; i++)
92 /* TODO: Currently, we punt on an integer array as an index. */
93 if (a1->dimen_type[i] != DIMEN_RANGE
94 || a2->dimen_type[i] != DIMEN_RANGE)
97 if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
103 if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
105 gcc_assert (a1->dimen == a2->dimen);
106 for (i = 0; i < a1->dimen; i++)
108 if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
118 /* Return true for identical variables, checking for references if
119 necessary. Calls identical_array_ref for checking array sections. */
122 are_identical_variables (gfc_expr *e1, gfc_expr *e2)
126 if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
128 /* Dummy arguments: Only check for equal names. */
129 if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
134 /* Check for equal symbols. */
135 if (e1->symtree->n.sym != e2->symtree->n.sym)
139 /* Volatile variables should never compare equal to themselves. */
141 if (e1->symtree->n.sym->attr.volatile_)
147 while (r1 != NULL || r2 != NULL)
150 /* Assume the variables are not equal if one has a reference and the
152 TODO: Handle full references like comparing a(:) to a.
155 if (r1 == NULL || r2 == NULL)
158 if (r1->type != r2->type)
165 if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
171 if (r1->u.c.component != r2->u.c.component)
176 if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0)
179 /* If both are NULL, the end length compares equal, because we
180 are looking at the same variable. This can only happen for
181 assumed- or deferred-length character arguments. */
183 if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
186 if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
192 gfc_internal_error ("are_identical_variables: Bad type");
200 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
201 impure_ok is false, only return 0 for pure functions. */
204 gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
207 gfc_actual_arglist *args1;
208 gfc_actual_arglist *args2;
210 if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
213 if ((e1->value.function.esym && e2->value.function.esym
214 && e1->value.function.esym == e2->value.function.esym
215 && (e1->value.function.esym->result->attr.pure || impure_ok))
216 || (e1->value.function.isym && e2->value.function.isym
217 && e1->value.function.isym == e2->value.function.isym
218 && (e1->value.function.isym->pure || impure_ok)))
220 args1 = e1->value.function.actual;
221 args2 = e2->value.function.actual;
223 /* Compare the argument lists for equality. */
224 while (args1 && args2)
226 /* Bitwise xor, since C has no non-bitwise xor operator. */
227 if ((args1->expr == NULL) ^ (args2->expr == NULL))
230 if (args1->expr != NULL && args2->expr != NULL
231 && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
237 return (args1 || args2) ? -2 : 0;
243 /* Compare two expressions. Return values:
247 * -2 if the relationship could not be determined
248 * -3 if e1 /= e2, but we cannot tell which one is larger.
249 REAL and COMPLEX constants are only compared for equality
250 or inequality; if they are unequal, -2 is returned in all cases. */
253 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
255 gfc_actual_arglist *args1;
256 gfc_actual_arglist *args2;
263 /* Remove any integer conversion functions to larger types. */
264 if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
265 && e1->value.function.isym->id == GFC_ISYM_CONVERSION
266 && e1->ts.type == BT_INTEGER)
268 args1 = e1->value.function.actual;
269 if (args1->expr->ts.type == BT_INTEGER
270 && e1->ts.kind > args1->expr->ts.kind)
274 if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
275 && e2->value.function.isym->id == GFC_ISYM_CONVERSION
276 && e2->ts.type == BT_INTEGER)
278 args2 = e2->value.function.actual;
279 if (args2->expr->ts.type == BT_INTEGER
280 && e2->ts.kind > args2->expr->ts.kind)
287 return gfc_dep_compare_expr (n1, n2);
289 return gfc_dep_compare_expr (n1, e2);
294 return gfc_dep_compare_expr (e1, n2);
297 if (e1->expr_type == EXPR_OP
298 && (e1->value.op.op == INTRINSIC_UPLUS
299 || e1->value.op.op == INTRINSIC_PARENTHESES))
300 return gfc_dep_compare_expr (e1->value.op.op1, e2);
301 if (e2->expr_type == EXPR_OP
302 && (e2->value.op.op == INTRINSIC_UPLUS
303 || e2->value.op.op == INTRINSIC_PARENTHESES))
304 return gfc_dep_compare_expr (e1, e2->value.op.op1);
306 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
308 /* Compare X+C vs. X, for INTEGER only. */
309 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
310 && e1->value.op.op2->ts.type == BT_INTEGER
311 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
312 return mpz_sgn (e1->value.op.op2->value.integer);
314 /* Compare P+Q vs. R+S. */
315 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
319 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
320 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
321 if (l == 0 && r == 0)
323 if (l == 0 && r > -2)
325 if (l > -2 && r == 0)
327 if (l == 1 && r == 1)
329 if (l == -1 && r == -1)
332 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
333 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
334 if (l == 0 && r == 0)
336 if (l == 0 && r > -2)
338 if (l > -2 && r == 0)
340 if (l == 1 && r == 1)
342 if (l == -1 && r == -1)
347 /* Compare X vs. X+C, for INTEGER only. */
348 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
350 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
351 && e2->value.op.op2->ts.type == BT_INTEGER
352 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
353 return -mpz_sgn (e2->value.op.op2->value.integer);
356 /* Compare X-C vs. X, for INTEGER only. */
357 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
359 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
360 && e1->value.op.op2->ts.type == BT_INTEGER
361 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
362 return -mpz_sgn (e1->value.op.op2->value.integer);
364 /* Compare P-Q vs. R-S. */
365 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
369 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
370 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
371 if (l == 0 && r == 0)
373 if (l > -2 && r == 0)
375 if (l == 0 && r > -2)
377 if (l == 1 && r == -1)
379 if (l == -1 && r == 1)
384 /* Compare A // B vs. C // D. */
386 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
387 && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
391 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
392 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
399 /* Watch out for 'A ' // x vs. 'A' // x. */
400 gfc_expr *e1_left = e1->value.op.op1;
401 gfc_expr *e2_left = e2->value.op.op1;
403 if (e1_left->expr_type == EXPR_CONSTANT
404 && e2_left->expr_type == EXPR_CONSTANT
405 && e1_left->value.character.length
406 != e2_left->value.character.length)
420 /* Compare X vs. X-C, for INTEGER only. */
421 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
423 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
424 && e2->value.op.op2->ts.type == BT_INTEGER
425 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
426 return mpz_sgn (e2->value.op.op2->value.integer);
429 if (e1->expr_type != e2->expr_type)
432 switch (e1->expr_type)
435 /* Compare strings for equality. */
436 if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
437 return gfc_compare_string (e1, e2);
439 /* Compare REAL and COMPLEX constants. Because of the
440 traps and pitfalls associated with comparing
441 a + 1.0 with a + 0.5, check for equality only. */
442 if (e2->expr_type == EXPR_CONSTANT)
444 if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
446 if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
451 else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
453 if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
460 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
463 /* For INTEGER, all cases where e2 is not constant should have
464 been filtered out above. */
465 gcc_assert (e2->expr_type == EXPR_CONSTANT);
467 i = mpz_cmp (e1->value.integer, e2->value.integer);
475 if (are_identical_variables (e1, e2))
481 /* Intrinsic operators are the same if their operands are the same. */
482 if (e1->value.op.op != e2->value.op.op)
484 if (e1->value.op.op2 == 0)
486 i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
487 return i == 0 ? 0 : -2;
489 if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
490 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
492 else if (e1->value.op.op == INTRINSIC_TIMES
493 && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
494 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
495 /* Commutativity of multiplication; addition is handled above. */
501 return gfc_dep_compare_functions (e1, e2, false);
510 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
511 results are indeterminate). 'n' is the dimension to compare. */
514 is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
520 /* TODO: More sophisticated range comparison. */
521 gcc_assert (ar1 && ar2);
523 gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
527 /* Check for mismatching strides. A NULL stride means a stride of 1. */
530 i = gfc_expr_is_one (e1, -1);
531 if (i == -1 || i == 0)
536 i = gfc_expr_is_one (e2, -1);
537 if (i == -1 || i == 0)
542 i = gfc_dep_compare_expr (e1, e2);
546 /* The strides match. */
548 /* Check the range start. */
553 /* Use the bound of the array if no bound is specified. */
555 e1 = ar1->as->lower[n];
558 e2 = ar2->as->lower[n];
560 /* Check we have values for both. */
564 i = gfc_dep_compare_expr (e1, e2);
569 /* Check the range end. */
574 /* Use the bound of the array if no bound is specified. */
576 e1 = ar1->as->upper[n];
579 e2 = ar2->as->upper[n];
581 /* Check we have values for both. */
585 i = gfc_dep_compare_expr (e1, e2);
594 /* Some array-returning intrinsics can be implemented by reusing the
595 data from one of the array arguments. For example, TRANSPOSE does
596 not necessarily need to allocate new data: it can be implemented
597 by copying the original array's descriptor and simply swapping the
598 two dimension specifications.
600 If EXPR is a call to such an intrinsic, return the argument
601 whose data can be reused, otherwise return NULL. */
604 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
606 if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
609 switch (expr->value.function.isym->id)
611 case GFC_ISYM_TRANSPOSE:
612 return expr->value.function.actual->expr;
620 /* Return true if the result of reference REF can only be constructed
621 using a temporary array. */
624 gfc_ref_needs_temporary_p (gfc_ref *ref)
630 for (; ref; ref = ref->next)
634 /* Vector dimensions are generally not monotonic and must be
635 handled using a temporary. */
636 if (ref->u.ar.type == AR_SECTION)
637 for (n = 0; n < ref->u.ar.dimen; n++)
638 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
645 /* Within an array reference, character substrings generally
646 need a temporary. Character array strides are expressed as
647 multiples of the element size (consistent with other array
648 types), not in characters. */
660 gfc_is_data_pointer (gfc_expr *e)
664 if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
667 /* No subreference if it is a function */
668 gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
670 if (e->symtree->n.sym->attr.pointer)
673 for (ref = e->ref; ref; ref = ref->next)
674 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
681 /* Return true if array variable VAR could be passed to the same function
682 as argument EXPR without interfering with EXPR. INTENT is the intent
685 This is considerably less conservative than other dependencies
686 because many function arguments will already be copied into a
690 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
691 gfc_expr *expr, gfc_dep_check elemental)
695 gcc_assert (var->expr_type == EXPR_VARIABLE);
696 gcc_assert (var->rank > 0);
698 switch (expr->expr_type)
701 /* In case of elemental subroutines, there is no dependency
702 between two same-range array references. */
703 if (gfc_ref_needs_temporary_p (expr->ref)
704 || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
706 if (elemental == ELEM_DONT_CHECK_VARIABLE)
708 /* Too many false positive with pointers. */
709 if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
711 /* Elemental procedures forbid unspecified intents,
712 and we don't check dependencies for INTENT_IN args. */
713 gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
715 /* We are told not to check dependencies.
716 We do it, however, and issue a warning in case we find one.
717 If a dependency is found in the case
718 elemental == ELEM_CHECK_VARIABLE, we will generate
719 a temporary, so we don't need to bother the user. */
720 gfc_warning ("INTENT(%s) actual argument at %L might "
721 "interfere with actual argument at %L.",
722 intent == INTENT_OUT ? "OUT" : "INOUT",
723 &var->where, &expr->where);
733 return gfc_check_dependency (var, expr, 1);
736 if (intent != INTENT_IN)
738 arg = gfc_get_noncopying_intrinsic_argument (expr);
740 return gfc_check_argument_var_dependency (var, intent, arg,
744 if (elemental != NOT_ELEMENTAL)
746 if ((expr->value.function.esym
747 && expr->value.function.esym->attr.elemental)
748 || (expr->value.function.isym
749 && expr->value.function.isym->elemental))
750 return gfc_check_fncall_dependency (var, intent, NULL,
751 expr->value.function.actual,
752 ELEM_CHECK_VARIABLE);
754 if (gfc_inline_intrinsic_function_p (expr))
756 /* The TRANSPOSE case should have been caught in the
757 noncopying intrinsic case above. */
758 gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
760 return gfc_check_fncall_dependency (var, intent, NULL,
761 expr->value.function.actual,
762 ELEM_CHECK_VARIABLE);
768 /* In case of non-elemental procedures, there is no need to catch
769 dependencies, as we will make a temporary anyway. */
772 /* If the actual arg EXPR is an expression, we need to catch
773 a dependency between variables in EXPR and VAR,
774 an intent((IN)OUT) variable. */
775 if (expr->value.op.op1
776 && gfc_check_argument_var_dependency (var, intent,
778 ELEM_CHECK_VARIABLE))
780 else if (expr->value.op.op2
781 && gfc_check_argument_var_dependency (var, intent,
783 ELEM_CHECK_VARIABLE))
794 /* Like gfc_check_argument_var_dependency, but extended to any
795 array expression OTHER, not just variables. */
798 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
799 gfc_expr *expr, gfc_dep_check elemental)
801 switch (other->expr_type)
804 return gfc_check_argument_var_dependency (other, intent, expr, elemental);
807 other = gfc_get_noncopying_intrinsic_argument (other);
809 return gfc_check_argument_dependency (other, INTENT_IN, expr,
820 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
821 FNSYM is the function being called, or NULL if not known. */
824 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
825 gfc_symbol *fnsym, gfc_actual_arglist *actual,
826 gfc_dep_check elemental)
828 gfc_formal_arglist *formal;
831 formal = fnsym ? fnsym->formal : NULL;
832 for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
836 /* Skip args which are not present. */
840 /* Skip other itself. */
844 /* Skip intent(in) arguments if OTHER itself is intent(in). */
845 if (formal && intent == INTENT_IN
846 && formal->sym->attr.intent == INTENT_IN)
849 if (gfc_check_argument_dependency (other, intent, expr, elemental))
857 /* Return 1 if e1 and e2 are equivalenced arrays, either
858 directly or indirectly; i.e., equivalence (a,b) for a and b
859 or equivalence (a,c),(b,c). This function uses the equiv_
860 lists, generated in trans-common(add_equivalences), that are
861 guaranteed to pick up indirect equivalences. We explicitly
862 check for overlap using the offset and length of the equivalence.
863 This function is symmetric.
864 TODO: This function only checks whether the full top-level
865 symbols overlap. An improved implementation could inspect
866 e1->ref and e2->ref to determine whether the actually accessed
867 portions of these variables/arrays potentially overlap. */
870 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
873 gfc_equiv_info *s, *fl1, *fl2;
875 gcc_assert (e1->expr_type == EXPR_VARIABLE
876 && e2->expr_type == EXPR_VARIABLE);
878 if (!e1->symtree->n.sym->attr.in_equivalence
879 || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
882 if (e1->symtree->n.sym->ns
883 && e1->symtree->n.sym->ns != gfc_current_ns)
884 l = e1->symtree->n.sym->ns->equiv_lists;
886 l = gfc_current_ns->equiv_lists;
888 /* Go through the equiv_lists and return 1 if the variables
889 e1 and e2 are members of the same group and satisfy the
890 requirement on their relative offsets. */
891 for (; l; l = l->next)
895 for (s = l->equiv; s; s = s->next)
897 if (s->sym == e1->symtree->n.sym)
903 if (s->sym == e2->symtree->n.sym)
913 /* Can these lengths be zero? */
914 if (fl1->length <= 0 || fl2->length <= 0)
916 /* These can't overlap if [f11,fl1+length] is before
917 [fl2,fl2+length], or [fl2,fl2+length] is before
918 [fl1,fl1+length], otherwise they do overlap. */
919 if (fl1->offset + fl1->length > fl2->offset
920 && fl2->offset + fl2->length > fl1->offset)
928 /* Return true if there is no possibility of aliasing because of a type
929 mismatch between all the possible pointer references and the
930 potential target. Note that this function is asymmetric in the
931 arguments and so must be called twice with the arguments exchanged. */
934 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
940 bool seen_component_ref;
942 if (expr1->expr_type != EXPR_VARIABLE
943 || expr1->expr_type != EXPR_VARIABLE)
946 sym1 = expr1->symtree->n.sym;
947 sym2 = expr2->symtree->n.sym;
949 /* Keep it simple for now. */
950 if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
953 if (sym1->attr.pointer)
955 if (gfc_compare_types (&sym1->ts, &sym2->ts))
959 /* This is a conservative check on the components of the derived type
960 if no component references have been seen. Since we will not dig
961 into the components of derived type components, we play it safe by
962 returning false. First we check the reference chain and then, if
963 no component references have been seen, the components. */
964 seen_component_ref = false;
965 if (sym1->ts.type == BT_DERIVED)
967 for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
969 if (ref1->type != REF_COMPONENT)
972 if (ref1->u.c.component->ts.type == BT_DERIVED)
975 if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
976 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
979 seen_component_ref = true;
983 if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
985 for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
987 if (cm1->ts.type == BT_DERIVED)
990 if ((sym2->attr.pointer || cm1->attr.pointer)
991 && gfc_compare_types (&cm1->ts, &sym2->ts))
1000 /* Return true if the statement body redefines the condition. Returns
1001 true if expr2 depends on expr1. expr1 should be a single term
1002 suitable for the lhs of an assignment. The IDENTICAL flag indicates
1003 whether array references to the same symbol with identical range
1004 references count as a dependency or not. Used for forall and where
1005 statements. Also used with functions returning arrays without a
1009 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1011 gfc_actual_arglist *actual;
1015 gcc_assert (expr1->expr_type == EXPR_VARIABLE);
1017 switch (expr2->expr_type)
1020 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1023 if (expr2->value.op.op2)
1024 return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1028 /* The interesting cases are when the symbols don't match. */
1029 if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1031 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1032 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1034 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1035 if (gfc_are_equivalenced_arrays (expr1, expr2))
1038 /* Symbols can only alias if they have the same type. */
1039 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1040 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1042 if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1046 /* If either variable is a pointer, assume the worst. */
1047 /* TODO: -fassume-no-pointer-aliasing */
1048 if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
1050 if (check_data_pointer_types (expr1, expr2)
1051 && check_data_pointer_types (expr2, expr1))
1058 gfc_symbol *sym1 = expr1->symtree->n.sym;
1059 gfc_symbol *sym2 = expr2->symtree->n.sym;
1060 if (sym1->attr.target && sym2->attr.target
1061 && ((sym1->attr.dummy && !sym1->attr.contiguous
1062 && (!sym1->attr.dimension
1063 || sym2->as->type == AS_ASSUMED_SHAPE))
1064 || (sym2->attr.dummy && !sym2->attr.contiguous
1065 && (!sym2->attr.dimension
1066 || sym2->as->type == AS_ASSUMED_SHAPE))))
1070 /* Otherwise distinct symbols have no dependencies. */
1077 /* Identical and disjoint ranges return 0,
1078 overlapping ranges return 1. */
1079 if (expr1->ref && expr2->ref)
1080 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
1085 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1088 /* Remember possible differences between elemental and
1089 transformational functions. All functions inside a FORALL
1091 for (actual = expr2->value.function.actual;
1092 actual; actual = actual->next)
1096 n = gfc_check_dependency (expr1, actual->expr, identical);
1107 /* Loop through the array constructor's elements. */
1108 for (c = gfc_constructor_first (expr2->value.constructor);
1109 c; c = gfc_constructor_next (c))
1111 /* If this is an iterator, assume the worst. */
1114 /* Avoid recursion in the common case. */
1115 if (c->expr->expr_type == EXPR_CONSTANT)
1117 if (gfc_check_dependency (expr1, c->expr, 1))
1128 /* Determines overlapping for two array sections. */
1130 static gfc_dependency
1131 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1147 int stride_comparison;
1148 int start_comparison;
1150 /* If they are the same range, return without more ado. */
1151 if (is_same_range (l_ar, r_ar, n))
1152 return GFC_DEP_EQUAL;
1154 l_start = l_ar->start[n];
1155 l_end = l_ar->end[n];
1156 l_stride = l_ar->stride[n];
1158 r_start = r_ar->start[n];
1159 r_end = r_ar->end[n];
1160 r_stride = r_ar->stride[n];
1162 /* If l_start is NULL take it from array specifier. */
1163 if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1164 l_start = l_ar->as->lower[n];
1165 /* If l_end is NULL take it from array specifier. */
1166 if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
1167 l_end = l_ar->as->upper[n];
1169 /* If r_start is NULL take it from array specifier. */
1170 if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
1171 r_start = r_ar->as->lower[n];
1172 /* If r_end is NULL take it from array specifier. */
1173 if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
1174 r_end = r_ar->as->upper[n];
1176 /* Determine whether the l_stride is positive or negative. */
1179 else if (l_stride->expr_type == EXPR_CONSTANT
1180 && l_stride->ts.type == BT_INTEGER)
1181 l_dir = mpz_sgn (l_stride->value.integer);
1182 else if (l_start && l_end)
1183 l_dir = gfc_dep_compare_expr (l_end, l_start);
1187 /* Determine whether the r_stride is positive or negative. */
1190 else if (r_stride->expr_type == EXPR_CONSTANT
1191 && r_stride->ts.type == BT_INTEGER)
1192 r_dir = mpz_sgn (r_stride->value.integer);
1193 else if (r_start && r_end)
1194 r_dir = gfc_dep_compare_expr (r_end, r_start);
1198 /* The strides should never be zero. */
1199 if (l_dir == 0 || r_dir == 0)
1200 return GFC_DEP_OVERLAP;
1202 /* Determine the relationship between the strides. Set stride_comparison to
1203 -2 if the dependency cannot be determined
1204 -1 if l_stride < r_stride
1205 0 if l_stride == r_stride
1206 1 if l_stride > r_stride
1207 as determined by gfc_dep_compare_expr. */
1209 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1211 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1212 r_stride ? r_stride : one_expr);
1214 if (l_start && r_start)
1215 start_comparison = gfc_dep_compare_expr (l_start, r_start);
1217 start_comparison = -2;
1221 /* Determine LHS upper and lower bounds. */
1227 else if (l_dir == -1)
1238 /* Determine RHS upper and lower bounds. */
1244 else if (r_dir == -1)
1255 /* Check whether the ranges are disjoint. */
1256 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1257 return GFC_DEP_NODEP;
1258 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1259 return GFC_DEP_NODEP;
1261 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1262 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1264 if (l_dir == 1 && r_dir == -1)
1265 return GFC_DEP_EQUAL;
1266 if (l_dir == -1 && r_dir == 1)
1267 return GFC_DEP_EQUAL;
1270 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1271 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1273 if (l_dir == 1 && r_dir == -1)
1274 return GFC_DEP_EQUAL;
1275 if (l_dir == -1 && r_dir == 1)
1276 return GFC_DEP_EQUAL;
1279 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1280 There is no dependency if the remainder of
1281 (l_start - r_start) / gcd(l_stride, r_stride) is
1284 - Handle cases where x is an expression.
1285 - Cases like a(1:4:2) = a(2:3) are still not handled.
1288 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1289 && (a)->ts.type == BT_INTEGER)
1291 if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
1292 && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
1300 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1301 mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
1303 mpz_fdiv_r (tmp, tmp, gcd);
1304 result = mpz_cmp_si (tmp, 0L);
1310 return GFC_DEP_NODEP;
1313 #undef IS_CONSTANT_INTEGER
1315 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1317 if (l_dir == 1 && r_dir == 1 &&
1318 (start_comparison == 0 || start_comparison == -1)
1319 && (stride_comparison == 0 || stride_comparison == -1))
1320 return GFC_DEP_FORWARD;
1322 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1323 x:y:-1 vs. x:y:-2. */
1324 if (l_dir == -1 && r_dir == -1 &&
1325 (start_comparison == 0 || start_comparison == 1)
1326 && (stride_comparison == 0 || stride_comparison == 1))
1327 return GFC_DEP_FORWARD;
1329 if (stride_comparison == 0 || stride_comparison == -1)
1331 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1334 /* Check for a(low:y:s) vs. a(z:x:s) or
1335 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1336 of low, which is always at least a forward dependence. */
1339 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1340 return GFC_DEP_FORWARD;
1344 if (stride_comparison == 0 || stride_comparison == 1)
1346 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1349 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1350 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1351 of high, which is always at least a forward dependence. */
1354 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1355 return GFC_DEP_FORWARD;
1360 if (stride_comparison == 0)
1362 /* From here, check for backwards dependencies. */
1363 /* x+1:y vs. x:z. */
1364 if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1365 return GFC_DEP_BACKWARD;
1367 /* x-1:y:-1 vs. x:z:-1. */
1368 if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1369 return GFC_DEP_BACKWARD;
1372 return GFC_DEP_OVERLAP;
1376 /* Determines overlapping for a single element and a section. */
1378 static gfc_dependency
1379 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1388 elem = lref->u.ar.start[n];
1390 return GFC_DEP_OVERLAP;
1393 start = ref->start[n] ;
1395 stride = ref->stride[n];
1397 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1398 start = ref->as->lower[n];
1399 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1400 end = ref->as->upper[n];
1402 /* Determine whether the stride is positive or negative. */
1405 else if (stride->expr_type == EXPR_CONSTANT
1406 && stride->ts.type == BT_INTEGER)
1407 s = mpz_sgn (stride->value.integer);
1411 /* Stride should never be zero. */
1413 return GFC_DEP_OVERLAP;
1415 /* Positive strides. */
1418 /* Check for elem < lower. */
1419 if (start && gfc_dep_compare_expr (elem, start) == -1)
1420 return GFC_DEP_NODEP;
1421 /* Check for elem > upper. */
1422 if (end && gfc_dep_compare_expr (elem, end) == 1)
1423 return GFC_DEP_NODEP;
1427 s = gfc_dep_compare_expr (start, end);
1428 /* Check for an empty range. */
1430 return GFC_DEP_NODEP;
1431 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1432 return GFC_DEP_EQUAL;
1435 /* Negative strides. */
1438 /* Check for elem > upper. */
1439 if (end && gfc_dep_compare_expr (elem, start) == 1)
1440 return GFC_DEP_NODEP;
1441 /* Check for elem < lower. */
1442 if (start && gfc_dep_compare_expr (elem, end) == -1)
1443 return GFC_DEP_NODEP;
1447 s = gfc_dep_compare_expr (start, end);
1448 /* Check for an empty range. */
1450 return GFC_DEP_NODEP;
1451 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1452 return GFC_DEP_EQUAL;
1455 /* Unknown strides. */
1459 return GFC_DEP_OVERLAP;
1460 s = gfc_dep_compare_expr (start, end);
1462 return GFC_DEP_OVERLAP;
1463 /* Assume positive stride. */
1466 /* Check for elem < lower. */
1467 if (gfc_dep_compare_expr (elem, start) == -1)
1468 return GFC_DEP_NODEP;
1469 /* Check for elem > upper. */
1470 if (gfc_dep_compare_expr (elem, end) == 1)
1471 return GFC_DEP_NODEP;
1473 /* Assume negative stride. */
1476 /* Check for elem > upper. */
1477 if (gfc_dep_compare_expr (elem, start) == 1)
1478 return GFC_DEP_NODEP;
1479 /* Check for elem < lower. */
1480 if (gfc_dep_compare_expr (elem, end) == -1)
1481 return GFC_DEP_NODEP;
1486 s = gfc_dep_compare_expr (elem, start);
1488 return GFC_DEP_EQUAL;
1489 if (s == 1 || s == -1)
1490 return GFC_DEP_NODEP;
1494 return GFC_DEP_OVERLAP;
1498 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1499 forall_index attribute. Return true if any variable may be
1500 being used as a FORALL index. Its safe to pessimistically
1501 return true, and assume a dependency. */
1504 contains_forall_index_p (gfc_expr *expr)
1506 gfc_actual_arglist *arg;
1514 switch (expr->expr_type)
1517 if (expr->symtree->n.sym->forall_index)
1522 if (contains_forall_index_p (expr->value.op.op1)
1523 || contains_forall_index_p (expr->value.op.op2))
1528 for (arg = expr->value.function.actual; arg; arg = arg->next)
1529 if (contains_forall_index_p (arg->expr))
1535 case EXPR_SUBSTRING:
1538 case EXPR_STRUCTURE:
1540 for (c = gfc_constructor_first (expr->value.constructor);
1541 c; gfc_constructor_next (c))
1542 if (contains_forall_index_p (c->expr))
1550 for (ref = expr->ref; ref; ref = ref->next)
1554 for (i = 0; i < ref->u.ar.dimen; i++)
1555 if (contains_forall_index_p (ref->u.ar.start[i])
1556 || contains_forall_index_p (ref->u.ar.end[i])
1557 || contains_forall_index_p (ref->u.ar.stride[i]))
1565 if (contains_forall_index_p (ref->u.ss.start)
1566 || contains_forall_index_p (ref->u.ss.end))
1577 /* Determines overlapping for two single element array references. */
1579 static gfc_dependency
1580 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1590 l_start = l_ar.start[n] ;
1591 r_start = r_ar.start[n] ;
1592 i = gfc_dep_compare_expr (r_start, l_start);
1594 return GFC_DEP_EQUAL;
1596 /* Treat two scalar variables as potentially equal. This allows
1597 us to prove that a(i,:) and a(j,:) have no dependency. See
1598 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1599 Proceedings of the International Conference on Parallel and
1600 Distributed Processing Techniques and Applications (PDPTA2001),
1601 Las Vegas, Nevada, June 2001. */
1602 /* However, we need to be careful when either scalar expression
1603 contains a FORALL index, as these can potentially change value
1604 during the scalarization/traversal of this array reference. */
1605 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1606 return GFC_DEP_OVERLAP;
1609 return GFC_DEP_NODEP;
1610 return GFC_DEP_EQUAL;
1614 /* Determine if an array ref, usually an array section specifies the
1615 entire array. In addition, if the second, pointer argument is
1616 provided, the function will return true if the reference is
1617 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1620 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1624 bool lbound_OK = true;
1625 bool ubound_OK = true;
1628 *contiguous = false;
1630 if (ref->type != REF_ARRAY)
1633 if (ref->u.ar.type == AR_FULL)
1640 if (ref->u.ar.type != AR_SECTION)
1645 for (i = 0; i < ref->u.ar.dimen; i++)
1647 /* If we have a single element in the reference, for the reference
1648 to be full, we need to ascertain that the array has a single
1649 element in this dimension and that we actually reference the
1651 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1653 /* This is unconditionally a contiguous reference if all the
1654 remaining dimensions are elements. */
1658 for (n = i + 1; n < ref->u.ar.dimen; n++)
1659 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1660 *contiguous = false;
1664 || !ref->u.ar.as->lower[i]
1665 || !ref->u.ar.as->upper[i]
1666 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1667 ref->u.ar.as->upper[i])
1668 || !ref->u.ar.start[i]
1669 || gfc_dep_compare_expr (ref->u.ar.start[i],
1670 ref->u.ar.as->lower[i]))
1676 /* Check the lower bound. */
1677 if (ref->u.ar.start[i]
1679 || !ref->u.ar.as->lower[i]
1680 || gfc_dep_compare_expr (ref->u.ar.start[i],
1681 ref->u.ar.as->lower[i])))
1683 /* Check the upper bound. */
1684 if (ref->u.ar.end[i]
1686 || !ref->u.ar.as->upper[i]
1687 || gfc_dep_compare_expr (ref->u.ar.end[i],
1688 ref->u.ar.as->upper[i])))
1690 /* Check the stride. */
1691 if (ref->u.ar.stride[i]
1692 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1695 /* This is unconditionally a contiguous reference as long as all
1696 the subsequent dimensions are elements. */
1700 for (n = i + 1; n < ref->u.ar.dimen; n++)
1701 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1702 *contiguous = false;
1705 if (!lbound_OK || !ubound_OK)
1712 /* Determine if a full array is the same as an array section with one
1713 variable limit. For this to be so, the strides must both be unity
1714 and one of either start == lower or end == upper must be true. */
1717 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1720 bool upper_or_lower;
1722 if (full_ref->type != REF_ARRAY)
1724 if (full_ref->u.ar.type != AR_FULL)
1726 if (ref->type != REF_ARRAY)
1728 if (ref->u.ar.type != AR_SECTION)
1731 for (i = 0; i < ref->u.ar.dimen; i++)
1733 /* If we have a single element in the reference, we need to check
1734 that the array has a single element and that we actually reference
1735 the correct element. */
1736 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1738 if (!full_ref->u.ar.as
1739 || !full_ref->u.ar.as->lower[i]
1740 || !full_ref->u.ar.as->upper[i]
1741 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1742 full_ref->u.ar.as->upper[i])
1743 || !ref->u.ar.start[i]
1744 || gfc_dep_compare_expr (ref->u.ar.start[i],
1745 full_ref->u.ar.as->lower[i]))
1749 /* Check the strides. */
1750 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1752 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1755 upper_or_lower = false;
1756 /* Check the lower bound. */
1757 if (ref->u.ar.start[i]
1759 && full_ref->u.ar.as->lower[i]
1760 && gfc_dep_compare_expr (ref->u.ar.start[i],
1761 full_ref->u.ar.as->lower[i]) == 0))
1762 upper_or_lower = true;
1763 /* Check the upper bound. */
1764 if (ref->u.ar.end[i]
1766 && full_ref->u.ar.as->upper[i]
1767 && gfc_dep_compare_expr (ref->u.ar.end[i],
1768 full_ref->u.ar.as->upper[i]) == 0))
1769 upper_or_lower = true;
1770 if (!upper_or_lower)
1777 /* Finds if two array references are overlapping or not.
1779 2 : array references are overlapping but reversal of one or
1780 more dimensions will clear the dependency.
1781 1 : array references are overlapping.
1782 0 : array references are identical or not overlapping. */
1785 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
1788 gfc_dependency fin_dep;
1789 gfc_dependency this_dep;
1791 this_dep = GFC_DEP_ERROR;
1792 fin_dep = GFC_DEP_ERROR;
1793 /* Dependencies due to pointers should already have been identified.
1794 We only need to check for overlapping array references. */
1796 while (lref && rref)
1798 /* We're resolving from the same base symbol, so both refs should be
1799 the same type. We traverse the reference chain until we find ranges
1800 that are not equal. */
1801 gcc_assert (lref->type == rref->type);
1805 /* The two ranges can't overlap if they are from different
1807 if (lref->u.c.component != rref->u.c.component)
1812 /* Substring overlaps are handled by the string assignment code
1813 if there is not an underlying dependency. */
1814 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1818 if (ref_same_as_full_array (lref, rref))
1821 if (ref_same_as_full_array (rref, lref))
1824 if (lref->u.ar.dimen != rref->u.ar.dimen)
1826 if (lref->u.ar.type == AR_FULL)
1827 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1829 else if (rref->u.ar.type == AR_FULL)
1830 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1837 for (n=0; n < lref->u.ar.dimen; n++)
1839 /* Assume dependency when either of array reference is vector
1841 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1842 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1845 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1846 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1847 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
1848 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1849 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1850 this_dep = gfc_check_element_vs_section (lref, rref, n);
1851 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1852 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1853 this_dep = gfc_check_element_vs_section (rref, lref, n);
1856 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1857 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1858 this_dep = gfc_check_element_vs_element (rref, lref, n);
1861 /* If any dimension doesn't overlap, we have no dependency. */
1862 if (this_dep == GFC_DEP_NODEP)
1865 /* Now deal with the loop reversal logic: This only works on
1866 ranges and is activated by setting
1867 reverse[n] == GFC_ENABLE_REVERSE
1868 The ability to reverse or not is set by previous conditions
1869 in this dimension. If reversal is not activated, the
1870 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
1871 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
1872 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1874 /* Set reverse if backward dependence and not inhibited. */
1875 if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
1876 reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
1877 GFC_REVERSE_SET : reverse[n];
1879 /* Set forward if forward dependence and not inhibited. */
1880 if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
1881 reverse[n] = (this_dep == GFC_DEP_FORWARD) ?
1882 GFC_FORWARD_SET : reverse[n];
1884 /* Flag up overlap if dependence not compatible with
1885 the overall state of the expression. */
1886 if (reverse && reverse[n] == GFC_REVERSE_SET
1887 && this_dep == GFC_DEP_FORWARD)
1889 reverse[n] = GFC_INHIBIT_REVERSE;
1890 this_dep = GFC_DEP_OVERLAP;
1892 else if (reverse && reverse[n] == GFC_FORWARD_SET
1893 && this_dep == GFC_DEP_BACKWARD)
1895 reverse[n] = GFC_INHIBIT_REVERSE;
1896 this_dep = GFC_DEP_OVERLAP;
1899 /* If no intention of reversing or reversing is explicitly
1900 inhibited, convert backward dependence to overlap. */
1901 if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
1902 || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
1903 this_dep = GFC_DEP_OVERLAP;
1906 /* Overlap codes are in order of priority. We only need to
1907 know the worst one.*/
1908 if (this_dep > fin_dep)
1912 /* If this is an equal element, we have to keep going until we find
1913 the "real" array reference. */
1914 if (lref->u.ar.type == AR_ELEMENT
1915 && rref->u.ar.type == AR_ELEMENT
1916 && fin_dep == GFC_DEP_EQUAL)
1919 /* Exactly matching and forward overlapping ranges don't cause a
1921 if (fin_dep < GFC_DEP_BACKWARD)
1924 /* Keep checking. We only have a dependency if
1925 subsequent references also overlap. */
1935 /* If we haven't seen any array refs then something went wrong. */
1936 gcc_assert (fin_dep != GFC_DEP_ERROR);
1938 /* Assume the worst if we nest to different depths. */
1942 return fin_dep == GFC_DEP_OVERLAP;