?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
re PR fortran/54687 (Use gcc option machinery for gfortran)
[official-gcc.git] / gcc / fortran / frontend-passes.c
blob7d59f2ebd6bb4e070c023e4ea91c57d130bac30c
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 (flag_frontend_optimize)
108 {
109 optimize_namespace (ns);
110 optimize_reduction (ns);
111 if (flag_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 && !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 (!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 (warn_array_temporaries)
550 gfc_warning (OPT_Warray_temporaries,
551 "Creating array temporary at %L", &(e->where));
552 }
553
554 /* Generate the new assignment. */
555 n = XCNEW (gfc_code);
556 n->op = EXEC_ASSIGN;
557 n->loc = (*current_code)->loc;
558 n->next = *changed_statement;
559 n->expr1 = gfc_copy_expr (result);
560 n->expr2 = e;
561 *changed_statement = n;
562
563 return result;
564 }
565
566 /* Warn about function elimination. */
567
568 static void
569 do_warn_function_elimination (gfc_expr *e)
570 {
571 if (e->expr_type != EXPR_FUNCTION)
572 return;
573 if (e->value.function.esym)
574 gfc_warning ("Removing call to function %qs at %L",
575 e->value.function.esym->name, &(e->where));
576 else if (e->value.function.isym)
577 gfc_warning ("Removing call to function %qs at %L",
578 e->value.function.isym->name, &(e->where));
579 }
580 /* Callback function for the code walker for doing common function
581 elimination. This builds up the list of functions in the expression
582 and goes through them to detect duplicates, which it then replaces
583 by variables. */
584
585 static int
586 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
587 void *data ATTRIBUTE_UNUSED)
588 {
589 int i,j;
590 gfc_expr *newvar;
591 gfc_expr **ei, **ej;
592
593 /* Don't do this optimization within OMP workshare. */
594
595 if (in_omp_workshare)
596 {
597 *walk_subtrees = 0;
598 return 0;
599 }
600
601 expr_array.release ();
602
603 gfc_expr_walker (e, cfe_register_funcs, NULL);
604
605 /* Walk through all the functions. */
606
607 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
608 {
609 /* Skip if the function has been replaced by a variable already. */
610 if ((*ei)->expr_type == EXPR_VARIABLE)
611 continue;
612
613 newvar = NULL;
614 for (j=0; j<i; j++)
615 {
616 ej = expr_array[j];
617 if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
618 {
619 if (newvar == NULL)
620 newvar = create_var (*ei);
621
622 if (warn_function_elimination)
623 do_warn_function_elimination (*ej);
624
625 free (*ej);
626 *ej = gfc_copy_expr (newvar);
627 }
628 }
629 if (newvar)
630 *ei = newvar;
631 }
632
633 /* We did all the necessary walking in this function. */
634 *walk_subtrees = 0;
635 return 0;
636 }
637
638 /* Callback function for common function elimination, called from
639 gfc_code_walker. This keeps track of the current code, in order
640 to insert statements as needed. */
641
642 static int
643 cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
644 {
645 current_code = c;
646 inserted_block = NULL;
647 changed_statement = NULL;
648
649 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
650 and allocation on assigment are prohibited inside WHERE, and finally
651 masking an expression would lead to wrong-code when replacing
652
653 WHERE (a>0)
654 b = sum(foo(a) + foo(a))
655 END WHERE
656
657 with
658
659 WHERE (a > 0)
660 tmp = foo(a)
661 b = sum(tmp + tmp)
662 END WHERE
663 */
664
665 if ((*c)->op == EXEC_WHERE)
666 {
667 *walk_subtrees = 0;
668 return 0;
669 }
670
671
672 return 0;
673 }
674
675 /* Dummy function for expression call back, for use when we
676 really don't want to do any walking. */
677
678 static int
679 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
680 void *data ATTRIBUTE_UNUSED)
681 {
682 *walk_subtrees = 0;
683 return 0;
684 }
685
686 /* Dummy function for code callback, for use when we really
687 don't want to do anything. */
688 int
689 gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
690 int *walk_subtrees ATTRIBUTE_UNUSED,
691 void *data ATTRIBUTE_UNUSED)
692 {
693 return 0;
694 }
695
696 /* Code callback function for converting
697 do while(a)
698 end do
699 into the equivalent
700 do
701 if (.not. a) exit
702 end do
703 This is because common function elimination would otherwise place the
704 temporary variables outside the loop. */
705
706 static int
707 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
708 void *data ATTRIBUTE_UNUSED)
709 {
710 gfc_code *co = *c;
711 gfc_code *c_if1, *c_if2, *c_exit;
712 gfc_code *loopblock;
713 gfc_expr *e_not, *e_cond;
714
715 if (co->op != EXEC_DO_WHILE)
716 return 0;
717
718 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
719 return 0;
720
721 e_cond = co->expr1;
722
723 /* Generate the condition of the if statement, which is .not. the original
724 statement. */
725 e_not = gfc_get_expr ();
726 e_not->ts = e_cond->ts;
727 e_not->where = e_cond->where;
728 e_not->expr_type = EXPR_OP;
729 e_not->value.op.op = INTRINSIC_NOT;
730 e_not->value.op.op1 = e_cond;
731
732 /* Generate the EXIT statement. */
733 c_exit = XCNEW (gfc_code);
734 c_exit->op = EXEC_EXIT;
735 c_exit->ext.which_construct = co;
736 c_exit->loc = co->loc;
737
738 /* Generate the IF statement. */
739 c_if2 = XCNEW (gfc_code);
740 c_if2->op = EXEC_IF;
741 c_if2->expr1 = e_not;
742 c_if2->next = c_exit;
743 c_if2->loc = co->loc;
744
745 /* ... plus the one to chain it to. */
746 c_if1 = XCNEW (gfc_code);
747 c_if1->op = EXEC_IF;
748 c_if1->block = c_if2;
749 c_if1->loc = co->loc;
750
751 /* Make the DO WHILE loop into a DO block by replacing the condition
752 with a true constant. */
753 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
754
755 /* Hang the generated if statement into the loop body. */
756
757 loopblock = co->block->next;
758 co->block->next = c_if1;
759 c_if1->next = loopblock;
760
761 return 0;
762 }
763
764 /* Code callback function for converting
765 if (a) then
766 ...
767 else if (b) then
768 end if
769
770 into
771 if (a) then
772 else
773 if (b) then
774 end if
775 end if
776
777 because otherwise common function elimination would place the BLOCKs
778 into the wrong place. */
779
780 static int
781 convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
782 void *data ATTRIBUTE_UNUSED)
783 {
784 gfc_code *co = *c;
785 gfc_code *c_if1, *c_if2, *else_stmt;
786
787 if (co->op != EXEC_IF)
788 return 0;
789
790 /* This loop starts out with the first ELSE statement. */
791 else_stmt = co->block->block;
792
793 while (else_stmt != NULL)
794 {
795 gfc_code *next_else;
796
797 /* If there is no condition, we're done. */
798 if (else_stmt->expr1 == NULL)
799 break;
800
801 next_else = else_stmt->block;
802
803 /* Generate the new IF statement. */
804 c_if2 = XCNEW (gfc_code);
805 c_if2->op = EXEC_IF;
806 c_if2->expr1 = else_stmt->expr1;
807 c_if2->next = else_stmt->next;
808 c_if2->loc = else_stmt->loc;
809 c_if2->block = next_else;
810
811 /* ... plus the one to chain it to. */
812 c_if1 = XCNEW (gfc_code);
813 c_if1->op = EXEC_IF;
814 c_if1->block = c_if2;
815 c_if1->loc = else_stmt->loc;
816
817 /* Insert the new IF after the ELSE. */
818 else_stmt->expr1 = NULL;
819 else_stmt->next = c_if1;
820 else_stmt->block = NULL;
821
822 else_stmt = next_else;
823 }
824 /* Don't walk subtrees. */
825 return 0;
826 }
827 /* Optimize a namespace, including all contained namespaces. */
828
829 static void
830 optimize_namespace (gfc_namespace *ns)
831 {
832
833 current_ns = ns;
834 forall_level = 0;
835 iterator_level = 0;
836 in_assoc_list = false;
837 in_omp_workshare = false;
838
839 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
840 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
841 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
842 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
843
844 /* BLOCKs are handled in the expression walker below. */
845 for (ns = ns->contained; ns; ns = ns->sibling)
846 {
847 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
848 optimize_namespace (ns);
849 }
850 }
851
852 static void
853 optimize_reduction (gfc_namespace *ns)
854 {
855 current_ns = ns;
856 gfc_code_walker (&ns->code, gfc_dummy_code_callback,
857 callback_reduction, NULL);
858
859 /* BLOCKs are handled in the expression walker below. */
860 for (ns = ns->contained; ns; ns = ns->sibling)
861 {
862 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
863 optimize_reduction (ns);
864 }
865 }
866
867 /* Replace code like
868 a = matmul(b,c) + d
869 with
870 a = matmul(b,c) ; a = a + d
871 where the array function is not elemental and not allocatable
872 and does not depend on the left-hand side.
873 */
874
875 static bool
876 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
877 {
878 gfc_expr *e;
879
880 e = *rhs;
881 if (e->expr_type == EXPR_OP)
882 {
883 switch (e->value.op.op)
884 {
885 /* Unary operators and exponentiation: Only look at a single
886 operand. */
887 case INTRINSIC_NOT:
888 case INTRINSIC_UPLUS:
889 case INTRINSIC_UMINUS:
890 case INTRINSIC_PARENTHESES:
891 case INTRINSIC_POWER:
892 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
893 return true;
894 break;
895
896 case INTRINSIC_CONCAT:
897 /* Do not do string concatenations. */
898 break;
899
900 default:
901 /* Binary operators. */
902 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
903 return true;
904
905 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
906 return true;
907
908 break;
909 }
910 }
911 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
912 && ! (e->value.function.esym
913 && (e->value.function.esym->attr.elemental
914 || e->value.function.esym->attr.allocatable
915 || e->value.function.esym->ts.type != c->expr1->ts.type
916 || e->value.function.esym->ts.kind != c->expr1->ts.kind))
917 && ! (e->value.function.isym
918 && (e->value.function.isym->elemental
919 || e->ts.type != c->expr1->ts.type
920 || e->ts.kind != c->expr1->ts.kind))
921 && ! gfc_inline_intrinsic_function_p (e))
922 {
923
924 gfc_code *n;
925 gfc_expr *new_expr;
926
927 /* Insert a new assignment statement after the current one. */
928 n = XCNEW (gfc_code);
929 n->op = EXEC_ASSIGN;
930 n->loc = c->loc;
931 n->next = c->next;
932 c->next = n;
933
934 n->expr1 = gfc_copy_expr (c->expr1);
935 n->expr2 = c->expr2;
936 new_expr = gfc_copy_expr (c->expr1);
937 c->expr2 = e;
938 *rhs = new_expr;
939
940 return true;
941
942 }
943
944 /* Nothing to optimize. */
945 return false;
946 }
947
948 /* Remove unneeded TRIMs at the end of expressions. */
949
950 static bool
951 remove_trim (gfc_expr *rhs)
952 {
953 bool ret;
954
955 ret = false;
956
957 /* Check for a // b // trim(c). Looping is probably not
958 necessary because the parser usually generates
959 (// (// a b ) trim(c) ) , but better safe than sorry. */
960
961 while (rhs->expr_type == EXPR_OP
962 && rhs->value.op.op == INTRINSIC_CONCAT)
963 rhs = rhs->value.op.op2;
964
965 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
966 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
967 {
968 strip_function_call (rhs);
969 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
970 remove_trim (rhs);
971 ret = true;
972 }
973
974 return ret;
975 }
976
977 /* Optimizations for an assignment. */
978
979 static void
980 optimize_assignment (gfc_code * c)
981 {
982 gfc_expr *lhs, *rhs;
983
984 lhs = c->expr1;
985 rhs = c->expr2;
986
987 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
988 {
989 /* Optimize a = trim(b) to a = b. */
990 remove_trim (rhs);
991
992 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
993 if (is_empty_string (rhs))
994 rhs->value.character.length = 0;
995 }
996
997 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
998 optimize_binop_array_assignment (c, &rhs, false);
999 }
1000
1001
1002 /* Remove an unneeded function call, modifying the expression.
1003 This replaces the function call with the value of its
1004 first argument. The rest of the argument list is freed. */
1005
1006 static void
1007 strip_function_call (gfc_expr *e)
1008 {
1009 gfc_expr *e1;
1010 gfc_actual_arglist *a;
1011
1012 a = e->value.function.actual;
1013
1014 /* We should have at least one argument. */
1015 gcc_assert (a->expr != NULL);
1016
1017 e1 = a->expr;
1018
1019 /* Free the remaining arglist, if any. */
1020 if (a->next)
1021 gfc_free_actual_arglist (a->next);
1022
1023 /* Graft the argument expression onto the original function. */
1024 *e = *e1;
1025 free (e1);
1026
1027 }
1028
1029 /* Optimization of lexical comparison functions. */
1030
1031 static bool
1032 optimize_lexical_comparison (gfc_expr *e)
1033 {
1034 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1035 return false;
1036
1037 switch (e->value.function.isym->id)
1038 {
1039 case GFC_ISYM_LLE:
1040 return optimize_comparison (e, INTRINSIC_LE);
1041
1042 case GFC_ISYM_LGE:
1043 return optimize_comparison (e, INTRINSIC_GE);
1044
1045 case GFC_ISYM_LGT:
1046 return optimize_comparison (e, INTRINSIC_GT);
1047
1048 case GFC_ISYM_LLT:
1049 return optimize_comparison (e, INTRINSIC_LT);
1050
1051 default:
1052 break;
1053 }
1054 return false;
1055 }
1056
1057 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1058 do CHARACTER because of possible pessimization involving character
1059 lengths. */
1060
1061 static bool
1062 combine_array_constructor (gfc_expr *e)
1063 {
1064
1065 gfc_expr *op1, *op2;
1066 gfc_expr *scalar;
1067 gfc_expr *new_expr;
1068 gfc_constructor *c, *new_c;
1069 gfc_constructor_base oldbase, newbase;
1070 bool scalar_first;
1071
1072 /* Array constructors have rank one. */
1073 if (e->rank != 1)
1074 return false;
1075
1076 /* Don't try to combine association lists, this makes no sense
1077 and leads to an ICE. */
1078 if (in_assoc_list)
1079 return false;
1080
1081 op1 = e->value.op.op1;
1082 op2 = e->value.op.op2;
1083
1084 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1085 scalar_first = false;
1086 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1087 {
1088 scalar_first = true;
1089 op1 = e->value.op.op2;
1090 op2 = e->value.op.op1;
1091 }
1092 else
1093 return false;
1094
1095 if (op2->ts.type == BT_CHARACTER)
1096 return false;
1097
1098 scalar = create_var (gfc_copy_expr (op2));
1099
1100 oldbase = op1->value.constructor;
1101 newbase = NULL;
1102 e->expr_type = EXPR_ARRAY;
1103
1104 for (c = gfc_constructor_first (oldbase); c;
1105 c = gfc_constructor_next (c))
1106 {
1107 new_expr = gfc_get_expr ();
1108 new_expr->ts = e->ts;
1109 new_expr->expr_type = EXPR_OP;
1110 new_expr->rank = c->expr->rank;
1111 new_expr->where = c->where;
1112 new_expr->value.op.op = e->value.op.op;
1113
1114 if (scalar_first)
1115 {
1116 new_expr->value.op.op1 = gfc_copy_expr (scalar);
1117 new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1118 }
1119 else
1120 {
1121 new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1122 new_expr->value.op.op2 = gfc_copy_expr (scalar);
1123 }
1124
1125 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
1126 new_c->iterator = c->iterator;
1127 c->iterator = NULL;
1128 }
1129
1130 gfc_free_expr (op1);
1131 gfc_free_expr (op2);
1132 gfc_free_expr (scalar);
1133
1134 e->value.constructor = newbase;
1135 return true;
1136 }
1137
1138 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1139 2**k into ishift(1,k) */
1140
1141 static bool
1142 optimize_power (gfc_expr *e)
1143 {
1144 gfc_expr *op1, *op2;
1145 gfc_expr *iand, *ishft;
1146
1147 if (e->ts.type != BT_INTEGER)
1148 return false;
1149
1150 op1 = e->value.op.op1;
1151
1152 if (op1 == NULL || op1->expr_type != EXPR_CONSTANT)
1153 return false;
1154
1155 if (mpz_cmp_si (op1->value.integer, -1L) == 0)
1156 {
1157 gfc_free_expr (op1);
1158
1159 op2 = e->value.op.op2;
1160
1161 if (op2 == NULL)
1162 return false;
1163
1164 iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND,
1165 "_internal_iand", e->where, 2, op2,
1166 gfc_get_int_expr (e->ts.kind,
1167 &e->where, 1));
1168
1169 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1170 "_internal_ishft", e->where, 2, iand,
1171 gfc_get_int_expr (e->ts.kind,
1172 &e->where, 1));
1173
1174 e->value.op.op = INTRINSIC_MINUS;
1175 e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1);
1176 e->value.op.op2 = ishft;
1177 return true;
1178 }
1179 else if (mpz_cmp_si (op1->value.integer, 2L) == 0)
1180 {
1181 gfc_free_expr (op1);
1182
1183 op2 = e->value.op.op2;
1184 if (op2 == NULL)
1185 return false;
1186
1187 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1188 "_internal_ishft", e->where, 2,
1189 gfc_get_int_expr (e->ts.kind,
1190 &e->where, 1),
1191 op2);
1192 *e = *ishft;
1193 return true;
1194 }
1195
1196 else if (mpz_cmp_si (op1->value.integer, 1L) == 0)
1197 {
1198 op2 = e->value.op.op2;
1199 if (op2 == NULL)
1200 return false;
1201
1202 gfc_free_expr (op1);
1203 gfc_free_expr (op2);
1204
1205 e->expr_type = EXPR_CONSTANT;
1206 e->value.op.op1 = NULL;
1207 e->value.op.op2 = NULL;
1208 mpz_init_set_si (e->value.integer, 1);
1209 /* Typespec and location are still OK. */
1210 return true;
1211 }
1212
1213 return false;
1214 }
1215
1216 /* Recursive optimization of operators. */
1217
1218 static bool
1219 optimize_op (gfc_expr *e)
1220 {
1221 bool changed;
1222
1223 gfc_intrinsic_op op = e->value.op.op;
1224
1225 changed = false;
1226
1227 /* Only use new-style comparisons. */
1228 switch(op)
1229 {
1230 case INTRINSIC_EQ_OS:
1231 op = INTRINSIC_EQ;
1232 break;
1233
1234 case INTRINSIC_GE_OS:
1235 op = INTRINSIC_GE;
1236 break;
1237
1238 case INTRINSIC_LE_OS:
1239 op = INTRINSIC_LE;
1240 break;
1241
1242 case INTRINSIC_NE_OS:
1243 op = INTRINSIC_NE;
1244 break;
1245
1246 case INTRINSIC_GT_OS:
1247 op = INTRINSIC_GT;
1248 break;
1249
1250 case INTRINSIC_LT_OS:
1251 op = INTRINSIC_LT;
1252 break;
1253
1254 default:
1255 break;
1256 }
1257
1258 switch (op)
1259 {
1260 case INTRINSIC_EQ:
1261 case INTRINSIC_GE:
1262 case INTRINSIC_LE:
1263 case INTRINSIC_NE:
1264 case INTRINSIC_GT:
1265 case INTRINSIC_LT:
1266 changed = optimize_comparison (e, op);
1267
1268 /* Fall through */
1269 /* Look at array constructors. */
1270 case INTRINSIC_PLUS:
1271 case INTRINSIC_MINUS:
1272 case INTRINSIC_TIMES:
1273 case INTRINSIC_DIVIDE:
1274 return combine_array_constructor (e) || changed;
1275
1276 case INTRINSIC_POWER:
1277 return optimize_power (e);
1278 break;
1279
1280 default:
1281 break;
1282 }
1283
1284 return false;
1285 }
1286
1287
1288 /* Return true if a constant string contains only blanks. */
1289
1290 static bool
1291 is_empty_string (gfc_expr *e)
1292 {
1293 int i;
1294
1295 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1296 return false;
1297
1298 for (i=0; i < e->value.character.length; i++)
1299 {
1300 if (e->value.character.string[i] != ' ')
1301 return false;
1302 }
1303
1304 return true;
1305 }
1306
1307
1308 /* Insert a call to the intrinsic len_trim. Use a different name for
1309 the symbol tree so we don't run into trouble when the user has
1310 renamed len_trim for some reason. */
1311
1312 static gfc_expr*
1313 get_len_trim_call (gfc_expr *str, int kind)
1314 {
1315 gfc_expr *fcn;
1316 gfc_actual_arglist *actual_arglist, *next;
1317
1318 fcn = gfc_get_expr ();
1319 fcn->expr_type = EXPR_FUNCTION;
1320 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1321 actual_arglist = gfc_get_actual_arglist ();
1322 actual_arglist->expr = str;
1323 next = gfc_get_actual_arglist ();
1324 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1325 actual_arglist->next = next;
1326
1327 fcn->value.function.actual = actual_arglist;
1328 fcn->where = str->where;
1329 fcn->ts.type = BT_INTEGER;
1330 fcn->ts.kind = gfc_charlen_int_kind;
1331
1332 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1333 fcn->symtree->n.sym->ts = fcn->ts;
1334 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1335 fcn->symtree->n.sym->attr.function = 1;
1336 fcn->symtree->n.sym->attr.elemental = 1;
1337 fcn->symtree->n.sym->attr.referenced = 1;
1338 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1339 gfc_commit_symbol (fcn->symtree->n.sym);
1340
1341 return fcn;
1342 }
1343
1344 /* Optimize expressions for equality. */
1345
1346 static bool
1347 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
1348 {
1349 gfc_expr *op1, *op2;
1350 bool change;
1351 int eq;
1352 bool result;
1353 gfc_actual_arglist *firstarg, *secondarg;
1354
1355 if (e->expr_type == EXPR_OP)
1356 {
1357 firstarg = NULL;
1358 secondarg = NULL;
1359 op1 = e->value.op.op1;
1360 op2 = e->value.op.op2;
1361 }
1362 else if (e->expr_type == EXPR_FUNCTION)
1363 {
1364 /* One of the lexical comparison functions. */
1365 firstarg = e->value.function.actual;
1366 secondarg = firstarg->next;
1367 op1 = firstarg->expr;
1368 op2 = secondarg->expr;
1369 }
1370 else
1371 gcc_unreachable ();
1372
1373 /* Strip off unneeded TRIM calls from string comparisons. */
1374
1375 change = remove_trim (op1);
1376
1377 if (remove_trim (op2))
1378 change = true;
1379
1380 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1381 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1382 handles them well). However, there are also cases that need a non-scalar
1383 argument. For example the any intrinsic. See PR 45380. */
1384 if (e->rank > 0)
1385 return change;
1386
1387 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1388 len_trim(a) != 0 */
1389 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1390 && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
1391 {
1392 bool empty_op1, empty_op2;
1393 empty_op1 = is_empty_string (op1);
1394 empty_op2 = is_empty_string (op2);
1395
1396 if (empty_op1 || empty_op2)
1397 {
1398 gfc_expr *fcn;
1399 gfc_expr *zero;
1400 gfc_expr *str;
1401
1402 /* This can only happen when an error for comparing
1403 characters of different kinds has already been issued. */
1404 if (empty_op1 && empty_op2)
1405 return false;
1406
1407 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
1408 str = empty_op1 ? op2 : op1;
1409
1410 fcn = get_len_trim_call (str, gfc_charlen_int_kind);
1411
1412
1413 if (empty_op1)
1414 gfc_free_expr (op1);
1415 else
1416 gfc_free_expr (op2);
1417
1418 op1 = fcn;
1419 op2 = zero;
1420 e->value.op.op1 = fcn;
1421 e->value.op.op2 = zero;
1422 }
1423 }
1424
1425
1426 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1427
1428 if (flag_finite_math_only
1429 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
1430 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
1431 {
1432 eq = gfc_dep_compare_expr (op1, op2);
1433 if (eq <= -2)
1434 {
1435 /* Replace A // B < A // C with B < C, and A // B < C // B
1436 with A < C. */
1437 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1438 && op1->expr_type == EXPR_OP
1439 && op1->value.op.op == INTRINSIC_CONCAT
1440 && op2->expr_type == EXPR_OP
1441 && op2->value.op.op == INTRINSIC_CONCAT)
1442 {
1443 gfc_expr *op1_left = op1->value.op.op1;
1444 gfc_expr *op2_left = op2->value.op.op1;
1445 gfc_expr *op1_right = op1->value.op.op2;
1446 gfc_expr *op2_right = op2->value.op.op2;
1447
1448 if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
1449 {
1450 /* Watch out for 'A ' // x vs. 'A' // x. */
1451
1452 if (op1_left->expr_type == EXPR_CONSTANT
1453 && op2_left->expr_type == EXPR_CONSTANT
1454 && op1_left->value.character.length
1455 != op2_left->value.character.length)
1456 return change;
1457 else
1458 {
1459 free (op1_left);
1460 free (op2_left);
1461 if (firstarg)
1462 {
1463 firstarg->expr = op1_right;
1464 secondarg->expr = op2_right;
1465 }
1466 else
1467 {
1468 e->value.op.op1 = op1_right;
1469 e->value.op.op2 = op2_right;
1470 }
1471 optimize_comparison (e, op);
1472 return true;
1473 }
1474 }
1475 if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
1476 {
1477 free (op1_right);
1478 free (op2_right);
1479 if (firstarg)
1480 {
1481 firstarg->expr = op1_left;
1482 secondarg->expr = op2_left;
1483 }
1484 else
1485 {
1486 e->value.op.op1 = op1_left;
1487 e->value.op.op2 = op2_left;
1488 }
1489
1490 optimize_comparison (e, op);
1491 return true;
1492 }
1493 }
1494 }
1495 else
1496 {
1497 /* eq can only be -1, 0 or 1 at this point. */
1498 switch (op)
1499 {
1500 case INTRINSIC_EQ:
1501 result = eq == 0;
1502 break;
1503
1504 case INTRINSIC_GE:
1505 result = eq >= 0;
1506 break;
1507
1508 case INTRINSIC_LE:
1509 result = eq <= 0;
1510 break;
1511
1512 case INTRINSIC_NE:
1513 result = eq != 0;
1514 break;
1515
1516 case INTRINSIC_GT:
1517 result = eq > 0;
1518 break;
1519
1520 case INTRINSIC_LT:
1521 result = eq < 0;
1522 break;
1523
1524 default:
1525 gfc_internal_error ("illegal OP in optimize_comparison");
1526 break;
1527 }
1528
1529 /* Replace the expression by a constant expression. The typespec
1530 and where remains the way it is. */
1531 free (op1);
1532 free (op2);
1533 e->expr_type = EXPR_CONSTANT;
1534 e->value.logical = result;
1535 return true;
1536 }
1537 }
1538
1539 return change;
1540 }
1541
1542 /* Optimize a trim function by replacing it with an equivalent substring
1543 involving a call to len_trim. This only works for expressions where
1544 variables are trimmed. Return true if anything was modified. */
1545
1546 static bool
1547 optimize_trim (gfc_expr *e)
1548 {
1549 gfc_expr *a;
1550 gfc_ref *ref;
1551 gfc_expr *fcn;
1552 gfc_ref **rr = NULL;
1553
1554 /* Don't do this optimization within an argument list, because
1555 otherwise aliasing issues may occur. */
1556
1557 if (count_arglist != 1)
1558 return false;
1559
1560 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
1561 || e->value.function.isym == NULL
1562 || e->value.function.isym->id != GFC_ISYM_TRIM)
1563 return false;
1564
1565 a = e->value.function.actual->expr;
1566
1567 if (a->expr_type != EXPR_VARIABLE)
1568 return false;
1569
1570 /* Follow all references to find the correct place to put the newly
1571 created reference. FIXME: Also handle substring references and
1572 array references. Array references cause strange regressions at
1573 the moment. */
1574
1575 if (a->ref)
1576 {
1577 for (rr = &(a->ref); *rr; rr = &((*rr)->next))
1578 {
1579 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
1580 return false;
1581 }
1582 }
1583
1584 strip_function_call (e);
1585
1586 if (e->ref == NULL)
1587 rr = &(e->ref);
1588
1589 /* Create the reference. */
1590
1591 ref = gfc_get_ref ();
1592 ref->type = REF_SUBSTRING;
1593
1594 /* Set the start of the reference. */
1595
1596 ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1597
1598 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1599
1600 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
1601
1602 /* Set the end of the reference to the call to len_trim. */
1603
1604 ref->u.ss.end = fcn;
1605 gcc_assert (rr != NULL && *rr == NULL);
1606 *rr = ref;
1607 return true;
1608 }
1609
1610 /* Optimize minloc(b), where b is rank 1 array, into
1611 (/ minloc(b, dim=1) /), and similarly for maxloc,
1612 as the latter forms are expanded inline. */
1613
1614 static void
1615 optimize_minmaxloc (gfc_expr **e)
1616 {
1617 gfc_expr *fn = *e;
1618 gfc_actual_arglist *a;
1619 char *name, *p;
1620
1621 if (fn->rank != 1
1622 || fn->value.function.actual == NULL
1623 || fn->value.function.actual->expr == NULL
1624 || fn->value.function.actual->expr->rank != 1)
1625 return;
1626
1627 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
1628 (*e)->shape = fn->shape;
1629 fn->rank = 0;
1630 fn->shape = NULL;
1631 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
1632
1633 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
1634 strcpy (name, fn->value.function.name);
1635 p = strstr (name, "loc0");
1636 p[3] = '1';
1637 fn->value.function.name = gfc_get_string (name);
1638 if (fn->value.function.actual->next)
1639 {
1640 a = fn->value.function.actual->next;
1641 gcc_assert (a->expr == NULL);
1642 }
1643 else
1644 {
1645 a = gfc_get_actual_arglist ();
1646 fn->value.function.actual->next = a;
1647 }
1648 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1649 &fn->where);
1650 mpz_set_ui (a->expr->value.integer, 1);
1651 }
1652
1653 /* Callback function for code checking that we do not pass a DO variable to an
1654 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1655
1656 static int
1657 doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1658 void *data ATTRIBUTE_UNUSED)
1659 {
1660 gfc_code *co;
1661 int i;
1662 gfc_formal_arglist *f;
1663 gfc_actual_arglist *a;
1664 gfc_code *cl;
1665
1666 co = *c;
1667
1668 /* If the doloop_list grew, we have to truncate it here. */
1669
1670 if ((unsigned) doloop_level < doloop_list.length())
1671 doloop_list.truncate (doloop_level);
1672
1673 switch (co->op)
1674 {
1675 case EXEC_DO:
1676
1677 if (co->ext.iterator && co->ext.iterator->var)
1678 doloop_list.safe_push (co);
1679 else
1680 doloop_list.safe_push ((gfc_code *) NULL);
1681 break;
1682
1683 case EXEC_CALL:
1684
1685 if (co->resolved_sym == NULL)
1686 break;
1687
1688 f = gfc_sym_get_dummy_args (co->resolved_sym);
1689
1690 /* Withot a formal arglist, there is only unknown INTENT,
1691 which we don't check for. */
1692 if (f == NULL)
1693 break;
1694
1695 a = co->ext.actual;
1696
1697 while (a && f)
1698 {
1699 FOR_EACH_VEC_ELT (doloop_list, i, cl)
1700 {
1701 gfc_symbol *do_sym;
1702
1703 if (cl == NULL)
1704 break;
1705
1706 do_sym = cl->ext.iterator->var->symtree->n.sym;
1707
1708 if (a->expr && a->expr->symtree
1709 && a->expr->symtree->n.sym == do_sym)
1710 {
1711 if (f->sym->attr.intent == INTENT_OUT)
1712 gfc_error_now_1 ("Variable '%s' at %L set to undefined "
1713 "value inside loop beginning at %L as "
1714 "INTENT(OUT) argument to subroutine '%s'",
1715 do_sym->name, &a->expr->where,
1716 &doloop_list[i]->loc,
1717 co->symtree->n.sym->name);
1718 else if (f->sym->attr.intent == INTENT_INOUT)
1719 gfc_error_now_1 ("Variable '%s' at %L not definable inside "
1720 "loop beginning at %L as INTENT(INOUT) "
1721 "argument to subroutine '%s'",
1722 do_sym->name, &a->expr->where,
1723 &doloop_list[i]->loc,
1724 co->symtree->n.sym->name);
1725 }
1726 }
1727 a = a->next;
1728 f = f->next;
1729 }
1730 break;
1731
1732 default:
1733 break;
1734 }
1735 return 0;
1736 }
1737
1738 /* Callback function for functions checking that we do not pass a DO variable
1739 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1740
1741 static int
1742 do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1743 void *data ATTRIBUTE_UNUSED)
1744 {
1745 gfc_formal_arglist *f;
1746 gfc_actual_arglist *a;
1747 gfc_expr *expr;
1748 gfc_code *dl;
1749 int i;
1750
1751 expr = *e;
1752 if (expr->expr_type != EXPR_FUNCTION)
1753 return 0;
1754
1755 /* Intrinsic functions don't modify their arguments. */
1756
1757 if (expr->value.function.isym)
1758 return 0;
1759
1760 f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
1761
1762 /* Without a formal arglist, there is only unknown INTENT,
1763 which we don't check for. */
1764 if (f == NULL)
1765 return 0;
1766
1767 a = expr->value.function.actual;
1768
1769 while (a && f)
1770 {
1771 FOR_EACH_VEC_ELT (doloop_list, i, dl)
1772 {
1773 gfc_symbol *do_sym;
1774
1775 if (dl == NULL)
1776 break;
1777
1778 do_sym = dl->ext.iterator->var->symtree->n.sym;
1779
1780 if (a->expr && a->expr->symtree
1781 && a->expr->symtree->n.sym == do_sym)
1782 {
1783 if (f->sym->attr.intent == INTENT_OUT)
1784 gfc_error_now_1 ("Variable '%s' at %L set to undefined value "
1785 "inside loop beginning at %L as INTENT(OUT) "
1786 "argument to function '%s'", do_sym->name,
1787 &a->expr->where, &doloop_list[i]->loc,
1788 expr->symtree->n.sym->name);
1789 else if (f->sym->attr.intent == INTENT_INOUT)
1790 gfc_error_now_1 ("Variable '%s' at %L not definable inside loop"
1791 " beginning at %L as INTENT(INOUT) argument to"
1792 " function '%s'", do_sym->name,
1793 &a->expr->where, &doloop_list[i]->loc,
1794 expr->symtree->n.sym->name);
1795 }
1796 }
1797 a = a->next;
1798 f = f->next;
1799 }
1800
1801 return 0;
1802 }
1803
1804 static void
1805 doloop_warn (gfc_namespace *ns)
1806 {
1807 gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
1808 }
1809
1810
1811 #define WALK_SUBEXPR(NODE) \
1812 do \
1813 { \
1814 result = gfc_expr_walker (&(NODE), exprfn, data); \
1815 if (result) \
1816 return result; \
1817 } \
1818 while (0)
1819 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1820
1821 /* Walk expression *E, calling EXPRFN on each expression in it. */
1822
1823 int
1824 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
1825 {
1826 while (*e)
1827 {
1828 int walk_subtrees = 1;
1829 gfc_actual_arglist *a;
1830 gfc_ref *r;
1831 gfc_constructor *c;
1832
1833 int result = exprfn (e, &walk_subtrees, data);
1834 if (result)
1835 return result;
1836 if (walk_subtrees)
1837 switch ((*e)->expr_type)
1838 {
1839 case EXPR_OP:
1840 WALK_SUBEXPR ((*e)->value.op.op1);
1841 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
1842 break;
1843 case EXPR_FUNCTION:
1844 for (a = (*e)->value.function.actual; a; a = a->next)
1845 WALK_SUBEXPR (a->expr);
1846 break;
1847 case EXPR_COMPCALL:
1848 case EXPR_PPC:
1849 WALK_SUBEXPR ((*e)->value.compcall.base_object);
1850 for (a = (*e)->value.compcall.actual; a; a = a->next)
1851 WALK_SUBEXPR (a->expr);
1852 break;
1853
1854 case EXPR_STRUCTURE:
1855 case EXPR_ARRAY:
1856 for (c = gfc_constructor_first ((*e)->value.constructor); c;
1857 c = gfc_constructor_next (c))
1858 {
1859 if (c->iterator == NULL)
1860 WALK_SUBEXPR (c->expr);
1861 else
1862 {
1863 iterator_level ++;
1864 WALK_SUBEXPR (c->expr);
1865 iterator_level --;
1866 WALK_SUBEXPR (c->iterator->var);
1867 WALK_SUBEXPR (c->iterator->start);
1868 WALK_SUBEXPR (c->iterator->end);
1869 WALK_SUBEXPR (c->iterator->step);
1870 }
1871 }
1872
1873 if ((*e)->expr_type != EXPR_ARRAY)
1874 break;
1875
1876 /* Fall through to the variable case in order to walk the
1877 reference. */
1878
1879 case EXPR_SUBSTRING:
1880 case EXPR_VARIABLE:
1881 for (r = (*e)->ref; r; r = r->next)
1882 {
1883 gfc_array_ref *ar;
1884 int i;
1885
1886 switch (r->type)
1887 {
1888 case REF_ARRAY:
1889 ar = &r->u.ar;
1890 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
1891 {
1892 for (i=0; i< ar->dimen; i++)
1893 {
1894 WALK_SUBEXPR (ar->start[i]);
1895 WALK_SUBEXPR (ar->end[i]);
1896 WALK_SUBEXPR (ar->stride[i]);
1897 }
1898 }
1899
1900 break;
1901
1902 case REF_SUBSTRING:
1903 WALK_SUBEXPR (r->u.ss.start);
1904 WALK_SUBEXPR (r->u.ss.end);
1905 break;
1906
1907 case REF_COMPONENT:
1908 break;
1909 }
1910 }
1911
1912 default:
1913 break;
1914 }
1915 return 0;
1916 }
1917 return 0;
1918 }
1919
1920 #define WALK_SUBCODE(NODE) \
1921 do \
1922 { \
1923 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1924 if (result) \
1925 return result; \
1926 } \
1927 while (0)
1928
1929 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1930 on each expression in it. If any of the hooks returns non-zero, that
1931 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
1932 no subcodes or subexpressions are traversed. */
1933
1934 int
1935 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
1936 void *data)
1937 {
1938 for (; *c; c = &(*c)->next)
1939 {
1940 int walk_subtrees = 1;
1941 int result = codefn (c, &walk_subtrees, data);
1942 if (result)
1943 return result;
1944
1945 if (walk_subtrees)
1946 {
1947 gfc_code *b;
1948 gfc_actual_arglist *a;
1949 gfc_code *co;
1950 gfc_association_list *alist;
1951 bool saved_in_omp_workshare;
1952
1953 /* There might be statement insertions before the current code,
1954 which must not affect the expression walker. */
1955
1956 co = *c;
1957 saved_in_omp_workshare = in_omp_workshare;
1958
1959 switch (co->op)
1960 {
1961
1962 case EXEC_BLOCK:
1963 WALK_SUBCODE (co->ext.block.ns->code);
1964 if (co->ext.block.assoc)
1965 {
1966 bool saved_in_assoc_list = in_assoc_list;
1967
1968 in_assoc_list = true;
1969 for (alist = co->ext.block.assoc; alist; alist = alist->next)
1970 WALK_SUBEXPR (alist->target);
1971
1972 in_assoc_list = saved_in_assoc_list;
1973 }
1974
1975 break;
1976
1977 case EXEC_DO:
1978 doloop_level ++;
1979 WALK_SUBEXPR (co->ext.iterator->var);
1980 WALK_SUBEXPR (co->ext.iterator->start);
1981 WALK_SUBEXPR (co->ext.iterator->end);
1982 WALK_SUBEXPR (co->ext.iterator->step);
1983 break;
1984
1985 case EXEC_CALL:
1986 case EXEC_ASSIGN_CALL:
1987 for (a = co->ext.actual; a; a = a->next)
1988 WALK_SUBEXPR (a->expr);
1989 break;
1990
1991 case EXEC_CALL_PPC:
1992 WALK_SUBEXPR (co->expr1);
1993 for (a = co->ext.actual; a; a = a->next)
1994 WALK_SUBEXPR (a->expr);
1995 break;
1996
1997 case EXEC_SELECT:
1998 WALK_SUBEXPR (co->expr1);
1999 for (b = co->block; b; b = b->block)
2000 {
2001 gfc_case *cp;
2002 for (cp = b->ext.block.case_list; cp; cp = cp->next)
2003 {
2004 WALK_SUBEXPR (cp->low);
2005 WALK_SUBEXPR (cp->high);
2006 }
2007 WALK_SUBCODE (b->next);
2008 }
2009 continue;
2010
2011 case EXEC_ALLOCATE:
2012 case EXEC_DEALLOCATE:
2013 {
2014 gfc_alloc *a;
2015 for (a = co->ext.alloc.list; a; a = a->next)
2016 WALK_SUBEXPR (a->expr);
2017 break;
2018 }
2019
2020 case EXEC_FORALL:
2021 case EXEC_DO_CONCURRENT:
2022 {
2023 gfc_forall_iterator *fa;
2024 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
2025 {
2026 WALK_SUBEXPR (fa->var);
2027 WALK_SUBEXPR (fa->start);
2028 WALK_SUBEXPR (fa->end);
2029 WALK_SUBEXPR (fa->stride);
2030 }
2031 if (co->op == EXEC_FORALL)
2032 forall_level ++;
2033 break;
2034 }
2035
2036 case EXEC_OPEN:
2037 WALK_SUBEXPR (co->ext.open->unit);
2038 WALK_SUBEXPR (co->ext.open->file);
2039 WALK_SUBEXPR (co->ext.open->status);
2040 WALK_SUBEXPR (co->ext.open->access);
2041 WALK_SUBEXPR (co->ext.open->form);
2042 WALK_SUBEXPR (co->ext.open->recl);
2043 WALK_SUBEXPR (co->ext.open->blank);
2044 WALK_SUBEXPR (co->ext.open->position);
2045 WALK_SUBEXPR (co->ext.open->action);
2046 WALK_SUBEXPR (co->ext.open->delim);
2047 WALK_SUBEXPR (co->ext.open->pad);
2048 WALK_SUBEXPR (co->ext.open->iostat);
2049 WALK_SUBEXPR (co->ext.open->iomsg);
2050 WALK_SUBEXPR (co->ext.open->convert);
2051 WALK_SUBEXPR (co->ext.open->decimal);
2052 WALK_SUBEXPR (co->ext.open->encoding);
2053 WALK_SUBEXPR (co->ext.open->round);
2054 WALK_SUBEXPR (co->ext.open->sign);
2055 WALK_SUBEXPR (co->ext.open->asynchronous);
2056 WALK_SUBEXPR (co->ext.open->id);
2057 WALK_SUBEXPR (co->ext.open->newunit);
2058 break;
2059
2060 case EXEC_CLOSE:
2061 WALK_SUBEXPR (co->ext.close->unit);
2062 WALK_SUBEXPR (co->ext.close->status);
2063 WALK_SUBEXPR (co->ext.close->iostat);
2064 WALK_SUBEXPR (co->ext.close->iomsg);
2065 break;
2066
2067 case EXEC_BACKSPACE:
2068 case EXEC_ENDFILE:
2069 case EXEC_REWIND:
2070 case EXEC_FLUSH:
2071 WALK_SUBEXPR (co->ext.filepos->unit);
2072 WALK_SUBEXPR (co->ext.filepos->iostat);
2073 WALK_SUBEXPR (co->ext.filepos->iomsg);
2074 break;
2075
2076 case EXEC_INQUIRE:
2077 WALK_SUBEXPR (co->ext.inquire->unit);
2078 WALK_SUBEXPR (co->ext.inquire->file);
2079 WALK_SUBEXPR (co->ext.inquire->iomsg);
2080 WALK_SUBEXPR (co->ext.inquire->iostat);
2081 WALK_SUBEXPR (co->ext.inquire->exist);
2082 WALK_SUBEXPR (co->ext.inquire->opened);
2083 WALK_SUBEXPR (co->ext.inquire->number);
2084 WALK_SUBEXPR (co->ext.inquire->named);
2085 WALK_SUBEXPR (co->ext.inquire->name);
2086 WALK_SUBEXPR (co->ext.inquire->access);
2087 WALK_SUBEXPR (co->ext.inquire->sequential);
2088 WALK_SUBEXPR (co->ext.inquire->direct);
2089 WALK_SUBEXPR (co->ext.inquire->form);
2090 WALK_SUBEXPR (co->ext.inquire->formatted);
2091 WALK_SUBEXPR (co->ext.inquire->unformatted);
2092 WALK_SUBEXPR (co->ext.inquire->recl);
2093 WALK_SUBEXPR (co->ext.inquire->nextrec);
2094 WALK_SUBEXPR (co->ext.inquire->blank);
2095 WALK_SUBEXPR (co->ext.inquire->position);
2096 WALK_SUBEXPR (co->ext.inquire->action);
2097 WALK_SUBEXPR (co->ext.inquire->read);
2098 WALK_SUBEXPR (co->ext.inquire->write);
2099 WALK_SUBEXPR (co->ext.inquire->readwrite);
2100 WALK_SUBEXPR (co->ext.inquire->delim);
2101 WALK_SUBEXPR (co->ext.inquire->encoding);
2102 WALK_SUBEXPR (co->ext.inquire->pad);
2103 WALK_SUBEXPR (co->ext.inquire->iolength);
2104 WALK_SUBEXPR (co->ext.inquire->convert);
2105 WALK_SUBEXPR (co->ext.inquire->strm_pos);
2106 WALK_SUBEXPR (co->ext.inquire->asynchronous);
2107 WALK_SUBEXPR (co->ext.inquire->decimal);
2108 WALK_SUBEXPR (co->ext.inquire->pending);
2109 WALK_SUBEXPR (co->ext.inquire->id);
2110 WALK_SUBEXPR (co->ext.inquire->sign);
2111 WALK_SUBEXPR (co->ext.inquire->size);
2112 WALK_SUBEXPR (co->ext.inquire->round);
2113 break;
2114
2115 case EXEC_WAIT:
2116 WALK_SUBEXPR (co->ext.wait->unit);
2117 WALK_SUBEXPR (co->ext.wait->iostat);
2118 WALK_SUBEXPR (co->ext.wait->iomsg);
2119 WALK_SUBEXPR (co->ext.wait->id);
2120 break;
2121
2122 case EXEC_READ:
2123 case EXEC_WRITE:
2124 WALK_SUBEXPR (co->ext.dt->io_unit);
2125 WALK_SUBEXPR (co->ext.dt->format_expr);
2126 WALK_SUBEXPR (co->ext.dt->rec);
2127 WALK_SUBEXPR (co->ext.dt->advance);
2128 WALK_SUBEXPR (co->ext.dt->iostat);
2129 WALK_SUBEXPR (co->ext.dt->size);
2130 WALK_SUBEXPR (co->ext.dt->iomsg);
2131 WALK_SUBEXPR (co->ext.dt->id);
2132 WALK_SUBEXPR (co->ext.dt->pos);
2133 WALK_SUBEXPR (co->ext.dt->asynchronous);
2134 WALK_SUBEXPR (co->ext.dt->blank);
2135 WALK_SUBEXPR (co->ext.dt->decimal);
2136 WALK_SUBEXPR (co->ext.dt->delim);
2137 WALK_SUBEXPR (co->ext.dt->pad);
2138 WALK_SUBEXPR (co->ext.dt->round);
2139 WALK_SUBEXPR (co->ext.dt->sign);
2140 WALK_SUBEXPR (co->ext.dt->extra_comma);
2141 break;
2142
2143 case EXEC_OMP_PARALLEL:
2144 case EXEC_OMP_PARALLEL_DO:
2145 case EXEC_OMP_PARALLEL_DO_SIMD:
2146 case EXEC_OMP_PARALLEL_SECTIONS:
2147
2148 in_omp_workshare = false;
2149
2150 /* This goto serves as a shortcut to avoid code
2151 duplication or a larger if or switch statement. */
2152 goto check_omp_clauses;
2153
2154 case EXEC_OMP_WORKSHARE:
2155 case EXEC_OMP_PARALLEL_WORKSHARE:
2156
2157 in_omp_workshare = true;
2158
2159 /* Fall through */
2160
2161 case EXEC_OMP_DISTRIBUTE:
2162 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2163 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2164 case EXEC_OMP_DISTRIBUTE_SIMD:
2165 case EXEC_OMP_DO:
2166 case EXEC_OMP_DO_SIMD:
2167 case EXEC_OMP_SECTIONS:
2168 case EXEC_OMP_SINGLE:
2169 case EXEC_OMP_END_SINGLE:
2170 case EXEC_OMP_SIMD:
2171 case EXEC_OMP_TARGET:
2172 case EXEC_OMP_TARGET_DATA:
2173 case EXEC_OMP_TARGET_TEAMS:
2174 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2175 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2176 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2177 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2178 case EXEC_OMP_TARGET_UPDATE:
2179 case EXEC_OMP_TASK:
2180 case EXEC_OMP_TEAMS:
2181 case EXEC_OMP_TEAMS_DISTRIBUTE:
2182 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2183 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2184 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2185
2186 /* Come to this label only from the
2187 EXEC_OMP_PARALLEL_* cases above. */
2188
2189 check_omp_clauses:
2190
2191 if (co->ext.omp_clauses)
2192 {
2193 gfc_omp_namelist *n;
2194 static int list_types[]
2195 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
2196 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
2197 size_t idx;
2198 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
2199 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
2200 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
2201 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
2202 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
2203 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
2204 WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
2205 WALK_SUBEXPR (co->ext.omp_clauses->device);
2206 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
2207 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
2208 for (idx = 0;
2209 idx < sizeof (list_types) / sizeof (list_types[0]);
2210 idx++)
2211 for (n = co->ext.omp_clauses->lists[list_types[idx]];
2212 n; n = n->next)
2213 WALK_SUBEXPR (n->expr);
2214 }
2215 break;
2216 default:
2217 break;
2218 }
2219
2220 WALK_SUBEXPR (co->expr1);
2221 WALK_SUBEXPR (co->expr2);
2222 WALK_SUBEXPR (co->expr3);
2223 WALK_SUBEXPR (co->expr4);
2224 for (b = co->block; b; b = b->block)
2225 {
2226 WALK_SUBEXPR (b->expr1);
2227 WALK_SUBEXPR (b->expr2);
2228 WALK_SUBCODE (b->next);
2229 }
2230
2231 if (co->op == EXEC_FORALL)
2232 forall_level --;
2233
2234 if (co->op == EXEC_DO)
2235 doloop_level --;
2236
2237 in_omp_workshare = saved_in_omp_workshare;
2238 }
2239 }
2240 return 0;
2241 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org