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