]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/frontend-passes.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Implement -Wimplicit-fallthrough.
[gcc.git] / gcc / fortran / frontend-passes.c
CommitLineData
601d98be 1/* Pass manager for Fortran front end.
818ab71a 2 Copyright (C) 2010-2016 Free Software Foundation, Inc.
601d98be
TK		 3 Contributed by Thomas König.
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
20
21#include "config.h"
22#include "system.h"
953bee7c 23#include "coretypes.h"
2adfab87 24#include "options.h"
601d98be 25#include "gfortran.h"
071bdb5f 26#include "dependency.h"
46f19baf 27#include "constructor.h"
f1abbf69 28#include "intrinsic.h"
601d98be
TK		 29
30/* Forward declarations. */
31
32static void strip_function_call (gfc_expr *);
2bfec368 33static void optimize_namespace (gfc_namespace *);
601d98be 34static void optimize_assignment (gfc_code *);
601d98be 35static bool optimize_op (gfc_expr *);
32af57e2 36static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
4afeb65c 37static bool optimize_trim (gfc_expr *);
9046a4dc 38static bool optimize_lexical_comparison (gfc_expr *);
d2663912 39static void optimize_minmaxloc (gfc_expr **);
9771b263 40static bool is_empty_string (gfc_expr *e);
305a35da 41static void doloop_warn (gfc_namespace *);
e81e4b43
TK		 42static void optimize_reduction (gfc_namespace *);
43static int callback_reduction (gfc_expr **, int *, void *);
8b7cec58 44static void realloc_strings (gfc_namespace *);
f1abbf69
TK		 45static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
46static int inline_matmul_assign (gfc_code **, int *, void *);
47static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
7474dcc1 48 locus *, gfc_namespace *,
f1abbf69 49 char *vname=NULL);
4afeb65c
TK		 50
51/* How deep we are inside an argument list. */
52
53static int count_arglist;
601d98be 54
6c7069d6 55/* Vector of gfc_expr ** we operate on. */
2757d5ec 56
6c7069d6 57static vec<gfc_expr **> expr_array;
2757d5ec
TK		 58
59/* Pointer to the gfc_code we currently work on - to be able to insert
5a87ca71 60 a block before the statement. */
2757d5ec
TK		 61
62static gfc_code **current_code;
63
5a87ca71
TK		 64/* Pointer to the block to be inserted, and the statement we are
65 changing within the block. */
66
67static gfc_code *inserted_block, **changed_statement;
68
2757d5ec
TK		 69/* The namespace we are currently dealing with. */
70
930d4d4e 71static gfc_namespace *current_ns;
2757d5ec 72
2855325f
TK		 73/* If we are within any forall loop. */
74
75static int forall_level;
76
e07e39f6
TK		 77/* Keep track of whether we are within an OMP workshare. */
78
79static bool in_omp_workshare;
80
fd42eed8
TK		 81/* Keep track of whether we are within a WHERE statement. */
82
83static bool in_where;
84
8144d290
TK		 85/* Keep track of iterators for array constructors. */
86
87static int iterator_level;
88
305a35da
TK		 89/* Keep track of DO loop levels. */
90
6c7069d6
TK		 91static vec<gfc_code *> doloop_list;
92
93static int doloop_level;
305a35da
TK		 94
95/* Vector of gfc_expr * to keep track of DO loops. */
96
97struct my_struct *evec;
98
e3f9e757
TK		 99/* Keep track of association lists. */
100
101static bool in_assoc_list;
102
f1abbf69
TK		 103/* Counter for temporary variables. */
104
105static int var_num = 1;
106
107/* What sort of matrix we are dealing with when inlining MATMUL. */
108
094773e8 109enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T };
f1abbf69 110
7474dcc1 111/* Keep track of the number of expressions we have inserted so far
f1abbf69
TK		 112 using create_var. */
113
114int n_vars;
115
1cc0e193 116/* Entry point - run all passes for a namespace. */
601d98be
TK		 117
118void
2bfec368 119gfc_run_passes (gfc_namespace *ns)
601d98be 120{
305a35da
TK		 121
122 /* Warn about dubious DO loops where the index might
123 change. */
124
305a35da 125 doloop_level = 0;
305a35da 126 doloop_warn (ns);
6c7069d6 127 doloop_list.release ();
a23404c9 128 int w, e;
305a35da 129
203c7ebf 130 if (flag_frontend_optimize)
1607a827
TK		 131 {
132 optimize_namespace (ns);
e81e4b43 133 optimize_reduction (ns);
c61819ff 134 if (flag_dump_fortran_optimized)
1607a827 135 gfc_dump_parse_tree (ns, stdout);
2757d5ec 136
6c7069d6 137 expr_array.release ();
1607a827 138 }
8b7cec58 139
a23404c9
PT		 140 gfc_get_errors (&w, &e);
141 if (e > 0)
142 return;
143
8b7cec58
TK		 144 if (flag_realloc_lhs)
145 realloc_strings (ns);
146}
147
148/* Callback for each gfc_code node invoked from check_realloc_strings.
149 For an allocatable LHS string which also appears as a variable on
7474dcc1 150 the RHS, replace
8b7cec58
TK		 151
152 a = a(x:y)
153
154 with
155
156 tmp = a(x:y)
157 a = tmp
158 */
159
160static int
7b201a88 161realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
8b7cec58
TK		 162 void *data ATTRIBUTE_UNUSED)
163{
164 gfc_expr *expr1, *expr2;
165 gfc_code *co = *c;
166 gfc_expr *n;
d6598cf7
TK		 167 gfc_ref *ref;
168 bool found_substr;
8b7cec58 169
8b7cec58
TK		 170 if (co->op != EXEC_ASSIGN)
171 return 0;
172
173 expr1 = co->expr1;
174 if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0
d6598cf7
TK		 175 || !gfc_expr_attr(expr1).allocatable
176 || !expr1->ts.deferred)
8b7cec58
TK		 177 return 0;
178
179 expr2 = gfc_discard_nops (co->expr2);
180 if (expr2->expr_type != EXPR_VARIABLE)
181 return 0;
182
d6598cf7
TK		 183 found_substr = false;
184 for (ref = expr2->ref; ref; ref = ref->next)
185 {
186 if (ref->type == REF_SUBSTRING)
187 {
188 found_substr = true;
189 break;
190 }
191 }
192 if (!found_substr)
193 return 0;
194
8b7cec58
TK		 195 if (!gfc_check_dependency (expr1, expr2, true))
196 return 0;
4f028369 197
7474dcc1
PT		 198 /* gfc_check_dependency doesn't always pick up identical expressions.
199 However, eliminating the above sends the compiler into an infinite
200 loop on valid expressions. Without this check, the gimplifier emits
201 an ICE for a = a, where a is deferred character length. */
202 if (!gfc_dep_compare_expr (expr1, expr2))
203 return 0;
204
8b7cec58 205 current_code = c;
4f028369
JJ		 206 inserted_block = NULL;
207 changed_statement = NULL;
d6598cf7 208 n = create_var (expr2, "realloc_string");
8b7cec58
TK		 209 co->expr2 = n;
210 return 0;
2bfec368
TK		 211}
212
4d42b5cd
JJ		 213/* Callback for each gfc_code node invoked through gfc_code_walker
214 from optimize_namespace. */
2bfec368 215
4d42b5cd
JJ		 216static int
217optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
218 void *data ATTRIBUTE_UNUSED)
2bfec368 219{
4afeb65c
TK		 220
221 gfc_exec_op op;
222
223 op = (*c)->op;
224
225 if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
226 || op == EXEC_CALL_PPC)
227 count_arglist = 1;
228 else
229 count_arglist = 0;
230
4099436d
TK		 231 current_code = c;
232 inserted_block = NULL;
233 changed_statement = NULL;
234
4afeb65c 235 if (op == EXEC_ASSIGN)
4d42b5cd
JJ		 236 optimize_assignment (*c);
237 return 0;
601d98be
TK		 238}
239
4d42b5cd
JJ		 240/* Callback for each gfc_expr node invoked through gfc_code_walker
241 from optimize_namespace. */
242
243static int
244optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
245 void *data ATTRIBUTE_UNUSED)
601d98be 246{
4afeb65c
TK		 247 bool function_expr;
248
249 if ((*e)->expr_type == EXPR_FUNCTION)
250 {
251 count_arglist ++;
252 function_expr = true;
253 }
254 else
255 function_expr = false;
256
257 if (optimize_trim (*e))
258 gfc_simplify_expr (*e, 0);
259
9046a4dc
TK		 260 if (optimize_lexical_comparison (*e))
261 gfc_simplify_expr (*e, 0);
262
4d42b5cd
JJ		 263 if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
264 gfc_simplify_expr (*e, 0);
4afeb65c 265
d2663912
JJ		 266 if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
267 switch ((*e)->value.function.isym->id)
268 {
269 case GFC_ISYM_MINLOC:
270 case GFC_ISYM_MAXLOC:
271 optimize_minmaxloc (e);
272 break;
273 default:
274 break;
275 }
276
4afeb65c
TK		 277 if (function_expr)
278 count_arglist --;
279
4d42b5cd 280 return 0;
601d98be
TK		 281}
282
e81e4b43
TK		 283/* Auxiliary function to handle the arguments to reduction intrnisics. If the
284 function is a scalar, just copy it; otherwise returns the new element, the
285 old one can be freed. */
286
287static gfc_expr *
b91a551f 288copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
e81e4b43 289{
b91a551f 290 gfc_expr *fcn, *e = c->expr;
e81e4b43 291
b91a551f
TK		 292 fcn = gfc_copy_expr (e);
293 if (c->iterator)
294 {
295 gfc_constructor_base newbase;
296 gfc_expr *new_expr;
297 gfc_constructor *new_c;
298
299 newbase = NULL;
300 new_expr = gfc_get_expr ();
301 new_expr->expr_type = EXPR_ARRAY;
302 new_expr->ts = e->ts;
303 new_expr->where = e->where;
304 new_expr->rank = 1;
305 new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
306 new_c->iterator = c->iterator;
307 new_expr->value.constructor = newbase;
308 c->iterator = NULL;
309
310 fcn = new_expr;
311 }
312
313 if (fcn->rank != 0)
e81e4b43 314 {
b91a551f 315 gfc_isym_id id = fn->value.function.isym->id;
e81e4b43
TK		 316
317 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
b91a551f 318 fcn = gfc_build_intrinsic_call (current_ns, id,
e81e4b43 319 fn->value.function.isym->name,
b91a551f 320 fn->where, 3, fcn, NULL, NULL);
e81e4b43 321 else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
b91a551f 322 fcn = gfc_build_intrinsic_call (current_ns, id,
e81e4b43 323 fn->value.function.isym->name,
b91a551f 324 fn->where, 2, fcn, NULL);
e81e4b43
TK		 325 else
326 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
327
328 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
329 }
330
e81e4b43
TK		 331 return fcn;
332}
333
334/* Callback function for optimzation of reductions to scalars. Transform ANY
335 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
336 correspondingly. Handly only the simple cases without MASK and DIM. */
337
338static int
339callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
340 void *data ATTRIBUTE_UNUSED)
341{
342 gfc_expr *fn, *arg;
343 gfc_intrinsic_op op;
344 gfc_isym_id id;
345 gfc_actual_arglist *a;
346 gfc_actual_arglist *dim;
347 gfc_constructor *c;
348 gfc_expr *res, *new_expr;
349 gfc_actual_arglist *mask;
350
351 fn = *e;
352
353 if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
354 || fn->value.function.isym == NULL)
355 return 0;
356
357 id = fn->value.function.isym->id;
358
359 if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
360 && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
361 return 0;
362
363 a = fn->value.function.actual;
364
365 /* Don't handle MASK or DIM. */
366
367 dim = a->next;
368
369 if (dim->expr != NULL)
370 return 0;
371
372 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
373 {
374 mask = dim->next;
375 if ( mask->expr != NULL)
376 return 0;
377 }
378
379 arg = a->expr;
380
381 if (arg->expr_type != EXPR_ARRAY)
382 return 0;
383
384 switch (id)
385 {
386 case GFC_ISYM_SUM:
387 op = INTRINSIC_PLUS;
388 break;
389
390 case GFC_ISYM_PRODUCT:
391 op = INTRINSIC_TIMES;
392 break;
393
394 case GFC_ISYM_ANY:
395 op = INTRINSIC_OR;
396 break;
397
398 case GFC_ISYM_ALL:
399 op = INTRINSIC_AND;
400 break;
401
402 default:
403 return 0;
404 }
405
406 c = gfc_constructor_first (arg->value.constructor);
407
a2d0800a
TK		 408 /* Don't do any simplififcation if we have
409 - no element in the constructor or
410 - only have a single element in the array which contains an
411 iterator. */
412
b91a551f 413 if (c == NULL)
e81e4b43
TK		 414 return 0;
415
b91a551f 416 res = copy_walk_reduction_arg (c, fn);
e81e4b43
TK		 417
418 c = gfc_constructor_next (c);
419 while (c)
420 {
421 new_expr = gfc_get_expr ();
422 new_expr->ts = fn->ts;
423 new_expr->expr_type = EXPR_OP;
424 new_expr->rank = fn->rank;
425 new_expr->where = fn->where;
426 new_expr->value.op.op = op;
427 new_expr->value.op.op1 = res;
b91a551f 428 new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
e81e4b43
TK		 429 res = new_expr;
430 c = gfc_constructor_next (c);
431 }
432
433 gfc_simplify_expr (res, 0);
434 *e = res;
435 gfc_free_expr (fn);
436
437 return 0;
438}
2757d5ec
TK		 439
440/* Callback function for common function elimination, called from cfe_expr_0.
42a2717c 441 Put all eligible function expressions into expr_array. */
2757d5ec
TK		 442
443static int
444cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
445 void *data ATTRIBUTE_UNUSED)
446{
6e98bce4 447
2757d5ec
TK		 448 if ((*e)->expr_type != EXPR_FUNCTION)
449 return 0;
450
42a2717c 451 /* We don't do character functions with unknown charlens. */
7474dcc1 452 if ((*e)->ts.type == BT_CHARACTER
42a2717c
TK		 453 && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
454 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
2757d5ec
TK		 455 return 0;
456
2855325f
TK		 457 /* We don't do function elimination within FORALL statements, it can
458 lead to wrong-code in certain circumstances. */
459
460 if (forall_level > 0)
461 return 0;
462
8144d290
TK		 463 /* Function elimination inside an iterator could lead to functions which
464 depend on iterator variables being moved outside. FIXME: We should check
465 if the functions do indeed depend on the iterator variable. */
466
467 if (iterator_level > 0)
468 return 0;
469
222c2a63
TK		 470 /* If we don't know the shape at compile time, we create an allocatable
471 temporary variable to hold the intermediate result, but only if
472 allocation on assignment is active. */
2757d5ec 473
203c7ebf 474 if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
2757d5ec 475 return 0;
7474dcc1 476
2757d5ec
TK		 477 /* Skip the test for pure functions if -faggressive-function-elimination
478 is specified. */
479 if ((*e)->value.function.esym)
480 {
2757d5ec
TK		 481 /* Don't create an array temporary for elemental functions. */
482 if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
483 return 0;
484
485 /* Only eliminate potentially impure functions if the
486 user specifically requested it. */
c61819ff 487 if (!flag_aggressive_function_elimination
2757d5ec
TK		 488 && !(*e)->value.function.esym->attr.pure
489 && !(*e)->value.function.esym->attr.implicit_pure)
490 return 0;
491 }
492
493 if ((*e)->value.function.isym)
494 {
495 /* Conversions are handled on the fly by the middle end,
42a2717c 496 transpose during trans-* stages and TRANSFER by the middle end. */
2757d5ec 497 if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
93ee6382
MM		 498 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
499 || gfc_inline_intrinsic_function_p (*e))
2757d5ec
TK		 500 return 0;
501
502 /* Don't create an array temporary for elemental functions,
503 as this would be wasteful of memory.
504 FIXME: Create a scalar temporary during scalarization. */
505 if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
506 return 0;
507
508 if (!(*e)->value.function.isym->pure)
509 return 0;
510 }
511
6c7069d6 512 expr_array.safe_push (e);
2757d5ec
TK		 513 return 0;
514}
515
ba8aa6fc
TK		 516/* Auxiliary function to check if an expression is a temporary created by
517 create var. */
518
519static bool
520is_fe_temp (gfc_expr *e)
521{
522 if (e->expr_type != EXPR_VARIABLE)
523 return false;
524
525 return e->symtree->n.sym->attr.fe_temp;
526}
527
8b7cec58
TK		 528/* Determine the length of a string, if it can be evaluated as a constant
529 expression. Return a newly allocated gfc_expr or NULL on failure.
530 If the user specified a substring which is potentially longer than
531 the string itself, the string will be padded with spaces, which
532 is harmless. */
533
534static gfc_expr *
535constant_string_length (gfc_expr *e)
536{
537
538 gfc_expr *length;
539 gfc_ref *ref;
540 gfc_expr *res;
541 mpz_t value;
542
543 if (e->ts.u.cl)
544 {
545 length = e->ts.u.cl->length;
546 if (length && length->expr_type == EXPR_CONSTANT)
547 return gfc_copy_expr(length);
548 }
549
550 /* Return length of substring, if constant. */
551 for (ref = e->ref; ref; ref = ref->next)
552 {
553 if (ref->type == REF_SUBSTRING
554 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
555 {
556 res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
557 &e->where);
7474dcc1 558
8b7cec58
TK		 559 mpz_add_ui (res->value.integer, value, 1);
560 mpz_clear (value);
561 return res;
562 }
563 }
564
565 /* Return length of char symbol, if constant. */
566
567 if (e->symtree->n.sym->ts.u.cl && e->symtree->n.sym->ts.u.cl->length
568 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
569 return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
570
571 return NULL;
572
573}
ba8aa6fc 574
f1abbf69
TK		 575/* Insert a block at the current position unless it has already
576 been inserted; in this case use the one already there. */
2757d5ec 577
f1abbf69
TK		 578static gfc_namespace*
579insert_block ()
2757d5ec 580{
5a87ca71 581 gfc_namespace *ns;
ba8aa6fc 582
5a87ca71
TK		 583 /* If the block hasn't already been created, do so. */
584 if (inserted_block == NULL)
585 {
586 inserted_block = XCNEW (gfc_code);
587 inserted_block->op = EXEC_BLOCK;
588 inserted_block->loc = (*current_code)->loc;
589 ns = gfc_build_block_ns (current_ns);
590 inserted_block->ext.block.ns = ns;
591 inserted_block->ext.block.assoc = NULL;
592
593 ns->code = *current_code;
3d3b8193
TK		 594
595 /* If the statement has a label, make sure it is transferred to
596 the newly created block. */
597
7474dcc1 598 if ((*current_code)->here)
3d3b8193
TK		 599 {
600 inserted_block->here = (*current_code)->here;
601 (*current_code)->here = NULL;
602 }
603
5a87ca71
TK		 604 inserted_block->next = (*current_code)->next;
605 changed_statement = &(inserted_block->ext.block.ns->code);
606 (*current_code)->next = NULL;
607 /* Insert the BLOCK at the right position. */
608 *current_code = inserted_block;
930d4d4e 609 ns->parent = current_ns;
5a87ca71
TK		 610 }
611 else
612 ns = inserted_block->ext.block.ns;
613
f1abbf69
TK		 614 return ns;
615}
616
617/* Returns a new expression (a variable) to be used in place of the old one,
618 with an optional assignment statement before the current statement to set
619 the value of the variable. Creates a new BLOCK for the statement if that
620 hasn't already been done and puts the statement, plus the newly created
621 variables, in that block. Special cases: If the expression is constant or
622 a temporary which has already been created, just copy it. */
623
624static gfc_expr*
625create_var (gfc_expr * e, const char *vname)
626{
627 char name[GFC_MAX_SYMBOL_LEN +1];
628 gfc_symtree *symtree;
629 gfc_symbol *symbol;
630 gfc_expr *result;
631 gfc_code *n;
632 gfc_namespace *ns;
633 int i;
874be74a 634 bool deferred;
f1abbf69
TK		 635
636 if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
637 return gfc_copy_expr (e);
638
639 ns = insert_block ();
640
641 if (vname)
642 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
643 else
644 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
645
5a87ca71 646 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
2757d5ec
TK		 647 gcc_unreachable ();
648
649 symbol = symtree->n.sym;
650 symbol->ts = e->ts;
222c2a63
TK		 651
652 if (e->rank > 0)
2757d5ec 653 {
222c2a63
TK		 654 symbol->as = gfc_get_array_spec ();
655 symbol->as->rank = e->rank;
656
657 if (e->shape == NULL)
658 {
659 /* We don't know the shape at compile time, so we use an
1cc0e193 660 allocatable. */
222c2a63
TK		 661 symbol->as->type = AS_DEFERRED;
662 symbol->attr.allocatable = 1;
663 }
664 else
665 {
666 symbol->as->type = AS_EXPLICIT;
667 /* Copy the shape. */
668 for (i=0; i<e->rank; i++)
669 {
670 gfc_expr *p, *q;
7474dcc1 671
222c2a63
TK		 672 p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
673 &(e->where));
674 mpz_set_si (p->value.integer, 1);
675 symbol->as->lower[i] = p;
7474dcc1 676
222c2a63
TK		 677 q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
678 &(e->where));
679 mpz_set (q->value.integer, e->shape[i]);
680 symbol->as->upper[i] = q;
681 }
682 }
2757d5ec
TK		 683 }
684
874be74a 685 deferred = 0;
8b7cec58
TK		 686 if (e->ts.type == BT_CHARACTER && e->rank == 0)
687 {
688 gfc_expr *length;
689
36b54ce0 690 symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
8b7cec58
TK		 691 length = constant_string_length (e);
692 if (length)
36b54ce0 693 symbol->ts.u.cl->length = length;
8b7cec58 694 else
874be74a
TK		 695 {
696 symbol->attr.allocatable = 1;
697 deferred = 1;
698 }
8b7cec58
TK		 699 }
700
2757d5ec
TK		 701 symbol->attr.flavor = FL_VARIABLE;
702 symbol->attr.referenced = 1;
703 symbol->attr.dimension = e->rank > 0;
ba8aa6fc 704 symbol->attr.fe_temp = 1;
2757d5ec
TK		 705 gfc_commit_symbol (symbol);
706
707 result = gfc_get_expr ();
708 result->expr_type = EXPR_VARIABLE;
709 result->ts = e->ts;
874be74a 710 result->ts.deferred = deferred;
2757d5ec
TK		 711 result->rank = e->rank;
712 result->shape = gfc_copy_shape (e->shape, e->rank);
713 result->symtree = symtree;
714 result->where = e->where;
715 if (e->rank > 0)
716 {
717 result->ref = gfc_get_ref ();
718 result->ref->type = REF_ARRAY;
719 result->ref->u.ar.type = AR_FULL;
720 result->ref->u.ar.where = e->where;
f1abbf69 721 result->ref->u.ar.dimen = e->rank;
102344e2
TB		 722 result->ref->u.ar.as = symbol->ts.type == BT_CLASS
723 ? CLASS_DATA (symbol)->as : symbol->as;
73e42eef 724 if (warn_array_temporaries)
48749dbc
MLI		 725 gfc_warning (OPT_Warray_temporaries,
726 "Creating array temporary at %L", &(e->where));
2757d5ec
TK		 727 }
728
729 /* Generate the new assignment. */
730 n = XCNEW (gfc_code);
731 n->op = EXEC_ASSIGN;
732 n->loc = (*current_code)->loc;
5a87ca71 733 n->next = *changed_statement;
2757d5ec
TK		 734 n->expr1 = gfc_copy_expr (result);
735 n->expr2 = e;
5a87ca71 736 *changed_statement = n;
f1abbf69 737 n_vars ++;
2757d5ec
TK		 738
739 return result;
740}
741
51a30b32
TK		 742/* Warn about function elimination. */
743
744static void
73e42eef 745do_warn_function_elimination (gfc_expr *e)
51a30b32
TK		 746{
747 if (e->expr_type != EXPR_FUNCTION)
748 return;
749 if (e->value.function.esym)
db30e21c 750 gfc_warning (0, "Removing call to function %qs at %L",
51a30b32
TK		 751 e->value.function.esym->name, &(e->where));
752 else if (e->value.function.isym)
db30e21c 753 gfc_warning (0, "Removing call to function %qs at %L",
51a30b32
TK		 754 e->value.function.isym->name, &(e->where));
755}
2757d5ec
TK		 756/* Callback function for the code walker for doing common function
757 elimination. This builds up the list of functions in the expression
758 and goes through them to detect duplicates, which it then replaces
759 by variables. */
760
761static int
762cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
763 void *data ATTRIBUTE_UNUSED)
764{
765 int i,j;
766 gfc_expr *newvar;
6c7069d6 767 gfc_expr **ei, **ej;
2757d5ec 768
49a1164a 769 /* Don't do this optimization within OMP workshare or ASSOC lists. */
e07e39f6 770
49a1164a 771 if (in_omp_workshare || in_assoc_list)
e07e39f6
TK		 772 {
773 *walk_subtrees = 0;
774 return 0;
775 }
776
6c7069d6 777 expr_array.release ();
2757d5ec
TK		 778
779 gfc_expr_walker (e, cfe_register_funcs, NULL);
780
128e09f9
TK		 781 /* Walk through all the functions. */
782
6c7069d6 783 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
2757d5ec
TK		 784 {
785 /* Skip if the function has been replaced by a variable already. */
6c7069d6 786 if ((*ei)->expr_type == EXPR_VARIABLE)
2757d5ec
TK		 787 continue;
788
789 newvar = NULL;
128e09f9 790 for (j=0; j<i; j++)
2757d5ec 791 {
6c7069d6
TK		 792 ej = expr_array[j];
793 if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
2757d5ec
TK		 794 {
795 if (newvar == NULL)
f1abbf69 796 newvar = create_var (*ei, "fcn");
51a30b32 797
73e42eef
TB		 798 if (warn_function_elimination)
799 do_warn_function_elimination (*ej);
51a30b32 800
6c7069d6
TK		 801 free (*ej);
802 *ej = gfc_copy_expr (newvar);
2757d5ec
TK		 803 }
804 }
805 if (newvar)
6c7069d6 806 *ei = newvar;
2757d5ec
TK		 807 }
808
809 /* We did all the necessary walking in this function. */
810 *walk_subtrees = 0;
811 return 0;
812}
813
814/* Callback function for common function elimination, called from
815 gfc_code_walker. This keeps track of the current code, in order
816 to insert statements as needed. */
817
818static int
4f83d583 819cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
2757d5ec
TK		 820{
821 current_code = c;
5a87ca71
TK		 822 inserted_block = NULL;
823 changed_statement = NULL;
4f83d583
TK		 824
825 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
826 and allocation on assigment are prohibited inside WHERE, and finally
827 masking an expression would lead to wrong-code when replacing
828
829 WHERE (a>0)
830 b = sum(foo(a) + foo(a))
831 END WHERE
832
833 with
834
835 WHERE (a > 0)
836 tmp = foo(a)
837 b = sum(tmp + tmp)
838 END WHERE
839*/
840
841 if ((*c)->op == EXEC_WHERE)
842 {
843 *walk_subtrees = 0;
844 return 0;
845 }
7474dcc1 846
4f83d583 847
2757d5ec
TK		 848 return 0;
849}
850
fa11ae6c
TK		 851/* Dummy function for expression call back, for use when we
852 really don't want to do any walking. */
853
854static int
855dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
856 void *data ATTRIBUTE_UNUSED)
857{
858 *walk_subtrees = 0;
859 return 0;
860}
861
e81e4b43
TK		 862/* Dummy function for code callback, for use when we really
863 don't want to do anything. */
5f23671d
JJ		 864int
865gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
866 int *walk_subtrees ATTRIBUTE_UNUSED,
867 void *data ATTRIBUTE_UNUSED)
e81e4b43
TK		 868{
869 return 0;
870}
871
fa11ae6c
TK		 872/* Code callback function for converting
873 do while(a)
874 end do
875 into the equivalent
876 do
877 if (.not. a) exit
878 end do
879 This is because common function elimination would otherwise place the
880 temporary variables outside the loop. */
881
882static int
883convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
884 void *data ATTRIBUTE_UNUSED)
885{
886 gfc_code *co = *c;
887 gfc_code *c_if1, *c_if2, *c_exit;
888 gfc_code *loopblock;
889 gfc_expr *e_not, *e_cond;
890
891 if (co->op != EXEC_DO_WHILE)
892 return 0;
893
894 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
895 return 0;
896
897 e_cond = co->expr1;
898
899 /* Generate the condition of the if statement, which is .not. the original
900 statement. */
901 e_not = gfc_get_expr ();
902 e_not->ts = e_cond->ts;
903 e_not->where = e_cond->where;
904 e_not->expr_type = EXPR_OP;
905 e_not->value.op.op = INTRINSIC_NOT;
906 e_not->value.op.op1 = e_cond;
907
908 /* Generate the EXIT statement. */
909 c_exit = XCNEW (gfc_code);
910 c_exit->op = EXEC_EXIT;
911 c_exit->ext.which_construct = co;
912 c_exit->loc = co->loc;
913
914 /* Generate the IF statement. */
915 c_if2 = XCNEW (gfc_code);
916 c_if2->op = EXEC_IF;
917 c_if2->expr1 = e_not;
918 c_if2->next = c_exit;
919 c_if2->loc = co->loc;
920
921 /* ... plus the one to chain it to. */
922 c_if1 = XCNEW (gfc_code);
923 c_if1->op = EXEC_IF;
924 c_if1->block = c_if2;
925 c_if1->loc = co->loc;
926
927 /* Make the DO WHILE loop into a DO block by replacing the condition
928 with a true constant. */
929 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
930
931 /* Hang the generated if statement into the loop body. */
932
933 loopblock = co->block->next;
934 co->block->next = c_if1;
935 c_if1->next = loopblock;
936
937 return 0;
938}
939
cf82db16
TK		 940/* Code callback function for converting
941 if (a) then
942 ...
943 else if (b) then
944 end if
945
946 into
947 if (a) then
948 else
949 if (b) then
950 end if
951 end if
952
953 because otherwise common function elimination would place the BLOCKs
954 into the wrong place. */
955
956static int
957convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
958 void *data ATTRIBUTE_UNUSED)
959{
960 gfc_code *co = *c;
961 gfc_code *c_if1, *c_if2, *else_stmt;
962
963 if (co->op != EXEC_IF)
964 return 0;
965
966 /* This loop starts out with the first ELSE statement. */
967 else_stmt = co->block->block;
968
969 while (else_stmt != NULL)
970 {
971 gfc_code *next_else;
972
973 /* If there is no condition, we're done. */
974 if (else_stmt->expr1 == NULL)
975 break;
976
977 next_else = else_stmt->block;
978
979 /* Generate the new IF statement. */
980 c_if2 = XCNEW (gfc_code);
981 c_if2->op = EXEC_IF;
982 c_if2->expr1 = else_stmt->expr1;
983 c_if2->next = else_stmt->next;
984 c_if2->loc = else_stmt->loc;
985 c_if2->block = next_else;
986
987 /* ... plus the one to chain it to. */
988 c_if1 = XCNEW (gfc_code);
989 c_if1->op = EXEC_IF;
990 c_if1->block = c_if2;
991 c_if1->loc = else_stmt->loc;
992
993 /* Insert the new IF after the ELSE. */
994 else_stmt->expr1 = NULL;
995 else_stmt->next = c_if1;
996 else_stmt->block = NULL;
997
998 else_stmt = next_else;
999 }
1000 /* Don't walk subtrees. */
1001 return 0;
1002}
f1abbf69 1003
4d42b5cd 1004/* Optimize a namespace, including all contained namespaces. */
601d98be
TK		 1005
1006static void
4d42b5cd 1007optimize_namespace (gfc_namespace *ns)
601d98be 1008{
f1abbf69 1009 gfc_namespace *saved_ns = gfc_current_ns;
2757d5ec 1010 current_ns = ns;
f1abbf69 1011 gfc_current_ns = ns;
2855325f 1012 forall_level = 0;
8144d290 1013 iterator_level = 0;
e3f9e757 1014 in_assoc_list = false;
e07e39f6 1015 in_omp_workshare = false;
2757d5ec 1016
fa11ae6c 1017 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
cf82db16 1018 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
2757d5ec 1019 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
4d42b5cd 1020 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
f1abbf69
TK		 1021 if (flag_inline_matmul_limit != 0)
1022 gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
1023 NULL);
601d98be 1024
930d4d4e 1025 /* BLOCKs are handled in the expression walker below. */
4d42b5cd 1026 for (ns = ns->contained; ns; ns = ns->sibling)
930d4d4e
TK		 1027 {
1028 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1029 optimize_namespace (ns);
1030 }
f1abbf69 1031 gfc_current_ns = saved_ns;
601d98be
TK		 1032}
1033
8b7cec58
TK		 1034/* Handle dependencies for allocatable strings which potentially redefine
1035 themselves in an assignment. */
1036
1037static void
1038realloc_strings (gfc_namespace *ns)
1039{
1040 current_ns = ns;
1041 gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
1042
1043 for (ns = ns->contained; ns; ns = ns->sibling)
1044 {
1045 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
f1abbf69 1046 realloc_strings (ns);
8b7cec58
TK		 1047 }
1048
1049}
1050
e81e4b43
TK		 1051static void
1052optimize_reduction (gfc_namespace *ns)
1053{
1054 current_ns = ns;
5f23671d
JJ		 1055 gfc_code_walker (&ns->code, gfc_dummy_code_callback,
1056 callback_reduction, NULL);
e81e4b43
TK		 1057
1058/* BLOCKs are handled in the expression walker below. */
1059 for (ns = ns->contained; ns; ns = ns->sibling)
1060 {
1061 if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
1062 optimize_reduction (ns);
1063 }
1064}
1065
5c599206
TK		 1066/* Replace code like
1067 a = matmul(b,c) + d
1068 with
1069 a = matmul(b,c) ; a = a + d
1070 where the array function is not elemental and not allocatable
1071 and does not depend on the left-hand side.
1072*/
1073
1074static bool
1075optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
1076{
1077 gfc_expr *e;
1078
f1c7e7f1
SK		 1079 if (!*rhs)
1080 return false;
1081
5c599206
TK		 1082 e = *rhs;
1083 if (e->expr_type == EXPR_OP)
1084 {
1085 switch (e->value.op.op)
1086 {
1087 /* Unary operators and exponentiation: Only look at a single
1088 operand. */
1089 case INTRINSIC_NOT:
1090 case INTRINSIC_UPLUS:
1091 case INTRINSIC_UMINUS:
1092 case INTRINSIC_PARENTHESES:
1093 case INTRINSIC_POWER:
1094 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
1095 return true;
1096 break;
1097
dc2c36fd
TK		 1098 case INTRINSIC_CONCAT:
1099 /* Do not do string concatenations. */
1100 break;
1101
5c599206
TK		 1102 default:
1103 /* Binary operators. */
1104 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
1105 return true;
1106
1107 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
1108 return true;
1109
1110 break;
1111 }
1112 }
1113 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
7474dcc1
PT		 1114 && ! (e->value.function.esym
1115 && (e->value.function.esym->attr.elemental
962b8a0e
TK		 1116 || e->value.function.esym->attr.allocatable
1117 || e->value.function.esym->ts.type != c->expr1->ts.type
1118 || e->value.function.esym->ts.kind != c->expr1->ts.kind))
1119 && ! (e->value.function.isym
1120 && (e->value.function.isym->elemental
1121 || e->ts.type != c->expr1->ts.type
93ee6382
MM		 1122 || e->ts.kind != c->expr1->ts.kind))
1123 && ! gfc_inline_intrinsic_function_p (e))
5c599206
TK		 1124 {
1125
1126 gfc_code *n;
1127 gfc_expr *new_expr;
1128
1129 /* Insert a new assignment statement after the current one. */
1130 n = XCNEW (gfc_code);
1131 n->op = EXEC_ASSIGN;
1132 n->loc = c->loc;
1133 n->next = c->next;
1134 c->next = n;
1135
1136 n->expr1 = gfc_copy_expr (c->expr1);
1137 n->expr2 = c->expr2;
1138 new_expr = gfc_copy_expr (c->expr1);
1139 c->expr2 = e;
1140 *rhs = new_expr;
7474dcc1 1141
5c599206
TK		 1142 return true;
1143
1144 }
1145
1146 /* Nothing to optimize. */
1147 return false;
1148}
1149
4f21f0da
TK		 1150/* Remove unneeded TRIMs at the end of expressions. */
1151
1152static bool
1153remove_trim (gfc_expr *rhs)
1154{
1155 bool ret;
1156
1157 ret = false;
e5cf1629
SK		 1158 if (!rhs)
1159 return ret;
4f21f0da
TK		 1160
1161 /* Check for a // b // trim(c). Looping is probably not
1162 necessary because the parser usually generates
1163 (// (// a b ) trim(c) ) , but better safe than sorry. */
1164
1165 while (rhs->expr_type == EXPR_OP
1166 && rhs->value.op.op == INTRINSIC_CONCAT)
1167 rhs = rhs->value.op.op2;
1168
1169 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
1170 && rhs->value.function.isym->id == GFC_ISYM_TRIM)
1171 {
1172 strip_function_call (rhs);
1173 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1174 remove_trim (rhs);
1175 ret = true;
1176 }
1177
1178 return ret;
1179}
1180
601d98be
TK		 1181/* Optimizations for an assignment. */
1182
1183static void
1184optimize_assignment (gfc_code * c)
1185{
1186 gfc_expr *lhs, *rhs;
1187
1188 lhs = c->expr1;
1189 rhs = c->expr2;
1190
0f6bfefd 1191 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
94d145bf 1192 {
0f6bfefd 1193 /* Optimize a = trim(b) to a = b. */
94d145bf
TK		 1194 remove_trim (rhs);
1195
0f6bfefd 1196 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
524af0d6 1197 if (is_empty_string (rhs))
94d145bf
TK		 1198 rhs->value.character.length = 0;
1199 }
601d98be 1200
5c599206
TK		 1201 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
1202 optimize_binop_array_assignment (c, &rhs, false);
601d98be
TK		 1203}
1204
1205
1206/* Remove an unneeded function call, modifying the expression.
1207 This replaces the function call with the value of its
1208 first argument. The rest of the argument list is freed. */
1209
1210static void
1211strip_function_call (gfc_expr *e)
1212{
1213 gfc_expr *e1;
1214 gfc_actual_arglist *a;
1215
1216 a = e->value.function.actual;
1217
1218 /* We should have at least one argument. */
1219 gcc_assert (a->expr != NULL);
1220
1221 e1 = a->expr;
1222
1223 /* Free the remaining arglist, if any. */
1224 if (a->next)
1225 gfc_free_actual_arglist (a->next);
1226
1227 /* Graft the argument expression onto the original function. */
1228 *e = *e1;
cede9502 1229 free (e1);
601d98be
TK		 1230
1231}
1232
9046a4dc
TK		 1233/* Optimization of lexical comparison functions. */
1234
1235static bool
1236optimize_lexical_comparison (gfc_expr *e)
1237{
1238 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
1239 return false;
1240
1241 switch (e->value.function.isym->id)
1242 {
1243 case GFC_ISYM_LLE:
1244 return optimize_comparison (e, INTRINSIC_LE);
1245
1246 case GFC_ISYM_LGE:
1247 return optimize_comparison (e, INTRINSIC_GE);
1248
1249 case GFC_ISYM_LGT:
1250 return optimize_comparison (e, INTRINSIC_GT);
1251
1252 case GFC_ISYM_LLT:
1253 return optimize_comparison (e, INTRINSIC_LT);
1254
1255 default:
1256 break;
1257 }
1258 return false;
1259}
1260
4099436d
TK		 1261/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1262 do CHARACTER because of possible pessimization involving character
1263 lengths. */
1264
1265static bool
1266combine_array_constructor (gfc_expr *e)
1267{
1268
1269 gfc_expr *op1, *op2;
1270 gfc_expr *scalar;
1271 gfc_expr *new_expr;
1272 gfc_constructor *c, *new_c;
1273 gfc_constructor_base oldbase, newbase;
1274 bool scalar_first;
1275
1276 /* Array constructors have rank one. */
1277 if (e->rank != 1)
1278 return false;
1279
e3f9e757
TK		 1280 /* Don't try to combine association lists, this makes no sense
1281 and leads to an ICE. */
1282 if (in_assoc_list)
1283 return false;
1284
9c3e121b
TK		 1285 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1286 if (forall_level > 0)
1287 return false;
1288
1603ebe0
TK		 1289 /* Inside an iterator, things can get hairy; we are likely to create
1290 an invalid temporary variable. */
1291 if (iterator_level > 0)
1292 return false;
1293
4099436d
TK		 1294 op1 = e->value.op.op1;
1295 op2 = e->value.op.op2;
1296
e5cf1629
SK		 1297 if (!op1 || !op2)
1298 return false;
1299
4099436d
TK		 1300 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
1301 scalar_first = false;
1302 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
1303 {
1304 scalar_first = true;
1305 op1 = e->value.op.op2;
1306 op2 = e->value.op.op1;
1307 }
1308 else
1309 return false;
1310
1311 if (op2->ts.type == BT_CHARACTER)
1312 return false;
1313
f1abbf69 1314 scalar = create_var (gfc_copy_expr (op2), "constr");
4099436d
TK		 1315
1316 oldbase = op1->value.constructor;
1317 newbase = NULL;
1318 e->expr_type = EXPR_ARRAY;
1319
4099436d
TK		 1320 for (c = gfc_constructor_first (oldbase); c;
1321 c = gfc_constructor_next (c))
1322 {
1323 new_expr = gfc_get_expr ();
1324 new_expr->ts = e->ts;
1325 new_expr->expr_type = EXPR_OP;
1326 new_expr->rank = c->expr->rank;
1327 new_expr->where = c->where;
1328 new_expr->value.op.op = e->value.op.op;
1329
1330 if (scalar_first)
1331 {
1332 new_expr->value.op.op1 = gfc_copy_expr (scalar);
1333 new_expr->value.op.op2 = gfc_copy_expr (c->expr);
1334 }
1335 else
1336 {
1337 new_expr->value.op.op1 = gfc_copy_expr (c->expr);
1338 new_expr->value.op.op2 = gfc_copy_expr (scalar);
1339 }
1340
1341 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
1342 new_c->iterator = c->iterator;
1343 c->iterator = NULL;
1344 }
1345
1346 gfc_free_expr (op1);
1347 gfc_free_expr (op2);
36abe895 1348 gfc_free_expr (scalar);
4099436d
TK		 1349
1350 e->value.constructor = newbase;
1351 return true;
1352}
1353
0de1e4a6
TK		 1354/* Change (-1)**k into 1-ishift(iand(k,1),1) and
1355 2**k into ishift(1,k) */
1356
1357static bool
1358optimize_power (gfc_expr *e)
1359{
1360 gfc_expr *op1, *op2;
1361 gfc_expr *iand, *ishft;
1362
1363 if (e->ts.type != BT_INTEGER)
1364 return false;
1365
1366 op1 = e->value.op.op1;
1367
1368 if (op1 == NULL || op1->expr_type != EXPR_CONSTANT)
1369 return false;
1370
1371 if (mpz_cmp_si (op1->value.integer, -1L) == 0)
1372 {
1373 gfc_free_expr (op1);
1374
1375 op2 = e->value.op.op2;
1376
1377 if (op2 == NULL)
1378 return false;
1379
1380 iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND,
1381 "_internal_iand", e->where, 2, op2,
1382 gfc_get_int_expr (e->ts.kind,
1383 &e->where, 1));
7474dcc1 1384
0de1e4a6
TK		 1385 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1386 "_internal_ishft", e->where, 2, iand,
1387 gfc_get_int_expr (e->ts.kind,
1388 &e->where, 1));
1389
1390 e->value.op.op = INTRINSIC_MINUS;
1391 e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1);
1392 e->value.op.op2 = ishft;
1393 return true;
1394 }
1395 else if (mpz_cmp_si (op1->value.integer, 2L) == 0)
1396 {
1397 gfc_free_expr (op1);
1398
1399 op2 = e->value.op.op2;
1400 if (op2 == NULL)
1401 return false;
1402
1403 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
1404 "_internal_ishft", e->where, 2,
1405 gfc_get_int_expr (e->ts.kind,
1406 &e->where, 1),
1407 op2);
1408 *e = *ishft;
1409 return true;
1410 }
068b04fe
TK		 1411
1412 else if (mpz_cmp_si (op1->value.integer, 1L) == 0)
1413 {
1414 op2 = e->value.op.op2;
1415 if (op2 == NULL)
1416 return false;
1417
1418 gfc_free_expr (op1);
1419 gfc_free_expr (op2);
1420
1421 e->expr_type = EXPR_CONSTANT;
1422 e->value.op.op1 = NULL;
1423 e->value.op.op2 = NULL;
1424 mpz_init_set_si (e->value.integer, 1);
e1e14947 1425 /* Typespec and location are still OK. */
068b04fe
TK		 1426 return true;
1427 }
1428
0de1e4a6
TK		 1429 return false;
1430}
4099436d 1431
601d98be
TK		 1432/* Recursive optimization of operators. */
1433
1434static bool
1435optimize_op (gfc_expr *e)
1436{
4099436d
TK		 1437 bool changed;
1438
4d42b5cd 1439 gfc_intrinsic_op op = e->value.op.op;
601d98be 1440
4099436d
TK		 1441 changed = false;
1442
eea58adb 1443 /* Only use new-style comparisons. */
91077d4e
TK		 1444 switch(op)
1445 {
1446 case INTRINSIC_EQ_OS:
1447 op = INTRINSIC_EQ;
1448 break;
1449
1450 case INTRINSIC_GE_OS:
1451 op = INTRINSIC_GE;
1452 break;
1453
1454 case INTRINSIC_LE_OS:
1455 op = INTRINSIC_LE;
1456 break;
1457
1458 case INTRINSIC_NE_OS:
1459 op = INTRINSIC_NE;
1460 break;
1461
1462 case INTRINSIC_GT_OS:
1463 op = INTRINSIC_GT;
1464 break;
1465
1466 case INTRINSIC_LT_OS:
1467 op = INTRINSIC_LT;
1468 break;
1469
1470 default:
1471 break;
1472 }
1473
601d98be
TK		 1474 switch (op)
1475 {
1476 case INTRINSIC_EQ:
601d98be 1477 case INTRINSIC_GE:
601d98be 1478 case INTRINSIC_LE:
601d98be 1479 case INTRINSIC_NE:
601d98be 1480 case INTRINSIC_GT:
601d98be 1481 case INTRINSIC_LT:
4099436d
TK		 1482 changed = optimize_comparison (e, op);
1483
81fea426 1484 gcc_fallthrough ();
4099436d
TK		 1485 /* Look at array constructors. */
1486 case INTRINSIC_PLUS:
1487 case INTRINSIC_MINUS:
1488 case INTRINSIC_TIMES:
1489 case INTRINSIC_DIVIDE:
1490 return combine_array_constructor (e) || changed;
601d98be 1491
0de1e4a6
TK		 1492 case INTRINSIC_POWER:
1493 return optimize_power (e);
1494 break;
1495
601d98be
TK		 1496 default:
1497 break;
1498 }
1499
1500 return false;
1501}
1502
91077d4e
TK		 1503
1504/* Return true if a constant string contains only blanks. */
1505
1506static bool
9771b263 1507is_empty_string (gfc_expr *e)
91077d4e
TK		 1508{
1509 int i;
1510
1511 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1512 return false;
1513
1514 for (i=0; i < e->value.character.length; i++)
1515 {
1516 if (e->value.character.string[i] != ' ')
1517 return false;
1518 }
1519
1520 return true;
1521}
1522
1523
1524/* Insert a call to the intrinsic len_trim. Use a different name for
1525 the symbol tree so we don't run into trouble when the user has
1526 renamed len_trim for some reason. */
1527
1528static gfc_expr*
1529get_len_trim_call (gfc_expr *str, int kind)
1530{
1531 gfc_expr *fcn;
1532 gfc_actual_arglist *actual_arglist, *next;
1533
1534 fcn = gfc_get_expr ();
1535 fcn->expr_type = EXPR_FUNCTION;
1536 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
1537 actual_arglist = gfc_get_actual_arglist ();
1538 actual_arglist->expr = str;
1539 next = gfc_get_actual_arglist ();
1540 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
1541 actual_arglist->next = next;
1542
1543 fcn->value.function.actual = actual_arglist;
1544 fcn->where = str->where;
1545 fcn->ts.type = BT_INTEGER;
1546 fcn->ts.kind = gfc_charlen_int_kind;
1547
1548 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
1549 fcn->symtree->n.sym->ts = fcn->ts;
1550 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
1551 fcn->symtree->n.sym->attr.function = 1;
1552 fcn->symtree->n.sym->attr.elemental = 1;
1553 fcn->symtree->n.sym->attr.referenced = 1;
1554 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
1555 gfc_commit_symbol (fcn->symtree->n.sym);
1556
1557 return fcn;
1558}
1559
601d98be
TK		 1560/* Optimize expressions for equality. */
1561
1562static bool
32af57e2 1563optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
601d98be 1564{
601d98be
TK		 1565 gfc_expr *op1, *op2;
1566 bool change;
32af57e2
TK		 1567 int eq;
1568 bool result;
9046a4dc 1569 gfc_actual_arglist *firstarg, *secondarg;
601d98be 1570
9046a4dc
TK		 1571 if (e->expr_type == EXPR_OP)
1572 {
1573 firstarg = NULL;
1574 secondarg = NULL;
1575 op1 = e->value.op.op1;
1576 op2 = e->value.op.op2;
1577 }
1578 else if (e->expr_type == EXPR_FUNCTION)
1579 {
eea58adb 1580 /* One of the lexical comparison functions. */
9046a4dc
TK		 1581 firstarg = e->value.function.actual;
1582 secondarg = firstarg->next;
1583 op1 = firstarg->expr;
1584 op2 = secondarg->expr;
1585 }
1586 else
1587 gcc_unreachable ();
601d98be
TK		 1588
1589 /* Strip off unneeded TRIM calls from string comparisons. */
1590
4f21f0da 1591 change = remove_trim (op1);
601d98be 1592
4f21f0da
TK		 1593 if (remove_trim (op2))
1594 change = true;
601d98be 1595
c0d15a77
MM		 1596 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1597 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1598 handles them well). However, there are also cases that need a non-scalar
1599 argument. For example the any intrinsic. See PR 45380. */
1600 if (e->rank > 0)
4f21f0da 1601 return change;
c0d15a77 1602
91077d4e
TK		 1603 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1604 len_trim(a) != 0 */
1605 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
1606 && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
1607 {
1608 bool empty_op1, empty_op2;
9771b263
DN		 1609 empty_op1 = is_empty_string (op1);
1610 empty_op2 = is_empty_string (op2);
91077d4e
TK		 1611
1612 if (empty_op1 || empty_op2)
1613 {
1614 gfc_expr *fcn;
1615 gfc_expr *zero;
1616 gfc_expr *str;
1617
1618 /* This can only happen when an error for comparing
1619 characters of different kinds has already been issued. */
1620 if (empty_op1 && empty_op2)
1621 return false;
1622
1623 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
1624 str = empty_op1 ? op2 : op1;
1625
1626 fcn = get_len_trim_call (str, gfc_charlen_int_kind);
1627
1628
1629 if (empty_op1)
1630 gfc_free_expr (op1);
1631 else
1632 gfc_free_expr (op2);
1633
1634 op1 = fcn;
1635 op2 = zero;
1636 e->value.op.op1 = fcn;
1637 e->value.op.op2 = zero;
1638 }
1639 }
1640
1641
32af57e2
TK		 1642 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1643
1644 if (flag_finite_math_only
1645 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
1646 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
601d98be 1647 {
32af57e2 1648 eq = gfc_dep_compare_expr (op1, op2);
13001f33 1649 if (eq <= -2)
32af57e2
TK		 1650 {
1651 /* Replace A // B < A // C with B < C, and A // B < C // B
1652 with A < C. */
1653 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
2ce29890 1654 && op1->expr_type == EXPR_OP
32af57e2 1655 && op1->value.op.op == INTRINSIC_CONCAT
2ce29890 1656 && op2->expr_type == EXPR_OP
32af57e2
TK		 1657 && op2->value.op.op == INTRINSIC_CONCAT)
1658 {
1659 gfc_expr *op1_left = op1->value.op.op1;
1660 gfc_expr *op2_left = op2->value.op.op1;
1661 gfc_expr *op1_right = op1->value.op.op2;
1662 gfc_expr *op2_right = op2->value.op.op2;
1663
1664 if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
1665 {
1666 /* Watch out for 'A ' // x vs. 'A' // x. */
1667
1668 if (op1_left->expr_type == EXPR_CONSTANT
1669 && op2_left->expr_type == EXPR_CONSTANT
1670 && op1_left->value.character.length
1671 != op2_left->value.character.length)
4f21f0da 1672 return change;
32af57e2
TK		 1673 else
1674 {
cede9502
JM		 1675 free (op1_left);
1676 free (op2_left);
9046a4dc
TK		 1677 if (firstarg)
1678 {
1679 firstarg->expr = op1_right;
1680 secondarg->expr = op2_right;
1681 }
1682 else
1683 {
1684 e->value.op.op1 = op1_right;
1685 e->value.op.op2 = op2_right;
1686 }
32af57e2
TK		 1687 optimize_comparison (e, op);
1688 return true;
1689 }
1690 }
1691 if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
1692 {
cede9502
JM		 1693 free (op1_right);
1694 free (op2_right);
9046a4dc
TK		 1695 if (firstarg)
1696 {
1697 firstarg->expr = op1_left;
1698 secondarg->expr = op2_left;
1699 }
1700 else
1701 {
1702 e->value.op.op1 = op1_left;
1703 e->value.op.op2 = op2_left;
1704 }
1705
32af57e2
TK		 1706 optimize_comparison (e, op);
1707 return true;
1708 }
1709 }
1710 }
1711 else
1712 {
1713 /* eq can only be -1, 0 or 1 at this point. */
1714 switch (op)
1715 {
1716 case INTRINSIC_EQ:
32af57e2
TK		 1717 result = eq == 0;
1718 break;
7474dcc1 1719
32af57e2 1720 case INTRINSIC_GE:
32af57e2
TK		 1721 result = eq >= 0;
1722 break;
1723
1724 case INTRINSIC_LE:
32af57e2
TK		 1725 result = eq <= 0;
1726 break;
1727
1728 case INTRINSIC_NE:
32af57e2
TK		 1729 result = eq != 0;
1730 break;
1731
1732 case INTRINSIC_GT:
32af57e2
TK		 1733 result = eq > 0;
1734 break;
1735
1736 case INTRINSIC_LT:
32af57e2
TK		 1737 result = eq < 0;
1738 break;
7474dcc1 1739
32af57e2
TK		 1740 default:
1741 gfc_internal_error ("illegal OP in optimize_comparison");
1742 break;
1743 }
1744
1745 /* Replace the expression by a constant expression. The typespec
1746 and where remains the way it is. */
cede9502
JM		 1747 free (op1);
1748 free (op2);
32af57e2
TK		 1749 e->expr_type = EXPR_CONSTANT;
1750 e->value.logical = result;
1751 return true;
1752 }
601d98be 1753 }
32af57e2 1754
4f21f0da 1755 return change;
601d98be
TK		 1756}
1757
4afeb65c
TK		 1758/* Optimize a trim function by replacing it with an equivalent substring
1759 involving a call to len_trim. This only works for expressions where
1760 variables are trimmed. Return true if anything was modified. */
1761
1762static bool
1763optimize_trim (gfc_expr *e)
1764{
1765 gfc_expr *a;
1766 gfc_ref *ref;
1767 gfc_expr *fcn;
7e3b6543 1768 gfc_ref **rr = NULL;
4afeb65c
TK		 1769
1770 /* Don't do this optimization within an argument list, because
1771 otherwise aliasing issues may occur. */
1772
1773 if (count_arglist != 1)
1774 return false;
1775
1776 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
1777 || e->value.function.isym == NULL
1778 || e->value.function.isym->id != GFC_ISYM_TRIM)
1779 return false;
1780
1781 a = e->value.function.actual->expr;
1782
1783 if (a->expr_type != EXPR_VARIABLE)
1784 return false;
1785
8b7cec58
TK		 1786 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1787
1788 if (a->symtree->n.sym->attr.allocatable)
1789 return false;
1790
7e3b6543
TK		 1791 /* Follow all references to find the correct place to put the newly
1792 created reference. FIXME: Also handle substring references and
1793 array references. Array references cause strange regressions at
1794 the moment. */
1795
4afeb65c
TK		 1796 if (a->ref)
1797 {
7e3b6543
TK		 1798 for (rr = &(a->ref); *rr; rr = &((*rr)->next))
1799 {
1800 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
1801 return false;
1802 }
4afeb65c 1803 }
4afeb65c 1804
7e3b6543 1805 strip_function_call (e);
4afeb65c 1806
7e3b6543
TK		 1807 if (e->ref == NULL)
1808 rr = &(e->ref);
4afeb65c 1809
7e3b6543 1810 /* Create the reference. */
4afeb65c 1811
7e3b6543
TK		 1812 ref = gfc_get_ref ();
1813 ref->type = REF_SUBSTRING;
4afeb65c 1814
7e3b6543 1815 /* Set the start of the reference. */
4afeb65c 1816
7e3b6543 1817 ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4afeb65c 1818
0f6bfefd 1819 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
4afeb65c 1820
91077d4e 1821 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
7e3b6543
TK		 1822
1823 /* Set the end of the reference to the call to len_trim. */
1824
1825 ref->u.ss.end = fcn;
efb63364 1826 gcc_assert (rr != NULL && *rr == NULL);
7e3b6543
TK		 1827 *rr = ref;
1828 return true;
4afeb65c
TK		 1829}
1830
d2663912
JJ		 1831/* Optimize minloc(b), where b is rank 1 array, into
1832 (/ minloc(b, dim=1) /), and similarly for maxloc,
1833 as the latter forms are expanded inline. */
1834
1835static void
1836optimize_minmaxloc (gfc_expr **e)
1837{
1838 gfc_expr *fn = *e;
1839 gfc_actual_arglist *a;
1840 char *name, *p;
1841
1842 if (fn->rank != 1
1843 || fn->value.function.actual == NULL
1844 || fn->value.function.actual->expr == NULL
1845 || fn->value.function.actual->expr->rank != 1)
1846 return;
1847
1848 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
1849 (*e)->shape = fn->shape;
1850 fn->rank = 0;
1851 fn->shape = NULL;
1852 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
1853
1854 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
1855 strcpy (name, fn->value.function.name);
1856 p = strstr (name, "loc0");
1857 p[3] = '1';
1858 fn->value.function.name = gfc_get_string (name);
1859 if (fn->value.function.actual->next)
1860 {
1861 a = fn->value.function.actual->next;
1862 gcc_assert (a->expr == NULL);
1863 }
1864 else
1865 {
1866 a = gfc_get_actual_arglist ();
1867 fn->value.function.actual->next = a;
1868 }
1869 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1870 &fn->where);
1871 mpz_set_ui (a->expr->value.integer, 1);
1872}
1873
305a35da
TK		 1874/* Callback function for code checking that we do not pass a DO variable to an
1875 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1876
1877static int
1878doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
1879 void *data ATTRIBUTE_UNUSED)
1880{
1881 gfc_code *co;
1882 int i;
1883 gfc_formal_arglist *f;
1884 gfc_actual_arglist *a;
6c7069d6 1885 gfc_code *cl;
305a35da
TK		 1886
1887 co = *c;
1888
6c7069d6
TK		 1889 /* If the doloop_list grew, we have to truncate it here. */
1890
1891 if ((unsigned) doloop_level < doloop_list.length())
1892 doloop_list.truncate (doloop_level);
1893
305a35da
TK		 1894 switch (co->op)
1895 {
1896 case EXEC_DO:
1897
305a35da 1898 if (co->ext.iterator && co->ext.iterator->var)
6c7069d6 1899 doloop_list.safe_push (co);
305a35da 1900 else
6c7069d6 1901 doloop_list.safe_push ((gfc_code *) NULL);
305a35da
TK		 1902 break;
1903
1904 case EXEC_CALL:
da52ef43
TK		 1905
1906 if (co->resolved_sym == NULL)
1907 break;
1908
4cbc9039 1909 f = gfc_sym_get_dummy_args (co->resolved_sym);
305a35da
TK		 1910
1911 /* Withot a formal arglist, there is only unknown INTENT,
1912 which we don't check for. */
1913 if (f == NULL)
1914 break;
1915
1916 a = co->ext.actual;
1917
1918 while (a && f)
1919 {
6c7069d6 1920 FOR_EACH_VEC_ELT (doloop_list, i, cl)
305a35da
TK		 1921 {
1922 gfc_symbol *do_sym;
7474dcc1 1923
6c7069d6 1924 if (cl == NULL)
305a35da
TK		 1925 break;
1926
6c7069d6 1927 do_sym = cl->ext.iterator->var->symtree->n.sym;
7474dcc1 1928
305a35da
TK		 1929 if (a->expr && a->expr->symtree
1930 && a->expr->symtree->n.sym == do_sym)
1931 {
1932 if (f->sym->attr.intent == INTENT_OUT)
fea70c99
MLI		 1933 gfc_error_now ("Variable %qs at %L set to undefined "
1934 "value inside loop beginning at %L as "
1935 "INTENT(OUT) argument to subroutine %qs",
1936 do_sym->name, &a->expr->where,
1937 &doloop_list[i]->loc,
1938 co->symtree->n.sym->name);
305a35da 1939 else if (f->sym->attr.intent == INTENT_INOUT)
fea70c99
MLI		 1940 gfc_error_now ("Variable %qs at %L not definable inside "
1941 "loop beginning at %L as INTENT(INOUT) "
1942 "argument to subroutine %qs",
1943 do_sym->name, &a->expr->where,
1944 &doloop_list[i]->loc,
1945 co->symtree->n.sym->name);
305a35da
TK		 1946 }
1947 }
1948 a = a->next;
1949 f = f->next;
1950 }
1951 break;
1952
1953 default:
1954 break;
1955 }
1956 return 0;
1957}
1958
1959/* Callback function for functions checking that we do not pass a DO variable
1960 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1961
1962static int
1963do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
1964 void *data ATTRIBUTE_UNUSED)
1965{
1966 gfc_formal_arglist *f;
1967 gfc_actual_arglist *a;
1968 gfc_expr *expr;
6c7069d6 1969 gfc_code *dl;
305a35da
TK		 1970 int i;
1971
1972 expr = *e;
1973 if (expr->expr_type != EXPR_FUNCTION)
1974 return 0;
1975
1976 /* Intrinsic functions don't modify their arguments. */
1977
1978 if (expr->value.function.isym)
1979 return 0;
1980
4cbc9039 1981 f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
305a35da
TK		 1982
1983 /* Without a formal arglist, there is only unknown INTENT,
1984 which we don't check for. */
1985 if (f == NULL)
1986 return 0;
1987
1988 a = expr->value.function.actual;
1989
1990 while (a && f)
1991 {
6c7069d6 1992 FOR_EACH_VEC_ELT (doloop_list, i, dl)
305a35da
TK		 1993 {
1994 gfc_symbol *do_sym;
6c7069d6
TK		 1995
1996 if (dl == NULL)
305a35da
TK		 1997 break;
1998
6c7069d6 1999 do_sym = dl->ext.iterator->var->symtree->n.sym;
7474dcc1 2000
305a35da
TK		 2001 if (a->expr && a->expr->symtree
2002 && a->expr->symtree->n.sym == do_sym)
2003 {
2004 if (f->sym->attr.intent == INTENT_OUT)
fea70c99
MLI		 2005 gfc_error_now ("Variable %qs at %L set to undefined value "
2006 "inside loop beginning at %L as INTENT(OUT) "
2007 "argument to function %qs", do_sym->name,
2008 &a->expr->where, &doloop_list[i]->loc,
2009 expr->symtree->n.sym->name);
305a35da 2010 else if (f->sym->attr.intent == INTENT_INOUT)
fea70c99
MLI		 2011 gfc_error_now ("Variable %qs at %L not definable inside loop"
2012 " beginning at %L as INTENT(INOUT) argument to"
2013 " function %qs", do_sym->name,
2014 &a->expr->where, &doloop_list[i]->loc,
2015 expr->symtree->n.sym->name);
305a35da
TK		 2016 }
2017 }
2018 a = a->next;
2019 f = f->next;
2020 }
2021
2022 return 0;
2023}
2024
2025static void
2026doloop_warn (gfc_namespace *ns)
2027{
2028 gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
2029}
2030
f1abbf69
TK		 2031/* This selction deals with inlining calls to MATMUL. */
2032
2033/* Auxiliary function to build and simplify an array inquiry function.
2034 dim is zero-based. */
2035
2036static gfc_expr *
2037get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim)
2038{
2039 gfc_expr *fcn;
2040 gfc_expr *dim_arg, *kind;
2041 const char *name;
2042 gfc_expr *ec;
2043
2044 switch (id)
2045 {
2046 case GFC_ISYM_LBOUND:
2047 name = "_gfortran_lbound";
2048 break;
2049
2050 case GFC_ISYM_UBOUND:
2051 name = "_gfortran_ubound";
2052 break;
2053
2054 case GFC_ISYM_SIZE:
2055 name = "_gfortran_size";
2056 break;
2057
2058 default:
2059 gcc_unreachable ();
2060 }
2061
2062 dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
2063 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
2064 gfc_index_integer_kind);
2065
2066 ec = gfc_copy_expr (e);
2067 fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
2068 ec, dim_arg, kind);
2069 gfc_simplify_expr (fcn, 0);
2070 return fcn;
2071}
2072
2073/* Builds a logical expression. */
2074
2075static gfc_expr*
2076build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
2077{
2078 gfc_typespec ts;
2079 gfc_expr *res;
2080
2081 ts.type = BT_LOGICAL;
2082 ts.kind = gfc_default_logical_kind;
2083 res = gfc_get_expr ();
2084 res->where = e1->where;
2085 res->expr_type = EXPR_OP;
2086 res->value.op.op = op;
2087 res->value.op.op1 = e1;
2088 res->value.op.op2 = e2;
2089 res->ts = ts;
2090
2091 return res;
2092}
2093
2094
2095/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2096 compatible typespecs. */
2097
2098static gfc_expr *
2099get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
2100{
2101 gfc_expr *res;
2102
2103 res = gfc_get_expr ();
2104 res->ts = e1->ts;
2105 res->where = e1->where;
2106 res->expr_type = EXPR_OP;
2107 res->value.op.op = op;
2108 res->value.op.op1 = e1;
2109 res->value.op.op2 = e2;
2110 gfc_simplify_expr (res, 0);
2111 return res;
2112}
2113
2114/* Generate the IF statement for a runtime check if we want to do inlining or
2115 not - putting in the code for both branches and putting it into the syntax
2116 tree is the caller's responsibility. For fixed array sizes, this should be
2117 removed by DCE. Only called for rank-two matrices A and B. */
2118
2119static gfc_code *
2120inline_limit_check (gfc_expr *a, gfc_expr *b, enum matrix_case m_case)
2121{
2122 gfc_expr *inline_limit;
2123 gfc_code *if_1, *if_2, *else_2;
2124 gfc_expr *b2, *a2, *a1, *m1, *m2;
2125 gfc_typespec ts;
2126 gfc_expr *cond;
2127
094773e8 2128 gcc_assert (m_case == A2B2 || m_case == A2B2T);
f1abbf69
TK		 2129
2130 /* Calculation is done in real to avoid integer overflow. */
2131
2132 inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
2133 &a->where);
2134 mpfr_set_si (inline_limit->value.real, flag_inline_matmul_limit,
2135 GFC_RND_MODE);
2136 mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3,
2137 GFC_RND_MODE);
2138
2139 a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2140 a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
2141 b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
2142
2143 gfc_clear_ts (&ts);
2144 ts.type = BT_REAL;
2145 ts.kind = gfc_default_real_kind;
2146 gfc_convert_type_warn (a1, &ts, 2, 0);
2147 gfc_convert_type_warn (a2, &ts, 2, 0);
2148 gfc_convert_type_warn (b2, &ts, 2, 0);
2149
2150 m1 = get_operand (INTRINSIC_TIMES, a1, a2);
2151 m2 = get_operand (INTRINSIC_TIMES, m1, b2);
2152
2153 cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
2154 gfc_simplify_expr (cond, 0);
2155
2156 else_2 = XCNEW (gfc_code);
2157 else_2->op = EXEC_IF;
2158 else_2->loc = a->where;
2159
2160 if_2 = XCNEW (gfc_code);
2161 if_2->op = EXEC_IF;
2162 if_2->expr1 = cond;
2163 if_2->loc = a->where;
2164 if_2->block = else_2;
2165
2166 if_1 = XCNEW (gfc_code);
2167 if_1->op = EXEC_IF;
2168 if_1->block = if_2;
2169 if_1->loc = a->where;
2170
2171 return if_1;
2172}
2173
2174
2175/* Insert code to issue a runtime error if the expressions are not equal. */
2176
2177static gfc_code *
2178runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
2179{
2180 gfc_expr *cond;
2181 gfc_code *if_1, *if_2;
2182 gfc_code *c;
2183 gfc_actual_arglist *a1, *a2, *a3;
2184
2185 gcc_assert (e1->where.lb);
2186 /* Build the call to runtime_error. */
2187 c = XCNEW (gfc_code);
2188 c->op = EXEC_CALL;
2189 c->loc = e1->where;
2190
2191 /* Get a null-terminated message string. */
2192
2193 a1 = gfc_get_actual_arglist ();
2194 a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
2195 msg, strlen(msg)+1);
2196 c->ext.actual = a1;
2197
2198 /* Pass the value of the first expression. */
2199 a2 = gfc_get_actual_arglist ();
2200 a2->expr = gfc_copy_expr (e1);
2201 a1->next = a2;
2202
2203 /* Pass the value of the second expression. */
2204 a3 = gfc_get_actual_arglist ();
2205 a3->expr = gfc_copy_expr (e2);
2206 a2->next = a3;
2207
2208 gfc_check_fe_runtime_error (c->ext.actual);
2209 gfc_resolve_fe_runtime_error (c);
2210
2211 if_2 = XCNEW (gfc_code);
2212 if_2->op = EXEC_IF;
2213 if_2->loc = e1->where;
2214 if_2->next = c;
2215
2216 if_1 = XCNEW (gfc_code);
2217 if_1->op = EXEC_IF;
2218 if_1->block = if_2;
2219 if_1->loc = e1->where;
2220
2221 cond = build_logical_expr (INTRINSIC_NE, e1, e2);
2222 gfc_simplify_expr (cond, 0);
2223 if_2->expr1 = cond;
2224
2225 return if_1;
2226}
2227
2228/* Handle matrix reallocation. Caller is responsible to insert into
2229 the code tree.
2230
7474dcc1 2231 For the two-dimensional case, build
f1abbf69
TK		 2232
2233 if (allocated(c)) then
2234 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2235 deallocate(c)
2236 allocate (c(size(a,1), size(b,2)))
2237 end if
2238 else
2239 allocate (c(size(a,1),size(b,2)))
2240 end if
2241
2242 and for the other cases correspondingly.
2243*/
2244
2245static gfc_code *
2246matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
2247 enum matrix_case m_case)
2248{
2249
2250 gfc_expr *allocated, *alloc_expr;
2251 gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
2252 gfc_code *else_alloc;
2253 gfc_code *deallocate, *allocate1, *allocate_else;
2254 gfc_array_ref *ar;
2255 gfc_expr *cond, *ne1, *ne2;
2256
2257 if (warn_realloc_lhs)
2258 gfc_warning (OPT_Wrealloc_lhs,
2259 "Code for reallocating the allocatable array at %L will "
2260 "be added", &c->where);
2261
2262 alloc_expr = gfc_copy_expr (c);
2263
2264 ar = gfc_find_array_ref (alloc_expr);
2265 gcc_assert (ar && ar->type == AR_FULL);
2266
2267 /* c comes in as a full ref. Change it into a copy and make it into an
2268 element ref so it has the right form for for ALLOCATE. In the same
2269 switch statement, also generate the size comparison for the secod IF
2270 statement. */
2271
2272 ar->type = AR_ELEMENT;
2273
2274 switch (m_case)
2275 {
2276 case A2B2:
2277 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2278 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
2279 ne1 = build_logical_expr (INTRINSIC_NE,
2280 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2281 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
2282 ne2 = build_logical_expr (INTRINSIC_NE,
2283 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
2284 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
2285 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
2286 break;
2287
094773e8
TK		 2288 case A2B2T:
2289 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2290 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
2291
2292 ne1 = build_logical_expr (INTRINSIC_NE,
2293 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2294 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
2295 ne2 = build_logical_expr (INTRINSIC_NE,
2296 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
2297 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
2298 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
a220f43d 2299 break;
094773e8 2300
f1abbf69
TK		 2301 case A2B1:
2302 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
2303 cond = build_logical_expr (INTRINSIC_NE,
2304 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2305 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
2306 break;
2307
2308 case A1B2:
2309 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
2310 cond = build_logical_expr (INTRINSIC_NE,
2311 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
2312 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
2313 break;
2314
2315 default:
2316 gcc_unreachable();
2317
2318 }
2319
2320 gfc_simplify_expr (cond, 0);
2321
2322 /* We need two identical allocate statements in two
2323 branches of the IF statement. */
7474dcc1 2324
f1abbf69
TK		 2325 allocate1 = XCNEW (gfc_code);
2326 allocate1->op = EXEC_ALLOCATE;
2327 allocate1->ext.alloc.list = gfc_get_alloc ();
2328 allocate1->loc = c->where;
2329 allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
2330
2331 allocate_else = XCNEW (gfc_code);
2332 allocate_else->op = EXEC_ALLOCATE;
2333 allocate_else->ext.alloc.list = gfc_get_alloc ();
2334 allocate_else->loc = c->where;
2335 allocate_else->ext.alloc.list->expr = alloc_expr;
2336
2337 allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
2338 "_gfortran_allocated", c->where,
2339 1, gfc_copy_expr (c));
2340
2341 deallocate = XCNEW (gfc_code);
2342 deallocate->op = EXEC_DEALLOCATE;
2343 deallocate->ext.alloc.list = gfc_get_alloc ();
2344 deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
2345 deallocate->next = allocate1;
2346 deallocate->loc = c->where;
7474dcc1 2347
f1abbf69
TK		 2348 if_size_2 = XCNEW (gfc_code);
2349 if_size_2->op = EXEC_IF;
2350 if_size_2->expr1 = cond;
2351 if_size_2->loc = c->where;
2352 if_size_2->next = deallocate;
2353
2354 if_size_1 = XCNEW (gfc_code);
2355 if_size_1->op = EXEC_IF;
2356 if_size_1->block = if_size_2;
2357 if_size_1->loc = c->where;
2358
2359 else_alloc = XCNEW (gfc_code);
2360 else_alloc->op = EXEC_IF;
2361 else_alloc->loc = c->where;
2362 else_alloc->next = allocate_else;
2363
2364 if_alloc_2 = XCNEW (gfc_code);
2365 if_alloc_2->op = EXEC_IF;
2366 if_alloc_2->expr1 = allocated;
2367 if_alloc_2->loc = c->where;
2368 if_alloc_2->next = if_size_1;
2369 if_alloc_2->block = else_alloc;
2370
2371 if_alloc_1 = XCNEW (gfc_code);
2372 if_alloc_1->op = EXEC_IF;
2373 if_alloc_1->block = if_alloc_2;
2374 if_alloc_1->loc = c->where;
2375
2376 return if_alloc_1;
2377}
2378
2379/* Callback function for has_function_or_op. */
2380
2381static int
2382is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2383 void *data ATTRIBUTE_UNUSED)
2384{
2385 if ((*e) == 0)
2386 return 0;
2387 else
2388 return (*e)->expr_type == EXPR_FUNCTION
2389 || (*e)->expr_type == EXPR_OP;
2390}
2391
2392/* Returns true if the expression contains a function. */
2393
2394static bool
2395has_function_or_op (gfc_expr **e)
2396{
2397 if (e == NULL)
2398 return false;
2399 else
2400 return gfc_expr_walker (e, is_function_or_op, NULL);
2401}
2402
2403/* Freeze (assign to a temporary variable) a single expression. */
2404
2405static void
2406freeze_expr (gfc_expr **ep)
2407{
2408 gfc_expr *ne;
2409 if (has_function_or_op (ep))
2410 {
2411 ne = create_var (*ep, "freeze");
2412 *ep = ne;
2413 }
2414}
2415
2416/* Go through an expression's references and assign them to temporary
2417 variables if they contain functions. This is usually done prior to
2418 front-end scalarization to avoid multiple invocations of functions. */
2419
2420static void
2421freeze_references (gfc_expr *e)
2422{
2423 gfc_ref *r;
2424 gfc_array_ref *ar;
2425 int i;
2426
2427 for (r=e->ref; r; r=r->next)
2428 {
2429 if (r->type == REF_SUBSTRING)
2430 {
2431 if (r->u.ss.start != NULL)
2432 freeze_expr (&r->u.ss.start);
2433
2434 if (r->u.ss.end != NULL)
2435 freeze_expr (&r->u.ss.end);
2436 }
2437 else if (r->type == REF_ARRAY)
2438 {
2439 ar = &r->u.ar;
2440 switch (ar->type)
2441 {
2442 case AR_FULL:
2443 break;
2444
2445 case AR_SECTION:
2446 for (i=0; i<ar->dimen; i++)
2447 {
2448 if (ar->dimen_type[i] == DIMEN_RANGE)
2449 {
2450 freeze_expr (&ar->start[i]);
2451 freeze_expr (&ar->end[i]);
2452 freeze_expr (&ar->stride[i]);
2453 }
2454 else if (ar->dimen_type[i] == DIMEN_ELEMENT)
2455 {
2456 freeze_expr (&ar->start[i]);
2457 }
2458 }
2459 break;
2460
2461 case AR_ELEMENT:
2462 for (i=0; i<ar->dimen; i++)
2463 freeze_expr (&ar->start[i]);
2464 break;
2465
2466 default:
2467 break;
2468 }
2469 }
2470 }
2471}
2472
2473/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2474
2475static gfc_expr *
2476convert_to_index_kind (gfc_expr *e)
2477{
2478 gfc_expr *res;
2479
2480 gcc_assert (e != NULL);
2481
2482 res = gfc_copy_expr (e);
2483
2484 gcc_assert (e->ts.type == BT_INTEGER);
2485
2486 if (res->ts.kind != gfc_index_integer_kind)
2487 {
2488 gfc_typespec ts;
2489 gfc_clear_ts (&ts);
2490 ts.type = BT_INTEGER;
2491 ts.kind = gfc_index_integer_kind;
2492
2493 gfc_convert_type_warn (e, &ts, 2, 0);
2494 }
2495
2496 return res;
2497}
2498
2499/* Function to create a DO loop including creation of the
2500 iteration variable. gfc_expr are copied.*/
2501
2502static gfc_code *
2503create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
2504 gfc_namespace *ns, char *vname)
2505{
2506
2507 char name[GFC_MAX_SYMBOL_LEN +1];
2508 gfc_symtree *symtree;
2509 gfc_symbol *symbol;
2510 gfc_expr *i;
2511 gfc_code *n, *n2;
2512
2513 /* Create an expression for the iteration variable. */
2514 if (vname)
2515 sprintf (name, "__var_%d_do_%s", var_num++, vname);
2516 else
2517 sprintf (name, "__var_%d_do", var_num++);
2518
2519
2520 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
2521 gcc_unreachable ();
2522
2523 /* Create the loop variable. */
2524
2525 symbol = symtree->n.sym;
2526 symbol->ts.type = BT_INTEGER;
2527 symbol->ts.kind = gfc_index_integer_kind;
2528 symbol->attr.flavor = FL_VARIABLE;
2529 symbol->attr.referenced = 1;
2530 symbol->attr.dimension = 0;
2531 symbol->attr.fe_temp = 1;
2532 gfc_commit_symbol (symbol);
2533
2534 i = gfc_get_expr ();
2535 i->expr_type = EXPR_VARIABLE;
2536 i->ts = symbol->ts;
2537 i->rank = 0;
2538 i->where = *where;
2539 i->symtree = symtree;
2540
2541 /* ... and the nested DO statements. */
2542 n = XCNEW (gfc_code);
2543 n->op = EXEC_DO;
2544 n->loc = *where;
2545 n->ext.iterator = gfc_get_iterator ();
2546 n->ext.iterator->var = i;
2547 n->ext.iterator->start = convert_to_index_kind (start);
2548 n->ext.iterator->end = convert_to_index_kind (end);
2549 if (step)
2550 n->ext.iterator->step = convert_to_index_kind (step);
2551 else
2552 n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
2553 where, 1);
2554
2555 n2 = XCNEW (gfc_code);
2556 n2->op = EXEC_DO;
2557 n2->loc = *where;
2558 n2->next = NULL;
2559 n->block = n2;
2560 return n;
2561}
2562
2563/* Get the upper bound of the DO loops for matmul along a dimension. This
2564 is one-based. */
2565
2566static gfc_expr*
2567get_size_m1 (gfc_expr *e, int dimen)
2568{
2569 mpz_t size;
2570 gfc_expr *res;
2571
2572 if (gfc_array_dimen_size (e, dimen - 1, &size))
2573 {
2574 res = gfc_get_constant_expr (BT_INTEGER,
2575 gfc_index_integer_kind, &e->where);
2576 mpz_sub_ui (res->value.integer, size, 1);
2577 mpz_clear (size);
2578 }
2579 else
2580 {
2581 res = get_operand (INTRINSIC_MINUS,
2582 get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
2583 gfc_get_int_expr (gfc_index_integer_kind,
2584 &e->where, 1));
2585 gfc_simplify_expr (res, 0);
2586 }
2587
2588 return res;
2589}
2590
2591/* Function to return a scalarized expression. It is assumed that indices are
2592 zero based to make generation of DO loops easier. A zero as index will
2593 access the first element along a dimension. Single element references will
2594 be skipped. A NULL as an expression will be replaced by a full reference.
2595 This assumes that the index loops have gfc_index_integer_kind, and that all
2596 references have been frozen. */
2597
2598static gfc_expr*
2599scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
2600{
2601 gfc_array_ref *ar;
2602 int i;
2603 int rank;
2604 gfc_expr *e;
2605 int i_index;
2606 bool was_fullref;
2607
2608 e = gfc_copy_expr(e_in);
2609
2610 rank = e->rank;
2611
2612 ar = gfc_find_array_ref (e);
2613
2614 /* We scalarize count_index variables, reducing the rank by count_index. */
2615
2616 e->rank = rank - count_index;
2617
2618 was_fullref = ar->type == AR_FULL;
2619
2620 if (e->rank == 0)
2621 ar->type = AR_ELEMENT;
2622 else
2623 ar->type = AR_SECTION;
2624
2625 /* Loop over the indices. For each index, create the expression
2626 index * stride + lbound(e, dim). */
7474dcc1 2627
f1abbf69
TK		 2628 i_index = 0;
2629 for (i=0; i < ar->dimen; i++)
2630 {
2631 if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
2632 {
2633 if (index[i_index] != NULL)
2634 {
2635 gfc_expr *lbound, *nindex;
2636 gfc_expr *loopvar;
7474dcc1
PT		 2637
2638 loopvar = gfc_copy_expr (index[i_index]);
2639
f1abbf69
TK		 2640 if (ar->stride[i])
2641 {
2642 gfc_expr *tmp;
2643
2644 tmp = gfc_copy_expr(ar->stride[i]);
2645 if (tmp->ts.kind != gfc_index_integer_kind)
2646 {
2647 gfc_typespec ts;
2648 gfc_clear_ts (&ts);
2649 ts.type = BT_INTEGER;
2650 ts.kind = gfc_index_integer_kind;
2651 gfc_convert_type (tmp, &ts, 2);
2652 }
2653 nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
2654 }
2655 else
2656 nindex = loopvar;
7474dcc1 2657
f1abbf69
TK		 2658 /* Calculate the lower bound of the expression. */
2659 if (ar->start[i])
2660 {
2661 lbound = gfc_copy_expr (ar->start[i]);
2662 if (lbound->ts.kind != gfc_index_integer_kind)
2663 {
2664 gfc_typespec ts;
2665 gfc_clear_ts (&ts);
2666 ts.type = BT_INTEGER;
2667 ts.kind = gfc_index_integer_kind;
2668 gfc_convert_type (lbound, &ts, 2);
2669
2670 }
2671 }
2672 else
2673 {
7fc67fcb
TK		 2674 gfc_expr *lbound_e;
2675 gfc_ref *ref;
2676
2677 lbound_e = gfc_copy_expr (e_in);
2678
2679 for (ref = lbound_e->ref; ref; ref = ref->next)
2680 if (ref->type == REF_ARRAY
2681 && (ref->u.ar.type == AR_FULL
2682 || ref->u.ar.type == AR_SECTION))
2683 break;
2684
2685 if (ref->next)
2686 {
2687 gfc_free_ref_list (ref->next);
2688 ref->next = NULL;
2689 }
2690
f1abbf69
TK		 2691 if (!was_fullref)
2692 {
2693 /* Look at full individual sections, like a(:). The first index
2694 is the lbound of a full ref. */
7fc67fcb 2695 int j;
f1abbf69
TK		 2696 gfc_array_ref *ar;
2697
7fc67fcb 2698 ar = &ref->u.ar;
f1abbf69 2699 ar->type = AR_FULL;
7fc67fcb
TK		 2700 for (j = 0; j < ar->dimen; j++)
2701 {
2702 gfc_free_expr (ar->start[j]);
2703 ar->start[j] = NULL;
2704 gfc_free_expr (ar->end[j]);
2705 ar->end[j] = NULL;
2706 gfc_free_expr (ar->stride[j]);
2707 ar->stride[j] = NULL;
2708 }
2709
2710 /* We have to get rid of the shape, if there is one. Do
2711 so by freeing it and calling gfc_resolve to rebuild
2712 it, if necessary. */
2713
2714 if (lbound_e->shape)
2715 gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
2716
2717 lbound_e->rank = ar->dimen;
2718 gfc_resolve_expr (lbound_e);
f1abbf69 2719 }
7fc67fcb
TK		 2720 lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
2721 i + 1);
2722 gfc_free_expr (lbound_e);
f1abbf69 2723 }
7474dcc1 2724
f1abbf69
TK		 2725 ar->dimen_type[i] = DIMEN_ELEMENT;
2726
2727 gfc_free_expr (ar->start[i]);
2728 ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
7474dcc1 2729
f1abbf69
TK		 2730 gfc_free_expr (ar->end[i]);
2731 ar->end[i] = NULL;
2732 gfc_free_expr (ar->stride[i]);
2733 ar->stride[i] = NULL;
2734 gfc_simplify_expr (ar->start[i], 0);
2735 }
2736 else if (was_fullref)
2737 {
2738 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2739 }
2740 i_index ++;
2741 }
2742 }
7fc67fcb 2743
f1abbf69
TK		 2744 return e;
2745}
2746
7e269fe8
TK		 2747/* Helper function to check for a dimen vector as subscript. */
2748
2749static bool
2750has_dimen_vector_ref (gfc_expr *e)
2751{
2752 gfc_array_ref *ar;
2753 int i;
2754
2755 ar = gfc_find_array_ref (e);
2756 gcc_assert (ar);
2757 if (ar->type == AR_FULL)
2758 return false;
2759
2760 for (i=0; i<ar->dimen; i++)
2761 if (ar->dimen_type[i] == DIMEN_VECTOR)
2762 return true;
2763
2764 return false;
2765}
f1abbf69 2766
c39d5e4a
TK		 2767/* If handed an expression of the form
2768
094773e8 2769 TRANSPOSE(CONJG(A))
c39d5e4a
TK		 2770
2771 check if A can be handled by matmul and return if there is an uneven number
2772 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2773 otherwise. The caller has to check for the correct rank. */
2774
2775static gfc_expr*
094773e8 2776check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
c39d5e4a
TK		 2777{
2778 *conjg = false;
094773e8 2779 *transpose = false;
c39d5e4a
TK		 2780
2781 do
2782 {
2783 if (e->expr_type == EXPR_VARIABLE)
2784 {
2785 gcc_assert (e->rank == 1 || e->rank == 2);
2786 return e;
2787 }
2788 else if (e->expr_type == EXPR_FUNCTION)
2789 {
2790 if (e->value.function.isym == NULL)
2791 return NULL;
2792
2793 if (e->value.function.isym->id == GFC_ISYM_CONJG)
2794 *conjg = !*conjg;
094773e8
TK		 2795 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
2796 *transpose = !*transpose;
c39d5e4a
TK		 2797 else return NULL;
2798 }
2799 else
2800 return NULL;
2801
2802 e = e->value.function.actual->expr;
2803 }
2804 while(1);
2805
2806 return NULL;
2807}
2808
f1abbf69
TK		 2809/* Inline assignments of the form c = matmul(a,b).
2810 Handle only the cases currently where b and c are rank-two arrays.
2811
2812 This basically translates the code to
2813
2814 BLOCK
2815 integer i,j,k
2816 c = 0
2817 do j=0, size(b,2)-1
2818 do k=0, size(a, 2)-1
2819 do i=0, size(a, 1)-1
2820 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2821 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2822 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2823 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2824 end do
2825 end do
2826 end do
2827 END BLOCK
7474dcc1 2828
f1abbf69
TK		 2829*/
2830
2831static int
2832inline_matmul_assign (gfc_code **c, int *walk_subtrees,
2833 void *data ATTRIBUTE_UNUSED)
2834{
2835 gfc_code *co = *c;
2836 gfc_expr *expr1, *expr2;
2837 gfc_expr *matrix_a, *matrix_b;
2838 gfc_actual_arglist *a, *b;
2839 gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
2840 gfc_expr *zero_e;
2841 gfc_expr *u1, *u2, *u3;
2842 gfc_expr *list[2];
2843 gfc_expr *ascalar, *bscalar, *cscalar;
2844 gfc_expr *mult;
2845 gfc_expr *var_1, *var_2, *var_3;
2846 gfc_expr *zero;
2847 gfc_namespace *ns;
2848 gfc_intrinsic_op op_times, op_plus;
2849 enum matrix_case m_case;
2850 int i;
2851 gfc_code *if_limit = NULL;
2852 gfc_code **next_code_point;
094773e8 2853 bool conjg_a, conjg_b, transpose_a, transpose_b;
f1abbf69
TK		 2854
2855 if (co->op != EXEC_ASSIGN)
2856 return 0;
2857
fd42eed8
TK		 2858 if (in_where)
2859 return 0;
2860
56a3d28b
JJ		 2861 /* For now don't do anything in OpenMP workshare, it confuses
2862 its translation, which expects only the allowed statements in there.
2863 We should figure out how to parallelize this eventually. */
2864 if (in_omp_workshare)
2865 return 0;
2866
f1abbf69
TK		 2867 expr1 = co->expr1;
2868 expr2 = co->expr2;
2869 if (expr2->expr_type != EXPR_FUNCTION
2870 || expr2->value.function.isym == NULL
2871 || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
2872 return 0;
2873
2874 current_code = c;
2875 inserted_block = NULL;
2876 changed_statement = NULL;
2877
2878 a = expr2->value.function.actual;
094773e8
TK		 2879 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
2880 if (transpose_a || matrix_a == NULL)
c39d5e4a 2881 return 0;
f1abbf69 2882
c39d5e4a 2883 b = a->next;
094773e8 2884 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
c39d5e4a 2885 if (matrix_b == NULL)
f1abbf69
TK		 2886 return 0;
2887
7e269fe8
TK		 2888 if (has_dimen_vector_ref (expr1) || has_dimen_vector_ref (matrix_a)
2889 || has_dimen_vector_ref (matrix_b))
2890 return 0;
2891
c39d5e4a
TK		 2892 /* We do not handle data dependencies yet. */
2893 if (gfc_check_dependency (expr1, matrix_a, true)
2894 || gfc_check_dependency (expr1, matrix_b, true))
2895 return 0;
2896
f1abbf69 2897 if (matrix_a->rank == 2)
094773e8
TK		 2898 {
2899 if (matrix_b->rank == 1)
2900 m_case = A2B1;
2901 else
2902 {
2903 if (transpose_b)
2904 m_case = A2B2T;
2905 else
2906 m_case = A2B2;
2907 }
2908 }
f1abbf69 2909 else
094773e8
TK		 2910 {
2911 /* Vector * Transpose(B) not handled yet. */
2912 if (transpose_b)
2913 m_case = none;
2914 else
2915 m_case = A1B2;
2916 }
f1abbf69 2917
094773e8
TK		 2918 if (m_case == none)
2919 return 0;
f1abbf69
TK		 2920
2921 ns = insert_block ();
2922
2923 /* Assign the type of the zero expression for initializing the resulting
2924 array, and the expression (+ and * for real, integer and complex;
2925 .and. and .or for logical. */
2926
2927 switch(expr1->ts.type)
2928 {
2929 case BT_INTEGER:
2930 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
2931 op_times = INTRINSIC_TIMES;
2932 op_plus = INTRINSIC_PLUS;
2933 break;
2934
2935 case BT_LOGICAL:
2936 op_times = INTRINSIC_AND;
2937 op_plus = INTRINSIC_OR;
2938 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
2939 0);
2940 break;
2941 case BT_REAL:
2942 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
2943 &expr1->where);
2944 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
2945 op_times = INTRINSIC_TIMES;
2946 op_plus = INTRINSIC_PLUS;
2947 break;
2948
2949 case BT_COMPLEX:
2950 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
2951 &expr1->where);
2952 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
2953 op_times = INTRINSIC_TIMES;
2954 op_plus = INTRINSIC_PLUS;
2955
2956 break;
2957
2958 default:
2959 gcc_unreachable();
2960 }
2961
2962 current_code = &ns->code;
2963
2964 /* Freeze the references, keeping track of how many temporary variables were
2965 created. */
2966 n_vars = 0;
2967 freeze_references (matrix_a);
2968 freeze_references (matrix_b);
2969 freeze_references (expr1);
2970
2971 if (n_vars == 0)
2972 next_code_point = current_code;
2973 else
2974 {
2975 next_code_point = &ns->code;
2976 for (i=0; i<n_vars; i++)
2977 next_code_point = &(*next_code_point)->next;
2978 }
2979
2980 /* Take care of the inline flag. If the limit check evaluates to a
2981 constant, dead code elimination will eliminate the unneeded branch. */
2982
2983 if (m_case == A2B2 && flag_inline_matmul_limit > 0)
2984 {
2985 if_limit = inline_limit_check (matrix_a, matrix_b, m_case);
2986
2987 /* Insert the original statement into the else branch. */
2988 if_limit->block->block->next = co;
2989 co->next = NULL;
2990
2991 /* ... and the new ones go into the original one. */
2992 *next_code_point = if_limit;
2993 next_code_point = &if_limit->block->next;
2994 }
2995
2996 assign_zero = XCNEW (gfc_code);
2997 assign_zero->op = EXEC_ASSIGN;
2998 assign_zero->loc = co->loc;
2999 assign_zero->expr1 = gfc_copy_expr (expr1);
3000 assign_zero->expr2 = zero_e;
3001
3002 /* Handle the reallocation, if needed. */
3003 if (flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1))
3004 {
3005 gfc_code *lhs_alloc;
3006
3007 /* Only need to check a single dimension for the A2B2 case for
3008 bounds checking, the rest will be allocated. */
3009
3010 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS && m_case == A2B2)
3011 {
3012 gfc_code *test;
3013 gfc_expr *a2, *b1;
3014
3015 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
3016 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3017 test = runtime_error_ne (b1, a2, "Dimension of array B incorrect "
3018 "in MATMUL intrinsic: Is %ld, should be %ld");
3019 *next_code_point = test;
3020 next_code_point = &test->next;
3021 }
3022
3023
3024 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
3025
3026 *next_code_point = lhs_alloc;
3027 next_code_point = &lhs_alloc->next;
3028
3029 }
3030 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3031 {
3032 gfc_code *test;
3033 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
3034
3035 if (m_case == A2B2 || m_case == A2B1)
3036 {
3037 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
3038 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3039 test = runtime_error_ne (b1, a2, "Dimension of array B incorrect "
3040 "in MATMUL intrinsic: Is %ld, should be %ld");
3041 *next_code_point = test;
3042 next_code_point = &test->next;
3043
3044 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
3045 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
3046
3047 if (m_case == A2B2)
3048 test = runtime_error_ne (c1, a1, "Incorrect extent in return array in "
3049 "MATMUL intrinsic for dimension 1: "
3050 "is %ld, should be %ld");
3051 else if (m_case == A2B1)
3052 test = runtime_error_ne (c1, a1, "Incorrect extent in return array in "
3053 "MATMUL intrinsic: "
3054 "is %ld, should be %ld");
3055
3056
3057 *next_code_point = test;
3058 next_code_point = &test->next;
3059 }
3060 else if (m_case == A1B2)
3061 {
3062 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
3063 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3064 test = runtime_error_ne (b1, a1, "Dimension of array B incorrect "
3065 "in MATMUL intrinsic: Is %ld, should be %ld");
3066 *next_code_point = test;
3067 next_code_point = &test->next;
3068
3069 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
3070 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
3071
3072 test = runtime_error_ne (c1, b2, "Incorrect extent in return array in "
3073 "MATMUL intrinsic: "
3074 "is %ld, should be %ld");
3075
3076 *next_code_point = test;
3077 next_code_point = &test->next;
3078 }
3079
3080 if (m_case == A2B2)
3081 {
3082 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
3083 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
3084 test = runtime_error_ne (c2, b2, "Incorrect extent in return array in "
3085 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3086
3087 *next_code_point = test;
3088 next_code_point = &test->next;
3089 }
094773e8
TK		 3090
3091 if (m_case == A2B2T)
3092 {
3093 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
3094 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
3095 test = runtime_error_ne (c1, a1, "Incorrect extent in return array in "
3096 "MATMUL intrinsic for dimension 1: "
3097 "is %ld, should be %ld");
3098
3099 *next_code_point = test;
3100 next_code_point = &test->next;
3101
3102 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
3103 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
3104 test = runtime_error_ne (c2, b1, "Incorrect extent in return array in "
3105 "MATMUL intrinsic for dimension 2: "
3106 "is %ld, should be %ld");
3107 *next_code_point = test;
3108 next_code_point = &test->next;
3109
3110 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
3111 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
3112
3113 test = runtime_error_ne (b2, a2, "Incorrect extent in argument B in "
3114 "MATMUL intrnisic for dimension 2: "
3115 "is %ld, should be %ld");
3116 *next_code_point = test;
3117 next_code_point = &test->next;
3118
3119 }
f1abbf69
TK		 3120 }
3121
3122 *next_code_point = assign_zero;
3123
3124 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
3125
3126 assign_matmul = XCNEW (gfc_code);
3127 assign_matmul->op = EXEC_ASSIGN;
3128 assign_matmul->loc = co->loc;
3129
3130 /* Get the bounds for the loops, create them and create the scalarized
3131 expressions. */
3132
3133 switch (m_case)
3134 {
3135 case A2B2:
3136 inline_limit_check (matrix_a, matrix_b, m_case);
3137
3138 u1 = get_size_m1 (matrix_b, 2);
3139 u2 = get_size_m1 (matrix_a, 2);
3140 u3 = get_size_m1 (matrix_a, 1);
3141
3142 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3143 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3144 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
3145
3146 do_1->block->next = do_2;
3147 do_2->block->next = do_3;
3148 do_3->block->next = assign_matmul;
3149
3150 var_1 = do_1->ext.iterator->var;
3151 var_2 = do_2->ext.iterator->var;
3152 var_3 = do_3->ext.iterator->var;
3153
3154 list[0] = var_3;
3155 list[1] = var_1;
7fc67fcb 3156 cscalar = scalarized_expr (co->expr1, list, 2);
f1abbf69
TK		 3157
3158 list[0] = var_3;
3159 list[1] = var_2;
7fc67fcb 3160 ascalar = scalarized_expr (matrix_a, list, 2);
f1abbf69
TK		 3161
3162 list[0] = var_2;
3163 list[1] = var_1;
7fc67fcb 3164 bscalar = scalarized_expr (matrix_b, list, 2);
f1abbf69
TK		 3165
3166 break;
3167
094773e8
TK		 3168 case A2B2T:
3169 inline_limit_check (matrix_a, matrix_b, m_case);
3170
3171 u1 = get_size_m1 (matrix_b, 1);
3172 u2 = get_size_m1 (matrix_a, 2);
3173 u3 = get_size_m1 (matrix_a, 1);
3174
3175 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3176 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3177 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
3178
3179 do_1->block->next = do_2;
3180 do_2->block->next = do_3;
3181 do_3->block->next = assign_matmul;
3182
3183 var_1 = do_1->ext.iterator->var;
3184 var_2 = do_2->ext.iterator->var;
3185 var_3 = do_3->ext.iterator->var;
3186
3187 list[0] = var_3;
3188 list[1] = var_1;
3189 cscalar = scalarized_expr (co->expr1, list, 2);
3190
3191 list[0] = var_3;
3192 list[1] = var_2;
3193 ascalar = scalarized_expr (matrix_a, list, 2);
3194
3195 list[0] = var_1;
3196 list[1] = var_2;
3197 bscalar = scalarized_expr (matrix_b, list, 2);
3198
3199 break;
3200
f1abbf69
TK		 3201 case A2B1:
3202 u1 = get_size_m1 (matrix_b, 1);
3203 u2 = get_size_m1 (matrix_a, 1);
3204
3205 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3206 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3207
3208 do_1->block->next = do_2;
3209 do_2->block->next = assign_matmul;
3210
3211 var_1 = do_1->ext.iterator->var;
3212 var_2 = do_2->ext.iterator->var;
3213
3214 list[0] = var_2;
7fc67fcb 3215 cscalar = scalarized_expr (co->expr1, list, 1);
f1abbf69
TK		 3216
3217 list[0] = var_2;
3218 list[1] = var_1;
7fc67fcb 3219 ascalar = scalarized_expr (matrix_a, list, 2);
f1abbf69
TK		 3220
3221 list[0] = var_1;
7fc67fcb 3222 bscalar = scalarized_expr (matrix_b, list, 1);
f1abbf69
TK		 3223
3224 break;
3225
3226 case A1B2:
3227 u1 = get_size_m1 (matrix_b, 2);
3228 u2 = get_size_m1 (matrix_a, 1);
3229
3230 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
3231 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
3232
3233 do_1->block->next = do_2;
3234 do_2->block->next = assign_matmul;
3235
3236 var_1 = do_1->ext.iterator->var;
3237 var_2 = do_2->ext.iterator->var;
3238
3239 list[0] = var_1;
7fc67fcb 3240 cscalar = scalarized_expr (co->expr1, list, 1);
f1abbf69
TK		 3241
3242 list[0] = var_2;
7fc67fcb 3243 ascalar = scalarized_expr (matrix_a, list, 1);
f1abbf69
TK		 3244
3245 list[0] = var_2;
3246 list[1] = var_1;
7fc67fcb 3247 bscalar = scalarized_expr (matrix_b, list, 2);
f1abbf69
TK		 3248
3249 break;
3250
3251 default:
3252 gcc_unreachable();
3253 }
3254
c39d5e4a
TK		 3255 if (conjg_a)
3256 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
3257 matrix_a->where, 1, ascalar);
3258
3259 if (conjg_b)
7474dcc1 3260 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
c39d5e4a
TK		 3261 matrix_b->where, 1, bscalar);
3262
f1abbf69
TK		 3263 /* First loop comes after the zero assignment. */
3264 assign_zero->next = do_1;
3265
3266 /* Build the assignment expression in the loop. */
3267 assign_matmul->expr1 = gfc_copy_expr (cscalar);
3268
3269 mult = get_operand (op_times, ascalar, bscalar);
3270 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
3271
3272 /* If we don't want to keep the original statement around in
3273 the else branch, we can free it. */
3274
3275 if (if_limit == NULL)
3276 gfc_free_statements(co);
3277 else
3278 co->next = NULL;
3279
3280 gfc_free_expr (zero);
3281 *walk_subtrees = 0;
3282 return 0;
3283}
305a35da 3284
4d42b5cd
JJ		 3285#define WALK_SUBEXPR(NODE) \
3286 do \
3287 { \
3288 result = gfc_expr_walker (&(NODE), exprfn, data); \
3289 if (result) \
3290 return result; \
3291 } \
3292 while (0)
3293#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
601d98be 3294
4d42b5cd
JJ		 3295/* Walk expression *E, calling EXPRFN on each expression in it. */
3296
3297int
3298gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
601d98be 3299{
4d42b5cd
JJ		 3300 while (*e)
3301 {
3302 int walk_subtrees = 1;
3303 gfc_actual_arglist *a;
46f19baf
TK		 3304 gfc_ref *r;
3305 gfc_constructor *c;
3306
4d42b5cd
JJ		 3307 int result = exprfn (e, &walk_subtrees, data);
3308 if (result)
3309 return result;
3310 if (walk_subtrees)
3311 switch ((*e)->expr_type)
3312 {
3313 case EXPR_OP:
3314 WALK_SUBEXPR ((*e)->value.op.op1);
3315 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
3316 break;
3317 case EXPR_FUNCTION:
3318 for (a = (*e)->value.function.actual; a; a = a->next)
3319 WALK_SUBEXPR (a->expr);
3320 break;
3321 case EXPR_COMPCALL:
3322 case EXPR_PPC:
3323 WALK_SUBEXPR ((*e)->value.compcall.base_object);
3324 for (a = (*e)->value.compcall.actual; a; a = a->next)
3325 WALK_SUBEXPR (a->expr);
3326 break;
46f19baf
TK		 3327
3328 case EXPR_STRUCTURE:
3329 case EXPR_ARRAY:
3330 for (c = gfc_constructor_first ((*e)->value.constructor); c;
3331 c = gfc_constructor_next (c))
3332 {
8144d290
TK		 3333 if (c->iterator == NULL)
3334 WALK_SUBEXPR (c->expr);
3335 else
46f19baf 3336 {
8144d290
TK		 3337 iterator_level ++;
3338 WALK_SUBEXPR (c->expr);
3339 iterator_level --;
46f19baf
TK		 3340 WALK_SUBEXPR (c->iterator->var);
3341 WALK_SUBEXPR (c->iterator->start);
3342 WALK_SUBEXPR (c->iterator->end);
3343 WALK_SUBEXPR (c->iterator->step);
3344 }
3345 }
3346
3347 if ((*e)->expr_type != EXPR_ARRAY)
3348 break;
3349
3350 /* Fall through to the variable case in order to walk the
dd5a833e 3351 reference. */
81fea426 3352 gcc_fallthrough ();
46f19baf 3353
1151446c 3354 case EXPR_SUBSTRING:
46f19baf
TK		 3355 case EXPR_VARIABLE:
3356 for (r = (*e)->ref; r; r = r->next)
3357 {
3358 gfc_array_ref *ar;
3359 int i;
3360
3361 switch (r->type)
3362 {
3363 case REF_ARRAY:
3364 ar = &r->u.ar;
3365 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
3366 {
3367 for (i=0; i< ar->dimen; i++)
3368 {
3369 WALK_SUBEXPR (ar->start[i]);
3370 WALK_SUBEXPR (ar->end[i]);
3371 WALK_SUBEXPR (ar->stride[i]);
3372 }
3373 }
3374
3375 break;
3376
3377 case REF_SUBSTRING:
3378 WALK_SUBEXPR (r->u.ss.start);
3379 WALK_SUBEXPR (r->u.ss.end);
3380 break;
3381
3382 case REF_COMPONENT:
3383 break;
3384 }
3385 }
3386
4d42b5cd
JJ		 3387 default:
3388 break;
3389 }
3390 return 0;
3391 }
3392 return 0;
3393}
601d98be 3394
4d42b5cd
JJ		 3395#define WALK_SUBCODE(NODE) \
3396 do \
3397 { \
3398 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3399 if (result) \
3400 return result; \
3401 } \
3402 while (0)
3403
3404/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3405 on each expression in it. If any of the hooks returns non-zero, that
3406 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3407 no subcodes or subexpressions are traversed. */
3408
3409int
3410gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
3411 void *data)
3412{
3413 for (; *c; c = &(*c)->next)
601d98be 3414 {
4d42b5cd
JJ		 3415 int walk_subtrees = 1;
3416 int result = codefn (c, &walk_subtrees, data);
3417 if (result)
3418 return result;
bc81f559 3419
4d42b5cd
JJ		 3420 if (walk_subtrees)
3421 {
3422 gfc_code *b;
bc81f559 3423 gfc_actual_arglist *a;
82358e09 3424 gfc_code *co;
930d4d4e 3425 gfc_association_list *alist;
e07e39f6 3426 bool saved_in_omp_workshare;
fd42eed8 3427 bool saved_in_where;
82358e09
TK		 3428
3429 /* There might be statement insertions before the current code,
3430 which must not affect the expression walker. */
3431
3432 co = *c;
e07e39f6 3433 saved_in_omp_workshare = in_omp_workshare;
fd42eed8 3434 saved_in_where = in_where;
bc81f559 3435
82358e09 3436 switch (co->op)
4d42b5cd 3437 {
930d4d4e
TK		 3438
3439 case EXEC_BLOCK:
3440 WALK_SUBCODE (co->ext.block.ns->code);
e3f9e757
TK		 3441 if (co->ext.block.assoc)
3442 {
3443 bool saved_in_assoc_list = in_assoc_list;
3444
3445 in_assoc_list = true;
3446 for (alist = co->ext.block.assoc; alist; alist = alist->next)
3447 WALK_SUBEXPR (alist->target);
3448
3449 in_assoc_list = saved_in_assoc_list;
3450 }
3451
930d4d4e
TK		 3452 break;
3453
4d42b5cd 3454 case EXEC_DO:
305a35da 3455 doloop_level ++;
82358e09
TK		 3456 WALK_SUBEXPR (co->ext.iterator->var);
3457 WALK_SUBEXPR (co->ext.iterator->start);
3458 WALK_SUBEXPR (co->ext.iterator->end);
3459 WALK_SUBEXPR (co->ext.iterator->step);
4d42b5cd 3460 break;
bc81f559 3461
fd42eed8
TK		 3462 case EXEC_WHERE:
3463 in_where = true;
3464 break;
3465
bc81f559
TK		 3466 case EXEC_CALL:
3467 case EXEC_ASSIGN_CALL:
82358e09 3468 for (a = co->ext.actual; a; a = a->next)
bc81f559
TK		 3469 WALK_SUBEXPR (a->expr);
3470 break;
3471
3472 case EXEC_CALL_PPC:
82358e09
TK		 3473 WALK_SUBEXPR (co->expr1);
3474 for (a = co->ext.actual; a; a = a->next)
bc81f559
TK		 3475 WALK_SUBEXPR (a->expr);
3476 break;
3477
4d42b5cd 3478 case EXEC_SELECT:
82358e09
TK		 3479 WALK_SUBEXPR (co->expr1);
3480 for (b = co->block; b; b = b->block)
4d42b5cd
JJ		 3481 {
3482 gfc_case *cp;
29a63d67 3483 for (cp = b->ext.block.case_list; cp; cp = cp->next)
4d42b5cd
JJ		 3484 {
3485 WALK_SUBEXPR (cp->low);
3486 WALK_SUBEXPR (cp->high);
3487 }
3488 WALK_SUBCODE (b->next);
3489 }
3490 continue;
bc81f559 3491
4d42b5cd
JJ		 3492 case EXEC_ALLOCATE:
3493 case EXEC_DEALLOCATE:
3494 {
3495 gfc_alloc *a;
82358e09 3496 for (a = co->ext.alloc.list; a; a = a->next)
4d42b5cd
JJ		 3497 WALK_SUBEXPR (a->expr);
3498 break;
3499 }
bc81f559 3500
4d42b5cd 3501 case EXEC_FORALL:
8c6a85e3 3502 case EXEC_DO_CONCURRENT:
4d42b5cd
JJ		 3503 {
3504 gfc_forall_iterator *fa;
82358e09 3505 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
4d42b5cd
JJ		 3506 {
3507 WALK_SUBEXPR (fa->var);
3508 WALK_SUBEXPR (fa->start);
3509 WALK_SUBEXPR (fa->end);
3510 WALK_SUBEXPR (fa->stride);
3511 }
2855325f
TK		 3512 if (co->op == EXEC_FORALL)
3513 forall_level ++;
4d42b5cd
JJ		 3514 break;
3515 }
bc81f559 3516
4d42b5cd 3517 case EXEC_OPEN:
82358e09
TK		 3518 WALK_SUBEXPR (co->ext.open->unit);
3519 WALK_SUBEXPR (co->ext.open->file);
3520 WALK_SUBEXPR (co->ext.open->status);
3521 WALK_SUBEXPR (co->ext.open->access);
3522 WALK_SUBEXPR (co->ext.open->form);
3523 WALK_SUBEXPR (co->ext.open->recl);
3524 WALK_SUBEXPR (co->ext.open->blank);
3525 WALK_SUBEXPR (co->ext.open->position);
3526 WALK_SUBEXPR (co->ext.open->action);
3527 WALK_SUBEXPR (co->ext.open->delim);
3528 WALK_SUBEXPR (co->ext.open->pad);
3529 WALK_SUBEXPR (co->ext.open->iostat);
3530 WALK_SUBEXPR (co->ext.open->iomsg);
3531 WALK_SUBEXPR (co->ext.open->convert);
3532 WALK_SUBEXPR (co->ext.open->decimal);
3533 WALK_SUBEXPR (co->ext.open->encoding);
3534 WALK_SUBEXPR (co->ext.open->round);
3535 WALK_SUBEXPR (co->ext.open->sign);
3536 WALK_SUBEXPR (co->ext.open->asynchronous);
3537 WALK_SUBEXPR (co->ext.open->id);
3538 WALK_SUBEXPR (co->ext.open->newunit);
4d42b5cd 3539 break;
bc81f559 3540
4d42b5cd 3541 case EXEC_CLOSE:
82358e09
TK		 3542 WALK_SUBEXPR (co->ext.close->unit);
3543 WALK_SUBEXPR (co->ext.close->status);
3544 WALK_SUBEXPR (co->ext.close->iostat);
3545 WALK_SUBEXPR (co->ext.close->iomsg);
4d42b5cd 3546 break;
bc81f559 3547
4d42b5cd
JJ		 3548 case EXEC_BACKSPACE:
3549 case EXEC_ENDFILE:
3550 case EXEC_REWIND:
3551 case EXEC_FLUSH:
82358e09
TK		 3552 WALK_SUBEXPR (co->ext.filepos->unit);
3553 WALK_SUBEXPR (co->ext.filepos->iostat);
3554 WALK_SUBEXPR (co->ext.filepos->iomsg);
4d42b5cd 3555 break;
bc81f559 3556
4d42b5cd 3557 case EXEC_INQUIRE:
82358e09
TK		 3558 WALK_SUBEXPR (co->ext.inquire->unit);
3559 WALK_SUBEXPR (co->ext.inquire->file);
3560 WALK_SUBEXPR (co->ext.inquire->iomsg);
3561 WALK_SUBEXPR (co->ext.inquire->iostat);
3562 WALK_SUBEXPR (co->ext.inquire->exist);
3563 WALK_SUBEXPR (co->ext.inquire->opened);
3564 WALK_SUBEXPR (co->ext.inquire->number);
3565 WALK_SUBEXPR (co->ext.inquire->named);
3566 WALK_SUBEXPR (co->ext.inquire->name);
3567 WALK_SUBEXPR (co->ext.inquire->access);
3568 WALK_SUBEXPR (co->ext.inquire->sequential);
3569 WALK_SUBEXPR (co->ext.inquire->direct);
3570 WALK_SUBEXPR (co->ext.inquire->form);
3571 WALK_SUBEXPR (co->ext.inquire->formatted);
3572 WALK_SUBEXPR (co->ext.inquire->unformatted);
3573 WALK_SUBEXPR (co->ext.inquire->recl);
3574 WALK_SUBEXPR (co->ext.inquire->nextrec);
3575 WALK_SUBEXPR (co->ext.inquire->blank);
3576 WALK_SUBEXPR (co->ext.inquire->position);
3577 WALK_SUBEXPR (co->ext.inquire->action);
3578 WALK_SUBEXPR (co->ext.inquire->read);
3579 WALK_SUBEXPR (co->ext.inquire->write);
3580 WALK_SUBEXPR (co->ext.inquire->readwrite);
3581 WALK_SUBEXPR (co->ext.inquire->delim);
3582 WALK_SUBEXPR (co->ext.inquire->encoding);
3583 WALK_SUBEXPR (co->ext.inquire->pad);
3584 WALK_SUBEXPR (co->ext.inquire->iolength);
3585 WALK_SUBEXPR (co->ext.inquire->convert);
3586 WALK_SUBEXPR (co->ext.inquire->strm_pos);
3587 WALK_SUBEXPR (co->ext.inquire->asynchronous);
3588 WALK_SUBEXPR (co->ext.inquire->decimal);
3589 WALK_SUBEXPR (co->ext.inquire->pending);
3590 WALK_SUBEXPR (co->ext.inquire->id);
3591 WALK_SUBEXPR (co->ext.inquire->sign);
3592 WALK_SUBEXPR (co->ext.inquire->size);
3593 WALK_SUBEXPR (co->ext.inquire->round);
4d42b5cd 3594 break;
bc81f559 3595
4d42b5cd 3596 case EXEC_WAIT:
82358e09
TK		 3597 WALK_SUBEXPR (co->ext.wait->unit);
3598 WALK_SUBEXPR (co->ext.wait->iostat);
3599 WALK_SUBEXPR (co->ext.wait->iomsg);
3600 WALK_SUBEXPR (co->ext.wait->id);
4d42b5cd 3601 break;
bc81f559 3602
4d42b5cd
JJ		 3603 case EXEC_READ:
3604 case EXEC_WRITE:
82358e09
TK		 3605 WALK_SUBEXPR (co->ext.dt->io_unit);
3606 WALK_SUBEXPR (co->ext.dt->format_expr);
3607 WALK_SUBEXPR (co->ext.dt->rec);
3608 WALK_SUBEXPR (co->ext.dt->advance);
3609 WALK_SUBEXPR (co->ext.dt->iostat);
3610 WALK_SUBEXPR (co->ext.dt->size);
3611 WALK_SUBEXPR (co->ext.dt->iomsg);
3612 WALK_SUBEXPR (co->ext.dt->id);
3613 WALK_SUBEXPR (co->ext.dt->pos);
3614 WALK_SUBEXPR (co->ext.dt->asynchronous);
3615 WALK_SUBEXPR (co->ext.dt->blank);
3616 WALK_SUBEXPR (co->ext.dt->decimal);
3617 WALK_SUBEXPR (co->ext.dt->delim);
3618 WALK_SUBEXPR (co->ext.dt->pad);
3619 WALK_SUBEXPR (co->ext.dt->round);
3620 WALK_SUBEXPR (co->ext.dt->sign);
3621 WALK_SUBEXPR (co->ext.dt->extra_comma);
4d42b5cd 3622 break;
bc81f559 3623
4d42b5cd
JJ		 3624 case EXEC_OMP_PARALLEL:
3625 case EXEC_OMP_PARALLEL_DO:
dd2fc525 3626 case EXEC_OMP_PARALLEL_DO_SIMD:
4d42b5cd 3627 case EXEC_OMP_PARALLEL_SECTIONS:
e07e39f6
TK		 3628
3629 in_omp_workshare = false;
3630
3631 /* This goto serves as a shortcut to avoid code
3632 duplication or a larger if or switch statement. */
3633 goto check_omp_clauses;
7474dcc1 3634
e07e39f6 3635 case EXEC_OMP_WORKSHARE:
4d42b5cd 3636 case EXEC_OMP_PARALLEL_WORKSHARE:
e07e39f6
TK		 3637
3638 in_omp_workshare = true;
3639
3640 /* Fall through */
f014c653
JJ		 3641
3642 case EXEC_OMP_DISTRIBUTE:
3643 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3644 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3645 case EXEC_OMP_DISTRIBUTE_SIMD:
e07e39f6 3646 case EXEC_OMP_DO:
dd2fc525 3647 case EXEC_OMP_DO_SIMD:
4d42b5cd
JJ		 3648 case EXEC_OMP_SECTIONS:
3649 case EXEC_OMP_SINGLE:
4d42b5cd 3650 case EXEC_OMP_END_SINGLE:
dd2fc525 3651 case EXEC_OMP_SIMD:
f014c653
JJ		 3652 case EXEC_OMP_TARGET:
3653 case EXEC_OMP_TARGET_DATA:
3654 case EXEC_OMP_TARGET_TEAMS:
3655 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3656 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3657 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3658 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3659 case EXEC_OMP_TARGET_UPDATE:
4d42b5cd 3660 case EXEC_OMP_TASK:
f014c653
JJ		 3661 case EXEC_OMP_TEAMS:
3662 case EXEC_OMP_TEAMS_DISTRIBUTE:
3663 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3664 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3665 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
e07e39f6
TK		 3666
3667 /* Come to this label only from the
3668 EXEC_OMP_PARALLEL_* cases above. */
3669
3670 check_omp_clauses:
3671
82358e09 3672 if (co->ext.omp_clauses)
4d42b5cd 3673 {
f014c653
JJ		 3674 gfc_omp_namelist *n;
3675 static int list_types[]
3676 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
3677 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
3678 size_t idx;
82358e09 3679 WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
20906c66 3680 WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
82358e09
TK		 3681 WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
3682 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
dd2fc525
JJ		 3683 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
3684 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
f014c653
JJ		 3685 WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
3686 WALK_SUBEXPR (co->ext.omp_clauses->device);
3687 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
3688 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
3689 for (idx = 0;
3690 idx < sizeof (list_types) / sizeof (list_types[0]);
3691 idx++)
3692 for (n = co->ext.omp_clauses->lists[list_types[idx]];
3693 n; n = n->next)
3694 WALK_SUBEXPR (n->expr);
4d42b5cd
JJ		 3695 }
3696 break;
3697 default:
3698 break;
3699 }
bc81f559 3700
82358e09
TK		 3701 WALK_SUBEXPR (co->expr1);
3702 WALK_SUBEXPR (co->expr2);
3703 WALK_SUBEXPR (co->expr3);
5493aa17 3704 WALK_SUBEXPR (co->expr4);
82358e09 3705 for (b = co->block; b; b = b->block)
4d42b5cd
JJ		 3706 {
3707 WALK_SUBEXPR (b->expr1);
3708 WALK_SUBEXPR (b->expr2);
3709 WALK_SUBCODE (b->next);
3710 }
2855325f
TK		 3711
3712 if (co->op == EXEC_FORALL)
3713 forall_level --;
3714
305a35da
TK		 3715 if (co->op == EXEC_DO)
3716 doloop_level --;
3717
e07e39f6 3718 in_omp_workshare = saved_in_omp_workshare;
fd42eed8 3719 in_where = saved_in_where;
4d42b5cd 3720 }
601d98be 3721 }
4d42b5cd 3722 return 0;
601d98be 3723}
GNU Compiler Collection
This page took 2.628748 seconds and 5 git commands to generate.