OSDN Git Service

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