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