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