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_TRANSFER
 207           || gfc_inline_intrinsic_function_p (*e))
 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            && ! gfc_inline_intrinsic_function_p (e))
 572     {
 573
 574       gfc_code *n;
 575       gfc_expr *new_expr;
 576
 577       /* Insert a new assignment statement after the current one.  */
 578       n = XCNEW (gfc_code);
 579       n->op = EXEC_ASSIGN;
 580       n->loc = c->loc;
 581       n->next = c->next;
 582       c->next = n;
 583
 584       n->expr1 = gfc_copy_expr (c->expr1);
 585       n->expr2 = c->expr2;
 586       new_expr = gfc_copy_expr (c->expr1);
 587       c->expr2 = e;
 588       *rhs = new_expr;
 589
 590       return true;
 591
 592     }
 593
 594   /* Nothing to optimize.  */
 595   return false;
 596 }
 597
 598 /* Remove unneeded TRIMs at the end of expressions.  */
 599
 600 static bool
 601 remove_trim (gfc_expr *rhs)
 602 {
 603   bool ret;
 604
 605   ret = false;
 606
 607   /* Check for a // b // trim(c).  Looping is probably not
 608      necessary because the parser usually generates
 609      (// (// a b ) trim(c) ) , but better safe than sorry.  */
 610
 611   while (rhs->expr_type == EXPR_OP
 612          && rhs->value.op.op == INTRINSIC_CONCAT)
 613     rhs = rhs->value.op.op2;
 614
 615   while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
 616          && rhs->value.function.isym->id == GFC_ISYM_TRIM)
 617     {
 618       strip_function_call (rhs);
 619       /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
 620       remove_trim (rhs);
 621       ret = true;
 622     }
 623
 624   return ret;
 625 }
 626
 627 /* Optimizations for an assignment.  */
 628
 629 static void
 630 optimize_assignment (gfc_code * c)
 631 {
 632   gfc_expr *lhs, *rhs;
 633
 634   lhs = c->expr1;
 635   rhs = c->expr2;
 636
 637   /* Optimize away a = trim(b), where a is a character variable.  */
 638
 639   if (lhs->ts.type == BT_CHARACTER)
 640     remove_trim (rhs);
 641
 642   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 643     optimize_binop_array_assignment (c, &rhs, false);
 644 }
 645
 646
 647 /* Remove an unneeded function call, modifying the expression.
 648    This replaces the function call with the value of its
 649    first argument.  The rest of the argument list is freed.  */
 650
 651 static void
 652 strip_function_call (gfc_expr *e)
 653 {
 654   gfc_expr *e1;
 655   gfc_actual_arglist *a;
 656
 657   a = e->value.function.actual;
 658
 659   /* We should have at least one argument.  */
 660   gcc_assert (a->expr != NULL);
 661
 662   e1 = a->expr;
 663
 664   /* Free the remaining arglist, if any.  */
 665   if (a->next)
 666     gfc_free_actual_arglist (a->next);
 667
 668   /* Graft the argument expression onto the original function.  */
 669   *e = *e1;
 670   free (e1);
 671
 672 }
 673
 674 /* Optimization of lexical comparison functions.  */
 675
 676 static bool
 677 optimize_lexical_comparison (gfc_expr *e)
 678 {
 679   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
 680     return false;
 681
 682   switch (e->value.function.isym->id)
 683     {
 684     case GFC_ISYM_LLE:
 685       return optimize_comparison (e, INTRINSIC_LE);
 686
 687     case GFC_ISYM_LGE:
 688       return optimize_comparison (e, INTRINSIC_GE);
 689
 690     case GFC_ISYM_LGT:
 691       return optimize_comparison (e, INTRINSIC_GT);
 692
 693     case GFC_ISYM_LLT:
 694       return optimize_comparison (e, INTRINSIC_LT);
 695
 696     default:
 697       break;
 698     }
 699   return false;
 700 }
 701
 702 /* Recursive optimization of operators.  */
 703
 704 static bool
 705 optimize_op (gfc_expr *e)
 706 {
 707   gfc_intrinsic_op op = e->value.op.op;
 708
 709   switch (op)
 710     {
 711     case INTRINSIC_EQ:
 712     case INTRINSIC_EQ_OS:
 713     case INTRINSIC_GE:
 714     case INTRINSIC_GE_OS:
 715     case INTRINSIC_LE:
 716     case INTRINSIC_LE_OS:
 717     case INTRINSIC_NE:
 718     case INTRINSIC_NE_OS:
 719     case INTRINSIC_GT:
 720     case INTRINSIC_GT_OS:
 721     case INTRINSIC_LT:
 722     case INTRINSIC_LT_OS:
 723       return optimize_comparison (e, op);
 724
 725     default:
 726       break;
 727     }
 728
 729   return false;
 730 }
 731
 732 /* Optimize expressions for equality.  */
 733
 734 static bool
 735 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
 736 {
 737   gfc_expr *op1, *op2;
 738   bool change;
 739   int eq;
 740   bool result;
 741   gfc_actual_arglist *firstarg, *secondarg;
 742
 743   if (e->expr_type == EXPR_OP)
 744     {
 745       firstarg = NULL;
 746       secondarg = NULL;
 747       op1 = e->value.op.op1;
 748       op2 = e->value.op.op2;
 749     }
 750   else if (e->expr_type == EXPR_FUNCTION)
 751     {
 752       /* One of the lexical comparision functions.  */
 753       firstarg = e->value.function.actual;
 754       secondarg = firstarg->next;
 755       op1 = firstarg->expr;
 756       op2 = secondarg->expr;
 757     }
 758   else
 759     gcc_unreachable ();
 760
 761   /* Strip off unneeded TRIM calls from string comparisons.  */
 762
 763   change = remove_trim (op1);
 764
 765   if (remove_trim (op2))
 766     change = true;
 767
 768   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 769   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 770      handles them well). However, there are also cases that need a non-scalar
 771      argument. For example the any intrinsic. See PR 45380.  */
 772   if (e->rank > 0)
 773     return change;
 774
 775   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 776
 777   if (flag_finite_math_only
 778       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 779           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
 780     {
 781       eq = gfc_dep_compare_expr (op1, op2);
 782       if (eq <= -2)
 783         {
 784           /* Replace A // B < A // C with B < C, and A // B < C // B
 785              with A < C.  */
 786           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 787               && op1->value.op.op == INTRINSIC_CONCAT
 788               && op2->value.op.op == INTRINSIC_CONCAT)
 789             {
 790               gfc_expr *op1_left = op1->value.op.op1;
 791               gfc_expr *op2_left = op2->value.op.op1;
 792               gfc_expr *op1_right = op1->value.op.op2;
 793               gfc_expr *op2_right = op2->value.op.op2;
 794
 795               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
 796                 {
 797                   /* Watch out for 'A ' // x vs. 'A' // x.  */
 798
 799                   if (op1_left->expr_type == EXPR_CONSTANT
 800                         && op2_left->expr_type == EXPR_CONSTANT
 801                         && op1_left->value.character.length
 802                            != op2_left->value.character.length)
 803                     return change;
 804                   else
 805                     {
 806                       free (op1_left);
 807                       free (op2_left);
 808                       if (firstarg)
 809                         {
 810                           firstarg->expr = op1_right;
 811                           secondarg->expr = op2_right;
 812                         }
 813                       else
 814                         {
 815                           e->value.op.op1 = op1_right;
 816                           e->value.op.op2 = op2_right;
 817                         }
 818                       optimize_comparison (e, op);
 819                       return true;
 820                     }
 821                 }
 822               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
 823                 {
 824                   free (op1_right);
 825                   free (op2_right);
 826                   if (firstarg)
 827                     {
 828                       firstarg->expr = op1_left;
 829                       secondarg->expr = op2_left;
 830                     }
 831                   else
 832                     {
 833                       e->value.op.op1 = op1_left;
 834                       e->value.op.op2 = op2_left;
 835                     }
 836
 837                   optimize_comparison (e, op);
 838                   return true;
 839                 }
 840             }
 841         }
 842       else
 843         {
 844           /* eq can only be -1, 0 or 1 at this point.  */
 845           switch (op)
 846             {
 847             case INTRINSIC_EQ:
 848             case INTRINSIC_EQ_OS:
 849               result = eq == 0;
 850               break;
 851
 852             case INTRINSIC_GE:
 853             case INTRINSIC_GE_OS:
 854               result = eq >= 0;
 855               break;
 856
 857             case INTRINSIC_LE:
 858             case INTRINSIC_LE_OS:
 859               result = eq <= 0;
 860               break;
 861
 862             case INTRINSIC_NE:
 863             case INTRINSIC_NE_OS:
 864               result = eq != 0;
 865               break;
 866
 867             case INTRINSIC_GT:
 868             case INTRINSIC_GT_OS:
 869               result = eq > 0;
 870               break;
 871
 872             case INTRINSIC_LT:
 873             case INTRINSIC_LT_OS:
 874               result = eq < 0;
 875               break;
 876
 877             default:
 878               gfc_internal_error ("illegal OP in optimize_comparison");
 879               break;
 880             }
 881
 882           /* Replace the expression by a constant expression.  The typespec
 883              and where remains the way it is.  */
 884           free (op1);
 885           free (op2);
 886           e->expr_type = EXPR_CONSTANT;
 887           e->value.logical = result;
 888           return true;
 889         }
 890     }
 891
 892   return change;
 893 }
 894
 895 /* Optimize a trim function by replacing it with an equivalent substring
 896    involving a call to len_trim.  This only works for expressions where
 897    variables are trimmed.  Return true if anything was modified.  */
 898
 899 static bool
 900 optimize_trim (gfc_expr *e)
 901 {
 902   gfc_expr *a;
 903   gfc_ref *ref;
 904   gfc_expr *fcn;
 905   gfc_actual_arglist *actual_arglist, *next;
 906   gfc_ref **rr = NULL;
 907
 908   /* Don't do this optimization within an argument list, because
 909      otherwise aliasing issues may occur.  */
 910
 911   if (count_arglist != 1)
 912     return false;
 913
 914   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
 915       || e->value.function.isym == NULL
 916       || e->value.function.isym->id != GFC_ISYM_TRIM)
 917     return false;
 918
 919   a = e->value.function.actual->expr;
 920
 921   if (a->expr_type != EXPR_VARIABLE)
 922     return false;
 923
 924   /* Follow all references to find the correct place to put the newly
 925      created reference.  FIXME:  Also handle substring references and
 926      array references.  Array references cause strange regressions at
 927      the moment.  */
 928
 929   if (a->ref)
 930     {
 931       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
 932         {
 933           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
 934             return false;
 935         }
 936     }
 937
 938   strip_function_call (e);
 939
 940   if (e->ref == NULL)
 941     rr = &(e->ref);
 942
 943   /* Create the reference.  */
 944
 945   ref = gfc_get_ref ();
 946   ref->type = REF_SUBSTRING;
 947
 948   /* Set the start of the reference.  */
 949
 950   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 951
 952   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 953
 954   fcn = gfc_get_expr ();
 955   fcn->expr_type = EXPR_FUNCTION;
 956   fcn->value.function.isym =
 957     gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
 958   actual_arglist = gfc_get_actual_arglist ();
 959   actual_arglist->expr = gfc_copy_expr (e);
 960   next = gfc_get_actual_arglist ();
 961   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
 962                                  gfc_default_integer_kind);
 963   actual_arglist->next = next;
 964   fcn->value.function.actual = actual_arglist;
 965
 966   /* Set the end of the reference to the call to len_trim.  */
 967
 968   ref->u.ss.end = fcn;
 969   gcc_assert (*rr == NULL);
 970   *rr = ref;
 971   return true;
 972 }
 973
 974 /* Optimize minloc(b), where b is rank 1 array, into
 975    (/ minloc(b, dim=1) /), and similarly for maxloc,
 976    as the latter forms are expanded inline.  */
 977
 978 static void
 979 optimize_minmaxloc (gfc_expr **e)
 980 {
 981   gfc_expr *fn = *e;
 982   gfc_actual_arglist *a;
 983   char *name, *p;
 984
 985   if (fn->rank != 1
 986       || fn->value.function.actual == NULL
 987       || fn->value.function.actual->expr == NULL
 988       || fn->value.function.actual->expr->rank != 1)
 989     return;
 990
 991   *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
 992   (*e)->shape = fn->shape;
 993   fn->rank = 0;
 994   fn->shape = NULL;
 995   gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
 996
 997   name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
 998   strcpy (name, fn->value.function.name);
 999   p = strstr (name, "loc0");
1000   p[3] = '1';
1001   fn->value.function.name = gfc_get_string (name);
1002   if (fn->value.function.actual->next)
1003     {
1004       a = fn->value.function.actual->next;
1005       gcc_assert (a->expr == NULL);
1006     }
1007   else
1008     {
1009       a = gfc_get_actual_arglist ();
1010       fn->value.function.actual->next = a;
1011     }
1012   a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1013                                    &fn->where);
1014   mpz_set_ui (a->expr->value.integer, 1);
1015 }
1016
1017 #define WALK_SUBEXPR(NODE) \
1018   do                                                    \
1019     {                                                   \
1020       result = gfc_expr_walker (&(NODE), exprfn, data); \
1021       if (result)                                       \
1022         return result;                                  \
1023     }                                                   \
1024   while (0)
1025 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1026
1027 /* Walk expression *E, calling EXPRFN on each expression in it.  */
1028
1029 int
1030 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
1031 {
1032   while (*e)
1033     {
1034       int walk_subtrees = 1;
1035       gfc_actual_arglist *a;
1036       gfc_ref *r;
1037       gfc_constructor *c;
1038
1039       int result = exprfn (e, &walk_subtrees, data);
1040       if (result)
1041         return result;
1042       if (walk_subtrees)
1043         switch ((*e)->expr_type)
1044           {
1045           case EXPR_OP:
1046             WALK_SUBEXPR ((*e)->value.op.op1);
1047             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
1048             break;
1049           case EXPR_FUNCTION:
1050             for (a = (*e)->value.function.actual; a; a = a->next)
1051               WALK_SUBEXPR (a->expr);
1052             break;
1053           case EXPR_COMPCALL:
1054           case EXPR_PPC:
1055             WALK_SUBEXPR ((*e)->value.compcall.base_object);
1056             for (a = (*e)->value.compcall.actual; a; a = a->next)
1057               WALK_SUBEXPR (a->expr);
1058             break;
1059
1060           case EXPR_STRUCTURE:
1061           case EXPR_ARRAY:
1062             for (c = gfc_constructor_first ((*e)->value.constructor); c;
1063                  c = gfc_constructor_next (c))
1064               {
1065                 WALK_SUBEXPR (c->expr);
1066                 if (c->iterator != NULL)
1067                   {
1068                     WALK_SUBEXPR (c->iterator->var);
1069                     WALK_SUBEXPR (c->iterator->start);
1070                     WALK_SUBEXPR (c->iterator->end);
1071                     WALK_SUBEXPR (c->iterator->step);
1072                   }
1073               }
1074
1075             if ((*e)->expr_type != EXPR_ARRAY)
1076               break;
1077
1078             /* Fall through to the variable case in order to walk the
1079                reference.  */
1080
1081           case EXPR_SUBSTRING:
1082           case EXPR_VARIABLE:
1083             for (r = (*e)->ref; r; r = r->next)
1084               {
1085                 gfc_array_ref *ar;
1086                 int i;
1087
1088                 switch (r->type)
1089                   {
1090                   case REF_ARRAY:
1091                     ar = &r->u.ar;
1092                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
1093                       {
1094                         for (i=0; i< ar->dimen; i++)
1095                           {
1096                             WALK_SUBEXPR (ar->start[i]);
1097                             WALK_SUBEXPR (ar->end[i]);
1098                             WALK_SUBEXPR (ar->stride[i]);
1099                           }
1100                       }
1101
1102                     break;
1103
1104                   case REF_SUBSTRING:
1105                     WALK_SUBEXPR (r->u.ss.start);
1106                     WALK_SUBEXPR (r->u.ss.end);
1107                     break;
1108
1109                   case REF_COMPONENT:
1110                     break;
1111                   }
1112               }
1113
1114           default:
1115             break;
1116           }
1117       return 0;
1118     }
1119   return 0;
1120 }
1121
1122 #define WALK_SUBCODE(NODE) \
1123   do                                                            \
1124     {                                                           \
1125       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1126       if (result)                                               \
1127         return result;                                          \
1128     }                                                           \
1129   while (0)
1130
1131 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1132    on each expression in it.  If any of the hooks returns non-zero, that
1133    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
1134    no subcodes or subexpressions are traversed.  */
1135
1136 int
1137 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
1138                  void *data)
1139 {
1140   for (; *c; c = &(*c)->next)
1141     {
1142       int walk_subtrees = 1;
1143       int result = codefn (c, &walk_subtrees, data);
1144       if (result)
1145         return result;
1146
1147       if (walk_subtrees)
1148         {
1149           gfc_code *b;
1150           gfc_actual_arglist *a;
1151           gfc_code *co;
1152           gfc_association_list *alist;
1153
1154           /* There might be statement insertions before the current code,
1155              which must not affect the expression walker.  */
1156
1157           co = *c;
1158
1159           switch (co->op)
1160             {
1161
1162             case EXEC_BLOCK:
1163               WALK_SUBCODE (co->ext.block.ns->code);
1164               for (alist = co->ext.block.assoc; alist; alist = alist->next)
1165                 WALK_SUBEXPR (alist->target);
1166               break;
1167
1168             case EXEC_DO:
1169               WALK_SUBEXPR (co->ext.iterator->var);
1170               WALK_SUBEXPR (co->ext.iterator->start);
1171               WALK_SUBEXPR (co->ext.iterator->end);
1172               WALK_SUBEXPR (co->ext.iterator->step);
1173               break;
1174
1175             case EXEC_CALL:
1176             case EXEC_ASSIGN_CALL:
1177               for (a = co->ext.actual; a; a = a->next)
1178                 WALK_SUBEXPR (a->expr);
1179               break;
1180
1181             case EXEC_CALL_PPC:
1182               WALK_SUBEXPR (co->expr1);
1183               for (a = co->ext.actual; a; a = a->next)
1184                 WALK_SUBEXPR (a->expr);
1185               break;
1186
1187             case EXEC_SELECT:
1188               WALK_SUBEXPR (co->expr1);
1189               for (b = co->block; b; b = b->block)
1190                 {
1191                   gfc_case *cp;
1192                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
1193                     {
1194                       WALK_SUBEXPR (cp->low);
1195                       WALK_SUBEXPR (cp->high);
1196                     }
1197                   WALK_SUBCODE (b->next);
1198                 }
1199               continue;
1200
1201             case EXEC_ALLOCATE:
1202             case EXEC_DEALLOCATE:
1203               {
1204                 gfc_alloc *a;
1205                 for (a = co->ext.alloc.list; a; a = a->next)
1206                   WALK_SUBEXPR (a->expr);
1207                 break;
1208               }
1209
1210             case EXEC_FORALL:
1211             case EXEC_DO_CONCURRENT:
1212               {
1213                 gfc_forall_iterator *fa;
1214                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
1215                   {
1216                     WALK_SUBEXPR (fa->var);
1217                     WALK_SUBEXPR (fa->start);
1218                     WALK_SUBEXPR (fa->end);
1219                     WALK_SUBEXPR (fa->stride);
1220                   }
1221                 if (co->op == EXEC_FORALL)
1222                   forall_level ++;
1223                 break;
1224               }
1225
1226             case EXEC_OPEN:
1227               WALK_SUBEXPR (co->ext.open->unit);
1228               WALK_SUBEXPR (co->ext.open->file);
1229               WALK_SUBEXPR (co->ext.open->status);
1230               WALK_SUBEXPR (co->ext.open->access);
1231               WALK_SUBEXPR (co->ext.open->form);
1232               WALK_SUBEXPR (co->ext.open->recl);
1233               WALK_SUBEXPR (co->ext.open->blank);
1234               WALK_SUBEXPR (co->ext.open->position);
1235               WALK_SUBEXPR (co->ext.open->action);
1236               WALK_SUBEXPR (co->ext.open->delim);
1237               WALK_SUBEXPR (co->ext.open->pad);
1238               WALK_SUBEXPR (co->ext.open->iostat);
1239               WALK_SUBEXPR (co->ext.open->iomsg);
1240               WALK_SUBEXPR (co->ext.open->convert);
1241               WALK_SUBEXPR (co->ext.open->decimal);
1242               WALK_SUBEXPR (co->ext.open->encoding);
1243               WALK_SUBEXPR (co->ext.open->round);
1244               WALK_SUBEXPR (co->ext.open->sign);
1245               WALK_SUBEXPR (co->ext.open->asynchronous);
1246               WALK_SUBEXPR (co->ext.open->id);
1247               WALK_SUBEXPR (co->ext.open->newunit);
1248               break;
1249
1250             case EXEC_CLOSE:
1251               WALK_SUBEXPR (co->ext.close->unit);
1252               WALK_SUBEXPR (co->ext.close->status);
1253               WALK_SUBEXPR (co->ext.close->iostat);
1254               WALK_SUBEXPR (co->ext.close->iomsg);
1255               break;
1256
1257             case EXEC_BACKSPACE:
1258             case EXEC_ENDFILE:
1259             case EXEC_REWIND:
1260             case EXEC_FLUSH:
1261               WALK_SUBEXPR (co->ext.filepos->unit);
1262               WALK_SUBEXPR (co->ext.filepos->iostat);
1263               WALK_SUBEXPR (co->ext.filepos->iomsg);
1264               break;
1265
1266             case EXEC_INQUIRE:
1267               WALK_SUBEXPR (co->ext.inquire->unit);
1268               WALK_SUBEXPR (co->ext.inquire->file);
1269               WALK_SUBEXPR (co->ext.inquire->iomsg);
1270               WALK_SUBEXPR (co->ext.inquire->iostat);
1271               WALK_SUBEXPR (co->ext.inquire->exist);
1272               WALK_SUBEXPR (co->ext.inquire->opened);
1273               WALK_SUBEXPR (co->ext.inquire->number);
1274               WALK_SUBEXPR (co->ext.inquire->named);
1275               WALK_SUBEXPR (co->ext.inquire->name);
1276               WALK_SUBEXPR (co->ext.inquire->access);
1277               WALK_SUBEXPR (co->ext.inquire->sequential);
1278               WALK_SUBEXPR (co->ext.inquire->direct);
1279               WALK_SUBEXPR (co->ext.inquire->form);
1280               WALK_SUBEXPR (co->ext.inquire->formatted);
1281               WALK_SUBEXPR (co->ext.inquire->unformatted);
1282               WALK_SUBEXPR (co->ext.inquire->recl);
1283               WALK_SUBEXPR (co->ext.inquire->nextrec);
1284               WALK_SUBEXPR (co->ext.inquire->blank);
1285               WALK_SUBEXPR (co->ext.inquire->position);
1286               WALK_SUBEXPR (co->ext.inquire->action);
1287               WALK_SUBEXPR (co->ext.inquire->read);
1288               WALK_SUBEXPR (co->ext.inquire->write);
1289               WALK_SUBEXPR (co->ext.inquire->readwrite);
1290               WALK_SUBEXPR (co->ext.inquire->delim);
1291               WALK_SUBEXPR (co->ext.inquire->encoding);
1292               WALK_SUBEXPR (co->ext.inquire->pad);
1293               WALK_SUBEXPR (co->ext.inquire->iolength);
1294               WALK_SUBEXPR (co->ext.inquire->convert);
1295               WALK_SUBEXPR (co->ext.inquire->strm_pos);
1296               WALK_SUBEXPR (co->ext.inquire->asynchronous);
1297               WALK_SUBEXPR (co->ext.inquire->decimal);
1298               WALK_SUBEXPR (co->ext.inquire->pending);
1299               WALK_SUBEXPR (co->ext.inquire->id);
1300               WALK_SUBEXPR (co->ext.inquire->sign);
1301               WALK_SUBEXPR (co->ext.inquire->size);
1302               WALK_SUBEXPR (co->ext.inquire->round);
1303               break;
1304
1305             case EXEC_WAIT:
1306               WALK_SUBEXPR (co->ext.wait->unit);
1307               WALK_SUBEXPR (co->ext.wait->iostat);
1308               WALK_SUBEXPR (co->ext.wait->iomsg);
1309               WALK_SUBEXPR (co->ext.wait->id);
1310               break;
1311
1312             case EXEC_READ:
1313             case EXEC_WRITE:
1314               WALK_SUBEXPR (co->ext.dt->io_unit);
1315               WALK_SUBEXPR (co->ext.dt->format_expr);
1316               WALK_SUBEXPR (co->ext.dt->rec);
1317               WALK_SUBEXPR (co->ext.dt->advance);
1318               WALK_SUBEXPR (co->ext.dt->iostat);
1319               WALK_SUBEXPR (co->ext.dt->size);
1320               WALK_SUBEXPR (co->ext.dt->iomsg);
1321               WALK_SUBEXPR (co->ext.dt->id);
1322               WALK_SUBEXPR (co->ext.dt->pos);
1323               WALK_SUBEXPR (co->ext.dt->asynchronous);
1324               WALK_SUBEXPR (co->ext.dt->blank);
1325               WALK_SUBEXPR (co->ext.dt->decimal);
1326               WALK_SUBEXPR (co->ext.dt->delim);
1327               WALK_SUBEXPR (co->ext.dt->pad);
1328               WALK_SUBEXPR (co->ext.dt->round);
1329               WALK_SUBEXPR (co->ext.dt->sign);
1330               WALK_SUBEXPR (co->ext.dt->extra_comma);
1331               break;
1332
1333             case EXEC_OMP_DO:
1334             case EXEC_OMP_PARALLEL:
1335             case EXEC_OMP_PARALLEL_DO:
1336             case EXEC_OMP_PARALLEL_SECTIONS:
1337             case EXEC_OMP_PARALLEL_WORKSHARE:
1338             case EXEC_OMP_SECTIONS:
1339             case EXEC_OMP_SINGLE:
1340             case EXEC_OMP_WORKSHARE:
1341             case EXEC_OMP_END_SINGLE:
1342             case EXEC_OMP_TASK:
1343               if (co->ext.omp_clauses)
1344                 {
1345                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
1346                   WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
1347                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
1348                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
1349                 }
1350               break;
1351             default:
1352               break;
1353             }
1354
1355           WALK_SUBEXPR (co->expr1);
1356           WALK_SUBEXPR (co->expr2);
1357           WALK_SUBEXPR (co->expr3);
1358           WALK_SUBEXPR (co->expr4);
1359           for (b = co->block; b; b = b->block)
1360             {
1361               WALK_SUBEXPR (b->expr1);
1362               WALK_SUBEXPR (b->expr2);
1363               WALK_SUBCODE (b->next);
1364             }
1365
1366           if (co->op == EXEC_FORALL)
1367             forall_level --;
1368
1369         }
1370     }
1371   return 0;
1372 }