OSDN Git Service

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