OSDN Git Service

* trans.h (gfc_inline_intrinsic_function_p): Move prototype...
[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           if (gfc_inline_intrinsic_function_p (expr))
718             {
719               /* The TRANSPOSE case should have been caught in the
720                  noncopying intrinsic case above.  */
721               gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
722
723               return gfc_check_fncall_dependency (var, intent, NULL,
724                                                   expr->value.function.actual,
725                                                   ELEM_CHECK_VARIABLE);
726             }
727         }
728       return 0;
729
730     case EXPR_OP:
731       /* In case of non-elemental procedures, there is no need to catch
732          dependencies, as we will make a temporary anyway.  */
733       if (elemental)
734         {
735           /* If the actual arg EXPR is an expression, we need to catch 
736              a dependency between variables in EXPR and VAR, 
737              an intent((IN)OUT) variable.  */
738           if (expr->value.op.op1
739               && gfc_check_argument_var_dependency (var, intent, 
740                                                     expr->value.op.op1, 
741                                                     ELEM_CHECK_VARIABLE))
742             return 1;
743           else if (expr->value.op.op2
744                    && gfc_check_argument_var_dependency (var, intent, 
745                                                          expr->value.op.op2, 
746                                                          ELEM_CHECK_VARIABLE))
747             return 1;
748         }
749       return 0;
750
751     default:
752       return 0;
753     }
754 }
755   
756   
757 /* Like gfc_check_argument_var_dependency, but extended to any
758    array expression OTHER, not just variables.  */
759
760 static int
761 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
762                                gfc_expr *expr, gfc_dep_check elemental)
763 {
764   switch (other->expr_type)
765     {
766     case EXPR_VARIABLE:
767       return gfc_check_argument_var_dependency (other, intent, expr, elemental);
768
769     case EXPR_FUNCTION:
770       other = gfc_get_noncopying_intrinsic_argument (other);
771       if (other != NULL)
772         return gfc_check_argument_dependency (other, INTENT_IN, expr,
773                                               NOT_ELEMENTAL);
774
775       return 0;
776
777     default:
778       return 0;
779     }
780 }
781
782
783 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
784    FNSYM is the function being called, or NULL if not known.  */
785
786 int
787 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
788                              gfc_symbol *fnsym, gfc_actual_arglist *actual,
789                              gfc_dep_check elemental)
790 {
791   gfc_formal_arglist *formal;
792   gfc_expr *expr;
793
794   formal = fnsym ? fnsym->formal : NULL;
795   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
796     {
797       expr = actual->expr;
798
799       /* Skip args which are not present.  */
800       if (!expr)
801         continue;
802
803       /* Skip other itself.  */
804       if (expr == other)
805         continue;
806
807       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
808       if (formal && intent == INTENT_IN
809           && formal->sym->attr.intent == INTENT_IN)
810         continue;
811
812       if (gfc_check_argument_dependency (other, intent, expr, elemental))
813         return 1;
814     }
815
816   return 0;
817 }
818
819
820 /* Return 1 if e1 and e2 are equivalenced arrays, either
821    directly or indirectly; i.e., equivalence (a,b) for a and b
822    or equivalence (a,c),(b,c).  This function uses the equiv_
823    lists, generated in trans-common(add_equivalences), that are
824    guaranteed to pick up indirect equivalences.  We explicitly
825    check for overlap using the offset and length of the equivalence.
826    This function is symmetric.
827    TODO: This function only checks whether the full top-level
828    symbols overlap.  An improved implementation could inspect
829    e1->ref and e2->ref to determine whether the actually accessed
830    portions of these variables/arrays potentially overlap.  */
831
832 int
833 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
834 {
835   gfc_equiv_list *l;
836   gfc_equiv_info *s, *fl1, *fl2;
837
838   gcc_assert (e1->expr_type == EXPR_VARIABLE
839               && e2->expr_type == EXPR_VARIABLE);
840
841   if (!e1->symtree->n.sym->attr.in_equivalence
842       || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
843     return 0;
844
845   if (e1->symtree->n.sym->ns
846         && e1->symtree->n.sym->ns != gfc_current_ns)
847     l = e1->symtree->n.sym->ns->equiv_lists;
848   else
849     l = gfc_current_ns->equiv_lists;
850
851   /* Go through the equiv_lists and return 1 if the variables
852      e1 and e2 are members of the same group and satisfy the
853      requirement on their relative offsets.  */
854   for (; l; l = l->next)
855     {
856       fl1 = NULL;
857       fl2 = NULL;
858       for (s = l->equiv; s; s = s->next)
859         {
860           if (s->sym == e1->symtree->n.sym)
861             {
862               fl1 = s;
863               if (fl2)
864                 break;
865             }
866           if (s->sym == e2->symtree->n.sym)
867             {
868               fl2 = s;
869               if (fl1)
870                 break;
871             }
872         }
873
874       if (s)
875         {
876           /* Can these lengths be zero?  */
877           if (fl1->length <= 0 || fl2->length <= 0)
878             return 1;
879           /* These can't overlap if [f11,fl1+length] is before 
880              [fl2,fl2+length], or [fl2,fl2+length] is before
881              [fl1,fl1+length], otherwise they do overlap.  */
882           if (fl1->offset + fl1->length > fl2->offset
883               && fl2->offset + fl2->length > fl1->offset)
884             return 1;
885         }
886     }
887   return 0;
888 }
889
890
891 /* Return true if there is no possibility of aliasing because of a type
892    mismatch between all the possible pointer references and the
893    potential target.  Note that this function is asymmetric in the
894    arguments and so must be called twice with the arguments exchanged.  */
895
896 static bool
897 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
898 {
899   gfc_component *cm1;
900   gfc_symbol *sym1;
901   gfc_symbol *sym2;
902   gfc_ref *ref1;
903   bool seen_component_ref;
904
905   if (expr1->expr_type != EXPR_VARIABLE
906         || expr1->expr_type != EXPR_VARIABLE)
907     return false;
908
909   sym1 = expr1->symtree->n.sym;
910   sym2 = expr2->symtree->n.sym;
911
912   /* Keep it simple for now.  */
913   if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
914     return false;
915
916   if (sym1->attr.pointer)
917     {
918       if (gfc_compare_types (&sym1->ts, &sym2->ts))
919         return false;
920     }
921
922   /* This is a conservative check on the components of the derived type
923      if no component references have been seen.  Since we will not dig
924      into the components of derived type components, we play it safe by
925      returning false.  First we check the reference chain and then, if
926      no component references have been seen, the components.  */
927   seen_component_ref = false;
928   if (sym1->ts.type == BT_DERIVED)
929     {
930       for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
931         {
932           if (ref1->type != REF_COMPONENT)
933             continue;
934
935           if (ref1->u.c.component->ts.type == BT_DERIVED)
936             return false;
937
938           if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
939                 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
940             return false;
941
942           seen_component_ref = true;
943         }
944     }
945
946   if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
947     {
948       for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
949         {
950           if (cm1->ts.type == BT_DERIVED)
951             return false;
952
953           if ((sym2->attr.pointer || cm1->attr.pointer)
954                 && gfc_compare_types (&cm1->ts, &sym2->ts))
955             return false;
956         }
957     }
958
959   return true;
960 }
961
962
963 /* Return true if the statement body redefines the condition.  Returns
964    true if expr2 depends on expr1.  expr1 should be a single term
965    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
966    whether array references to the same symbol with identical range
967    references count as a dependency or not.  Used for forall and where
968    statements.  Also used with functions returning arrays without a
969    temporary.  */
970
971 int
972 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
973 {
974   gfc_actual_arglist *actual;
975   gfc_constructor *c;
976   int n;
977
978   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
979
980   switch (expr2->expr_type)
981     {
982     case EXPR_OP:
983       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
984       if (n)
985         return n;
986       if (expr2->value.op.op2)
987         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
988       return 0;
989
990     case EXPR_VARIABLE:
991       /* The interesting cases are when the symbols don't match.  */
992       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
993         {
994           gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
995           gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
996
997           /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
998           if (gfc_are_equivalenced_arrays (expr1, expr2))
999             return 1;
1000
1001           /* Symbols can only alias if they have the same type.  */
1002           if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1003               && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1004             {
1005               if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1006                 return 0;
1007             }
1008
1009           /* If either variable is a pointer, assume the worst.  */
1010           /* TODO: -fassume-no-pointer-aliasing */
1011           if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
1012             {
1013               if (check_data_pointer_types (expr1, expr2)
1014                     && check_data_pointer_types (expr2, expr1))
1015                 return 0;
1016
1017               return 1;
1018             }
1019           else
1020             {
1021               gfc_symbol *sym1 = expr1->symtree->n.sym;
1022               gfc_symbol *sym2 = expr2->symtree->n.sym;
1023               if (sym1->attr.target && sym2->attr.target
1024                   && ((sym1->attr.dummy && !sym1->attr.contiguous
1025                        && (!sym1->attr.dimension
1026                            || sym2->as->type == AS_ASSUMED_SHAPE))
1027                       || (sym2->attr.dummy && !sym2->attr.contiguous
1028                           && (!sym2->attr.dimension
1029                               || sym2->as->type == AS_ASSUMED_SHAPE))))
1030                 return 1;
1031             }
1032
1033           /* Otherwise distinct symbols have no dependencies.  */
1034           return 0;
1035         }
1036
1037       if (identical)
1038         return 1;
1039
1040       /* Identical and disjoint ranges return 0,
1041          overlapping ranges return 1.  */
1042       if (expr1->ref && expr2->ref)
1043         return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
1044
1045       return 1;
1046
1047     case EXPR_FUNCTION:
1048       if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1049         identical = 1;
1050
1051       /* Remember possible differences between elemental and
1052          transformational functions.  All functions inside a FORALL
1053          will be pure.  */
1054       for (actual = expr2->value.function.actual;
1055            actual; actual = actual->next)
1056         {
1057           if (!actual->expr)
1058             continue;
1059           n = gfc_check_dependency (expr1, actual->expr, identical);
1060           if (n)
1061             return n;
1062         }
1063       return 0;
1064
1065     case EXPR_CONSTANT:
1066     case EXPR_NULL:
1067       return 0;
1068
1069     case EXPR_ARRAY:
1070       /* Loop through the array constructor's elements.  */
1071       for (c = gfc_constructor_first (expr2->value.constructor);
1072            c; c = gfc_constructor_next (c))
1073         {
1074           /* If this is an iterator, assume the worst.  */
1075           if (c->iterator)
1076             return 1;
1077           /* Avoid recursion in the common case.  */
1078           if (c->expr->expr_type == EXPR_CONSTANT)
1079             continue;
1080           if (gfc_check_dependency (expr1, c->expr, 1))
1081             return 1;
1082         }
1083       return 0;
1084
1085     default:
1086       return 1;
1087     }
1088 }
1089
1090
1091 /* Determines overlapping for two array sections.  */
1092
1093 static gfc_dependency
1094 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1095 {
1096   gfc_expr *l_start;
1097   gfc_expr *l_end;
1098   gfc_expr *l_stride;
1099   gfc_expr *l_lower;
1100   gfc_expr *l_upper;
1101   int l_dir;
1102
1103   gfc_expr *r_start;
1104   gfc_expr *r_end;
1105   gfc_expr *r_stride;
1106   gfc_expr *r_lower;
1107   gfc_expr *r_upper;
1108   gfc_expr *one_expr;
1109   int r_dir;
1110   int stride_comparison;
1111   int start_comparison;
1112
1113   /* If they are the same range, return without more ado.  */
1114   if (is_same_range (l_ar, r_ar, n))
1115     return GFC_DEP_EQUAL;
1116
1117   l_start = l_ar->start[n];
1118   l_end = l_ar->end[n];
1119   l_stride = l_ar->stride[n];
1120
1121   r_start = r_ar->start[n];
1122   r_end = r_ar->end[n];
1123   r_stride = r_ar->stride[n];
1124
1125   /* If l_start is NULL take it from array specifier.  */
1126   if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1127     l_start = l_ar->as->lower[n];
1128   /* If l_end is NULL take it from array specifier.  */
1129   if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
1130     l_end = l_ar->as->upper[n];
1131
1132   /* If r_start is NULL take it from array specifier.  */
1133   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
1134     r_start = r_ar->as->lower[n];
1135   /* If r_end is NULL take it from array specifier.  */
1136   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
1137     r_end = r_ar->as->upper[n];
1138
1139   /* Determine whether the l_stride is positive or negative.  */
1140   if (!l_stride)
1141     l_dir = 1;
1142   else if (l_stride->expr_type == EXPR_CONSTANT
1143            && l_stride->ts.type == BT_INTEGER)
1144     l_dir = mpz_sgn (l_stride->value.integer);
1145   else if (l_start && l_end)
1146     l_dir = gfc_dep_compare_expr (l_end, l_start);
1147   else
1148     l_dir = -2;
1149
1150   /* Determine whether the r_stride is positive or negative.  */
1151   if (!r_stride)
1152     r_dir = 1;
1153   else if (r_stride->expr_type == EXPR_CONSTANT
1154            && r_stride->ts.type == BT_INTEGER)
1155     r_dir = mpz_sgn (r_stride->value.integer);
1156   else if (r_start && r_end)
1157     r_dir = gfc_dep_compare_expr (r_end, r_start);
1158   else
1159     r_dir = -2;
1160
1161   /* The strides should never be zero.  */
1162   if (l_dir == 0 || r_dir == 0)
1163     return GFC_DEP_OVERLAP;
1164
1165   /* Determine the relationship between the strides.  Set stride_comparison to
1166      -2 if the dependency cannot be determined
1167      -1 if l_stride < r_stride
1168       0 if l_stride == r_stride
1169       1 if l_stride > r_stride
1170      as determined by gfc_dep_compare_expr.  */
1171
1172   one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1173
1174   stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1175                                             r_stride ? r_stride : one_expr);
1176
1177   if (l_start && r_start)
1178     start_comparison = gfc_dep_compare_expr (l_start, r_start);
1179   else
1180     start_comparison = -2;
1181       
1182   free (one_expr);
1183
1184   /* Determine LHS upper and lower bounds.  */
1185   if (l_dir == 1)
1186     {
1187       l_lower = l_start;
1188       l_upper = l_end;
1189     }
1190   else if (l_dir == -1)
1191     {
1192       l_lower = l_end;
1193       l_upper = l_start;
1194     }
1195   else
1196     {
1197       l_lower = NULL;
1198       l_upper = NULL;
1199     }
1200
1201   /* Determine RHS upper and lower bounds.  */
1202   if (r_dir == 1)
1203     {
1204       r_lower = r_start;
1205       r_upper = r_end;
1206     }
1207   else if (r_dir == -1)
1208     {
1209       r_lower = r_end;
1210       r_upper = r_start;
1211     }
1212   else
1213     {
1214       r_lower = NULL;
1215       r_upper = NULL;
1216     }
1217
1218   /* Check whether the ranges are disjoint.  */
1219   if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1220     return GFC_DEP_NODEP;
1221   if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1222     return GFC_DEP_NODEP;
1223
1224   /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
1225   if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1226     {
1227       if (l_dir == 1 && r_dir == -1)
1228         return GFC_DEP_EQUAL;
1229       if (l_dir == -1 && r_dir == 1)
1230         return GFC_DEP_EQUAL;
1231     }
1232
1233   /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
1234   if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1235     {
1236       if (l_dir == 1 && r_dir == -1)
1237         return GFC_DEP_EQUAL;
1238       if (l_dir == -1 && r_dir == 1)
1239         return GFC_DEP_EQUAL;
1240     }
1241
1242   /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1243      There is no dependency if the remainder of
1244      (l_start - r_start) / gcd(l_stride, r_stride) is
1245      nonzero.
1246      TODO:
1247        - Handle cases where x is an expression.
1248        - Cases like a(1:4:2) = a(2:3) are still not handled.
1249   */
1250
1251 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1252                               && (a)->ts.type == BT_INTEGER)
1253
1254   if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
1255       && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
1256     {
1257       mpz_t gcd, tmp;
1258       int result;
1259
1260       mpz_init (gcd);
1261       mpz_init (tmp);
1262
1263       mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1264       mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
1265
1266       mpz_fdiv_r (tmp, tmp, gcd);
1267       result = mpz_cmp_si (tmp, 0L);
1268
1269       mpz_clear (gcd);
1270       mpz_clear (tmp);
1271
1272       if (result != 0)
1273         return GFC_DEP_NODEP;
1274     }
1275
1276 #undef IS_CONSTANT_INTEGER
1277
1278   /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1279
1280   if (l_dir == 1 && r_dir == 1 &&
1281       (start_comparison == 0 || start_comparison == -1)
1282       && (stride_comparison == 0 || stride_comparison == -1))
1283           return GFC_DEP_FORWARD;
1284
1285   /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1286      x:y:-1 vs. x:y:-2.  */
1287   if (l_dir == -1 && r_dir == -1 && 
1288       (start_comparison == 0 || start_comparison == 1)
1289       && (stride_comparison == 0 || stride_comparison == 1))
1290     return GFC_DEP_FORWARD;
1291
1292   if (stride_comparison == 0 || stride_comparison == -1)
1293     {
1294       if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1295         {
1296
1297           /* Check for a(low:y:s) vs. a(z:x:s) or
1298              a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1299              of low, which is always at least a forward dependence.  */
1300
1301           if (r_dir == 1
1302               && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1303             return GFC_DEP_FORWARD;
1304         }
1305     }
1306
1307   if (stride_comparison == 0 || stride_comparison == 1)
1308     {
1309       if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1310         {
1311       
1312           /* Check for a(high:y:-s) vs. a(z:x:-s) or
1313              a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1314              of high, which is always at least a forward dependence.  */
1315
1316           if (r_dir == -1
1317               && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1318             return GFC_DEP_FORWARD;
1319         }
1320     }
1321
1322
1323   if (stride_comparison == 0)
1324     {
1325       /* From here, check for backwards dependencies.  */
1326       /* x+1:y vs. x:z.  */
1327       if (l_dir == 1 && r_dir == 1  && start_comparison == 1)
1328         return GFC_DEP_BACKWARD;
1329
1330       /* x-1:y:-1 vs. x:z:-1.  */
1331       if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1332         return GFC_DEP_BACKWARD;
1333     }
1334
1335   return GFC_DEP_OVERLAP;
1336 }
1337
1338
1339 /* Determines overlapping for a single element and a section.  */
1340
1341 static gfc_dependency
1342 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1343 {
1344   gfc_array_ref *ref;
1345   gfc_expr *elem;
1346   gfc_expr *start;
1347   gfc_expr *end;
1348   gfc_expr *stride;
1349   int s;
1350
1351   elem = lref->u.ar.start[n];
1352   if (!elem)
1353     return GFC_DEP_OVERLAP;
1354
1355   ref = &rref->u.ar;
1356   start = ref->start[n] ;
1357   end = ref->end[n] ;
1358   stride = ref->stride[n];
1359
1360   if (!start && IS_ARRAY_EXPLICIT (ref->as))
1361     start = ref->as->lower[n];
1362   if (!end && IS_ARRAY_EXPLICIT (ref->as))
1363     end = ref->as->upper[n];
1364
1365   /* Determine whether the stride is positive or negative.  */
1366   if (!stride)
1367     s = 1;
1368   else if (stride->expr_type == EXPR_CONSTANT
1369            && stride->ts.type == BT_INTEGER)
1370     s = mpz_sgn (stride->value.integer);
1371   else
1372     s = -2;
1373
1374   /* Stride should never be zero.  */
1375   if (s == 0)
1376     return GFC_DEP_OVERLAP;
1377
1378   /* Positive strides.  */
1379   if (s == 1)
1380     {
1381       /* Check for elem < lower.  */
1382       if (start && gfc_dep_compare_expr (elem, start) == -1)
1383         return GFC_DEP_NODEP;
1384       /* Check for elem > upper.  */
1385       if (end && gfc_dep_compare_expr (elem, end) == 1)
1386         return GFC_DEP_NODEP;
1387
1388       if (start && end)
1389         {
1390           s = gfc_dep_compare_expr (start, end);
1391           /* Check for an empty range.  */
1392           if (s == 1)
1393             return GFC_DEP_NODEP;
1394           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1395             return GFC_DEP_EQUAL;
1396         }
1397     }
1398   /* Negative strides.  */
1399   else if (s == -1)
1400     {
1401       /* Check for elem > upper.  */
1402       if (end && gfc_dep_compare_expr (elem, start) == 1)
1403         return GFC_DEP_NODEP;
1404       /* Check for elem < lower.  */
1405       if (start && gfc_dep_compare_expr (elem, end) == -1)
1406         return GFC_DEP_NODEP;
1407
1408       if (start && end)
1409         {
1410           s = gfc_dep_compare_expr (start, end);
1411           /* Check for an empty range.  */
1412           if (s == -1)
1413             return GFC_DEP_NODEP;
1414           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1415             return GFC_DEP_EQUAL;
1416         }
1417     }
1418   /* Unknown strides.  */
1419   else
1420     {
1421       if (!start || !end)
1422         return GFC_DEP_OVERLAP;
1423       s = gfc_dep_compare_expr (start, end);
1424       if (s <= -2)
1425         return GFC_DEP_OVERLAP;
1426       /* Assume positive stride.  */
1427       if (s == -1)
1428         {
1429           /* Check for elem < lower.  */
1430           if (gfc_dep_compare_expr (elem, start) == -1)
1431             return GFC_DEP_NODEP;
1432           /* Check for elem > upper.  */
1433           if (gfc_dep_compare_expr (elem, end) == 1)
1434             return GFC_DEP_NODEP;
1435         }
1436       /* Assume negative stride.  */
1437       else if (s == 1)
1438         {
1439           /* Check for elem > upper.  */
1440           if (gfc_dep_compare_expr (elem, start) == 1)
1441             return GFC_DEP_NODEP;
1442           /* Check for elem < lower.  */
1443           if (gfc_dep_compare_expr (elem, end) == -1)
1444             return GFC_DEP_NODEP;
1445         }
1446       /* Equal bounds.  */
1447       else if (s == 0)
1448         {
1449           s = gfc_dep_compare_expr (elem, start);
1450           if (s == 0)
1451             return GFC_DEP_EQUAL;
1452           if (s == 1 || s == -1)
1453             return GFC_DEP_NODEP;
1454         }
1455     }
1456
1457   return GFC_DEP_OVERLAP;
1458 }
1459
1460
1461 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1462    forall_index attribute.  Return true if any variable may be
1463    being used as a FORALL index.  Its safe to pessimistically
1464    return true, and assume a dependency.  */
1465
1466 static bool
1467 contains_forall_index_p (gfc_expr *expr)
1468 {
1469   gfc_actual_arglist *arg;
1470   gfc_constructor *c;
1471   gfc_ref *ref;
1472   int i;
1473
1474   if (!expr)
1475     return false;
1476
1477   switch (expr->expr_type)
1478     {
1479     case EXPR_VARIABLE:
1480       if (expr->symtree->n.sym->forall_index)
1481         return true;
1482       break;
1483
1484     case EXPR_OP:
1485       if (contains_forall_index_p (expr->value.op.op1)
1486           || contains_forall_index_p (expr->value.op.op2))
1487         return true;
1488       break;
1489
1490     case EXPR_FUNCTION:
1491       for (arg = expr->value.function.actual; arg; arg = arg->next)
1492         if (contains_forall_index_p (arg->expr))
1493           return true;
1494       break;
1495
1496     case EXPR_CONSTANT:
1497     case EXPR_NULL:
1498     case EXPR_SUBSTRING:
1499       break;
1500
1501     case EXPR_STRUCTURE:
1502     case EXPR_ARRAY:
1503       for (c = gfc_constructor_first (expr->value.constructor);
1504            c; gfc_constructor_next (c))
1505         if (contains_forall_index_p (c->expr))
1506           return true;
1507       break;
1508
1509     default:
1510       gcc_unreachable ();
1511     }
1512
1513   for (ref = expr->ref; ref; ref = ref->next)
1514     switch (ref->type)
1515       {
1516       case REF_ARRAY:
1517         for (i = 0; i < ref->u.ar.dimen; i++)
1518           if (contains_forall_index_p (ref->u.ar.start[i])
1519               || contains_forall_index_p (ref->u.ar.end[i])
1520               || contains_forall_index_p (ref->u.ar.stride[i]))
1521             return true;
1522         break;
1523
1524       case REF_COMPONENT:
1525         break;
1526
1527       case REF_SUBSTRING:
1528         if (contains_forall_index_p (ref->u.ss.start)
1529             || contains_forall_index_p (ref->u.ss.end))
1530           return true;
1531         break;
1532
1533       default:
1534         gcc_unreachable ();
1535       }
1536
1537   return false;
1538 }
1539
1540 /* Determines overlapping for two single element array references.  */
1541
1542 static gfc_dependency
1543 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1544 {
1545   gfc_array_ref l_ar;
1546   gfc_array_ref r_ar;
1547   gfc_expr *l_start;
1548   gfc_expr *r_start;
1549   int i;
1550
1551   l_ar = lref->u.ar;
1552   r_ar = rref->u.ar;
1553   l_start = l_ar.start[n] ;
1554   r_start = r_ar.start[n] ;
1555   i = gfc_dep_compare_expr (r_start, l_start);
1556   if (i == 0)
1557     return GFC_DEP_EQUAL;
1558
1559   /* Treat two scalar variables as potentially equal.  This allows
1560      us to prove that a(i,:) and a(j,:) have no dependency.  See
1561      Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1562      Proceedings of the International Conference on Parallel and
1563      Distributed Processing Techniques and Applications (PDPTA2001),
1564      Las Vegas, Nevada, June 2001.  */
1565   /* However, we need to be careful when either scalar expression
1566      contains a FORALL index, as these can potentially change value
1567      during the scalarization/traversal of this array reference.  */
1568   if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1569     return GFC_DEP_OVERLAP;
1570
1571   if (i > -2)
1572     return GFC_DEP_NODEP;
1573   return GFC_DEP_EQUAL;
1574 }
1575
1576
1577 /* Determine if an array ref, usually an array section specifies the
1578    entire array.  In addition, if the second, pointer argument is
1579    provided, the function will return true if the reference is
1580    contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
1581
1582 bool
1583 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1584 {
1585   int i;
1586   int n;
1587   bool lbound_OK = true;
1588   bool ubound_OK = true;
1589
1590   if (contiguous)
1591     *contiguous = false;
1592
1593   if (ref->type != REF_ARRAY)
1594     return false;
1595
1596   if (ref->u.ar.type == AR_FULL)
1597     {
1598       if (contiguous)
1599         *contiguous = true;
1600       return true;
1601     }
1602
1603   if (ref->u.ar.type != AR_SECTION)
1604     return false;
1605   if (ref->next)
1606     return false;
1607
1608   for (i = 0; i < ref->u.ar.dimen; i++)
1609     {
1610       /* If we have a single element in the reference, for the reference
1611          to be full, we need to ascertain that the array has a single
1612          element in this dimension and that we actually reference the
1613          correct element.  */
1614       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1615         {
1616           /* This is unconditionally a contiguous reference if all the
1617              remaining dimensions are elements.  */
1618           if (contiguous)
1619             {
1620               *contiguous = true;
1621               for (n = i + 1; n < ref->u.ar.dimen; n++)
1622                 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1623                   *contiguous = false;
1624             }
1625
1626           if (!ref->u.ar.as
1627               || !ref->u.ar.as->lower[i]
1628               || !ref->u.ar.as->upper[i]
1629               || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1630                                        ref->u.ar.as->upper[i])
1631               || !ref->u.ar.start[i]
1632               || gfc_dep_compare_expr (ref->u.ar.start[i],
1633                                        ref->u.ar.as->lower[i]))
1634             return false;
1635           else
1636             continue;
1637         }
1638
1639       /* Check the lower bound.  */
1640       if (ref->u.ar.start[i]
1641           && (!ref->u.ar.as
1642               || !ref->u.ar.as->lower[i]
1643               || gfc_dep_compare_expr (ref->u.ar.start[i],
1644                                        ref->u.ar.as->lower[i])))
1645         lbound_OK = false;
1646       /* Check the upper bound.  */
1647       if (ref->u.ar.end[i]
1648           && (!ref->u.ar.as
1649               || !ref->u.ar.as->upper[i]
1650               || gfc_dep_compare_expr (ref->u.ar.end[i],
1651                                        ref->u.ar.as->upper[i])))
1652         ubound_OK = false;
1653       /* Check the stride.  */
1654       if (ref->u.ar.stride[i]
1655             && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1656         return false;
1657
1658       /* This is unconditionally a contiguous reference as long as all
1659          the subsequent dimensions are elements.  */
1660       if (contiguous)
1661         {
1662           *contiguous = true;
1663           for (n = i + 1; n < ref->u.ar.dimen; n++)
1664             if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1665               *contiguous = false;
1666         }
1667
1668       if (!lbound_OK || !ubound_OK)
1669         return false;
1670     }
1671   return true;
1672 }
1673
1674
1675 /* Determine if a full array is the same as an array section with one
1676    variable limit.  For this to be so, the strides must both be unity
1677    and one of either start == lower or end == upper must be true.  */
1678
1679 static bool
1680 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1681 {
1682   int i;
1683   bool upper_or_lower;
1684
1685   if (full_ref->type != REF_ARRAY)
1686     return false;
1687   if (full_ref->u.ar.type != AR_FULL)
1688     return false;
1689   if (ref->type != REF_ARRAY)
1690     return false;
1691   if (ref->u.ar.type != AR_SECTION)
1692     return false;
1693
1694   for (i = 0; i < ref->u.ar.dimen; i++)
1695     {
1696       /* If we have a single element in the reference, we need to check
1697          that the array has a single element and that we actually reference
1698          the correct element.  */
1699       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1700         {
1701           if (!full_ref->u.ar.as
1702               || !full_ref->u.ar.as->lower[i]
1703               || !full_ref->u.ar.as->upper[i]
1704               || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1705                                        full_ref->u.ar.as->upper[i])
1706               || !ref->u.ar.start[i]
1707               || gfc_dep_compare_expr (ref->u.ar.start[i],
1708                                        full_ref->u.ar.as->lower[i]))
1709             return false;
1710         }
1711
1712       /* Check the strides.  */
1713       if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1714         return false;
1715       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1716         return false;
1717
1718       upper_or_lower = false;
1719       /* Check the lower bound.  */
1720       if (ref->u.ar.start[i]
1721           && (ref->u.ar.as
1722                 && full_ref->u.ar.as->lower[i]
1723                 && gfc_dep_compare_expr (ref->u.ar.start[i],
1724                                          full_ref->u.ar.as->lower[i]) == 0))
1725         upper_or_lower =  true;
1726       /* Check the upper bound.  */
1727       if (ref->u.ar.end[i]
1728           && (ref->u.ar.as
1729                 && full_ref->u.ar.as->upper[i]
1730                 && gfc_dep_compare_expr (ref->u.ar.end[i],
1731                                          full_ref->u.ar.as->upper[i]) == 0))
1732         upper_or_lower =  true;
1733       if (!upper_or_lower)
1734         return false;
1735     }
1736   return true;
1737 }
1738
1739
1740 /* Finds if two array references are overlapping or not.
1741    Return value
1742         2 : array references are overlapping but reversal of one or
1743             more dimensions will clear the dependency.
1744         1 : array references are overlapping.
1745         0 : array references are identical or not overlapping.  */
1746
1747 int
1748 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
1749 {
1750   int n;
1751   gfc_dependency fin_dep;
1752   gfc_dependency this_dep;
1753
1754   this_dep = GFC_DEP_ERROR;
1755   fin_dep = GFC_DEP_ERROR;
1756   /* Dependencies due to pointers should already have been identified.
1757      We only need to check for overlapping array references.  */
1758
1759   while (lref && rref)
1760     {
1761       /* We're resolving from the same base symbol, so both refs should be
1762          the same type.  We traverse the reference chain until we find ranges
1763          that are not equal.  */
1764       gcc_assert (lref->type == rref->type);
1765       switch (lref->type)
1766         {
1767         case REF_COMPONENT:
1768           /* The two ranges can't overlap if they are from different
1769              components.  */
1770           if (lref->u.c.component != rref->u.c.component)
1771             return 0;
1772           break;
1773           
1774         case REF_SUBSTRING:
1775           /* Substring overlaps are handled by the string assignment code
1776              if there is not an underlying dependency.  */
1777           return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1778         
1779         case REF_ARRAY:
1780
1781           if (ref_same_as_full_array (lref, rref))
1782             return 0;
1783
1784           if (ref_same_as_full_array (rref, lref))
1785             return 0;
1786
1787           if (lref->u.ar.dimen != rref->u.ar.dimen)
1788             {
1789               if (lref->u.ar.type == AR_FULL)
1790                 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1791                                                             : GFC_DEP_OVERLAP;
1792               else if (rref->u.ar.type == AR_FULL)
1793                 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1794                                                             : GFC_DEP_OVERLAP;
1795               else
1796                 return 1;
1797               break;
1798             }
1799
1800           for (n=0; n < lref->u.ar.dimen; n++)
1801             {
1802               /* Assume dependency when either of array reference is vector
1803                  subscript.  */
1804               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1805                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1806                 return 1;
1807
1808               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1809                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1810                 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
1811               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1812                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1813                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1814               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1815                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1816                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1817               else 
1818                 {
1819                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1820                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1821                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1822                 }
1823
1824               /* If any dimension doesn't overlap, we have no dependency.  */
1825               if (this_dep == GFC_DEP_NODEP)
1826                 return 0;
1827
1828               /* Now deal with the loop reversal logic:  This only works on
1829                  ranges and is activated by setting
1830                                 reverse[n] == GFC_ENABLE_REVERSE
1831                  The ability to reverse or not is set by previous conditions
1832                  in this dimension.  If reversal is not activated, the
1833                  value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP.  */
1834               if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
1835                     && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1836                 {
1837                   /* Set reverse if backward dependence and not inhibited.  */
1838                   if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
1839                     reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
1840                                  GFC_REVERSE_SET : reverse[n];
1841
1842                   /* Set forward if forward dependence and not inhibited.  */
1843                   if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
1844                     reverse[n] = (this_dep == GFC_DEP_FORWARD) ?
1845                                  GFC_FORWARD_SET : reverse[n];
1846
1847                   /* Flag up overlap if dependence not compatible with
1848                      the overall state of the expression.  */
1849                   if (reverse && reverse[n] == GFC_REVERSE_SET
1850                         && this_dep == GFC_DEP_FORWARD)
1851                     {
1852                       reverse[n] = GFC_INHIBIT_REVERSE;
1853                       this_dep = GFC_DEP_OVERLAP;
1854                     }
1855                   else if (reverse && reverse[n] == GFC_FORWARD_SET
1856                         && this_dep == GFC_DEP_BACKWARD)
1857                     {
1858                       reverse[n] = GFC_INHIBIT_REVERSE;
1859                       this_dep = GFC_DEP_OVERLAP;
1860                     }
1861
1862                   /* If no intention of reversing or reversing is explicitly
1863                      inhibited, convert backward dependence to overlap.  */
1864                   if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
1865                       || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
1866                     this_dep = GFC_DEP_OVERLAP;
1867                 }
1868
1869               /* Overlap codes are in order of priority.  We only need to
1870                  know the worst one.*/
1871               if (this_dep > fin_dep)
1872                 fin_dep = this_dep;
1873             }
1874
1875           /* If this is an equal element, we have to keep going until we find
1876              the "real" array reference.  */
1877           if (lref->u.ar.type == AR_ELEMENT
1878                 && rref->u.ar.type == AR_ELEMENT
1879                 && fin_dep == GFC_DEP_EQUAL)
1880             break;
1881
1882           /* Exactly matching and forward overlapping ranges don't cause a
1883              dependency.  */
1884           if (fin_dep < GFC_DEP_BACKWARD)
1885             return 0;
1886
1887           /* Keep checking.  We only have a dependency if
1888              subsequent references also overlap.  */
1889           break;
1890
1891         default:
1892           gcc_unreachable ();
1893         }
1894       lref = lref->next;
1895       rref = rref->next;
1896     }
1897
1898   /* If we haven't seen any array refs then something went wrong.  */
1899   gcc_assert (fin_dep != GFC_DEP_ERROR);
1900
1901   /* Assume the worst if we nest to different depths.  */
1902   if (lref || rref)
1903     return 1;
1904
1905   return fin_dep == GFC_DEP_OVERLAP;
1906 }