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   int r_dir;
1075   bool identical_strides;
1076
1077   /* If they are the same range, return without more ado.  */
1078   if (gfc_is_same_range (l_ar, r_ar, n, 0))
1079     return GFC_DEP_EQUAL;
1080
1081   l_start = l_ar->start[n];
1082   l_end = l_ar->end[n];
1083   l_stride = l_ar->stride[n];
1084
1085   r_start = r_ar->start[n];
1086   r_end = r_ar->end[n];
1087   r_stride = r_ar->stride[n];
1088
1089   /* If l_start is NULL take it from array specifier.  */
1090   if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1091     l_start = l_ar->as->lower[n];
1092   /* If l_end is NULL take it from array specifier.  */
1093   if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
1094     l_end = l_ar->as->upper[n];
1095
1096   /* If r_start is NULL take it from array specifier.  */
1097   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
1098     r_start = r_ar->as->lower[n];
1099   /* If r_end is NULL take it from array specifier.  */
1100   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
1101     r_end = r_ar->as->upper[n];
1102
1103   /* Determine whether the l_stride is positive or negative.  */
1104   if (!l_stride)
1105     l_dir = 1;
1106   else if (l_stride->expr_type == EXPR_CONSTANT
1107            && l_stride->ts.type == BT_INTEGER)
1108     l_dir = mpz_sgn (l_stride->value.integer);
1109   else if (l_start && l_end)
1110     l_dir = gfc_dep_compare_expr (l_end, l_start);
1111   else
1112     l_dir = -2;
1113
1114   /* Determine whether the r_stride is positive or negative.  */
1115   if (!r_stride)
1116     r_dir = 1;
1117   else if (r_stride->expr_type == EXPR_CONSTANT
1118            && r_stride->ts.type == BT_INTEGER)
1119     r_dir = mpz_sgn (r_stride->value.integer);
1120   else if (r_start && r_end)
1121     r_dir = gfc_dep_compare_expr (r_end, r_start);
1122   else
1123     r_dir = -2;
1124
1125   /* The strides should never be zero.  */
1126   if (l_dir == 0 || r_dir == 0)
1127     return GFC_DEP_OVERLAP;
1128
1129   /* Determine if the strides are equal.  */
1130
1131   if (l_stride)
1132     {
1133       if (r_stride)
1134         identical_strides = gfc_dep_compare_expr (l_stride, r_stride) == 0;
1135       else
1136         identical_strides = gfc_expr_is_one (l_stride, 0) == 1;
1137     }
1138   else
1139     {
1140       if (r_stride)
1141         identical_strides = gfc_expr_is_one (r_stride, 0) == 1;
1142       else
1143         identical_strides = true;
1144     }
1145
1146   /* Determine LHS upper and lower bounds.  */
1147   if (l_dir == 1)
1148     {
1149       l_lower = l_start;
1150       l_upper = l_end;
1151     }
1152   else if (l_dir == -1)
1153     {
1154       l_lower = l_end;
1155       l_upper = l_start;
1156     }
1157   else
1158     {
1159       l_lower = NULL;
1160       l_upper = NULL;
1161     }
1162
1163   /* Determine RHS upper and lower bounds.  */
1164   if (r_dir == 1)
1165     {
1166       r_lower = r_start;
1167       r_upper = r_end;
1168     }
1169   else if (r_dir == -1)
1170     {
1171       r_lower = r_end;
1172       r_upper = r_start;
1173     }
1174   else
1175     {
1176       r_lower = NULL;
1177       r_upper = NULL;
1178     }
1179
1180   /* Check whether the ranges are disjoint.  */
1181   if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1182     return GFC_DEP_NODEP;
1183   if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1184     return GFC_DEP_NODEP;
1185
1186   /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
1187   if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1188     {
1189       if (l_dir == 1 && r_dir == -1)
1190         return GFC_DEP_EQUAL;
1191       if (l_dir == -1 && r_dir == 1)
1192         return GFC_DEP_EQUAL;
1193     }
1194
1195   /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
1196   if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1197     {
1198       if (l_dir == 1 && r_dir == -1)
1199         return GFC_DEP_EQUAL;
1200       if (l_dir == -1 && r_dir == 1)
1201         return GFC_DEP_EQUAL;
1202     }
1203
1204   /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1205      There is no dependency if the remainder of
1206      (l_start - r_start) / gcd(l_stride, r_stride) is
1207      nonzero.
1208      TODO:
1209        - Handle cases where x is an expression.
1210        - Cases like a(1:4:2) = a(2:3) are still not handled.
1211   */
1212
1213 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1214                               && (a)->ts.type == BT_INTEGER)
1215
1216   if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
1217       && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
1218     {
1219       mpz_t gcd, tmp;
1220       int result;
1221
1222       mpz_init (gcd);
1223       mpz_init (tmp);
1224
1225       mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1226       mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
1227
1228       mpz_fdiv_r (tmp, tmp, gcd);
1229       result = mpz_cmp_si (tmp, 0L);
1230
1231       mpz_clear (gcd);
1232       mpz_clear (tmp);
1233
1234       if (result != 0)
1235         return GFC_DEP_NODEP;
1236     }
1237
1238 #undef IS_CONSTANT_INTEGER
1239
1240   /* Check for forward dependencies x:y vs. x+1:z.  */
1241   if (l_dir == 1 && r_dir == 1
1242       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
1243       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
1244     {
1245       if (identical_strides)
1246         return GFC_DEP_FORWARD;
1247     }
1248
1249   /* Check for forward dependencies x:y:-1 vs. x-1:z:-1.  */
1250   if (l_dir == -1 && r_dir == -1
1251       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
1252       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
1253     {
1254       if (identical_strides)
1255         return GFC_DEP_FORWARD;
1256     }
1257
1258
1259   if (identical_strides)
1260     {
1261
1262       if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1263         {
1264
1265           /* Check for a(low:y:s) vs. a(z:a:s) where a has a lower bound
1266              of low, which is always at least a forward dependence.  */
1267
1268           if (r_dir == 1
1269               && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1270             return GFC_DEP_FORWARD;
1271
1272           /* Check for a(high:y:-s) vs. a(z:a:-s) where a has a higher bound
1273              of high, which is always at least a forward dependence.  */
1274
1275           if (r_dir == -1
1276               && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1277             return GFC_DEP_FORWARD;
1278         }
1279
1280       /* From here, check for backwards dependencies.  */
1281       /* x:y vs. x+1:z.  */
1282       if (l_dir == 1 && r_dir == 1
1283             && l_start && r_start
1284             && gfc_dep_compare_expr (l_start, r_start) == 1
1285             && l_end && r_end
1286             && gfc_dep_compare_expr (l_end, r_end) == 1)
1287         return GFC_DEP_BACKWARD;
1288
1289       /* x:y:-1 vs. x-1:z:-1.  */
1290       if (l_dir == -1 && r_dir == -1
1291             && l_start && r_start
1292             && gfc_dep_compare_expr (l_start, r_start) == -1
1293             && l_end && r_end
1294             && gfc_dep_compare_expr (l_end, r_end) == -1)
1295         return GFC_DEP_BACKWARD;
1296     }
1297
1298   return GFC_DEP_OVERLAP;
1299 }
1300
1301
1302 /* Determines overlapping for a single element and a section.  */
1303
1304 static gfc_dependency
1305 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1306 {
1307   gfc_array_ref *ref;
1308   gfc_expr *elem;
1309   gfc_expr *start;
1310   gfc_expr *end;
1311   gfc_expr *stride;
1312   int s;
1313
1314   elem = lref->u.ar.start[n];
1315   if (!elem)
1316     return GFC_DEP_OVERLAP;
1317
1318   ref = &rref->u.ar;
1319   start = ref->start[n] ;
1320   end = ref->end[n] ;
1321   stride = ref->stride[n];
1322
1323   if (!start && IS_ARRAY_EXPLICIT (ref->as))
1324     start = ref->as->lower[n];
1325   if (!end && IS_ARRAY_EXPLICIT (ref->as))
1326     end = ref->as->upper[n];
1327
1328   /* Determine whether the stride is positive or negative.  */
1329   if (!stride)
1330     s = 1;
1331   else if (stride->expr_type == EXPR_CONSTANT
1332            && stride->ts.type == BT_INTEGER)
1333     s = mpz_sgn (stride->value.integer);
1334   else
1335     s = -2;
1336
1337   /* Stride should never be zero.  */
1338   if (s == 0)
1339     return GFC_DEP_OVERLAP;
1340
1341   /* Positive strides.  */
1342   if (s == 1)
1343     {
1344       /* Check for elem < lower.  */
1345       if (start && gfc_dep_compare_expr (elem, start) == -1)
1346         return GFC_DEP_NODEP;
1347       /* Check for elem > upper.  */
1348       if (end && gfc_dep_compare_expr (elem, end) == 1)
1349         return GFC_DEP_NODEP;
1350
1351       if (start && end)
1352         {
1353           s = gfc_dep_compare_expr (start, end);
1354           /* Check for an empty range.  */
1355           if (s == 1)
1356             return GFC_DEP_NODEP;
1357           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1358             return GFC_DEP_EQUAL;
1359         }
1360     }
1361   /* Negative strides.  */
1362   else if (s == -1)
1363     {
1364       /* Check for elem > upper.  */
1365       if (end && gfc_dep_compare_expr (elem, start) == 1)
1366         return GFC_DEP_NODEP;
1367       /* Check for elem < lower.  */
1368       if (start && gfc_dep_compare_expr (elem, end) == -1)
1369         return GFC_DEP_NODEP;
1370
1371       if (start && end)
1372         {
1373           s = gfc_dep_compare_expr (start, end);
1374           /* Check for an empty range.  */
1375           if (s == -1)
1376             return GFC_DEP_NODEP;
1377           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1378             return GFC_DEP_EQUAL;
1379         }
1380     }
1381   /* Unknown strides.  */
1382   else
1383     {
1384       if (!start || !end)
1385         return GFC_DEP_OVERLAP;
1386       s = gfc_dep_compare_expr (start, end);
1387       if (s == -2)
1388         return GFC_DEP_OVERLAP;
1389       /* Assume positive stride.  */
1390       if (s == -1)
1391         {
1392           /* Check for elem < lower.  */
1393           if (gfc_dep_compare_expr (elem, start) == -1)
1394             return GFC_DEP_NODEP;
1395           /* Check for elem > upper.  */
1396           if (gfc_dep_compare_expr (elem, end) == 1)
1397             return GFC_DEP_NODEP;
1398         }
1399       /* Assume negative stride.  */
1400       else if (s == 1)
1401         {
1402           /* Check for elem > upper.  */
1403           if (gfc_dep_compare_expr (elem, start) == 1)
1404             return GFC_DEP_NODEP;
1405           /* Check for elem < lower.  */
1406           if (gfc_dep_compare_expr (elem, end) == -1)
1407             return GFC_DEP_NODEP;
1408         }
1409       /* Equal bounds.  */
1410       else if (s == 0)
1411         {
1412           s = gfc_dep_compare_expr (elem, start);
1413           if (s == 0)
1414             return GFC_DEP_EQUAL;
1415           if (s == 1 || s == -1)
1416             return GFC_DEP_NODEP;
1417         }
1418     }
1419
1420   return GFC_DEP_OVERLAP;
1421 }
1422
1423
1424 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1425    forall_index attribute.  Return true if any variable may be
1426    being used as a FORALL index.  Its safe to pessimistically
1427    return true, and assume a dependency.  */
1428
1429 static bool
1430 contains_forall_index_p (gfc_expr *expr)
1431 {
1432   gfc_actual_arglist *arg;
1433   gfc_constructor *c;
1434   gfc_ref *ref;
1435   int i;
1436
1437   if (!expr)
1438     return false;
1439
1440   switch (expr->expr_type)
1441     {
1442     case EXPR_VARIABLE:
1443       if (expr->symtree->n.sym->forall_index)
1444         return true;
1445       break;
1446
1447     case EXPR_OP:
1448       if (contains_forall_index_p (expr->value.op.op1)
1449           || contains_forall_index_p (expr->value.op.op2))
1450         return true;
1451       break;
1452
1453     case EXPR_FUNCTION:
1454       for (arg = expr->value.function.actual; arg; arg = arg->next)
1455         if (contains_forall_index_p (arg->expr))
1456           return true;
1457       break;
1458
1459     case EXPR_CONSTANT:
1460     case EXPR_NULL:
1461     case EXPR_SUBSTRING:
1462       break;
1463
1464     case EXPR_STRUCTURE:
1465     case EXPR_ARRAY:
1466       for (c = gfc_constructor_first (expr->value.constructor);
1467            c; gfc_constructor_next (c))
1468         if (contains_forall_index_p (c->expr))
1469           return true;
1470       break;
1471
1472     default:
1473       gcc_unreachable ();
1474     }
1475
1476   for (ref = expr->ref; ref; ref = ref->next)
1477     switch (ref->type)
1478       {
1479       case REF_ARRAY:
1480         for (i = 0; i < ref->u.ar.dimen; i++)
1481           if (contains_forall_index_p (ref->u.ar.start[i])
1482               || contains_forall_index_p (ref->u.ar.end[i])
1483               || contains_forall_index_p (ref->u.ar.stride[i]))
1484             return true;
1485         break;
1486
1487       case REF_COMPONENT:
1488         break;
1489
1490       case REF_SUBSTRING:
1491         if (contains_forall_index_p (ref->u.ss.start)
1492             || contains_forall_index_p (ref->u.ss.end))
1493           return true;
1494         break;
1495
1496       default:
1497         gcc_unreachable ();
1498       }
1499
1500   return false;
1501 }
1502
1503 /* Determines overlapping for two single element array references.  */
1504
1505 static gfc_dependency
1506 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1507 {
1508   gfc_array_ref l_ar;
1509   gfc_array_ref r_ar;
1510   gfc_expr *l_start;
1511   gfc_expr *r_start;
1512   int i;
1513
1514   l_ar = lref->u.ar;
1515   r_ar = rref->u.ar;
1516   l_start = l_ar.start[n] ;
1517   r_start = r_ar.start[n] ;
1518   i = gfc_dep_compare_expr (r_start, l_start);
1519   if (i == 0)
1520     return GFC_DEP_EQUAL;
1521
1522   /* Treat two scalar variables as potentially equal.  This allows
1523      us to prove that a(i,:) and a(j,:) have no dependency.  See
1524      Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1525      Proceedings of the International Conference on Parallel and
1526      Distributed Processing Techniques and Applications (PDPTA2001),
1527      Las Vegas, Nevada, June 2001.  */
1528   /* However, we need to be careful when either scalar expression
1529      contains a FORALL index, as these can potentially change value
1530      during the scalarization/traversal of this array reference.  */
1531   if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1532     return GFC_DEP_OVERLAP;
1533
1534   if (i != -2)
1535     return GFC_DEP_NODEP;
1536   return GFC_DEP_EQUAL;
1537 }
1538
1539
1540 /* Determine if an array ref, usually an array section specifies the
1541    entire array.  In addition, if the second, pointer argument is
1542    provided, the function will return true if the reference is
1543    contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
1544
1545 bool
1546 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1547 {
1548   int i;
1549   int n;
1550   bool lbound_OK = true;
1551   bool ubound_OK = true;
1552
1553   if (contiguous)
1554     *contiguous = false;
1555
1556   if (ref->type != REF_ARRAY)
1557     return false;
1558
1559   if (ref->u.ar.type == AR_FULL)
1560     {
1561       if (contiguous)
1562         *contiguous = true;
1563       return true;
1564     }
1565
1566   if (ref->u.ar.type != AR_SECTION)
1567     return false;
1568   if (ref->next)
1569     return false;
1570
1571   for (i = 0; i < ref->u.ar.dimen; i++)
1572     {
1573       /* If we have a single element in the reference, for the reference
1574          to be full, we need to ascertain that the array has a single
1575          element in this dimension and that we actually reference the
1576          correct element.  */
1577       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1578         {
1579           /* This is unconditionally a contiguous reference if all the
1580              remaining dimensions are elements.  */
1581           if (contiguous)
1582             {
1583               *contiguous = true;
1584               for (n = i + 1; n < ref->u.ar.dimen; n++)
1585                 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1586                   *contiguous = false;
1587             }
1588
1589           if (!ref->u.ar.as
1590               || !ref->u.ar.as->lower[i]
1591               || !ref->u.ar.as->upper[i]
1592               || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1593                                        ref->u.ar.as->upper[i])
1594               || !ref->u.ar.start[i]
1595               || gfc_dep_compare_expr (ref->u.ar.start[i],
1596                                        ref->u.ar.as->lower[i]))
1597             return false;
1598           else
1599             continue;
1600         }
1601
1602       /* Check the lower bound.  */
1603       if (ref->u.ar.start[i]
1604           && (!ref->u.ar.as
1605               || !ref->u.ar.as->lower[i]
1606               || gfc_dep_compare_expr (ref->u.ar.start[i],
1607                                        ref->u.ar.as->lower[i])))
1608         lbound_OK = false;
1609       /* Check the upper bound.  */
1610       if (ref->u.ar.end[i]
1611           && (!ref->u.ar.as
1612               || !ref->u.ar.as->upper[i]
1613               || gfc_dep_compare_expr (ref->u.ar.end[i],
1614                                        ref->u.ar.as->upper[i])))
1615         ubound_OK = false;
1616       /* Check the stride.  */
1617       if (ref->u.ar.stride[i]
1618             && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1619         return false;
1620
1621       /* This is unconditionally a contiguous reference as long as all
1622          the subsequent dimensions are elements.  */
1623       if (contiguous)
1624         {
1625           *contiguous = true;
1626           for (n = i + 1; n < ref->u.ar.dimen; n++)
1627             if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1628               *contiguous = false;
1629         }
1630
1631       if (!lbound_OK || !ubound_OK)
1632         return false;
1633     }
1634   return true;
1635 }
1636
1637
1638 /* Determine if a full array is the same as an array section with one
1639    variable limit.  For this to be so, the strides must both be unity
1640    and one of either start == lower or end == upper must be true.  */
1641
1642 static bool
1643 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1644 {
1645   int i;
1646   bool upper_or_lower;
1647
1648   if (full_ref->type != REF_ARRAY)
1649     return false;
1650   if (full_ref->u.ar.type != AR_FULL)
1651     return false;
1652   if (ref->type != REF_ARRAY)
1653     return false;
1654   if (ref->u.ar.type != AR_SECTION)
1655     return false;
1656
1657   for (i = 0; i < ref->u.ar.dimen; i++)
1658     {
1659       /* If we have a single element in the reference, we need to check
1660          that the array has a single element and that we actually reference
1661          the correct element.  */
1662       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1663         {
1664           if (!full_ref->u.ar.as
1665               || !full_ref->u.ar.as->lower[i]
1666               || !full_ref->u.ar.as->upper[i]
1667               || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1668                                        full_ref->u.ar.as->upper[i])
1669               || !ref->u.ar.start[i]
1670               || gfc_dep_compare_expr (ref->u.ar.start[i],
1671                                        full_ref->u.ar.as->lower[i]))
1672             return false;
1673         }
1674
1675       /* Check the strides.  */
1676       if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1677         return false;
1678       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1679         return false;
1680
1681       upper_or_lower = false;
1682       /* Check the lower bound.  */
1683       if (ref->u.ar.start[i]
1684           && (ref->u.ar.as
1685                 && full_ref->u.ar.as->lower[i]
1686                 && gfc_dep_compare_expr (ref->u.ar.start[i],
1687                                          full_ref->u.ar.as->lower[i]) == 0))
1688         upper_or_lower =  true;
1689       /* Check the upper bound.  */
1690       if (ref->u.ar.end[i]
1691           && (ref->u.ar.as
1692                 && full_ref->u.ar.as->upper[i]
1693                 && gfc_dep_compare_expr (ref->u.ar.end[i],
1694                                          full_ref->u.ar.as->upper[i]) == 0))
1695         upper_or_lower =  true;
1696       if (!upper_or_lower)
1697         return false;
1698     }
1699   return true;
1700 }
1701
1702
1703 /* Finds if two array references are overlapping or not.
1704    Return value
1705         2 : array references are overlapping but reversal of one or
1706             more dimensions will clear the dependency.
1707         1 : array references are overlapping.
1708         0 : array references are identical or not overlapping.  */
1709
1710 int
1711 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
1712 {
1713   int n;
1714   gfc_dependency fin_dep;
1715   gfc_dependency this_dep;
1716
1717   this_dep = GFC_DEP_ERROR;
1718   fin_dep = GFC_DEP_ERROR;
1719   /* Dependencies due to pointers should already have been identified.
1720      We only need to check for overlapping array references.  */
1721
1722   while (lref && rref)
1723     {
1724       /* We're resolving from the same base symbol, so both refs should be
1725          the same type.  We traverse the reference chain until we find ranges
1726          that are not equal.  */
1727       gcc_assert (lref->type == rref->type);
1728       switch (lref->type)
1729         {
1730         case REF_COMPONENT:
1731           /* The two ranges can't overlap if they are from different
1732              components.  */
1733           if (lref->u.c.component != rref->u.c.component)
1734             return 0;
1735           break;
1736
1737         case REF_SUBSTRING:
1738           /* Substring overlaps are handled by the string assignment code
1739              if there is not an underlying dependency.  */
1740           return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1741
1742         case REF_ARRAY:
1743
1744           if (ref_same_as_full_array (lref, rref))
1745             return 0;
1746
1747           if (ref_same_as_full_array (rref, lref))
1748             return 0;
1749
1750           if (lref->u.ar.dimen != rref->u.ar.dimen)
1751             {
1752               if (lref->u.ar.type == AR_FULL)
1753                 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1754                                                             : GFC_DEP_OVERLAP;
1755               else if (rref->u.ar.type == AR_FULL)
1756                 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1757                                                             : GFC_DEP_OVERLAP;
1758               else
1759                 return 1;
1760               break;
1761             }
1762
1763           for (n=0; n < lref->u.ar.dimen; n++)
1764             {
1765               /* Assume dependency when either of array reference is vector
1766                  subscript.  */
1767               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1768                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1769                 return 1;
1770
1771               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1772                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1773                 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
1774               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1775                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1776                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1777               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1778                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1779                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1780               else
1781                 {
1782                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1783                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1784                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1785                 }
1786
1787               /* If any dimension doesn't overlap, we have no dependency.  */
1788               if (this_dep == GFC_DEP_NODEP)
1789                 return 0;
1790
1791               /* Now deal with the loop reversal logic:  This only works on
1792                  ranges and is activated by setting
1793                                 reverse[n] == GFC_CAN_REVERSE
1794                  The ability to reverse or not is set by previous conditions
1795                  in this dimension.  If reversal is not activated, the
1796                  value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP.  */
1797               if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
1798                     && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1799                 {
1800                   /* Set reverse if backward dependence and not inhibited.  */
1801                   if (reverse && reverse[n] != GFC_CANNOT_REVERSE)
1802                     reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
1803                                  GFC_REVERSE_SET : reverse[n];
1804
1805                   /* Inhibit loop reversal if dependence not compatible.  */
1806                   if (reverse && reverse[n] != GFC_REVERSE_NOT_SET
1807                         && this_dep != GFC_DEP_EQUAL
1808                         && this_dep != GFC_DEP_BACKWARD
1809                         && this_dep != GFC_DEP_NODEP)
1810                     {
1811                       reverse[n] = GFC_CANNOT_REVERSE;
1812                       if (this_dep != GFC_DEP_FORWARD)
1813                         this_dep = GFC_DEP_OVERLAP;
1814                     }
1815
1816                   /* If no intention of reversing or reversing is explicitly
1817                      inhibited, convert backward dependence to overlap.  */
1818                   if (this_dep == GFC_DEP_BACKWARD
1819                       && (reverse == NULL || reverse[n] == GFC_CANNOT_REVERSE))
1820                     this_dep = GFC_DEP_OVERLAP;
1821                 }
1822
1823               /* Overlap codes are in order of priority.  We only need to
1824                  know the worst one.*/
1825               if (this_dep > fin_dep)
1826                 fin_dep = this_dep;
1827             }
1828
1829           /* If this is an equal element, we have to keep going until we find
1830              the "real" array reference.  */
1831           if (lref->u.ar.type == AR_ELEMENT
1832                 && rref->u.ar.type == AR_ELEMENT
1833                 && fin_dep == GFC_DEP_EQUAL)
1834             break;
1835
1836           /* Exactly matching and forward overlapping ranges don't cause a
1837              dependency.  */
1838           if (fin_dep < GFC_DEP_BACKWARD)
1839             return 0;
1840
1841           /* Keep checking.  We only have a dependency if
1842              subsequent references also overlap.  */
1843           break;
1844
1845         default:
1846           gcc_unreachable ();
1847         }
1848       lref = lref->next;
1849       rref = rref->next;
1850     }
1851
1852   /* If we haven't seen any array refs then something went wrong.  */
1853   gcc_assert (fin_dep != GFC_DEP_ERROR);
1854
1855   /* Assume the worst if we nest to different depths.  */
1856   if (lref || rref)
1857     return 1;
1858
1859   return fin_dep == GFC_DEP_OVERLAP;
1860 }