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