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.  We explicitly
 418    check for overlap using the offset and length of the equivalence.
 419    This function is symmetric.
 420    TODO: This function only checks whether the full top-level
 421    symbols overlap.  An improved implementation could inspect
 422    e1->ref and e2->ref to determine whether the actually accessed
 423    portions of these variables/arrays potentially overlap.  */
 424
 425 int
 426 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 427 {
 428   gfc_equiv_list *l;
 429   gfc_equiv_info *s, *fl1, *fl2;
 430
 431   gcc_assert (e1->expr_type == EXPR_VARIABLE
 432                 && e2->expr_type == EXPR_VARIABLE);
 433
 434   if (!e1->symtree->n.sym->attr.in_equivalence
 435         || !e2->symtree->n.sym->attr.in_equivalence
 436         || !e1->rank
 437         || !e2->rank)
 438     return 0;
 439
 440   /* Go through the equiv_lists and return 1 if the variables
 441      e1 and e2 are members of the same group and satisfy the
 442      requirement on their relative offsets.  */
 443   for (l = gfc_current_ns->equiv_lists; l; l = l->next)
 444     {
 445       fl1 = NULL;
 446       fl2 = NULL;
 447       for (s = l->equiv; s; s = s->next)
 448         {
 449           if (s->sym == e1->symtree->n.sym)
 450             {
 451               fl1 = s;
 452               if (fl2)
 453                 break;
 454             }
 455           if (s->sym == e2->symtree->n.sym)
 456             {
 457               fl2 = s;
 458               if (fl1)
 459                 break;
 460             }
 461         }
 462
 463       if (s)
 464         {
 465           /* Can these lengths be zero?  */
 466           if (fl1->length <= 0 || fl2->length <= 0)
 467             return 1;
 468           /* These can't overlap if [f11,fl1+length] is before
 469              [fl2,fl2+length], or [fl2,fl2+length] is before
 470              [fl1,fl1+length], otherwise they do overlap.  */
 471           if (fl1->offset + fl1->length > fl2->offset
 472               && fl2->offset + fl2->length > fl1->offset)
 473             return 1;
 474         }
 475     }
 476   return 0;
 477 }
 478
 479
 480 /* Return true if the statement body redefines the condition.  Returns
 481    true if expr2 depends on expr1.  expr1 should be a single term
 482    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 483    whether array references to the same symbol with identical range
 484    references count as a dependency or not.  Used for forall and where
 485    statements.  Also used with functions returning arrays without a
 486    temporary.  */
 487
 488 int
 489 gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
 490 {
 491   gfc_ref *ref;
 492   int n;
 493   gfc_actual_arglist *actual;
 494
 495   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 496
 497   /* TODO: -fassume-no-pointer-aliasing */
 498   if (expr1->symtree->n.sym->attr.pointer)
 499     return 1;
 500   for (ref = expr1->ref; ref; ref = ref->next)
 501     {
 502       if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 503         return 1;
 504     }
 505
 506   switch (expr2->expr_type)
 507     {
 508     case EXPR_OP:
 509       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
 510       if (n)
 511         return n;
 512       if (expr2->value.op.op2)
 513         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
 514       return 0;
 515
 516     case EXPR_VARIABLE:
 517       if (expr2->symtree->n.sym->attr.pointer)
 518         return 1;
 519
 520       for (ref = expr2->ref; ref; ref = ref->next)
 521         {
 522           if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 523             return 1;
 524         }
 525
 526       /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
 527       if (gfc_are_equivalenced_arrays (expr1, expr2))
 528         return 1;
 529
 530       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 531         return 0;
 532
 533       if (identical)
 534         return 1;
 535
 536       /* Identical and disjoint ranges return 0,
 537          overlapping ranges return 1.  */
 538       /* Return zero if we refer to the same full arrays.  */
 539       if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY)
 540         return gfc_dep_resolver (expr1->ref, expr2->ref);
 541
 542       return 1;
 543
 544     case EXPR_FUNCTION:
 545       if (expr2->inline_noncopying_intrinsic)
 546         identical = 1;
 547       /* Remember possible differences between elemental and
 548          transformational functions.  All functions inside a FORALL
 549          will be pure.  */
 550       for (actual = expr2->value.function.actual;
 551            actual; actual = actual->next)
 552         {
 553           if (!actual->expr)
 554             continue;
 555           n = gfc_check_dependency (expr1, actual->expr, identical);
 556           if (n)
 557             return n;
 558         }
 559       return 0;
 560
 561     case EXPR_CONSTANT:
 562       return 0;
 563
 564     case EXPR_ARRAY:
 565       /* Probably ok in the majority of (constant) cases.  */
 566       return 1;
 567
 568     default:
 569       return 1;
 570     }
 571 }
 572
 573
 574 /* Calculates size of the array reference using lower bound, upper bound
 575    and stride.  */
 576
 577 static void
 578 get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
 579 {
 580   /* nNoOfEle = (u1-l1)/s1  */
 581
 582   mpz_sub (ele, u1->value.integer, l1->value.integer);
 583
 584   if (s1 != NULL)
 585     mpz_tdiv_q (ele, ele, s1->value.integer);
 586 }
 587
 588
 589 /* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
 590
 591 static gfc_dependency
 592 get_deps (mpz_t x1, mpz_t x2, mpz_t y)
 593 {
 594   int start;
 595   int end;
 596
 597   start = mpz_cmp_ui (x1, 0);
 598   end = mpz_cmp (x2, y);
 599
 600   /* Both ranges the same.  */
 601   if (start == 0 && end == 0)
 602     return GFC_DEP_EQUAL;
 603
 604   /* Distinct ranges.  */
 605   if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
 606       || (mpz_cmp (x1, y) > 0 && end > 0))
 607     return GFC_DEP_NODEP;
 608
 609   /* Overlapping, but with corresponding elements of the second range
 610      greater than the first.  */
 611   if (start > 0 && end > 0)
 612     return GFC_DEP_FORWARD;
 613
 614   /* Overlapping in some other way.  */
 615   return GFC_DEP_OVERLAP;
 616 }
 617
 618
 619 /* Perform the same linear transformation on sections l and r such that
 620    (l_start:l_end:l_stride) -> (0:no_of_elements)
 621    (r_start:r_end:r_stride) -> (X1:X2)
 622    Where r_end is implicit as both sections must have the same number of
 623    elements.
 624    Returns 0 on success, 1 of the transformation failed.  */
 625 /* TODO: Should this be (0:no_of_elements-1) */
 626
 627 static int
 628 transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
 629                     gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
 630                     gfc_expr * r_start, gfc_expr * r_stride)
 631 {
 632   if (NULL == l_start || NULL == l_end || NULL == r_start)
 633     return 1;
 634
 635   /* TODO : Currently we check the dependency only when start, end and stride
 636     are constant.  We could also check for equal (variable) values, and
 637     common subexpressions, eg. x vs. x+1.  */
 638
 639   if (l_end->expr_type != EXPR_CONSTANT
 640       || l_start->expr_type != EXPR_CONSTANT
 641       || r_start->expr_type != EXPR_CONSTANT
 642       || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
 643       || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
 644     {
 645        return 1;
 646     }
 647
 648
 649   get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
 650
 651   mpz_sub (X1, r_start->value.integer, l_start->value.integer);
 652   if (l_stride != NULL)
 653     mpz_cdiv_q (X1, X1, l_stride->value.integer);
 654
 655   if (r_stride == NULL)
 656     mpz_set (X2, no_of_elements);
 657   else
 658     mpz_mul (X2, no_of_elements, r_stride->value.integer);
 659
 660   if (l_stride != NULL)
 661     mpz_cdiv_q (X2, X2, l_stride->value.integer);
 662   mpz_add (X2, X2, X1);
 663
 664   return 0;
 665 }
 666
 667
 668 /* Determines overlapping for two array sections.  */
 669
 670 static gfc_dependency
 671 gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
 672 {
 673   gfc_expr *l_start;
 674   gfc_expr *l_end;
 675   gfc_expr *l_stride;
 676
 677   gfc_expr *r_start;
 678   gfc_expr *r_stride;
 679
 680   gfc_array_ref l_ar;
 681   gfc_array_ref r_ar;
 682
 683   mpz_t no_of_elements;
 684   mpz_t X1, X2;
 685   gfc_dependency dep;
 686
 687   l_ar = lref->u.ar;
 688   r_ar = rref->u.ar;
 689
 690   /* If they are the same range, return without more ado.  */
 691   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 692     return GFC_DEP_EQUAL;
 693
 694   l_start = l_ar.start[n];
 695   l_end = l_ar.end[n];
 696   l_stride = l_ar.stride[n];
 697   r_start = r_ar.start[n];
 698   r_stride = r_ar.stride[n];
 699
 700   /* if l_start is NULL take it from array specifier  */
 701   if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
 702     l_start = l_ar.as->lower[n];
 703
 704   /* if l_end is NULL take it from array specifier  */
 705   if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
 706     l_end = l_ar.as->upper[n];
 707
 708   /* if r_start is NULL take it from array specifier  */
 709   if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
 710     r_start = r_ar.as->lower[n];
 711
 712   mpz_init (X1);
 713   mpz_init (X2);
 714   mpz_init (no_of_elements);
 715
 716   if (transform_sections (X1, X2, no_of_elements,
 717                           l_start, l_end, l_stride,
 718                           r_start, r_stride))
 719     dep = GFC_DEP_OVERLAP;
 720   else
 721     dep =  get_deps (X1, X2, no_of_elements);
 722
 723   mpz_clear (no_of_elements);
 724   mpz_clear (X1);
 725   mpz_clear (X2);
 726   return dep;
 727 }
 728
 729
 730 /* Checks if the expr chk is inside the range left-right.
 731    Returns  GFC_DEP_NODEP if chk is outside the range,
 732    GFC_DEP_OVERLAP otherwise.
 733    Assumes left<=right.  */
 734
 735 static gfc_dependency
 736 gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
 737 {
 738   int l;
 739   int r;
 740   int s;
 741
 742   s = gfc_dep_compare_expr (left, right);
 743   if (s == -2)
 744     return GFC_DEP_OVERLAP;
 745
 746   l = gfc_dep_compare_expr (chk, left);
 747   r = gfc_dep_compare_expr (chk, right);
 748
 749   /* Check for indeterminate relationships.  */
 750   if (l == -2 || r == -2 || s == -2)
 751     return GFC_DEP_OVERLAP;
 752
 753   if (s == 1)
 754     {
 755       /* When left>right we want to check for right <= chk <= left.  */
 756       if (l <= 0 || r >= 0)
 757         return GFC_DEP_OVERLAP;
 758     }
 759   else
 760     {
 761       /* Otherwise check for left <= chk <= right.  */
 762       if (l >= 0 || r <= 0)
 763         return GFC_DEP_OVERLAP;
 764     }
 765
 766   return GFC_DEP_NODEP;
 767 }
 768
 769
 770 /* Determines overlapping for a single element and a section.  */
 771
 772 static gfc_dependency
 773 gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
 774 {
 775   gfc_array_ref l_ar;
 776   gfc_array_ref r_ar;
 777   gfc_expr *l_start;
 778   gfc_expr *r_start;
 779   gfc_expr *r_end;
 780
 781   l_ar = lref->u.ar;
 782   r_ar = rref->u.ar;
 783   l_start = l_ar.start[n] ;
 784   r_start = r_ar.start[n] ;
 785   r_end = r_ar.end[n] ;
 786   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 787     r_start = r_ar.as->lower[n];
 788   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 789     r_end = r_ar.as->upper[n];
 790   if (NULL == r_start || NULL == r_end || l_start == NULL)
 791     return GFC_DEP_OVERLAP;
 792
 793   return gfc_is_inside_range (l_start, r_end, r_start);
 794 }
 795
 796
 797 /* Determines overlapping for two single element array references.  */
 798
 799 static gfc_dependency
 800 gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
 801 {
 802   gfc_array_ref l_ar;
 803   gfc_array_ref r_ar;
 804   gfc_expr *l_start;
 805   gfc_expr *r_start;
 806   int i;
 807
 808   l_ar = lref->u.ar;
 809   r_ar = rref->u.ar;
 810   l_start = l_ar.start[n] ;
 811   r_start = r_ar.start[n] ;
 812   i = gfc_dep_compare_expr (r_start, l_start);
 813   if (i == 0)
 814     return GFC_DEP_EQUAL;
 815   if (i == -2)
 816     return GFC_DEP_OVERLAP;
 817   return GFC_DEP_NODEP;
 818 }
 819
 820
 821 /* Finds if two array references are overlapping or not.
 822    Return value
 823         1 : array references are overlapping.
 824         0 : array references are identical or not overlapping.  */
 825
 826 int
 827 gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
 828 {
 829   int n;
 830   gfc_dependency fin_dep;
 831   gfc_dependency this_dep;
 832
 833
 834   fin_dep = GFC_DEP_ERROR;
 835   /* Dependencies due to pointers should already have been identified.
 836      We only need to check for overlapping array references.  */
 837
 838   while (lref && rref)
 839     {
 840       /* We're resolving from the same base symbol, so both refs should be
 841          the same type.  We traverse the reference chain intil we find ranges
 842          that are not equal.  */
 843       gcc_assert (lref->type == rref->type);
 844       switch (lref->type)
 845         {
 846         case REF_COMPONENT:
 847           /* The two ranges can't overlap if they are from different
 848              components.  */
 849           if (lref->u.c.component != rref->u.c.component)
 850             return 0;
 851           break;
 852
 853         case REF_SUBSTRING:
 854           /* Substring overlaps are handled by the string assignment code.  */
 855           return 0;
 856
 857         case REF_ARRAY:
 858           for (n=0; n < lref->u.ar.dimen; n++)
 859             {
 860               /* Assume dependency when either of array reference is vector
 861                  subscript.  */
 862               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
 863                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 864                 return 1;
 865               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
 866                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 867                 this_dep = gfc_check_section_vs_section (lref, rref, n);
 868               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 869                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 870                 this_dep = gfc_check_element_vs_section (lref, rref, n);
 871               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 872                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
 873                 this_dep = gfc_check_element_vs_section (rref, lref, n);
 874               else
 875                 {
 876                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 877                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
 878                   this_dep = gfc_check_element_vs_element (rref, lref, n);
 879                 }
 880
 881               /* If any dimension doesn't overlap, we have no dependency.  */
 882               if (this_dep == GFC_DEP_NODEP)
 883                 return 0;
 884
 885               /* Overlap codes are in order of priority.  We only need to
 886                  know the worst one.*/
 887               if (this_dep > fin_dep)
 888                 fin_dep = this_dep;
 889             }
 890           /* Exactly matching and forward overlapping ranges don't cause a
 891              dependency.  */
 892           if (fin_dep < GFC_DEP_OVERLAP)
 893             return 0;
 894
 895           /* Keep checking.  We only have a dependency if
 896              subsequent references also overlap.  */
 897           break;
 898
 899         default:
 900           gcc_unreachable ();
 901         }
 902       lref = lref->next;
 903       rref = rref->next;
 904     }
 905
 906   /* If we haven't seen any array refs then something went wrong.  */
 907   gcc_assert (fin_dep != GFC_DEP_ERROR);
 908
 909   /* Assume the worst if we nest to different depths.  */
 910   if (lref || rref)
 911     return 1;
 912
 913   return fin_dep == GFC_DEP_OVERLAP;
 914 }
 915