gcc/fortran/dependency.c

   1 /* Dependency analysis
   2    Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5
   6 This file is part of GCC.
   7
   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
  11 version.
  12
  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
  16 for more details.
  17
  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/>.  */
  21
  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.  */
  26
  27 #include "config.h"
  28 #include "gfortran.h"
  29 #include "dependency.h"
  30
  31 /* static declarations */
  32 /* Enums  */
  33 enum range {LHS, RHS, MID};
  34
  35 /* Dependency types.  These must be in reverse order of priority.  */
  36 typedef enum
  37 {
  38   GFC_DEP_ERROR,
  39   GFC_DEP_EQUAL,        /* Identical Ranges.  */
  40   GFC_DEP_FORWARD,      /* e.g., a(1:3), a(2:4).  */
  41   GFC_DEP_OVERLAP,      /* May overlap in some other way.  */
  42   GFC_DEP_NODEP         /* Distinct ranges.  */
  43 }
  44 gfc_dependency;
  45
  46 /* Macros */
  47 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
  48
  49
  50 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
  51    def if the value could not be determined.  */
  52
  53 int
  54 gfc_expr_is_one (gfc_expr *expr, int def)
  55 {
  56   gcc_assert (expr != NULL);
  57
  58   if (expr->expr_type != EXPR_CONSTANT)
  59     return def;
  60
  61   if (expr->ts.type != BT_INTEGER)
  62     return def;
  63
  64   return mpz_cmp_si (expr->value.integer, 1) == 0;
  65 }
  66
  67
  68 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
  69    and -2 if the relationship could not be determined.  */
  70
  71 int
  72 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
  73 {
  74   gfc_actual_arglist *args1;
  75   gfc_actual_arglist *args2;
  76   int i;
  77
  78   if (e1->expr_type == EXPR_OP
  79       && (e1->value.op.op == INTRINSIC_UPLUS
  80           || e1->value.op.op == INTRINSIC_PARENTHESES))
  81     return gfc_dep_compare_expr (e1->value.op.op1, e2);
  82   if (e2->expr_type == EXPR_OP
  83       && (e2->value.op.op == INTRINSIC_UPLUS
  84           || e2->value.op.op == INTRINSIC_PARENTHESES))
  85     return gfc_dep_compare_expr (e1, e2->value.op.op1);
  86
  87   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
  88     {
  89       /* Compare X+C vs. X.  */
  90       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
  91           && e1->value.op.op2->ts.type == BT_INTEGER
  92           && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
  93         return mpz_sgn (e1->value.op.op2->value.integer);
  94
  95       /* Compare P+Q vs. R+S.  */
  96       if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
  97         {
  98           int l, r;
  99
 100           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 101           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 102           if (l == 0 && r == 0)
 103             return 0;
 104           if (l == 0 && r != -2)
 105             return r;
 106           if (l != -2 && r == 0)
 107             return l;
 108           if (l == 1 && r == 1)
 109             return 1;
 110           if (l == -1 && r == -1)
 111             return -1;
 112
 113           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
 114           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
 115           if (l == 0 && r == 0)
 116             return 0;
 117           if (l == 0 && r != -2)
 118             return r;
 119           if (l != -2 && r == 0)
 120             return l;
 121           if (l == 1 && r == 1)
 122             return 1;
 123           if (l == -1 && r == -1)
 124             return -1;
 125         }
 126     }
 127
 128   /* Compare X vs. X+C.  */
 129   if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
 130     {
 131       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
 132           && e2->value.op.op2->ts.type == BT_INTEGER
 133           && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
 134         return -mpz_sgn (e2->value.op.op2->value.integer);
 135     }
 136
 137   /* Compare X-C vs. X.  */
 138   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
 139     {
 140       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
 141           && e1->value.op.op2->ts.type == BT_INTEGER
 142           && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
 143         return -mpz_sgn (e1->value.op.op2->value.integer);
 144
 145       /* Compare P-Q vs. R-S.  */
 146       if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 147         {
 148           int l, r;
 149
 150           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 151           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 152           if (l == 0 && r == 0)
 153             return 0;
 154           if (l != -2 && r == 0)
 155             return l;
 156           if (l == 0 && r != -2)
 157             return -r;
 158           if (l == 1 && r == -1)
 159             return 1;
 160           if (l == -1 && r == 1)
 161             return -1;
 162         }
 163     }
 164
 165   /* Compare X vs. X-C.  */
 166   if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 167     {
 168       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
 169           && e2->value.op.op2->ts.type == BT_INTEGER
 170           && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
 171         return mpz_sgn (e2->value.op.op2->value.integer);
 172     }
 173
 174   if (e1->expr_type != e2->expr_type)
 175     return -2;
 176
 177   switch (e1->expr_type)
 178     {
 179     case EXPR_CONSTANT:
 180       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
 181         return -2;
 182
 183       i = mpz_cmp (e1->value.integer, e2->value.integer);
 184       if (i == 0)
 185         return 0;
 186       else if (i < 0)
 187         return -1;
 188       return 1;
 189
 190     case EXPR_VARIABLE:
 191       if (e1->ref || e2->ref)
 192         return -2;
 193       if (e1->symtree->n.sym == e2->symtree->n.sym)
 194         return 0;
 195       return -2;
 196
 197     case EXPR_OP:
 198       /* Intrinsic operators are the same if their operands are the same.  */
 199       if (e1->value.op.op != e2->value.op.op)
 200         return -2;
 201       if (e1->value.op.op2 == 0)
 202         {
 203           i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 204           return i == 0 ? 0 : -2;
 205         }
 206       if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
 207           && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
 208         return 0;
 209       /* TODO Handle commutative binary operators here?  */
 210       return -2;
 211
 212     case EXPR_FUNCTION:
 213       /* We can only compare calls to the same intrinsic function.  */
 214       if (e1->value.function.isym == 0 || e2->value.function.isym == 0
 215           || e1->value.function.isym != e2->value.function.isym)
 216         return -2;
 217
 218       args1 = e1->value.function.actual;
 219       args2 = e2->value.function.actual;
 220
 221       /* We should list the "constant" intrinsic functions.  Those
 222          without side-effects that provide equal results given equal
 223          argument lists.  */
 224       switch (e1->value.function.isym->id)
 225         {
 226         case GFC_ISYM_CONVERSION:
 227           /* Handle integer extensions specially, as __convert_i4_i8
 228              is not only "constant" but also "unary" and "increasing".  */
 229           if (args1 && !args1->next
 230               && args2 && !args2->next
 231               && e1->ts.type == BT_INTEGER
 232               && args1->expr->ts.type == BT_INTEGER
 233               && e1->ts.kind > args1->expr->ts.kind
 234               && e2->ts.type == e1->ts.type
 235               && e2->ts.kind == e1->ts.kind
 236               && args2->expr->ts.type == args1->expr->ts.type
 237               && args2->expr->ts.kind == args2->expr->ts.kind)
 238             return gfc_dep_compare_expr (args1->expr, args2->expr);
 239           break;
 240
 241         case GFC_ISYM_REAL:
 242         case GFC_ISYM_LOGICAL:
 243         case GFC_ISYM_DBLE:
 244           break;
 245
 246         default:
 247           return -2;
 248         }
 249
 250       /* Compare the argument lists for equality.  */
 251       while (args1 && args2)
 252         {
 253           if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
 254             return -2;
 255           args1 = args1->next;
 256           args2 = args2->next;
 257         }
 258       return (args1 || args2) ? -2 : 0;
 259
 260     default:
 261       return -2;
 262     }
 263 }
 264
 265
 266 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
 267    if the results are indeterminate.  N is the dimension to compare.  */
 268
 269 int
 270 gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
 271 {
 272   gfc_expr *e1;
 273   gfc_expr *e2;
 274   int i;
 275
 276   /* TODO: More sophisticated range comparison.  */
 277   gcc_assert (ar1 && ar2);
 278
 279   gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
 280
 281   e1 = ar1->stride[n];
 282   e2 = ar2->stride[n];
 283   /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
 284   if (e1 && !e2)
 285     {
 286       i = gfc_expr_is_one (e1, -1);
 287       if (i == -1)
 288         return def;
 289       else if (i == 0)
 290         return 0;
 291     }
 292   else if (e2 && !e1)
 293     {
 294       i = gfc_expr_is_one (e2, -1);
 295       if (i == -1)
 296         return def;
 297       else if (i == 0)
 298         return 0;
 299     }
 300   else if (e1 && e2)
 301     {
 302       i = gfc_dep_compare_expr (e1, e2);
 303       if (i == -2)
 304         return def;
 305       else if (i != 0)
 306         return 0;
 307     }
 308   /* The strides match.  */
 309
 310   /* Check the range start.  */
 311   e1 = ar1->start[n];
 312   e2 = ar2->start[n];
 313   if (e1 || e2)
 314     {
 315       /* Use the bound of the array if no bound is specified.  */
 316       if (ar1->as && !e1)
 317         e1 = ar1->as->lower[n];
 318
 319       if (ar2->as && !e2)
 320         e2 = ar2->as->lower[n];
 321
 322       /* Check we have values for both.  */
 323       if (!(e1 && e2))
 324         return def;
 325
 326       i = gfc_dep_compare_expr (e1, e2);
 327       if (i == -2)
 328         return def;
 329       else if (i != 0)
 330         return 0;
 331     }
 332
 333   /* Check the range end.  */
 334   e1 = ar1->end[n];
 335   e2 = ar2->end[n];
 336   if (e1 || e2)
 337     {
 338       /* Use the bound of the array if no bound is specified.  */
 339       if (ar1->as && !e1)
 340         e1 = ar1->as->upper[n];
 341
 342       if (ar2->as && !e2)
 343         e2 = ar2->as->upper[n];
 344
 345       /* Check we have values for both.  */
 346       if (!(e1 && e2))
 347         return def;
 348
 349       i = gfc_dep_compare_expr (e1, e2);
 350       if (i == -2)
 351         return def;
 352       else if (i != 0)
 353         return 0;
 354     }
 355
 356   return 1;
 357 }
 358
 359
 360 /* Some array-returning intrinsics can be implemented by reusing the
 361    data from one of the array arguments.  For example, TRANSPOSE does
 362    not necessarily need to allocate new data: it can be implemented
 363    by copying the original array's descriptor and simply swapping the
 364    two dimension specifications.
 365
 366    If EXPR is a call to such an intrinsic, return the argument
 367    whose data can be reused, otherwise return NULL.  */
 368
 369 gfc_expr *
 370 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
 371 {
 372   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
 373     return NULL;
 374
 375   switch (expr->value.function.isym->id)
 376     {
 377     case GFC_ISYM_TRANSPOSE:
 378       return expr->value.function.actual->expr;
 379
 380     default:
 381       return NULL;
 382     }
 383 }
 384
 385
 386 /* Return true if the result of reference REF can only be constructed
 387    using a temporary array.  */
 388
 389 bool
 390 gfc_ref_needs_temporary_p (gfc_ref *ref)
 391 {
 392   int n;
 393   bool subarray_p;
 394
 395   subarray_p = false;
 396   for (; ref; ref = ref->next)
 397     switch (ref->type)
 398       {
 399       case REF_ARRAY:
 400         /* Vector dimensions are generally not monotonic and must be
 401            handled using a temporary.  */
 402         if (ref->u.ar.type == AR_SECTION)
 403           for (n = 0; n < ref->u.ar.dimen; n++)
 404             if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 405               return true;
 406
 407         subarray_p = true;
 408         break;
 409
 410       case REF_SUBSTRING:
 411         /* Within an array reference, character substrings generally
 412            need a temporary.  Character array strides are expressed as
 413            multiples of the element size (consistent with other array
 414            types), not in characters.  */
 415         return subarray_p;
 416
 417       case REF_COMPONENT:
 418         break;
 419       }
 420
 421   return false;
 422 }
 423
 424
 425 int
 426 gfc_is_data_pointer (gfc_expr *e)
 427 {
 428   gfc_ref *ref;
 429
 430   if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
 431     return 0;
 432
 433   /* No subreference if it is a function  */
 434   gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
 435
 436   if (e->symtree->n.sym->attr.pointer)
 437     return 1;
 438
 439   for (ref = e->ref; ref; ref = ref->next)
 440     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
 441       return 1;
 442
 443   return 0;
 444 }
 445
 446
 447 /* Return true if array variable VAR could be passed to the same function
 448    as argument EXPR without interfering with EXPR.  INTENT is the intent
 449    of VAR.
 450
 451    This is considerably less conservative than other dependencies
 452    because many function arguments will already be copied into a
 453    temporary.  */
 454
 455 static int
 456 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
 457                                    gfc_expr *expr, gfc_dep_check elemental)
 458 {
 459   gfc_expr *arg;
 460
 461   gcc_assert (var->expr_type == EXPR_VARIABLE);
 462   gcc_assert (var->rank > 0);
 463
 464   switch (expr->expr_type)
 465     {
 466     case EXPR_VARIABLE:
 467       /* In case of elemental subroutines, there is no dependency
 468          between two same-range array references.  */
 469       if (gfc_ref_needs_temporary_p (expr->ref)
 470           || gfc_check_dependency (var, expr, !elemental))
 471         {
 472           if (elemental == ELEM_DONT_CHECK_VARIABLE)
 473             {
 474               /* Too many false positive with pointers.  */
 475               if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
 476                 {
 477                   /* Elemental procedures forbid unspecified intents,
 478                      and we don't check dependencies for INTENT_IN args.  */
 479                   gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
 480
 481                   /* We are told not to check dependencies.
 482                      We do it, however, and issue a warning in case we find one.
 483                      If a dependency is found in the case
 484                      elemental == ELEM_CHECK_VARIABLE, we will generate
 485                      a temporary, so we don't need to bother the user.  */
 486                   gfc_warning ("INTENT(%s) actual argument at %L might "
 487                                "interfere with actual argument at %L.",
 488                                intent == INTENT_OUT ? "OUT" : "INOUT",
 489                                &var->where, &expr->where);
 490                 }
 491               return 0;
 492             }
 493           else
 494             return 1;
 495         }
 496       return 0;
 497
 498     case EXPR_ARRAY:
 499       return gfc_check_dependency (var, expr, 1);
 500
 501     case EXPR_FUNCTION:
 502       if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
 503           && (arg = gfc_get_noncopying_intrinsic_argument (expr))
 504           && gfc_check_argument_var_dependency (var, intent, arg, elemental))
 505         return 1;
 506       if (elemental)
 507         {
 508           if ((expr->value.function.esym
 509                && expr->value.function.esym->attr.elemental)
 510               || (expr->value.function.isym
 511                   && expr->value.function.isym->elemental))
 512             return gfc_check_fncall_dependency (var, intent, NULL,
 513                                                 expr->value.function.actual,
 514                                                 ELEM_CHECK_VARIABLE);
 515         }
 516       return 0;
 517
 518     case EXPR_OP:
 519       /* In case of non-elemental procedures, there is no need to catch
 520          dependencies, as we will make a temporary anyway.  */
 521       if (elemental)
 522         {
 523           /* If the actual arg EXPR is an expression, we need to catch
 524              a dependency between variables in EXPR and VAR,
 525              an intent((IN)OUT) variable.  */
 526           if (expr->value.op.op1
 527               && gfc_check_argument_var_dependency (var, intent,
 528                                                     expr->value.op.op1,
 529                                                     ELEM_CHECK_VARIABLE))
 530             return 1;
 531           else if (expr->value.op.op2
 532                    && gfc_check_argument_var_dependency (var, intent,
 533                                                          expr->value.op.op2,
 534                                                          ELEM_CHECK_VARIABLE))
 535             return 1;
 536         }
 537       return 0;
 538
 539     default:
 540       return 0;
 541     }
 542 }
 543
 544
 545 /* Like gfc_check_argument_var_dependency, but extended to any
 546    array expression OTHER, not just variables.  */
 547
 548 static int
 549 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
 550                                gfc_expr *expr, gfc_dep_check elemental)
 551 {
 552   switch (other->expr_type)
 553     {
 554     case EXPR_VARIABLE:
 555       return gfc_check_argument_var_dependency (other, intent, expr, elemental);
 556
 557     case EXPR_FUNCTION:
 558       if (other->inline_noncopying_intrinsic)
 559         {
 560           other = gfc_get_noncopying_intrinsic_argument (other);
 561           return gfc_check_argument_dependency (other, INTENT_IN, expr,
 562                                                 elemental);
 563         }
 564       return 0;
 565
 566     default:
 567       return 0;
 568     }
 569 }
 570
 571
 572 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
 573    FNSYM is the function being called, or NULL if not known.  */
 574
 575 int
 576 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
 577                              gfc_symbol *fnsym, gfc_actual_arglist *actual,
 578                              gfc_dep_check elemental)
 579 {
 580   gfc_formal_arglist *formal;
 581   gfc_expr *expr;
 582
 583   formal = fnsym ? fnsym->formal : NULL;
 584   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
 585     {
 586       expr = actual->expr;
 587
 588       /* Skip args which are not present.  */
 589       if (!expr)
 590         continue;
 591
 592       /* Skip other itself.  */
 593       if (expr == other)
 594         continue;
 595
 596       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
 597       if (formal && intent == INTENT_IN
 598           && formal->sym->attr.intent == INTENT_IN)
 599         continue;
 600
 601       if (gfc_check_argument_dependency (other, intent, expr, elemental))
 602         return 1;
 603     }
 604
 605   return 0;
 606 }
 607
 608
 609 /* Return 1 if e1 and e2 are equivalenced arrays, either
 610    directly or indirectly; i.e., equivalence (a,b) for a and b
 611    or equivalence (a,c),(b,c).  This function uses the equiv_
 612    lists, generated in trans-common(add_equivalences), that are
 613    guaranteed to pick up indirect equivalences.  We explicitly
 614    check for overlap using the offset and length of the equivalence.
 615    This function is symmetric.
 616    TODO: This function only checks whether the full top-level
 617    symbols overlap.  An improved implementation could inspect
 618    e1->ref and e2->ref to determine whether the actually accessed
 619    portions of these variables/arrays potentially overlap.  */
 620
 621 int
 622 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 623 {
 624   gfc_equiv_list *l;
 625   gfc_equiv_info *s, *fl1, *fl2;
 626
 627   gcc_assert (e1->expr_type == EXPR_VARIABLE
 628               && e2->expr_type == EXPR_VARIABLE);
 629
 630   if (!e1->symtree->n.sym->attr.in_equivalence
 631       || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
 632     return 0;
 633
 634   if (e1->symtree->n.sym->ns
 635         && e1->symtree->n.sym->ns != gfc_current_ns)
 636     l = e1->symtree->n.sym->ns->equiv_lists;
 637   else
 638     l = gfc_current_ns->equiv_lists;
 639
 640   /* Go through the equiv_lists and return 1 if the variables
 641      e1 and e2 are members of the same group and satisfy the
 642      requirement on their relative offsets.  */
 643   for (; l; l = l->next)
 644     {
 645       fl1 = NULL;
 646       fl2 = NULL;
 647       for (s = l->equiv; s; s = s->next)
 648         {
 649           if (s->sym == e1->symtree->n.sym)
 650             {
 651               fl1 = s;
 652               if (fl2)
 653                 break;
 654             }
 655           if (s->sym == e2->symtree->n.sym)
 656             {
 657               fl2 = s;
 658               if (fl1)
 659                 break;
 660             }
 661         }
 662
 663       if (s)
 664         {
 665           /* Can these lengths be zero?  */
 666           if (fl1->length <= 0 || fl2->length <= 0)
 667             return 1;
 668           /* These can't overlap if [f11,fl1+length] is before
 669              [fl2,fl2+length], or [fl2,fl2+length] is before
 670              [fl1,fl1+length], otherwise they do overlap.  */
 671           if (fl1->offset + fl1->length > fl2->offset
 672               && fl2->offset + fl2->length > fl1->offset)
 673             return 1;
 674         }
 675     }
 676   return 0;
 677 }
 678
 679
 680 /* Return true if the statement body redefines the condition.  Returns
 681    true if expr2 depends on expr1.  expr1 should be a single term
 682    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 683    whether array references to the same symbol with identical range
 684    references count as a dependency or not.  Used for forall and where
 685    statements.  Also used with functions returning arrays without a
 686    temporary.  */
 687
 688 int
 689 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
 690 {
 691   gfc_actual_arglist *actual;
 692   gfc_constructor *c;
 693   int n;
 694
 695   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 696
 697   switch (expr2->expr_type)
 698     {
 699     case EXPR_OP:
 700       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
 701       if (n)
 702         return n;
 703       if (expr2->value.op.op2)
 704         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
 705       return 0;
 706
 707     case EXPR_VARIABLE:
 708       /* The interesting cases are when the symbols don't match.  */
 709       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 710         {
 711           gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
 712           gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
 713
 714           /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
 715           if (gfc_are_equivalenced_arrays (expr1, expr2))
 716             return 1;
 717
 718           /* Symbols can only alias if they have the same type.  */
 719           if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
 720               && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
 721             {
 722               if (ts1->type != ts2->type || ts1->kind != ts2->kind)
 723                 return 0;
 724             }
 725
 726           /* If either variable is a pointer, assume the worst.  */
 727           /* TODO: -fassume-no-pointer-aliasing */
 728           if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
 729             return 1;
 730
 731           /* Otherwise distinct symbols have no dependencies.  */
 732           return 0;
 733         }
 734
 735       if (identical)
 736         return 1;
 737
 738       /* Identical and disjoint ranges return 0,
 739          overlapping ranges return 1.  */
 740       if (expr1->ref && expr2->ref)
 741         return gfc_dep_resolver (expr1->ref, expr2->ref);
 742
 743       return 1;
 744
 745     case EXPR_FUNCTION:
 746       if (expr2->inline_noncopying_intrinsic)
 747         identical = 1;
 748       /* Remember possible differences between elemental and
 749          transformational functions.  All functions inside a FORALL
 750          will be pure.  */
 751       for (actual = expr2->value.function.actual;
 752            actual; actual = actual->next)
 753         {
 754           if (!actual->expr)
 755             continue;
 756           n = gfc_check_dependency (expr1, actual->expr, identical);
 757           if (n)
 758             return n;
 759         }
 760       return 0;
 761
 762     case EXPR_CONSTANT:
 763     case EXPR_NULL:
 764       return 0;
 765
 766     case EXPR_ARRAY:
 767       /* Loop through the array constructor's elements.  */
 768       for (c = expr2->value.constructor; c; c = c->next)
 769         {
 770           /* If this is an iterator, assume the worst.  */
 771           if (c->iterator)
 772             return 1;
 773           /* Avoid recursion in the common case.  */
 774           if (c->expr->expr_type == EXPR_CONSTANT)
 775             continue;
 776           if (gfc_check_dependency (expr1, c->expr, 1))
 777             return 1;
 778         }
 779       return 0;
 780
 781     default:
 782       return 1;
 783     }
 784 }
 785
 786
 787 /* Determines overlapping for two array sections.  */
 788
 789 static gfc_dependency
 790 gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n)
 791 {
 792   gfc_array_ref l_ar;
 793   gfc_expr *l_start;
 794   gfc_expr *l_end;
 795   gfc_expr *l_stride;
 796   gfc_expr *l_lower;
 797   gfc_expr *l_upper;
 798   int l_dir;
 799
 800   gfc_array_ref r_ar;
 801   gfc_expr *r_start;
 802   gfc_expr *r_end;
 803   gfc_expr *r_stride;
 804   gfc_expr *r_lower;
 805   gfc_expr *r_upper;
 806   int r_dir;
 807
 808   l_ar = lref->u.ar;
 809   r_ar = rref->u.ar;
 810
 811   /* If they are the same range, return without more ado.  */
 812   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 813     return GFC_DEP_EQUAL;
 814
 815   l_start = l_ar.start[n];
 816   l_end = l_ar.end[n];
 817   l_stride = l_ar.stride[n];
 818
 819   r_start = r_ar.start[n];
 820   r_end = r_ar.end[n];
 821   r_stride = r_ar.stride[n];
 822
 823   /* If l_start is NULL take it from array specifier.  */
 824   if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as))
 825     l_start = l_ar.as->lower[n];
 826   /* If l_end is NULL take it from array specifier.  */
 827   if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as))
 828     l_end = l_ar.as->upper[n];
 829
 830   /* If r_start is NULL take it from array specifier.  */
 831   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 832     r_start = r_ar.as->lower[n];
 833   /* If r_end is NULL take it from array specifier.  */
 834   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 835     r_end = r_ar.as->upper[n];
 836
 837   /* Determine whether the l_stride is positive or negative.  */
 838   if (!l_stride)
 839     l_dir = 1;
 840   else if (l_stride->expr_type == EXPR_CONSTANT
 841            && l_stride->ts.type == BT_INTEGER)
 842     l_dir = mpz_sgn (l_stride->value.integer);
 843   else if (l_start && l_end)
 844     l_dir = gfc_dep_compare_expr (l_end, l_start);
 845   else
 846     l_dir = -2;
 847
 848   /* Determine whether the r_stride is positive or negative.  */
 849   if (!r_stride)
 850     r_dir = 1;
 851   else if (r_stride->expr_type == EXPR_CONSTANT
 852            && r_stride->ts.type == BT_INTEGER)
 853     r_dir = mpz_sgn (r_stride->value.integer);
 854   else if (r_start && r_end)
 855     r_dir = gfc_dep_compare_expr (r_end, r_start);
 856   else
 857     r_dir = -2;
 858
 859   /* The strides should never be zero.  */
 860   if (l_dir == 0 || r_dir == 0)
 861     return GFC_DEP_OVERLAP;
 862
 863   /* Determine LHS upper and lower bounds.  */
 864   if (l_dir == 1)
 865     {
 866       l_lower = l_start;
 867       l_upper = l_end;
 868     }
 869   else if (l_dir == -1)
 870     {
 871       l_lower = l_end;
 872       l_upper = l_start;
 873     }
 874   else
 875     {
 876       l_lower = NULL;
 877       l_upper = NULL;
 878     }
 879
 880   /* Determine RHS upper and lower bounds.  */
 881   if (r_dir == 1)
 882     {
 883       r_lower = r_start;
 884       r_upper = r_end;
 885     }
 886   else if (r_dir == -1)
 887     {
 888       r_lower = r_end;
 889       r_upper = r_start;
 890     }
 891   else
 892     {
 893       r_lower = NULL;
 894       r_upper = NULL;
 895     }
 896
 897   /* Check whether the ranges are disjoint.  */
 898   if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
 899     return GFC_DEP_NODEP;
 900   if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
 901     return GFC_DEP_NODEP;
 902
 903   /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
 904   if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
 905     {
 906       if (l_dir == 1 && r_dir == -1)
 907         return GFC_DEP_EQUAL;
 908       if (l_dir == -1 && r_dir == 1)
 909         return GFC_DEP_EQUAL;
 910     }
 911
 912   /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
 913   if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
 914     {
 915       if (l_dir == 1 && r_dir == -1)
 916         return GFC_DEP_EQUAL;
 917       if (l_dir == -1 && r_dir == 1)
 918         return GFC_DEP_EQUAL;
 919     }
 920
 921   /* Check for forward dependencies x:y vs. x+1:z.  */
 922   if (l_dir == 1 && r_dir == 1
 923       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
 924       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
 925     {
 926       /* Check that the strides are the same.  */
 927       if (!l_stride && !r_stride)
 928         return GFC_DEP_FORWARD;
 929       if (l_stride && r_stride
 930           && gfc_dep_compare_expr (l_stride, r_stride) == 0)
 931         return GFC_DEP_FORWARD;
 932     }
 933
 934   /* Check for forward dependencies x:y:-1 vs. x-1:z:-1.  */
 935   if (l_dir == -1 && r_dir == -1
 936       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
 937       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
 938     {
 939       /* Check that the strides are the same.  */
 940       if (!l_stride && !r_stride)
 941         return GFC_DEP_FORWARD;
 942       if (l_stride && r_stride
 943           && gfc_dep_compare_expr (l_stride, r_stride) == 0)
 944         return GFC_DEP_FORWARD;
 945     }
 946
 947   return GFC_DEP_OVERLAP;
 948 }
 949
 950
 951 /* Determines overlapping for a single element and a section.  */
 952
 953 static gfc_dependency
 954 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
 955 {
 956   gfc_array_ref *ref;
 957   gfc_expr *elem;
 958   gfc_expr *start;
 959   gfc_expr *end;
 960   gfc_expr *stride;
 961   int s;
 962
 963   elem = lref->u.ar.start[n];
 964   if (!elem)
 965     return GFC_DEP_OVERLAP;
 966
 967   ref = &rref->u.ar;
 968   start = ref->start[n] ;
 969   end = ref->end[n] ;
 970   stride = ref->stride[n];
 971
 972   if (!start && IS_ARRAY_EXPLICIT (ref->as))
 973     start = ref->as->lower[n];
 974   if (!end && IS_ARRAY_EXPLICIT (ref->as))
 975     end = ref->as->upper[n];
 976
 977   /* Determine whether the stride is positive or negative.  */
 978   if (!stride)
 979     s = 1;
 980   else if (stride->expr_type == EXPR_CONSTANT
 981            && stride->ts.type == BT_INTEGER)
 982     s = mpz_sgn (stride->value.integer);
 983   else
 984     s = -2;
 985
 986   /* Stride should never be zero.  */
 987   if (s == 0)
 988     return GFC_DEP_OVERLAP;
 989
 990   /* Positive strides.  */
 991   if (s == 1)
 992     {
 993       /* Check for elem < lower.  */
 994       if (start && gfc_dep_compare_expr (elem, start) == -1)
 995         return GFC_DEP_NODEP;
 996       /* Check for elem > upper.  */
 997       if (end && gfc_dep_compare_expr (elem, end) == 1)
 998         return GFC_DEP_NODEP;
 999
1000       if (start && end)
1001         {
1002           s = gfc_dep_compare_expr (start, end);
1003           /* Check for an empty range.  */
1004           if (s == 1)
1005             return GFC_DEP_NODEP;
1006           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1007             return GFC_DEP_EQUAL;
1008         }
1009     }
1010   /* Negative strides.  */
1011   else if (s == -1)
1012     {
1013       /* Check for elem > upper.  */
1014       if (end && gfc_dep_compare_expr (elem, start) == 1)
1015         return GFC_DEP_NODEP;
1016       /* Check for elem < lower.  */
1017       if (start && gfc_dep_compare_expr (elem, end) == -1)
1018         return GFC_DEP_NODEP;
1019
1020       if (start && end)
1021         {
1022           s = gfc_dep_compare_expr (start, end);
1023           /* Check for an empty range.  */
1024           if (s == -1)
1025             return GFC_DEP_NODEP;
1026           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1027             return GFC_DEP_EQUAL;
1028         }
1029     }
1030   /* Unknown strides.  */
1031   else
1032     {
1033       if (!start || !end)
1034         return GFC_DEP_OVERLAP;
1035       s = gfc_dep_compare_expr (start, end);
1036       if (s == -2)
1037         return GFC_DEP_OVERLAP;
1038       /* Assume positive stride.  */
1039       if (s == -1)
1040         {
1041           /* Check for elem < lower.  */
1042           if (gfc_dep_compare_expr (elem, start) == -1)
1043             return GFC_DEP_NODEP;
1044           /* Check for elem > upper.  */
1045           if (gfc_dep_compare_expr (elem, end) == 1)
1046             return GFC_DEP_NODEP;
1047         }
1048       /* Assume negative stride.  */
1049       else if (s == 1)
1050         {
1051           /* Check for elem > upper.  */
1052           if (gfc_dep_compare_expr (elem, start) == 1)
1053             return GFC_DEP_NODEP;
1054           /* Check for elem < lower.  */
1055           if (gfc_dep_compare_expr (elem, end) == -1)
1056             return GFC_DEP_NODEP;
1057         }
1058       /* Equal bounds.  */
1059       else if (s == 0)
1060         {
1061           s = gfc_dep_compare_expr (elem, start);
1062           if (s == 0)
1063             return GFC_DEP_EQUAL;
1064           if (s == 1 || s == -1)
1065             return GFC_DEP_NODEP;
1066         }
1067     }
1068
1069   return GFC_DEP_OVERLAP;
1070 }
1071
1072
1073 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1074    forall_index attribute.  Return true if any variable may be
1075    being used as a FORALL index.  Its safe to pessimistically
1076    return true, and assume a dependency.  */
1077
1078 static bool
1079 contains_forall_index_p (gfc_expr *expr)
1080 {
1081   gfc_actual_arglist *arg;
1082   gfc_constructor *c;
1083   gfc_ref *ref;
1084   int i;
1085
1086   if (!expr)
1087     return false;
1088
1089   switch (expr->expr_type)
1090     {
1091     case EXPR_VARIABLE:
1092       if (expr->symtree->n.sym->forall_index)
1093         return true;
1094       break;
1095
1096     case EXPR_OP:
1097       if (contains_forall_index_p (expr->value.op.op1)
1098           || contains_forall_index_p (expr->value.op.op2))
1099         return true;
1100       break;
1101
1102     case EXPR_FUNCTION:
1103       for (arg = expr->value.function.actual; arg; arg = arg->next)
1104         if (contains_forall_index_p (arg->expr))
1105           return true;
1106       break;
1107
1108     case EXPR_CONSTANT:
1109     case EXPR_NULL:
1110     case EXPR_SUBSTRING:
1111       break;
1112
1113     case EXPR_STRUCTURE:
1114     case EXPR_ARRAY:
1115       for (c = expr->value.constructor; c; c = c->next)
1116         if (contains_forall_index_p (c->expr))
1117           return true;
1118       break;
1119
1120     default:
1121       gcc_unreachable ();
1122     }
1123
1124   for (ref = expr->ref; ref; ref = ref->next)
1125     switch (ref->type)
1126       {
1127       case REF_ARRAY:
1128         for (i = 0; i < ref->u.ar.dimen; i++)
1129           if (contains_forall_index_p (ref->u.ar.start[i])
1130               || contains_forall_index_p (ref->u.ar.end[i])
1131               || contains_forall_index_p (ref->u.ar.stride[i]))
1132             return true;
1133         break;
1134
1135       case REF_COMPONENT:
1136         break;
1137
1138       case REF_SUBSTRING:
1139         if (contains_forall_index_p (ref->u.ss.start)
1140             || contains_forall_index_p (ref->u.ss.end))
1141           return true;
1142         break;
1143
1144       default:
1145         gcc_unreachable ();
1146       }
1147
1148   return false;
1149 }
1150
1151 /* Determines overlapping for two single element array references.  */
1152
1153 static gfc_dependency
1154 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1155 {
1156   gfc_array_ref l_ar;
1157   gfc_array_ref r_ar;
1158   gfc_expr *l_start;
1159   gfc_expr *r_start;
1160   int i;
1161
1162   l_ar = lref->u.ar;
1163   r_ar = rref->u.ar;
1164   l_start = l_ar.start[n] ;
1165   r_start = r_ar.start[n] ;
1166   i = gfc_dep_compare_expr (r_start, l_start);
1167   if (i == 0)
1168     return GFC_DEP_EQUAL;
1169
1170   /* Treat two scalar variables as potentially equal.  This allows
1171      us to prove that a(i,:) and a(j,:) have no dependency.  See
1172      Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1173      Proceedings of the International Conference on Parallel and
1174      Distributed Processing Techniques and Applications (PDPTA2001),
1175      Las Vegas, Nevada, June 2001.  */
1176   /* However, we need to be careful when either scalar expression
1177      contains a FORALL index, as these can potentially change value
1178      during the scalarization/traversal of this array reference.  */
1179   if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1180     return GFC_DEP_OVERLAP;
1181
1182   if (i != -2)
1183     return GFC_DEP_NODEP;
1184   return GFC_DEP_EQUAL;
1185 }
1186
1187
1188 /* Determine if an array ref, usually an array section specifies the
1189    entire array.  */
1190
1191 bool
1192 gfc_full_array_ref_p (gfc_ref *ref)
1193 {
1194   int i;
1195
1196   if (ref->type != REF_ARRAY)
1197     return false;
1198   if (ref->u.ar.type == AR_FULL)
1199     return true;
1200   if (ref->u.ar.type != AR_SECTION)
1201     return false;
1202   if (ref->next)
1203     return false;
1204
1205   for (i = 0; i < ref->u.ar.dimen; i++)
1206     {
1207       /* If we have a single element in the reference, we need to check
1208          that the array has a single element and that we actually reference
1209          the correct element.  */
1210       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1211         {
1212           if (!ref->u.ar.as
1213               || !ref->u.ar.as->lower[i]
1214               || !ref->u.ar.as->upper[i]
1215               || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1216                                        ref->u.ar.as->upper[i])
1217               || !ref->u.ar.start[i]
1218               || gfc_dep_compare_expr (ref->u.ar.start[i],
1219                                        ref->u.ar.as->lower[i]))
1220             return false;
1221           else
1222             continue;
1223         }
1224
1225       /* Check the lower bound.  */
1226       if (ref->u.ar.start[i]
1227           && (!ref->u.ar.as
1228               || !ref->u.ar.as->lower[i]
1229               || gfc_dep_compare_expr (ref->u.ar.start[i],
1230                                        ref->u.ar.as->lower[i])))
1231         return false;
1232       /* Check the upper bound.  */
1233       if (ref->u.ar.end[i]
1234           && (!ref->u.ar.as
1235               || !ref->u.ar.as->upper[i]
1236               || gfc_dep_compare_expr (ref->u.ar.end[i],
1237                                        ref->u.ar.as->upper[i])))
1238         return false;
1239       /* Check the stride.  */
1240       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1241         return false;
1242     }
1243   return true;
1244 }
1245
1246
1247 /* Determine if a full array is the same as an array section with one
1248    variable limit.  For this to be so, the strides must both be unity
1249    and one of either start == lower or end == upper must be true.  */
1250
1251 static bool
1252 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1253 {
1254   int i;
1255   bool upper_or_lower;
1256
1257   if (full_ref->type != REF_ARRAY)
1258     return false;
1259   if (full_ref->u.ar.type != AR_FULL)
1260     return false;
1261   if (ref->type != REF_ARRAY)
1262     return false;
1263   if (ref->u.ar.type != AR_SECTION)
1264     return false;
1265
1266   for (i = 0; i < ref->u.ar.dimen; i++)
1267     {
1268       /* If we have a single element in the reference, we need to check
1269          that the array has a single element and that we actually reference
1270          the correct element.  */
1271       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1272         {
1273           if (!full_ref->u.ar.as
1274               || !full_ref->u.ar.as->lower[i]
1275               || !full_ref->u.ar.as->upper[i]
1276               || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1277                                        full_ref->u.ar.as->upper[i])
1278               || !ref->u.ar.start[i]
1279               || gfc_dep_compare_expr (ref->u.ar.start[i],
1280                                        full_ref->u.ar.as->lower[i]))
1281             return false;
1282         }
1283
1284       /* Check the strides.  */
1285       if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1286         return false;
1287       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1288         return false;
1289
1290       upper_or_lower = false;
1291       /* Check the lower bound.  */
1292       if (ref->u.ar.start[i]
1293           && (ref->u.ar.as
1294                 && full_ref->u.ar.as->lower[i]
1295                 && gfc_dep_compare_expr (ref->u.ar.start[i],
1296                                          full_ref->u.ar.as->lower[i]) == 0))
1297         upper_or_lower =  true;
1298       /* Check the upper bound.  */
1299       if (ref->u.ar.end[i]
1300           && (ref->u.ar.as
1301                 && full_ref->u.ar.as->upper[i]
1302                 && gfc_dep_compare_expr (ref->u.ar.end[i],
1303                                          full_ref->u.ar.as->upper[i]) == 0))
1304         upper_or_lower =  true;
1305       if (!upper_or_lower)
1306         return false;
1307     }
1308   return true;
1309 }
1310
1311
1312 /* Finds if two array references are overlapping or not.
1313    Return value
1314         1 : array references are overlapping.
1315         0 : array references are identical or not overlapping.  */
1316
1317 int
1318 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
1319 {
1320   int n;
1321   gfc_dependency fin_dep;
1322   gfc_dependency this_dep;
1323
1324   fin_dep = GFC_DEP_ERROR;
1325   /* Dependencies due to pointers should already have been identified.
1326      We only need to check for overlapping array references.  */
1327
1328   while (lref && rref)
1329     {
1330       /* We're resolving from the same base symbol, so both refs should be
1331          the same type.  We traverse the reference chain until we find ranges
1332          that are not equal.  */
1333       gcc_assert (lref->type == rref->type);
1334       switch (lref->type)
1335         {
1336         case REF_COMPONENT:
1337           /* The two ranges can't overlap if they are from different
1338              components.  */
1339           if (lref->u.c.component != rref->u.c.component)
1340             return 0;
1341           break;
1342
1343         case REF_SUBSTRING:
1344           /* Substring overlaps are handled by the string assignment code
1345              if there is not an underlying dependency.  */
1346           return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1347
1348         case REF_ARRAY:
1349
1350           if (ref_same_as_full_array (lref, rref))
1351             return 0;
1352
1353           if (ref_same_as_full_array (rref, lref))
1354             return 0;
1355
1356           if (lref->u.ar.dimen != rref->u.ar.dimen)
1357             {
1358               if (lref->u.ar.type == AR_FULL)
1359                 fin_dep = gfc_full_array_ref_p (rref) ? GFC_DEP_EQUAL
1360                                                       : GFC_DEP_OVERLAP;
1361               else if (rref->u.ar.type == AR_FULL)
1362                 fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL
1363                                                       : GFC_DEP_OVERLAP;
1364               else
1365                 return 1;
1366               break;
1367             }
1368
1369           for (n=0; n < lref->u.ar.dimen; n++)
1370             {
1371               /* Assume dependency when either of array reference is vector
1372                  subscript.  */
1373               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1374                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1375                 return 1;
1376               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1377                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1378                 this_dep = gfc_check_section_vs_section (lref, rref, n);
1379               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1380                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1381                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1382               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1383                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1384                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1385               else
1386                 {
1387                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1388                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1389                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1390                 }
1391
1392               /* If any dimension doesn't overlap, we have no dependency.  */
1393               if (this_dep == GFC_DEP_NODEP)
1394                 return 0;
1395
1396               /* Overlap codes are in order of priority.  We only need to
1397                  know the worst one.*/
1398               if (this_dep > fin_dep)
1399                 fin_dep = this_dep;
1400             }
1401
1402           /* If this is an equal element, we have to keep going until we find
1403              the "real" array reference.  */
1404           if (lref->u.ar.type == AR_ELEMENT
1405                 && rref->u.ar.type == AR_ELEMENT
1406                 && fin_dep == GFC_DEP_EQUAL)
1407             break;
1408
1409           /* Exactly matching and forward overlapping ranges don't cause a
1410              dependency.  */
1411           if (fin_dep < GFC_DEP_OVERLAP)
1412             return 0;
1413
1414           /* Keep checking.  We only have a dependency if
1415              subsequent references also overlap.  */
1416           break;
1417
1418         default:
1419           gcc_unreachable ();
1420         }
1421       lref = lref->next;
1422       rref = rref->next;
1423     }
1424
1425   /* If we haven't seen any array refs then something went wrong.  */
1426   gcc_assert (fin_dep != GFC_DEP_ERROR);
1427
1428   /* Assume the worst if we nest to different depths.  */
1429   if (lref || rref)
1430     return 1;
1431
1432   return fin_dep == GFC_DEP_OVERLAP;
1433 }
1434