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