gcc/fortran/frontend-passes.c

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