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     case EXPR_OP:
 101       /* Intrinsic operators are the same if their operands are the same.  */
 102       if (e1->value.op.operator != e2->value.op.operator)
 103         return -2;
 104       if (e1->value.op.op2 == 0)
 105         {
 106           i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 107           return i == 0 ? 0 : -2;
 108         }
 109       if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
 110           && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
 111         return 0;
 112       /* TODO Handle commutative binary operators here?  */
 113       return -2;
 114
 115     case EXPR_FUNCTION:
 116       /* We can only compare calls to the same intrinsic function.  */
 117       if (e1->value.function.isym == 0
 118           || e2->value.function.isym == 0
 119           || e1->value.function.isym != e2->value.function.isym)
 120         return -2;
 121
 122       /* We should list the "constant" intrinsic functions.  Those
 123          without side-effects that provide equal results given equal
 124          argument lists.  */
 125       switch (e1->value.function.isym->generic_id)
 126         {
 127         case GFC_ISYM_CONVERSION:
 128         case GFC_ISYM_REAL:
 129         case GFC_ISYM_LOGICAL:
 130         case GFC_ISYM_DBLE:
 131           break;
 132
 133         default:
 134           return -2;
 135         }
 136
 137       /* Compare the argument lists for equality.  */
 138       {
 139         gfc_actual_arglist *args1 = e1->value.function.actual;
 140         gfc_actual_arglist *args2 = e2->value.function.actual;
 141         while (args1 && args2)
 142           {
 143             if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
 144               return -2;
 145             args1 = args1->next;
 146             args2 = args2->next;
 147           }
 148         return (args1 || args2) ? -2 : 0;
 149       }
 150
 151     default:
 152       return -2;
 153     }
 154 }
 155
 156
 157 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
 158    if the results are indeterminate.  N is the dimension to compare.  */
 159
 160 int
 161 gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
 162 {
 163   gfc_expr *e1;
 164   gfc_expr *e2;
 165   int i;
 166
 167   /* TODO: More sophisticated range comparison.  */
 168   gcc_assert (ar1 && ar2);
 169
 170   gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
 171
 172   e1 = ar1->stride[n];
 173   e2 = ar2->stride[n];
 174   /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
 175   if (e1 && !e2)
 176     {
 177       i = gfc_expr_is_one (e1, -1);
 178       if (i == -1)
 179         return def;
 180       else if (i == 0)
 181         return 0;
 182     }
 183   else if (e2 && !e1)
 184     {
 185       i = gfc_expr_is_one (e2, -1);
 186       if (i == -1)
 187         return def;
 188       else if (i == 0)
 189         return 0;
 190     }
 191   else if (e1 && e2)
 192     {
 193       i = gfc_dep_compare_expr (e1, e2);
 194       if (i == -2)
 195         return def;
 196       else if (i != 0)
 197         return 0;
 198     }
 199   /* The strides match.  */
 200
 201   /* Check the range start.  */
 202   e1 = ar1->start[n];
 203   e2 = ar2->start[n];
 204   if (e1 || e2)
 205     {
 206       /* Use the bound of the array if no bound is specified.  */
 207       if (ar1->as && !e1)
 208         e1 = ar1->as->lower[n];
 209
 210       if (ar2->as && !e2)
 211         e2 = ar2->as->lower[n];
 212
 213       /* Check we have values for both.  */
 214       if (!(e1 && e2))
 215         return def;
 216
 217       i = gfc_dep_compare_expr (e1, e2);
 218       if (i == -2)
 219         return def;
 220       else if (i != 0)
 221         return 0;
 222     }
 223
 224   /* Check the range end.  */
 225   e1 = ar1->end[n];
 226   e2 = ar2->end[n];
 227   if (e1 || e2)
 228     {
 229       /* Use the bound of the array if no bound is specified.  */
 230       if (ar1->as && !e1)
 231         e1 = ar1->as->upper[n];
 232
 233       if (ar2->as && !e2)
 234         e2 = ar2->as->upper[n];
 235
 236       /* Check we have values for both.  */
 237       if (!(e1 && e2))
 238         return def;
 239
 240       i = gfc_dep_compare_expr (e1, e2);
 241       if (i == -2)
 242         return def;
 243       else if (i != 0)
 244         return 0;
 245     }
 246
 247   return 1;
 248 }
 249
 250
 251 /* Some array-returning intrinsics can be implemented by reusing the
 252    data from one of the array arguments.  For example, TRANSPOSE does
 253    not necessarily need to allocate new data: it can be implemented
 254    by copying the original array's descriptor and simply swapping the
 255    two dimension specifications.
 256
 257    If EXPR is a call to such an intrinsic, return the argument
 258    whose data can be reused, otherwise return NULL.  */
 259
 260 gfc_expr *
 261 gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
 262 {
 263   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
 264     return NULL;
 265
 266   switch (expr->value.function.isym->generic_id)
 267     {
 268     case GFC_ISYM_TRANSPOSE:
 269       return expr->value.function.actual->expr;
 270
 271     default:
 272       return NULL;
 273     }
 274 }
 275
 276
 277 /* Return true if the result of reference REF can only be constructed
 278    using a temporary array.  */
 279
 280 bool
 281 gfc_ref_needs_temporary_p (gfc_ref *ref)
 282 {
 283   int n;
 284   bool subarray_p;
 285
 286   subarray_p = false;
 287   for (; ref; ref = ref->next)
 288     switch (ref->type)
 289       {
 290       case REF_ARRAY:
 291         /* Vector dimensions are generally not monotonic and must be
 292            handled using a temporary.  */
 293         if (ref->u.ar.type == AR_SECTION)
 294           for (n = 0; n < ref->u.ar.dimen; n++)
 295             if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 296               return true;
 297
 298         subarray_p = true;
 299         break;
 300
 301       case REF_SUBSTRING:
 302         /* Within an array reference, character substrings generally
 303            need a temporary.  Character array strides are expressed as
 304            multiples of the element size (consistent with other array
 305            types), not in characters.  */
 306         return subarray_p;
 307
 308       case REF_COMPONENT:
 309         break;
 310       }
 311
 312   return false;
 313 }
 314
 315
 316 /* Return true if array variable VAR could be passed to the same function
 317    as argument EXPR without interfering with EXPR.  INTENT is the intent
 318    of VAR.
 319
 320    This is considerably less conservative than other dependencies
 321    because many function arguments will already be copied into a
 322    temporary.  */
 323
 324 static int
 325 gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
 326                                    gfc_expr * expr)
 327 {
 328   gcc_assert (var->expr_type == EXPR_VARIABLE);
 329   gcc_assert (var->rank > 0);
 330
 331   switch (expr->expr_type)
 332     {
 333     case EXPR_VARIABLE:
 334       return (gfc_ref_needs_temporary_p (expr->ref)
 335               || gfc_check_dependency (var, expr, 1));
 336
 337     case EXPR_ARRAY:
 338       return gfc_check_dependency (var, expr, 1);
 339
 340     case EXPR_FUNCTION:
 341       if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
 342         {
 343           expr = gfc_get_noncopying_intrinsic_argument (expr);
 344           return gfc_check_argument_var_dependency (var, intent, expr);
 345         }
 346       return 0;
 347
 348     default:
 349       return 0;
 350     }
 351 }
 352
 353
 354 /* Like gfc_check_argument_var_dependency, but extended to any
 355    array expression OTHER, not just variables.  */
 356
 357 static int
 358 gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
 359                                gfc_expr * expr)
 360 {
 361   switch (other->expr_type)
 362     {
 363     case EXPR_VARIABLE:
 364       return gfc_check_argument_var_dependency (other, intent, expr);
 365
 366     case EXPR_FUNCTION:
 367       if (other->inline_noncopying_intrinsic)
 368         {
 369           other = gfc_get_noncopying_intrinsic_argument (other);
 370           return gfc_check_argument_dependency (other, INTENT_IN, expr);
 371         }
 372       return 0;
 373
 374     default:
 375       return 0;
 376     }
 377 }
 378
 379
 380 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
 381    FNSYM is the function being called, or NULL if not known.  */
 382
 383 int
 384 gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
 385                              gfc_symbol * fnsym, gfc_actual_arglist * actual)
 386 {
 387   gfc_formal_arglist *formal;
 388   gfc_expr *expr;
 389
 390   formal = fnsym ? fnsym->formal : NULL;
 391   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
 392     {
 393       expr = actual->expr;
 394
 395       /* Skip args which are not present.  */
 396       if (!expr)
 397         continue;
 398
 399       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
 400       if (formal
 401           && intent == INTENT_IN
 402           && formal->sym->attr.intent == INTENT_IN)
 403         continue;
 404
 405       if (gfc_check_argument_dependency (other, intent, expr))
 406         return 1;
 407     }
 408
 409   return 0;
 410 }
 411
 412
 413 /* Return 1 if e1 and e2 are equivalenced arrays, either
 414    directly or indirectly; ie. equivalence (a,b) for a and b
 415    or equivalence (a,c),(b,c).  This function uses the equiv_
 416    lists, generated in trans-common(add_equivalences), that are
 417    guaranteed to pick up indirect equivalences.  A rudimentary
 418    use is made of the offset to ensure that cases where the
 419    source elements are moved down to the destination are not
 420    identified as dependencies.  */
 421
 422 int
 423 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 424 {
 425   gfc_equiv_list *l;
 426   gfc_equiv_info *s, *fl1, *fl2;
 427
 428   gcc_assert (e1->expr_type == EXPR_VARIABLE
 429                 && e2->expr_type == EXPR_VARIABLE);
 430
 431   if (!e1->symtree->n.sym->attr.in_equivalence
 432         || !e2->symtree->n.sym->attr.in_equivalence
 433         || !e1->rank
 434         || !e2->rank)
 435     return 0;
 436
 437   /* Go through the equiv_lists and return 1 if the variables
 438      e1 and e2 are members of the same group and satisfy the
 439      requirement on their relative offsets.  */
 440   for (l = gfc_current_ns->equiv_lists; l; l = l->next)
 441     {
 442       fl1 = NULL;
 443       fl2 = NULL;
 444       for (s = l->equiv; s; s = s->next)
 445         {
 446           if (s->sym == e1->symtree->n.sym)
 447             fl1 = s;
 448           if (s->sym == e2->symtree->n.sym)
 449             fl2 = s;
 450           if (fl1 && fl2 && (fl1->offset > fl2->offset))
 451             return 1;
 452         }
 453     }
 454 return 0;
 455 }
 456
 457
 458 /* Return true if the statement body redefines the condition.  Returns
 459    true if expr2 depends on expr1.  expr1 should be a single term
 460    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 461    whether array references to the same symbol with identical range
 462    references count as a dependency or not.  Used for forall and where
 463    statements.  Also used with functions returning arrays without a
 464    temporary.  */
 465
 466 int
 467 gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
 468 {
 469   gfc_ref *ref;
 470   int n;
 471   gfc_actual_arglist *actual;
 472
 473   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 474
 475   /* TODO: -fassume-no-pointer-aliasing */
 476   if (expr1->symtree->n.sym->attr.pointer)
 477     return 1;
 478   for (ref = expr1->ref; ref; ref = ref->next)
 479     {
 480       if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 481         return 1;
 482     }
 483
 484   switch (expr2->expr_type)
 485     {
 486     case EXPR_OP:
 487       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
 488       if (n)
 489         return n;
 490       if (expr2->value.op.op2)
 491         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
 492       return 0;
 493
 494     case EXPR_VARIABLE:
 495       if (expr2->symtree->n.sym->attr.pointer)
 496         return 1;
 497
 498       for (ref = expr2->ref; ref; ref = ref->next)
 499         {
 500           if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 501             return 1;
 502         }
 503
 504       /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
 505       if (gfc_are_equivalenced_arrays (expr1, expr2))
 506         return 1;
 507
 508       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 509         return 0;
 510
 511       if (identical)
 512         return 1;
 513
 514       /* Identical and disjoint ranges return 0,
 515          overlapping ranges return 1.  */
 516       /* Return zero if we refer to the same full arrays.  */
 517       if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY)
 518         return gfc_dep_resolver (expr1->ref, expr2->ref);
 519
 520       return 1;
 521
 522     case EXPR_FUNCTION:
 523       if (expr2->inline_noncopying_intrinsic)
 524         identical = 1;
 525       /* Remember possible differences between elemental and
 526          transformational functions.  All functions inside a FORALL
 527          will be pure.  */
 528       for (actual = expr2->value.function.actual;
 529            actual; actual = actual->next)
 530         {
 531           if (!actual->expr)
 532             continue;
 533           n = gfc_check_dependency (expr1, actual->expr, identical);
 534           if (n)
 535             return n;
 536         }
 537       return 0;
 538
 539     case EXPR_CONSTANT:
 540       return 0;
 541
 542     case EXPR_ARRAY:
 543       /* Probably ok in the majority of (constant) cases.  */
 544       return 1;
 545
 546     default:
 547       return 1;
 548     }
 549 }
 550
 551
 552 /* Calculates size of the array reference using lower bound, upper bound
 553    and stride.  */
 554
 555 static void
 556 get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
 557 {
 558   /* nNoOfEle = (u1-l1)/s1  */
 559
 560   mpz_sub (ele, u1->value.integer, l1->value.integer);
 561
 562   if (s1 != NULL)
 563     mpz_tdiv_q (ele, ele, s1->value.integer);
 564 }
 565
 566
 567 /* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
 568
 569 static gfc_dependency
 570 get_deps (mpz_t x1, mpz_t x2, mpz_t y)
 571 {
 572   int start;
 573   int end;
 574
 575   start = mpz_cmp_ui (x1, 0);
 576   end = mpz_cmp (x2, y);
 577
 578   /* Both ranges the same.  */
 579   if (start == 0 && end == 0)
 580     return GFC_DEP_EQUAL;
 581
 582   /* Distinct ranges.  */
 583   if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
 584       || (mpz_cmp (x1, y) > 0 && end > 0))
 585     return GFC_DEP_NODEP;
 586
 587   /* Overlapping, but with corresponding elements of the second range
 588      greater than the first.  */
 589   if (start > 0 && end > 0)
 590     return GFC_DEP_FORWARD;
 591
 592   /* Overlapping in some other way.  */
 593   return GFC_DEP_OVERLAP;
 594 }
 595
 596
 597 /* Perform the same linear transformation on sections l and r such that
 598    (l_start:l_end:l_stride) -> (0:no_of_elements)
 599    (r_start:r_end:r_stride) -> (X1:X2)
 600    Where r_end is implicit as both sections must have the same number of
 601    elements.
 602    Returns 0 on success, 1 of the transformation failed.  */
 603 /* TODO: Should this be (0:no_of_elements-1) */
 604
 605 static int
 606 transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
 607                     gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
 608                     gfc_expr * r_start, gfc_expr * r_stride)
 609 {
 610   if (NULL == l_start || NULL == l_end || NULL == r_start)
 611     return 1;
 612
 613   /* TODO : Currently we check the dependency only when start, end and stride
 614     are constant.  We could also check for equal (variable) values, and
 615     common subexpressions, eg. x vs. x+1.  */
 616
 617   if (l_end->expr_type != EXPR_CONSTANT
 618       || l_start->expr_type != EXPR_CONSTANT
 619       || r_start->expr_type != EXPR_CONSTANT
 620       || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
 621       || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
 622     {
 623        return 1;
 624     }
 625
 626
 627   get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
 628
 629   mpz_sub (X1, r_start->value.integer, l_start->value.integer);
 630   if (l_stride != NULL)
 631     mpz_cdiv_q (X1, X1, l_stride->value.integer);
 632
 633   if (r_stride == NULL)
 634     mpz_set (X2, no_of_elements);
 635   else
 636     mpz_mul (X2, no_of_elements, r_stride->value.integer);
 637
 638   if (l_stride != NULL)
 639     mpz_cdiv_q (X2, X2, l_stride->value.integer);
 640   mpz_add (X2, X2, X1);
 641
 642   return 0;
 643 }
 644
 645
 646 /* Determines overlapping for two array sections.  */
 647
 648 static gfc_dependency
 649 gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
 650 {
 651   gfc_expr *l_start;
 652   gfc_expr *l_end;
 653   gfc_expr *l_stride;
 654
 655   gfc_expr *r_start;
 656   gfc_expr *r_stride;
 657
 658   gfc_array_ref l_ar;
 659   gfc_array_ref r_ar;
 660
 661   mpz_t no_of_elements;
 662   mpz_t X1, X2;
 663   gfc_dependency dep;
 664
 665   l_ar = lref->u.ar;
 666   r_ar = rref->u.ar;
 667
 668   /* If they are the same range, return without more ado.  */
 669   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 670     return GFC_DEP_EQUAL;
 671
 672   l_start = l_ar.start[n];
 673   l_end = l_ar.end[n];
 674   l_stride = l_ar.stride[n];
 675   r_start = r_ar.start[n];
 676   r_stride = r_ar.stride[n];
 677
 678   /* if l_start is NULL take it from array specifier  */
 679   if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
 680     l_start = l_ar.as->lower[n];
 681
 682   /* if l_end is NULL take it from array specifier  */
 683   if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
 684     l_end = l_ar.as->upper[n];
 685
 686   /* if r_start is NULL take it from array specifier  */
 687   if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
 688     r_start = r_ar.as->lower[n];
 689
 690   mpz_init (X1);
 691   mpz_init (X2);
 692   mpz_init (no_of_elements);
 693
 694   if (transform_sections (X1, X2, no_of_elements,
 695                           l_start, l_end, l_stride,
 696                           r_start, r_stride))
 697     dep = GFC_DEP_OVERLAP;
 698   else
 699     dep =  get_deps (X1, X2, no_of_elements);
 700
 701   mpz_clear (no_of_elements);
 702   mpz_clear (X1);
 703   mpz_clear (X2);
 704   return dep;
 705 }
 706
 707
 708 /* Checks if the expr chk is inside the range left-right.
 709    Returns  GFC_DEP_NODEP if chk is outside the range,
 710    GFC_DEP_OVERLAP otherwise.
 711    Assumes left<=right.  */
 712
 713 static gfc_dependency
 714 gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
 715 {
 716   int l;
 717   int r;
 718   int s;
 719
 720   s = gfc_dep_compare_expr (left, right);
 721   if (s == -2)
 722     return GFC_DEP_OVERLAP;
 723
 724   l = gfc_dep_compare_expr (chk, left);
 725   r = gfc_dep_compare_expr (chk, right);
 726
 727   /* Check for indeterminate relationships.  */
 728   if (l == -2 || r == -2 || s == -2)
 729     return GFC_DEP_OVERLAP;
 730
 731   if (s == 1)
 732     {
 733       /* When left>right we want to check for right <= chk <= left.  */
 734       if (l <= 0 || r >= 0)
 735         return GFC_DEP_OVERLAP;
 736     }
 737   else
 738     {
 739       /* Otherwise check for left <= chk <= right.  */
 740       if (l >= 0 || r <= 0)
 741         return GFC_DEP_OVERLAP;
 742     }
 743
 744   return GFC_DEP_NODEP;
 745 }
 746
 747
 748 /* Determines overlapping for a single element and a section.  */
 749
 750 static gfc_dependency
 751 gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
 752 {
 753   gfc_array_ref l_ar;
 754   gfc_array_ref r_ar;
 755   gfc_expr *l_start;
 756   gfc_expr *r_start;
 757   gfc_expr *r_end;
 758
 759   l_ar = lref->u.ar;
 760   r_ar = rref->u.ar;
 761   l_start = l_ar.start[n] ;
 762   r_start = r_ar.start[n] ;
 763   r_end = r_ar.end[n] ;
 764   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 765     r_start = r_ar.as->lower[n];
 766   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 767     r_end = r_ar.as->upper[n];
 768   if (NULL == r_start || NULL == r_end || l_start == NULL)
 769     return GFC_DEP_OVERLAP;
 770
 771   return gfc_is_inside_range (l_start, r_end, r_start);
 772 }
 773
 774
 775 /* Determines overlapping for two single element array references.  */
 776
 777 static gfc_dependency
 778 gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
 779 {
 780   gfc_array_ref l_ar;
 781   gfc_array_ref r_ar;
 782   gfc_expr *l_start;
 783   gfc_expr *r_start;
 784   int i;
 785
 786   l_ar = lref->u.ar;
 787   r_ar = rref->u.ar;
 788   l_start = l_ar.start[n] ;
 789   r_start = r_ar.start[n] ;
 790   i = gfc_dep_compare_expr (r_start, l_start);
 791   if (i == 0)
 792     return GFC_DEP_EQUAL;
 793   if (i == -2)
 794     return GFC_DEP_OVERLAP;
 795   return GFC_DEP_NODEP;
 796 }
 797
 798
 799 /* Finds if two array references are overlapping or not.
 800    Return value
 801         1 : array references are overlapping.
 802         0 : array references are identical or not overlapping.  */
 803
 804 int
 805 gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
 806 {
 807   int n;
 808   gfc_dependency fin_dep;
 809   gfc_dependency this_dep;
 810
 811
 812   fin_dep = GFC_DEP_ERROR;
 813   /* Dependencies due to pointers should already have been identified.
 814      We only need to check for overlapping array references.  */
 815
 816   while (lref && rref)
 817     {
 818       /* We're resolving from the same base symbol, so both refs should be
 819          the same type.  We traverse the reference chain intil we find ranges
 820          that are not equal.  */
 821       gcc_assert (lref->type == rref->type);
 822       switch (lref->type)
 823         {
 824         case REF_COMPONENT:
 825           /* The two ranges can't overlap if they are from different
 826              components.  */
 827           if (lref->u.c.component != rref->u.c.component)
 828             return 0;
 829           break;
 830
 831         case REF_SUBSTRING:
 832           /* Substring overlaps are handled by the string assignment code.  */
 833           return 0;
 834
 835         case REF_ARRAY:
 836           for (n=0; n < lref->u.ar.dimen; n++)
 837             {
 838               /* Assume dependency when either of array reference is vector
 839                  subscript.  */
 840               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
 841                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 842                 return 1;
 843               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
 844                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 845                 this_dep = gfc_check_section_vs_section (lref, rref, n);
 846               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 847                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 848                 this_dep = gfc_check_element_vs_section (lref, rref, n);
 849               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 850                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
 851                 this_dep = gfc_check_element_vs_section (rref, lref, n);
 852               else
 853                 {
 854                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 855                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
 856                   this_dep = gfc_check_element_vs_element (rref, lref, n);
 857                 }
 858
 859               /* If any dimension doesn't overlap, we have no dependency.  */
 860               if (this_dep == GFC_DEP_NODEP)
 861                 return 0;
 862
 863               /* Overlap codes are in order of priority.  We only need to
 864                  know the worst one.*/
 865               if (this_dep > fin_dep)
 866                 fin_dep = this_dep;
 867             }
 868           /* Exactly matching and forward overlapping ranges don't cause a
 869              dependency.  */
 870           if (fin_dep < GFC_DEP_OVERLAP)
 871             return 0;
 872
 873           /* Keep checking.  We only have a dependency if
 874              subsequent references also overlap.  */
 875           break;
 876
 877         default:
 878           gcc_unreachable ();
 879         }
 880       lref = lref->next;
 881       rref = rref->next;
 882     }
 883
 884   /* If we haven't seen any array refs then something went wrong.  */
 885   gcc_assert (fin_dep != GFC_DEP_ERROR);
 886
 887   /* Assume the worst if we nest to different depths.  */
 888   if (lref || rref)
 889     return 1;
 890
 891   return fin_dep == GFC_DEP_OVERLAP;
 892 }
 893