gcc/fortran/dependency.c

   1 /* Dependency analysis
   2    Copyright (C) 2000, 2001, 2002, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  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
  28 #include "config.h"
  29 #include "gfortran.h"
  30 #include "dependency.h"
  31
  32 /* static declarations */
  33 /* Enums  */
  34 enum range {LHS, RHS, MID};
  35
  36 /* Dependency types.  These must be in reverse order of priority.  */
  37 typedef enum
  38 {
  39   GFC_DEP_ERROR,
  40   GFC_DEP_EQUAL,        /* Identical Ranges.  */
  41   GFC_DEP_FORWARD,      /* eg. a(1:3), a(2:4).  */
  42   GFC_DEP_OVERLAP,      /* May overlap in some other way.  */
  43   GFC_DEP_NODEP         /* Distinct ranges.  */
  44 }
  45 gfc_dependency;
  46
  47 /* Macros */
  48 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
  49
  50
  51 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
  52    def if the value could not be determined.  */
  53
  54 int
  55 gfc_expr_is_one (gfc_expr * expr, int def)
  56 {
  57   gcc_assert (expr != NULL);
  58
  59   if (expr->expr_type != EXPR_CONSTANT)
  60     return def;
  61
  62   if (expr->ts.type != BT_INTEGER)
  63     return def;
  64
  65   return mpz_cmp_si (expr->value.integer, 1) == 0;
  66 }
  67
  68
  69 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
  70    and -2 if the relationship could not be determined.  */
  71
  72 int
  73 gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
  74 {
  75   int i;
  76
  77   if (e1->expr_type != e2->expr_type)
  78     return -2;
  79
  80   switch (e1->expr_type)
  81     {
  82     case EXPR_CONSTANT:
  83       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
  84         return -2;
  85
  86       i = mpz_cmp (e1->value.integer, e2->value.integer);
  87       if (i == 0)
  88         return 0;
  89       else if (i < 0)
  90         return -1;
  91       return 1;
  92
  93     case EXPR_VARIABLE:
  94       if (e1->ref || e2->ref)
  95         return -2;
  96       if (e1->symtree->n.sym == e2->symtree->n.sym)
  97         return 0;
  98       return -2;
  99
 100     default:
 101       return -2;
 102     }
 103 }
 104
 105
 106 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
 107    if the results are indeterminate.  N is the dimension to compare.  */
 108
 109 int
 110 gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
 111 {
 112   gfc_expr *e1;
 113   gfc_expr *e2;
 114   int i;
 115
 116   /* TODO: More sophisticated range comparison.  */
 117   gcc_assert (ar1 && ar2);
 118
 119   gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
 120
 121   e1 = ar1->stride[n];
 122   e2 = ar2->stride[n];
 123   /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
 124   if (e1 && !e2)
 125     {
 126       i = gfc_expr_is_one (e1, -1);
 127       if (i == -1)
 128         return def;
 129       else if (i == 0)
 130         return 0;
 131     }
 132   else if (e2 && !e1)
 133     {
 134       i = gfc_expr_is_one (e2, -1);
 135       if (i == -1)
 136         return def;
 137       else if (i == 0)
 138         return 0;
 139     }
 140   else if (e1 && e2)
 141     {
 142       i = gfc_dep_compare_expr (e1, e2);
 143       if (i == -2)
 144         return def;
 145       else if (i != 0)
 146         return 0;
 147     }
 148   /* The strides match.  */
 149
 150   /* Check the range start.  */
 151   e1 = ar1->start[n];
 152   e2 = ar2->start[n];
 153   if (e1 || e2)
 154     {
 155       /* Use the bound of the array if no bound is specified.  */
 156       if (ar1->as && !e1)
 157         e1 = ar1->as->lower[n];
 158
 159       if (ar2->as && !e2)
 160         e2 = ar2->as->lower[n];
 161
 162       /* Check we have values for both.  */
 163       if (!(e1 && e2))
 164         return def;
 165
 166       i = gfc_dep_compare_expr (e1, e2);
 167       if (i == -2)
 168         return def;
 169       else if (i != 0)
 170         return 0;
 171     }
 172
 173   /* Check the range end.  */
 174   e1 = ar1->end[n];
 175   e2 = ar2->end[n];
 176   if (e1 || e2)
 177     {
 178       /* Use the bound of the array if no bound is specified.  */
 179       if (ar1->as && !e1)
 180         e1 = ar1->as->upper[n];
 181
 182       if (ar2->as && !e2)
 183         e2 = ar2->as->upper[n];
 184
 185       /* Check we have values for both.  */
 186       if (!(e1 && e2))
 187         return def;
 188
 189       i = gfc_dep_compare_expr (e1, e2);
 190       if (i == -2)
 191         return def;
 192       else if (i != 0)
 193         return 0;
 194     }
 195
 196   return 1;
 197 }
 198
 199
 200 /* Some array-returning intrinsics can be implemented by reusing the
 201    data from one of the array arguments.  For example, TRANSPOSE does
 202    not necessarily need to allocate new data: it can be implemented
 203    by copying the original array's descriptor and simply swapping the
 204    two dimension specifications.
 205
 206    If EXPR is a call to such an intrinsic, return the argument
 207    whose data can be reused, otherwise return NULL.  */
 208
 209 gfc_expr *
 210 gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
 211 {
 212   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
 213     return NULL;
 214
 215   switch (expr->value.function.isym->generic_id)
 216     {
 217     case GFC_ISYM_TRANSPOSE:
 218       return expr->value.function.actual->expr;
 219
 220     default:
 221       return NULL;
 222     }
 223 }
 224
 225
 226 /* Return true if the result of reference REF can only be constructed
 227    using a temporary array.  */
 228
 229 bool
 230 gfc_ref_needs_temporary_p (gfc_ref *ref)
 231 {
 232   int n;
 233   bool subarray_p;
 234
 235   subarray_p = false;
 236   for (; ref; ref = ref->next)
 237     switch (ref->type)
 238       {
 239       case REF_ARRAY:
 240         /* Vector dimensions are generally not monotonic and must be
 241            handled using a temporary.  */
 242         if (ref->u.ar.type == AR_SECTION)
 243           for (n = 0; n < ref->u.ar.dimen; n++)
 244             if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 245               return true;
 246
 247         subarray_p = true;
 248         break;
 249
 250       case REF_SUBSTRING:
 251         /* Within an array reference, character substrings generally
 252            need a temporary.  Character array strides are expressed as
 253            multiples of the element size (consistent with other array
 254            types), not in characters.  */
 255         return subarray_p;
 256
 257       case REF_COMPONENT:
 258         break;
 259       }
 260
 261   return false;
 262 }
 263
 264
 265 /* Return true if array variable VAR could be passed to the same function
 266    as argument EXPR without interfering with EXPR.  INTENT is the intent
 267    of VAR.
 268
 269    This is considerably less conservative than other dependencies
 270    because many function arguments will already be copied into a
 271    temporary.  */
 272
 273 static int
 274 gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
 275                                    gfc_expr * expr)
 276 {
 277   gcc_assert (var->expr_type == EXPR_VARIABLE);
 278   gcc_assert (var->rank > 0);
 279
 280   switch (expr->expr_type)
 281     {
 282     case EXPR_VARIABLE:
 283       return (gfc_ref_needs_temporary_p (expr->ref)
 284               || gfc_check_dependency (var, expr, 1));
 285
 286     case EXPR_ARRAY:
 287       return gfc_check_dependency (var, expr, 1);
 288
 289     case EXPR_FUNCTION:
 290       if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
 291         {
 292           expr = gfc_get_noncopying_intrinsic_argument (expr);
 293           return gfc_check_argument_var_dependency (var, intent, expr);
 294         }
 295       return 0;
 296
 297     default:
 298       return 0;
 299     }
 300 }
 301
 302
 303 /* Like gfc_check_argument_var_dependency, but extended to any
 304    array expression OTHER, not just variables.  */
 305
 306 static int
 307 gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
 308                                gfc_expr * expr)
 309 {
 310   switch (other->expr_type)
 311     {
 312     case EXPR_VARIABLE:
 313       return gfc_check_argument_var_dependency (other, intent, expr);
 314
 315     case EXPR_FUNCTION:
 316       if (other->inline_noncopying_intrinsic)
 317         {
 318           other = gfc_get_noncopying_intrinsic_argument (other);
 319           return gfc_check_argument_dependency (other, INTENT_IN, expr);
 320         }
 321       return 0;
 322
 323     default:
 324       return 0;
 325     }
 326 }
 327
 328
 329 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
 330    FNSYM is the function being called, or NULL if not known.  */
 331
 332 int
 333 gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
 334                              gfc_symbol * fnsym, gfc_actual_arglist * actual)
 335 {
 336   gfc_formal_arglist *formal;
 337   gfc_expr *expr;
 338
 339   formal = fnsym ? fnsym->formal : NULL;
 340   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
 341     {
 342       expr = actual->expr;
 343
 344       /* Skip args which are not present.  */
 345       if (!expr)
 346         continue;
 347
 348       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
 349       if (formal
 350           && intent == INTENT_IN
 351           && formal->sym->attr.intent == INTENT_IN)
 352         continue;
 353
 354       if (gfc_check_argument_dependency (other, intent, expr))
 355         return 1;
 356     }
 357
 358   return 0;
 359 }
 360
 361
 362 /* Return true if the statement body redefines the condition.  Returns
 363    true if expr2 depends on expr1.  expr1 should be a single term
 364    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 365    whether array references to the same symbol with identical range
 366    references count as a dependency or not.  Used for forall and where
 367    statements.  Also used with functions returning arrays without a
 368    temporary.  */
 369
 370 int
 371 gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
 372 {
 373   gfc_ref *ref;
 374   int n;
 375   gfc_actual_arglist *actual;
 376
 377   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 378
 379   /* TODO: -fassume-no-pointer-aliasing */
 380   if (expr1->symtree->n.sym->attr.pointer)
 381     return 1;
 382   for (ref = expr1->ref; ref; ref = ref->next)
 383     {
 384       if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 385         return 1;
 386     }
 387
 388   switch (expr2->expr_type)
 389     {
 390     case EXPR_OP:
 391       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
 392       if (n)
 393         return n;
 394       if (expr2->value.op.op2)
 395         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
 396       return 0;
 397
 398     case EXPR_VARIABLE:
 399       if (expr2->symtree->n.sym->attr.pointer)
 400         return 1;
 401
 402       for (ref = expr2->ref; ref; ref = ref->next)
 403         {
 404           if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 405             return 1;
 406         }
 407
 408       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 409         return 0;
 410
 411       if (identical)
 412         return 1;
 413
 414       /* Identical ranges return 0, overlapping ranges return 1.  */
 415
 416       /* Return zero if we refer to the same full arrays.  */
 417       if (expr1->ref->type == REF_ARRAY
 418           && expr2->ref->type == REF_ARRAY
 419           && expr1->ref->u.ar.type == AR_FULL
 420           && expr2->ref->u.ar.type == AR_FULL
 421           && !expr1->ref->next
 422           && !expr2->ref->next)
 423         return 0;
 424
 425       return 1;
 426
 427     case EXPR_FUNCTION:
 428       if (expr2->inline_noncopying_intrinsic)
 429         identical = 1;
 430       /* Remember possible differences between elemental and
 431          transformational functions.  All functions inside a FORALL
 432          will be pure.  */
 433       for (actual = expr2->value.function.actual;
 434            actual; actual = actual->next)
 435         {
 436           if (!actual->expr)
 437             continue;
 438           n = gfc_check_dependency (expr1, actual->expr, identical);
 439           if (n)
 440             return n;
 441         }
 442       return 0;
 443
 444     case EXPR_CONSTANT:
 445       return 0;
 446
 447     case EXPR_ARRAY:
 448       /* Probably ok in the majority of (constant) cases.  */
 449       return 1;
 450
 451     default:
 452       return 1;
 453     }
 454 }
 455
 456
 457 /* Calculates size of the array reference using lower bound, upper bound
 458    and stride.  */
 459
 460 static void
 461 get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
 462 {
 463   /* nNoOfEle = (u1-l1)/s1  */
 464
 465   mpz_sub (ele, u1->value.integer, l1->value.integer);
 466
 467   if (s1 != NULL)
 468     mpz_tdiv_q (ele, ele, s1->value.integer);
 469 }
 470
 471
 472 /* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
 473
 474 static gfc_dependency
 475 get_deps (mpz_t x1, mpz_t x2, mpz_t y)
 476 {
 477   int start;
 478   int end;
 479
 480   start = mpz_cmp_ui (x1, 0);
 481   end = mpz_cmp (x2, y);
 482
 483   /* Both ranges the same.  */
 484   if (start == 0 && end == 0)
 485     return GFC_DEP_EQUAL;
 486
 487   /* Distinct ranges.  */
 488   if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
 489       || (mpz_cmp (x1, y) > 0 && end > 0))
 490     return GFC_DEP_NODEP;
 491
 492   /* Overlapping, but with corresponding elements of the second range
 493      greater than the first.  */
 494   if (start > 0 && end > 0)
 495     return GFC_DEP_FORWARD;
 496
 497   /* Overlapping in some other way.  */
 498   return GFC_DEP_OVERLAP;
 499 }
 500
 501
 502 /* Perform the same linear transformation on sections l and r such that
 503    (l_start:l_end:l_stride) -> (0:no_of_elements)
 504    (r_start:r_end:r_stride) -> (X1:X2)
 505    Where r_end is implicit as both sections must have the same number of
 506    elements.
 507    Returns 0 on success, 1 of the transformation failed.  */
 508 /* TODO: Should this be (0:no_of_elements-1) */
 509
 510 static int
 511 transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
 512                     gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
 513                     gfc_expr * r_start, gfc_expr * r_stride)
 514 {
 515   if (NULL == l_start || NULL == l_end || NULL == r_start)
 516     return 1;
 517
 518   /* TODO : Currently we check the dependency only when start, end and stride
 519     are constant.  We could also check for equal (variable) values, and
 520     common subexpressions, eg. x vs. x+1.  */
 521
 522   if (l_end->expr_type != EXPR_CONSTANT
 523       || l_start->expr_type != EXPR_CONSTANT
 524       || r_start->expr_type != EXPR_CONSTANT
 525       || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
 526       || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
 527     {
 528        return 1;
 529     }
 530
 531
 532   get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
 533
 534   mpz_sub (X1, r_start->value.integer, l_start->value.integer);
 535   if (l_stride != NULL)
 536     mpz_cdiv_q (X1, X1, l_stride->value.integer);
 537
 538   if (r_stride == NULL)
 539     mpz_set (X2, no_of_elements);
 540   else
 541     mpz_mul (X2, no_of_elements, r_stride->value.integer);
 542
 543   if (l_stride != NULL)
 544     mpz_cdiv_q (X2, X2, l_stride->value.integer);
 545   mpz_add (X2, X2, X1);
 546
 547   return 0;
 548 }
 549
 550
 551 /* Determines overlapping for two array sections.  */
 552
 553 static gfc_dependency
 554 gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
 555 {
 556   gfc_expr *l_start;
 557   gfc_expr *l_end;
 558   gfc_expr *l_stride;
 559
 560   gfc_expr *r_start;
 561   gfc_expr *r_stride;
 562
 563   gfc_array_ref l_ar;
 564   gfc_array_ref r_ar;
 565
 566   mpz_t no_of_elements;
 567   mpz_t X1, X2;
 568   gfc_dependency dep;
 569
 570   l_ar = lref->u.ar;
 571   r_ar = rref->u.ar;
 572
 573   /* If they are the same range, return without more ado.  */
 574   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 575     return GFC_DEP_EQUAL;
 576
 577   l_start = l_ar.start[n];
 578   l_end = l_ar.end[n];
 579   l_stride = l_ar.stride[n];
 580   r_start = r_ar.start[n];
 581   r_stride = r_ar.stride[n];
 582
 583   /* if l_start is NULL take it from array specifier  */
 584   if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
 585     l_start = l_ar.as->lower[n];
 586
 587   /* if l_end is NULL take it from array specifier  */
 588   if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
 589     l_end = l_ar.as->upper[n];
 590
 591   /* if r_start is NULL take it from array specifier  */
 592   if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
 593     r_start = r_ar.as->lower[n];
 594
 595   mpz_init (X1);
 596   mpz_init (X2);
 597   mpz_init (no_of_elements);
 598
 599   if (transform_sections (X1, X2, no_of_elements,
 600                           l_start, l_end, l_stride,
 601                           r_start, r_stride))
 602     dep = GFC_DEP_OVERLAP;
 603   else
 604     dep =  get_deps (X1, X2, no_of_elements);
 605
 606   mpz_clear (no_of_elements);
 607   mpz_clear (X1);
 608   mpz_clear (X2);
 609   return dep;
 610 }
 611
 612
 613 /* Checks if the expr chk is inside the range left-right.
 614    Returns  GFC_DEP_NODEP if chk is outside the range,
 615    GFC_DEP_OVERLAP otherwise.
 616    Assumes left<=right.  */
 617
 618 static gfc_dependency
 619 gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
 620 {
 621   int l;
 622   int r;
 623   int s;
 624
 625   s = gfc_dep_compare_expr (left, right);
 626   if (s == -2)
 627     return GFC_DEP_OVERLAP;
 628
 629   l = gfc_dep_compare_expr (chk, left);
 630   r = gfc_dep_compare_expr (chk, right);
 631
 632   /* Check for indeterminate relationships.  */
 633   if (l == -2 || r == -2 || s == -2)
 634     return GFC_DEP_OVERLAP;
 635
 636   if (s == 1)
 637     {
 638       /* When left>right we want to check for right <= chk <= left.  */
 639       if (l <= 0 || r >= 0)
 640         return GFC_DEP_OVERLAP;
 641     }
 642   else
 643     {
 644       /* Otherwise check for left <= chk <= right.  */
 645       if (l >= 0 || r <= 0)
 646         return GFC_DEP_OVERLAP;
 647     }
 648
 649   return GFC_DEP_NODEP;
 650 }
 651
 652
 653 /* Determines overlapping for a single element and a section.  */
 654
 655 static gfc_dependency
 656 gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
 657 {
 658   gfc_array_ref l_ar;
 659   gfc_array_ref r_ar;
 660   gfc_expr *l_start;
 661   gfc_expr *r_start;
 662   gfc_expr *r_end;
 663
 664   l_ar = lref->u.ar;
 665   r_ar = rref->u.ar;
 666   l_start = l_ar.start[n] ;
 667   r_start = r_ar.start[n] ;
 668   r_end = r_ar.end[n] ;
 669   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 670     r_start = r_ar.as->lower[n];
 671   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 672     r_end = r_ar.as->upper[n];
 673   if (NULL == r_start || NULL == r_end || l_start == NULL)
 674     return GFC_DEP_OVERLAP;
 675
 676   return gfc_is_inside_range (l_start, r_end, r_start);
 677 }
 678
 679
 680 /* Determines overlapping for two single element array references.  */
 681
 682 static gfc_dependency
 683 gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
 684 {
 685   gfc_array_ref l_ar;
 686   gfc_array_ref r_ar;
 687   gfc_expr *l_start;
 688   gfc_expr *r_start;
 689   gfc_dependency nIsDep;
 690
 691   if (lref->type == REF_ARRAY && rref->type == REF_ARRAY)
 692     {
 693       l_ar = lref->u.ar;
 694       r_ar = rref->u.ar;
 695       l_start = l_ar.start[n] ;
 696       r_start = r_ar.start[n] ;
 697       if (gfc_dep_compare_expr (r_start, l_start) == 0)
 698         nIsDep = GFC_DEP_EQUAL;
 699       else
 700         nIsDep = GFC_DEP_NODEP;
 701   }
 702   else
 703     nIsDep = GFC_DEP_NODEP;
 704
 705   return nIsDep;
 706 }
 707
 708
 709 /* Finds if two array references are overlapping or not.
 710    Return value
 711         1 : array references are overlapping.
 712         0 : array references are not overlapping.  */
 713
 714 int
 715 gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
 716 {
 717   int n;
 718   gfc_dependency fin_dep;
 719   gfc_dependency this_dep;
 720
 721
 722   fin_dep = GFC_DEP_ERROR;
 723   /* Dependencies due to pointers should already have been identified.
 724      We only need to check for overlapping array references.  */
 725
 726   while (lref && rref)
 727     {
 728       /* We're resolving from the same base symbol, so both refs should be
 729          the same type.  We traverse the reference chain intil we find ranges
 730          that are not equal.  */
 731       gcc_assert (lref->type == rref->type);
 732       switch (lref->type)
 733         {
 734         case REF_COMPONENT:
 735           /* The two ranges can't overlap if they are from different
 736              components.  */
 737           if (lref->u.c.component != rref->u.c.component)
 738             return 0;
 739           break;
 740
 741         case REF_SUBSTRING:
 742           /* Substring overlaps are handled by the string assignment code.  */
 743           return 0;
 744
 745         case REF_ARRAY:
 746
 747           for (n=0; n < lref->u.ar.dimen; n++)
 748             {
 749               /* Assume dependency when either of array reference is vector
 750                  subscript.  */
 751               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
 752                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 753                 return 1;
 754               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
 755                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 756                 this_dep = gfc_check_section_vs_section (lref, rref, n);
 757               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 758                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 759                 this_dep = gfc_check_element_vs_section (lref, rref, n);
 760               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 761                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
 762                 this_dep = gfc_check_element_vs_section (rref, lref, n);
 763               else
 764                 {
 765                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 766                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
 767                   this_dep = gfc_check_element_vs_element (rref, lref, n);
 768                 }
 769
 770               /* If any dimension doesn't overlap, we have no dependency.  */
 771               if (this_dep == GFC_DEP_NODEP)
 772                 return 0;
 773
 774               /* Overlap codes are in order of priority.  We only need to
 775                  know the worst one.*/
 776               if (this_dep > fin_dep)
 777                 fin_dep = this_dep;
 778             }
 779           /* Exactly matching and forward overlapping ranges don't cause a
 780              dependency.  */
 781           if (fin_dep < GFC_DEP_OVERLAP)
 782             return 0;
 783
 784           /* Keep checking.  We only have a dependency if
 785              subsequent references also overlap.  */
 786           break;
 787
 788         default:
 789           gcc_unreachable ();
 790         }
 791       lref = lref->next;
 792       rref = rref->next;
 793     }
 794
 795   /* If we haven't seen any array refs then something went wrong.  */
 796   gcc_assert (fin_dep != GFC_DEP_ERROR);
 797
 798   if (fin_dep < GFC_DEP_OVERLAP)
 799     return 0;
 800   else
 801     return 1;
 802 }
 803