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