gcc/fortran/frontend-passes.c

   1 /* Pass manager for Fortran front end.
   2    Copyright (C) 2010 Free Software Foundation, Inc.
   3    Contributed by Thomas König.
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "gfortran.h"
  24 #include "arith.h"
  25 #include "flags.h"
  26 #include "dependency.h"
  27 #include "constructor.h"
  28 #include "opts.h"
  29
  30 /* Forward declarations.  */
  31
  32 static void strip_function_call (gfc_expr *);
  33 static void optimize_namespace (gfc_namespace *);
  34 static void optimize_assignment (gfc_code *);
  35 static bool optimize_op (gfc_expr *);
  36 static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
  37 static bool optimize_trim (gfc_expr *);
  38
  39 /* How deep we are inside an argument list.  */
  40
  41 static int count_arglist;
  42
  43 /* Pointer to an array of gfc_expr ** we operate on, plus its size
  44    and counter.  */
  45
  46 static gfc_expr ***expr_array;
  47 static int expr_size, expr_count;
  48
  49 /* Pointer to the gfc_code we currently work on - to be able to insert
  50    a statement before.  */
  51
  52 static gfc_code **current_code;
  53
  54 /* The namespace we are currently dealing with.  */
  55
  56 gfc_namespace *current_ns;
  57
  58 /* Entry point - run all passes for a namespace.  So far, only an
  59    optimization pass is run.  */
  60
  61 void
  62 gfc_run_passes (gfc_namespace *ns)
  63 {
  64   if (optimize)
  65     {
  66       expr_size = 20;
  67       expr_array = XNEWVEC(gfc_expr **, expr_size);
  68
  69       optimize_namespace (ns);
  70       if (gfc_option.dump_fortran_optimized)
  71         gfc_dump_parse_tree (ns, stdout);
  72
  73       /* FIXME: The following should be XDELETEVEC(expr_array);
  74       but we cannot do that because it depends on free.  */
  75       gfc_free (expr_array);
  76     }
  77 }
  78
  79 /* Callback for each gfc_code node invoked through gfc_code_walker
  80    from optimize_namespace.  */
  81
  82 static int
  83 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
  84                void *data ATTRIBUTE_UNUSED)
  85 {
  86
  87   gfc_exec_op op;
  88
  89   op = (*c)->op;
  90
  91   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
  92       || op == EXEC_CALL_PPC)
  93     count_arglist = 1;
  94   else
  95     count_arglist = 0;
  96
  97   if (op == EXEC_ASSIGN)
  98     optimize_assignment (*c);
  99   return 0;
 100 }
 101
 102 /* Callback for each gfc_expr node invoked through gfc_code_walker
 103    from optimize_namespace.  */
 104
 105 static int
 106 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 107                void *data ATTRIBUTE_UNUSED)
 108 {
 109   bool function_expr;
 110
 111   if ((*e)->expr_type == EXPR_FUNCTION)
 112     {
 113       count_arglist ++;
 114       function_expr = true;
 115     }
 116   else
 117     function_expr = false;
 118
 119   if (optimize_trim (*e))
 120     gfc_simplify_expr (*e, 0);
 121
 122   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
 123     gfc_simplify_expr (*e, 0);
 124
 125   if (function_expr)
 126     count_arglist --;
 127
 128   return 0;
 129 }
 130
 131
 132 /* Callback function for common function elimination, called from cfe_expr_0.
 133    Put all eligible function expressions into expr_array.  We can't do
 134    allocatable functions.  */
 135
 136 static int
 137 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 138           void *data ATTRIBUTE_UNUSED)
 139 {
 140
 141   /* FIXME - there is a bug in the insertion code for DO loops.  Bail
 142      out here.  */
 143
 144   if ((*current_code)->op == EXEC_DO)
 145     return 0;
 146
 147   if ((*e)->expr_type != EXPR_FUNCTION)
 148     return 0;
 149
 150   /* We don't do character functions (yet).  */
 151   if ((*e)->ts.type == BT_CHARACTER)
 152     return 0;
 153
 154   /* If we don't know the shape at compile time, we do not create a temporary
 155      variable to hold the intermediate result.  FIXME: Change this later when
 156      allocation on assignment works for intrinsics.  */
 157
 158   if ((*e)->rank > 0 && (*e)->shape == NULL)
 159     return 0;
 160
 161   /* Skip the test for pure functions if -faggressive-function-elimination
 162      is specified.  */
 163   if ((*e)->value.function.esym)
 164     {
 165       if ((*e)->value.function.esym->attr.allocatable)
 166         return 0;
 167
 168       /* Don't create an array temporary for elemental functions.  */
 169       if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
 170         return 0;
 171
 172       /* Only eliminate potentially impure functions if the
 173          user specifically requested it.  */
 174       if (!gfc_option.flag_aggressive_function_elimination
 175           && !(*e)->value.function.esym->attr.pure
 176           && !(*e)->value.function.esym->attr.implicit_pure)
 177         return 0;
 178     }
 179
 180   if ((*e)->value.function.isym)
 181     {
 182       /* Conversions are handled on the fly by the middle end,
 183          transpose during trans-* stages.  */
 184       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
 185           || (*e)->value.function.isym->id == GFC_ISYM_TRANSPOSE)
 186         return 0;
 187
 188       /* Don't create an array temporary for elemental functions,
 189          as this would be wasteful of memory.
 190          FIXME: Create a scalar temporary during scalarization.  */
 191       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
 192         return 0;
 193
 194       if (!(*e)->value.function.isym->pure)
 195         return 0;
 196     }
 197
 198   if (expr_count >= expr_size)
 199     {
 200       expr_size += expr_size;
 201       expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
 202     }
 203   expr_array[expr_count] = e;
 204   expr_count ++;
 205   return 0;
 206 }
 207
 208 /* Returns a new expression (a variable) to be used in place of the old one,
 209    with an an assignment statement before the current statement to set
 210    the value of the variable.  */
 211
 212 static gfc_expr*
 213 create_var (gfc_expr * e)
 214 {
 215   char name[GFC_MAX_SYMBOL_LEN +1];
 216   static int num = 1;
 217   gfc_symtree *symtree;
 218   gfc_symbol *symbol;
 219   gfc_expr *result;
 220   gfc_code *n;
 221   int i;
 222
 223   sprintf(name, "__var_%d",num++);
 224   if (gfc_get_sym_tree (name, current_ns, &symtree, false) != 0)
 225     gcc_unreachable ();
 226
 227   symbol = symtree->n.sym;
 228   symbol->ts = e->ts;
 229   symbol->as = gfc_get_array_spec ();
 230   symbol->as->rank = e->rank;
 231   symbol->as->type = AS_EXPLICIT;
 232   for (i=0; i<e->rank; i++)
 233     {
 234       gfc_expr *p, *q;
 235
 236       p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 237                                  &(e->where));
 238       mpz_set_si (p->value.integer, 1);
 239       symbol->as->lower[i] = p;
 240
 241       q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
 242                                  &(e->where));
 243       mpz_set (q->value.integer, e->shape[i]);
 244       symbol->as->upper[i] = q;
 245     }
 246
 247   symbol->attr.flavor = FL_VARIABLE;
 248   symbol->attr.referenced = 1;
 249   symbol->attr.dimension = e->rank > 0;
 250   gfc_commit_symbol (symbol);
 251
 252   result = gfc_get_expr ();
 253   result->expr_type = EXPR_VARIABLE;
 254   result->ts = e->ts;
 255   result->rank = e->rank;
 256   result->shape = gfc_copy_shape (e->shape, e->rank);
 257   result->symtree = symtree;
 258   result->where = e->where;
 259   if (e->rank > 0)
 260     {
 261       result->ref = gfc_get_ref ();
 262       result->ref->type = REF_ARRAY;
 263       result->ref->u.ar.type = AR_FULL;
 264       result->ref->u.ar.where = e->where;
 265       result->ref->u.ar.as = symbol->as;
 266       if (gfc_option.warn_array_temp)
 267         gfc_warning ("Creating array temporary at %L", &(e->where));
 268     }
 269
 270   /* Generate the new assignment.  */
 271   n = XCNEW (gfc_code);
 272   n->op = EXEC_ASSIGN;
 273   n->loc = (*current_code)->loc;
 274   n->next = *current_code;
 275   n->expr1 = gfc_copy_expr (result);
 276   n->expr2 = e;
 277   *current_code = n;
 278
 279   return result;
 280 }
 281
 282 /* Callback function for the code walker for doing common function
 283    elimination.  This builds up the list of functions in the expression
 284    and goes through them to detect duplicates, which it then replaces
 285    by variables.  */
 286
 287 static int
 288 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
 289           void *data ATTRIBUTE_UNUSED)
 290 {
 291   int i,j;
 292   gfc_expr *newvar;
 293
 294   expr_count = 0;
 295
 296   gfc_expr_walker (e, cfe_register_funcs, NULL);
 297
 298   /* Walk backwards through all the functions to make sure we
 299      catch the leaf functions first.  */
 300   for (i=expr_count-1; i>=1; i--)
 301     {
 302       /* Skip if the function has been replaced by a variable already.  */
 303       if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
 304         continue;
 305
 306       newvar = NULL;
 307       for (j=i-1; j>=0; j--)
 308         {
 309           if (gfc_dep_compare_functions(*(expr_array[i]),
 310                                         *(expr_array[j]), true) == 0)
 311             {
 312               if (newvar == NULL)
 313                 newvar = create_var (*(expr_array[i]));
 314               gfc_free (*(expr_array[j]));
 315               *(expr_array[j]) = gfc_copy_expr (newvar);
 316             }
 317         }
 318       if (newvar)
 319         *(expr_array[i]) = newvar;
 320     }
 321
 322   /* We did all the necessary walking in this function.  */
 323   *walk_subtrees = 0;
 324   return 0;
 325 }
 326
 327 /* Callback function for common function elimination, called from
 328    gfc_code_walker.  This keeps track of the current code, in order
 329    to insert statements as needed.  */
 330
 331 static int
 332 cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 333           void *data ATTRIBUTE_UNUSED)
 334 {
 335   current_code = c;
 336   return 0;
 337 }
 338
 339 /* Optimize a namespace, including all contained namespaces.  */
 340
 341 static void
 342 optimize_namespace (gfc_namespace *ns)
 343 {
 344
 345   current_ns = ns;
 346
 347   gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
 348   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
 349
 350   for (ns = ns->contained; ns; ns = ns->sibling)
 351     optimize_namespace (ns);
 352 }
 353
 354 /* Replace code like
 355    a = matmul(b,c) + d
 356    with
 357    a = matmul(b,c) ;   a = a + d
 358    where the array function is not elemental and not allocatable
 359    and does not depend on the left-hand side.
 360 */
 361
 362 static bool
 363 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
 364 {
 365   gfc_expr *e;
 366
 367   e = *rhs;
 368   if (e->expr_type == EXPR_OP)
 369     {
 370       switch (e->value.op.op)
 371         {
 372           /* Unary operators and exponentiation: Only look at a single
 373              operand.  */
 374         case INTRINSIC_NOT:
 375         case INTRINSIC_UPLUS:
 376         case INTRINSIC_UMINUS:
 377         case INTRINSIC_PARENTHESES:
 378         case INTRINSIC_POWER:
 379           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
 380             return true;
 381           break;
 382
 383         default:
 384           /* Binary operators.  */
 385           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
 386             return true;
 387
 388           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
 389             return true;
 390
 391           break;
 392         }
 393     }
 394   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
 395            && ! (e->value.function.esym
 396                  && (e->value.function.esym->attr.elemental
 397                      || e->value.function.esym->attr.allocatable
 398                      || e->value.function.esym->ts.type != c->expr1->ts.type
 399                      || e->value.function.esym->ts.kind != c->expr1->ts.kind))
 400            && ! (e->value.function.isym
 401                  && (e->value.function.isym->elemental
 402                      || e->ts.type != c->expr1->ts.type
 403                      || e->ts.kind != c->expr1->ts.kind)))
 404     {
 405
 406       gfc_code *n;
 407       gfc_expr *new_expr;
 408
 409       /* Insert a new assignment statement after the current one.  */
 410       n = XCNEW (gfc_code);
 411       n->op = EXEC_ASSIGN;
 412       n->loc = c->loc;
 413       n->next = c->next;
 414       c->next = n;
 415
 416       n->expr1 = gfc_copy_expr (c->expr1);
 417       n->expr2 = c->expr2;
 418       new_expr = gfc_copy_expr (c->expr1);
 419       c->expr2 = e;
 420       *rhs = new_expr;
 421
 422       return true;
 423
 424     }
 425
 426   /* Nothing to optimize.  */
 427   return false;
 428 }
 429
 430 /* Optimizations for an assignment.  */
 431
 432 static void
 433 optimize_assignment (gfc_code * c)
 434 {
 435   gfc_expr *lhs, *rhs;
 436
 437   lhs = c->expr1;
 438   rhs = c->expr2;
 439
 440   /* Optimize away a = trim(b), where a is a character variable.  */
 441
 442   if (lhs->ts.type == BT_CHARACTER)
 443     {
 444       if (rhs->expr_type == EXPR_FUNCTION &&
 445           rhs->value.function.isym &&
 446           rhs->value.function.isym->id == GFC_ISYM_TRIM)
 447         {
 448           strip_function_call (rhs);
 449           optimize_assignment (c);
 450           return;
 451         }
 452     }
 453
 454   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 455     optimize_binop_array_assignment (c, &rhs, false);
 456 }
 457
 458
 459 /* Remove an unneeded function call, modifying the expression.
 460    This replaces the function call with the value of its
 461    first argument.  The rest of the argument list is freed.  */
 462
 463 static void
 464 strip_function_call (gfc_expr *e)
 465 {
 466   gfc_expr *e1;
 467   gfc_actual_arglist *a;
 468
 469   a = e->value.function.actual;
 470
 471   /* We should have at least one argument.  */
 472   gcc_assert (a->expr != NULL);
 473
 474   e1 = a->expr;
 475
 476   /* Free the remaining arglist, if any.  */
 477   if (a->next)
 478     gfc_free_actual_arglist (a->next);
 479
 480   /* Graft the argument expression onto the original function.  */
 481   *e = *e1;
 482   gfc_free (e1);
 483
 484 }
 485
 486 /* Recursive optimization of operators.  */
 487
 488 static bool
 489 optimize_op (gfc_expr *e)
 490 {
 491   gfc_intrinsic_op op = e->value.op.op;
 492
 493   switch (op)
 494     {
 495     case INTRINSIC_EQ:
 496     case INTRINSIC_EQ_OS:
 497     case INTRINSIC_GE:
 498     case INTRINSIC_GE_OS:
 499     case INTRINSIC_LE:
 500     case INTRINSIC_LE_OS:
 501     case INTRINSIC_NE:
 502     case INTRINSIC_NE_OS:
 503     case INTRINSIC_GT:
 504     case INTRINSIC_GT_OS:
 505     case INTRINSIC_LT:
 506     case INTRINSIC_LT_OS:
 507       return optimize_comparison (e, op);
 508
 509     default:
 510       break;
 511     }
 512
 513   return false;
 514 }
 515
 516 /* Optimize expressions for equality.  */
 517
 518 static bool
 519 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
 520 {
 521   gfc_expr *op1, *op2;
 522   bool change;
 523   int eq;
 524   bool result;
 525
 526   op1 = e->value.op.op1;
 527   op2 = e->value.op.op2;
 528
 529   /* Strip off unneeded TRIM calls from string comparisons.  */
 530
 531   change = false;
 532
 533   if (op1->expr_type == EXPR_FUNCTION
 534       && op1->value.function.isym
 535       && op1->value.function.isym->id == GFC_ISYM_TRIM)
 536     {
 537       strip_function_call (op1);
 538       change = true;
 539     }
 540
 541   if (op2->expr_type == EXPR_FUNCTION
 542       && op2->value.function.isym
 543       && op2->value.function.isym->id == GFC_ISYM_TRIM)
 544     {
 545       strip_function_call (op2);
 546       change = true;
 547     }
 548
 549   if (change)
 550     {
 551       optimize_comparison (e, op);
 552       return true;
 553     }
 554
 555   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 556   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 557      handles them well). However, there are also cases that need a non-scalar
 558      argument. For example the any intrinsic. See PR 45380.  */
 559   if (e->rank > 0)
 560     return false;
 561
 562   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 563
 564   if (flag_finite_math_only
 565       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 566           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
 567     {
 568       eq = gfc_dep_compare_expr (op1, op2);
 569       if (eq == -2)
 570         {
 571           /* Replace A // B < A // C with B < C, and A // B < C // B
 572              with A < C.  */
 573           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 574               && op1->value.op.op == INTRINSIC_CONCAT
 575               && op2->value.op.op == INTRINSIC_CONCAT)
 576             {
 577               gfc_expr *op1_left = op1->value.op.op1;
 578               gfc_expr *op2_left = op2->value.op.op1;
 579               gfc_expr *op1_right = op1->value.op.op2;
 580               gfc_expr *op2_right = op2->value.op.op2;
 581
 582               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
 583                 {
 584                   /* Watch out for 'A ' // x vs. 'A' // x.  */
 585
 586                   if (op1_left->expr_type == EXPR_CONSTANT
 587                         && op2_left->expr_type == EXPR_CONSTANT
 588                         && op1_left->value.character.length
 589                            != op2_left->value.character.length)
 590                     return -2;
 591                   else
 592                     {
 593                       gfc_free (op1_left);
 594                       gfc_free (op2_left);
 595                       e->value.op.op1 = op1_right;
 596                       e->value.op.op2 = op2_right;
 597                       optimize_comparison (e, op);
 598                       return true;
 599                     }
 600                 }
 601               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
 602                 {
 603                   gfc_free (op1_right);
 604                   gfc_free (op2_right);
 605                   e->value.op.op1 = op1_left;
 606                   e->value.op.op2 = op2_left;
 607                   optimize_comparison (e, op);
 608                   return true;
 609                 }
 610             }
 611         }
 612       else
 613         {
 614           /* eq can only be -1, 0 or 1 at this point.  */
 615           switch (op)
 616             {
 617             case INTRINSIC_EQ:
 618             case INTRINSIC_EQ_OS:
 619               result = eq == 0;
 620               break;
 621
 622             case INTRINSIC_GE:
 623             case INTRINSIC_GE_OS:
 624               result = eq >= 0;
 625               break;
 626
 627             case INTRINSIC_LE:
 628             case INTRINSIC_LE_OS:
 629               result = eq <= 0;
 630               break;
 631
 632             case INTRINSIC_NE:
 633             case INTRINSIC_NE_OS:
 634               result = eq != 0;
 635               break;
 636
 637             case INTRINSIC_GT:
 638             case INTRINSIC_GT_OS:
 639               result = eq > 0;
 640               break;
 641
 642             case INTRINSIC_LT:
 643             case INTRINSIC_LT_OS:
 644               result = eq < 0;
 645               break;
 646
 647             default:
 648               gfc_internal_error ("illegal OP in optimize_comparison");
 649               break;
 650             }
 651
 652           /* Replace the expression by a constant expression.  The typespec
 653              and where remains the way it is.  */
 654           gfc_free (op1);
 655           gfc_free (op2);
 656           e->expr_type = EXPR_CONSTANT;
 657           e->value.logical = result;
 658           return true;
 659         }
 660     }
 661
 662   return false;
 663 }
 664
 665 /* Optimize a trim function by replacing it with an equivalent substring
 666    involving a call to len_trim.  This only works for expressions where
 667    variables are trimmed.  Return true if anything was modified.  */
 668
 669 static bool
 670 optimize_trim (gfc_expr *e)
 671 {
 672   gfc_expr *a;
 673   gfc_ref *ref;
 674   gfc_expr *fcn;
 675   gfc_actual_arglist *actual_arglist, *next;
 676   gfc_ref **rr = NULL;
 677
 678   /* Don't do this optimization within an argument list, because
 679      otherwise aliasing issues may occur.  */
 680
 681   if (count_arglist != 1)
 682     return false;
 683
 684   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
 685       || e->value.function.isym == NULL
 686       || e->value.function.isym->id != GFC_ISYM_TRIM)
 687     return false;
 688
 689   a = e->value.function.actual->expr;
 690
 691   if (a->expr_type != EXPR_VARIABLE)
 692     return false;
 693
 694   /* Follow all references to find the correct place to put the newly
 695      created reference.  FIXME:  Also handle substring references and
 696      array references.  Array references cause strange regressions at
 697      the moment.  */
 698
 699   if (a->ref)
 700     {
 701       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
 702         {
 703           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
 704             return false;
 705         }
 706     }
 707
 708   strip_function_call (e);
 709
 710   if (e->ref == NULL)
 711     rr = &(e->ref);
 712
 713   /* Create the reference.  */
 714
 715   ref = gfc_get_ref ();
 716   ref->type = REF_SUBSTRING;
 717
 718   /* Set the start of the reference.  */
 719
 720   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 721
 722   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 723
 724   fcn = gfc_get_expr ();
 725   fcn->expr_type = EXPR_FUNCTION;
 726   fcn->value.function.isym =
 727     gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
 728   actual_arglist = gfc_get_actual_arglist ();
 729   actual_arglist->expr = gfc_copy_expr (e);
 730   next = gfc_get_actual_arglist ();
 731   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
 732                                  gfc_default_integer_kind);
 733   actual_arglist->next = next;
 734   fcn->value.function.actual = actual_arglist;
 735
 736   /* Set the end of the reference to the call to len_trim.  */
 737
 738   ref->u.ss.end = fcn;
 739   gcc_assert (*rr == NULL);
 740   *rr = ref;
 741   return true;
 742 }
 743
 744 #define WALK_SUBEXPR(NODE) \
 745   do                                                    \
 746     {                                                   \
 747       result = gfc_expr_walker (&(NODE), exprfn, data); \
 748       if (result)                                       \
 749         return result;                                  \
 750     }                                                   \
 751   while (0)
 752 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
 753
 754 /* Walk expression *E, calling EXPRFN on each expression in it.  */
 755
 756 int
 757 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
 758 {
 759   while (*e)
 760     {
 761       int walk_subtrees = 1;
 762       gfc_actual_arglist *a;
 763       gfc_ref *r;
 764       gfc_constructor *c;
 765
 766       int result = exprfn (e, &walk_subtrees, data);
 767       if (result)
 768         return result;
 769       if (walk_subtrees)
 770         switch ((*e)->expr_type)
 771           {
 772           case EXPR_OP:
 773             WALK_SUBEXPR ((*e)->value.op.op1);
 774             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
 775             break;
 776           case EXPR_FUNCTION:
 777             for (a = (*e)->value.function.actual; a; a = a->next)
 778               WALK_SUBEXPR (a->expr);
 779             break;
 780           case EXPR_COMPCALL:
 781           case EXPR_PPC:
 782             WALK_SUBEXPR ((*e)->value.compcall.base_object);
 783             for (a = (*e)->value.compcall.actual; a; a = a->next)
 784               WALK_SUBEXPR (a->expr);
 785             break;
 786
 787           case EXPR_STRUCTURE:
 788           case EXPR_ARRAY:
 789             for (c = gfc_constructor_first ((*e)->value.constructor); c;
 790                  c = gfc_constructor_next (c))
 791               {
 792                 WALK_SUBEXPR (c->expr);
 793                 if (c->iterator != NULL)
 794                   {
 795                     WALK_SUBEXPR (c->iterator->var);
 796                     WALK_SUBEXPR (c->iterator->start);
 797                     WALK_SUBEXPR (c->iterator->end);
 798                     WALK_SUBEXPR (c->iterator->step);
 799                   }
 800               }
 801
 802             if ((*e)->expr_type != EXPR_ARRAY)
 803               break;
 804
 805             /* Fall through to the variable case in order to walk the
 806                the reference.  */
 807
 808           case EXPR_SUBSTRING:
 809           case EXPR_VARIABLE:
 810             for (r = (*e)->ref; r; r = r->next)
 811               {
 812                 gfc_array_ref *ar;
 813                 int i;
 814
 815                 switch (r->type)
 816                   {
 817                   case REF_ARRAY:
 818                     ar = &r->u.ar;
 819                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
 820                       {
 821                         for (i=0; i< ar->dimen; i++)
 822                           {
 823                             WALK_SUBEXPR (ar->start[i]);
 824                             WALK_SUBEXPR (ar->end[i]);
 825                             WALK_SUBEXPR (ar->stride[i]);
 826                           }
 827                       }
 828
 829                     break;
 830
 831                   case REF_SUBSTRING:
 832                     WALK_SUBEXPR (r->u.ss.start);
 833                     WALK_SUBEXPR (r->u.ss.end);
 834                     break;
 835
 836                   case REF_COMPONENT:
 837                     break;
 838                   }
 839               }
 840
 841           default:
 842             break;
 843           }
 844       return 0;
 845     }
 846   return 0;
 847 }
 848
 849 #define WALK_SUBCODE(NODE) \
 850   do                                                            \
 851     {                                                           \
 852       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
 853       if (result)                                               \
 854         return result;                                          \
 855     }                                                           \
 856   while (0)
 857
 858 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
 859    on each expression in it.  If any of the hooks returns non-zero, that
 860    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
 861    no subcodes or subexpressions are traversed.  */
 862
 863 int
 864 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 865                  void *data)
 866 {
 867   for (; *c; c = &(*c)->next)
 868     {
 869       int walk_subtrees = 1;
 870       int result = codefn (c, &walk_subtrees, data);
 871       if (result)
 872         return result;
 873
 874       if (walk_subtrees)
 875         {
 876           gfc_code *b;
 877           gfc_actual_arglist *a;
 878
 879           switch ((*c)->op)
 880             {
 881             case EXEC_DO:
 882               WALK_SUBEXPR ((*c)->ext.iterator->var);
 883               WALK_SUBEXPR ((*c)->ext.iterator->start);
 884               WALK_SUBEXPR ((*c)->ext.iterator->end);
 885               WALK_SUBEXPR ((*c)->ext.iterator->step);
 886               break;
 887
 888             case EXEC_CALL:
 889             case EXEC_ASSIGN_CALL:
 890               for (a = (*c)->ext.actual; a; a = a->next)
 891                 WALK_SUBEXPR (a->expr);
 892               break;
 893
 894             case EXEC_CALL_PPC:
 895               WALK_SUBEXPR ((*c)->expr1);
 896               for (a = (*c)->ext.actual; a; a = a->next)
 897                 WALK_SUBEXPR (a->expr);
 898               break;
 899
 900             case EXEC_SELECT:
 901               WALK_SUBEXPR ((*c)->expr1);
 902               for (b = (*c)->block; b; b = b->block)
 903                 {
 904                   gfc_case *cp;
 905                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
 906                     {
 907                       WALK_SUBEXPR (cp->low);
 908                       WALK_SUBEXPR (cp->high);
 909                     }
 910                   WALK_SUBCODE (b->next);
 911                 }
 912               continue;
 913
 914             case EXEC_ALLOCATE:
 915             case EXEC_DEALLOCATE:
 916               {
 917                 gfc_alloc *a;
 918                 for (a = (*c)->ext.alloc.list; a; a = a->next)
 919                   WALK_SUBEXPR (a->expr);
 920                 break;
 921               }
 922
 923             case EXEC_FORALL:
 924               {
 925                 gfc_forall_iterator *fa;
 926                 for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
 927                   {
 928                     WALK_SUBEXPR (fa->var);
 929                     WALK_SUBEXPR (fa->start);
 930                     WALK_SUBEXPR (fa->end);
 931                     WALK_SUBEXPR (fa->stride);
 932                   }
 933                 break;
 934               }
 935
 936             case EXEC_OPEN:
 937               WALK_SUBEXPR ((*c)->ext.open->unit);
 938               WALK_SUBEXPR ((*c)->ext.open->file);
 939               WALK_SUBEXPR ((*c)->ext.open->status);
 940               WALK_SUBEXPR ((*c)->ext.open->access);
 941               WALK_SUBEXPR ((*c)->ext.open->form);
 942               WALK_SUBEXPR ((*c)->ext.open->recl);
 943               WALK_SUBEXPR ((*c)->ext.open->blank);
 944               WALK_SUBEXPR ((*c)->ext.open->position);
 945               WALK_SUBEXPR ((*c)->ext.open->action);
 946               WALK_SUBEXPR ((*c)->ext.open->delim);
 947               WALK_SUBEXPR ((*c)->ext.open->pad);
 948               WALK_SUBEXPR ((*c)->ext.open->iostat);
 949               WALK_SUBEXPR ((*c)->ext.open->iomsg);
 950               WALK_SUBEXPR ((*c)->ext.open->convert);
 951               WALK_SUBEXPR ((*c)->ext.open->decimal);
 952               WALK_SUBEXPR ((*c)->ext.open->encoding);
 953               WALK_SUBEXPR ((*c)->ext.open->round);
 954               WALK_SUBEXPR ((*c)->ext.open->sign);
 955               WALK_SUBEXPR ((*c)->ext.open->asynchronous);
 956               WALK_SUBEXPR ((*c)->ext.open->id);
 957               WALK_SUBEXPR ((*c)->ext.open->newunit);
 958               break;
 959
 960             case EXEC_CLOSE:
 961               WALK_SUBEXPR ((*c)->ext.close->unit);
 962               WALK_SUBEXPR ((*c)->ext.close->status);
 963               WALK_SUBEXPR ((*c)->ext.close->iostat);
 964               WALK_SUBEXPR ((*c)->ext.close->iomsg);
 965               break;
 966
 967             case EXEC_BACKSPACE:
 968             case EXEC_ENDFILE:
 969             case EXEC_REWIND:
 970             case EXEC_FLUSH:
 971               WALK_SUBEXPR ((*c)->ext.filepos->unit);
 972               WALK_SUBEXPR ((*c)->ext.filepos->iostat);
 973               WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
 974               break;
 975
 976             case EXEC_INQUIRE:
 977               WALK_SUBEXPR ((*c)->ext.inquire->unit);
 978               WALK_SUBEXPR ((*c)->ext.inquire->file);
 979               WALK_SUBEXPR ((*c)->ext.inquire->iomsg);
 980               WALK_SUBEXPR ((*c)->ext.inquire->iostat);
 981               WALK_SUBEXPR ((*c)->ext.inquire->exist);
 982               WALK_SUBEXPR ((*c)->ext.inquire->opened);
 983               WALK_SUBEXPR ((*c)->ext.inquire->number);
 984               WALK_SUBEXPR ((*c)->ext.inquire->named);
 985               WALK_SUBEXPR ((*c)->ext.inquire->name);
 986               WALK_SUBEXPR ((*c)->ext.inquire->access);
 987               WALK_SUBEXPR ((*c)->ext.inquire->sequential);
 988               WALK_SUBEXPR ((*c)->ext.inquire->direct);
 989               WALK_SUBEXPR ((*c)->ext.inquire->form);
 990               WALK_SUBEXPR ((*c)->ext.inquire->formatted);
 991               WALK_SUBEXPR ((*c)->ext.inquire->unformatted);
 992               WALK_SUBEXPR ((*c)->ext.inquire->recl);
 993               WALK_SUBEXPR ((*c)->ext.inquire->nextrec);
 994               WALK_SUBEXPR ((*c)->ext.inquire->blank);
 995               WALK_SUBEXPR ((*c)->ext.inquire->position);
 996               WALK_SUBEXPR ((*c)->ext.inquire->action);
 997               WALK_SUBEXPR ((*c)->ext.inquire->read);
 998               WALK_SUBEXPR ((*c)->ext.inquire->write);
 999               WALK_SUBEXPR ((*c)->ext.inquire->readwrite);
1000               WALK_SUBEXPR ((*c)->ext.inquire->delim);
1001               WALK_SUBEXPR ((*c)->ext.inquire->encoding);
1002               WALK_SUBEXPR ((*c)->ext.inquire->pad);
1003               WALK_SUBEXPR ((*c)->ext.inquire->iolength);
1004               WALK_SUBEXPR ((*c)->ext.inquire->convert);
1005               WALK_SUBEXPR ((*c)->ext.inquire->strm_pos);
1006               WALK_SUBEXPR ((*c)->ext.inquire->asynchronous);
1007               WALK_SUBEXPR ((*c)->ext.inquire->decimal);
1008               WALK_SUBEXPR ((*c)->ext.inquire->pending);
1009               WALK_SUBEXPR ((*c)->ext.inquire->id);
1010               WALK_SUBEXPR ((*c)->ext.inquire->sign);
1011               WALK_SUBEXPR ((*c)->ext.inquire->size);
1012               WALK_SUBEXPR ((*c)->ext.inquire->round);
1013               break;
1014
1015             case EXEC_WAIT:
1016               WALK_SUBEXPR ((*c)->ext.wait->unit);
1017               WALK_SUBEXPR ((*c)->ext.wait->iostat);
1018               WALK_SUBEXPR ((*c)->ext.wait->iomsg);
1019               WALK_SUBEXPR ((*c)->ext.wait->id);
1020               break;
1021
1022             case EXEC_READ:
1023             case EXEC_WRITE:
1024               WALK_SUBEXPR ((*c)->ext.dt->io_unit);
1025               WALK_SUBEXPR ((*c)->ext.dt->format_expr);
1026               WALK_SUBEXPR ((*c)->ext.dt->rec);
1027               WALK_SUBEXPR ((*c)->ext.dt->advance);
1028               WALK_SUBEXPR ((*c)->ext.dt->iostat);
1029               WALK_SUBEXPR ((*c)->ext.dt->size);
1030               WALK_SUBEXPR ((*c)->ext.dt->iomsg);
1031               WALK_SUBEXPR ((*c)->ext.dt->id);
1032               WALK_SUBEXPR ((*c)->ext.dt->pos);
1033               WALK_SUBEXPR ((*c)->ext.dt->asynchronous);
1034               WALK_SUBEXPR ((*c)->ext.dt->blank);
1035               WALK_SUBEXPR ((*c)->ext.dt->decimal);
1036               WALK_SUBEXPR ((*c)->ext.dt->delim);
1037               WALK_SUBEXPR ((*c)->ext.dt->pad);
1038               WALK_SUBEXPR ((*c)->ext.dt->round);
1039               WALK_SUBEXPR ((*c)->ext.dt->sign);
1040               WALK_SUBEXPR ((*c)->ext.dt->extra_comma);
1041               break;
1042
1043             case EXEC_OMP_DO:
1044             case EXEC_OMP_PARALLEL:
1045             case EXEC_OMP_PARALLEL_DO:
1046             case EXEC_OMP_PARALLEL_SECTIONS:
1047             case EXEC_OMP_PARALLEL_WORKSHARE:
1048             case EXEC_OMP_SECTIONS:
1049             case EXEC_OMP_SINGLE:
1050             case EXEC_OMP_WORKSHARE:
1051             case EXEC_OMP_END_SINGLE:
1052             case EXEC_OMP_TASK:
1053               if ((*c)->ext.omp_clauses)
1054                 {
1055                   WALK_SUBEXPR ((*c)->ext.omp_clauses->if_expr);
1056                   WALK_SUBEXPR ((*c)->ext.omp_clauses->num_threads);
1057                   WALK_SUBEXPR ((*c)->ext.omp_clauses->chunk_size);
1058                 }
1059               break;
1060             default:
1061               break;
1062             }
1063
1064           WALK_SUBEXPR ((*c)->expr1);
1065           WALK_SUBEXPR ((*c)->expr2);
1066           WALK_SUBEXPR ((*c)->expr3);
1067           for (b = (*c)->block; b; b = b->block)
1068             {
1069               WALK_SUBEXPR (b->expr1);
1070               WALK_SUBEXPR (b->expr2);
1071               WALK_SUBCODE (b->next);
1072             }
1073         }
1074     }
1075   return 0;
1076 }