gcc/fortran/dependency.c

   1 /* Dependency analysis
   2    Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
   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 "system.h"
  29 #include "gfortran.h"
  30 #include "dependency.h"
  31 #include "constructor.h"
  32 #include "arith.h"
  33
  34 /* static declarations */
  35 /* Enums  */
  36 enum range {LHS, RHS, MID};
  37
  38 /* Dependency types.  These must be in reverse order of priority.  */
  39 typedef enum
  40 {
  41   GFC_DEP_ERROR,
  42   GFC_DEP_EQUAL,        /* Identical Ranges.  */
  43   GFC_DEP_FORWARD,      /* e.g., a(1:3) = a(2:4).  */
  44   GFC_DEP_BACKWARD,     /* e.g. a(2:4) = a(1:3).  */
  45   GFC_DEP_OVERLAP,      /* May overlap in some other way.  */
  46   GFC_DEP_NODEP         /* Distinct ranges.  */
  47 }
  48 gfc_dependency;
  49
  50 /* Macros */
  51 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
  52
  53 /* Forward declarations */
  54
  55 static gfc_dependency check_section_vs_section (gfc_array_ref *,
  56                                                 gfc_array_ref *, int);
  57
  58 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
  59    def if the value could not be determined.  */
  60
  61 int
  62 gfc_expr_is_one (gfc_expr *expr, int def)
  63 {
  64   gcc_assert (expr != NULL);
  65
  66   if (expr->expr_type != EXPR_CONSTANT)
  67     return def;
  68
  69   if (expr->ts.type != BT_INTEGER)
  70     return def;
  71
  72   return mpz_cmp_si (expr->value.integer, 1) == 0;
  73 }
  74
  75 /* Check if two array references are known to be identical.  Calls
  76    gfc_dep_compare_expr if necessary for comparing array indices.  */
  77
  78 static bool
  79 identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
  80 {
  81   int i;
  82
  83   if (a1->type == AR_FULL && a2->type == AR_FULL)
  84     return true;
  85
  86   if (a1->type == AR_SECTION && a2->type == AR_SECTION)
  87     {
  88       gcc_assert (a1->dimen == a2->dimen);
  89
  90       for ( i = 0; i < a1->dimen; i++)
  91         {
  92           /* TODO: Currently, we punt on an integer array as an index.  */
  93           if (a1->dimen_type[i] != DIMEN_RANGE
  94               || a2->dimen_type[i] != DIMEN_RANGE)
  95             return false;
  96
  97           if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
  98             return false;
  99         }
 100       return true;
 101     }
 102
 103   if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
 104     {
 105       gcc_assert (a1->dimen == a2->dimen);
 106       for (i = 0; i < a1->dimen; i++)
 107         {
 108           if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
 109             return false;
 110         }
 111       return true;
 112     }
 113   return false;
 114 }
 115
 116
 117
 118 /* Return true for identical variables, checking for references if
 119    necessary.  Calls identical_array_ref for checking array sections.  */
 120
 121 bool
 122 gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
 123 {
 124   gfc_ref *r1, *r2;
 125
 126   if (e1->symtree->n.sym != e2->symtree->n.sym)
 127     return false;
 128
 129   /* Volatile variables should never compare equal to themselves.  */
 130
 131   if (e1->symtree->n.sym->attr.volatile_)
 132     return false;
 133
 134   r1 = e1->ref;
 135   r2 = e2->ref;
 136
 137   while (r1 != NULL || r2 != NULL)
 138     {
 139
 140       /* Assume the variables are not equal if one has a reference and the
 141          other doesn't.
 142          TODO: Handle full references like comparing a(:) to a.
 143       */
 144
 145       if (r1 == NULL || r2 == NULL)
 146         return false;
 147
 148       if (r1->type != r2->type)
 149         return false;
 150
 151       switch (r1->type)
 152         {
 153
 154         case REF_ARRAY:
 155           if (!identical_array_ref (&r1->u.ar,  &r2->u.ar))
 156             return false;
 157
 158           break;
 159
 160         case REF_COMPONENT:
 161           if (r1->u.c.component != r2->u.c.component)
 162             return false;
 163           break;
 164
 165         case REF_SUBSTRING:
 166           if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0
 167               || gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
 168             return false;
 169           break;
 170
 171         default:
 172           gfc_internal_error ("gfc_are_identical_variables: Bad type");
 173         }
 174       r1 = r1->next;
 175       r2 = r2->next;
 176     }
 177   return true;
 178 }
 179
 180 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
 181    and -2 if the relationship could not be determined.  */
 182
 183 int
 184 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
 185 {
 186   gfc_actual_arglist *args1;
 187   gfc_actual_arglist *args2;
 188   int i;
 189   gfc_expr *n1, *n2;
 190
 191   n1 = NULL;
 192   n2 = NULL;
 193
 194   /* Remove any integer conversion functions to larger types.  */
 195   if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
 196       && e1->value.function.isym->id == GFC_ISYM_CONVERSION
 197       && e1->ts.type == BT_INTEGER)
 198     {
 199       args1 = e1->value.function.actual;
 200       if (args1->expr->ts.type == BT_INTEGER
 201           && e1->ts.kind > args1->expr->ts.kind)
 202         n1 = args1->expr;
 203     }
 204
 205   if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
 206       && e2->value.function.isym->id == GFC_ISYM_CONVERSION
 207       && e2->ts.type == BT_INTEGER)
 208     {
 209       args2 = e2->value.function.actual;
 210       if (args2->expr->ts.type == BT_INTEGER
 211           && e2->ts.kind > args2->expr->ts.kind)
 212         n2 = args2->expr;
 213     }
 214
 215   if (n1 != NULL)
 216     {
 217       if (n2 != NULL)
 218         return gfc_dep_compare_expr (n1, n2);
 219       else
 220         return gfc_dep_compare_expr (n1, e2);
 221     }
 222   else
 223     {
 224       if (n2 != NULL)
 225         return gfc_dep_compare_expr (e1, n2);
 226     }
 227
 228   if (e1->expr_type == EXPR_OP
 229       && (e1->value.op.op == INTRINSIC_UPLUS
 230           || e1->value.op.op == INTRINSIC_PARENTHESES))
 231     return gfc_dep_compare_expr (e1->value.op.op1, e2);
 232   if (e2->expr_type == EXPR_OP
 233       && (e2->value.op.op == INTRINSIC_UPLUS
 234           || e2->value.op.op == INTRINSIC_PARENTHESES))
 235     return gfc_dep_compare_expr (e1, e2->value.op.op1);
 236
 237   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
 238     {
 239       /* Compare X+C vs. X.  */
 240       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
 241           && e1->value.op.op2->ts.type == BT_INTEGER
 242           && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
 243         return mpz_sgn (e1->value.op.op2->value.integer);
 244
 245       /* Compare P+Q vs. R+S.  */
 246       if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
 247         {
 248           int l, r;
 249
 250           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 251           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 252           if (l == 0 && r == 0)
 253             return 0;
 254           if (l == 0 && r != -2)
 255             return r;
 256           if (l != -2 && r == 0)
 257             return l;
 258           if (l == 1 && r == 1)
 259             return 1;
 260           if (l == -1 && r == -1)
 261             return -1;
 262
 263           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
 264           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
 265           if (l == 0 && r == 0)
 266             return 0;
 267           if (l == 0 && r != -2)
 268             return r;
 269           if (l != -2 && r == 0)
 270             return l;
 271           if (l == 1 && r == 1)
 272             return 1;
 273           if (l == -1 && r == -1)
 274             return -1;
 275         }
 276     }
 277
 278   /* Compare X vs. X+C.  */
 279   if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
 280     {
 281       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
 282           && e2->value.op.op2->ts.type == BT_INTEGER
 283           && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
 284         return -mpz_sgn (e2->value.op.op2->value.integer);
 285     }
 286
 287   /* Compare X-C vs. X.  */
 288   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
 289     {
 290       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
 291           && e1->value.op.op2->ts.type == BT_INTEGER
 292           && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
 293         return -mpz_sgn (e1->value.op.op2->value.integer);
 294
 295       /* Compare P-Q vs. R-S.  */
 296       if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 297         {
 298           int l, r;
 299
 300           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 301           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 302           if (l == 0 && r == 0)
 303             return 0;
 304           if (l != -2 && r == 0)
 305             return l;
 306           if (l == 0 && r != -2)
 307             return -r;
 308           if (l == 1 && r == -1)
 309             return 1;
 310           if (l == -1 && r == 1)
 311             return -1;
 312         }
 313     }
 314
 315   /* Compare A // B vs. C // D.  */
 316
 317   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
 318       && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
 319     {
 320       int l, r;
 321
 322       l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 323       r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 324
 325       if (l == -2)
 326         return -2;
 327
 328       if (l == 0)
 329         {
 330           /* Watch out for 'A ' // x vs. 'A' // x.  */
 331           gfc_expr *e1_left = e1->value.op.op1;
 332           gfc_expr *e2_left = e2->value.op.op1;
 333
 334           if (e1_left->expr_type == EXPR_CONSTANT
 335               && e2_left->expr_type == EXPR_CONSTANT
 336               && e1_left->value.character.length
 337                 != e2_left->value.character.length)
 338             return -2;
 339           else
 340             return r;
 341         }
 342       else
 343         {
 344           if (l != 0)
 345             return l;
 346           else
 347             return r;
 348         }
 349     }
 350
 351   /* Compare X vs. X-C.  */
 352   if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 353     {
 354       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
 355           && e2->value.op.op2->ts.type == BT_INTEGER
 356           && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
 357         return mpz_sgn (e2->value.op.op2->value.integer);
 358     }
 359
 360   if (e1->expr_type != e2->expr_type)
 361     return -2;
 362
 363   switch (e1->expr_type)
 364     {
 365     case EXPR_CONSTANT:
 366       /* Compare strings for equality.  */
 367       if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
 368         return gfc_compare_string (e1, e2);
 369
 370       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
 371         return -2;
 372
 373       i = mpz_cmp (e1->value.integer, e2->value.integer);
 374       if (i == 0)
 375         return 0;
 376       else if (i < 0)
 377         return -1;
 378       return 1;
 379
 380     case EXPR_VARIABLE:
 381       if (gfc_are_identical_variables (e1, e2))
 382         return 0;
 383       else
 384         return -2;
 385
 386     case EXPR_OP:
 387       /* Intrinsic operators are the same if their operands are the same.  */
 388       if (e1->value.op.op != e2->value.op.op)
 389         return -2;
 390       if (e1->value.op.op2 == 0)
 391         {
 392           i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 393           return i == 0 ? 0 : -2;
 394         }
 395       if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
 396           && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
 397         return 0;
 398       /* TODO Handle commutative binary operators here?  */
 399       return -2;
 400
 401     case EXPR_FUNCTION:
 402
 403       /* PURE functions can be compared for argument equality.  */
 404       if ((e1->value.function.esym && e2->value.function.esym
 405            && e1->value.function.esym == e2->value.function.esym
 406            && e1->value.function.esym->result->attr.pure)
 407           || (e1->value.function.isym && e2->value.function.isym
 408               && e1->value.function.isym == e2->value.function.isym
 409               && e1->value.function.isym->pure))
 410         {
 411           args1 = e1->value.function.actual;
 412           args2 = e2->value.function.actual;
 413
 414           /* Compare the argument lists for equality.  */
 415           while (args1 && args2)
 416             {
 417               /*  Bitwise xor, since C has no non-bitwise xor operator.  */
 418               if ((args1->expr == NULL) ^ (args2->expr == NULL))
 419                 return -2;
 420
 421               if (args1->expr != NULL && args2->expr != NULL
 422                   && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
 423                 return -2;
 424
 425               args1 = args1->next;
 426               args2 = args2->next;
 427             }
 428           return (args1 || args2) ? -2 : 0;
 429         }
 430       else
 431         return -2;
 432       break;
 433
 434     default:
 435       return -2;
 436     }
 437 }
 438
 439
 440 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
 441    if the results are indeterminate.  N is the dimension to compare.  */
 442
 443 int
 444 gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
 445 {
 446   gfc_expr *e1;
 447   gfc_expr *e2;
 448   int i;
 449
 450   /* TODO: More sophisticated range comparison.  */
 451   gcc_assert (ar1 && ar2);
 452
 453   gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
 454
 455   e1 = ar1->stride[n];
 456   e2 = ar2->stride[n];
 457   /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
 458   if (e1 && !e2)
 459     {
 460       i = gfc_expr_is_one (e1, -1);
 461       if (i == -1)
 462         return def;
 463       else if (i == 0)
 464         return 0;
 465     }
 466   else if (e2 && !e1)
 467     {
 468       i = gfc_expr_is_one (e2, -1);
 469       if (i == -1)
 470         return def;
 471       else if (i == 0)
 472         return 0;
 473     }
 474   else if (e1 && e2)
 475     {
 476       i = gfc_dep_compare_expr (e1, e2);
 477       if (i == -2)
 478         return def;
 479       else if (i != 0)
 480         return 0;
 481     }
 482   /* The strides match.  */
 483
 484   /* Check the range start.  */
 485   e1 = ar1->start[n];
 486   e2 = ar2->start[n];
 487   if (e1 || e2)
 488     {
 489       /* Use the bound of the array if no bound is specified.  */
 490       if (ar1->as && !e1)
 491         e1 = ar1->as->lower[n];
 492
 493       if (ar2->as && !e2)
 494         e2 = ar2->as->lower[n];
 495
 496       /* Check we have values for both.  */
 497       if (!(e1 && e2))
 498         return def;
 499
 500       i = gfc_dep_compare_expr (e1, e2);
 501       if (i == -2)
 502         return def;
 503       else if (i != 0)
 504         return 0;
 505     }
 506
 507   /* Check the range end.  */
 508   e1 = ar1->end[n];
 509   e2 = ar2->end[n];
 510   if (e1 || e2)
 511     {
 512       /* Use the bound of the array if no bound is specified.  */
 513       if (ar1->as && !e1)
 514         e1 = ar1->as->upper[n];
 515
 516       if (ar2->as && !e2)
 517         e2 = ar2->as->upper[n];
 518
 519       /* Check we have values for both.  */
 520       if (!(e1 && e2))
 521         return def;
 522
 523       i = gfc_dep_compare_expr (e1, e2);
 524       if (i == -2)
 525         return def;
 526       else if (i != 0)
 527         return 0;
 528     }
 529
 530   return 1;
 531 }
 532
 533
 534 /* Some array-returning intrinsics can be implemented by reusing the
 535    data from one of the array arguments.  For example, TRANSPOSE does
 536    not necessarily need to allocate new data: it can be implemented
 537    by copying the original array's descriptor and simply swapping the
 538    two dimension specifications.
 539
 540    If EXPR is a call to such an intrinsic, return the argument
 541    whose data can be reused, otherwise return NULL.  */
 542
 543 gfc_expr *
 544 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
 545 {
 546   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
 547     return NULL;
 548
 549   switch (expr->value.function.isym->id)
 550     {
 551     case GFC_ISYM_TRANSPOSE:
 552       return expr->value.function.actual->expr;
 553
 554     default:
 555       return NULL;
 556     }
 557 }
 558
 559
 560 /* Return true if the result of reference REF can only be constructed
 561    using a temporary array.  */
 562
 563 bool
 564 gfc_ref_needs_temporary_p (gfc_ref *ref)
 565 {
 566   int n;
 567   bool subarray_p;
 568
 569   subarray_p = false;
 570   for (; ref; ref = ref->next)
 571     switch (ref->type)
 572       {
 573       case REF_ARRAY:
 574         /* Vector dimensions are generally not monotonic and must be
 575            handled using a temporary.  */
 576         if (ref->u.ar.type == AR_SECTION)
 577           for (n = 0; n < ref->u.ar.dimen; n++)
 578             if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 579               return true;
 580
 581         subarray_p = true;
 582         break;
 583
 584       case REF_SUBSTRING:
 585         /* Within an array reference, character substrings generally
 586            need a temporary.  Character array strides are expressed as
 587            multiples of the element size (consistent with other array
 588            types), not in characters.  */
 589         return subarray_p;
 590
 591       case REF_COMPONENT:
 592         break;
 593       }
 594
 595   return false;
 596 }
 597
 598
 599 static int
 600 gfc_is_data_pointer (gfc_expr *e)
 601 {
 602   gfc_ref *ref;
 603
 604   if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
 605     return 0;
 606
 607   /* No subreference if it is a function  */
 608   gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
 609
 610   if (e->symtree->n.sym->attr.pointer)
 611     return 1;
 612
 613   for (ref = e->ref; ref; ref = ref->next)
 614     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
 615       return 1;
 616
 617   return 0;
 618 }
 619
 620
 621 /* Return true if array variable VAR could be passed to the same function
 622    as argument EXPR without interfering with EXPR.  INTENT is the intent
 623    of VAR.
 624
 625    This is considerably less conservative than other dependencies
 626    because many function arguments will already be copied into a
 627    temporary.  */
 628
 629 static int
 630 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
 631                                    gfc_expr *expr, gfc_dep_check elemental)
 632 {
 633   gfc_expr *arg;
 634
 635   gcc_assert (var->expr_type == EXPR_VARIABLE);
 636   gcc_assert (var->rank > 0);
 637
 638   switch (expr->expr_type)
 639     {
 640     case EXPR_VARIABLE:
 641       /* In case of elemental subroutines, there is no dependency
 642          between two same-range array references.  */
 643       if (gfc_ref_needs_temporary_p (expr->ref)
 644           || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
 645         {
 646           if (elemental == ELEM_DONT_CHECK_VARIABLE)
 647             {
 648               /* Too many false positive with pointers.  */
 649               if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
 650                 {
 651                   /* Elemental procedures forbid unspecified intents,
 652                      and we don't check dependencies for INTENT_IN args.  */
 653                   gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
 654
 655                   /* We are told not to check dependencies.
 656                      We do it, however, and issue a warning in case we find one.
 657                      If a dependency is found in the case
 658                      elemental == ELEM_CHECK_VARIABLE, we will generate
 659                      a temporary, so we don't need to bother the user.  */
 660                   gfc_warning ("INTENT(%s) actual argument at %L might "
 661                                "interfere with actual argument at %L.",
 662                                intent == INTENT_OUT ? "OUT" : "INOUT",
 663                                &var->where, &expr->where);
 664                 }
 665               return 0;
 666             }
 667           else
 668             return 1;
 669         }
 670       return 0;
 671
 672     case EXPR_ARRAY:
 673       return gfc_check_dependency (var, expr, 1);
 674
 675     case EXPR_FUNCTION:
 676       if (intent != INTENT_IN)
 677         {
 678           arg = gfc_get_noncopying_intrinsic_argument (expr);
 679           if (arg != NULL)
 680             return gfc_check_argument_var_dependency (var, intent, arg,
 681                                                       NOT_ELEMENTAL);
 682         }
 683
 684       if (elemental != NOT_ELEMENTAL)
 685         {
 686           if ((expr->value.function.esym
 687                && expr->value.function.esym->attr.elemental)
 688               || (expr->value.function.isym
 689                   && expr->value.function.isym->elemental))
 690             return gfc_check_fncall_dependency (var, intent, NULL,
 691                                                 expr->value.function.actual,
 692                                                 ELEM_CHECK_VARIABLE);
 693         }
 694       return 0;
 695
 696     case EXPR_OP:
 697       /* In case of non-elemental procedures, there is no need to catch
 698          dependencies, as we will make a temporary anyway.  */
 699       if (elemental)
 700         {
 701           /* If the actual arg EXPR is an expression, we need to catch
 702              a dependency between variables in EXPR and VAR,
 703              an intent((IN)OUT) variable.  */
 704           if (expr->value.op.op1
 705               && gfc_check_argument_var_dependency (var, intent,
 706                                                     expr->value.op.op1,
 707                                                     ELEM_CHECK_VARIABLE))
 708             return 1;
 709           else if (expr->value.op.op2
 710                    && gfc_check_argument_var_dependency (var, intent,
 711                                                          expr->value.op.op2,
 712                                                          ELEM_CHECK_VARIABLE))
 713             return 1;
 714         }
 715       return 0;
 716
 717     default:
 718       return 0;
 719     }
 720 }
 721
 722
 723 /* Like gfc_check_argument_var_dependency, but extended to any
 724    array expression OTHER, not just variables.  */
 725
 726 static int
 727 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
 728                                gfc_expr *expr, gfc_dep_check elemental)
 729 {
 730   switch (other->expr_type)
 731     {
 732     case EXPR_VARIABLE:
 733       return gfc_check_argument_var_dependency (other, intent, expr, elemental);
 734
 735     case EXPR_FUNCTION:
 736       other = gfc_get_noncopying_intrinsic_argument (other);
 737       if (other != NULL)
 738         return gfc_check_argument_dependency (other, INTENT_IN, expr,
 739                                               NOT_ELEMENTAL);
 740
 741       return 0;
 742
 743     default:
 744       return 0;
 745     }
 746 }
 747
 748
 749 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
 750    FNSYM is the function being called, or NULL if not known.  */
 751
 752 int
 753 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
 754                              gfc_symbol *fnsym, gfc_actual_arglist *actual,
 755                              gfc_dep_check elemental)
 756 {
 757   gfc_formal_arglist *formal;
 758   gfc_expr *expr;
 759
 760   formal = fnsym ? fnsym->formal : NULL;
 761   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
 762     {
 763       expr = actual->expr;
 764
 765       /* Skip args which are not present.  */
 766       if (!expr)
 767         continue;
 768
 769       /* Skip other itself.  */
 770       if (expr == other)
 771         continue;
 772
 773       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
 774       if (formal && intent == INTENT_IN
 775           && formal->sym->attr.intent == INTENT_IN)
 776         continue;
 777
 778       if (gfc_check_argument_dependency (other, intent, expr, elemental))
 779         return 1;
 780     }
 781
 782   return 0;
 783 }
 784
 785
 786 /* Return 1 if e1 and e2 are equivalenced arrays, either
 787    directly or indirectly; i.e., equivalence (a,b) for a and b
 788    or equivalence (a,c),(b,c).  This function uses the equiv_
 789    lists, generated in trans-common(add_equivalences), that are
 790    guaranteed to pick up indirect equivalences.  We explicitly
 791    check for overlap using the offset and length of the equivalence.
 792    This function is symmetric.
 793    TODO: This function only checks whether the full top-level
 794    symbols overlap.  An improved implementation could inspect
 795    e1->ref and e2->ref to determine whether the actually accessed
 796    portions of these variables/arrays potentially overlap.  */
 797
 798 int
 799 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 800 {
 801   gfc_equiv_list *l;
 802   gfc_equiv_info *s, *fl1, *fl2;
 803
 804   gcc_assert (e1->expr_type == EXPR_VARIABLE
 805               && e2->expr_type == EXPR_VARIABLE);
 806
 807   if (!e1->symtree->n.sym->attr.in_equivalence
 808       || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
 809     return 0;
 810
 811   if (e1->symtree->n.sym->ns
 812         && e1->symtree->n.sym->ns != gfc_current_ns)
 813     l = e1->symtree->n.sym->ns->equiv_lists;
 814   else
 815     l = gfc_current_ns->equiv_lists;
 816
 817   /* Go through the equiv_lists and return 1 if the variables
 818      e1 and e2 are members of the same group and satisfy the
 819      requirement on their relative offsets.  */
 820   for (; l; l = l->next)
 821     {
 822       fl1 = NULL;
 823       fl2 = NULL;
 824       for (s = l->equiv; s; s = s->next)
 825         {
 826           if (s->sym == e1->symtree->n.sym)
 827             {
 828               fl1 = s;
 829               if (fl2)
 830                 break;
 831             }
 832           if (s->sym == e2->symtree->n.sym)
 833             {
 834               fl2 = s;
 835               if (fl1)
 836                 break;
 837             }
 838         }
 839
 840       if (s)
 841         {
 842           /* Can these lengths be zero?  */
 843           if (fl1->length <= 0 || fl2->length <= 0)
 844             return 1;
 845           /* These can't overlap if [f11,fl1+length] is before
 846              [fl2,fl2+length], or [fl2,fl2+length] is before
 847              [fl1,fl1+length], otherwise they do overlap.  */
 848           if (fl1->offset + fl1->length > fl2->offset
 849               && fl2->offset + fl2->length > fl1->offset)
 850             return 1;
 851         }
 852     }
 853   return 0;
 854 }
 855
 856
 857 /* Return true if there is no possibility of aliasing because of a type
 858    mismatch between all the possible pointer references and the
 859    potential target.  Note that this function is asymmetric in the
 860    arguments and so must be called twice with the arguments exchanged.  */
 861
 862 static bool
 863 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
 864 {
 865   gfc_component *cm1;
 866   gfc_symbol *sym1;
 867   gfc_symbol *sym2;
 868   gfc_ref *ref1;
 869   bool seen_component_ref;
 870
 871   if (expr1->expr_type != EXPR_VARIABLE
 872         || expr1->expr_type != EXPR_VARIABLE)
 873     return false;
 874
 875   sym1 = expr1->symtree->n.sym;
 876   sym2 = expr2->symtree->n.sym;
 877
 878   /* Keep it simple for now.  */
 879   if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
 880     return false;
 881
 882   if (sym1->attr.pointer)
 883     {
 884       if (gfc_compare_types (&sym1->ts, &sym2->ts))
 885         return false;
 886     }
 887
 888   /* This is a conservative check on the components of the derived type
 889      if no component references have been seen.  Since we will not dig
 890      into the components of derived type components, we play it safe by
 891      returning false.  First we check the reference chain and then, if
 892      no component references have been seen, the components.  */
 893   seen_component_ref = false;
 894   if (sym1->ts.type == BT_DERIVED)
 895     {
 896       for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
 897         {
 898           if (ref1->type != REF_COMPONENT)
 899             continue;
 900
 901           if (ref1->u.c.component->ts.type == BT_DERIVED)
 902             return false;
 903
 904           if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
 905                 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
 906             return false;
 907
 908           seen_component_ref = true;
 909         }
 910     }
 911
 912   if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
 913     {
 914       for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
 915         {
 916           if (cm1->ts.type == BT_DERIVED)
 917             return false;
 918
 919           if ((sym2->attr.pointer || cm1->attr.pointer)
 920                 && gfc_compare_types (&cm1->ts, &sym2->ts))
 921             return false;
 922         }
 923     }
 924
 925   return true;
 926 }
 927
 928
 929 /* Return true if the statement body redefines the condition.  Returns
 930    true if expr2 depends on expr1.  expr1 should be a single term
 931    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 932    whether array references to the same symbol with identical range
 933    references count as a dependency or not.  Used for forall and where
 934    statements.  Also used with functions returning arrays without a
 935    temporary.  */
 936
 937 int
 938 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
 939 {
 940   gfc_actual_arglist *actual;
 941   gfc_constructor *c;
 942   int n;
 943
 944   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 945
 946   switch (expr2->expr_type)
 947     {
 948     case EXPR_OP:
 949       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
 950       if (n)
 951         return n;
 952       if (expr2->value.op.op2)
 953         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
 954       return 0;
 955
 956     case EXPR_VARIABLE:
 957       /* The interesting cases are when the symbols don't match.  */
 958       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 959         {
 960           gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
 961           gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
 962
 963           /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
 964           if (gfc_are_equivalenced_arrays (expr1, expr2))
 965             return 1;
 966
 967           /* Symbols can only alias if they have the same type.  */
 968           if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
 969               && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
 970             {
 971               if (ts1->type != ts2->type || ts1->kind != ts2->kind)
 972                 return 0;
 973             }
 974
 975           /* If either variable is a pointer, assume the worst.  */
 976           /* TODO: -fassume-no-pointer-aliasing */
 977           if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
 978             {
 979               if (check_data_pointer_types (expr1, expr2)
 980                     && check_data_pointer_types (expr2, expr1))
 981                 return 0;
 982
 983               return 1;
 984             }
 985           else
 986             {
 987               gfc_symbol *sym1 = expr1->symtree->n.sym;
 988               gfc_symbol *sym2 = expr2->symtree->n.sym;
 989               if (sym1->attr.target && sym2->attr.target
 990                   && ((sym1->attr.dummy && !sym1->attr.contiguous
 991                        && (!sym1->attr.dimension
 992                            || sym2->as->type == AS_ASSUMED_SHAPE))
 993                       || (sym2->attr.dummy && !sym2->attr.contiguous
 994                           && (!sym2->attr.dimension
 995                               || sym2->as->type == AS_ASSUMED_SHAPE))))
 996                 return 1;
 997             }
 998
 999           /* Otherwise distinct symbols have no dependencies.  */
1000           return 0;
1001         }
1002
1003       if (identical)
1004         return 1;
1005
1006       /* Identical and disjoint ranges return 0,
1007          overlapping ranges return 1.  */
1008       if (expr1->ref && expr2->ref)
1009         return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
1010
1011       return 1;
1012
1013     case EXPR_FUNCTION:
1014       if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1015         identical = 1;
1016
1017       /* Remember possible differences between elemental and
1018          transformational functions.  All functions inside a FORALL
1019          will be pure.  */
1020       for (actual = expr2->value.function.actual;
1021            actual; actual = actual->next)
1022         {
1023           if (!actual->expr)
1024             continue;
1025           n = gfc_check_dependency (expr1, actual->expr, identical);
1026           if (n)
1027             return n;
1028         }
1029       return 0;
1030
1031     case EXPR_CONSTANT:
1032     case EXPR_NULL:
1033       return 0;
1034
1035     case EXPR_ARRAY:
1036       /* Loop through the array constructor's elements.  */
1037       for (c = gfc_constructor_first (expr2->value.constructor);
1038            c; c = gfc_constructor_next (c))
1039         {
1040           /* If this is an iterator, assume the worst.  */
1041           if (c->iterator)
1042             return 1;
1043           /* Avoid recursion in the common case.  */
1044           if (c->expr->expr_type == EXPR_CONSTANT)
1045             continue;
1046           if (gfc_check_dependency (expr1, c->expr, 1))
1047             return 1;
1048         }
1049       return 0;
1050
1051     default:
1052       return 1;
1053     }
1054 }
1055
1056
1057 /* Determines overlapping for two array sections.  */
1058
1059 static gfc_dependency
1060 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1061 {
1062   gfc_expr *l_start;
1063   gfc_expr *l_end;
1064   gfc_expr *l_stride;
1065   gfc_expr *l_lower;
1066   gfc_expr *l_upper;
1067   int l_dir;
1068
1069   gfc_expr *r_start;
1070   gfc_expr *r_end;
1071   gfc_expr *r_stride;
1072   gfc_expr *r_lower;
1073   gfc_expr *r_upper;
1074   gfc_expr *one_expr;
1075   int r_dir;
1076   int stride_comparison;
1077   int start_comparison;
1078
1079   /* If they are the same range, return without more ado.  */
1080   if (gfc_is_same_range (l_ar, r_ar, n, 0))
1081     return GFC_DEP_EQUAL;
1082
1083   l_start = l_ar->start[n];
1084   l_end = l_ar->end[n];
1085   l_stride = l_ar->stride[n];
1086
1087   r_start = r_ar->start[n];
1088   r_end = r_ar->end[n];
1089   r_stride = r_ar->stride[n];
1090
1091   /* If l_start is NULL take it from array specifier.  */
1092   if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1093     l_start = l_ar->as->lower[n];
1094   /* If l_end is NULL take it from array specifier.  */
1095   if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
1096     l_end = l_ar->as->upper[n];
1097
1098   /* If r_start is NULL take it from array specifier.  */
1099   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
1100     r_start = r_ar->as->lower[n];
1101   /* If r_end is NULL take it from array specifier.  */
1102   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
1103     r_end = r_ar->as->upper[n];
1104
1105   /* Determine whether the l_stride is positive or negative.  */
1106   if (!l_stride)
1107     l_dir = 1;
1108   else if (l_stride->expr_type == EXPR_CONSTANT
1109            && l_stride->ts.type == BT_INTEGER)
1110     l_dir = mpz_sgn (l_stride->value.integer);
1111   else if (l_start && l_end)
1112     l_dir = gfc_dep_compare_expr (l_end, l_start);
1113   else
1114     l_dir = -2;
1115
1116   /* Determine whether the r_stride is positive or negative.  */
1117   if (!r_stride)
1118     r_dir = 1;
1119   else if (r_stride->expr_type == EXPR_CONSTANT
1120            && r_stride->ts.type == BT_INTEGER)
1121     r_dir = mpz_sgn (r_stride->value.integer);
1122   else if (r_start && r_end)
1123     r_dir = gfc_dep_compare_expr (r_end, r_start);
1124   else
1125     r_dir = -2;
1126
1127   /* The strides should never be zero.  */
1128   if (l_dir == 0 || r_dir == 0)
1129     return GFC_DEP_OVERLAP;
1130
1131   /* Determine the relationship between the strides.  Set stride_comparison to
1132      -2 if the dependency cannot be determined
1133      -1 if l_stride < r_stride
1134       0 if l_stride == r_stride
1135       1 if l_stride > r_stride
1136      as determined by gfc_dep_compare_expr.  */
1137
1138   one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1139
1140   stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1141                                             r_stride ? r_stride : one_expr);
1142
1143   if (l_start && r_start)
1144     start_comparison = gfc_dep_compare_expr (l_start, r_start);
1145   else
1146     start_comparison = -2;
1147
1148   gfc_free (one_expr);
1149
1150   /* Determine LHS upper and lower bounds.  */
1151   if (l_dir == 1)
1152     {
1153       l_lower = l_start;
1154       l_upper = l_end;
1155     }
1156   else if (l_dir == -1)
1157     {
1158       l_lower = l_end;
1159       l_upper = l_start;
1160     }
1161   else
1162     {
1163       l_lower = NULL;
1164       l_upper = NULL;
1165     }
1166
1167   /* Determine RHS upper and lower bounds.  */
1168   if (r_dir == 1)
1169     {
1170       r_lower = r_start;
1171       r_upper = r_end;
1172     }
1173   else if (r_dir == -1)
1174     {
1175       r_lower = r_end;
1176       r_upper = r_start;
1177     }
1178   else
1179     {
1180       r_lower = NULL;
1181       r_upper = NULL;
1182     }
1183
1184   /* Check whether the ranges are disjoint.  */
1185   if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1186     return GFC_DEP_NODEP;
1187   if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1188     return GFC_DEP_NODEP;
1189
1190   /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
1191   if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1192     {
1193       if (l_dir == 1 && r_dir == -1)
1194         return GFC_DEP_EQUAL;
1195       if (l_dir == -1 && r_dir == 1)
1196         return GFC_DEP_EQUAL;
1197     }
1198
1199   /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
1200   if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1201     {
1202       if (l_dir == 1 && r_dir == -1)
1203         return GFC_DEP_EQUAL;
1204       if (l_dir == -1 && r_dir == 1)
1205         return GFC_DEP_EQUAL;
1206     }
1207
1208   /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1209      There is no dependency if the remainder of
1210      (l_start - r_start) / gcd(l_stride, r_stride) is
1211      nonzero.
1212      TODO:
1213        - Handle cases where x is an expression.
1214        - Cases like a(1:4:2) = a(2:3) are still not handled.
1215   */
1216
1217 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1218                               && (a)->ts.type == BT_INTEGER)
1219
1220   if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
1221       && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
1222     {
1223       mpz_t gcd, tmp;
1224       int result;
1225
1226       mpz_init (gcd);
1227       mpz_init (tmp);
1228
1229       mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1230       mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
1231
1232       mpz_fdiv_r (tmp, tmp, gcd);
1233       result = mpz_cmp_si (tmp, 0L);
1234
1235       mpz_clear (gcd);
1236       mpz_clear (tmp);
1237
1238       if (result != 0)
1239         return GFC_DEP_NODEP;
1240     }
1241
1242 #undef IS_CONSTANT_INTEGER
1243
1244   /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1245
1246   if (l_dir == 1 && r_dir == 1 &&
1247       (start_comparison == 0 || start_comparison == -1)
1248       && (stride_comparison == 0 || stride_comparison == -1))
1249           return GFC_DEP_FORWARD;
1250
1251   /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1252      x:y:-1 vs. x:y:-2.  */
1253   if (l_dir == -1 && r_dir == -1 &&
1254       (start_comparison == 0 || start_comparison == 1)
1255       && (stride_comparison == 0 || stride_comparison == 1))
1256     return GFC_DEP_FORWARD;
1257
1258   if (stride_comparison == 0 || stride_comparison == -1)
1259     {
1260       if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1261         {
1262
1263           /* Check for a(low:y:s) vs. a(z:x:s) or
1264              a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1265              of low, which is always at least a forward dependence.  */
1266
1267           if (r_dir == 1
1268               && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1269             return GFC_DEP_FORWARD;
1270         }
1271     }
1272
1273   if (stride_comparison == 0 || stride_comparison == 1)
1274     {
1275       if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1276         {
1277
1278           /* Check for a(high:y:-s) vs. a(z:x:-s) or
1279              a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1280              of high, which is always at least a forward dependence.  */
1281
1282           if (r_dir == -1
1283               && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1284             return GFC_DEP_FORWARD;
1285         }
1286     }
1287
1288
1289   if (stride_comparison == 0)
1290     {
1291       /* From here, check for backwards dependencies.  */
1292       /* x+1:y vs. x:z.  */
1293       if (l_dir == 1 && r_dir == 1  && start_comparison == 1)
1294         return GFC_DEP_BACKWARD;
1295
1296       /* x-1:y:-1 vs. x:z:-1.  */
1297       if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1298         return GFC_DEP_BACKWARD;
1299     }
1300
1301   return GFC_DEP_OVERLAP;
1302 }
1303
1304
1305 /* Determines overlapping for a single element and a section.  */
1306
1307 static gfc_dependency
1308 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1309 {
1310   gfc_array_ref *ref;
1311   gfc_expr *elem;
1312   gfc_expr *start;
1313   gfc_expr *end;
1314   gfc_expr *stride;
1315   int s;
1316
1317   elem = lref->u.ar.start[n];
1318   if (!elem)
1319     return GFC_DEP_OVERLAP;
1320
1321   ref = &rref->u.ar;
1322   start = ref->start[n] ;
1323   end = ref->end[n] ;
1324   stride = ref->stride[n];
1325
1326   if (!start && IS_ARRAY_EXPLICIT (ref->as))
1327     start = ref->as->lower[n];
1328   if (!end && IS_ARRAY_EXPLICIT (ref->as))
1329     end = ref->as->upper[n];
1330
1331   /* Determine whether the stride is positive or negative.  */
1332   if (!stride)
1333     s = 1;
1334   else if (stride->expr_type == EXPR_CONSTANT
1335            && stride->ts.type == BT_INTEGER)
1336     s = mpz_sgn (stride->value.integer);
1337   else
1338     s = -2;
1339
1340   /* Stride should never be zero.  */
1341   if (s == 0)
1342     return GFC_DEP_OVERLAP;
1343
1344   /* Positive strides.  */
1345   if (s == 1)
1346     {
1347       /* Check for elem < lower.  */
1348       if (start && gfc_dep_compare_expr (elem, start) == -1)
1349         return GFC_DEP_NODEP;
1350       /* Check for elem > upper.  */
1351       if (end && gfc_dep_compare_expr (elem, end) == 1)
1352         return GFC_DEP_NODEP;
1353
1354       if (start && end)
1355         {
1356           s = gfc_dep_compare_expr (start, end);
1357           /* Check for an empty range.  */
1358           if (s == 1)
1359             return GFC_DEP_NODEP;
1360           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1361             return GFC_DEP_EQUAL;
1362         }
1363     }
1364   /* Negative strides.  */
1365   else if (s == -1)
1366     {
1367       /* Check for elem > upper.  */
1368       if (end && gfc_dep_compare_expr (elem, start) == 1)
1369         return GFC_DEP_NODEP;
1370       /* Check for elem < lower.  */
1371       if (start && gfc_dep_compare_expr (elem, end) == -1)
1372         return GFC_DEP_NODEP;
1373
1374       if (start && end)
1375         {
1376           s = gfc_dep_compare_expr (start, end);
1377           /* Check for an empty range.  */
1378           if (s == -1)
1379             return GFC_DEP_NODEP;
1380           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1381             return GFC_DEP_EQUAL;
1382         }
1383     }
1384   /* Unknown strides.  */
1385   else
1386     {
1387       if (!start || !end)
1388         return GFC_DEP_OVERLAP;
1389       s = gfc_dep_compare_expr (start, end);
1390       if (s == -2)
1391         return GFC_DEP_OVERLAP;
1392       /* Assume positive stride.  */
1393       if (s == -1)
1394         {
1395           /* Check for elem < lower.  */
1396           if (gfc_dep_compare_expr (elem, start) == -1)
1397             return GFC_DEP_NODEP;
1398           /* Check for elem > upper.  */
1399           if (gfc_dep_compare_expr (elem, end) == 1)
1400             return GFC_DEP_NODEP;
1401         }
1402       /* Assume negative stride.  */
1403       else if (s == 1)
1404         {
1405           /* Check for elem > upper.  */
1406           if (gfc_dep_compare_expr (elem, start) == 1)
1407             return GFC_DEP_NODEP;
1408           /* Check for elem < lower.  */
1409           if (gfc_dep_compare_expr (elem, end) == -1)
1410             return GFC_DEP_NODEP;
1411         }
1412       /* Equal bounds.  */
1413       else if (s == 0)
1414         {
1415           s = gfc_dep_compare_expr (elem, start);
1416           if (s == 0)
1417             return GFC_DEP_EQUAL;
1418           if (s == 1 || s == -1)
1419             return GFC_DEP_NODEP;
1420         }
1421     }
1422
1423   return GFC_DEP_OVERLAP;
1424 }
1425
1426
1427 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1428    forall_index attribute.  Return true if any variable may be
1429    being used as a FORALL index.  Its safe to pessimistically
1430    return true, and assume a dependency.  */
1431
1432 static bool
1433 contains_forall_index_p (gfc_expr *expr)
1434 {
1435   gfc_actual_arglist *arg;
1436   gfc_constructor *c;
1437   gfc_ref *ref;
1438   int i;
1439
1440   if (!expr)
1441     return false;
1442
1443   switch (expr->expr_type)
1444     {
1445     case EXPR_VARIABLE:
1446       if (expr->symtree->n.sym->forall_index)
1447         return true;
1448       break;
1449
1450     case EXPR_OP:
1451       if (contains_forall_index_p (expr->value.op.op1)
1452           || contains_forall_index_p (expr->value.op.op2))
1453         return true;
1454       break;
1455
1456     case EXPR_FUNCTION:
1457       for (arg = expr->value.function.actual; arg; arg = arg->next)
1458         if (contains_forall_index_p (arg->expr))
1459           return true;
1460       break;
1461
1462     case EXPR_CONSTANT:
1463     case EXPR_NULL:
1464     case EXPR_SUBSTRING:
1465       break;
1466
1467     case EXPR_STRUCTURE:
1468     case EXPR_ARRAY:
1469       for (c = gfc_constructor_first (expr->value.constructor);
1470            c; gfc_constructor_next (c))
1471         if (contains_forall_index_p (c->expr))
1472           return true;
1473       break;
1474
1475     default:
1476       gcc_unreachable ();
1477     }
1478
1479   for (ref = expr->ref; ref; ref = ref->next)
1480     switch (ref->type)
1481       {
1482       case REF_ARRAY:
1483         for (i = 0; i < ref->u.ar.dimen; i++)
1484           if (contains_forall_index_p (ref->u.ar.start[i])
1485               || contains_forall_index_p (ref->u.ar.end[i])
1486               || contains_forall_index_p (ref->u.ar.stride[i]))
1487             return true;
1488         break;
1489
1490       case REF_COMPONENT:
1491         break;
1492
1493       case REF_SUBSTRING:
1494         if (contains_forall_index_p (ref->u.ss.start)
1495             || contains_forall_index_p (ref->u.ss.end))
1496           return true;
1497         break;
1498
1499       default:
1500         gcc_unreachable ();
1501       }
1502
1503   return false;
1504 }
1505
1506 /* Determines overlapping for two single element array references.  */
1507
1508 static gfc_dependency
1509 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1510 {
1511   gfc_array_ref l_ar;
1512   gfc_array_ref r_ar;
1513   gfc_expr *l_start;
1514   gfc_expr *r_start;
1515   int i;
1516
1517   l_ar = lref->u.ar;
1518   r_ar = rref->u.ar;
1519   l_start = l_ar.start[n] ;
1520   r_start = r_ar.start[n] ;
1521   i = gfc_dep_compare_expr (r_start, l_start);
1522   if (i == 0)
1523     return GFC_DEP_EQUAL;
1524
1525   /* Treat two scalar variables as potentially equal.  This allows
1526      us to prove that a(i,:) and a(j,:) have no dependency.  See
1527      Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1528      Proceedings of the International Conference on Parallel and
1529      Distributed Processing Techniques and Applications (PDPTA2001),
1530      Las Vegas, Nevada, June 2001.  */
1531   /* However, we need to be careful when either scalar expression
1532      contains a FORALL index, as these can potentially change value
1533      during the scalarization/traversal of this array reference.  */
1534   if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1535     return GFC_DEP_OVERLAP;
1536
1537   if (i != -2)
1538     return GFC_DEP_NODEP;
1539   return GFC_DEP_EQUAL;
1540 }
1541
1542
1543 /* Determine if an array ref, usually an array section specifies the
1544    entire array.  In addition, if the second, pointer argument is
1545    provided, the function will return true if the reference is
1546    contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
1547
1548 bool
1549 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1550 {
1551   int i;
1552   int n;
1553   bool lbound_OK = true;
1554   bool ubound_OK = true;
1555
1556   if (contiguous)
1557     *contiguous = false;
1558
1559   if (ref->type != REF_ARRAY)
1560     return false;
1561
1562   if (ref->u.ar.type == AR_FULL)
1563     {
1564       if (contiguous)
1565         *contiguous = true;
1566       return true;
1567     }
1568
1569   if (ref->u.ar.type != AR_SECTION)
1570     return false;
1571   if (ref->next)
1572     return false;
1573
1574   for (i = 0; i < ref->u.ar.dimen; i++)
1575     {
1576       /* If we have a single element in the reference, for the reference
1577          to be full, we need to ascertain that the array has a single
1578          element in this dimension and that we actually reference the
1579          correct element.  */
1580       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1581         {
1582           /* This is unconditionally a contiguous reference if all the
1583              remaining dimensions are elements.  */
1584           if (contiguous)
1585             {
1586               *contiguous = true;
1587               for (n = i + 1; n < ref->u.ar.dimen; n++)
1588                 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1589                   *contiguous = false;
1590             }
1591
1592           if (!ref->u.ar.as
1593               || !ref->u.ar.as->lower[i]
1594               || !ref->u.ar.as->upper[i]
1595               || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1596                                        ref->u.ar.as->upper[i])
1597               || !ref->u.ar.start[i]
1598               || gfc_dep_compare_expr (ref->u.ar.start[i],
1599                                        ref->u.ar.as->lower[i]))
1600             return false;
1601           else
1602             continue;
1603         }
1604
1605       /* Check the lower bound.  */
1606       if (ref->u.ar.start[i]
1607           && (!ref->u.ar.as
1608               || !ref->u.ar.as->lower[i]
1609               || gfc_dep_compare_expr (ref->u.ar.start[i],
1610                                        ref->u.ar.as->lower[i])))
1611         lbound_OK = false;
1612       /* Check the upper bound.  */
1613       if (ref->u.ar.end[i]
1614           && (!ref->u.ar.as
1615               || !ref->u.ar.as->upper[i]
1616               || gfc_dep_compare_expr (ref->u.ar.end[i],
1617                                        ref->u.ar.as->upper[i])))
1618         ubound_OK = false;
1619       /* Check the stride.  */
1620       if (ref->u.ar.stride[i]
1621             && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1622         return false;
1623
1624       /* This is unconditionally a contiguous reference as long as all
1625          the subsequent dimensions are elements.  */
1626       if (contiguous)
1627         {
1628           *contiguous = true;
1629           for (n = i + 1; n < ref->u.ar.dimen; n++)
1630             if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1631               *contiguous = false;
1632         }
1633
1634       if (!lbound_OK || !ubound_OK)
1635         return false;
1636     }
1637   return true;
1638 }
1639
1640
1641 /* Determine if a full array is the same as an array section with one
1642    variable limit.  For this to be so, the strides must both be unity
1643    and one of either start == lower or end == upper must be true.  */
1644
1645 static bool
1646 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1647 {
1648   int i;
1649   bool upper_or_lower;
1650
1651   if (full_ref->type != REF_ARRAY)
1652     return false;
1653   if (full_ref->u.ar.type != AR_FULL)
1654     return false;
1655   if (ref->type != REF_ARRAY)
1656     return false;
1657   if (ref->u.ar.type != AR_SECTION)
1658     return false;
1659
1660   for (i = 0; i < ref->u.ar.dimen; i++)
1661     {
1662       /* If we have a single element in the reference, we need to check
1663          that the array has a single element and that we actually reference
1664          the correct element.  */
1665       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1666         {
1667           if (!full_ref->u.ar.as
1668               || !full_ref->u.ar.as->lower[i]
1669               || !full_ref->u.ar.as->upper[i]
1670               || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1671                                        full_ref->u.ar.as->upper[i])
1672               || !ref->u.ar.start[i]
1673               || gfc_dep_compare_expr (ref->u.ar.start[i],
1674                                        full_ref->u.ar.as->lower[i]))
1675             return false;
1676         }
1677
1678       /* Check the strides.  */
1679       if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1680         return false;
1681       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1682         return false;
1683
1684       upper_or_lower = false;
1685       /* Check the lower bound.  */
1686       if (ref->u.ar.start[i]
1687           && (ref->u.ar.as
1688                 && full_ref->u.ar.as->lower[i]
1689                 && gfc_dep_compare_expr (ref->u.ar.start[i],
1690                                          full_ref->u.ar.as->lower[i]) == 0))
1691         upper_or_lower =  true;
1692       /* Check the upper bound.  */
1693       if (ref->u.ar.end[i]
1694           && (ref->u.ar.as
1695                 && full_ref->u.ar.as->upper[i]
1696                 && gfc_dep_compare_expr (ref->u.ar.end[i],
1697                                          full_ref->u.ar.as->upper[i]) == 0))
1698         upper_or_lower =  true;
1699       if (!upper_or_lower)
1700         return false;
1701     }
1702   return true;
1703 }
1704
1705
1706 /* Finds if two array references are overlapping or not.
1707    Return value
1708         2 : array references are overlapping but reversal of one or
1709             more dimensions will clear the dependency.
1710         1 : array references are overlapping.
1711         0 : array references are identical or not overlapping.  */
1712
1713 int
1714 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
1715 {
1716   int n;
1717   gfc_dependency fin_dep;
1718   gfc_dependency this_dep;
1719
1720   this_dep = GFC_DEP_ERROR;
1721   fin_dep = GFC_DEP_ERROR;
1722   /* Dependencies due to pointers should already have been identified.
1723      We only need to check for overlapping array references.  */
1724
1725   while (lref && rref)
1726     {
1727       /* We're resolving from the same base symbol, so both refs should be
1728          the same type.  We traverse the reference chain until we find ranges
1729          that are not equal.  */
1730       gcc_assert (lref->type == rref->type);
1731       switch (lref->type)
1732         {
1733         case REF_COMPONENT:
1734           /* The two ranges can't overlap if they are from different
1735              components.  */
1736           if (lref->u.c.component != rref->u.c.component)
1737             return 0;
1738           break;
1739
1740         case REF_SUBSTRING:
1741           /* Substring overlaps are handled by the string assignment code
1742              if there is not an underlying dependency.  */
1743           return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1744
1745         case REF_ARRAY:
1746
1747           if (ref_same_as_full_array (lref, rref))
1748             return 0;
1749
1750           if (ref_same_as_full_array (rref, lref))
1751             return 0;
1752
1753           if (lref->u.ar.dimen != rref->u.ar.dimen)
1754             {
1755               if (lref->u.ar.type == AR_FULL)
1756                 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1757                                                             : GFC_DEP_OVERLAP;
1758               else if (rref->u.ar.type == AR_FULL)
1759                 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1760                                                             : GFC_DEP_OVERLAP;
1761               else
1762                 return 1;
1763               break;
1764             }
1765
1766           for (n=0; n < lref->u.ar.dimen; n++)
1767             {
1768               /* Assume dependency when either of array reference is vector
1769                  subscript.  */
1770               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1771                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1772                 return 1;
1773
1774               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1775                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1776                 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
1777               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1778                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1779                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1780               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1781                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1782                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1783               else
1784                 {
1785                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1786                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1787                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1788                 }
1789
1790               /* If any dimension doesn't overlap, we have no dependency.  */
1791               if (this_dep == GFC_DEP_NODEP)
1792                 return 0;
1793
1794               /* Now deal with the loop reversal logic:  This only works on
1795                  ranges and is activated by setting
1796                                 reverse[n] == GFC_CAN_REVERSE
1797                  The ability to reverse or not is set by previous conditions
1798                  in this dimension.  If reversal is not activated, the
1799                  value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP.  */
1800               if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
1801                     && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1802                 {
1803                   /* Set reverse if backward dependence and not inhibited.  */
1804                   if (reverse && reverse[n] != GFC_CANNOT_REVERSE)
1805                     reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
1806                                  GFC_REVERSE_SET : reverse[n];
1807
1808                   /* Inhibit loop reversal if dependence not compatible.  */
1809                   if (reverse && reverse[n] != GFC_REVERSE_NOT_SET
1810                         && this_dep != GFC_DEP_EQUAL
1811                         && this_dep != GFC_DEP_BACKWARD
1812                         && this_dep != GFC_DEP_NODEP)
1813                     {
1814                       reverse[n] = GFC_CANNOT_REVERSE;
1815                       if (this_dep != GFC_DEP_FORWARD)
1816                         this_dep = GFC_DEP_OVERLAP;
1817                     }
1818
1819                   /* If no intention of reversing or reversing is explicitly
1820                      inhibited, convert backward dependence to overlap.  */
1821                   if (this_dep == GFC_DEP_BACKWARD
1822                       && (reverse == NULL || reverse[n] == GFC_CANNOT_REVERSE))
1823                     this_dep = GFC_DEP_OVERLAP;
1824                 }
1825
1826               /* Overlap codes are in order of priority.  We only need to
1827                  know the worst one.*/
1828               if (this_dep > fin_dep)
1829                 fin_dep = this_dep;
1830             }
1831
1832           /* If this is an equal element, we have to keep going until we find
1833              the "real" array reference.  */
1834           if (lref->u.ar.type == AR_ELEMENT
1835                 && rref->u.ar.type == AR_ELEMENT
1836                 && fin_dep == GFC_DEP_EQUAL)
1837             break;
1838
1839           /* Exactly matching and forward overlapping ranges don't cause a
1840              dependency.  */
1841           if (fin_dep < GFC_DEP_BACKWARD)
1842             return 0;
1843
1844           /* Keep checking.  We only have a dependency if
1845              subsequent references also overlap.  */
1846           break;
1847
1848         default:
1849           gcc_unreachable ();
1850         }
1851       lref = lref->next;
1852       rref = rref->next;
1853     }
1854
1855   /* If we haven't seen any array refs then something went wrong.  */
1856   gcc_assert (fin_dep != GFC_DEP_ERROR);
1857
1858   /* Assume the worst if we nest to different depths.  */
1859   if (lref || rref)
1860     return 1;
1861
1862   return fin_dep == GFC_DEP_OVERLAP;
1863 }