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