projects / gcc.git / blob
? search:


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