gcc/fortran/frontend-passes.c

   1 /* Pass manager for Fortran front end.
   2    Copyright (C) 2010 Free Software Foundation, Inc.
   3    Contributed by Thomas König.
   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 #include "config.h"
  22 #include "system.h"
  23 #include "gfortran.h"
  24 #include "arith.h"
  25 #include "flags.h"
  26 #include "dependency.h"
  27 #include "constructor.h"
  28 #include "opts.h"
  29
  30 /* Forward declarations.  */
  31
  32 static void strip_function_call (gfc_expr *);
  33 static void optimize_namespace (gfc_namespace *);
  34 static void optimize_assignment (gfc_code *);
  35 static bool optimize_op (gfc_expr *);
  36 static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
  37 static bool optimize_trim (gfc_expr *);
  38
  39 /* How deep we are inside an argument list.  */
  40
  41 static int count_arglist;
  42
  43 /* Pointer to an array of gfc_expr ** we operate on, plus its size
  44    and counter.  */
  45
  46 static gfc_expr ***expr_array;
  47 static int expr_size, expr_count;
  48
  49 /* Pointer to the gfc_code we currently work on - to be able to insert
  50    a statement before.  */
  51
  52 static gfc_code **current_code;
  53
  54 /* The namespace we are currently dealing with.  */
  55
  56 gfc_namespace *current_ns;
  57
  58 /* Entry point - run all passes for a namespace.  So far, only an
  59    optimization pass is run.  */
  60
  61 void
  62 gfc_run_passes (gfc_namespace *ns)
  63 {
  64   if (optimize)
  65     {
  66       expr_size = 20;
  67       expr_array = XNEWVEC(gfc_expr **, expr_size);
  68
  69       optimize_namespace (ns);
  70       if (gfc_option.dump_fortran_optimized)
  71         gfc_dump_parse_tree (ns, stdout);
  72
  73       /* FIXME: The following should be XDELETEVEC(expr_array);
  74       but we cannot do that because it depends on free.  */
  75       gfc_free (expr_array);
  76     }
  77 }
  78
  79 /* Callback for each gfc_code node invoked through gfc_code_walker
  80    from optimize_namespace.  */
  81
  82 static int
  83 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
  84                void *data ATTRIBUTE_UNUSED)
  85 {
  86
  87   gfc_exec_op op;
  88
  89   op = (*c)->op;
  90
  91   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
  92       || op == EXEC_CALL_PPC)
  93     count_arglist = 1;
  94   else
  95     count_arglist = 0;
  96
  97   if (op == EXEC_ASSIGN)
  98     optimize_assignment (*c);
  99   return 0;
 100 }
 101
 102 /* Callback for each gfc_expr node invoked through gfc_code_walker
 103    from optimize_namespace.  */
 104
 105 static int
 106 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 107                void *data ATTRIBUTE_UNUSED)
 108 {
 109   bool function_expr;
 110
 111   if ((*e)->expr_type == EXPR_FUNCTION)
 112     {
 113       count_arglist ++;
 114       function_expr = true;
 115     }
 116   else
 117     function_expr = false;
 118
 119   if (optimize_trim (*e))
 120     gfc_simplify_expr (*e, 0);
 121
 122   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
 123     gfc_simplify_expr (*e, 0);
 124
 125   if (function_expr)
 126     count_arglist --;
 127
 128   return 0;
 129 }
 130
 131
 132 /* Callback function for common function elimination, called from cfe_expr_0.
 133    Put all eligible function expressions into expr_array.  We can't do
 134    allocatable functions.  */
 135
 136 static int
 137 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 138           void *data ATTRIBUTE_UNUSED)
 139 {
 140   if ((*e)->expr_type != EXPR_FUNCTION)
 141     return 0;
 142
 143   /* We don't do character functions (yet).  */
 144   if ((*e)->ts.type == BT_CHARACTER)
 145     return 0;
 146
 147   /* If we don't know the shape at compile time, we do not create a temporary
 148      variable to hold the intermediate result.  FIXME: Change this later when
 149      allocation on assignment works for intrinsics.  */
 150
 151   if ((*e)->rank > 0 && (*e)->shape == NULL)
 152     return 0;
 153
 154   /* Skip the test for pure functions if -faggressive-function-elimination
 155      is specified.  */
 156   if ((*e)->value.function.esym)
 157     {
 158       if ((*e)->value.function.esym->attr.allocatable)
 159         return 0;
 160
 161       /* Don't create an array temporary for elemental functions.  */
 162       if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
 163         return 0;
 164
 165       /* Only eliminate potentially impure functions if the
 166          user specifically requested it.  */
 167       if (!gfc_option.flag_aggressive_function_elimination
 168           && !(*e)->value.function.esym->attr.pure
 169           && !(*e)->value.function.esym->attr.implicit_pure)
 170         return 0;
 171     }
 172
 173   if ((*e)->value.function.isym)
 174     {
 175       /* Conversions are handled on the fly by the middle end,
 176          transpose during trans-* stages.  */
 177       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
 178           || (*e)->value.function.isym->id == GFC_ISYM_TRANSPOSE)
 179         return 0;
 180
 181       /* Don't create an array temporary for elemental functions,
 182          as this would be wasteful of memory.
 183          FIXME: Create a scalar temporary during scalarization.  */
 184       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
 185         return 0;
 186
 187       if (!(*e)->value.function.isym->pure)
 188         return 0;
 189     }
 190
 191   if (expr_count >= expr_size)
 192     {
 193       expr_size += expr_size;
 194       expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
 195     }
 196   expr_array[expr_count] = e;
 197   expr_count ++;
 198   return 0;
 199 }
 200
 201 /* Returns a new expression (a variable) to be used in place of the old one,
 202    with an an assignment statement before the current statement to set
 203    the value of the variable.  */
 204
 205 static gfc_expr*
 206 create_var (gfc_expr * e)
 207 {
 208   char name[GFC_MAX_SYMBOL_LEN +1];
 209   static int num = 1;
 210   gfc_symtree *symtree;
 211   gfc_symbol *symbol;
 212   gfc_expr *result;
 213   gfc_code *n;
 214   int i;
 215
 216   sprintf(name, "__var_%d",num++);
 217   if (gfc_get_sym_tree (name, current_ns, &symtree, false) != 0)
 218     gcc_unreachable ();
 219
 220   symbol = symtree->n.sym;
 221   symbol->ts = e->ts;
 222   symbol->as = gfc_get_array_spec ();
 223   symbol->as->rank = e->rank;
 224   symbol->as->type = AS_EXPLICIT;
 225   for (i=0; i<e->rank; i++)
 226     {
 227       gfc_expr *p, *q;
 228
 229       p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 230                                  &(e->where));
 231       mpz_set_si (p->value.integer, 1);
 232       symbol->as->lower[i] = p;
 233
 234       q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
 235                                  &(e->where));
 236       mpz_set (q->value.integer, e->shape[i]);
 237       symbol->as->upper[i] = q;
 238     }
 239
 240   symbol->attr.flavor = FL_VARIABLE;
 241   symbol->attr.referenced = 1;
 242   symbol->attr.dimension = e->rank > 0;
 243   gfc_commit_symbol (symbol);
 244
 245   result = gfc_get_expr ();
 246   result->expr_type = EXPR_VARIABLE;
 247   result->ts = e->ts;
 248   result->rank = e->rank;
 249   result->shape = gfc_copy_shape (e->shape, e->rank);
 250   result->symtree = symtree;
 251   result->where = e->where;
 252   if (e->rank > 0)
 253     {
 254       result->ref = gfc_get_ref ();
 255       result->ref->type = REF_ARRAY;
 256       result->ref->u.ar.type = AR_FULL;
 257       result->ref->u.ar.where = e->where;
 258       result->ref->u.ar.as = symbol->as;
 259       if (gfc_option.warn_array_temp)
 260         gfc_warning ("Creating array temporary at %L", &(e->where));
 261     }
 262
 263   /* Generate the new assignment.  */
 264   n = XCNEW (gfc_code);
 265   n->op = EXEC_ASSIGN;
 266   n->loc = (*current_code)->loc;
 267   n->next = *current_code;
 268   n->expr1 = gfc_copy_expr (result);
 269   n->expr2 = e;
 270   *current_code = n;
 271
 272   return result;
 273 }
 274
 275 /* Callback function for the code walker for doing common function
 276    elimination.  This builds up the list of functions in the expression
 277    and goes through them to detect duplicates, which it then replaces
 278    by variables.  */
 279
 280 static int
 281 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
 282           void *data ATTRIBUTE_UNUSED)
 283 {
 284   int i,j;
 285   gfc_expr *newvar;
 286
 287   expr_count = 0;
 288
 289   gfc_expr_walker (e, cfe_register_funcs, NULL);
 290
 291   /* Walk backwards through all the functions to make sure we
 292      catch the leaf functions first.  */
 293   for (i=expr_count-1; i>=1; i--)
 294     {
 295       /* Skip if the function has been replaced by a variable already.  */
 296       if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
 297         continue;
 298
 299       newvar = NULL;
 300       for (j=i-1; j>=0; j--)
 301         {
 302           if (gfc_dep_compare_functions(*(expr_array[i]),
 303                                         *(expr_array[j]), true) == 0)
 304             {
 305               if (newvar == NULL)
 306                 newvar = create_var (*(expr_array[i]));
 307               gfc_free (*(expr_array[j]));
 308               *(expr_array[j]) = gfc_copy_expr (newvar);
 309             }
 310         }
 311       if (newvar)
 312         *(expr_array[i]) = newvar;
 313     }
 314
 315   /* We did all the necessary walking in this function.  */
 316   *walk_subtrees = 0;
 317   return 0;
 318 }
 319
 320 /* Callback function for common function elimination, called from
 321    gfc_code_walker.  This keeps track of the current code, in order
 322    to insert statements as needed.  */
 323
 324 static int
 325 cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 326           void *data ATTRIBUTE_UNUSED)
 327 {
 328   current_code = c;
 329   return 0;
 330 }
 331
 332 /* Optimize a namespace, including all contained namespaces.  */
 333
 334 static void
 335 optimize_namespace (gfc_namespace *ns)
 336 {
 337
 338   current_ns = ns;
 339
 340   gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
 341   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
 342
 343   for (ns = ns->contained; ns; ns = ns->sibling)
 344     optimize_namespace (ns);
 345 }
 346
 347 /* Replace code like
 348    a = matmul(b,c) + d
 349    with
 350    a = matmul(b,c) ;   a = a + d
 351    where the array function is not elemental and not allocatable
 352    and does not depend on the left-hand side.
 353 */
 354
 355 static bool
 356 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
 357 {
 358   gfc_expr *e;
 359
 360   e = *rhs;
 361   if (e->expr_type == EXPR_OP)
 362     {
 363       switch (e->value.op.op)
 364         {
 365           /* Unary operators and exponentiation: Only look at a single
 366              operand.  */
 367         case INTRINSIC_NOT:
 368         case INTRINSIC_UPLUS:
 369         case INTRINSIC_UMINUS:
 370         case INTRINSIC_PARENTHESES:
 371         case INTRINSIC_POWER:
 372           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
 373             return true;
 374           break;
 375
 376         default:
 377           /* Binary operators.  */
 378           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
 379             return true;
 380
 381           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
 382             return true;
 383
 384           break;
 385         }
 386     }
 387   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
 388            && ! (e->value.function.esym
 389                  && (e->value.function.esym->attr.elemental
 390                      || e->value.function.esym->attr.allocatable
 391                      || e->value.function.esym->ts.type != c->expr1->ts.type
 392                      || e->value.function.esym->ts.kind != c->expr1->ts.kind))
 393            && ! (e->value.function.isym
 394                  && (e->value.function.isym->elemental
 395                      || e->ts.type != c->expr1->ts.type
 396                      || e->ts.kind != c->expr1->ts.kind)))
 397     {
 398
 399       gfc_code *n;
 400       gfc_expr *new_expr;
 401
 402       /* Insert a new assignment statement after the current one.  */
 403       n = XCNEW (gfc_code);
 404       n->op = EXEC_ASSIGN;
 405       n->loc = c->loc;
 406       n->next = c->next;
 407       c->next = n;
 408
 409       n->expr1 = gfc_copy_expr (c->expr1);
 410       n->expr2 = c->expr2;
 411       new_expr = gfc_copy_expr (c->expr1);
 412       c->expr2 = e;
 413       *rhs = new_expr;
 414
 415       return true;
 416
 417     }
 418
 419   /* Nothing to optimize.  */
 420   return false;
 421 }
 422
 423 /* Optimizations for an assignment.  */
 424
 425 static void
 426 optimize_assignment (gfc_code * c)
 427 {
 428   gfc_expr *lhs, *rhs;
 429
 430   lhs = c->expr1;
 431   rhs = c->expr2;
 432
 433   /* Optimize away a = trim(b), where a is a character variable.  */
 434
 435   if (lhs->ts.type == BT_CHARACTER)
 436     {
 437       if (rhs->expr_type == EXPR_FUNCTION &&
 438           rhs->value.function.isym &&
 439           rhs->value.function.isym->id == GFC_ISYM_TRIM)
 440         {
 441           strip_function_call (rhs);
 442           optimize_assignment (c);
 443           return;
 444         }
 445     }
 446
 447   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 448     optimize_binop_array_assignment (c, &rhs, false);
 449 }
 450
 451
 452 /* Remove an unneeded function call, modifying the expression.
 453    This replaces the function call with the value of its
 454    first argument.  The rest of the argument list is freed.  */
 455
 456 static void
 457 strip_function_call (gfc_expr *e)
 458 {
 459   gfc_expr *e1;
 460   gfc_actual_arglist *a;
 461
 462   a = e->value.function.actual;
 463
 464   /* We should have at least one argument.  */
 465   gcc_assert (a->expr != NULL);
 466
 467   e1 = a->expr;
 468
 469   /* Free the remaining arglist, if any.  */
 470   if (a->next)
 471     gfc_free_actual_arglist (a->next);
 472
 473   /* Graft the argument expression onto the original function.  */
 474   *e = *e1;
 475   gfc_free (e1);
 476
 477 }
 478
 479 /* Recursive optimization of operators.  */
 480
 481 static bool
 482 optimize_op (gfc_expr *e)
 483 {
 484   gfc_intrinsic_op op = e->value.op.op;
 485
 486   switch (op)
 487     {
 488     case INTRINSIC_EQ:
 489     case INTRINSIC_EQ_OS:
 490     case INTRINSIC_GE:
 491     case INTRINSIC_GE_OS:
 492     case INTRINSIC_LE:
 493     case INTRINSIC_LE_OS:
 494     case INTRINSIC_NE:
 495     case INTRINSIC_NE_OS:
 496     case INTRINSIC_GT:
 497     case INTRINSIC_GT_OS:
 498     case INTRINSIC_LT:
 499     case INTRINSIC_LT_OS:
 500       return optimize_comparison (e, op);
 501
 502     default:
 503       break;
 504     }
 505
 506   return false;
 507 }
 508
 509 /* Optimize expressions for equality.  */
 510
 511 static bool
 512 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
 513 {
 514   gfc_expr *op1, *op2;
 515   bool change;
 516   int eq;
 517   bool result;
 518
 519   op1 = e->value.op.op1;
 520   op2 = e->value.op.op2;
 521
 522   /* Strip off unneeded TRIM calls from string comparisons.  */
 523
 524   change = false;
 525
 526   if (op1->expr_type == EXPR_FUNCTION
 527       && op1->value.function.isym
 528       && op1->value.function.isym->id == GFC_ISYM_TRIM)
 529     {
 530       strip_function_call (op1);
 531       change = true;
 532     }
 533
 534   if (op2->expr_type == EXPR_FUNCTION
 535       && op2->value.function.isym
 536       && op2->value.function.isym->id == GFC_ISYM_TRIM)
 537     {
 538       strip_function_call (op2);
 539       change = true;
 540     }
 541
 542   if (change)
 543     {
 544       optimize_comparison (e, op);
 545       return true;
 546     }
 547
 548   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 549   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 550      handles them well). However, there are also cases that need a non-scalar
 551      argument. For example the any intrinsic. See PR 45380.  */
 552   if (e->rank > 0)
 553     return false;
 554
 555   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 556
 557   if (flag_finite_math_only
 558       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 559           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
 560     {
 561       eq = gfc_dep_compare_expr (op1, op2);
 562       if (eq == -2)
 563         {
 564           /* Replace A // B < A // C with B < C, and A // B < C // B
 565              with A < C.  */
 566           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 567               && op1->value.op.op == INTRINSIC_CONCAT
 568               && op2->value.op.op == INTRINSIC_CONCAT)
 569             {
 570               gfc_expr *op1_left = op1->value.op.op1;
 571               gfc_expr *op2_left = op2->value.op.op1;
 572               gfc_expr *op1_right = op1->value.op.op2;
 573               gfc_expr *op2_right = op2->value.op.op2;
 574
 575               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
 576                 {
 577                   /* Watch out for 'A ' // x vs. 'A' // x.  */
 578
 579                   if (op1_left->expr_type == EXPR_CONSTANT
 580                         && op2_left->expr_type == EXPR_CONSTANT
 581                         && op1_left->value.character.length
 582                            != op2_left->value.character.length)
 583                     return -2;
 584                   else
 585                     {
 586                       gfc_free (op1_left);
 587                       gfc_free (op2_left);
 588                       e->value.op.op1 = op1_right;
 589                       e->value.op.op2 = op2_right;
 590                       optimize_comparison (e, op);
 591                       return true;
 592                     }
 593                 }
 594               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
 595                 {
 596                   gfc_free (op1_right);
 597                   gfc_free (op2_right);
 598                   e->value.op.op1 = op1_left;
 599                   e->value.op.op2 = op2_left;
 600                   optimize_comparison (e, op);
 601                   return true;
 602                 }
 603             }
 604         }
 605       else
 606         {
 607           /* eq can only be -1, 0 or 1 at this point.  */
 608           switch (op)
 609             {
 610             case INTRINSIC_EQ:
 611             case INTRINSIC_EQ_OS:
 612               result = eq == 0;
 613               break;
 614
 615             case INTRINSIC_GE:
 616             case INTRINSIC_GE_OS:
 617               result = eq >= 0;
 618               break;
 619
 620             case INTRINSIC_LE:
 621             case INTRINSIC_LE_OS:
 622               result = eq <= 0;
 623               break;
 624
 625             case INTRINSIC_NE:
 626             case INTRINSIC_NE_OS:
 627               result = eq != 0;
 628               break;
 629
 630             case INTRINSIC_GT:
 631             case INTRINSIC_GT_OS:
 632               result = eq > 0;
 633               break;
 634
 635             case INTRINSIC_LT:
 636             case INTRINSIC_LT_OS:
 637               result = eq < 0;
 638               break;
 639
 640             default:
 641               gfc_internal_error ("illegal OP in optimize_comparison");
 642               break;
 643             }
 644
 645           /* Replace the expression by a constant expression.  The typespec
 646              and where remains the way it is.  */
 647           gfc_free (op1);
 648           gfc_free (op2);
 649           e->expr_type = EXPR_CONSTANT;
 650           e->value.logical = result;
 651           return true;
 652         }
 653     }
 654
 655   return false;
 656 }
 657
 658 /* Optimize a trim function by replacing it with an equivalent substring
 659    involving a call to len_trim.  This only works for expressions where
 660    variables are trimmed.  Return true if anything was modified.  */
 661
 662 static bool
 663 optimize_trim (gfc_expr *e)
 664 {
 665   gfc_expr *a;
 666   gfc_ref *ref;
 667   gfc_expr *fcn;
 668   gfc_actual_arglist *actual_arglist, *next;
 669   gfc_ref **rr = NULL;
 670
 671   /* Don't do this optimization within an argument list, because
 672      otherwise aliasing issues may occur.  */
 673
 674   if (count_arglist != 1)
 675     return false;
 676
 677   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
 678       || e->value.function.isym == NULL
 679       || e->value.function.isym->id != GFC_ISYM_TRIM)
 680     return false;
 681
 682   a = e->value.function.actual->expr;
 683
 684   if (a->expr_type != EXPR_VARIABLE)
 685     return false;
 686
 687   /* Follow all references to find the correct place to put the newly
 688      created reference.  FIXME:  Also handle substring references and
 689      array references.  Array references cause strange regressions at
 690      the moment.  */
 691
 692   if (a->ref)
 693     {
 694       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
 695         {
 696           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
 697             return false;
 698         }
 699     }
 700
 701   strip_function_call (e);
 702
 703   if (e->ref == NULL)
 704     rr = &(e->ref);
 705
 706   /* Create the reference.  */
 707
 708   ref = gfc_get_ref ();
 709   ref->type = REF_SUBSTRING;
 710
 711   /* Set the start of the reference.  */
 712
 713   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 714
 715   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 716
 717   fcn = gfc_get_expr ();
 718   fcn->expr_type = EXPR_FUNCTION;
 719   fcn->value.function.isym =
 720     gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
 721   actual_arglist = gfc_get_actual_arglist ();
 722   actual_arglist->expr = gfc_copy_expr (e);
 723   next = gfc_get_actual_arglist ();
 724   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
 725                                  gfc_default_integer_kind);
 726   actual_arglist->next = next;
 727   fcn->value.function.actual = actual_arglist;
 728
 729   /* Set the end of the reference to the call to len_trim.  */
 730
 731   ref->u.ss.end = fcn;
 732   gcc_assert (*rr == NULL);
 733   *rr = ref;
 734   return true;
 735 }
 736
 737 #define WALK_SUBEXPR(NODE) \
 738   do                                                    \
 739     {                                                   \
 740       result = gfc_expr_walker (&(NODE), exprfn, data); \
 741       if (result)                                       \
 742         return result;                                  \
 743     }                                                   \
 744   while (0)
 745 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
 746
 747 /* Walk expression *E, calling EXPRFN on each expression in it.  */
 748
 749 int
 750 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
 751 {
 752   while (*e)
 753     {
 754       int walk_subtrees = 1;
 755       gfc_actual_arglist *a;
 756       gfc_ref *r;
 757       gfc_constructor *c;
 758
 759       int result = exprfn (e, &walk_subtrees, data);
 760       if (result)
 761         return result;
 762       if (walk_subtrees)
 763         switch ((*e)->expr_type)
 764           {
 765           case EXPR_OP:
 766             WALK_SUBEXPR ((*e)->value.op.op1);
 767             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
 768             break;
 769           case EXPR_FUNCTION:
 770             for (a = (*e)->value.function.actual; a; a = a->next)
 771               WALK_SUBEXPR (a->expr);
 772             break;
 773           case EXPR_COMPCALL:
 774           case EXPR_PPC:
 775             WALK_SUBEXPR ((*e)->value.compcall.base_object);
 776             for (a = (*e)->value.compcall.actual; a; a = a->next)
 777               WALK_SUBEXPR (a->expr);
 778             break;
 779
 780           case EXPR_STRUCTURE:
 781           case EXPR_ARRAY:
 782             for (c = gfc_constructor_first ((*e)->value.constructor); c;
 783                  c = gfc_constructor_next (c))
 784               {
 785                 WALK_SUBEXPR (c->expr);
 786                 if (c->iterator != NULL)
 787                   {
 788                     WALK_SUBEXPR (c->iterator->var);
 789                     WALK_SUBEXPR (c->iterator->start);
 790                     WALK_SUBEXPR (c->iterator->end);
 791                     WALK_SUBEXPR (c->iterator->step);
 792                   }
 793               }
 794
 795             if ((*e)->expr_type != EXPR_ARRAY)
 796               break;
 797
 798             /* Fall through to the variable case in order to walk the
 799                the reference.  */
 800
 801           case EXPR_SUBSTRING:
 802           case EXPR_VARIABLE:
 803             for (r = (*e)->ref; r; r = r->next)
 804               {
 805                 gfc_array_ref *ar;
 806                 int i;
 807
 808                 switch (r->type)
 809                   {
 810                   case REF_ARRAY:
 811                     ar = &r->u.ar;
 812                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
 813                       {
 814                         for (i=0; i< ar->dimen; i++)
 815                           {
 816                             WALK_SUBEXPR (ar->start[i]);
 817                             WALK_SUBEXPR (ar->end[i]);
 818                             WALK_SUBEXPR (ar->stride[i]);
 819                           }
 820                       }
 821
 822                     break;
 823
 824                   case REF_SUBSTRING:
 825                     WALK_SUBEXPR (r->u.ss.start);
 826                     WALK_SUBEXPR (r->u.ss.end);
 827                     break;
 828
 829                   case REF_COMPONENT:
 830                     break;
 831                   }
 832               }
 833
 834           default:
 835             break;
 836           }
 837       return 0;
 838     }
 839   return 0;
 840 }
 841
 842 #define WALK_SUBCODE(NODE) \
 843   do                                                            \
 844     {                                                           \
 845       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
 846       if (result)                                               \
 847         return result;                                          \
 848     }                                                           \
 849   while (0)
 850
 851 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
 852    on each expression in it.  If any of the hooks returns non-zero, that
 853    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
 854    no subcodes or subexpressions are traversed.  */
 855
 856 int
 857 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 858                  void *data)
 859 {
 860   for (; *c; c = &(*c)->next)
 861     {
 862       int walk_subtrees = 1;
 863       int result = codefn (c, &walk_subtrees, data);
 864       if (result)
 865         return result;
 866
 867       if (walk_subtrees)
 868         {
 869           gfc_code *b;
 870           gfc_actual_arglist *a;
 871
 872           switch ((*c)->op)
 873             {
 874             case EXEC_DO:
 875               WALK_SUBEXPR ((*c)->ext.iterator->var);
 876               WALK_SUBEXPR ((*c)->ext.iterator->start);
 877               WALK_SUBEXPR ((*c)->ext.iterator->end);
 878               WALK_SUBEXPR ((*c)->ext.iterator->step);
 879               break;
 880
 881             case EXEC_CALL:
 882             case EXEC_ASSIGN_CALL:
 883               for (a = (*c)->ext.actual; a; a = a->next)
 884                 WALK_SUBEXPR (a->expr);
 885               break;
 886
 887             case EXEC_CALL_PPC:
 888               WALK_SUBEXPR ((*c)->expr1);
 889               for (a = (*c)->ext.actual; a; a = a->next)
 890                 WALK_SUBEXPR (a->expr);
 891               break;
 892
 893             case EXEC_SELECT:
 894               WALK_SUBEXPR ((*c)->expr1);
 895               for (b = (*c)->block; b; b = b->block)
 896                 {
 897                   gfc_case *cp;
 898                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
 899                     {
 900                       WALK_SUBEXPR (cp->low);
 901                       WALK_SUBEXPR (cp->high);
 902                     }
 903                   WALK_SUBCODE (b->next);
 904                 }
 905               continue;
 906
 907             case EXEC_ALLOCATE:
 908             case EXEC_DEALLOCATE:
 909               {
 910                 gfc_alloc *a;
 911                 for (a = (*c)->ext.alloc.list; a; a = a->next)
 912                   WALK_SUBEXPR (a->expr);
 913                 break;
 914               }
 915
 916             case EXEC_FORALL:
 917               {
 918                 gfc_forall_iterator *fa;
 919                 for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
 920                   {
 921                     WALK_SUBEXPR (fa->var);
 922                     WALK_SUBEXPR (fa->start);
 923                     WALK_SUBEXPR (fa->end);
 924                     WALK_SUBEXPR (fa->stride);
 925                   }
 926                 break;
 927               }
 928
 929             case EXEC_OPEN:
 930               WALK_SUBEXPR ((*c)->ext.open->unit);
 931               WALK_SUBEXPR ((*c)->ext.open->file);
 932               WALK_SUBEXPR ((*c)->ext.open->status);
 933               WALK_SUBEXPR ((*c)->ext.open->access);
 934               WALK_SUBEXPR ((*c)->ext.open->form);
 935               WALK_SUBEXPR ((*c)->ext.open->recl);
 936               WALK_SUBEXPR ((*c)->ext.open->blank);
 937               WALK_SUBEXPR ((*c)->ext.open->position);
 938               WALK_SUBEXPR ((*c)->ext.open->action);
 939               WALK_SUBEXPR ((*c)->ext.open->delim);
 940               WALK_SUBEXPR ((*c)->ext.open->pad);
 941               WALK_SUBEXPR ((*c)->ext.open->iostat);
 942               WALK_SUBEXPR ((*c)->ext.open->iomsg);
 943               WALK_SUBEXPR ((*c)->ext.open->convert);
 944               WALK_SUBEXPR ((*c)->ext.open->decimal);
 945               WALK_SUBEXPR ((*c)->ext.open->encoding);
 946               WALK_SUBEXPR ((*c)->ext.open->round);
 947               WALK_SUBEXPR ((*c)->ext.open->sign);
 948               WALK_SUBEXPR ((*c)->ext.open->asynchronous);
 949               WALK_SUBEXPR ((*c)->ext.open->id);
 950               WALK_SUBEXPR ((*c)->ext.open->newunit);
 951               break;
 952
 953             case EXEC_CLOSE:
 954               WALK_SUBEXPR ((*c)->ext.close->unit);
 955               WALK_SUBEXPR ((*c)->ext.close->status);
 956               WALK_SUBEXPR ((*c)->ext.close->iostat);
 957               WALK_SUBEXPR ((*c)->ext.close->iomsg);
 958               break;
 959
 960             case EXEC_BACKSPACE:
 961             case EXEC_ENDFILE:
 962             case EXEC_REWIND:
 963             case EXEC_FLUSH:
 964               WALK_SUBEXPR ((*c)->ext.filepos->unit);
 965               WALK_SUBEXPR ((*c)->ext.filepos->iostat);
 966               WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
 967               break;
 968
 969             case EXEC_INQUIRE:
 970               WALK_SUBEXPR ((*c)->ext.inquire->unit);
 971               WALK_SUBEXPR ((*c)->ext.inquire->file);
 972               WALK_SUBEXPR ((*c)->ext.inquire->iomsg);
 973               WALK_SUBEXPR ((*c)->ext.inquire->iostat);
 974               WALK_SUBEXPR ((*c)->ext.inquire->exist);
 975               WALK_SUBEXPR ((*c)->ext.inquire->opened);
 976               WALK_SUBEXPR ((*c)->ext.inquire->number);
 977               WALK_SUBEXPR ((*c)->ext.inquire->named);
 978               WALK_SUBEXPR ((*c)->ext.inquire->name);
 979               WALK_SUBEXPR ((*c)->ext.inquire->access);
 980               WALK_SUBEXPR ((*c)->ext.inquire->sequential);
 981               WALK_SUBEXPR ((*c)->ext.inquire->direct);
 982               WALK_SUBEXPR ((*c)->ext.inquire->form);
 983               WALK_SUBEXPR ((*c)->ext.inquire->formatted);
 984               WALK_SUBEXPR ((*c)->ext.inquire->unformatted);
 985               WALK_SUBEXPR ((*c)->ext.inquire->recl);
 986               WALK_SUBEXPR ((*c)->ext.inquire->nextrec);
 987               WALK_SUBEXPR ((*c)->ext.inquire->blank);
 988               WALK_SUBEXPR ((*c)->ext.inquire->position);
 989               WALK_SUBEXPR ((*c)->ext.inquire->action);
 990               WALK_SUBEXPR ((*c)->ext.inquire->read);
 991               WALK_SUBEXPR ((*c)->ext.inquire->write);
 992               WALK_SUBEXPR ((*c)->ext.inquire->readwrite);
 993               WALK_SUBEXPR ((*c)->ext.inquire->delim);
 994               WALK_SUBEXPR ((*c)->ext.inquire->encoding);
 995               WALK_SUBEXPR ((*c)->ext.inquire->pad);
 996               WALK_SUBEXPR ((*c)->ext.inquire->iolength);
 997               WALK_SUBEXPR ((*c)->ext.inquire->convert);
 998               WALK_SUBEXPR ((*c)->ext.inquire->strm_pos);
 999               WALK_SUBEXPR ((*c)->ext.inquire->asynchronous);
1000               WALK_SUBEXPR ((*c)->ext.inquire->decimal);
1001               WALK_SUBEXPR ((*c)->ext.inquire->pending);
1002               WALK_SUBEXPR ((*c)->ext.inquire->id);
1003               WALK_SUBEXPR ((*c)->ext.inquire->sign);
1004               WALK_SUBEXPR ((*c)->ext.inquire->size);
1005               WALK_SUBEXPR ((*c)->ext.inquire->round);
1006               break;
1007
1008             case EXEC_WAIT:
1009               WALK_SUBEXPR ((*c)->ext.wait->unit);
1010               WALK_SUBEXPR ((*c)->ext.wait->iostat);
1011               WALK_SUBEXPR ((*c)->ext.wait->iomsg);
1012               WALK_SUBEXPR ((*c)->ext.wait->id);
1013               break;
1014
1015             case EXEC_READ:
1016             case EXEC_WRITE:
1017               WALK_SUBEXPR ((*c)->ext.dt->io_unit);
1018               WALK_SUBEXPR ((*c)->ext.dt->format_expr);
1019               WALK_SUBEXPR ((*c)->ext.dt->rec);
1020               WALK_SUBEXPR ((*c)->ext.dt->advance);
1021               WALK_SUBEXPR ((*c)->ext.dt->iostat);
1022               WALK_SUBEXPR ((*c)->ext.dt->size);
1023               WALK_SUBEXPR ((*c)->ext.dt->iomsg);
1024               WALK_SUBEXPR ((*c)->ext.dt->id);
1025               WALK_SUBEXPR ((*c)->ext.dt->pos);
1026               WALK_SUBEXPR ((*c)->ext.dt->asynchronous);
1027               WALK_SUBEXPR ((*c)->ext.dt->blank);
1028               WALK_SUBEXPR ((*c)->ext.dt->decimal);
1029               WALK_SUBEXPR ((*c)->ext.dt->delim);
1030               WALK_SUBEXPR ((*c)->ext.dt->pad);
1031               WALK_SUBEXPR ((*c)->ext.dt->round);
1032               WALK_SUBEXPR ((*c)->ext.dt->sign);
1033               WALK_SUBEXPR ((*c)->ext.dt->extra_comma);
1034               break;
1035
1036             case EXEC_OMP_DO:
1037             case EXEC_OMP_PARALLEL:
1038             case EXEC_OMP_PARALLEL_DO:
1039             case EXEC_OMP_PARALLEL_SECTIONS:
1040             case EXEC_OMP_PARALLEL_WORKSHARE:
1041             case EXEC_OMP_SECTIONS:
1042             case EXEC_OMP_SINGLE:
1043             case EXEC_OMP_WORKSHARE:
1044             case EXEC_OMP_END_SINGLE:
1045             case EXEC_OMP_TASK:
1046               if ((*c)->ext.omp_clauses)
1047                 {
1048                   WALK_SUBEXPR ((*c)->ext.omp_clauses->if_expr);
1049                   WALK_SUBEXPR ((*c)->ext.omp_clauses->num_threads);
1050                   WALK_SUBEXPR ((*c)->ext.omp_clauses->chunk_size);
1051                 }
1052               break;
1053             default:
1054               break;
1055             }
1056
1057           WALK_SUBEXPR ((*c)->expr1);
1058           WALK_SUBEXPR ((*c)->expr2);
1059           WALK_SUBEXPR ((*c)->expr3);
1060           for (b = (*c)->block; b; b = b->block)
1061             {
1062               WALK_SUBEXPR (b->expr1);
1063               WALK_SUBEXPR (b->expr2);
1064               WALK_SUBCODE (b->next);
1065             }
1066         }
1067     }
1068   return 0;
1069 }