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