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