gcc/fortran/frontend-passes.c

   1 /* Pass manager for Fortran front end.
   2    Copyright (C) 2010-2014 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 "coretypes.h"
  24 #include "gfortran.h"
  25 #include "arith.h"
  26 #include "flags.h"
  27 #include "dependency.h"
  28 #include "constructor.h"
  29 #include "opts.h"
  30
  31 /* Forward declarations.  */
  32
  33 static void strip_function_call (gfc_expr *);
  34 static void optimize_namespace (gfc_namespace *);
  35 static void optimize_assignment (gfc_code *);
  36 static bool optimize_op (gfc_expr *);
  37 static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
  38 static bool optimize_trim (gfc_expr *);
  39 static bool optimize_lexical_comparison (gfc_expr *);
  40 static void optimize_minmaxloc (gfc_expr **);
  41 static bool is_empty_string (gfc_expr *e);
  42 static void doloop_warn (gfc_namespace *);
  43 static void optimize_reduction (gfc_namespace *);
  44 static int callback_reduction (gfc_expr **, int *, void *);
  45
  46 /* How deep we are inside an argument list.  */
  47
  48 static int count_arglist;
  49
  50 /* Pointer to an array of gfc_expr ** we operate on, plus its size
  51    and counter.  */
  52
  53 static gfc_expr ***expr_array;
  54 static int expr_size, expr_count;
  55
  56 /* Pointer to the gfc_code we currently work on - to be able to insert
  57    a block before the statement.  */
  58
  59 static gfc_code **current_code;
  60
  61 /* Pointer to the block to be inserted, and the statement we are
  62    changing within the block.  */
  63
  64 static gfc_code *inserted_block, **changed_statement;
  65
  66 /* The namespace we are currently dealing with.  */
  67
  68 static gfc_namespace *current_ns;
  69
  70 /* If we are within any forall loop.  */
  71
  72 static int forall_level;
  73
  74 /* Keep track of whether we are within an OMP workshare.  */
  75
  76 static bool in_omp_workshare;
  77
  78 /* Keep track of iterators for array constructors.  */
  79
  80 static int iterator_level;
  81
  82 /* Keep track of DO loop levels.  */
  83
  84 static gfc_code **doloop_list;
  85 static int doloop_size, doloop_level;
  86
  87 /* Vector of gfc_expr * to keep track of DO loops.  */
  88
  89 struct my_struct *evec;
  90
  91 /* Entry point - run all passes for a namespace. */
  92
  93 void
  94 gfc_run_passes (gfc_namespace *ns)
  95 {
  96
  97   /* Warn about dubious DO loops where the index might
  98      change.  */
  99
 100   doloop_size = 20;
 101   doloop_level = 0;
 102   doloop_list = XNEWVEC(gfc_code *, doloop_size);
 103   doloop_warn (ns);
 104   XDELETEVEC (doloop_list);
 105
 106   if (gfc_option.flag_frontend_optimize)
 107     {
 108       expr_size = 20;
 109       expr_array = XNEWVEC(gfc_expr **, expr_size);
 110
 111       optimize_namespace (ns);
 112       optimize_reduction (ns);
 113       if (gfc_option.dump_fortran_optimized)
 114         gfc_dump_parse_tree (ns, stdout);
 115
 116       XDELETEVEC (expr_array);
 117     }
 118 }
 119
 120 /* Callback for each gfc_code node invoked through gfc_code_walker
 121    from optimize_namespace.  */
 122
 123 static int
 124 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 125                void *data ATTRIBUTE_UNUSED)
 126 {
 127
 128   gfc_exec_op op;
 129
 130   op = (*c)->op;
 131
 132   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
 133       || op == EXEC_CALL_PPC)
 134     count_arglist = 1;
 135   else
 136     count_arglist = 0;
 137
 138   current_code = c;
 139   inserted_block = NULL;
 140   changed_statement = NULL;
 141
 142   if (op == EXEC_ASSIGN)
 143     optimize_assignment (*c);
 144   return 0;
 145 }
 146
 147 /* Callback for each gfc_expr node invoked through gfc_code_walker
 148    from optimize_namespace.  */
 149
 150 static int
 151 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 152                void *data ATTRIBUTE_UNUSED)
 153 {
 154   bool function_expr;
 155
 156   if ((*e)->expr_type == EXPR_FUNCTION)
 157     {
 158       count_arglist ++;
 159       function_expr = true;
 160     }
 161   else
 162     function_expr = false;
 163
 164   if (optimize_trim (*e))
 165     gfc_simplify_expr (*e, 0);
 166
 167   if (optimize_lexical_comparison (*e))
 168     gfc_simplify_expr (*e, 0);
 169
 170   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
 171     gfc_simplify_expr (*e, 0);
 172
 173   if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
 174     switch ((*e)->value.function.isym->id)
 175       {
 176       case GFC_ISYM_MINLOC:
 177       case GFC_ISYM_MAXLOC:
 178         optimize_minmaxloc (e);
 179         break;
 180       default:
 181         break;
 182       }
 183
 184   if (function_expr)
 185     count_arglist --;
 186
 187   return 0;
 188 }
 189
 190 /* Auxiliary function to handle the arguments to reduction intrnisics.  If the
 191    function is a scalar, just copy it; otherwise returns the new element, the
 192    old one can be freed.  */
 193
 194 static gfc_expr *
 195 copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
 196 {
 197   gfc_expr *fcn, *e = c->expr;
 198
 199   fcn = gfc_copy_expr (e);
 200   if (c->iterator)
 201     {
 202       gfc_constructor_base newbase;
 203       gfc_expr *new_expr;
 204       gfc_constructor *new_c;
 205
 206       newbase = NULL;
 207       new_expr = gfc_get_expr ();
 208       new_expr->expr_type = EXPR_ARRAY;
 209       new_expr->ts = e->ts;
 210       new_expr->where = e->where;
 211       new_expr->rank = 1;
 212       new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
 213       new_c->iterator = c->iterator;
 214       new_expr->value.constructor = newbase;
 215       c->iterator = NULL;
 216
 217       fcn = new_expr;
 218     }
 219
 220   if (fcn->rank != 0)
 221     {
 222       gfc_isym_id id = fn->value.function.isym->id;
 223
 224       if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
 225         fcn = gfc_build_intrinsic_call (current_ns, id,
 226                                         fn->value.function.isym->name,
 227                                         fn->where, 3, fcn, NULL, NULL);
 228       else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
 229         fcn = gfc_build_intrinsic_call (current_ns, id,
 230                                         fn->value.function.isym->name,
 231                                         fn->where, 2, fcn, NULL);
 232       else
 233         gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
 234
 235       fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
 236     }
 237
 238   return fcn;
 239 }
 240
 241 /* Callback function for optimzation of reductions to scalars.  Transform ANY
 242    ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
 243    correspondingly.  Handly only the simple cases without MASK and DIM.  */
 244
 245 static int
 246 callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 247                     void *data ATTRIBUTE_UNUSED)
 248 {
 249   gfc_expr *fn, *arg;
 250   gfc_intrinsic_op op;
 251   gfc_isym_id id;
 252   gfc_actual_arglist *a;
 253   gfc_actual_arglist *dim;
 254   gfc_constructor *c;
 255   gfc_expr *res, *new_expr;
 256   gfc_actual_arglist *mask;
 257
 258   fn = *e;
 259
 260   if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
 261       || fn->value.function.isym == NULL)
 262     return 0;
 263
 264   id = fn->value.function.isym->id;
 265
 266   if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
 267       && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
 268     return 0;
 269
 270   a = fn->value.function.actual;
 271
 272   /* Don't handle MASK or DIM.  */
 273
 274   dim = a->next;
 275
 276   if (dim->expr != NULL)
 277     return 0;
 278
 279   if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
 280     {
 281       mask = dim->next;
 282       if ( mask->expr != NULL)
 283         return 0;
 284     }
 285
 286   arg = a->expr;
 287
 288   if (arg->expr_type != EXPR_ARRAY)
 289     return 0;
 290
 291   switch (id)
 292     {
 293     case GFC_ISYM_SUM:
 294       op = INTRINSIC_PLUS;
 295       break;
 296
 297     case GFC_ISYM_PRODUCT:
 298       op = INTRINSIC_TIMES;
 299       break;
 300
 301     case GFC_ISYM_ANY:
 302       op = INTRINSIC_OR;
 303       break;
 304
 305     case GFC_ISYM_ALL:
 306       op = INTRINSIC_AND;
 307       break;
 308
 309     default:
 310       return 0;
 311     }
 312
 313   c = gfc_constructor_first (arg->value.constructor);
 314
 315   /* Don't do any simplififcation if we have
 316      - no element in the constructor or
 317      - only have a single element in the array which contains an
 318      iterator.  */
 319
 320   if (c == NULL)
 321     return 0;
 322
 323   res = copy_walk_reduction_arg (c, fn);
 324
 325   c = gfc_constructor_next (c);
 326   while (c)
 327     {
 328       new_expr = gfc_get_expr ();
 329       new_expr->ts = fn->ts;
 330       new_expr->expr_type = EXPR_OP;
 331       new_expr->rank = fn->rank;
 332       new_expr->where = fn->where;
 333       new_expr->value.op.op = op;
 334       new_expr->value.op.op1 = res;
 335       new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
 336       res = new_expr;
 337       c = gfc_constructor_next (c);
 338     }
 339
 340   gfc_simplify_expr (res, 0);
 341   *e = res;
 342   gfc_free_expr (fn);
 343
 344   return 0;
 345 }
 346
 347 /* Callback function for common function elimination, called from cfe_expr_0.
 348    Put all eligible function expressions into expr_array.  */
 349
 350 static int
 351 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 352           void *data ATTRIBUTE_UNUSED)
 353 {
 354
 355   if ((*e)->expr_type != EXPR_FUNCTION)
 356     return 0;
 357
 358   /* We don't do character functions with unknown charlens.  */
 359   if ((*e)->ts.type == BT_CHARACTER
 360       && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
 361           || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
 362     return 0;
 363
 364   /* We don't do function elimination within FORALL statements, it can
 365      lead to wrong-code in certain circumstances.  */
 366
 367   if (forall_level > 0)
 368     return 0;
 369
 370   /* Function elimination inside an iterator could lead to functions which
 371      depend on iterator variables being moved outside.  FIXME: We should check
 372      if the functions do indeed depend on the iterator variable.  */
 373
 374   if (iterator_level > 0)
 375     return 0;
 376
 377   /* If we don't know the shape at compile time, we create an allocatable
 378      temporary variable to hold the intermediate result, but only if
 379      allocation on assignment is active.  */
 380
 381   if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
 382     return 0;
 383
 384   /* Skip the test for pure functions if -faggressive-function-elimination
 385      is specified.  */
 386   if ((*e)->value.function.esym)
 387     {
 388       /* Don't create an array temporary for elemental functions.  */
 389       if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
 390         return 0;
 391
 392       /* Only eliminate potentially impure functions if the
 393          user specifically requested it.  */
 394       if (!gfc_option.flag_aggressive_function_elimination
 395           && !(*e)->value.function.esym->attr.pure
 396           && !(*e)->value.function.esym->attr.implicit_pure)
 397         return 0;
 398     }
 399
 400   if ((*e)->value.function.isym)
 401     {
 402       /* Conversions are handled on the fly by the middle end,
 403          transpose during trans-* stages and TRANSFER by the middle end.  */
 404       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
 405           || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
 406           || gfc_inline_intrinsic_function_p (*e))
 407         return 0;
 408
 409       /* Don't create an array temporary for elemental functions,
 410          as this would be wasteful of memory.
 411          FIXME: Create a scalar temporary during scalarization.  */
 412       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
 413         return 0;
 414
 415       if (!(*e)->value.function.isym->pure)
 416         return 0;
 417     }
 418
 419   if (expr_count >= expr_size)
 420     {
 421       expr_size += expr_size;
 422       expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
 423     }
 424   expr_array[expr_count] = e;
 425   expr_count ++;
 426   return 0;
 427 }
 428
 429 /* Returns a new expression (a variable) to be used in place of the old one,
 430    with an assignment statement before the current statement to set
 431    the value of the variable. Creates a new BLOCK for the statement if
 432    that hasn't already been done and puts the statement, plus the
 433    newly created variables, in that block.  */
 434
 435 static gfc_expr*
 436 create_var (gfc_expr * e)
 437 {
 438   char name[GFC_MAX_SYMBOL_LEN +1];
 439   static int num = 1;
 440   gfc_symtree *symtree;
 441   gfc_symbol *symbol;
 442   gfc_expr *result;
 443   gfc_code *n;
 444   gfc_namespace *ns;
 445   int i;
 446
 447   /* If the block hasn't already been created, do so.  */
 448   if (inserted_block == NULL)
 449     {
 450       inserted_block = XCNEW (gfc_code);
 451       inserted_block->op = EXEC_BLOCK;
 452       inserted_block->loc = (*current_code)->loc;
 453       ns = gfc_build_block_ns (current_ns);
 454       inserted_block->ext.block.ns = ns;
 455       inserted_block->ext.block.assoc = NULL;
 456
 457       ns->code = *current_code;
 458
 459       /* If the statement has a label,  make sure it is transferred to
 460          the newly created block.  */
 461
 462       if ((*current_code)->here)
 463         {
 464           inserted_block->here = (*current_code)->here;
 465           (*current_code)->here = NULL;
 466         }
 467
 468       inserted_block->next = (*current_code)->next;
 469       changed_statement = &(inserted_block->ext.block.ns->code);
 470       (*current_code)->next = NULL;
 471       /* Insert the BLOCK at the right position.  */
 472       *current_code = inserted_block;
 473       ns->parent = current_ns;
 474     }
 475   else
 476     ns = inserted_block->ext.block.ns;
 477
 478   sprintf(name, "__var_%d",num++);
 479   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
 480     gcc_unreachable ();
 481
 482   symbol = symtree->n.sym;
 483   symbol->ts = e->ts;
 484
 485   if (e->rank > 0)
 486     {
 487       symbol->as = gfc_get_array_spec ();
 488       symbol->as->rank = e->rank;
 489
 490       if (e->shape == NULL)
 491         {
 492           /* We don't know the shape at compile time, so we use an
 493              allocatable. */
 494           symbol->as->type = AS_DEFERRED;
 495           symbol->attr.allocatable = 1;
 496         }
 497       else
 498         {
 499           symbol->as->type = AS_EXPLICIT;
 500           /* Copy the shape.  */
 501           for (i=0; i<e->rank; i++)
 502             {
 503               gfc_expr *p, *q;
 504
 505               p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 506                                          &(e->where));
 507               mpz_set_si (p->value.integer, 1);
 508               symbol->as->lower[i] = p;
 509
 510               q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
 511                                          &(e->where));
 512               mpz_set (q->value.integer, e->shape[i]);
 513               symbol->as->upper[i] = q;
 514             }
 515         }
 516     }
 517
 518   symbol->attr.flavor = FL_VARIABLE;
 519   symbol->attr.referenced = 1;
 520   symbol->attr.dimension = e->rank > 0;
 521   gfc_commit_symbol (symbol);
 522
 523   result = gfc_get_expr ();
 524   result->expr_type = EXPR_VARIABLE;
 525   result->ts = e->ts;
 526   result->rank = e->rank;
 527   result->shape = gfc_copy_shape (e->shape, e->rank);
 528   result->symtree = symtree;
 529   result->where = e->where;
 530   if (e->rank > 0)
 531     {
 532       result->ref = gfc_get_ref ();
 533       result->ref->type = REF_ARRAY;
 534       result->ref->u.ar.type = AR_FULL;
 535       result->ref->u.ar.where = e->where;
 536       result->ref->u.ar.as = symbol->ts.type == BT_CLASS
 537                              ? CLASS_DATA (symbol)->as : symbol->as;
 538       if (gfc_option.warn_array_temp)
 539         gfc_warning ("Creating array temporary at %L", &(e->where));
 540     }
 541
 542   /* Generate the new assignment.  */
 543   n = XCNEW (gfc_code);
 544   n->op = EXEC_ASSIGN;
 545   n->loc = (*current_code)->loc;
 546   n->next = *changed_statement;
 547   n->expr1 = gfc_copy_expr (result);
 548   n->expr2 = e;
 549   *changed_statement = n;
 550
 551   return result;
 552 }
 553
 554 /* Warn about function elimination.  */
 555
 556 static void
 557 warn_function_elimination (gfc_expr *e)
 558 {
 559   if (e->expr_type != EXPR_FUNCTION)
 560     return;
 561   if (e->value.function.esym)
 562     gfc_warning ("Removing call to function '%s' at %L",
 563                  e->value.function.esym->name, &(e->where));
 564   else if (e->value.function.isym)
 565     gfc_warning ("Removing call to function '%s' at %L",
 566                  e->value.function.isym->name, &(e->where));
 567 }
 568 /* Callback function for the code walker for doing common function
 569    elimination.  This builds up the list of functions in the expression
 570    and goes through them to detect duplicates, which it then replaces
 571    by variables.  */
 572
 573 static int
 574 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
 575           void *data ATTRIBUTE_UNUSED)
 576 {
 577   int i,j;
 578   gfc_expr *newvar;
 579
 580   /* Don't do this optimization within OMP workshare. */
 581
 582   if (in_omp_workshare)
 583     {
 584       *walk_subtrees = 0;
 585       return 0;
 586     }
 587
 588   expr_count = 0;
 589
 590   gfc_expr_walker (e, cfe_register_funcs, NULL);
 591
 592   /* Walk through all the functions.  */
 593
 594   for (i=1; i<expr_count; i++)
 595     {
 596       /* Skip if the function has been replaced by a variable already.  */
 597       if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
 598         continue;
 599
 600       newvar = NULL;
 601       for (j=0; j<i; j++)
 602         {
 603           if (gfc_dep_compare_functions (*(expr_array[i]),
 604                                         *(expr_array[j]), true) == 0)
 605             {
 606               if (newvar == NULL)
 607                 newvar = create_var (*(expr_array[i]));
 608
 609               if (gfc_option.warn_function_elimination)
 610                 warn_function_elimination (*(expr_array[j]));
 611
 612               free (*(expr_array[j]));
 613               *(expr_array[j]) = gfc_copy_expr (newvar);
 614             }
 615         }
 616       if (newvar)
 617         *(expr_array[i]) = newvar;
 618     }
 619
 620   /* We did all the necessary walking in this function.  */
 621   *walk_subtrees = 0;
 622   return 0;
 623 }
 624
 625 /* Callback function for common function elimination, called from
 626    gfc_code_walker.  This keeps track of the current code, in order
 627    to insert statements as needed.  */
 628
 629 static int
 630 cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
 631 {
 632   current_code = c;
 633   inserted_block = NULL;
 634   changed_statement = NULL;
 635
 636   /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
 637      and allocation on assigment are prohibited inside WHERE, and finally
 638      masking an expression would lead to wrong-code when replacing
 639
 640      WHERE (a>0)
 641        b = sum(foo(a) + foo(a))
 642      END WHERE
 643
 644      with
 645
 646      WHERE (a > 0)
 647        tmp = foo(a)
 648        b = sum(tmp + tmp)
 649      END WHERE
 650 */
 651
 652   if ((*c)->op == EXEC_WHERE)
 653     {
 654       *walk_subtrees = 0;
 655       return 0;
 656     }
 657
 658
 659   return 0;
 660 }
 661
 662 /* Dummy function for expression call back, for use when we
 663    really don't want to do any walking.  */
 664
 665 static int
 666 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
 667                      void *data ATTRIBUTE_UNUSED)
 668 {
 669   *walk_subtrees = 0;
 670   return 0;
 671 }
 672
 673 /* Dummy function for code callback, for use when we really
 674    don't want to do anything.  */
 675 static int
 676 dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
 677                      int *walk_subtrees ATTRIBUTE_UNUSED,
 678                      void *data ATTRIBUTE_UNUSED)
 679 {
 680   return 0;
 681 }
 682
 683 /* Code callback function for converting
 684    do while(a)
 685    end do
 686    into the equivalent
 687    do
 688      if (.not. a) exit
 689    end do
 690    This is because common function elimination would otherwise place the
 691    temporary variables outside the loop.  */
 692
 693 static int
 694 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 695                   void *data ATTRIBUTE_UNUSED)
 696 {
 697   gfc_code *co = *c;
 698   gfc_code *c_if1, *c_if2, *c_exit;
 699   gfc_code *loopblock;
 700   gfc_expr *e_not, *e_cond;
 701
 702   if (co->op != EXEC_DO_WHILE)
 703     return 0;
 704
 705   if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
 706     return 0;
 707
 708   e_cond = co->expr1;
 709
 710   /* Generate the condition of the if statement, which is .not. the original
 711      statement.  */
 712   e_not = gfc_get_expr ();
 713   e_not->ts = e_cond->ts;
 714   e_not->where = e_cond->where;
 715   e_not->expr_type = EXPR_OP;
 716   e_not->value.op.op = INTRINSIC_NOT;
 717   e_not->value.op.op1 = e_cond;
 718
 719   /* Generate the EXIT statement.  */
 720   c_exit = XCNEW (gfc_code);
 721   c_exit->op = EXEC_EXIT;
 722   c_exit->ext.which_construct = co;
 723   c_exit->loc = co->loc;
 724
 725   /* Generate the IF statement.  */
 726   c_if2 = XCNEW (gfc_code);
 727   c_if2->op = EXEC_IF;
 728   c_if2->expr1 = e_not;
 729   c_if2->next = c_exit;
 730   c_if2->loc = co->loc;
 731
 732   /* ... plus the one to chain it to.  */
 733   c_if1 = XCNEW (gfc_code);
 734   c_if1->op = EXEC_IF;
 735   c_if1->block = c_if2;
 736   c_if1->loc = co->loc;
 737
 738   /* Make the DO WHILE loop into a DO block by replacing the condition
 739      with a true constant.  */
 740   co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
 741
 742   /* Hang the generated if statement into the loop body.  */
 743
 744   loopblock = co->block->next;
 745   co->block->next = c_if1;
 746   c_if1->next = loopblock;
 747
 748   return 0;
 749 }
 750
 751 /* Code callback function for converting
 752    if (a) then
 753    ...
 754    else if (b) then
 755    end if
 756
 757    into
 758    if (a) then
 759    else
 760      if (b) then
 761      end if
 762    end if
 763
 764    because otherwise common function elimination would place the BLOCKs
 765    into the wrong place.  */
 766
 767 static int
 768 convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 769                 void *data ATTRIBUTE_UNUSED)
 770 {
 771   gfc_code *co = *c;
 772   gfc_code *c_if1, *c_if2, *else_stmt;
 773
 774   if (co->op != EXEC_IF)
 775     return 0;
 776
 777   /* This loop starts out with the first ELSE statement.  */
 778   else_stmt = co->block->block;
 779
 780   while (else_stmt != NULL)
 781     {
 782       gfc_code *next_else;
 783
 784       /* If there is no condition, we're done.  */
 785       if (else_stmt->expr1 == NULL)
 786         break;
 787
 788       next_else = else_stmt->block;
 789
 790       /* Generate the new IF statement.  */
 791       c_if2 = XCNEW (gfc_code);
 792       c_if2->op = EXEC_IF;
 793       c_if2->expr1 = else_stmt->expr1;
 794       c_if2->next = else_stmt->next;
 795       c_if2->loc = else_stmt->loc;
 796       c_if2->block = next_else;
 797
 798       /* ... plus the one to chain it to.  */
 799       c_if1 = XCNEW (gfc_code);
 800       c_if1->op = EXEC_IF;
 801       c_if1->block = c_if2;
 802       c_if1->loc = else_stmt->loc;
 803
 804       /* Insert the new IF after the ELSE.  */
 805       else_stmt->expr1 = NULL;
 806       else_stmt->next = c_if1;
 807       else_stmt->block = NULL;
 808
 809       else_stmt = next_else;
 810     }
 811   /*  Don't walk subtrees.  */
 812   return 0;
 813 }
 814 /* Optimize a namespace, including all contained namespaces.  */
 815
 816 static void
 817 optimize_namespace (gfc_namespace *ns)
 818 {
 819
 820   current_ns = ns;
 821   forall_level = 0;
 822   iterator_level = 0;
 823   in_omp_workshare = false;
 824
 825   gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
 826   gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
 827   gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
 828   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
 829
 830   /* BLOCKs are handled in the expression walker below.  */
 831   for (ns = ns->contained; ns; ns = ns->sibling)
 832     {
 833       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
 834         optimize_namespace (ns);
 835     }
 836 }
 837
 838 static void
 839 optimize_reduction (gfc_namespace *ns)
 840 {
 841   current_ns = ns;
 842   gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
 843
 844 /* BLOCKs are handled in the expression walker below.  */
 845   for (ns = ns->contained; ns; ns = ns->sibling)
 846     {
 847       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
 848         optimize_reduction (ns);
 849     }
 850 }
 851
 852 /* Replace code like
 853    a = matmul(b,c) + d
 854    with
 855    a = matmul(b,c) ;   a = a + d
 856    where the array function is not elemental and not allocatable
 857    and does not depend on the left-hand side.
 858 */
 859
 860 static bool
 861 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
 862 {
 863   gfc_expr *e;
 864
 865   e = *rhs;
 866   if (e->expr_type == EXPR_OP)
 867     {
 868       switch (e->value.op.op)
 869         {
 870           /* Unary operators and exponentiation: Only look at a single
 871              operand.  */
 872         case INTRINSIC_NOT:
 873         case INTRINSIC_UPLUS:
 874         case INTRINSIC_UMINUS:
 875         case INTRINSIC_PARENTHESES:
 876         case INTRINSIC_POWER:
 877           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
 878             return true;
 879           break;
 880
 881         default:
 882           /* Binary operators.  */
 883           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
 884             return true;
 885
 886           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
 887             return true;
 888
 889           break;
 890         }
 891     }
 892   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
 893            && ! (e->value.function.esym
 894                  && (e->value.function.esym->attr.elemental
 895                      || e->value.function.esym->attr.allocatable
 896                      || e->value.function.esym->ts.type != c->expr1->ts.type
 897                      || e->value.function.esym->ts.kind != c->expr1->ts.kind))
 898            && ! (e->value.function.isym
 899                  && (e->value.function.isym->elemental
 900                      || e->ts.type != c->expr1->ts.type
 901                      || e->ts.kind != c->expr1->ts.kind))
 902            && ! gfc_inline_intrinsic_function_p (e))
 903     {
 904
 905       gfc_code *n;
 906       gfc_expr *new_expr;
 907
 908       /* Insert a new assignment statement after the current one.  */
 909       n = XCNEW (gfc_code);
 910       n->op = EXEC_ASSIGN;
 911       n->loc = c->loc;
 912       n->next = c->next;
 913       c->next = n;
 914
 915       n->expr1 = gfc_copy_expr (c->expr1);
 916       n->expr2 = c->expr2;
 917       new_expr = gfc_copy_expr (c->expr1);
 918       c->expr2 = e;
 919       *rhs = new_expr;
 920
 921       return true;
 922
 923     }
 924
 925   /* Nothing to optimize.  */
 926   return false;
 927 }
 928
 929 /* Remove unneeded TRIMs at the end of expressions.  */
 930
 931 static bool
 932 remove_trim (gfc_expr *rhs)
 933 {
 934   bool ret;
 935
 936   ret = false;
 937
 938   /* Check for a // b // trim(c).  Looping is probably not
 939      necessary because the parser usually generates
 940      (// (// a b ) trim(c) ) , but better safe than sorry.  */
 941
 942   while (rhs->expr_type == EXPR_OP
 943          && rhs->value.op.op == INTRINSIC_CONCAT)
 944     rhs = rhs->value.op.op2;
 945
 946   while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
 947          && rhs->value.function.isym->id == GFC_ISYM_TRIM)
 948     {
 949       strip_function_call (rhs);
 950       /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
 951       remove_trim (rhs);
 952       ret = true;
 953     }
 954
 955   return ret;
 956 }
 957
 958 /* Optimizations for an assignment.  */
 959
 960 static void
 961 optimize_assignment (gfc_code * c)
 962 {
 963   gfc_expr *lhs, *rhs;
 964
 965   lhs = c->expr1;
 966   rhs = c->expr2;
 967
 968   if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
 969     {
 970       /* Optimize  a = trim(b)  to  a = b.  */
 971       remove_trim (rhs);
 972
 973       /* Replace a = '   ' by a = '' to optimize away a memcpy.  */
 974       if (is_empty_string (rhs))
 975         rhs->value.character.length = 0;
 976     }
 977
 978   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 979     optimize_binop_array_assignment (c, &rhs, false);
 980 }
 981
 982
 983 /* Remove an unneeded function call, modifying the expression.
 984    This replaces the function call with the value of its
 985    first argument.  The rest of the argument list is freed.  */
 986
 987 static void
 988 strip_function_call (gfc_expr *e)
 989 {
 990   gfc_expr *e1;
 991   gfc_actual_arglist *a;
 992
 993   a = e->value.function.actual;
 994
 995   /* We should have at least one argument.  */
 996   gcc_assert (a->expr != NULL);
 997
 998   e1 = a->expr;
 999
1000   /* Free the remaining arglist, if any.  */
1001   if (a->next)
1002     gfc_free_actual_arglist (a->next);
1003
1004   /* Graft the argument expression onto the original function.  */
1005   *e = *e1;
1006   free (e1);
1007
1008 }
1009
1010 /* Optimization of lexical comparison functions.  */
1011
1012 static bool
1013 optimize_lexical_comparison (gfc_expr *e)
1014 {
1015   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1016     return false;
1017
1018   switch (e->value.function.isym->id)
1019     {
1020     case GFC_ISYM_LLE:
1021       return optimize_comparison (e, INTRINSIC_LE);
1022
1023     case GFC_ISYM_LGE:
1024       return optimize_comparison (e, INTRINSIC_GE);
1025
1026     case GFC_ISYM_LGT:
1027       return optimize_comparison (e, INTRINSIC_GT);
1028
1029     case GFC_ISYM_LLT:
1030       return optimize_comparison (e, INTRINSIC_LT);
1031
1032     default:
1033       break;
1034     }
1035   return false;
1036 }
1037
1038 /* Combine stuff like [a]>b into [a>b], for easier optimization later.  Do not
1039    do CHARACTER because of possible pessimization involving character
1040    lengths.  */
1041
1042 static bool
1043 combine_array_constructor (gfc_expr *e)
1044 {
1045
1046   gfc_expr *op1, *op2;
1047   gfc_expr *scalar;
1048   gfc_expr *new_expr;
1049   gfc_constructor *c, *new_c;
1050   gfc_constructor_base oldbase, newbase;
1051   bool scalar_first;
1052
1053   /* Array constructors have rank one.  */
1054   if (e->rank != 1)
1055     return false;
1056
1057   op1 = e->value.op.op1;
1058   op2 = e->value.op.op2;
1059
1060   if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1061     scalar_first = false;
1062   else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1063     {
1064       scalar_first = true;
1065       op1 = e->value.op.op2;
1066       op2 = e->value.op.op1;
1067     }
1068   else
1069     return false;
1070
1071   if (op2->ts.type == BT_CHARACTER)
1072     return false;
1073
1074   if (op2->expr_type == EXPR_CONSTANT)
1075     scalar = gfc_copy_expr (op2);
1076   else
1077     scalar = create_var (gfc_copy_expr (op2));
1078
1079   oldbase = op1->value.constructor;
1080   newbase = NULL;
1081   e->expr_type = EXPR_ARRAY;
1082
1083   for (c = gfc_constructor_first (oldbase); c;
1084        c = gfc_constructor_next (c))
1085     {
1086       new_expr = gfc_get_expr ();
1087       new_expr->ts = e->ts;
1088       new_expr->expr_type = EXPR_OP;
1089       new_expr->rank = c->expr->rank;
1090       new_expr->where = c->where;
1091       new_expr->value.op.op = e->value.op.op;
1092
1093       if (scalar_first)
1094         {
1095           new_expr->value.op.op1 = gfc_copy_expr (scalar);
1096           new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1097         }
1098       else
1099         {
1100           new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1101           new_expr->value.op.op2 = gfc_copy_expr (scalar);
1102         }
1103
1104       new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
1105       new_c->iterator = c->iterator;
1106       c->iterator = NULL;
1107     }
1108
1109   gfc_free_expr (op1);
1110   gfc_free_expr (op2);
1111   gfc_free_expr (scalar);
1112
1113   e->value.constructor = newbase;
1114   return true;
1115 }
1116
1117 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1118  2**k into ishift(1,k) */
1119
1120 static bool
1121 optimize_power (gfc_expr *e)
1122 {
1123   gfc_expr *op1, *op2;
1124   gfc_expr *iand, *ishft;
1125
1126   if (e->ts.type != BT_INTEGER)
1127     return false;
1128
1129   op1 = e->value.op.op1;
1130
1131   if (op1 == NULL || op1->expr_type != EXPR_CONSTANT)
1132     return false;
1133
1134   if (mpz_cmp_si (op1->value.integer, -1L) == 0)
1135     {
1136       gfc_free_expr (op1);
1137
1138       op2 = e->value.op.op2;
1139
1140       if (op2 == NULL)
1141         return false;
1142
1143       iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND,
1144                                        "_internal_iand", e->where, 2, op2,
1145                                        gfc_get_int_expr (e->ts.kind,
1146                                                          &e->where, 1));
1147
1148       ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1149                                         "_internal_ishft", e->where, 2, iand,
1150                                         gfc_get_int_expr (e->ts.kind,
1151                                                           &e->where, 1));
1152
1153       e->value.op.op = INTRINSIC_MINUS;
1154       e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1);
1155       e->value.op.op2 = ishft;
1156       return true;
1157     }
1158   else if (mpz_cmp_si (op1->value.integer, 2L) == 0)
1159     {
1160       gfc_free_expr (op1);
1161
1162       op2 = e->value.op.op2;
1163       if (op2 == NULL)
1164         return false;
1165
1166       ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1167                                         "_internal_ishft", e->where, 2,
1168                                         gfc_get_int_expr (e->ts.kind,
1169                                                           &e->where, 1),
1170                                         op2);
1171       *e = *ishft;
1172       return true;
1173     }
1174
1175   else if (mpz_cmp_si (op1->value.integer, 1L) == 0)
1176     {
1177       op2 = e->value.op.op2;
1178       if (op2 == NULL)
1179         return false;
1180
1181       gfc_free_expr (op1);
1182       gfc_free_expr (op2);
1183
1184       e->expr_type = EXPR_CONSTANT;
1185       e->value.op.op1 = NULL;
1186       e->value.op.op2 = NULL;
1187       mpz_init_set_si (e->value.integer, 1);
1188       /* Typespec and location are still OK.  */
1189       return true;
1190     }
1191
1192   return false;
1193 }
1194
1195 /* Recursive optimization of operators.  */
1196
1197 static bool
1198 optimize_op (gfc_expr *e)
1199 {
1200   bool changed;
1201
1202   gfc_intrinsic_op op = e->value.op.op;
1203
1204   changed = false;
1205
1206   /* Only use new-style comparisons.  */
1207   switch(op)
1208     {
1209     case INTRINSIC_EQ_OS:
1210       op = INTRINSIC_EQ;
1211       break;
1212
1213     case INTRINSIC_GE_OS:
1214       op = INTRINSIC_GE;
1215       break;
1216
1217     case INTRINSIC_LE_OS:
1218       op = INTRINSIC_LE;
1219       break;
1220
1221     case INTRINSIC_NE_OS:
1222       op = INTRINSIC_NE;
1223       break;
1224
1225     case INTRINSIC_GT_OS:
1226       op = INTRINSIC_GT;
1227       break;
1228
1229     case INTRINSIC_LT_OS:
1230       op = INTRINSIC_LT;
1231       break;
1232
1233     default:
1234       break;
1235     }
1236
1237   switch (op)
1238     {
1239     case INTRINSIC_EQ:
1240     case INTRINSIC_GE:
1241     case INTRINSIC_LE:
1242     case INTRINSIC_NE:
1243     case INTRINSIC_GT:
1244     case INTRINSIC_LT:
1245       changed = optimize_comparison (e, op);
1246
1247       /* Fall through */
1248       /* Look at array constructors.  */
1249     case INTRINSIC_PLUS:
1250     case INTRINSIC_MINUS:
1251     case INTRINSIC_TIMES:
1252     case INTRINSIC_DIVIDE:
1253       return combine_array_constructor (e) || changed;
1254
1255     case INTRINSIC_POWER:
1256       return optimize_power (e);
1257       break;
1258
1259     default:
1260       break;
1261     }
1262
1263   return false;
1264 }
1265
1266
1267 /* Return true if a constant string contains only blanks.  */
1268
1269 static bool
1270 is_empty_string (gfc_expr *e)
1271 {
1272   int i;
1273
1274   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1275     return false;
1276
1277   for (i=0; i < e->value.character.length; i++)
1278     {
1279       if (e->value.character.string[i] != ' ')
1280         return false;
1281     }
1282
1283   return true;
1284 }
1285
1286
1287 /* Insert a call to the intrinsic len_trim. Use a different name for
1288    the symbol tree so we don't run into trouble when the user has
1289    renamed len_trim for some reason.  */
1290
1291 static gfc_expr*
1292 get_len_trim_call (gfc_expr *str, int kind)
1293 {
1294   gfc_expr *fcn;
1295   gfc_actual_arglist *actual_arglist, *next;
1296
1297   fcn = gfc_get_expr ();
1298   fcn->expr_type = EXPR_FUNCTION;
1299   fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1300   actual_arglist = gfc_get_actual_arglist ();
1301   actual_arglist->expr = str;
1302   next = gfc_get_actual_arglist ();
1303   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1304   actual_arglist->next = next;
1305
1306   fcn->value.function.actual = actual_arglist;
1307   fcn->where = str->where;
1308   fcn->ts.type = BT_INTEGER;
1309   fcn->ts.kind = gfc_charlen_int_kind;
1310
1311   gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1312   fcn->symtree->n.sym->ts = fcn->ts;
1313   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1314   fcn->symtree->n.sym->attr.function = 1;
1315   fcn->symtree->n.sym->attr.elemental = 1;
1316   fcn->symtree->n.sym->attr.referenced = 1;
1317   fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1318   gfc_commit_symbol (fcn->symtree->n.sym);
1319
1320   return fcn;
1321 }
1322
1323 /* Optimize expressions for equality.  */
1324
1325 static bool
1326 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
1327 {
1328   gfc_expr *op1, *op2;
1329   bool change;
1330   int eq;
1331   bool result;
1332   gfc_actual_arglist *firstarg, *secondarg;
1333
1334   if (e->expr_type == EXPR_OP)
1335     {
1336       firstarg = NULL;
1337       secondarg = NULL;
1338       op1 = e->value.op.op1;
1339       op2 = e->value.op.op2;
1340     }
1341   else if (e->expr_type == EXPR_FUNCTION)
1342     {
1343       /* One of the lexical comparison functions.  */
1344       firstarg = e->value.function.actual;
1345       secondarg = firstarg->next;
1346       op1 = firstarg->expr;
1347       op2 = secondarg->expr;
1348     }
1349   else
1350     gcc_unreachable ();
1351
1352   /* Strip off unneeded TRIM calls from string comparisons.  */
1353
1354   change = remove_trim (op1);
1355
1356   if (remove_trim (op2))
1357     change = true;
1358
1359   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
1360   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1361      handles them well). However, there are also cases that need a non-scalar
1362      argument. For example the any intrinsic. See PR 45380.  */
1363   if (e->rank > 0)
1364     return change;
1365
1366   /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1367      len_trim(a) != 0 */
1368   if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1369       && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
1370     {
1371       bool empty_op1, empty_op2;
1372       empty_op1 = is_empty_string (op1);
1373       empty_op2 = is_empty_string (op2);
1374
1375       if (empty_op1 || empty_op2)
1376         {
1377           gfc_expr *fcn;
1378           gfc_expr *zero;
1379           gfc_expr *str;
1380
1381           /* This can only happen when an error for comparing
1382              characters of different kinds has already been issued.  */
1383           if (empty_op1 && empty_op2)
1384             return false;
1385
1386           zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
1387           str = empty_op1 ? op2 : op1;
1388
1389           fcn = get_len_trim_call (str, gfc_charlen_int_kind);
1390
1391
1392           if (empty_op1)
1393             gfc_free_expr (op1);
1394           else
1395             gfc_free_expr (op2);
1396
1397           op1 = fcn;
1398           op2 = zero;
1399           e->value.op.op1 = fcn;
1400           e->value.op.op2 = zero;
1401         }
1402     }
1403
1404
1405   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
1406
1407   if (flag_finite_math_only
1408       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
1409           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
1410     {
1411       eq = gfc_dep_compare_expr (op1, op2);
1412       if (eq <= -2)
1413         {
1414           /* Replace A // B < A // C with B < C, and A // B < C // B
1415              with A < C.  */
1416           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1417               && op1->expr_type == EXPR_OP
1418               && op1->value.op.op == INTRINSIC_CONCAT
1419               && op2->expr_type == EXPR_OP
1420               && op2->value.op.op == INTRINSIC_CONCAT)
1421             {
1422               gfc_expr *op1_left = op1->value.op.op1;
1423               gfc_expr *op2_left = op2->value.op.op1;
1424               gfc_expr *op1_right = op1->value.op.op2;
1425               gfc_expr *op2_right = op2->value.op.op2;
1426
1427               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
1428                 {
1429                   /* Watch out for 'A ' // x vs. 'A' // x.  */
1430
1431                   if (op1_left->expr_type == EXPR_CONSTANT
1432                         && op2_left->expr_type == EXPR_CONSTANT
1433                         && op1_left->value.character.length
1434                            != op2_left->value.character.length)
1435                     return change;
1436                   else
1437                     {
1438                       free (op1_left);
1439                       free (op2_left);
1440                       if (firstarg)
1441                         {
1442                           firstarg->expr = op1_right;
1443                           secondarg->expr = op2_right;
1444                         }
1445                       else
1446                         {
1447                           e->value.op.op1 = op1_right;
1448                           e->value.op.op2 = op2_right;
1449                         }
1450                       optimize_comparison (e, op);
1451                       return true;
1452                     }
1453                 }
1454               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
1455                 {
1456                   free (op1_right);
1457                   free (op2_right);
1458                   if (firstarg)
1459                     {
1460                       firstarg->expr = op1_left;
1461                       secondarg->expr = op2_left;
1462                     }
1463                   else
1464                     {
1465                       e->value.op.op1 = op1_left;
1466                       e->value.op.op2 = op2_left;
1467                     }
1468
1469                   optimize_comparison (e, op);
1470                   return true;
1471                 }
1472             }
1473         }
1474       else
1475         {
1476           /* eq can only be -1, 0 or 1 at this point.  */
1477           switch (op)
1478             {
1479             case INTRINSIC_EQ:
1480               result = eq == 0;
1481               break;
1482
1483             case INTRINSIC_GE:
1484               result = eq >= 0;
1485               break;
1486
1487             case INTRINSIC_LE:
1488               result = eq <= 0;
1489               break;
1490
1491             case INTRINSIC_NE:
1492               result = eq != 0;
1493               break;
1494
1495             case INTRINSIC_GT:
1496               result = eq > 0;
1497               break;
1498
1499             case INTRINSIC_LT:
1500               result = eq < 0;
1501               break;
1502
1503             default:
1504               gfc_internal_error ("illegal OP in optimize_comparison");
1505               break;
1506             }
1507
1508           /* Replace the expression by a constant expression.  The typespec
1509              and where remains the way it is.  */
1510           free (op1);
1511           free (op2);
1512           e->expr_type = EXPR_CONSTANT;
1513           e->value.logical = result;
1514           return true;
1515         }
1516     }
1517
1518   return change;
1519 }
1520
1521 /* Optimize a trim function by replacing it with an equivalent substring
1522    involving a call to len_trim.  This only works for expressions where
1523    variables are trimmed.  Return true if anything was modified.  */
1524
1525 static bool
1526 optimize_trim (gfc_expr *e)
1527 {
1528   gfc_expr *a;
1529   gfc_ref *ref;
1530   gfc_expr *fcn;
1531   gfc_ref **rr = NULL;
1532
1533   /* Don't do this optimization within an argument list, because
1534      otherwise aliasing issues may occur.  */
1535
1536   if (count_arglist != 1)
1537     return false;
1538
1539   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
1540       || e->value.function.isym == NULL
1541       || e->value.function.isym->id != GFC_ISYM_TRIM)
1542     return false;
1543
1544   a = e->value.function.actual->expr;
1545
1546   if (a->expr_type != EXPR_VARIABLE)
1547     return false;
1548
1549   /* Follow all references to find the correct place to put the newly
1550      created reference.  FIXME:  Also handle substring references and
1551      array references.  Array references cause strange regressions at
1552      the moment.  */
1553
1554   if (a->ref)
1555     {
1556       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
1557         {
1558           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
1559             return false;
1560         }
1561     }
1562
1563   strip_function_call (e);
1564
1565   if (e->ref == NULL)
1566     rr = &(e->ref);
1567
1568   /* Create the reference.  */
1569
1570   ref = gfc_get_ref ();
1571   ref->type = REF_SUBSTRING;
1572
1573   /* Set the start of the reference.  */
1574
1575   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1576
1577   /* Build the function call to len_trim(x, gfc_default_integer_kind).  */
1578
1579   fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
1580
1581   /* Set the end of the reference to the call to len_trim.  */
1582
1583   ref->u.ss.end = fcn;
1584   gcc_assert (rr != NULL && *rr == NULL);
1585   *rr = ref;
1586   return true;
1587 }
1588
1589 /* Optimize minloc(b), where b is rank 1 array, into
1590    (/ minloc(b, dim=1) /), and similarly for maxloc,
1591    as the latter forms are expanded inline.  */
1592
1593 static void
1594 optimize_minmaxloc (gfc_expr **e)
1595 {
1596   gfc_expr *fn = *e;
1597   gfc_actual_arglist *a;
1598   char *name, *p;
1599
1600   if (fn->rank != 1
1601       || fn->value.function.actual == NULL
1602       || fn->value.function.actual->expr == NULL
1603       || fn->value.function.actual->expr->rank != 1)
1604     return;
1605
1606   *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
1607   (*e)->shape = fn->shape;
1608   fn->rank = 0;
1609   fn->shape = NULL;
1610   gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
1611
1612   name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
1613   strcpy (name, fn->value.function.name);
1614   p = strstr (name, "loc0");
1615   p[3] = '1';
1616   fn->value.function.name = gfc_get_string (name);
1617   if (fn->value.function.actual->next)
1618     {
1619       a = fn->value.function.actual->next;
1620       gcc_assert (a->expr == NULL);
1621     }
1622   else
1623     {
1624       a = gfc_get_actual_arglist ();
1625       fn->value.function.actual->next = a;
1626     }
1627   a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1628                                    &fn->where);
1629   mpz_set_ui (a->expr->value.integer, 1);
1630 }
1631
1632 /* Callback function for code checking that we do not pass a DO variable to an
1633    INTENT(OUT) or INTENT(INOUT) dummy variable.  */
1634
1635 static int
1636 doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1637          void *data ATTRIBUTE_UNUSED)
1638 {
1639   gfc_code *co;
1640   int i;
1641   gfc_formal_arglist *f;
1642   gfc_actual_arglist *a;
1643
1644   co = *c;
1645
1646   switch (co->op)
1647     {
1648     case EXEC_DO:
1649
1650       /* Grow the temporary storage if necessary.  */
1651       if (doloop_level >= doloop_size)
1652         {
1653           doloop_size = 2 * doloop_size;
1654           doloop_list = XRESIZEVEC (gfc_code *, doloop_list, doloop_size);
1655         }
1656
1657       /* Mark the DO loop variable if there is one.  */
1658       if (co->ext.iterator && co->ext.iterator->var)
1659         doloop_list[doloop_level] = co;
1660       else
1661         doloop_list[doloop_level] = NULL;
1662       break;
1663
1664     case EXEC_CALL:
1665
1666       if (co->resolved_sym == NULL)
1667         break;
1668
1669       f = gfc_sym_get_dummy_args (co->resolved_sym);
1670
1671       /* Withot a formal arglist, there is only unknown INTENT,
1672          which we don't check for.  */
1673       if (f == NULL)
1674         break;
1675
1676       a = co->ext.actual;
1677
1678       while (a && f)
1679         {
1680           for (i=0; i<doloop_level; i++)
1681             {
1682               gfc_symbol *do_sym;
1683
1684               if (doloop_list[i] == NULL)
1685                 break;
1686
1687               do_sym = doloop_list[i]->ext.iterator->var->symtree->n.sym;
1688
1689               if (a->expr && a->expr->symtree
1690                   && a->expr->symtree->n.sym == do_sym)
1691                 {
1692                   if (f->sym->attr.intent == INTENT_OUT)
1693                     gfc_error_now("Variable '%s' at %L set to undefined value "
1694                                   "inside loop  beginning at %L as INTENT(OUT) "
1695                                   "argument to subroutine '%s'", do_sym->name,
1696                                   &a->expr->where, &doloop_list[i]->loc,
1697                                   co->symtree->n.sym->name);
1698                   else if (f->sym->attr.intent == INTENT_INOUT)
1699                     gfc_error_now("Variable '%s' at %L not definable inside loop "
1700                                   "beginning at %L as INTENT(INOUT) argument to "
1701                                   "subroutine '%s'", do_sym->name,
1702                                   &a->expr->where, &doloop_list[i]->loc,
1703                                   co->symtree->n.sym->name);
1704                 }
1705             }
1706           a = a->next;
1707           f = f->next;
1708         }
1709       break;
1710
1711     default:
1712       break;
1713     }
1714   return 0;
1715 }
1716
1717 /* Callback function for functions checking that we do not pass a DO variable
1718    to an INTENT(OUT) or INTENT(INOUT) dummy variable.  */
1719
1720 static int
1721 do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1722              void *data ATTRIBUTE_UNUSED)
1723 {
1724   gfc_formal_arglist *f;
1725   gfc_actual_arglist *a;
1726   gfc_expr *expr;
1727   int i;
1728
1729   expr = *e;
1730   if (expr->expr_type != EXPR_FUNCTION)
1731     return 0;
1732
1733   /* Intrinsic functions don't modify their arguments.  */
1734
1735   if (expr->value.function.isym)
1736     return 0;
1737
1738   f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
1739
1740   /* Without a formal arglist, there is only unknown INTENT,
1741      which we don't check for.  */
1742   if (f == NULL)
1743     return 0;
1744
1745   a = expr->value.function.actual;
1746
1747   while (a && f)
1748     {
1749       for (i=0; i<doloop_level; i++)
1750         {
1751           gfc_symbol *do_sym;
1752
1753
1754           if (doloop_list[i] == NULL)
1755             break;
1756
1757           do_sym = doloop_list[i]->ext.iterator->var->symtree->n.sym;
1758
1759           if (a->expr && a->expr->symtree
1760               && a->expr->symtree->n.sym == do_sym)
1761             {
1762               if (f->sym->attr.intent == INTENT_OUT)
1763                 gfc_error_now("Variable '%s' at %L set to undefined value "
1764                               "inside loop beginning at %L as INTENT(OUT) "
1765                               "argument to function '%s'", do_sym->name,
1766                               &a->expr->where, &doloop_list[i]->loc,
1767                               expr->symtree->n.sym->name);
1768               else if (f->sym->attr.intent == INTENT_INOUT)
1769                 gfc_error_now("Variable '%s' at %L not definable inside loop "
1770                               "beginning at %L as INTENT(INOUT) argument to "
1771                               "function '%s'", do_sym->name,
1772                               &a->expr->where, &doloop_list[i]->loc,
1773                               expr->symtree->n.sym->name);
1774             }
1775         }
1776       a = a->next;
1777       f = f->next;
1778     }
1779
1780   return 0;
1781 }
1782
1783 static void
1784 doloop_warn (gfc_namespace *ns)
1785 {
1786   gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
1787 }
1788
1789
1790 #define WALK_SUBEXPR(NODE) \
1791   do                                                    \
1792     {                                                   \
1793       result = gfc_expr_walker (&(NODE), exprfn, data); \
1794       if (result)                                       \
1795         return result;                                  \
1796     }                                                   \
1797   while (0)
1798 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1799
1800 /* Walk expression *E, calling EXPRFN on each expression in it.  */
1801
1802 int
1803 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
1804 {
1805   while (*e)
1806     {
1807       int walk_subtrees = 1;
1808       gfc_actual_arglist *a;
1809       gfc_ref *r;
1810       gfc_constructor *c;
1811
1812       int result = exprfn (e, &walk_subtrees, data);
1813       if (result)
1814         return result;
1815       if (walk_subtrees)
1816         switch ((*e)->expr_type)
1817           {
1818           case EXPR_OP:
1819             WALK_SUBEXPR ((*e)->value.op.op1);
1820             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
1821             break;
1822           case EXPR_FUNCTION:
1823             for (a = (*e)->value.function.actual; a; a = a->next)
1824               WALK_SUBEXPR (a->expr);
1825             break;
1826           case EXPR_COMPCALL:
1827           case EXPR_PPC:
1828             WALK_SUBEXPR ((*e)->value.compcall.base_object);
1829             for (a = (*e)->value.compcall.actual; a; a = a->next)
1830               WALK_SUBEXPR (a->expr);
1831             break;
1832
1833           case EXPR_STRUCTURE:
1834           case EXPR_ARRAY:
1835             for (c = gfc_constructor_first ((*e)->value.constructor); c;
1836                  c = gfc_constructor_next (c))
1837               {
1838                 if (c->iterator == NULL)
1839                   WALK_SUBEXPR (c->expr);
1840                 else
1841                   {
1842                     iterator_level ++;
1843                     WALK_SUBEXPR (c->expr);
1844                     iterator_level --;
1845                     WALK_SUBEXPR (c->iterator->var);
1846                     WALK_SUBEXPR (c->iterator->start);
1847                     WALK_SUBEXPR (c->iterator->end);
1848                     WALK_SUBEXPR (c->iterator->step);
1849                   }
1850               }
1851
1852             if ((*e)->expr_type != EXPR_ARRAY)
1853               break;
1854
1855             /* Fall through to the variable case in order to walk the
1856                reference.  */
1857
1858           case EXPR_SUBSTRING:
1859           case EXPR_VARIABLE:
1860             for (r = (*e)->ref; r; r = r->next)
1861               {
1862                 gfc_array_ref *ar;
1863                 int i;
1864
1865                 switch (r->type)
1866                   {
1867                   case REF_ARRAY:
1868                     ar = &r->u.ar;
1869                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
1870                       {
1871                         for (i=0; i< ar->dimen; i++)
1872                           {
1873                             WALK_SUBEXPR (ar->start[i]);
1874                             WALK_SUBEXPR (ar->end[i]);
1875                             WALK_SUBEXPR (ar->stride[i]);
1876                           }
1877                       }
1878
1879                     break;
1880
1881                   case REF_SUBSTRING:
1882                     WALK_SUBEXPR (r->u.ss.start);
1883                     WALK_SUBEXPR (r->u.ss.end);
1884                     break;
1885
1886                   case REF_COMPONENT:
1887                     break;
1888                   }
1889               }
1890
1891           default:
1892             break;
1893           }
1894       return 0;
1895     }
1896   return 0;
1897 }
1898
1899 #define WALK_SUBCODE(NODE) \
1900   do                                                            \
1901     {                                                           \
1902       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1903       if (result)                                               \
1904         return result;                                          \
1905     }                                                           \
1906   while (0)
1907
1908 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1909    on each expression in it.  If any of the hooks returns non-zero, that
1910    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
1911    no subcodes or subexpressions are traversed.  */
1912
1913 int
1914 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
1915                  void *data)
1916 {
1917   for (; *c; c = &(*c)->next)
1918     {
1919       int walk_subtrees = 1;
1920       int result = codefn (c, &walk_subtrees, data);
1921       if (result)
1922         return result;
1923
1924       if (walk_subtrees)
1925         {
1926           gfc_code *b;
1927           gfc_actual_arglist *a;
1928           gfc_code *co;
1929           gfc_association_list *alist;
1930           bool saved_in_omp_workshare;
1931
1932           /* There might be statement insertions before the current code,
1933              which must not affect the expression walker.  */
1934
1935           co = *c;
1936           saved_in_omp_workshare = in_omp_workshare;
1937
1938           switch (co->op)
1939             {
1940
1941             case EXEC_BLOCK:
1942               WALK_SUBCODE (co->ext.block.ns->code);
1943               for (alist = co->ext.block.assoc; alist; alist = alist->next)
1944                 WALK_SUBEXPR (alist->target);
1945               break;
1946
1947             case EXEC_DO:
1948               doloop_level ++;
1949               WALK_SUBEXPR (co->ext.iterator->var);
1950               WALK_SUBEXPR (co->ext.iterator->start);
1951               WALK_SUBEXPR (co->ext.iterator->end);
1952               WALK_SUBEXPR (co->ext.iterator->step);
1953               break;
1954
1955             case EXEC_CALL:
1956             case EXEC_ASSIGN_CALL:
1957               for (a = co->ext.actual; a; a = a->next)
1958                 WALK_SUBEXPR (a->expr);
1959               break;
1960
1961             case EXEC_CALL_PPC:
1962               WALK_SUBEXPR (co->expr1);
1963               for (a = co->ext.actual; a; a = a->next)
1964                 WALK_SUBEXPR (a->expr);
1965               break;
1966
1967             case EXEC_SELECT:
1968               WALK_SUBEXPR (co->expr1);
1969               for (b = co->block; b; b = b->block)
1970                 {
1971                   gfc_case *cp;
1972                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
1973                     {
1974                       WALK_SUBEXPR (cp->low);
1975                       WALK_SUBEXPR (cp->high);
1976                     }
1977                   WALK_SUBCODE (b->next);
1978                 }
1979               continue;
1980
1981             case EXEC_ALLOCATE:
1982             case EXEC_DEALLOCATE:
1983               {
1984                 gfc_alloc *a;
1985                 for (a = co->ext.alloc.list; a; a = a->next)
1986                   WALK_SUBEXPR (a->expr);
1987                 break;
1988               }
1989
1990             case EXEC_FORALL:
1991             case EXEC_DO_CONCURRENT:
1992               {
1993                 gfc_forall_iterator *fa;
1994                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
1995                   {
1996                     WALK_SUBEXPR (fa->var);
1997                     WALK_SUBEXPR (fa->start);
1998                     WALK_SUBEXPR (fa->end);
1999                     WALK_SUBEXPR (fa->stride);
2000                   }
2001                 if (co->op == EXEC_FORALL)
2002                   forall_level ++;
2003                 break;
2004               }
2005
2006             case EXEC_OPEN:
2007               WALK_SUBEXPR (co->ext.open->unit);
2008               WALK_SUBEXPR (co->ext.open->file);
2009               WALK_SUBEXPR (co->ext.open->status);
2010               WALK_SUBEXPR (co->ext.open->access);
2011               WALK_SUBEXPR (co->ext.open->form);
2012               WALK_SUBEXPR (co->ext.open->recl);
2013               WALK_SUBEXPR (co->ext.open->blank);
2014               WALK_SUBEXPR (co->ext.open->position);
2015               WALK_SUBEXPR (co->ext.open->action);
2016               WALK_SUBEXPR (co->ext.open->delim);
2017               WALK_SUBEXPR (co->ext.open->pad);
2018               WALK_SUBEXPR (co->ext.open->iostat);
2019               WALK_SUBEXPR (co->ext.open->iomsg);
2020               WALK_SUBEXPR (co->ext.open->convert);
2021               WALK_SUBEXPR (co->ext.open->decimal);
2022               WALK_SUBEXPR (co->ext.open->encoding);
2023               WALK_SUBEXPR (co->ext.open->round);
2024               WALK_SUBEXPR (co->ext.open->sign);
2025               WALK_SUBEXPR (co->ext.open->asynchronous);
2026               WALK_SUBEXPR (co->ext.open->id);
2027               WALK_SUBEXPR (co->ext.open->newunit);
2028               break;
2029
2030             case EXEC_CLOSE:
2031               WALK_SUBEXPR (co->ext.close->unit);
2032               WALK_SUBEXPR (co->ext.close->status);
2033               WALK_SUBEXPR (co->ext.close->iostat);
2034               WALK_SUBEXPR (co->ext.close->iomsg);
2035               break;
2036
2037             case EXEC_BACKSPACE:
2038             case EXEC_ENDFILE:
2039             case EXEC_REWIND:
2040             case EXEC_FLUSH:
2041               WALK_SUBEXPR (co->ext.filepos->unit);
2042               WALK_SUBEXPR (co->ext.filepos->iostat);
2043               WALK_SUBEXPR (co->ext.filepos->iomsg);
2044               break;
2045
2046             case EXEC_INQUIRE:
2047               WALK_SUBEXPR (co->ext.inquire->unit);
2048               WALK_SUBEXPR (co->ext.inquire->file);
2049               WALK_SUBEXPR (co->ext.inquire->iomsg);
2050               WALK_SUBEXPR (co->ext.inquire->iostat);
2051               WALK_SUBEXPR (co->ext.inquire->exist);
2052               WALK_SUBEXPR (co->ext.inquire->opened);
2053               WALK_SUBEXPR (co->ext.inquire->number);
2054               WALK_SUBEXPR (co->ext.inquire->named);
2055               WALK_SUBEXPR (co->ext.inquire->name);
2056               WALK_SUBEXPR (co->ext.inquire->access);
2057               WALK_SUBEXPR (co->ext.inquire->sequential);
2058               WALK_SUBEXPR (co->ext.inquire->direct);
2059               WALK_SUBEXPR (co->ext.inquire->form);
2060               WALK_SUBEXPR (co->ext.inquire->formatted);
2061               WALK_SUBEXPR (co->ext.inquire->unformatted);
2062               WALK_SUBEXPR (co->ext.inquire->recl);
2063               WALK_SUBEXPR (co->ext.inquire->nextrec);
2064               WALK_SUBEXPR (co->ext.inquire->blank);
2065               WALK_SUBEXPR (co->ext.inquire->position);
2066               WALK_SUBEXPR (co->ext.inquire->action);
2067               WALK_SUBEXPR (co->ext.inquire->read);
2068               WALK_SUBEXPR (co->ext.inquire->write);
2069               WALK_SUBEXPR (co->ext.inquire->readwrite);
2070               WALK_SUBEXPR (co->ext.inquire->delim);
2071               WALK_SUBEXPR (co->ext.inquire->encoding);
2072               WALK_SUBEXPR (co->ext.inquire->pad);
2073               WALK_SUBEXPR (co->ext.inquire->iolength);
2074               WALK_SUBEXPR (co->ext.inquire->convert);
2075               WALK_SUBEXPR (co->ext.inquire->strm_pos);
2076               WALK_SUBEXPR (co->ext.inquire->asynchronous);
2077               WALK_SUBEXPR (co->ext.inquire->decimal);
2078               WALK_SUBEXPR (co->ext.inquire->pending);
2079               WALK_SUBEXPR (co->ext.inquire->id);
2080               WALK_SUBEXPR (co->ext.inquire->sign);
2081               WALK_SUBEXPR (co->ext.inquire->size);
2082               WALK_SUBEXPR (co->ext.inquire->round);
2083               break;
2084
2085             case EXEC_WAIT:
2086               WALK_SUBEXPR (co->ext.wait->unit);
2087               WALK_SUBEXPR (co->ext.wait->iostat);
2088               WALK_SUBEXPR (co->ext.wait->iomsg);
2089               WALK_SUBEXPR (co->ext.wait->id);
2090               break;
2091
2092             case EXEC_READ:
2093             case EXEC_WRITE:
2094               WALK_SUBEXPR (co->ext.dt->io_unit);
2095               WALK_SUBEXPR (co->ext.dt->format_expr);
2096               WALK_SUBEXPR (co->ext.dt->rec);
2097               WALK_SUBEXPR (co->ext.dt->advance);
2098               WALK_SUBEXPR (co->ext.dt->iostat);
2099               WALK_SUBEXPR (co->ext.dt->size);
2100               WALK_SUBEXPR (co->ext.dt->iomsg);
2101               WALK_SUBEXPR (co->ext.dt->id);
2102               WALK_SUBEXPR (co->ext.dt->pos);
2103               WALK_SUBEXPR (co->ext.dt->asynchronous);
2104               WALK_SUBEXPR (co->ext.dt->blank);
2105               WALK_SUBEXPR (co->ext.dt->decimal);
2106               WALK_SUBEXPR (co->ext.dt->delim);
2107               WALK_SUBEXPR (co->ext.dt->pad);
2108               WALK_SUBEXPR (co->ext.dt->round);
2109               WALK_SUBEXPR (co->ext.dt->sign);
2110               WALK_SUBEXPR (co->ext.dt->extra_comma);
2111               break;
2112
2113             case EXEC_OMP_PARALLEL:
2114             case EXEC_OMP_PARALLEL_DO:
2115             case EXEC_OMP_PARALLEL_SECTIONS:
2116
2117               in_omp_workshare = false;
2118
2119               /* This goto serves as a shortcut to avoid code
2120                  duplication or a larger if or switch statement.  */
2121               goto check_omp_clauses;
2122
2123             case EXEC_OMP_WORKSHARE:
2124             case EXEC_OMP_PARALLEL_WORKSHARE:
2125
2126               in_omp_workshare = true;
2127
2128               /* Fall through  */
2129
2130             case EXEC_OMP_DO:
2131             case EXEC_OMP_SECTIONS:
2132             case EXEC_OMP_SINGLE:
2133             case EXEC_OMP_END_SINGLE:
2134             case EXEC_OMP_TASK:
2135
2136               /* Come to this label only from the
2137                  EXEC_OMP_PARALLEL_* cases above.  */
2138
2139             check_omp_clauses:
2140
2141               if (co->ext.omp_clauses)
2142                 {
2143                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
2144                   WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
2145                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
2146                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
2147                 }
2148               break;
2149             default:
2150               break;
2151             }
2152
2153           WALK_SUBEXPR (co->expr1);
2154           WALK_SUBEXPR (co->expr2);
2155           WALK_SUBEXPR (co->expr3);
2156           WALK_SUBEXPR (co->expr4);
2157           for (b = co->block; b; b = b->block)
2158             {
2159               WALK_SUBEXPR (b->expr1);
2160               WALK_SUBEXPR (b->expr2);
2161               WALK_SUBCODE (b->next);
2162             }
2163
2164           if (co->op == EXEC_FORALL)
2165             forall_level --;
2166
2167           if (co->op == EXEC_DO)
2168             doloop_level --;
2169
2170           in_omp_workshare = saved_in_omp_workshare;
2171         }
2172     }
2173   return 0;
2174 }