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