2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of GCC.
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
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
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/>. */
21 /* dependency.c -- 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. */
28 #include "coretypes.h"
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 if (e1 == NULL && e2 == NULL)
266 /* Remove any integer conversion functions to larger types. */
267 if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
268 && e1->value.function.isym->id == GFC_ISYM_CONVERSION
269 && e1->ts.type == BT_INTEGER)
271 args1 = e1->value.function.actual;
272 if (args1->expr->ts.type == BT_INTEGER
273 && e1->ts.kind > args1->expr->ts.kind)
277 if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
278 && e2->value.function.isym->id == GFC_ISYM_CONVERSION
279 && e2->ts.type == BT_INTEGER)
281 args2 = e2->value.function.actual;
282 if (args2->expr->ts.type == BT_INTEGER
283 && e2->ts.kind > args2->expr->ts.kind)
290 return gfc_dep_compare_expr (n1, n2);
292 return gfc_dep_compare_expr (n1, e2);
297 return gfc_dep_compare_expr (e1, n2);
300 if (e1->expr_type == EXPR_OP
301 && (e1->value.op.op == INTRINSIC_UPLUS
302 || e1->value.op.op == INTRINSIC_PARENTHESES))
303 return gfc_dep_compare_expr (e1->value.op.op1, e2);
304 if (e2->expr_type == EXPR_OP
305 && (e2->value.op.op == INTRINSIC_UPLUS
306 || e2->value.op.op == INTRINSIC_PARENTHESES))
307 return gfc_dep_compare_expr (e1, e2->value.op.op1);
309 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
311 /* Compare X+C vs. X, for INTEGER only. */
312 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
313 && e1->value.op.op2->ts.type == BT_INTEGER
314 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
315 return mpz_sgn (e1->value.op.op2->value.integer);
317 /* Compare P+Q vs. R+S. */
318 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
322 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
323 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
324 if (l == 0 && r == 0)
326 if (l == 0 && r > -2)
328 if (l > -2 && r == 0)
330 if (l == 1 && r == 1)
332 if (l == -1 && r == -1)
335 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
336 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
337 if (l == 0 && r == 0)
339 if (l == 0 && r > -2)
341 if (l > -2 && r == 0)
343 if (l == 1 && r == 1)
345 if (l == -1 && r == -1)
350 /* Compare X vs. X+C, for INTEGER only. */
351 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
353 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
354 && e2->value.op.op2->ts.type == BT_INTEGER
355 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
356 return -mpz_sgn (e2->value.op.op2->value.integer);
359 /* Compare X-C vs. X, for INTEGER only. */
360 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
362 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
363 && e1->value.op.op2->ts.type == BT_INTEGER
364 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
365 return -mpz_sgn (e1->value.op.op2->value.integer);
367 /* Compare P-Q vs. R-S. */
368 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
372 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
373 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
374 if (l == 0 && r == 0)
376 if (l > -2 && r == 0)
378 if (l == 0 && r > -2)
380 if (l == 1 && r == -1)
382 if (l == -1 && r == 1)
387 /* Compare A // B vs. C // D. */
389 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
390 && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
394 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
395 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
400 /* Left expressions of // compare equal, but
401 watch out for 'A ' // x vs. 'A' // x. */
402 gfc_expr *e1_left = e1->value.op.op1;
403 gfc_expr *e2_left = e2->value.op.op1;
405 if (e1_left->expr_type == EXPR_CONSTANT
406 && e2_left->expr_type == EXPR_CONSTANT
407 && e1_left->value.character.length
408 != e2_left->value.character.length)
414 /* Compare X vs. X-C, for INTEGER only. */
415 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
417 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
418 && e2->value.op.op2->ts.type == BT_INTEGER
419 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
420 return mpz_sgn (e2->value.op.op2->value.integer);
423 if (e1->expr_type != e2->expr_type)
426 switch (e1->expr_type)
429 /* Compare strings for equality. */
430 if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
431 return gfc_compare_string (e1, e2);
433 /* Compare REAL and COMPLEX constants. Because of the
434 traps and pitfalls associated with comparing
435 a + 1.0 with a + 0.5, check for equality only. */
436 if (e2->expr_type == EXPR_CONSTANT)
438 if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
440 if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
445 else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
447 if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
454 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
457 /* For INTEGER, all cases where e2 is not constant should have
458 been filtered out above. */
459 gcc_assert (e2->expr_type == EXPR_CONSTANT);
461 i = mpz_cmp (e1->value.integer, e2->value.integer);
469 if (are_identical_variables (e1, e2))
475 /* Intrinsic operators are the same if their operands are the same. */
476 if (e1->value.op.op != e2->value.op.op)
478 if (e1->value.op.op2 == 0)
480 i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
481 return i == 0 ? 0 : -2;
483 if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
484 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
486 else if (e1->value.op.op == INTRINSIC_TIMES
487 && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
488 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
489 /* Commutativity of multiplication; addition is handled above. */
495 return gfc_dep_compare_functions (e1, e2, false);
504 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
505 results are indeterminate). 'n' is the dimension to compare. */
508 is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
514 /* TODO: More sophisticated range comparison. */
515 gcc_assert (ar1 && ar2);
517 gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
521 /* Check for mismatching strides. A NULL stride means a stride of 1. */
524 i = gfc_expr_is_one (e1, -1);
525 if (i == -1 || i == 0)
530 i = gfc_expr_is_one (e2, -1);
531 if (i == -1 || i == 0)
536 i = gfc_dep_compare_expr (e1, e2);
540 /* The strides match. */
542 /* Check the range start. */
547 /* Use the bound of the array if no bound is specified. */
549 e1 = ar1->as->lower[n];
552 e2 = ar2->as->lower[n];
554 /* Check we have values for both. */
558 i = gfc_dep_compare_expr (e1, e2);
563 /* Check the range end. */
568 /* Use the bound of the array if no bound is specified. */
570 e1 = ar1->as->upper[n];
573 e2 = ar2->as->upper[n];
575 /* Check we have values for both. */
579 i = gfc_dep_compare_expr (e1, e2);
588 /* Some array-returning intrinsics can be implemented by reusing the
589 data from one of the array arguments. For example, TRANSPOSE does
590 not necessarily need to allocate new data: it can be implemented
591 by copying the original array's descriptor and simply swapping the
592 two dimension specifications.
594 If EXPR is a call to such an intrinsic, return the argument
595 whose data can be reused, otherwise return NULL. */
598 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
600 if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
603 switch (expr->value.function.isym->id)
605 case GFC_ISYM_TRANSPOSE:
606 return expr->value.function.actual->expr;
614 /* Return true if the result of reference REF can only be constructed
615 using a temporary array. */
618 gfc_ref_needs_temporary_p (gfc_ref *ref)
624 for (; ref; ref = ref->next)
628 /* Vector dimensions are generally not monotonic and must be
629 handled using a temporary. */
630 if (ref->u.ar.type == AR_SECTION)
631 for (n = 0; n < ref->u.ar.dimen; n++)
632 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
639 /* Within an array reference, character substrings generally
640 need a temporary. Character array strides are expressed as
641 multiples of the element size (consistent with other array
642 types), not in characters. */
654 gfc_is_data_pointer (gfc_expr *e)
658 if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
661 /* No subreference if it is a function */
662 gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
664 if (e->symtree->n.sym->attr.pointer)
667 for (ref = e->ref; ref; ref = ref->next)
668 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
675 /* Return true if array variable VAR could be passed to the same function
676 as argument EXPR without interfering with EXPR. INTENT is the intent
679 This is considerably less conservative than other dependencies
680 because many function arguments will already be copied into a
684 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
685 gfc_expr *expr, gfc_dep_check elemental)
689 gcc_assert (var->expr_type == EXPR_VARIABLE);
690 gcc_assert (var->rank > 0);
692 switch (expr->expr_type)
695 /* In case of elemental subroutines, there is no dependency
696 between two same-range array references. */
697 if (gfc_ref_needs_temporary_p (expr->ref)
698 || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
700 if (elemental == ELEM_DONT_CHECK_VARIABLE)
702 /* Too many false positive with pointers. */
703 if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
705 /* Elemental procedures forbid unspecified intents,
706 and we don't check dependencies for INTENT_IN args. */
707 gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
709 /* We are told not to check dependencies.
710 We do it, however, and issue a warning in case we find one.
711 If a dependency is found in the case
712 elemental == ELEM_CHECK_VARIABLE, we will generate
713 a temporary, so we don't need to bother the user. */
714 gfc_warning ("INTENT(%s) actual argument at %L might "
715 "interfere with actual argument at %L.",
716 intent == INTENT_OUT ? "OUT" : "INOUT",
717 &var->where, &expr->where);
727 return gfc_check_dependency (var, expr, 1);
730 if (intent != INTENT_IN)
732 arg = gfc_get_noncopying_intrinsic_argument (expr);
734 return gfc_check_argument_var_dependency (var, intent, arg,
738 if (elemental != NOT_ELEMENTAL)
740 if ((expr->value.function.esym
741 && expr->value.function.esym->attr.elemental)
742 || (expr->value.function.isym
743 && expr->value.function.isym->elemental))
744 return gfc_check_fncall_dependency (var, intent, NULL,
745 expr->value.function.actual,
746 ELEM_CHECK_VARIABLE);
748 if (gfc_inline_intrinsic_function_p (expr))
750 /* The TRANSPOSE case should have been caught in the
751 noncopying intrinsic case above. */
752 gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
754 return gfc_check_fncall_dependency (var, intent, NULL,
755 expr->value.function.actual,
756 ELEM_CHECK_VARIABLE);
762 /* In case of non-elemental procedures, there is no need to catch
763 dependencies, as we will make a temporary anyway. */
766 /* If the actual arg EXPR is an expression, we need to catch
767 a dependency between variables in EXPR and VAR,
768 an intent((IN)OUT) variable. */
769 if (expr->value.op.op1
770 && gfc_check_argument_var_dependency (var, intent,
772 ELEM_CHECK_VARIABLE))
774 else if (expr->value.op.op2
775 && gfc_check_argument_var_dependency (var, intent,
777 ELEM_CHECK_VARIABLE))
788 /* Like gfc_check_argument_var_dependency, but extended to any
789 array expression OTHER, not just variables. */
792 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
793 gfc_expr *expr, gfc_dep_check elemental)
795 switch (other->expr_type)
798 return gfc_check_argument_var_dependency (other, intent, expr, elemental);
801 other = gfc_get_noncopying_intrinsic_argument (other);
803 return gfc_check_argument_dependency (other, INTENT_IN, expr,
814 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
815 FNSYM is the function being called, or NULL if not known. */
818 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
819 gfc_symbol *fnsym, gfc_actual_arglist *actual,
820 gfc_dep_check elemental)
822 gfc_formal_arglist *formal;
825 formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
826 for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
830 /* Skip args which are not present. */
834 /* Skip other itself. */
838 /* Skip intent(in) arguments if OTHER itself is intent(in). */
839 if (formal && intent == INTENT_IN
840 && formal->sym->attr.intent == INTENT_IN)
843 if (gfc_check_argument_dependency (other, intent, expr, elemental))
851 /* Return 1 if e1 and e2 are equivalenced arrays, either
852 directly or indirectly; i.e., equivalence (a,b) for a and b
853 or equivalence (a,c),(b,c). This function uses the equiv_
854 lists, generated in trans-common(add_equivalences), that are
855 guaranteed to pick up indirect equivalences. We explicitly
856 check for overlap using the offset and length of the equivalence.
857 This function is symmetric.
858 TODO: This function only checks whether the full top-level
859 symbols overlap. An improved implementation could inspect
860 e1->ref and e2->ref to determine whether the actually accessed
861 portions of these variables/arrays potentially overlap. */
864 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
867 gfc_equiv_info *s, *fl1, *fl2;
869 gcc_assert (e1->expr_type == EXPR_VARIABLE
870 && e2->expr_type == EXPR_VARIABLE);
872 if (!e1->symtree->n.sym->attr.in_equivalence
873 || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
876 if (e1->symtree->n.sym->ns
877 && e1->symtree->n.sym->ns != gfc_current_ns)
878 l = e1->symtree->n.sym->ns->equiv_lists;
880 l = gfc_current_ns->equiv_lists;
882 /* Go through the equiv_lists and return 1 if the variables
883 e1 and e2 are members of the same group and satisfy the
884 requirement on their relative offsets. */
885 for (; l; l = l->next)
889 for (s = l->equiv; s; s = s->next)
891 if (s->sym == e1->symtree->n.sym)
897 if (s->sym == e2->symtree->n.sym)
907 /* Can these lengths be zero? */
908 if (fl1->length <= 0 || fl2->length <= 0)
910 /* These can't overlap if [f11,fl1+length] is before
911 [fl2,fl2+length], or [fl2,fl2+length] is before
912 [fl1,fl1+length], otherwise they do overlap. */
913 if (fl1->offset + fl1->length > fl2->offset
914 && fl2->offset + fl2->length > fl1->offset)
922 /* Return true if there is no possibility of aliasing because of a type
923 mismatch between all the possible pointer references and the
924 potential target. Note that this function is asymmetric in the
925 arguments and so must be called twice with the arguments exchanged. */
928 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
934 bool seen_component_ref;
936 if (expr1->expr_type != EXPR_VARIABLE
937 || expr1->expr_type != EXPR_VARIABLE)
940 sym1 = expr1->symtree->n.sym;
941 sym2 = expr2->symtree->n.sym;
943 /* Keep it simple for now. */
944 if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
947 if (sym1->attr.pointer)
949 if (gfc_compare_types (&sym1->ts, &sym2->ts))
953 /* This is a conservative check on the components of the derived type
954 if no component references have been seen. Since we will not dig
955 into the components of derived type components, we play it safe by
956 returning false. First we check the reference chain and then, if
957 no component references have been seen, the components. */
958 seen_component_ref = false;
959 if (sym1->ts.type == BT_DERIVED)
961 for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
963 if (ref1->type != REF_COMPONENT)
966 if (ref1->u.c.component->ts.type == BT_DERIVED)
969 if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
970 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
973 seen_component_ref = true;
977 if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
979 for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
981 if (cm1->ts.type == BT_DERIVED)
984 if ((sym2->attr.pointer || cm1->attr.pointer)
985 && gfc_compare_types (&cm1->ts, &sym2->ts))
994 /* Return true if the statement body redefines the condition. Returns
995 true if expr2 depends on expr1. expr1 should be a single term
996 suitable for the lhs of an assignment. The IDENTICAL flag indicates
997 whether array references to the same symbol with identical range
998 references count as a dependency or not. Used for forall and where
999 statements. Also used with functions returning arrays without a
1003 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1005 gfc_actual_arglist *actual;
1009 gcc_assert (expr1->expr_type == EXPR_VARIABLE);
1011 switch (expr2->expr_type)
1014 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1017 if (expr2->value.op.op2)
1018 return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1022 /* The interesting cases are when the symbols don't match. */
1023 if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1025 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1026 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1028 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1029 if (gfc_are_equivalenced_arrays (expr1, expr2))
1032 /* Symbols can only alias if they have the same type. */
1033 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1034 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1036 if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1040 /* If either variable is a pointer, assume the worst. */
1041 /* TODO: -fassume-no-pointer-aliasing */
1042 if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
1044 if (check_data_pointer_types (expr1, expr2)
1045 && check_data_pointer_types (expr2, expr1))
1052 gfc_symbol *sym1 = expr1->symtree->n.sym;
1053 gfc_symbol *sym2 = expr2->symtree->n.sym;
1054 if (sym1->attr.target && sym2->attr.target
1055 && ((sym1->attr.dummy && !sym1->attr.contiguous
1056 && (!sym1->attr.dimension
1057 || sym2->as->type == AS_ASSUMED_SHAPE))
1058 || (sym2->attr.dummy && !sym2->attr.contiguous
1059 && (!sym2->attr.dimension
1060 || sym2->as->type == AS_ASSUMED_SHAPE))))
1064 /* Otherwise distinct symbols have no dependencies. */
1071 /* Identical and disjoint ranges return 0,
1072 overlapping ranges return 1. */
1073 if (expr1->ref && expr2->ref)
1074 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
1079 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1082 /* Remember possible differences between elemental and
1083 transformational functions. All functions inside a FORALL
1085 for (actual = expr2->value.function.actual;
1086 actual; actual = actual->next)
1090 n = gfc_check_dependency (expr1, actual->expr, identical);
1101 /* Loop through the array constructor's elements. */
1102 for (c = gfc_constructor_first (expr2->value.constructor);
1103 c; c = gfc_constructor_next (c))
1105 /* If this is an iterator, assume the worst. */
1108 /* Avoid recursion in the common case. */
1109 if (c->expr->expr_type == EXPR_CONSTANT)
1111 if (gfc_check_dependency (expr1, c->expr, 1))
1122 /* Determines overlapping for two array sections. */
1124 static gfc_dependency
1125 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1141 int stride_comparison;
1142 int start_comparison;
1144 /* If they are the same range, return without more ado. */
1145 if (is_same_range (l_ar, r_ar, n))
1146 return GFC_DEP_EQUAL;
1148 l_start = l_ar->start[n];
1149 l_end = l_ar->end[n];
1150 l_stride = l_ar->stride[n];
1152 r_start = r_ar->start[n];
1153 r_end = r_ar->end[n];
1154 r_stride = r_ar->stride[n];
1156 /* If l_start is NULL take it from array specifier. */
1157 if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1158 l_start = l_ar->as->lower[n];
1159 /* If l_end is NULL take it from array specifier. */
1160 if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
1161 l_end = l_ar->as->upper[n];
1163 /* If r_start is NULL take it from array specifier. */
1164 if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
1165 r_start = r_ar->as->lower[n];
1166 /* If r_end is NULL take it from array specifier. */
1167 if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
1168 r_end = r_ar->as->upper[n];
1170 /* Determine whether the l_stride is positive or negative. */
1173 else if (l_stride->expr_type == EXPR_CONSTANT
1174 && l_stride->ts.type == BT_INTEGER)
1175 l_dir = mpz_sgn (l_stride->value.integer);
1176 else if (l_start && l_end)
1177 l_dir = gfc_dep_compare_expr (l_end, l_start);
1181 /* Determine whether the r_stride is positive or negative. */
1184 else if (r_stride->expr_type == EXPR_CONSTANT
1185 && r_stride->ts.type == BT_INTEGER)
1186 r_dir = mpz_sgn (r_stride->value.integer);
1187 else if (r_start && r_end)
1188 r_dir = gfc_dep_compare_expr (r_end, r_start);
1192 /* The strides should never be zero. */
1193 if (l_dir == 0 || r_dir == 0)
1194 return GFC_DEP_OVERLAP;
1196 /* Determine the relationship between the strides. Set stride_comparison to
1197 -2 if the dependency cannot be determined
1198 -1 if l_stride < r_stride
1199 0 if l_stride == r_stride
1200 1 if l_stride > r_stride
1201 as determined by gfc_dep_compare_expr. */
1203 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1205 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1206 r_stride ? r_stride : one_expr);
1208 if (l_start && r_start)
1209 start_comparison = gfc_dep_compare_expr (l_start, r_start);
1211 start_comparison = -2;
1213 gfc_free_expr (one_expr);
1215 /* Determine LHS upper and lower bounds. */
1221 else if (l_dir == -1)
1232 /* Determine RHS upper and lower bounds. */
1238 else if (r_dir == -1)
1249 /* Check whether the ranges are disjoint. */
1250 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1251 return GFC_DEP_NODEP;
1252 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1253 return GFC_DEP_NODEP;
1255 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1256 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1258 if (l_dir == 1 && r_dir == -1)
1259 return GFC_DEP_EQUAL;
1260 if (l_dir == -1 && r_dir == 1)
1261 return GFC_DEP_EQUAL;
1264 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1265 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1267 if (l_dir == 1 && r_dir == -1)
1268 return GFC_DEP_EQUAL;
1269 if (l_dir == -1 && r_dir == 1)
1270 return GFC_DEP_EQUAL;
1273 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1274 There is no dependency if the remainder of
1275 (l_start - r_start) / gcd(l_stride, r_stride) is
1278 - Handle cases where x is an expression.
1279 - Cases like a(1:4:2) = a(2:3) are still not handled.
1282 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1283 && (a)->ts.type == BT_INTEGER)
1285 if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
1286 && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
1294 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1295 mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
1297 mpz_fdiv_r (tmp, tmp, gcd);
1298 result = mpz_cmp_si (tmp, 0L);
1304 return GFC_DEP_NODEP;
1307 #undef IS_CONSTANT_INTEGER
1309 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1311 if (l_dir == 1 && r_dir == 1 &&
1312 (start_comparison == 0 || start_comparison == -1)
1313 && (stride_comparison == 0 || stride_comparison == -1))
1314 return GFC_DEP_FORWARD;
1316 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1317 x:y:-1 vs. x:y:-2. */
1318 if (l_dir == -1 && r_dir == -1 &&
1319 (start_comparison == 0 || start_comparison == 1)
1320 && (stride_comparison == 0 || stride_comparison == 1))
1321 return GFC_DEP_FORWARD;
1323 if (stride_comparison == 0 || stride_comparison == -1)
1325 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1328 /* Check for a(low:y:s) vs. a(z:x:s) or
1329 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1330 of low, which is always at least a forward dependence. */
1333 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1334 return GFC_DEP_FORWARD;
1338 if (stride_comparison == 0 || stride_comparison == 1)
1340 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1343 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1344 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1345 of high, which is always at least a forward dependence. */
1348 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1349 return GFC_DEP_FORWARD;
1354 if (stride_comparison == 0)
1356 /* From here, check for backwards dependencies. */
1357 /* x+1:y vs. x:z. */
1358 if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1359 return GFC_DEP_BACKWARD;
1361 /* x-1:y:-1 vs. x:z:-1. */
1362 if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1363 return GFC_DEP_BACKWARD;
1366 return GFC_DEP_OVERLAP;
1370 /* Determines overlapping for a single element and a section. */
1372 static gfc_dependency
1373 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1382 elem = lref->u.ar.start[n];
1384 return GFC_DEP_OVERLAP;
1387 start = ref->start[n] ;
1389 stride = ref->stride[n];
1391 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1392 start = ref->as->lower[n];
1393 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1394 end = ref->as->upper[n];
1396 /* Determine whether the stride is positive or negative. */
1399 else if (stride->expr_type == EXPR_CONSTANT
1400 && stride->ts.type == BT_INTEGER)
1401 s = mpz_sgn (stride->value.integer);
1405 /* Stride should never be zero. */
1407 return GFC_DEP_OVERLAP;
1409 /* Positive strides. */
1412 /* Check for elem < lower. */
1413 if (start && gfc_dep_compare_expr (elem, start) == -1)
1414 return GFC_DEP_NODEP;
1415 /* Check for elem > upper. */
1416 if (end && gfc_dep_compare_expr (elem, end) == 1)
1417 return GFC_DEP_NODEP;
1421 s = gfc_dep_compare_expr (start, end);
1422 /* Check for an empty range. */
1424 return GFC_DEP_NODEP;
1425 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1426 return GFC_DEP_EQUAL;
1429 /* Negative strides. */
1432 /* Check for elem > upper. */
1433 if (end && gfc_dep_compare_expr (elem, start) == 1)
1434 return GFC_DEP_NODEP;
1435 /* Check for elem < lower. */
1436 if (start && gfc_dep_compare_expr (elem, end) == -1)
1437 return GFC_DEP_NODEP;
1441 s = gfc_dep_compare_expr (start, end);
1442 /* Check for an empty range. */
1444 return GFC_DEP_NODEP;
1445 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1446 return GFC_DEP_EQUAL;
1449 /* Unknown strides. */
1453 return GFC_DEP_OVERLAP;
1454 s = gfc_dep_compare_expr (start, end);
1456 return GFC_DEP_OVERLAP;
1457 /* Assume positive stride. */
1460 /* Check for elem < lower. */
1461 if (gfc_dep_compare_expr (elem, start) == -1)
1462 return GFC_DEP_NODEP;
1463 /* Check for elem > upper. */
1464 if (gfc_dep_compare_expr (elem, end) == 1)
1465 return GFC_DEP_NODEP;
1467 /* Assume negative stride. */
1470 /* Check for elem > upper. */
1471 if (gfc_dep_compare_expr (elem, start) == 1)
1472 return GFC_DEP_NODEP;
1473 /* Check for elem < lower. */
1474 if (gfc_dep_compare_expr (elem, end) == -1)
1475 return GFC_DEP_NODEP;
1480 s = gfc_dep_compare_expr (elem, start);
1482 return GFC_DEP_EQUAL;
1483 if (s == 1 || s == -1)
1484 return GFC_DEP_NODEP;
1488 return GFC_DEP_OVERLAP;
1492 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1493 forall_index attribute. Return true if any variable may be
1494 being used as a FORALL index. Its safe to pessimistically
1495 return true, and assume a dependency. */
1498 contains_forall_index_p (gfc_expr *expr)
1500 gfc_actual_arglist *arg;
1508 switch (expr->expr_type)
1511 if (expr->symtree->n.sym->forall_index)
1516 if (contains_forall_index_p (expr->value.op.op1)
1517 || contains_forall_index_p (expr->value.op.op2))
1522 for (arg = expr->value.function.actual; arg; arg = arg->next)
1523 if (contains_forall_index_p (arg->expr))
1529 case EXPR_SUBSTRING:
1532 case EXPR_STRUCTURE:
1534 for (c = gfc_constructor_first (expr->value.constructor);
1535 c; gfc_constructor_next (c))
1536 if (contains_forall_index_p (c->expr))
1544 for (ref = expr->ref; ref; ref = ref->next)
1548 for (i = 0; i < ref->u.ar.dimen; i++)
1549 if (contains_forall_index_p (ref->u.ar.start[i])
1550 || contains_forall_index_p (ref->u.ar.end[i])
1551 || contains_forall_index_p (ref->u.ar.stride[i]))
1559 if (contains_forall_index_p (ref->u.ss.start)
1560 || contains_forall_index_p (ref->u.ss.end))
1571 /* Determines overlapping for two single element array references. */
1573 static gfc_dependency
1574 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1584 l_start = l_ar.start[n] ;
1585 r_start = r_ar.start[n] ;
1586 i = gfc_dep_compare_expr (r_start, l_start);
1588 return GFC_DEP_EQUAL;
1590 /* Treat two scalar variables as potentially equal. This allows
1591 us to prove that a(i,:) and a(j,:) have no dependency. See
1592 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1593 Proceedings of the International Conference on Parallel and
1594 Distributed Processing Techniques and Applications (PDPTA2001),
1595 Las Vegas, Nevada, June 2001. */
1596 /* However, we need to be careful when either scalar expression
1597 contains a FORALL index, as these can potentially change value
1598 during the scalarization/traversal of this array reference. */
1599 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1600 return GFC_DEP_OVERLAP;
1603 return GFC_DEP_NODEP;
1604 return GFC_DEP_EQUAL;
1608 /* Determine if an array ref, usually an array section specifies the
1609 entire array. In addition, if the second, pointer argument is
1610 provided, the function will return true if the reference is
1611 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1614 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1618 bool lbound_OK = true;
1619 bool ubound_OK = true;
1622 *contiguous = false;
1624 if (ref->type != REF_ARRAY)
1627 if (ref->u.ar.type == AR_FULL)
1634 if (ref->u.ar.type != AR_SECTION)
1639 for (i = 0; i < ref->u.ar.dimen; i++)
1641 /* If we have a single element in the reference, for the reference
1642 to be full, we need to ascertain that the array has a single
1643 element in this dimension and that we actually reference the
1645 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1647 /* This is unconditionally a contiguous reference if all the
1648 remaining dimensions are elements. */
1652 for (n = i + 1; n < ref->u.ar.dimen; n++)
1653 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1654 *contiguous = false;
1658 || !ref->u.ar.as->lower[i]
1659 || !ref->u.ar.as->upper[i]
1660 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1661 ref->u.ar.as->upper[i])
1662 || !ref->u.ar.start[i]
1663 || gfc_dep_compare_expr (ref->u.ar.start[i],
1664 ref->u.ar.as->lower[i]))
1670 /* Check the lower bound. */
1671 if (ref->u.ar.start[i]
1673 || !ref->u.ar.as->lower[i]
1674 || gfc_dep_compare_expr (ref->u.ar.start[i],
1675 ref->u.ar.as->lower[i])))
1677 /* Check the upper bound. */
1678 if (ref->u.ar.end[i]
1680 || !ref->u.ar.as->upper[i]
1681 || gfc_dep_compare_expr (ref->u.ar.end[i],
1682 ref->u.ar.as->upper[i])))
1684 /* Check the stride. */
1685 if (ref->u.ar.stride[i]
1686 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1689 /* This is unconditionally a contiguous reference as long as all
1690 the subsequent dimensions are elements. */
1694 for (n = i + 1; n < ref->u.ar.dimen; n++)
1695 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1696 *contiguous = false;
1699 if (!lbound_OK || !ubound_OK)
1706 /* Determine if a full array is the same as an array section with one
1707 variable limit. For this to be so, the strides must both be unity
1708 and one of either start == lower or end == upper must be true. */
1711 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1714 bool upper_or_lower;
1716 if (full_ref->type != REF_ARRAY)
1718 if (full_ref->u.ar.type != AR_FULL)
1720 if (ref->type != REF_ARRAY)
1722 if (ref->u.ar.type != AR_SECTION)
1725 for (i = 0; i < ref->u.ar.dimen; i++)
1727 /* If we have a single element in the reference, we need to check
1728 that the array has a single element and that we actually reference
1729 the correct element. */
1730 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1732 if (!full_ref->u.ar.as
1733 || !full_ref->u.ar.as->lower[i]
1734 || !full_ref->u.ar.as->upper[i]
1735 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1736 full_ref->u.ar.as->upper[i])
1737 || !ref->u.ar.start[i]
1738 || gfc_dep_compare_expr (ref->u.ar.start[i],
1739 full_ref->u.ar.as->lower[i]))
1743 /* Check the strides. */
1744 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1746 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1749 upper_or_lower = false;
1750 /* Check the lower bound. */
1751 if (ref->u.ar.start[i]
1753 && full_ref->u.ar.as->lower[i]
1754 && gfc_dep_compare_expr (ref->u.ar.start[i],
1755 full_ref->u.ar.as->lower[i]) == 0))
1756 upper_or_lower = true;
1757 /* Check the upper bound. */
1758 if (ref->u.ar.end[i]
1760 && full_ref->u.ar.as->upper[i]
1761 && gfc_dep_compare_expr (ref->u.ar.end[i],
1762 full_ref->u.ar.as->upper[i]) == 0))
1763 upper_or_lower = true;
1764 if (!upper_or_lower)
1771 /* Finds if two array references are overlapping or not.
1773 2 : array references are overlapping but reversal of one or
1774 more dimensions will clear the dependency.
1775 1 : array references are overlapping.
1776 0 : array references are identical or not overlapping. */
1779 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
1782 gfc_dependency fin_dep;
1783 gfc_dependency this_dep;
1785 this_dep = GFC_DEP_ERROR;
1786 fin_dep = GFC_DEP_ERROR;
1787 /* Dependencies due to pointers should already have been identified.
1788 We only need to check for overlapping array references. */
1790 while (lref && rref)
1792 /* We're resolving from the same base symbol, so both refs should be
1793 the same type. We traverse the reference chain until we find ranges
1794 that are not equal. */
1795 gcc_assert (lref->type == rref->type);
1799 /* The two ranges can't overlap if they are from different
1801 if (lref->u.c.component != rref->u.c.component)
1806 /* Substring overlaps are handled by the string assignment code
1807 if there is not an underlying dependency. */
1808 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1812 if (ref_same_as_full_array (lref, rref))
1815 if (ref_same_as_full_array (rref, lref))
1818 if (lref->u.ar.dimen != rref->u.ar.dimen)
1820 if (lref->u.ar.type == AR_FULL)
1821 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1823 else if (rref->u.ar.type == AR_FULL)
1824 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1831 for (n=0; n < lref->u.ar.dimen; n++)
1833 /* Assume dependency when either of array reference is vector
1835 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1836 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1839 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1840 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1841 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
1842 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1843 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1844 this_dep = gfc_check_element_vs_section (lref, rref, n);
1845 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1846 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1847 this_dep = gfc_check_element_vs_section (rref, lref, n);
1850 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1851 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1852 this_dep = gfc_check_element_vs_element (rref, lref, n);
1855 /* If any dimension doesn't overlap, we have no dependency. */
1856 if (this_dep == GFC_DEP_NODEP)
1859 /* Now deal with the loop reversal logic: This only works on
1860 ranges and is activated by setting
1861 reverse[n] == GFC_ENABLE_REVERSE
1862 The ability to reverse or not is set by previous conditions
1863 in this dimension. If reversal is not activated, the
1864 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
1865 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
1866 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1868 /* Set reverse if backward dependence and not inhibited. */
1869 if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
1870 reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
1871 GFC_REVERSE_SET : reverse[n];
1873 /* Set forward if forward dependence and not inhibited. */
1874 if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
1875 reverse[n] = (this_dep == GFC_DEP_FORWARD) ?
1876 GFC_FORWARD_SET : reverse[n];
1878 /* Flag up overlap if dependence not compatible with
1879 the overall state of the expression. */
1880 if (reverse && reverse[n] == GFC_REVERSE_SET
1881 && this_dep == GFC_DEP_FORWARD)
1883 reverse[n] = GFC_INHIBIT_REVERSE;
1884 this_dep = GFC_DEP_OVERLAP;
1886 else if (reverse && reverse[n] == GFC_FORWARD_SET
1887 && this_dep == GFC_DEP_BACKWARD)
1889 reverse[n] = GFC_INHIBIT_REVERSE;
1890 this_dep = GFC_DEP_OVERLAP;
1893 /* If no intention of reversing or reversing is explicitly
1894 inhibited, convert backward dependence to overlap. */
1895 if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
1896 || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
1897 this_dep = GFC_DEP_OVERLAP;
1900 /* Overlap codes are in order of priority. We only need to
1901 know the worst one.*/
1902 if (this_dep > fin_dep)
1906 /* If this is an equal element, we have to keep going until we find
1907 the "real" array reference. */
1908 if (lref->u.ar.type == AR_ELEMENT
1909 && rref->u.ar.type == AR_ELEMENT
1910 && fin_dep == GFC_DEP_EQUAL)
1913 /* Exactly matching and forward overlapping ranges don't cause a
1915 if (fin_dep < GFC_DEP_BACKWARD)
1918 /* Keep checking. We only have a dependency if
1919 subsequent references also overlap. */
1929 /* If we haven't seen any array refs then something went wrong. */
1930 gcc_assert (fin_dep != GFC_DEP_ERROR);
1932 /* Assume the worst if we nest to different depths. */
1936 return fin_dep == GFC_DEP_OVERLAP;