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