?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* es.po: Update.
[official-gcc.git] / gcc / fortran / dependency.c
blob82c5e6b573325e4a2b110db1c2b8c7052501435e
1 /* Dependency analysis
2 Copyright (C) 2000-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 /* dependency.c -- Expression dependency analysis code. */
22 /* There's probably quite a bit of duplication in this file. We currently
23 have different dependency checking functions for different types
24 if dependencies. Ideally these would probably be merged. */
25
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.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 enum gfc_dependency
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
49 /* Macros */
50 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
51
52 /* Forward declarations */
53
54 static gfc_dependency check_section_vs_section (gfc_array_ref *,
55 gfc_array_ref *, int);
56
57 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
58 def if the value could not be determined. */
59
60 int
61 gfc_expr_is_one (gfc_expr *expr, int def)
62 {
63 gcc_assert (expr != NULL);
64
65 if (expr->expr_type != EXPR_CONSTANT)
66 return def;
67
68 if (expr->ts.type != BT_INTEGER)
69 return def;
70
71 return mpz_cmp_si (expr->value.integer, 1) == 0;
72 }
73
74 /* Check if two array references are known to be identical. Calls
75 gfc_dep_compare_expr if necessary for comparing array indices. */
76
77 static bool
78 identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
79 {
80 int i;
81
82 if (a1->type == AR_FULL && a2->type == AR_FULL)
83 return true;
84
85 if (a1->type == AR_SECTION && a2->type == AR_SECTION)
86 {
87 gcc_assert (a1->dimen == a2->dimen);
88
89 for ( i = 0; i < a1->dimen; i++)
90 {
91 /* TODO: Currently, we punt on an integer array as an index. */
92 if (a1->dimen_type[i] != DIMEN_RANGE
93 || a2->dimen_type[i] != DIMEN_RANGE)
94 return false;
95
96 if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
97 return false;
98 }
99 return true;
100 }
101
102 if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
103 {
104 gcc_assert (a1->dimen == a2->dimen);
105 for (i = 0; i < a1->dimen; i++)
106 {
107 if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
108 return false;
109 }
110 return true;
111 }
112 return false;
113 }
114
115
116
117 /* Return true for identical variables, checking for references if
118 necessary. Calls identical_array_ref for checking array sections. */
119
120 static bool
121 are_identical_variables (gfc_expr *e1, gfc_expr *e2)
122 {
123 gfc_ref *r1, *r2;
124
125 if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
126 {
127 /* Dummy arguments: Only check for equal names. */
128 if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
129 return false;
130 }
131 else
132 {
133 /* Check for equal symbols. */
134 if (e1->symtree->n.sym != e2->symtree->n.sym)
135 return false;
136 }
137
138 /* Volatile variables should never compare equal to themselves. */
139
140 if (e1->symtree->n.sym->attr.volatile_)
141 return false;
142
143 r1 = e1->ref;
144 r2 = e2->ref;
145
146 while (r1 != NULL || r2 != NULL)
147 {
148
149 /* Assume the variables are not equal if one has a reference and the
150 other doesn't.
151 TODO: Handle full references like comparing a(:) to a.
152 */
153
154 if (r1 == NULL || r2 == NULL)
155 return false;
156
157 if (r1->type != r2->type)
158 return false;
159
160 switch (r1->type)
161 {
162
163 case REF_ARRAY:
164 if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
165 return false;
166
167 break;
168
169 case REF_COMPONENT:
170 if (r1->u.c.component != r2->u.c.component)
171 return false;
172 break;
173
174 case REF_SUBSTRING:
175 if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0)
176 return false;
177
178 /* If both are NULL, the end length compares equal, because we
179 are looking at the same variable. This can only happen for
180 assumed- or deferred-length character arguments. */
181
182 if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
183 break;
184
185 if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
186 return false;
187
188 break;
189
190 default:
191 gfc_internal_error ("are_identical_variables: Bad type");
192 }
193 r1 = r1->next;
194 r2 = r2->next;
195 }
196 return true;
197 }
198
199 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
200 impure_ok is false, only return 0 for pure functions. */
201
202 int
203 gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
204 {
205
206 gfc_actual_arglist *args1;
207 gfc_actual_arglist *args2;
208
209 if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
210 return -2;
211
212 if ((e1->value.function.esym && e2->value.function.esym
213 && e1->value.function.esym == e2->value.function.esym
214 && (e1->value.function.esym->result->attr.pure || impure_ok))
215 || (e1->value.function.isym && e2->value.function.isym
216 && e1->value.function.isym == e2->value.function.isym
217 && (e1->value.function.isym->pure || impure_ok)))
218 {
219 args1 = e1->value.function.actual;
220 args2 = e2->value.function.actual;
221
222 /* Compare the argument lists for equality. */
223 while (args1 && args2)
224 {
225 /* Bitwise xor, since C has no non-bitwise xor operator. */
226 if ((args1->expr == NULL) ^ (args2->expr == NULL))
227 return -2;
228
229 if (args1->expr != NULL && args2->expr != NULL)
230 {
231 gfc_expr *e1, *e2;
232 e1 = args1->expr;
233 e2 = args2->expr;
234
235 if (gfc_dep_compare_expr (e1, e2) != 0)
236 return -2;
237
238 /* Special case: String arguments which compare equal can have
239 different lengths, which makes them different in calls to
240 procedures. */
241
242 if (e1->expr_type == EXPR_CONSTANT
243 && e1->ts.type == BT_CHARACTER
244 && e2->expr_type == EXPR_CONSTANT
245 && e2->ts.type == BT_CHARACTER
246 && e1->value.character.length != e2->value.character.length)
247 return -2;
248 }
249
250 args1 = args1->next;
251 args2 = args2->next;
252 }
253 return (args1 || args2) ? -2 : 0;
254 }
255 else
256 return -2;
257 }
258
259 /* Helper function to look through parens, unary plus and widening
260 integer conversions. */
261
262 gfc_expr *
263 gfc_discard_nops (gfc_expr *e)
264 {
265 gfc_actual_arglist *arglist;
266
267 if (e == NULL)
268 return NULL;
269
270 while (true)
271 {
272 if (e->expr_type == EXPR_OP
273 && (e->value.op.op == INTRINSIC_UPLUS
274 || e->value.op.op == INTRINSIC_PARENTHESES))
275 {
276 e = e->value.op.op1;
277 continue;
278 }
279
280 if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
281 && e->value.function.isym->id == GFC_ISYM_CONVERSION
282 && e->ts.type == BT_INTEGER)
283 {
284 arglist = e->value.function.actual;
285 if (arglist->expr->ts.type == BT_INTEGER
286 && e->ts.kind > arglist->expr->ts.kind)
287 {
288 e = arglist->expr;
289 continue;
290 }
291 }
292 break;
293 }
294
295 return e;
296 }
297
298
299 /* Compare two expressions. Return values:
300 * +1 if e1 > e2
301 * 0 if e1 == e2
302 * -1 if e1 < e2
303 * -2 if the relationship could not be determined
304 * -3 if e1 /= e2, but we cannot tell which one is larger.
305 REAL and COMPLEX constants are only compared for equality
306 or inequality; if they are unequal, -2 is returned in all cases. */
307
308 int
309 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
310 {
311 int i;
312
313 if (e1 == NULL && e2 == NULL)
314 return 0;
315
316 e1 = gfc_discard_nops (e1);
317 e2 = gfc_discard_nops (e2);
318
319 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
320 {
321 /* Compare X+C vs. X, for INTEGER only. */
322 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
323 && e1->value.op.op2->ts.type == BT_INTEGER
324 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
325 return mpz_sgn (e1->value.op.op2->value.integer);
326
327 /* Compare P+Q vs. R+S. */
328 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
329 {
330 int l, r;
331
332 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
333 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
334 if (l == 0 && r == 0)
335 return 0;
336 if (l == 0 && r > -2)
337 return r;
338 if (l > -2 && r == 0)
339 return l;
340 if (l == 1 && r == 1)
341 return 1;
342 if (l == -1 && r == -1)
343 return -1;
344
345 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
346 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
347 if (l == 0 && r == 0)
348 return 0;
349 if (l == 0 && r > -2)
350 return r;
351 if (l > -2 && r == 0)
352 return l;
353 if (l == 1 && r == 1)
354 return 1;
355 if (l == -1 && r == -1)
356 return -1;
357 }
358 }
359
360 /* Compare X vs. X+C, for INTEGER only. */
361 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
362 {
363 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
364 && e2->value.op.op2->ts.type == BT_INTEGER
365 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
366 return -mpz_sgn (e2->value.op.op2->value.integer);
367 }
368
369 /* Compare X-C vs. X, for INTEGER only. */
370 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
371 {
372 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
373 && e1->value.op.op2->ts.type == BT_INTEGER
374 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
375 return -mpz_sgn (e1->value.op.op2->value.integer);
376
377 /* Compare P-Q vs. R-S. */
378 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
379 {
380 int l, r;
381
382 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
383 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
384 if (l == 0 && r == 0)
385 return 0;
386 if (l > -2 && r == 0)
387 return l;
388 if (l == 0 && r > -2)
389 return -r;
390 if (l == 1 && r == -1)
391 return 1;
392 if (l == -1 && r == 1)
393 return -1;
394 }
395 }
396
397 /* Compare A // B vs. C // D. */
398
399 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
400 && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
401 {
402 int l, r;
403
404 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
405 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
406
407 if (l != 0)
408 return l;
409
410 /* Left expressions of // compare equal, but
411 watch out for 'A ' // x vs. 'A' // x. */
412 gfc_expr *e1_left = e1->value.op.op1;
413 gfc_expr *e2_left = e2->value.op.op1;
414
415 if (e1_left->expr_type == EXPR_CONSTANT
416 && e2_left->expr_type == EXPR_CONSTANT
417 && e1_left->value.character.length
418 != e2_left->value.character.length)
419 return -2;
420 else
421 return r;
422 }
423
424 /* Compare X vs. X-C, for INTEGER only. */
425 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
426 {
427 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
428 && e2->value.op.op2->ts.type == BT_INTEGER
429 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
430 return mpz_sgn (e2->value.op.op2->value.integer);
431 }
432
433 if (e1->expr_type != e2->expr_type)
434 return -3;
435
436 switch (e1->expr_type)
437 {
438 case EXPR_CONSTANT:
439 /* Compare strings for equality. */
440 if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
441 return gfc_compare_string (e1, e2);
442
443 /* Compare REAL and COMPLEX constants. Because of the
444 traps and pitfalls associated with comparing
445 a + 1.0 with a + 0.5, check for equality only. */
446 if (e2->expr_type == EXPR_CONSTANT)
447 {
448 if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
449 {
450 if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
451 return 0;
452 else
453 return -2;
454 }
455 else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
456 {
457 if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
458 return 0;
459 else
460 return -2;
461 }
462 }
463
464 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
465 return -2;
466
467 /* For INTEGER, all cases where e2 is not constant should have
468 been filtered out above. */
469 gcc_assert (e2->expr_type == EXPR_CONSTANT);
470
471 i = mpz_cmp (e1->value.integer, e2->value.integer);
472 if (i == 0)
473 return 0;
474 else if (i < 0)
475 return -1;
476 return 1;
477
478 case EXPR_VARIABLE:
479 if (are_identical_variables (e1, e2))
480 return 0;
481 else
482 return -3;
483
484 case EXPR_OP:
485 /* Intrinsic operators are the same if their operands are the same. */
486 if (e1->value.op.op != e2->value.op.op)
487 return -2;
488 if (e1->value.op.op2 == 0)
489 {
490 i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
491 return i == 0 ? 0 : -2;
492 }
493 if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
494 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
495 return 0;
496 else if (e1->value.op.op == INTRINSIC_TIMES
497 && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
498 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
499 /* Commutativity of multiplication; addition is handled above. */
500 return 0;
501
502 return -2;
503
504 case EXPR_FUNCTION:
505 return gfc_dep_compare_functions (e1, e2, false);
506
507 default:
508 return -2;
509 }
510 }
511
512
513 /* Return the difference between two expressions. Integer expressions of
514 the form
515
516 X + constant, X - constant and constant + X
517
518 are handled. Return true on success, false on failure. result is assumed
519 to be uninitialized on entry, and will be initialized on success.
520 */
521
522 bool
523 gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
524 {
525 gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
526
527 if (e1 == NULL || e2 == NULL)
528 return false;
529
530 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
531 return false;
532
533 e1 = gfc_discard_nops (e1);
534 e2 = gfc_discard_nops (e2);
535
536 /* Inizialize tentatively, clear if we don't return anything. */
537 mpz_init (*result);
538
539 /* Case 1: c1 - c2 = c1 - c2, trivially. */
540
541 if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
542 {
543 mpz_sub (*result, e1->value.integer, e2->value.integer);
544 return true;
545 }
546
547 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
548 {
549 e1_op1 = gfc_discard_nops (e1->value.op.op1);
550 e1_op2 = gfc_discard_nops (e1->value.op.op2);
551
552 /* Case 2: (X + c1) - X = c1. */
553 if (e1_op2->expr_type == EXPR_CONSTANT
554 && gfc_dep_compare_expr (e1_op1, e2) == 0)
555 {
556 mpz_set (*result, e1_op2->value.integer);
557 return true;
558 }
559
560 /* Case 3: (c1 + X) - X = c1. */
561 if (e1_op1->expr_type == EXPR_CONSTANT
562 && gfc_dep_compare_expr (e1_op2, e2) == 0)
563 {
564 mpz_set (*result, e1_op1->value.integer);
565 return true;
566 }
567
568 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
569 {
570 e2_op1 = gfc_discard_nops (e2->value.op.op1);
571 e2_op2 = gfc_discard_nops (e2->value.op.op2);
572
573 if (e1_op2->expr_type == EXPR_CONSTANT)
574 {
575 /* Case 4: X + c1 - (X + c2) = c1 - c2. */
576 if (e2_op2->expr_type == EXPR_CONSTANT
577 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
578 {
579 mpz_sub (*result, e1_op2->value.integer,
580 e2_op2->value.integer);
581 return true;
582 }
583 /* Case 5: X + c1 - (c2 + X) = c1 - c2. */
584 if (e2_op1->expr_type == EXPR_CONSTANT
585 && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
586 {
587 mpz_sub (*result, e1_op2->value.integer,
588 e2_op1->value.integer);
589 return true;
590 }
591 }
592 else if (e1_op1->expr_type == EXPR_CONSTANT)
593 {
594 /* Case 6: c1 + X - (X + c2) = c1 - c2. */
595 if (e2_op2->expr_type == EXPR_CONSTANT
596 && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
597 {
598 mpz_sub (*result, e1_op1->value.integer,
599 e2_op2->value.integer);
600 return true;
601 }
602 /* Case 7: c1 + X - (c2 + X) = c1 - c2. */
603 if (e2_op1->expr_type == EXPR_CONSTANT
604 && gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
605 {
606 mpz_sub (*result, e1_op1->value.integer,
607 e2_op1->value.integer);
608 return true;
609 }
610 }
611 }
612
613 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
614 {
615 e2_op1 = gfc_discard_nops (e2->value.op.op1);
616 e2_op2 = gfc_discard_nops (e2->value.op.op2);
617
618 if (e1_op2->expr_type == EXPR_CONSTANT)
619 {
620 /* Case 8: X + c1 - (X - c2) = c1 + c2. */
621 if (e2_op2->expr_type == EXPR_CONSTANT
622 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
623 {
624 mpz_add (*result, e1_op2->value.integer,
625 e2_op2->value.integer);
626 return true;
627 }
628 }
629 if (e1_op1->expr_type == EXPR_CONSTANT)
630 {
631 /* Case 9: c1 + X - (X - c2) = c1 + c2. */
632 if (e2_op2->expr_type == EXPR_CONSTANT
633 && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
634 {
635 mpz_add (*result, e1_op1->value.integer,
636 e2_op2->value.integer);
637 return true;
638 }
639 }
640 }
641 }
642
643 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
644 {
645 e1_op1 = gfc_discard_nops (e1->value.op.op1);
646 e1_op2 = gfc_discard_nops (e1->value.op.op2);
647
648 if (e1_op2->expr_type == EXPR_CONSTANT)
649 {
650 /* Case 10: (X - c1) - X = -c1 */
651
652 if (gfc_dep_compare_expr (e1_op1, e2) == 0)
653 {
654 mpz_neg (*result, e1_op2->value.integer);
655 return true;
656 }
657
658 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
659 {
660 e2_op1 = gfc_discard_nops (e2->value.op.op1);
661 e2_op2 = gfc_discard_nops (e2->value.op.op2);
662
663 /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
664 if (e2_op2->expr_type == EXPR_CONSTANT
665 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
666 {
667 mpz_add (*result, e1_op2->value.integer,
668 e2_op2->value.integer);
669 mpz_neg (*result, *result);
670 return true;
671 }
672
673 /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */
674 if (e2_op1->expr_type == EXPR_CONSTANT
675 && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
676 {
677 mpz_add (*result, e1_op2->value.integer,
678 e2_op1->value.integer);
679 mpz_neg (*result, *result);
680 return true;
681 }
682 }
683
684 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
685 {
686 e2_op1 = gfc_discard_nops (e2->value.op.op1);
687 e2_op2 = gfc_discard_nops (e2->value.op.op2);
688
689 /* Case 13: (X - c1) - (X - c2) = c2 - c1. */
690 if (e2_op2->expr_type == EXPR_CONSTANT
691 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
692 {
693 mpz_sub (*result, e2_op2->value.integer,
694 e1_op2->value.integer);
695 return true;
696 }
697 }
698 }
699 if (e1_op1->expr_type == EXPR_CONSTANT)
700 {
701 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
702 {
703 e2_op1 = gfc_discard_nops (e2->value.op.op1);
704 e2_op2 = gfc_discard_nops (e2->value.op.op2);
705
706 /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
707 if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
708 {
709 mpz_sub (*result, e1_op1->value.integer,
710 e2_op1->value.integer);
711 return true;
712 }
713 }
714
715 }
716 }
717
718 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
719 {
720 e2_op1 = gfc_discard_nops (e2->value.op.op1);
721 e2_op2 = gfc_discard_nops (e2->value.op.op2);
722
723 /* Case 15: X - (X + c2) = -c2. */
724 if (e2_op2->expr_type == EXPR_CONSTANT
725 && gfc_dep_compare_expr (e1, e2_op1) == 0)
726 {
727 mpz_neg (*result, e2_op2->value.integer);
728 return true;
729 }
730 /* Case 16: X - (c2 + X) = -c2. */
731 if (e2_op1->expr_type == EXPR_CONSTANT
732 && gfc_dep_compare_expr (e1, e2_op2) == 0)
733 {
734 mpz_neg (*result, e2_op1->value.integer);
735 return true;
736 }
737 }
738
739 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
740 {
741 e2_op1 = gfc_discard_nops (e2->value.op.op1);
742 e2_op2 = gfc_discard_nops (e2->value.op.op2);
743
744 /* Case 17: X - (X - c2) = c2. */
745 if (e2_op2->expr_type == EXPR_CONSTANT
746 && gfc_dep_compare_expr (e1, e2_op1) == 0)
747 {
748 mpz_set (*result, e2_op2->value.integer);
749 return true;
750 }
751 }
752
753 if (gfc_dep_compare_expr (e1, e2) == 0)
754 {
755 /* Case 18: X - X = 0. */
756 mpz_set_si (*result, 0);
757 return true;
758 }
759
760 mpz_clear (*result);
761 return false;
762 }
763
764 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
765 results are indeterminate). 'n' is the dimension to compare. */
766
767 static int
768 is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
769 {
770 gfc_expr *e1;
771 gfc_expr *e2;
772 int i;
773
774 /* TODO: More sophisticated range comparison. */
775 gcc_assert (ar1 && ar2);
776
777 gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
778
779 e1 = ar1->stride[n];
780 e2 = ar2->stride[n];
781 /* Check for mismatching strides. A NULL stride means a stride of 1. */
782 if (e1 && !e2)
783 {
784 i = gfc_expr_is_one (e1, -1);
785 if (i == -1 || i == 0)
786 return 0;
787 }
788 else if (e2 && !e1)
789 {
790 i = gfc_expr_is_one (e2, -1);
791 if (i == -1 || i == 0)
792 return 0;
793 }
794 else if (e1 && e2)
795 {
796 i = gfc_dep_compare_expr (e1, e2);
797 if (i != 0)
798 return 0;
799 }
800 /* The strides match. */
801
802 /* Check the range start. */
803 e1 = ar1->start[n];
804 e2 = ar2->start[n];
805 if (e1 || e2)
806 {
807 /* Use the bound of the array if no bound is specified. */
808 if (ar1->as && !e1)
809 e1 = ar1->as->lower[n];
810
811 if (ar2->as && !e2)
812 e2 = ar2->as->lower[n];
813
814 /* Check we have values for both. */
815 if (!(e1 && e2))
816 return 0;
817
818 i = gfc_dep_compare_expr (e1, e2);
819 if (i != 0)
820 return 0;
821 }
822
823 /* Check the range end. */
824 e1 = ar1->end[n];
825 e2 = ar2->end[n];
826 if (e1 || e2)
827 {
828 /* Use the bound of the array if no bound is specified. */
829 if (ar1->as && !e1)
830 e1 = ar1->as->upper[n];
831
832 if (ar2->as && !e2)
833 e2 = ar2->as->upper[n];
834
835 /* Check we have values for both. */
836 if (!(e1 && e2))
837 return 0;
838
839 i = gfc_dep_compare_expr (e1, e2);
840 if (i != 0)
841 return 0;
842 }
843
844 return 1;
845 }
846
847
848 /* Some array-returning intrinsics can be implemented by reusing the
849 data from one of the array arguments. For example, TRANSPOSE does
850 not necessarily need to allocate new data: it can be implemented
851 by copying the original array's descriptor and simply swapping the
852 two dimension specifications.
853
854 If EXPR is a call to such an intrinsic, return the argument
855 whose data can be reused, otherwise return NULL. */
856
857 gfc_expr *
858 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
859 {
860 if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
861 return NULL;
862
863 switch (expr->value.function.isym->id)
864 {
865 case GFC_ISYM_TRANSPOSE:
866 return expr->value.function.actual->expr;
867
868 default:
869 return NULL;
870 }
871 }
872
873
874 /* Return true if the result of reference REF can only be constructed
875 using a temporary array. */
876
877 bool
878 gfc_ref_needs_temporary_p (gfc_ref *ref)
879 {
880 int n;
881 bool subarray_p;
882
883 subarray_p = false;
884 for (; ref; ref = ref->next)
885 switch (ref->type)
886 {
887 case REF_ARRAY:
888 /* Vector dimensions are generally not monotonic and must be
889 handled using a temporary. */
890 if (ref->u.ar.type == AR_SECTION)
891 for (n = 0; n < ref->u.ar.dimen; n++)
892 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
893 return true;
894
895 subarray_p = true;
896 break;
897
898 case REF_SUBSTRING:
899 /* Within an array reference, character substrings generally
900 need a temporary. Character array strides are expressed as
901 multiples of the element size (consistent with other array
902 types), not in characters. */
903 return subarray_p;
904
905 case REF_COMPONENT:
906 break;
907 }
908
909 return false;
910 }
911
912
913 static int
914 gfc_is_data_pointer (gfc_expr *e)
915 {
916 gfc_ref *ref;
917
918 if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
919 return 0;
920
921 /* No subreference if it is a function */
922 gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
923
924 if (e->symtree->n.sym->attr.pointer)
925 return 1;
926
927 for (ref = e->ref; ref; ref = ref->next)
928 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
929 return 1;
930
931 return 0;
932 }
933
934
935 /* Return true if array variable VAR could be passed to the same function
936 as argument EXPR without interfering with EXPR. INTENT is the intent
937 of VAR.
938
939 This is considerably less conservative than other dependencies
940 because many function arguments will already be copied into a
941 temporary. */
942
943 static int
944 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
945 gfc_expr *expr, gfc_dep_check elemental)
946 {
947 gfc_expr *arg;
948
949 gcc_assert (var->expr_type == EXPR_VARIABLE);
950 gcc_assert (var->rank > 0);
951
952 switch (expr->expr_type)
953 {
954 case EXPR_VARIABLE:
955 /* In case of elemental subroutines, there is no dependency
956 between two same-range array references. */
957 if (gfc_ref_needs_temporary_p (expr->ref)
958 || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
959 {
960 if (elemental == ELEM_DONT_CHECK_VARIABLE)
961 {
962 /* Too many false positive with pointers. */
963 if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
964 {
965 /* Elemental procedures forbid unspecified intents,
966 and we don't check dependencies for INTENT_IN args. */
967 gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
968
969 /* We are told not to check dependencies.
970 We do it, however, and issue a warning in case we find one.
971 If a dependency is found in the case
972 elemental == ELEM_CHECK_VARIABLE, we will generate
973 a temporary, so we don't need to bother the user. */
974 gfc_warning (0, "INTENT(%s) actual argument at %L might "
975 "interfere with actual argument at %L.",
976 intent == INTENT_OUT ? "OUT" : "INOUT",
977 &var->where, &expr->where);
978 }
979 return 0;
980 }
981 else
982 return 1;
983 }
984 return 0;
985
986 case EXPR_ARRAY:
987 /* the scalarizer always generates a temporary for array constructors,
988 so there is no dependency. */
989 return 0;
990
991 case EXPR_FUNCTION:
992 if (intent != INTENT_IN)
993 {
994 arg = gfc_get_noncopying_intrinsic_argument (expr);
995 if (arg != NULL)
996 return gfc_check_argument_var_dependency (var, intent, arg,
997 NOT_ELEMENTAL);
998 }
999
1000 if (elemental != NOT_ELEMENTAL)
1001 {
1002 if ((expr->value.function.esym
1003 && expr->value.function.esym->attr.elemental)
1004 || (expr->value.function.isym
1005 && expr->value.function.isym->elemental))
1006 return gfc_check_fncall_dependency (var, intent, NULL,
1007 expr->value.function.actual,
1008 ELEM_CHECK_VARIABLE);
1009
1010 if (gfc_inline_intrinsic_function_p (expr))
1011 {
1012 /* The TRANSPOSE case should have been caught in the
1013 noncopying intrinsic case above. */
1014 gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
1015
1016 return gfc_check_fncall_dependency (var, intent, NULL,
1017 expr->value.function.actual,
1018 ELEM_CHECK_VARIABLE);
1019 }
1020 }
1021 return 0;
1022
1023 case EXPR_OP:
1024 /* In case of non-elemental procedures, there is no need to catch
1025 dependencies, as we will make a temporary anyway. */
1026 if (elemental)
1027 {
1028 /* If the actual arg EXPR is an expression, we need to catch
1029 a dependency between variables in EXPR and VAR,
1030 an intent((IN)OUT) variable. */
1031 if (expr->value.op.op1
1032 && gfc_check_argument_var_dependency (var, intent,
1033 expr->value.op.op1,
1034 ELEM_CHECK_VARIABLE))
1035 return 1;
1036 else if (expr->value.op.op2
1037 && gfc_check_argument_var_dependency (var, intent,
1038 expr->value.op.op2,
1039 ELEM_CHECK_VARIABLE))
1040 return 1;
1041 }
1042 return 0;
1043
1044 default:
1045 return 0;
1046 }
1047 }
1048
1049
1050 /* Like gfc_check_argument_var_dependency, but extended to any
1051 array expression OTHER, not just variables. */
1052
1053 static int
1054 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
1055 gfc_expr *expr, gfc_dep_check elemental)
1056 {
1057 switch (other->expr_type)
1058 {
1059 case EXPR_VARIABLE:
1060 return gfc_check_argument_var_dependency (other, intent, expr, elemental);
1061
1062 case EXPR_FUNCTION:
1063 other = gfc_get_noncopying_intrinsic_argument (other);
1064 if (other != NULL)
1065 return gfc_check_argument_dependency (other, INTENT_IN, expr,
1066 NOT_ELEMENTAL);
1067
1068 return 0;
1069
1070 default:
1071 return 0;
1072 }
1073 }
1074
1075
1076 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
1077 FNSYM is the function being called, or NULL if not known. */
1078
1079 int
1080 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
1081 gfc_symbol *fnsym, gfc_actual_arglist *actual,
1082 gfc_dep_check elemental)
1083 {
1084 gfc_formal_arglist *formal;
1085 gfc_expr *expr;
1086
1087 formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
1088 for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
1089 {
1090 expr = actual->expr;
1091
1092 /* Skip args which are not present. */
1093 if (!expr)
1094 continue;
1095
1096 /* Skip other itself. */
1097 if (expr == other)
1098 continue;
1099
1100 /* Skip intent(in) arguments if OTHER itself is intent(in). */
1101 if (formal && intent == INTENT_IN
1102 && formal->sym->attr.intent == INTENT_IN)
1103 continue;
1104
1105 if (gfc_check_argument_dependency (other, intent, expr, elemental))
1106 return 1;
1107 }
1108
1109 return 0;
1110 }
1111
1112
1113 /* Return 1 if e1 and e2 are equivalenced arrays, either
1114 directly or indirectly; i.e., equivalence (a,b) for a and b
1115 or equivalence (a,c),(b,c). This function uses the equiv_
1116 lists, generated in trans-common(add_equivalences), that are
1117 guaranteed to pick up indirect equivalences. We explicitly
1118 check for overlap using the offset and length of the equivalence.
1119 This function is symmetric.
1120 TODO: This function only checks whether the full top-level
1121 symbols overlap. An improved implementation could inspect
1122 e1->ref and e2->ref to determine whether the actually accessed
1123 portions of these variables/arrays potentially overlap. */
1124
1125 int
1126 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
1127 {
1128 gfc_equiv_list *l;
1129 gfc_equiv_info *s, *fl1, *fl2;
1130
1131 gcc_assert (e1->expr_type == EXPR_VARIABLE
1132 && e2->expr_type == EXPR_VARIABLE);
1133
1134 if (!e1->symtree->n.sym->attr.in_equivalence
1135 || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
1136 return 0;
1137
1138 if (e1->symtree->n.sym->ns
1139 && e1->symtree->n.sym->ns != gfc_current_ns)
1140 l = e1->symtree->n.sym->ns->equiv_lists;
1141 else
1142 l = gfc_current_ns->equiv_lists;
1143
1144 /* Go through the equiv_lists and return 1 if the variables
1145 e1 and e2 are members of the same group and satisfy the
1146 requirement on their relative offsets. */
1147 for (; l; l = l->next)
1148 {
1149 fl1 = NULL;
1150 fl2 = NULL;
1151 for (s = l->equiv; s; s = s->next)
1152 {
1153 if (s->sym == e1->symtree->n.sym)
1154 {
1155 fl1 = s;
1156 if (fl2)
1157 break;
1158 }
1159 if (s->sym == e2->symtree->n.sym)
1160 {
1161 fl2 = s;
1162 if (fl1)
1163 break;
1164 }
1165 }
1166
1167 if (s)
1168 {
1169 /* Can these lengths be zero? */
1170 if (fl1->length <= 0 || fl2->length <= 0)
1171 return 1;
1172 /* These can't overlap if [f11,fl1+length] is before
1173 [fl2,fl2+length], or [fl2,fl2+length] is before
1174 [fl1,fl1+length], otherwise they do overlap. */
1175 if (fl1->offset + fl1->length > fl2->offset
1176 && fl2->offset + fl2->length > fl1->offset)
1177 return 1;
1178 }
1179 }
1180 return 0;
1181 }
1182
1183
1184 /* Return true if there is no possibility of aliasing because of a type
1185 mismatch between all the possible pointer references and the
1186 potential target. Note that this function is asymmetric in the
1187 arguments and so must be called twice with the arguments exchanged. */
1188
1189 static bool
1190 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
1191 {
1192 gfc_component *cm1;
1193 gfc_symbol *sym1;
1194 gfc_symbol *sym2;
1195 gfc_ref *ref1;
1196 bool seen_component_ref;
1197
1198 if (expr1->expr_type != EXPR_VARIABLE
1199 || expr2->expr_type != EXPR_VARIABLE)
1200 return false;
1201
1202 sym1 = expr1->symtree->n.sym;
1203 sym2 = expr2->symtree->n.sym;
1204
1205 /* Keep it simple for now. */
1206 if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
1207 return false;
1208
1209 if (sym1->attr.pointer)
1210 {
1211 if (gfc_compare_types (&sym1->ts, &sym2->ts))
1212 return false;
1213 }
1214
1215 /* This is a conservative check on the components of the derived type
1216 if no component references have been seen. Since we will not dig
1217 into the components of derived type components, we play it safe by
1218 returning false. First we check the reference chain and then, if
1219 no component references have been seen, the components. */
1220 seen_component_ref = false;
1221 if (sym1->ts.type == BT_DERIVED)
1222 {
1223 for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
1224 {
1225 if (ref1->type != REF_COMPONENT)
1226 continue;
1227
1228 if (ref1->u.c.component->ts.type == BT_DERIVED)
1229 return false;
1230
1231 if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
1232 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
1233 return false;
1234
1235 seen_component_ref = true;
1236 }
1237 }
1238
1239 if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
1240 {
1241 for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
1242 {
1243 if (cm1->ts.type == BT_DERIVED)
1244 return false;
1245
1246 if ((sym2->attr.pointer || cm1->attr.pointer)
1247 && gfc_compare_types (&cm1->ts, &sym2->ts))
1248 return false;
1249 }
1250 }
1251
1252 return true;
1253 }
1254
1255
1256 /* Return true if the statement body redefines the condition. Returns
1257 true if expr2 depends on expr1. expr1 should be a single term
1258 suitable for the lhs of an assignment. The IDENTICAL flag indicates
1259 whether array references to the same symbol with identical range
1260 references count as a dependency or not. Used for forall and where
1261 statements. Also used with functions returning arrays without a
1262 temporary. */
1263
1264 int
1265 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1266 {
1267 gfc_actual_arglist *actual;
1268 gfc_constructor *c;
1269 int n;
1270
1271 /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION
1272 and a reference to _F.caf_get, so skip the assert. */
1273 if (expr1->expr_type == EXPR_FUNCTION
1274 && strcmp (expr1->value.function.name, "_F.caf_get") == 0)
1275 return 0;
1276
1277 if (expr1->expr_type != EXPR_VARIABLE)
1278 gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
1279
1280 switch (expr2->expr_type)
1281 {
1282 case EXPR_OP:
1283 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1284 if (n)
1285 return n;
1286 if (expr2->value.op.op2)
1287 return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1288 return 0;
1289
1290 case EXPR_VARIABLE:
1291 /* The interesting cases are when the symbols don't match. */
1292 if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1293 {
1294 symbol_attribute attr1, attr2;
1295 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1296 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1297
1298 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1299 if (gfc_are_equivalenced_arrays (expr1, expr2))
1300 return 1;
1301
1302 /* Symbols can only alias if they have the same type. */
1303 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1304 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1305 {
1306 if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1307 return 0;
1308 }
1309
1310 /* We have to also include target-target as ptr%comp is not a
1311 pointer but it still alias with "dt%comp" for "ptr => dt". As
1312 subcomponents and array access to pointers retains the target
1313 attribute, that's sufficient. */
1314 attr1 = gfc_expr_attr (expr1);
1315 attr2 = gfc_expr_attr (expr2);
1316 if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target))
1317 {
1318 if (check_data_pointer_types (expr1, expr2)
1319 && check_data_pointer_types (expr2, expr1))
1320 return 0;
1321
1322 return 1;
1323 }
1324 else
1325 {
1326 gfc_symbol *sym1 = expr1->symtree->n.sym;
1327 gfc_symbol *sym2 = expr2->symtree->n.sym;
1328 if (sym1->attr.target && sym2->attr.target
1329 && ((sym1->attr.dummy && !sym1->attr.contiguous
1330 && (!sym1->attr.dimension
1331 || sym2->as->type == AS_ASSUMED_SHAPE))
1332 || (sym2->attr.dummy && !sym2->attr.contiguous
1333 && (!sym2->attr.dimension
1334 || sym2->as->type == AS_ASSUMED_SHAPE))))
1335 return 1;
1336 }
1337
1338 /* Otherwise distinct symbols have no dependencies. */
1339 return 0;
1340 }
1341
1342 if (identical)
1343 return 1;
1344
1345 /* Identical and disjoint ranges return 0,
1346 overlapping ranges return 1. */
1347 if (expr1->ref && expr2->ref)
1348 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
1349
1350 return 1;
1351
1352 case EXPR_FUNCTION:
1353 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1354 identical = 1;
1355
1356 /* Remember possible differences between elemental and
1357 transformational functions. All functions inside a FORALL
1358 will be pure. */
1359 for (actual = expr2->value.function.actual;
1360 actual; actual = actual->next)
1361 {
1362 if (!actual->expr)
1363 continue;
1364 n = gfc_check_dependency (expr1, actual->expr, identical);
1365 if (n)
1366 return n;
1367 }
1368 return 0;
1369
1370 case EXPR_CONSTANT:
1371 case EXPR_NULL:
1372 return 0;
1373
1374 case EXPR_ARRAY:
1375 /* Loop through the array constructor's elements. */
1376 for (c = gfc_constructor_first (expr2->value.constructor);
1377 c; c = gfc_constructor_next (c))
1378 {
1379 /* If this is an iterator, assume the worst. */
1380 if (c->iterator)
1381 return 1;
1382 /* Avoid recursion in the common case. */
1383 if (c->expr->expr_type == EXPR_CONSTANT)
1384 continue;
1385 if (gfc_check_dependency (expr1, c->expr, 1))
1386 return 1;
1387 }
1388 return 0;
1389
1390 default:
1391 return 1;
1392 }
1393 }
1394
1395
1396 /* Determines overlapping for two array sections. */
1397
1398 static gfc_dependency
1399 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1400 {
1401 gfc_expr *l_start;
1402 gfc_expr *l_end;
1403 gfc_expr *l_stride;
1404 gfc_expr *l_lower;
1405 gfc_expr *l_upper;
1406 int l_dir;
1407
1408 gfc_expr *r_start;
1409 gfc_expr *r_end;
1410 gfc_expr *r_stride;
1411 gfc_expr *r_lower;
1412 gfc_expr *r_upper;
1413 gfc_expr *one_expr;
1414 int r_dir;
1415 int stride_comparison;
1416 int start_comparison;
1417 mpz_t tmp;
1418
1419 /* If they are the same range, return without more ado. */
1420 if (is_same_range (l_ar, r_ar, n))
1421 return GFC_DEP_EQUAL;
1422
1423 l_start = l_ar->start[n];
1424 l_end = l_ar->end[n];
1425 l_stride = l_ar->stride[n];
1426
1427 r_start = r_ar->start[n];
1428 r_end = r_ar->end[n];
1429 r_stride = r_ar->stride[n];
1430
1431 /* If l_start is NULL take it from array specifier. */
1432 if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1433 l_start = l_ar->as->lower[n];
1434 /* If l_end is NULL take it from array specifier. */
1435 if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as))
1436 l_end = l_ar->as->upper[n];
1437
1438 /* If r_start is NULL take it from array specifier. */
1439 if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as))
1440 r_start = r_ar->as->lower[n];
1441 /* If r_end is NULL take it from array specifier. */
1442 if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
1443 r_end = r_ar->as->upper[n];
1444
1445 /* Determine whether the l_stride is positive or negative. */
1446 if (!l_stride)
1447 l_dir = 1;
1448 else if (l_stride->expr_type == EXPR_CONSTANT
1449 && l_stride->ts.type == BT_INTEGER)
1450 l_dir = mpz_sgn (l_stride->value.integer);
1451 else if (l_start && l_end)
1452 l_dir = gfc_dep_compare_expr (l_end, l_start);
1453 else
1454 l_dir = -2;
1455
1456 /* Determine whether the r_stride is positive or negative. */
1457 if (!r_stride)
1458 r_dir = 1;
1459 else if (r_stride->expr_type == EXPR_CONSTANT
1460 && r_stride->ts.type == BT_INTEGER)
1461 r_dir = mpz_sgn (r_stride->value.integer);
1462 else if (r_start && r_end)
1463 r_dir = gfc_dep_compare_expr (r_end, r_start);
1464 else
1465 r_dir = -2;
1466
1467 /* The strides should never be zero. */
1468 if (l_dir == 0 || r_dir == 0)
1469 return GFC_DEP_OVERLAP;
1470
1471 /* Determine the relationship between the strides. Set stride_comparison to
1472 -2 if the dependency cannot be determined
1473 -1 if l_stride < r_stride
1474 0 if l_stride == r_stride
1475 1 if l_stride > r_stride
1476 as determined by gfc_dep_compare_expr. */
1477
1478 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1479
1480 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1481 r_stride ? r_stride : one_expr);
1482
1483 if (l_start && r_start)
1484 start_comparison = gfc_dep_compare_expr (l_start, r_start);
1485 else
1486 start_comparison = -2;
1487
1488 gfc_free_expr (one_expr);
1489
1490 /* Determine LHS upper and lower bounds. */
1491 if (l_dir == 1)
1492 {
1493 l_lower = l_start;
1494 l_upper = l_end;
1495 }
1496 else if (l_dir == -1)
1497 {
1498 l_lower = l_end;
1499 l_upper = l_start;
1500 }
1501 else
1502 {
1503 l_lower = NULL;
1504 l_upper = NULL;
1505 }
1506
1507 /* Determine RHS upper and lower bounds. */
1508 if (r_dir == 1)
1509 {
1510 r_lower = r_start;
1511 r_upper = r_end;
1512 }
1513 else if (r_dir == -1)
1514 {
1515 r_lower = r_end;
1516 r_upper = r_start;
1517 }
1518 else
1519 {
1520 r_lower = NULL;
1521 r_upper = NULL;
1522 }
1523
1524 /* Check whether the ranges are disjoint. */
1525 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1526 return GFC_DEP_NODEP;
1527 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1528 return GFC_DEP_NODEP;
1529
1530 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1531 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1532 {
1533 if (l_dir == 1 && r_dir == -1)
1534 return GFC_DEP_EQUAL;
1535 if (l_dir == -1 && r_dir == 1)
1536 return GFC_DEP_EQUAL;
1537 }
1538
1539 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1540 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1541 {
1542 if (l_dir == 1 && r_dir == -1)
1543 return GFC_DEP_EQUAL;
1544 if (l_dir == -1 && r_dir == 1)
1545 return GFC_DEP_EQUAL;
1546 }
1547
1548 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1549 There is no dependency if the remainder of
1550 (l_start - r_start) / gcd(l_stride, r_stride) is
1551 nonzero.
1552 TODO:
1553 - Cases like a(1:4:2) = a(2:3) are still not handled.
1554 */
1555
1556 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1557 && (a)->ts.type == BT_INTEGER)
1558
1559 if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
1560 && gfc_dep_difference (l_start, r_start, &tmp))
1561 {
1562 mpz_t gcd;
1563 int result;
1564
1565 mpz_init (gcd);
1566 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1567
1568 mpz_fdiv_r (tmp, tmp, gcd);
1569 result = mpz_cmp_si (tmp, 0L);
1570
1571 mpz_clear (gcd);
1572 mpz_clear (tmp);
1573
1574 if (result != 0)
1575 return GFC_DEP_NODEP;
1576 }
1577
1578 #undef IS_CONSTANT_INTEGER
1579
1580 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1581
1582 if (l_dir == 1 && r_dir == 1 &&
1583 (start_comparison == 0 || start_comparison == -1)
1584 && (stride_comparison == 0 || stride_comparison == -1))
1585 return GFC_DEP_FORWARD;
1586
1587 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1588 x:y:-1 vs. x:y:-2. */
1589 if (l_dir == -1 && r_dir == -1 &&
1590 (start_comparison == 0 || start_comparison == 1)
1591 && (stride_comparison == 0 || stride_comparison == 1))
1592 return GFC_DEP_FORWARD;
1593
1594 if (stride_comparison == 0 || stride_comparison == -1)
1595 {
1596 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1597 {
1598
1599 /* Check for a(low:y:s) vs. a(z:x:s) or
1600 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1601 of low, which is always at least a forward dependence. */
1602
1603 if (r_dir == 1
1604 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1605 return GFC_DEP_FORWARD;
1606 }
1607 }
1608
1609 if (stride_comparison == 0 || stride_comparison == 1)
1610 {
1611 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1612 {
1613
1614 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1615 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1616 of high, which is always at least a forward dependence. */
1617
1618 if (r_dir == -1
1619 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1620 return GFC_DEP_FORWARD;
1621 }
1622 }
1623
1624
1625 if (stride_comparison == 0)
1626 {
1627 /* From here, check for backwards dependencies. */
1628 /* x+1:y vs. x:z. */
1629 if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1630 return GFC_DEP_BACKWARD;
1631
1632 /* x-1:y:-1 vs. x:z:-1. */
1633 if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1634 return GFC_DEP_BACKWARD;
1635 }
1636
1637 return GFC_DEP_OVERLAP;
1638 }
1639
1640
1641 /* Determines overlapping for a single element and a section. */
1642
1643 static gfc_dependency
1644 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1645 {
1646 gfc_array_ref *ref;
1647 gfc_expr *elem;
1648 gfc_expr *start;
1649 gfc_expr *end;
1650 gfc_expr *stride;
1651 int s;
1652
1653 elem = lref->u.ar.start[n];
1654 if (!elem)
1655 return GFC_DEP_OVERLAP;
1656
1657 ref = &rref->u.ar;
1658 start = ref->start[n] ;
1659 end = ref->end[n] ;
1660 stride = ref->stride[n];
1661
1662 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1663 start = ref->as->lower[n];
1664 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1665 end = ref->as->upper[n];
1666
1667 /* Determine whether the stride is positive or negative. */
1668 if (!stride)
1669 s = 1;
1670 else if (stride->expr_type == EXPR_CONSTANT
1671 && stride->ts.type == BT_INTEGER)
1672 s = mpz_sgn (stride->value.integer);
1673 else
1674 s = -2;
1675
1676 /* Stride should never be zero. */
1677 if (s == 0)
1678 return GFC_DEP_OVERLAP;
1679
1680 /* Positive strides. */
1681 if (s == 1)
1682 {
1683 /* Check for elem < lower. */
1684 if (start && gfc_dep_compare_expr (elem, start) == -1)
1685 return GFC_DEP_NODEP;
1686 /* Check for elem > upper. */
1687 if (end && gfc_dep_compare_expr (elem, end) == 1)
1688 return GFC_DEP_NODEP;
1689
1690 if (start && end)
1691 {
1692 s = gfc_dep_compare_expr (start, end);
1693 /* Check for an empty range. */
1694 if (s == 1)
1695 return GFC_DEP_NODEP;
1696 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1697 return GFC_DEP_EQUAL;
1698 }
1699 }
1700 /* Negative strides. */
1701 else if (s == -1)
1702 {
1703 /* Check for elem > upper. */
1704 if (end && gfc_dep_compare_expr (elem, start) == 1)
1705 return GFC_DEP_NODEP;
1706 /* Check for elem < lower. */
1707 if (start && gfc_dep_compare_expr (elem, end) == -1)
1708 return GFC_DEP_NODEP;
1709
1710 if (start && end)
1711 {
1712 s = gfc_dep_compare_expr (start, end);
1713 /* Check for an empty range. */
1714 if (s == -1)
1715 return GFC_DEP_NODEP;
1716 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1717 return GFC_DEP_EQUAL;
1718 }
1719 }
1720 /* Unknown strides. */
1721 else
1722 {
1723 if (!start || !end)
1724 return GFC_DEP_OVERLAP;
1725 s = gfc_dep_compare_expr (start, end);
1726 if (s <= -2)
1727 return GFC_DEP_OVERLAP;
1728 /* Assume positive stride. */
1729 if (s == -1)
1730 {
1731 /* Check for elem < lower. */
1732 if (gfc_dep_compare_expr (elem, start) == -1)
1733 return GFC_DEP_NODEP;
1734 /* Check for elem > upper. */
1735 if (gfc_dep_compare_expr (elem, end) == 1)
1736 return GFC_DEP_NODEP;
1737 }
1738 /* Assume negative stride. */
1739 else if (s == 1)
1740 {
1741 /* Check for elem > upper. */
1742 if (gfc_dep_compare_expr (elem, start) == 1)
1743 return GFC_DEP_NODEP;
1744 /* Check for elem < lower. */
1745 if (gfc_dep_compare_expr (elem, end) == -1)
1746 return GFC_DEP_NODEP;
1747 }
1748 /* Equal bounds. */
1749 else if (s == 0)
1750 {
1751 s = gfc_dep_compare_expr (elem, start);
1752 if (s == 0)
1753 return GFC_DEP_EQUAL;
1754 if (s == 1 || s == -1)
1755 return GFC_DEP_NODEP;
1756 }
1757 }
1758
1759 return GFC_DEP_OVERLAP;
1760 }
1761
1762
1763 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1764 forall_index attribute. Return true if any variable may be
1765 being used as a FORALL index. Its safe to pessimistically
1766 return true, and assume a dependency. */
1767
1768 static bool
1769 contains_forall_index_p (gfc_expr *expr)
1770 {
1771 gfc_actual_arglist *arg;
1772 gfc_constructor *c;
1773 gfc_ref *ref;
1774 int i;
1775
1776 if (!expr)
1777 return false;
1778
1779 switch (expr->expr_type)
1780 {
1781 case EXPR_VARIABLE:
1782 if (expr->symtree->n.sym->forall_index)
1783 return true;
1784 break;
1785
1786 case EXPR_OP:
1787 if (contains_forall_index_p (expr->value.op.op1)
1788 || contains_forall_index_p (expr->value.op.op2))
1789 return true;
1790 break;
1791
1792 case EXPR_FUNCTION:
1793 for (arg = expr->value.function.actual; arg; arg = arg->next)
1794 if (contains_forall_index_p (arg->expr))
1795 return true;
1796 break;
1797
1798 case EXPR_CONSTANT:
1799 case EXPR_NULL:
1800 case EXPR_SUBSTRING:
1801 break;
1802
1803 case EXPR_STRUCTURE:
1804 case EXPR_ARRAY:
1805 for (c = gfc_constructor_first (expr->value.constructor);
1806 c; gfc_constructor_next (c))
1807 if (contains_forall_index_p (c->expr))
1808 return true;
1809 break;
1810
1811 default:
1812 gcc_unreachable ();
1813 }
1814
1815 for (ref = expr->ref; ref; ref = ref->next)
1816 switch (ref->type)
1817 {
1818 case REF_ARRAY:
1819 for (i = 0; i < ref->u.ar.dimen; i++)
1820 if (contains_forall_index_p (ref->u.ar.start[i])
1821 || contains_forall_index_p (ref->u.ar.end[i])
1822 || contains_forall_index_p (ref->u.ar.stride[i]))
1823 return true;
1824 break;
1825
1826 case REF_COMPONENT:
1827 break;
1828
1829 case REF_SUBSTRING:
1830 if (contains_forall_index_p (ref->u.ss.start)
1831 || contains_forall_index_p (ref->u.ss.end))
1832 return true;
1833 break;
1834
1835 default:
1836 gcc_unreachable ();
1837 }
1838
1839 return false;
1840 }
1841
1842 /* Determines overlapping for two single element array references. */
1843
1844 static gfc_dependency
1845 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1846 {
1847 gfc_array_ref l_ar;
1848 gfc_array_ref r_ar;
1849 gfc_expr *l_start;
1850 gfc_expr *r_start;
1851 int i;
1852
1853 l_ar = lref->u.ar;
1854 r_ar = rref->u.ar;
1855 l_start = l_ar.start[n] ;
1856 r_start = r_ar.start[n] ;
1857 i = gfc_dep_compare_expr (r_start, l_start);
1858 if (i == 0)
1859 return GFC_DEP_EQUAL;
1860
1861 /* Treat two scalar variables as potentially equal. This allows
1862 us to prove that a(i,:) and a(j,:) have no dependency. See
1863 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1864 Proceedings of the International Conference on Parallel and
1865 Distributed Processing Techniques and Applications (PDPTA2001),
1866 Las Vegas, Nevada, June 2001. */
1867 /* However, we need to be careful when either scalar expression
1868 contains a FORALL index, as these can potentially change value
1869 during the scalarization/traversal of this array reference. */
1870 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1871 return GFC_DEP_OVERLAP;
1872
1873 if (i > -2)
1874 return GFC_DEP_NODEP;
1875 return GFC_DEP_EQUAL;
1876 }
1877
1878 /* Callback function for checking if an expression depends on a
1879 dummy variable which is any other than INTENT(IN). */
1880
1881 static int
1882 callback_dummy_intent_not_in (gfc_expr **ep,
1883 int *walk_subtrees ATTRIBUTE_UNUSED,
1884 void *data ATTRIBUTE_UNUSED)
1885 {
1886 gfc_expr *e = *ep;
1887
1888 if (e->expr_type == EXPR_VARIABLE && e->symtree
1889 && e->symtree->n.sym->attr.dummy)
1890 return e->symtree->n.sym->attr.intent != INTENT_IN;
1891 else
1892 return 0;
1893 }
1894
1895 /* Auxiliary function to check if subexpressions have dummy variables which
1896 are not intent(in).
1897 */
1898
1899 static bool
1900 dummy_intent_not_in (gfc_expr **ep)
1901 {
1902 return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL);
1903 }
1904
1905 /* Determine if an array ref, usually an array section specifies the
1906 entire array. In addition, if the second, pointer argument is
1907 provided, the function will return true if the reference is
1908 contiguous; eg. (:, 1) gives true but (1,:) gives false.
1909 If one of the bounds depends on a dummy variable which is
1910 not INTENT(IN), also return false, because the user may
1911 have changed the variable. */
1912
1913 bool
1914 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1915 {
1916 int i;
1917 int n;
1918 bool lbound_OK = true;
1919 bool ubound_OK = true;
1920
1921 if (contiguous)
1922 *contiguous = false;
1923
1924 if (ref->type != REF_ARRAY)
1925 return false;
1926
1927 if (ref->u.ar.type == AR_FULL)
1928 {
1929 if (contiguous)
1930 *contiguous = true;
1931 return true;
1932 }
1933
1934 if (ref->u.ar.type != AR_SECTION)
1935 return false;
1936 if (ref->next)
1937 return false;
1938
1939 for (i = 0; i < ref->u.ar.dimen; i++)
1940 {
1941 /* If we have a single element in the reference, for the reference
1942 to be full, we need to ascertain that the array has a single
1943 element in this dimension and that we actually reference the
1944 correct element. */
1945 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1946 {
1947 /* This is unconditionally a contiguous reference if all the
1948 remaining dimensions are elements. */
1949 if (contiguous)
1950 {
1951 *contiguous = true;
1952 for (n = i + 1; n < ref->u.ar.dimen; n++)
1953 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1954 *contiguous = false;
1955 }
1956
1957 if (!ref->u.ar.as
1958 || !ref->u.ar.as->lower[i]
1959 || !ref->u.ar.as->upper[i]
1960 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1961 ref->u.ar.as->upper[i])
1962 || !ref->u.ar.start[i]
1963 || gfc_dep_compare_expr (ref->u.ar.start[i],
1964 ref->u.ar.as->lower[i]))
1965 return false;
1966 else
1967 continue;
1968 }
1969
1970 /* Check the lower bound. */
1971 if (ref->u.ar.start[i]
1972 && (!ref->u.ar.as
1973 || !ref->u.ar.as->lower[i]
1974 || gfc_dep_compare_expr (ref->u.ar.start[i],
1975 ref->u.ar.as->lower[i])
1976 || dummy_intent_not_in (&ref->u.ar.start[i])))
1977 lbound_OK = false;
1978 /* Check the upper bound. */
1979 if (ref->u.ar.end[i]
1980 && (!ref->u.ar.as
1981 || !ref->u.ar.as->upper[i]
1982 || gfc_dep_compare_expr (ref->u.ar.end[i],
1983 ref->u.ar.as->upper[i])
1984 || dummy_intent_not_in (&ref->u.ar.end[i])))
1985 ubound_OK = false;
1986 /* Check the stride. */
1987 if (ref->u.ar.stride[i]
1988 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1989 return false;
1990
1991 /* This is unconditionally a contiguous reference as long as all
1992 the subsequent dimensions are elements. */
1993 if (contiguous)
1994 {
1995 *contiguous = true;
1996 for (n = i + 1; n < ref->u.ar.dimen; n++)
1997 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1998 *contiguous = false;
1999 }
2000
2001 if (!lbound_OK || !ubound_OK)
2002 return false;
2003 }
2004 return true;
2005 }
2006
2007
2008 /* Determine if a full array is the same as an array section with one
2009 variable limit. For this to be so, the strides must both be unity
2010 and one of either start == lower or end == upper must be true. */
2011
2012 static bool
2013 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
2014 {
2015 int i;
2016 bool upper_or_lower;
2017
2018 if (full_ref->type != REF_ARRAY)
2019 return false;
2020 if (full_ref->u.ar.type != AR_FULL)
2021 return false;
2022 if (ref->type != REF_ARRAY)
2023 return false;
2024 if (ref->u.ar.type != AR_SECTION)
2025 return false;
2026
2027 for (i = 0; i < ref->u.ar.dimen; i++)
2028 {
2029 /* If we have a single element in the reference, we need to check
2030 that the array has a single element and that we actually reference
2031 the correct element. */
2032 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
2033 {
2034 if (!full_ref->u.ar.as
2035 || !full_ref->u.ar.as->lower[i]
2036 || !full_ref->u.ar.as->upper[i]
2037 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
2038 full_ref->u.ar.as->upper[i])
2039 || !ref->u.ar.start[i]
2040 || gfc_dep_compare_expr (ref->u.ar.start[i],
2041 full_ref->u.ar.as->lower[i]))
2042 return false;
2043 }
2044
2045 /* Check the strides. */
2046 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
2047 return false;
2048 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2049 return false;
2050
2051 upper_or_lower = false;
2052 /* Check the lower bound. */
2053 if (ref->u.ar.start[i]
2054 && (ref->u.ar.as
2055 && full_ref->u.ar.as->lower[i]
2056 && gfc_dep_compare_expr (ref->u.ar.start[i],
2057 full_ref->u.ar.as->lower[i]) == 0))
2058 upper_or_lower = true;
2059 /* Check the upper bound. */
2060 if (ref->u.ar.end[i]
2061 && (ref->u.ar.as
2062 && full_ref->u.ar.as->upper[i]
2063 && gfc_dep_compare_expr (ref->u.ar.end[i],
2064 full_ref->u.ar.as->upper[i]) == 0))
2065 upper_or_lower = true;
2066 if (!upper_or_lower)
2067 return false;
2068 }
2069 return true;
2070 }
2071
2072
2073 /* Finds if two array references are overlapping or not.
2074 Return value
2075 2 : array references are overlapping but reversal of one or
2076 more dimensions will clear the dependency.
2077 1 : array references are overlapping.
2078 0 : array references are identical or not overlapping. */
2079
2080 int
2081 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
2082 {
2083 int n;
2084 int m;
2085 gfc_dependency fin_dep;
2086 gfc_dependency this_dep;
2087
2088 this_dep = GFC_DEP_ERROR;
2089 fin_dep = GFC_DEP_ERROR;
2090 /* Dependencies due to pointers should already have been identified.
2091 We only need to check for overlapping array references. */
2092
2093 while (lref && rref)
2094 {
2095 /* We're resolving from the same base symbol, so both refs should be
2096 the same type. We traverse the reference chain until we find ranges
2097 that are not equal. */
2098 gcc_assert (lref->type == rref->type);
2099 switch (lref->type)
2100 {
2101 case REF_COMPONENT:
2102 /* The two ranges can't overlap if they are from different
2103 components. */
2104 if (lref->u.c.component != rref->u.c.component)
2105 return 0;
2106 break;
2107
2108 case REF_SUBSTRING:
2109 /* Substring overlaps are handled by the string assignment code
2110 if there is not an underlying dependency. */
2111 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
2112
2113 case REF_ARRAY:
2114
2115 if (ref_same_as_full_array (lref, rref))
2116 return 0;
2117
2118 if (ref_same_as_full_array (rref, lref))
2119 return 0;
2120
2121 if (lref->u.ar.dimen != rref->u.ar.dimen)
2122 {
2123 if (lref->u.ar.type == AR_FULL)
2124 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
2125 : GFC_DEP_OVERLAP;
2126 else if (rref->u.ar.type == AR_FULL)
2127 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
2128 : GFC_DEP_OVERLAP;
2129 else
2130 return 1;
2131 break;
2132 }
2133
2134 /* Index for the reverse array. */
2135 m = -1;
2136 for (n=0; n < lref->u.ar.dimen; n++)
2137 {
2138 /* Handle dependency when either of array reference is vector
2139 subscript. There is no dependency if the vector indices
2140 are equal or if indices are known to be different in a
2141 different dimension. */
2142 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2143 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2144 {
2145 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2146 && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2147 && gfc_dep_compare_expr (lref->u.ar.start[n],
2148 rref->u.ar.start[n]) == 0)
2149 this_dep = GFC_DEP_EQUAL;
2150 else
2151 this_dep = GFC_DEP_OVERLAP;
2152
2153 goto update_fin_dep;
2154 }
2155
2156 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2157 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2158 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
2159 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2160 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2161 this_dep = gfc_check_element_vs_section (lref, rref, n);
2162 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2163 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2164 this_dep = gfc_check_element_vs_section (rref, lref, n);
2165 else
2166 {
2167 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2168 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
2169 this_dep = gfc_check_element_vs_element (rref, lref, n);
2170 }
2171
2172 /* If any dimension doesn't overlap, we have no dependency. */
2173 if (this_dep == GFC_DEP_NODEP)
2174 return 0;
2175
2176 /* Now deal with the loop reversal logic: This only works on
2177 ranges and is activated by setting
2178 reverse[n] == GFC_ENABLE_REVERSE
2179 The ability to reverse or not is set by previous conditions
2180 in this dimension. If reversal is not activated, the
2181 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2182
2183 /* Get the indexing right for the scalarizing loop. If this
2184 is an element, there is no corresponding loop. */
2185 if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2186 m++;
2187
2188 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
2189 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2190 {
2191 /* Set reverse if backward dependence and not inhibited. */
2192 if (reverse && reverse[m] == GFC_ENABLE_REVERSE)
2193 reverse[m] = (this_dep == GFC_DEP_BACKWARD) ?
2194 GFC_REVERSE_SET : reverse[m];
2195
2196 /* Set forward if forward dependence and not inhibited. */
2197 if (reverse && reverse[m] == GFC_ENABLE_REVERSE)
2198 reverse[m] = (this_dep == GFC_DEP_FORWARD) ?
2199 GFC_FORWARD_SET : reverse[m];
2200
2201 /* Flag up overlap if dependence not compatible with
2202 the overall state of the expression. */
2203 if (reverse && reverse[m] == GFC_REVERSE_SET
2204 && this_dep == GFC_DEP_FORWARD)
2205 {
2206 reverse[m] = GFC_INHIBIT_REVERSE;
2207 this_dep = GFC_DEP_OVERLAP;
2208 }
2209 else if (reverse && reverse[m] == GFC_FORWARD_SET
2210 && this_dep == GFC_DEP_BACKWARD)
2211 {
2212 reverse[m] = GFC_INHIBIT_REVERSE;
2213 this_dep = GFC_DEP_OVERLAP;
2214 }
2215
2216 /* If no intention of reversing or reversing is explicitly
2217 inhibited, convert backward dependence to overlap. */
2218 if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
2219 || (reverse != NULL && reverse[m] == GFC_INHIBIT_REVERSE))
2220 this_dep = GFC_DEP_OVERLAP;
2221 }
2222
2223 /* Overlap codes are in order of priority. We only need to
2224 know the worst one.*/
2225
2226 update_fin_dep:
2227 if (this_dep > fin_dep)
2228 fin_dep = this_dep;
2229 }
2230
2231 /* If this is an equal element, we have to keep going until we find
2232 the "real" array reference. */
2233 if (lref->u.ar.type == AR_ELEMENT
2234 && rref->u.ar.type == AR_ELEMENT
2235 && fin_dep == GFC_DEP_EQUAL)
2236 break;
2237
2238 /* Exactly matching and forward overlapping ranges don't cause a
2239 dependency. */
2240 if (fin_dep < GFC_DEP_BACKWARD)
2241 return 0;
2242
2243 /* Keep checking. We only have a dependency if
2244 subsequent references also overlap. */
2245 break;
2246
2247 default:
2248 gcc_unreachable ();
2249 }
2250 lref = lref->next;
2251 rref = rref->next;
2252 }
2253
2254 /* If we haven't seen any array refs then something went wrong. */
2255 gcc_assert (fin_dep != GFC_DEP_ERROR);
2256
2257 /* Assume the worst if we nest to different depths. */
2258 if (lref || rref)
2259 return 1;
2260
2261 return fin_dep == GFC_DEP_OVERLAP;
2262 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org