gcc/fortran/frontend-passes.c

   1 /* Pass manager for Fortran front end.
   2    Copyright (C) 2010, 2011 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 static bool optimize_lexical_comparison (gfc_expr *);
  39 static void optimize_minmaxloc (gfc_expr **);
  40
  41 /* How deep we are inside an argument list.  */
  42
  43 static int count_arglist;
  44
  45 /* Pointer to an array of gfc_expr ** we operate on, plus its size
  46    and counter.  */
  47
  48 static gfc_expr ***expr_array;
  49 static int expr_size, expr_count;
  50
  51 /* Pointer to the gfc_code we currently work on - to be able to insert
  52    a block before the statement.  */
  53
  54 static gfc_code **current_code;
  55
  56 /* Pointer to the block to be inserted, and the statement we are
  57    changing within the block.  */
  58
  59 static gfc_code *inserted_block, **changed_statement;
  60
  61 /* The namespace we are currently dealing with.  */
  62
  63 static gfc_namespace *current_ns;
  64
  65 /* If we are within any forall loop.  */
  66
  67 static int forall_level;
  68
  69 /* Keep track of whether we are within an OMP workshare.  */
  70
  71 static bool in_omp_workshare;
  72
  73 /* Keep track of iterators for array constructors.  */
  74
  75 static int iterator_level;
  76
  77 /* Entry point - run all passes for a namespace.  So far, only an
  78    optimization pass is run.  */
  79
  80 void
  81 gfc_run_passes (gfc_namespace *ns)
  82 {
  83   if (gfc_option.flag_frontend_optimize)
  84     {
  85       expr_size = 20;
  86       expr_array = XNEWVEC(gfc_expr **, expr_size);
  87
  88       optimize_namespace (ns);
  89       if (gfc_option.dump_fortran_optimized)
  90         gfc_dump_parse_tree (ns, stdout);
  91
  92       XDELETEVEC (expr_array);
  93     }
  94 }
  95
  96 /* Callback for each gfc_code node invoked through gfc_code_walker
  97    from optimize_namespace.  */
  98
  99 static int
 100 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 101                void *data ATTRIBUTE_UNUSED)
 102 {
 103
 104   gfc_exec_op op;
 105
 106   op = (*c)->op;
 107
 108   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
 109       || op == EXEC_CALL_PPC)
 110     count_arglist = 1;
 111   else
 112     count_arglist = 0;
 113
 114   if (op == EXEC_ASSIGN)
 115     optimize_assignment (*c);
 116   return 0;
 117 }
 118
 119 /* Callback for each gfc_expr node invoked through gfc_code_walker
 120    from optimize_namespace.  */
 121
 122 static int
 123 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 124                void *data ATTRIBUTE_UNUSED)
 125 {
 126   bool function_expr;
 127
 128   if ((*e)->expr_type == EXPR_FUNCTION)
 129     {
 130       count_arglist ++;
 131       function_expr = true;
 132     }
 133   else
 134     function_expr = false;
 135
 136   if (optimize_trim (*e))
 137     gfc_simplify_expr (*e, 0);
 138
 139   if (optimize_lexical_comparison (*e))
 140     gfc_simplify_expr (*e, 0);
 141
 142   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
 143     gfc_simplify_expr (*e, 0);
 144
 145   if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
 146     switch ((*e)->value.function.isym->id)
 147       {
 148       case GFC_ISYM_MINLOC:
 149       case GFC_ISYM_MAXLOC:
 150         optimize_minmaxloc (e);
 151         break;
 152       default:
 153         break;
 154       }
 155
 156   if (function_expr)
 157     count_arglist --;
 158
 159   return 0;
 160 }
 161
 162
 163 /* Callback function for common function elimination, called from cfe_expr_0.
 164    Put all eligible function expressions into expr_array.  */
 165
 166 static int
 167 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 168           void *data ATTRIBUTE_UNUSED)
 169 {
 170
 171   if ((*e)->expr_type != EXPR_FUNCTION)
 172     return 0;
 173
 174   /* We don't do character functions with unknown charlens.  */
 175   if ((*e)->ts.type == BT_CHARACTER
 176       && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
 177           || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
 178     return 0;
 179
 180   /* We don't do function elimination within FORALL statements, it can
 181      lead to wrong-code in certain circumstances.  */
 182
 183   if (forall_level > 0)
 184     return 0;
 185
 186   /* Function elimination inside an iterator could lead to functions
 187      which depend on iterator variables being moved outside.  */
 188
 189   if (iterator_level > 0)
 190     return 0;
 191
 192   /* If we don't know the shape at compile time, we create an allocatable
 193      temporary variable to hold the intermediate result, but only if
 194      allocation on assignment is active.  */
 195
 196   if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
 197     return 0;
 198
 199   /* Skip the test for pure functions if -faggressive-function-elimination
 200      is specified.  */
 201   if ((*e)->value.function.esym)
 202     {
 203       /* Don't create an array temporary for elemental functions.  */
 204       if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
 205         return 0;
 206
 207       /* Only eliminate potentially impure functions if the
 208          user specifically requested it.  */
 209       if (!gfc_option.flag_aggressive_function_elimination
 210           && !(*e)->value.function.esym->attr.pure
 211           && !(*e)->value.function.esym->attr.implicit_pure)
 212         return 0;
 213     }
 214
 215   if ((*e)->value.function.isym)
 216     {
 217       /* Conversions are handled on the fly by the middle end,
 218          transpose during trans-* stages and TRANSFER by the middle end.  */
 219       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
 220           || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
 221           || gfc_inline_intrinsic_function_p (*e))
 222         return 0;
 223
 224       /* Don't create an array temporary for elemental functions,
 225          as this would be wasteful of memory.
 226          FIXME: Create a scalar temporary during scalarization.  */
 227       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
 228         return 0;
 229
 230       if (!(*e)->value.function.isym->pure)
 231         return 0;
 232     }
 233
 234   if (expr_count >= expr_size)
 235     {
 236       expr_size += expr_size;
 237       expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
 238     }
 239   expr_array[expr_count] = e;
 240   expr_count ++;
 241   return 0;
 242 }
 243
 244 /* Returns a new expression (a variable) to be used in place of the old one,
 245    with an an assignment statement before the current statement to set
 246    the value of the variable. Creates a new BLOCK for the statement if
 247    that hasn't already been done and puts the statement, plus the
 248    newly created variables, in that block.  */
 249
 250 static gfc_expr*
 251 create_var (gfc_expr * e)
 252 {
 253   char name[GFC_MAX_SYMBOL_LEN +1];
 254   static int num = 1;
 255   gfc_symtree *symtree;
 256   gfc_symbol *symbol;
 257   gfc_expr *result;
 258   gfc_code *n;
 259   gfc_namespace *ns;
 260   int i;
 261
 262   /* If the block hasn't already been created, do so.  */
 263   if (inserted_block == NULL)
 264     {
 265       inserted_block = XCNEW (gfc_code);
 266       inserted_block->op = EXEC_BLOCK;
 267       inserted_block->loc = (*current_code)->loc;
 268       ns = gfc_build_block_ns (current_ns);
 269       inserted_block->ext.block.ns = ns;
 270       inserted_block->ext.block.assoc = NULL;
 271
 272       ns->code = *current_code;
 273       inserted_block->next = (*current_code)->next;
 274       changed_statement = &(inserted_block->ext.block.ns->code);
 275       (*current_code)->next = NULL;
 276       /* Insert the BLOCK at the right position.  */
 277       *current_code = inserted_block;
 278       ns->parent = current_ns;
 279     }
 280   else
 281     ns = inserted_block->ext.block.ns;
 282
 283   sprintf(name, "__var_%d",num++);
 284   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
 285     gcc_unreachable ();
 286
 287   symbol = symtree->n.sym;
 288   symbol->ts = e->ts;
 289
 290   if (e->rank > 0)
 291     {
 292       symbol->as = gfc_get_array_spec ();
 293       symbol->as->rank = e->rank;
 294
 295       if (e->shape == NULL)
 296         {
 297           /* We don't know the shape at compile time, so we use an
 298              allocatable. */
 299           symbol->as->type = AS_DEFERRED;
 300           symbol->attr.allocatable = 1;
 301         }
 302       else
 303         {
 304           symbol->as->type = AS_EXPLICIT;
 305           /* Copy the shape.  */
 306           for (i=0; i<e->rank; i++)
 307             {
 308               gfc_expr *p, *q;
 309
 310               p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 311                                          &(e->where));
 312               mpz_set_si (p->value.integer, 1);
 313               symbol->as->lower[i] = p;
 314
 315               q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
 316                                          &(e->where));
 317               mpz_set (q->value.integer, e->shape[i]);
 318               symbol->as->upper[i] = q;
 319             }
 320         }
 321     }
 322
 323   symbol->attr.flavor = FL_VARIABLE;
 324   symbol->attr.referenced = 1;
 325   symbol->attr.dimension = e->rank > 0;
 326   gfc_commit_symbol (symbol);
 327
 328   result = gfc_get_expr ();
 329   result->expr_type = EXPR_VARIABLE;
 330   result->ts = e->ts;
 331   result->rank = e->rank;
 332   result->shape = gfc_copy_shape (e->shape, e->rank);
 333   result->symtree = symtree;
 334   result->where = e->where;
 335   if (e->rank > 0)
 336     {
 337       result->ref = gfc_get_ref ();
 338       result->ref->type = REF_ARRAY;
 339       result->ref->u.ar.type = AR_FULL;
 340       result->ref->u.ar.where = e->where;
 341       result->ref->u.ar.as = symbol->ts.type == BT_CLASS
 342                              ? CLASS_DATA (symbol)->as : symbol->as;
 343       if (gfc_option.warn_array_temp)
 344         gfc_warning ("Creating array temporary at %L", &(e->where));
 345     }
 346
 347   /* Generate the new assignment.  */
 348   n = XCNEW (gfc_code);
 349   n->op = EXEC_ASSIGN;
 350   n->loc = (*current_code)->loc;
 351   n->next = *changed_statement;
 352   n->expr1 = gfc_copy_expr (result);
 353   n->expr2 = e;
 354   *changed_statement = n;
 355
 356   return result;
 357 }
 358
 359 /* Warn about function elimination.  */
 360
 361 static void
 362 warn_function_elimination (gfc_expr *e)
 363 {
 364   if (e->expr_type != EXPR_FUNCTION)
 365     return;
 366   if (e->value.function.esym)
 367     gfc_warning ("Removing call to function '%s' at %L",
 368                  e->value.function.esym->name, &(e->where));
 369   else if (e->value.function.isym)
 370     gfc_warning ("Removing call to function '%s' at %L",
 371                  e->value.function.isym->name, &(e->where));
 372 }
 373 /* Callback function for the code walker for doing common function
 374    elimination.  This builds up the list of functions in the expression
 375    and goes through them to detect duplicates, which it then replaces
 376    by variables.  */
 377
 378 static int
 379 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
 380           void *data ATTRIBUTE_UNUSED)
 381 {
 382   int i,j;
 383   gfc_expr *newvar;
 384
 385   /* Don't do this optimization within OMP workshare. */
 386
 387   if (in_omp_workshare)
 388     {
 389       *walk_subtrees = 0;
 390       return 0;
 391     }
 392
 393   expr_count = 0;
 394
 395   gfc_expr_walker (e, cfe_register_funcs, NULL);
 396
 397   /* Walk through all the functions.  */
 398
 399   for (i=1; i<expr_count; i++)
 400     {
 401       /* Skip if the function has been replaced by a variable already.  */
 402       if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
 403         continue;
 404
 405       newvar = NULL;
 406       for (j=0; j<i; j++)
 407         {
 408           if (gfc_dep_compare_functions(*(expr_array[i]),
 409                                         *(expr_array[j]), true) == 0)
 410             {
 411               if (newvar == NULL)
 412                 newvar = create_var (*(expr_array[i]));
 413
 414               if (gfc_option.warn_function_elimination)
 415                 warn_function_elimination (*(expr_array[j]));
 416
 417               free (*(expr_array[j]));
 418               *(expr_array[j]) = gfc_copy_expr (newvar);
 419             }
 420         }
 421       if (newvar)
 422         *(expr_array[i]) = newvar;
 423     }
 424
 425   /* We did all the necessary walking in this function.  */
 426   *walk_subtrees = 0;
 427   return 0;
 428 }
 429
 430 /* Callback function for common function elimination, called from
 431    gfc_code_walker.  This keeps track of the current code, in order
 432    to insert statements as needed.  */
 433
 434 static int
 435 cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 436           void *data ATTRIBUTE_UNUSED)
 437 {
 438   current_code = c;
 439   inserted_block = NULL;
 440   changed_statement = NULL;
 441   return 0;
 442 }
 443
 444 /* Dummy function for expression call back, for use when we
 445    really don't want to do any walking.  */
 446
 447 static int
 448 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
 449                      void *data ATTRIBUTE_UNUSED)
 450 {
 451   *walk_subtrees = 0;
 452   return 0;
 453 }
 454
 455 /* Code callback function for converting
 456    do while(a)
 457    end do
 458    into the equivalent
 459    do
 460      if (.not. a) exit
 461    end do
 462    This is because common function elimination would otherwise place the
 463    temporary variables outside the loop.  */
 464
 465 static int
 466 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 467                   void *data ATTRIBUTE_UNUSED)
 468 {
 469   gfc_code *co = *c;
 470   gfc_code *c_if1, *c_if2, *c_exit;
 471   gfc_code *loopblock;
 472   gfc_expr *e_not, *e_cond;
 473
 474   if (co->op != EXEC_DO_WHILE)
 475     return 0;
 476
 477   if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
 478     return 0;
 479
 480   e_cond = co->expr1;
 481
 482   /* Generate the condition of the if statement, which is .not. the original
 483      statement.  */
 484   e_not = gfc_get_expr ();
 485   e_not->ts = e_cond->ts;
 486   e_not->where = e_cond->where;
 487   e_not->expr_type = EXPR_OP;
 488   e_not->value.op.op = INTRINSIC_NOT;
 489   e_not->value.op.op1 = e_cond;
 490
 491   /* Generate the EXIT statement.  */
 492   c_exit = XCNEW (gfc_code);
 493   c_exit->op = EXEC_EXIT;
 494   c_exit->ext.which_construct = co;
 495   c_exit->loc = co->loc;
 496
 497   /* Generate the IF statement.  */
 498   c_if2 = XCNEW (gfc_code);
 499   c_if2->op = EXEC_IF;
 500   c_if2->expr1 = e_not;
 501   c_if2->next = c_exit;
 502   c_if2->loc = co->loc;
 503
 504   /* ... plus the one to chain it to.  */
 505   c_if1 = XCNEW (gfc_code);
 506   c_if1->op = EXEC_IF;
 507   c_if1->block = c_if2;
 508   c_if1->loc = co->loc;
 509
 510   /* Make the DO WHILE loop into a DO block by replacing the condition
 511      with a true constant.  */
 512   co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
 513
 514   /* Hang the generated if statement into the loop body.  */
 515
 516   loopblock = co->block->next;
 517   co->block->next = c_if1;
 518   c_if1->next = loopblock;
 519
 520   return 0;
 521 }
 522
 523 /* Code callback function for converting
 524    if (a) then
 525    ...
 526    else if (b) then
 527    end if
 528
 529    into
 530    if (a) then
 531    else
 532      if (b) then
 533      end if
 534    end if
 535
 536    because otherwise common function elimination would place the BLOCKs
 537    into the wrong place.  */
 538
 539 static int
 540 convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 541                 void *data ATTRIBUTE_UNUSED)
 542 {
 543   gfc_code *co = *c;
 544   gfc_code *c_if1, *c_if2, *else_stmt;
 545
 546   if (co->op != EXEC_IF)
 547     return 0;
 548
 549   /* This loop starts out with the first ELSE statement.  */
 550   else_stmt = co->block->block;
 551
 552   while (else_stmt != NULL)
 553     {
 554       gfc_code *next_else;
 555
 556       /* If there is no condition, we're done.  */
 557       if (else_stmt->expr1 == NULL)
 558         break;
 559
 560       next_else = else_stmt->block;
 561
 562       /* Generate the new IF statement.  */
 563       c_if2 = XCNEW (gfc_code);
 564       c_if2->op = EXEC_IF;
 565       c_if2->expr1 = else_stmt->expr1;
 566       c_if2->next = else_stmt->next;
 567       c_if2->loc = else_stmt->loc;
 568       c_if2->block = next_else;
 569
 570       /* ... plus the one to chain it to.  */
 571       c_if1 = XCNEW (gfc_code);
 572       c_if1->op = EXEC_IF;
 573       c_if1->block = c_if2;
 574       c_if1->loc = else_stmt->loc;
 575
 576       /* Insert the new IF after the ELSE.  */
 577       else_stmt->expr1 = NULL;
 578       else_stmt->next = c_if1;
 579       else_stmt->block = NULL;
 580
 581       else_stmt = next_else;
 582     }
 583   /*  Don't walk subtrees.  */
 584   return 0;
 585 }
 586 /* Optimize a namespace, including all contained namespaces.  */
 587
 588 static void
 589 optimize_namespace (gfc_namespace *ns)
 590 {
 591
 592   current_ns = ns;
 593   forall_level = 0;
 594   iterator_level = 0;
 595   in_omp_workshare = false;
 596
 597   gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
 598   gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
 599   gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
 600   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
 601
 602   /* BLOCKs are handled in the expression walker below.  */
 603   for (ns = ns->contained; ns; ns = ns->sibling)
 604     {
 605       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
 606         optimize_namespace (ns);
 607     }
 608 }
 609
 610 /* Replace code like
 611    a = matmul(b,c) + d
 612    with
 613    a = matmul(b,c) ;   a = a + d
 614    where the array function is not elemental and not allocatable
 615    and does not depend on the left-hand side.
 616 */
 617
 618 static bool
 619 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
 620 {
 621   gfc_expr *e;
 622
 623   e = *rhs;
 624   if (e->expr_type == EXPR_OP)
 625     {
 626       switch (e->value.op.op)
 627         {
 628           /* Unary operators and exponentiation: Only look at a single
 629              operand.  */
 630         case INTRINSIC_NOT:
 631         case INTRINSIC_UPLUS:
 632         case INTRINSIC_UMINUS:
 633         case INTRINSIC_PARENTHESES:
 634         case INTRINSIC_POWER:
 635           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
 636             return true;
 637           break;
 638
 639         default:
 640           /* Binary operators.  */
 641           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
 642             return true;
 643
 644           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
 645             return true;
 646
 647           break;
 648         }
 649     }
 650   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
 651            && ! (e->value.function.esym
 652                  && (e->value.function.esym->attr.elemental
 653                      || e->value.function.esym->attr.allocatable
 654                      || e->value.function.esym->ts.type != c->expr1->ts.type
 655                      || e->value.function.esym->ts.kind != c->expr1->ts.kind))
 656            && ! (e->value.function.isym
 657                  && (e->value.function.isym->elemental
 658                      || e->ts.type != c->expr1->ts.type
 659                      || e->ts.kind != c->expr1->ts.kind))
 660            && ! gfc_inline_intrinsic_function_p (e))
 661     {
 662
 663       gfc_code *n;
 664       gfc_expr *new_expr;
 665
 666       /* Insert a new assignment statement after the current one.  */
 667       n = XCNEW (gfc_code);
 668       n->op = EXEC_ASSIGN;
 669       n->loc = c->loc;
 670       n->next = c->next;
 671       c->next = n;
 672
 673       n->expr1 = gfc_copy_expr (c->expr1);
 674       n->expr2 = c->expr2;
 675       new_expr = gfc_copy_expr (c->expr1);
 676       c->expr2 = e;
 677       *rhs = new_expr;
 678
 679       return true;
 680
 681     }
 682
 683   /* Nothing to optimize.  */
 684   return false;
 685 }
 686
 687 /* Remove unneeded TRIMs at the end of expressions.  */
 688
 689 static bool
 690 remove_trim (gfc_expr *rhs)
 691 {
 692   bool ret;
 693
 694   ret = false;
 695
 696   /* Check for a // b // trim(c).  Looping is probably not
 697      necessary because the parser usually generates
 698      (// (// a b ) trim(c) ) , but better safe than sorry.  */
 699
 700   while (rhs->expr_type == EXPR_OP
 701          && rhs->value.op.op == INTRINSIC_CONCAT)
 702     rhs = rhs->value.op.op2;
 703
 704   while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
 705          && rhs->value.function.isym->id == GFC_ISYM_TRIM)
 706     {
 707       strip_function_call (rhs);
 708       /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
 709       remove_trim (rhs);
 710       ret = true;
 711     }
 712
 713   return ret;
 714 }
 715
 716 /* Optimizations for an assignment.  */
 717
 718 static void
 719 optimize_assignment (gfc_code * c)
 720 {
 721   gfc_expr *lhs, *rhs;
 722
 723   lhs = c->expr1;
 724   rhs = c->expr2;
 725
 726   /* Optimize away a = trim(b), where a is a character variable.  */
 727
 728   if (lhs->ts.type == BT_CHARACTER)
 729     remove_trim (rhs);
 730
 731   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 732     optimize_binop_array_assignment (c, &rhs, false);
 733 }
 734
 735
 736 /* Remove an unneeded function call, modifying the expression.
 737    This replaces the function call with the value of its
 738    first argument.  The rest of the argument list is freed.  */
 739
 740 static void
 741 strip_function_call (gfc_expr *e)
 742 {
 743   gfc_expr *e1;
 744   gfc_actual_arglist *a;
 745
 746   a = e->value.function.actual;
 747
 748   /* We should have at least one argument.  */
 749   gcc_assert (a->expr != NULL);
 750
 751   e1 = a->expr;
 752
 753   /* Free the remaining arglist, if any.  */
 754   if (a->next)
 755     gfc_free_actual_arglist (a->next);
 756
 757   /* Graft the argument expression onto the original function.  */
 758   *e = *e1;
 759   free (e1);
 760
 761 }
 762
 763 /* Optimization of lexical comparison functions.  */
 764
 765 static bool
 766 optimize_lexical_comparison (gfc_expr *e)
 767 {
 768   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
 769     return false;
 770
 771   switch (e->value.function.isym->id)
 772     {
 773     case GFC_ISYM_LLE:
 774       return optimize_comparison (e, INTRINSIC_LE);
 775
 776     case GFC_ISYM_LGE:
 777       return optimize_comparison (e, INTRINSIC_GE);
 778
 779     case GFC_ISYM_LGT:
 780       return optimize_comparison (e, INTRINSIC_GT);
 781
 782     case GFC_ISYM_LLT:
 783       return optimize_comparison (e, INTRINSIC_LT);
 784
 785     default:
 786       break;
 787     }
 788   return false;
 789 }
 790
 791 /* Recursive optimization of operators.  */
 792
 793 static bool
 794 optimize_op (gfc_expr *e)
 795 {
 796   gfc_intrinsic_op op = e->value.op.op;
 797
 798   switch (op)
 799     {
 800     case INTRINSIC_EQ:
 801     case INTRINSIC_EQ_OS:
 802     case INTRINSIC_GE:
 803     case INTRINSIC_GE_OS:
 804     case INTRINSIC_LE:
 805     case INTRINSIC_LE_OS:
 806     case INTRINSIC_NE:
 807     case INTRINSIC_NE_OS:
 808     case INTRINSIC_GT:
 809     case INTRINSIC_GT_OS:
 810     case INTRINSIC_LT:
 811     case INTRINSIC_LT_OS:
 812       return optimize_comparison (e, op);
 813
 814     default:
 815       break;
 816     }
 817
 818   return false;
 819 }
 820
 821 /* Optimize expressions for equality.  */
 822
 823 static bool
 824 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
 825 {
 826   gfc_expr *op1, *op2;
 827   bool change;
 828   int eq;
 829   bool result;
 830   gfc_actual_arglist *firstarg, *secondarg;
 831
 832   if (e->expr_type == EXPR_OP)
 833     {
 834       firstarg = NULL;
 835       secondarg = NULL;
 836       op1 = e->value.op.op1;
 837       op2 = e->value.op.op2;
 838     }
 839   else if (e->expr_type == EXPR_FUNCTION)
 840     {
 841       /* One of the lexical comparision functions.  */
 842       firstarg = e->value.function.actual;
 843       secondarg = firstarg->next;
 844       op1 = firstarg->expr;
 845       op2 = secondarg->expr;
 846     }
 847   else
 848     gcc_unreachable ();
 849
 850   /* Strip off unneeded TRIM calls from string comparisons.  */
 851
 852   change = remove_trim (op1);
 853
 854   if (remove_trim (op2))
 855     change = true;
 856
 857   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 858   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 859      handles them well). However, there are also cases that need a non-scalar
 860      argument. For example the any intrinsic. See PR 45380.  */
 861   if (e->rank > 0)
 862     return change;
 863
 864   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 865
 866   if (flag_finite_math_only
 867       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 868           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
 869     {
 870       eq = gfc_dep_compare_expr (op1, op2);
 871       if (eq <= -2)
 872         {
 873           /* Replace A // B < A // C with B < C, and A // B < C // B
 874              with A < C.  */
 875           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 876               && op1->value.op.op == INTRINSIC_CONCAT
 877               && op2->value.op.op == INTRINSIC_CONCAT)
 878             {
 879               gfc_expr *op1_left = op1->value.op.op1;
 880               gfc_expr *op2_left = op2->value.op.op1;
 881               gfc_expr *op1_right = op1->value.op.op2;
 882               gfc_expr *op2_right = op2->value.op.op2;
 883
 884               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
 885                 {
 886                   /* Watch out for 'A ' // x vs. 'A' // x.  */
 887
 888                   if (op1_left->expr_type == EXPR_CONSTANT
 889                         && op2_left->expr_type == EXPR_CONSTANT
 890                         && op1_left->value.character.length
 891                            != op2_left->value.character.length)
 892                     return change;
 893                   else
 894                     {
 895                       free (op1_left);
 896                       free (op2_left);
 897                       if (firstarg)
 898                         {
 899                           firstarg->expr = op1_right;
 900                           secondarg->expr = op2_right;
 901                         }
 902                       else
 903                         {
 904                           e->value.op.op1 = op1_right;
 905                           e->value.op.op2 = op2_right;
 906                         }
 907                       optimize_comparison (e, op);
 908                       return true;
 909                     }
 910                 }
 911               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
 912                 {
 913                   free (op1_right);
 914                   free (op2_right);
 915                   if (firstarg)
 916                     {
 917                       firstarg->expr = op1_left;
 918                       secondarg->expr = op2_left;
 919                     }
 920                   else
 921                     {
 922                       e->value.op.op1 = op1_left;
 923                       e->value.op.op2 = op2_left;
 924                     }
 925
 926                   optimize_comparison (e, op);
 927                   return true;
 928                 }
 929             }
 930         }
 931       else
 932         {
 933           /* eq can only be -1, 0 or 1 at this point.  */
 934           switch (op)
 935             {
 936             case INTRINSIC_EQ:
 937             case INTRINSIC_EQ_OS:
 938               result = eq == 0;
 939               break;
 940
 941             case INTRINSIC_GE:
 942             case INTRINSIC_GE_OS:
 943               result = eq >= 0;
 944               break;
 945
 946             case INTRINSIC_LE:
 947             case INTRINSIC_LE_OS:
 948               result = eq <= 0;
 949               break;
 950
 951             case INTRINSIC_NE:
 952             case INTRINSIC_NE_OS:
 953               result = eq != 0;
 954               break;
 955
 956             case INTRINSIC_GT:
 957             case INTRINSIC_GT_OS:
 958               result = eq > 0;
 959               break;
 960
 961             case INTRINSIC_LT:
 962             case INTRINSIC_LT_OS:
 963               result = eq < 0;
 964               break;
 965
 966             default:
 967               gfc_internal_error ("illegal OP in optimize_comparison");
 968               break;
 969             }
 970
 971           /* Replace the expression by a constant expression.  The typespec
 972              and where remains the way it is.  */
 973           free (op1);
 974           free (op2);
 975           e->expr_type = EXPR_CONSTANT;
 976           e->value.logical = result;
 977           return true;
 978         }
 979     }
 980
 981   return change;
 982 }
 983
 984 /* Optimize a trim function by replacing it with an equivalent substring
 985    involving a call to len_trim.  This only works for expressions where
 986    variables are trimmed.  Return true if anything was modified.  */
 987
 988 static bool
 989 optimize_trim (gfc_expr *e)
 990 {
 991   gfc_expr *a;
 992   gfc_ref *ref;
 993   gfc_expr *fcn;
 994   gfc_actual_arglist *actual_arglist, *next;
 995   gfc_ref **rr = NULL;
 996
 997   /* Don't do this optimization within an argument list, because
 998      otherwise aliasing issues may occur.  */
 999
1000   if (count_arglist != 1)
1001     return false;
1002
1003   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
1004       || e->value.function.isym == NULL
1005       || e->value.function.isym->id != GFC_ISYM_TRIM)
1006     return false;
1007
1008   a = e->value.function.actual->expr;
1009
1010   if (a->expr_type != EXPR_VARIABLE)
1011     return false;
1012
1013   /* Follow all references to find the correct place to put the newly
1014      created reference.  FIXME:  Also handle substring references and
1015      array references.  Array references cause strange regressions at
1016      the moment.  */
1017
1018   if (a->ref)
1019     {
1020       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
1021         {
1022           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
1023             return false;
1024         }
1025     }
1026
1027   strip_function_call (e);
1028
1029   if (e->ref == NULL)
1030     rr = &(e->ref);
1031
1032   /* Create the reference.  */
1033
1034   ref = gfc_get_ref ();
1035   ref->type = REF_SUBSTRING;
1036
1037   /* Set the start of the reference.  */
1038
1039   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1040
1041   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
1042
1043   fcn = gfc_get_expr ();
1044   fcn->expr_type = EXPR_FUNCTION;
1045   fcn->value.function.isym =
1046     gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1047   actual_arglist = gfc_get_actual_arglist ();
1048   actual_arglist->expr = gfc_copy_expr (e);
1049   next = gfc_get_actual_arglist ();
1050   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
1051                                  gfc_default_integer_kind);
1052   actual_arglist->next = next;
1053   fcn->value.function.actual = actual_arglist;
1054
1055   /* Set the end of the reference to the call to len_trim.  */
1056
1057   ref->u.ss.end = fcn;
1058   gcc_assert (*rr == NULL);
1059   *rr = ref;
1060   return true;
1061 }
1062
1063 /* Optimize minloc(b), where b is rank 1 array, into
1064    (/ minloc(b, dim=1) /), and similarly for maxloc,
1065    as the latter forms are expanded inline.  */
1066
1067 static void
1068 optimize_minmaxloc (gfc_expr **e)
1069 {
1070   gfc_expr *fn = *e;
1071   gfc_actual_arglist *a;
1072   char *name, *p;
1073
1074   if (fn->rank != 1
1075       || fn->value.function.actual == NULL
1076       || fn->value.function.actual->expr == NULL
1077       || fn->value.function.actual->expr->rank != 1)
1078     return;
1079
1080   *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
1081   (*e)->shape = fn->shape;
1082   fn->rank = 0;
1083   fn->shape = NULL;
1084   gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
1085
1086   name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
1087   strcpy (name, fn->value.function.name);
1088   p = strstr (name, "loc0");
1089   p[3] = '1';
1090   fn->value.function.name = gfc_get_string (name);
1091   if (fn->value.function.actual->next)
1092     {
1093       a = fn->value.function.actual->next;
1094       gcc_assert (a->expr == NULL);
1095     }
1096   else
1097     {
1098       a = gfc_get_actual_arglist ();
1099       fn->value.function.actual->next = a;
1100     }
1101   a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1102                                    &fn->where);
1103   mpz_set_ui (a->expr->value.integer, 1);
1104 }
1105
1106 #define WALK_SUBEXPR(NODE) \
1107   do                                                    \
1108     {                                                   \
1109       result = gfc_expr_walker (&(NODE), exprfn, data); \
1110       if (result)                                       \
1111         return result;                                  \
1112     }                                                   \
1113   while (0)
1114 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1115
1116 /* Walk expression *E, calling EXPRFN on each expression in it.  */
1117
1118 int
1119 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
1120 {
1121   while (*e)
1122     {
1123       int walk_subtrees = 1;
1124       gfc_actual_arglist *a;
1125       gfc_ref *r;
1126       gfc_constructor *c;
1127
1128       int result = exprfn (e, &walk_subtrees, data);
1129       if (result)
1130         return result;
1131       if (walk_subtrees)
1132         switch ((*e)->expr_type)
1133           {
1134           case EXPR_OP:
1135             WALK_SUBEXPR ((*e)->value.op.op1);
1136             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
1137             break;
1138           case EXPR_FUNCTION:
1139             for (a = (*e)->value.function.actual; a; a = a->next)
1140               WALK_SUBEXPR (a->expr);
1141             break;
1142           case EXPR_COMPCALL:
1143           case EXPR_PPC:
1144             WALK_SUBEXPR ((*e)->value.compcall.base_object);
1145             for (a = (*e)->value.compcall.actual; a; a = a->next)
1146               WALK_SUBEXPR (a->expr);
1147             break;
1148
1149           case EXPR_STRUCTURE:
1150           case EXPR_ARRAY:
1151             for (c = gfc_constructor_first ((*e)->value.constructor); c;
1152                  c = gfc_constructor_next (c))
1153               {
1154                 if (c->iterator == NULL)
1155                   WALK_SUBEXPR (c->expr);
1156                 else
1157                   {
1158                     iterator_level ++;
1159                     WALK_SUBEXPR (c->expr);
1160                     iterator_level --;
1161                     WALK_SUBEXPR (c->iterator->var);
1162                     WALK_SUBEXPR (c->iterator->start);
1163                     WALK_SUBEXPR (c->iterator->end);
1164                     WALK_SUBEXPR (c->iterator->step);
1165                   }
1166               }
1167
1168             if ((*e)->expr_type != EXPR_ARRAY)
1169               break;
1170
1171             /* Fall through to the variable case in order to walk the
1172                reference.  */
1173
1174           case EXPR_SUBSTRING:
1175           case EXPR_VARIABLE:
1176             for (r = (*e)->ref; r; r = r->next)
1177               {
1178                 gfc_array_ref *ar;
1179                 int i;
1180
1181                 switch (r->type)
1182                   {
1183                   case REF_ARRAY:
1184                     ar = &r->u.ar;
1185                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
1186                       {
1187                         for (i=0; i< ar->dimen; i++)
1188                           {
1189                             WALK_SUBEXPR (ar->start[i]);
1190                             WALK_SUBEXPR (ar->end[i]);
1191                             WALK_SUBEXPR (ar->stride[i]);
1192                           }
1193                       }
1194
1195                     break;
1196
1197                   case REF_SUBSTRING:
1198                     WALK_SUBEXPR (r->u.ss.start);
1199                     WALK_SUBEXPR (r->u.ss.end);
1200                     break;
1201
1202                   case REF_COMPONENT:
1203                     break;
1204                   }
1205               }
1206
1207           default:
1208             break;
1209           }
1210       return 0;
1211     }
1212   return 0;
1213 }
1214
1215 #define WALK_SUBCODE(NODE) \
1216   do                                                            \
1217     {                                                           \
1218       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1219       if (result)                                               \
1220         return result;                                          \
1221     }                                                           \
1222   while (0)
1223
1224 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1225    on each expression in it.  If any of the hooks returns non-zero, that
1226    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
1227    no subcodes or subexpressions are traversed.  */
1228
1229 int
1230 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
1231                  void *data)
1232 {
1233   for (; *c; c = &(*c)->next)
1234     {
1235       int walk_subtrees = 1;
1236       int result = codefn (c, &walk_subtrees, data);
1237       if (result)
1238         return result;
1239
1240       if (walk_subtrees)
1241         {
1242           gfc_code *b;
1243           gfc_actual_arglist *a;
1244           gfc_code *co;
1245           gfc_association_list *alist;
1246           bool saved_in_omp_workshare;
1247
1248           /* There might be statement insertions before the current code,
1249              which must not affect the expression walker.  */
1250
1251           co = *c;
1252           saved_in_omp_workshare = in_omp_workshare;
1253
1254           switch (co->op)
1255             {
1256
1257             case EXEC_BLOCK:
1258               WALK_SUBCODE (co->ext.block.ns->code);
1259               for (alist = co->ext.block.assoc; alist; alist = alist->next)
1260                 WALK_SUBEXPR (alist->target);
1261               break;
1262
1263             case EXEC_DO:
1264               WALK_SUBEXPR (co->ext.iterator->var);
1265               WALK_SUBEXPR (co->ext.iterator->start);
1266               WALK_SUBEXPR (co->ext.iterator->end);
1267               WALK_SUBEXPR (co->ext.iterator->step);
1268               break;
1269
1270             case EXEC_CALL:
1271             case EXEC_ASSIGN_CALL:
1272               for (a = co->ext.actual; a; a = a->next)
1273                 WALK_SUBEXPR (a->expr);
1274               break;
1275
1276             case EXEC_CALL_PPC:
1277               WALK_SUBEXPR (co->expr1);
1278               for (a = co->ext.actual; a; a = a->next)
1279                 WALK_SUBEXPR (a->expr);
1280               break;
1281
1282             case EXEC_SELECT:
1283               WALK_SUBEXPR (co->expr1);
1284               for (b = co->block; b; b = b->block)
1285                 {
1286                   gfc_case *cp;
1287                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
1288                     {
1289                       WALK_SUBEXPR (cp->low);
1290                       WALK_SUBEXPR (cp->high);
1291                     }
1292                   WALK_SUBCODE (b->next);
1293                 }
1294               continue;
1295
1296             case EXEC_ALLOCATE:
1297             case EXEC_DEALLOCATE:
1298               {
1299                 gfc_alloc *a;
1300                 for (a = co->ext.alloc.list; a; a = a->next)
1301                   WALK_SUBEXPR (a->expr);
1302                 break;
1303               }
1304
1305             case EXEC_FORALL:
1306             case EXEC_DO_CONCURRENT:
1307               {
1308                 gfc_forall_iterator *fa;
1309                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
1310                   {
1311                     WALK_SUBEXPR (fa->var);
1312                     WALK_SUBEXPR (fa->start);
1313                     WALK_SUBEXPR (fa->end);
1314                     WALK_SUBEXPR (fa->stride);
1315                   }
1316                 if (co->op == EXEC_FORALL)
1317                   forall_level ++;
1318                 break;
1319               }
1320
1321             case EXEC_OPEN:
1322               WALK_SUBEXPR (co->ext.open->unit);
1323               WALK_SUBEXPR (co->ext.open->file);
1324               WALK_SUBEXPR (co->ext.open->status);
1325               WALK_SUBEXPR (co->ext.open->access);
1326               WALK_SUBEXPR (co->ext.open->form);
1327               WALK_SUBEXPR (co->ext.open->recl);
1328               WALK_SUBEXPR (co->ext.open->blank);
1329               WALK_SUBEXPR (co->ext.open->position);
1330               WALK_SUBEXPR (co->ext.open->action);
1331               WALK_SUBEXPR (co->ext.open->delim);
1332               WALK_SUBEXPR (co->ext.open->pad);
1333               WALK_SUBEXPR (co->ext.open->iostat);
1334               WALK_SUBEXPR (co->ext.open->iomsg);
1335               WALK_SUBEXPR (co->ext.open->convert);
1336               WALK_SUBEXPR (co->ext.open->decimal);
1337               WALK_SUBEXPR (co->ext.open->encoding);
1338               WALK_SUBEXPR (co->ext.open->round);
1339               WALK_SUBEXPR (co->ext.open->sign);
1340               WALK_SUBEXPR (co->ext.open->asynchronous);
1341               WALK_SUBEXPR (co->ext.open->id);
1342               WALK_SUBEXPR (co->ext.open->newunit);
1343               break;
1344
1345             case EXEC_CLOSE:
1346               WALK_SUBEXPR (co->ext.close->unit);
1347               WALK_SUBEXPR (co->ext.close->status);
1348               WALK_SUBEXPR (co->ext.close->iostat);
1349               WALK_SUBEXPR (co->ext.close->iomsg);
1350               break;
1351
1352             case EXEC_BACKSPACE:
1353             case EXEC_ENDFILE:
1354             case EXEC_REWIND:
1355             case EXEC_FLUSH:
1356               WALK_SUBEXPR (co->ext.filepos->unit);
1357               WALK_SUBEXPR (co->ext.filepos->iostat);
1358               WALK_SUBEXPR (co->ext.filepos->iomsg);
1359               break;
1360
1361             case EXEC_INQUIRE:
1362               WALK_SUBEXPR (co->ext.inquire->unit);
1363               WALK_SUBEXPR (co->ext.inquire->file);
1364               WALK_SUBEXPR (co->ext.inquire->iomsg);
1365               WALK_SUBEXPR (co->ext.inquire->iostat);
1366               WALK_SUBEXPR (co->ext.inquire->exist);
1367               WALK_SUBEXPR (co->ext.inquire->opened);
1368               WALK_SUBEXPR (co->ext.inquire->number);
1369               WALK_SUBEXPR (co->ext.inquire->named);
1370               WALK_SUBEXPR (co->ext.inquire->name);
1371               WALK_SUBEXPR (co->ext.inquire->access);
1372               WALK_SUBEXPR (co->ext.inquire->sequential);
1373               WALK_SUBEXPR (co->ext.inquire->direct);
1374               WALK_SUBEXPR (co->ext.inquire->form);
1375               WALK_SUBEXPR (co->ext.inquire->formatted);
1376               WALK_SUBEXPR (co->ext.inquire->unformatted);
1377               WALK_SUBEXPR (co->ext.inquire->recl);
1378               WALK_SUBEXPR (co->ext.inquire->nextrec);
1379               WALK_SUBEXPR (co->ext.inquire->blank);
1380               WALK_SUBEXPR (co->ext.inquire->position);
1381               WALK_SUBEXPR (co->ext.inquire->action);
1382               WALK_SUBEXPR (co->ext.inquire->read);
1383               WALK_SUBEXPR (co->ext.inquire->write);
1384               WALK_SUBEXPR (co->ext.inquire->readwrite);
1385               WALK_SUBEXPR (co->ext.inquire->delim);
1386               WALK_SUBEXPR (co->ext.inquire->encoding);
1387               WALK_SUBEXPR (co->ext.inquire->pad);
1388               WALK_SUBEXPR (co->ext.inquire->iolength);
1389               WALK_SUBEXPR (co->ext.inquire->convert);
1390               WALK_SUBEXPR (co->ext.inquire->strm_pos);
1391               WALK_SUBEXPR (co->ext.inquire->asynchronous);
1392               WALK_SUBEXPR (co->ext.inquire->decimal);
1393               WALK_SUBEXPR (co->ext.inquire->pending);
1394               WALK_SUBEXPR (co->ext.inquire->id);
1395               WALK_SUBEXPR (co->ext.inquire->sign);
1396               WALK_SUBEXPR (co->ext.inquire->size);
1397               WALK_SUBEXPR (co->ext.inquire->round);
1398               break;
1399
1400             case EXEC_WAIT:
1401               WALK_SUBEXPR (co->ext.wait->unit);
1402               WALK_SUBEXPR (co->ext.wait->iostat);
1403               WALK_SUBEXPR (co->ext.wait->iomsg);
1404               WALK_SUBEXPR (co->ext.wait->id);
1405               break;
1406
1407             case EXEC_READ:
1408             case EXEC_WRITE:
1409               WALK_SUBEXPR (co->ext.dt->io_unit);
1410               WALK_SUBEXPR (co->ext.dt->format_expr);
1411               WALK_SUBEXPR (co->ext.dt->rec);
1412               WALK_SUBEXPR (co->ext.dt->advance);
1413               WALK_SUBEXPR (co->ext.dt->iostat);
1414               WALK_SUBEXPR (co->ext.dt->size);
1415               WALK_SUBEXPR (co->ext.dt->iomsg);
1416               WALK_SUBEXPR (co->ext.dt->id);
1417               WALK_SUBEXPR (co->ext.dt->pos);
1418               WALK_SUBEXPR (co->ext.dt->asynchronous);
1419               WALK_SUBEXPR (co->ext.dt->blank);
1420               WALK_SUBEXPR (co->ext.dt->decimal);
1421               WALK_SUBEXPR (co->ext.dt->delim);
1422               WALK_SUBEXPR (co->ext.dt->pad);
1423               WALK_SUBEXPR (co->ext.dt->round);
1424               WALK_SUBEXPR (co->ext.dt->sign);
1425               WALK_SUBEXPR (co->ext.dt->extra_comma);
1426               break;
1427
1428             case EXEC_OMP_PARALLEL:
1429             case EXEC_OMP_PARALLEL_DO:
1430             case EXEC_OMP_PARALLEL_SECTIONS:
1431
1432               in_omp_workshare = false;
1433
1434               /* This goto serves as a shortcut to avoid code
1435                  duplication or a larger if or switch statement.  */
1436               goto check_omp_clauses;
1437
1438             case EXEC_OMP_WORKSHARE:
1439             case EXEC_OMP_PARALLEL_WORKSHARE:
1440
1441               in_omp_workshare = true;
1442
1443               /* Fall through  */
1444
1445             case EXEC_OMP_DO:
1446             case EXEC_OMP_SECTIONS:
1447             case EXEC_OMP_SINGLE:
1448             case EXEC_OMP_END_SINGLE:
1449             case EXEC_OMP_TASK:
1450
1451               /* Come to this label only from the
1452                  EXEC_OMP_PARALLEL_* cases above.  */
1453
1454             check_omp_clauses:
1455
1456               if (co->ext.omp_clauses)
1457                 {
1458                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
1459                   WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
1460                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
1461                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
1462                 }
1463               break;
1464             default:
1465               break;
1466             }
1467
1468           WALK_SUBEXPR (co->expr1);
1469           WALK_SUBEXPR (co->expr2);
1470           WALK_SUBEXPR (co->expr3);
1471           WALK_SUBEXPR (co->expr4);
1472           for (b = co->block; b; b = b->block)
1473             {
1474               WALK_SUBEXPR (b->expr1);
1475               WALK_SUBEXPR (b->expr2);
1476               WALK_SUBCODE (b->next);
1477             }
1478
1479           if (co->op == EXEC_FORALL)
1480             forall_level --;
1481
1482           in_omp_workshare = saved_in_omp_workshare;
1483         }
1484     }
1485   return 0;
1486 }