gcc/fortran/frontend-passes.c

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